



		    display.pl1                     11/15/82  1819.8rew 11/15/82  1502.6       56799



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


di: display: proc;

/* Modified: 29 November 1979 by PCK to produce tree level indented output */

dcl	display_block	entry(ptr,bit(1) aligned,bit(1) aligned,
			      bit(1) aligned,fixed bin);
dcl	display_statement	entry(ptr,bit(1) aligned,fixed bin);
dcl	display_source	entry(ptr,fixed bin);
dcl	(display_array, display_list, display_exp, display_symbol)
	 entry(ptr,fixed bin);
dcl	show_ms$pt entry(ptr);

dcl	show_statement ext entry(char(*) aligned),
	show_declaration ext entry(char(*) aligned,char(*) aligned),
	display_any_node_name ext entry(char(*) aligned,ptr,fixed bin);

dcl	ioa_		entry options(variable),
	cv_dec_		entry(char(*) aligned) returns(fixed bin),
	cu_$arg_count	entry(fixed bin(15)),
	cu_$arg_ptr	entry(fixed bin(15),ptr,fixed bin(15),fixed bin(15)),
	cu_$gen_call	entry(entry,ptr),
	cu_$arg_list_ptr	entry(ptr);

dcl	(k,tree_level) fixed bin;
dcl	(string,string2,string3) char(12) aligned;
dcl	display_stat_$brief_display bit(1) ext static;
dcl	argstring char(arglen) based(argpt);
dcl	(code,arglen) fixed bin(15),
	(ap1,argpt) pointer;


dcl	(addr,baseptr,fixed,index,min,null,ptr,substr) builtin;
dcl	program_interrupt condition;

dcl	p ptr,
	(no_dcls,sourceb,walk) bit(1) aligned,
	(i,j,n) fixed bin(15),
	(pl1_stat_$root,pl1_stat_$cur_block,pl1_stat_$cur_statement) ptr ext,
	cv_oct_ entry(char(*) aligned) returns(fixed);

dcl	disp_xeq bit(1) aligned;

%include pl1_tree_areas;
%include token_list;
%include token_types;
%include source_list;
%include nodes;

dcl	based_ptr	ptr based;

dcl	1 arglist	based,
	2 number	bit(17),
	2 filler	fixed,
	2 arg(1)	ptr;

%include block;

			/*eject*/

begin:
	disp_xeq = "0"b;

common:
	on condition(program_interrupt) goto done;
	no_dcls,
	sourceb,
	walk = "0"b;
	tree_level = 0;
	call cu_$arg_count(i);
	if i = 0 then do;
		call ioa_("display | di -options-^/^a^/^a",
"options are: root | main | cur_block | cur_statement (walk) (no_dcls) (source)",
"	   brief | long
	   token_list (_n)");
	call ioa_(
"	   source_list (_n) (min'ed with pl1_stat_$last_source)
	   arg arg# offset#
	   seg#|offset# (default seg is tree_)
	   statement file#.line#.statement#
	   dcl iden1 iden2 ... (10 max)");
		return;
		end;

	call cu_$arg_ptr(1,argpt,arglen,code);
	ap1=argpt;
	string=argstring;
	if substr(string,1,4) = "dcl " then go to show_dcl;

	if substr(string,1,8) = "brief   "
	then do;
	     display_stat_$brief_display = "1"b;
	     return;
	     end;

	if substr(string,1,8) = "long    "
	then do;
	     display_stat_$brief_display = "0"b;
	     return;
	     end;

	call cu_$arg_ptr(2,argpt,arglen,code);
	if code ^= 0 then string2=""; else string2=argstring;
	call cu_$arg_ptr(3,argpt,arglen,code);
	if code ^= 0 then string3=""; else string3=argstring;

	if substr(string,1,8) = "source_l" then go to source_list_;
	if substr(string,1,8) = "token_li" then go to token_list_;
	if substr(string,1,8) = "statemen" then go to show_stm;
	if substr(string,1,4) = "root"
	then p = pl1_stat_$root;
	else if substr(string,1,8) = "cur_bloc"
	then p = pl1_stat_$cur_block;
	else if substr(string,1,8) = "cur_stat"
	then p = pl1_stat_$cur_statement;
	else if substr(string,1,4) = "main"
	then if pl1_stat_$root ^= null then p = pl1_stat_$root -> block.son; else goto null_ptr;
	else if substr(string,1,4) = "arg "
	then do;
	     n = cv_oct_(string2);
	     p = addr(p);
	     p = ptr(p,cv_oct_(string3));
	     if n > fixed(p -> arglist.number,17)
	     then do;
		call ioa_("no arg ^d",n);
		return;
		end;
	     p = p -> arglist.arg(n) -> based_ptr;
	     end;
	else do;
	     if disp_xeq
		then p = pl1_stat_$xeq_tree_area_ptr;
		else p = pl1_stat_$root;
	     n = index(string,"|");
	     if n = 0 then p = ptr(p,cv_oct_(string));
	     else p = ptr(baseptr(cv_oct_(substr(string,1,n-1))),
	      cv_oct_(substr(string,n+1)));
	     end;

	if p = null
	then do;
null_ptr:
	     call ioa_("Pointer is null");
	     return;
	     end;

	if substr(string2,1,4) = "walk" then walk="1"b; else
	if substr(string3,1,4) = "walk" then walk="1"b;
	if substr(string2,1,8) = "no_dcls " then no_dcls="1"b; else
	if substr(string3,1,8) = "no_dcls " then no_dcls="1"b;
	if substr(string2,1,8) = "source  " then sourceb="1"b; else
	if substr(string3,1,8) = "source  " then sourceb="1"b;

	n = fixed(p -> node.type,17,0);
	if n > fixed(temporary_node,9,0) then n = 0;

	call ioa_("Displaying ^p",p);
	goto switch(n);

switch(0):
switch(7):
switch(17):
	call display_any_node_name("No display program for",p,tree_level+1);
	return;

switch(1):
	call display_block(p,walk,no_dcls,sourceb,tree_level+1);
	return;

switch(3):
switch(4):
switch(5):
switch(10):
switch(16):
switch(18):
	call display_exp(p,tree_level+1);
	return;

switch(8):
switch(9):
	call display_array(p,tree_level+1);
	return;

switch(11):
	call display_list(p,tree_level+1);
	return;

switch(2):
	call display_statement(p,sourceb,tree_level+1);
	return;

switch(6):
switch(12):
switch(15):
	call display_symbol(p,tree_level+1);
	return;

switch(13):
	call show_ms$pt(p);
	return;

switch(14):
	call display_source(p,tree_level+1);
	return;

show_stm:
	call show_statement(string2);
	return;

show_dcl:
	ap1->argstring="";			/* zap "dcl" */
	call cu_$arg_list_ptr(argpt);
	call cu_$gen_call(show_declaration,argpt);

done:	return;

token_list_:
	n = cv_dec_(string2);
	if n = 0 then n = 3000;
	do k = 1 to n;
	     if token_list(k)=null then return;

	     if t_table.type = semi_colon & n = 3000
	     then return;

	     call display_exp(token_list(k),tree_level+1);
	end;
	return;

source_list_:
	m = pl1_stat_$last_source;
	n = cv_dec_(string2);
	if n = 0
	then do;
		n = m;
		j = 0;
	     end;
	else	j, n = min(n,m);
	do i = j to n;
	     call display_source(source_list(i),tree_level+1);
	end;
	return;

dix:	display_xeq:	entry;
	disp_xeq = "1"b;
	go to common;

	end display;




		    display_any_node_name.pl1       11/15/82  1819.8rew 11/15/82  1502.7       13464



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_any_node_name: proc(string,p,tree_level);

/*	Modified: 	26 July 1971 by PG 
	Modified:		9 Oct 1975 by RAB
	Modified:		25 Dec 1977 by RAB
	Modified:		29 Nov 1979 by PCK to produce tree level indented output */

dcl p ptr,
    tree_level fixed bin,
    ioa_ ext entry options(variable),
	(fixed,hbound,null) builtin,
    j fixed bin(17),
    string char(*);

dcl names(0:20) char(20) aligned int static options(constant) init(
    " zero"," block"," statement","n operator"," reference",
    " token"," symbol"," context","n array"," bound"," format value",
    " list"," default"," machine state"," source"," label"," cross ref",
    " sf par"," temporary"," label_array_element","n ILLEGAL");

%include nodes;

if p = null then do;
	call ioa_("^/^vx^a NULL^/",tree_level,string);
	return;
	end;

j = fixed(p->node.type,17,0);
if j >= hbound(names,1) then j = hbound(names,1);
call ioa_("^/^vx^a ^p, a^a node.^/",tree_level,string,p,names(j));
return;
end display_any_node_name;




		    display_array.pl1               11/15/82  1819.8rew 11/15/82  1502.8       48339



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* display array|bound nodes,
    modified on 26 August by PAG for Version II */
/*	Modified again on:	19 October 1970 PG */
/*	Modified on:	 2 December 1970 jk  */
/*	Modified on:	 7 January 1971 by BLW */
/*	Modified on:	25 April 1979 by PCK to implement 4-bit decimal */
/*	Modified on:	29 November 1979 by PCK to display tree level indented output */

display_array: proc(a,tree_level);

dcl	tree_level fixed bin;
dcl	(a,p,b) ptr;
dcl	units(0:7) char(5) int aligned static init("----","bits","digit","byte","half","word","mod2","mod4");
dcl	i fixed bin(31);
dcl	c char(16) varying;
dcl	display_exp external entry(ptr,fixed bin), display_any_node_name ext entry(char(*) aligned,ptr,fixed bin),
	ioa_ entry options(variable),
	(fixed,null) builtin;

dcl	display_stat_$brief_display bit(1) ext static;

dcl	boundary_type(7) char(5) aligned int static
	init("bit", "digit", "byte", "half", "word", "mod2", "mod4");

%include array;
%include nodes;
begin:
	p = a;
	if p = null then do;
		call ioa_("^/^vxdisplay_array: ptr is NULL^/",tree_level);
		return;
		end;

	if p -> node.type = bound_node
	then do;
	     call display_bounds(p,tree_level+1);
	     return;
	     end;

	if p -> node.type ^= array_node then do;
		call display_any_node_name("display_array: arg is not an array node,
 arg =",p,tree_level+1);
		return;
		end;

	if p -> array.interleaved then c = " is interleaved"; else c = "";
	call ioa_("^/^vxARRAY ^p^a, dimensions = ^d",tree_level,p,c,p -> array.number_of_dimensions);

	i=p->array.own_number_of_dimensions;
	if i ^= 0 then
	call ioa_("^vxown_number_of_dimensions = ^d",tree_level,i);

	i = p -> array.element_boundary;
	if i ^= 0 then call ioa_("^vxelement boundary is ^a",tree_level,(boundary_type(i)));

	i = p -> array.size_units;
	if i ^= 0 then call ioa_("^vxsize units are ^a",tree_level,(boundary_type(i)));

	call ioa_("^vxoffset units are ^a",tree_level,units(p->array.offset_units));

	b=p->array.element_descriptor;
	if b ^= null then call show_exp("element descriptor",tree_level);

	b=p->array.virtual_origin;
	if b ^= null then call show_exp("virtual origin",tree_level);

	b = p -> array.symtab_virtual_origin;
	if b ^= null then call show_exp("symtab virtual origin",tree_level);

	i=p->array.c_virtual_origin;
	if i ^= 0 then
	call ioa_("^vxc_virtual_origin = ^d",tree_level,i);

	b=p->array.element_size;
	if b ^= null then call show_exp("element size",tree_level);

	b = p -> array.symtab_element_size;
	if b ^= null then call show_exp("symtab element size",tree_level);

	i=p->array.c_element_size;
	if i ^= 0 then
	call ioa_("^vxc_element_size = ^d",tree_level,i);

	b=p->array.element_size_bits;
	if b ^= null then call show_exp("bit element size",tree_level);

	i=p->array.c_element_size_bits;
	if i ^= 0 then
	call ioa_("^vxc_element_size_bits = ^d",tree_level,i);

	p=p->array.bounds;
	call ioa_("^vxbounds of ARRAY ^p:",tree_level,p);
	call display_bounds(p,tree_level+1);
	call ioa_("^vxEND ARRAY ^p^/",tree_level,p);
	return;

display_bounds: procedure (s,tree_level);
dcl	(p,s) ptr;
dcl	tree_level fixed bin;

	p=s;
test_bounds:
	if p = null then do;
		call ioa_("^/^vxbounds ptr is NULL^/b",tree_level);
		return;
		end;

	if p->node.type ^= bound_node then do;
		call display_any_node_name("display_array: arg is not a bound node,
arg =",p,tree_level+1);
		return;
		end;

next:	if p = null then return;

	call ioa_("^/^vxBOUND ^p",tree_level,p);

	b = p->bound.lower;
	if b ^= null then call show_exp("lower bound",tree_level);

	i=p->bound.c_lower;
	if i ^= 0 then call ioa_("^vxc_lower bound = ^d",tree_level,i);

	b=p->bound.upper;
	if b ^= null then call show_exp("upper bound",tree_level);

	i=p->bound.c_upper;
	if i ^= 0 then call ioa_("^vxc_upper bound = ^d",tree_level,i);

	b=p->bound.multiplier;
	if b ^= null then call show_exp("multiplier",tree_level);

	i=p->bound.c_multiplier;
	if i ^= 0 then call ioa_("^vxc_multiplier = ^d",tree_level,i);

	b=p->bound.desc_multiplier;
	if b ^= null then call show_exp("descriptor multiplier",tree_level);

	i=p->bound.c_desc_multiplier;
	if i ^= 0 then call ioa_("^vxc_desc_multiplier = ^d",tree_level,i);

	b = p -> bound.symtab_lower;
	if b ^= null then call show_exp("symtab lower",tree_level);

	b = p -> bound.symtab_upper;
	if b ^= null then call show_exp("symtab upper",tree_level);

	b = p -> bound.symtab_multiplier;
	if b ^= null then call show_exp("symtab multiplier",tree_level);

	call ioa_("^vxEND BOUND ^p^/",tree_level,p);
	p = p->bound.next;
	go to next;
	end display_bounds;

show_exp:	     proc(mess,tree_level);

dcl	     tree_level fixed bin;
dcl	     mess char(*) aligned;

	     if display_stat_$brief_display then call ioa_("^vx^a = ^p",tree_level,mess,b);
	     else do;
		call ioa_("^vx^a exp follows",tree_level,mess);
		call display_exp(b,tree_level+1);
		call ioa_("^vx^a ended",tree_level,mess);
		end;

	     end;

	end;




		    display_block.pl1               11/15/82  1819.8rew 11/15/82  1502.8       91746



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_block:
	procedure(node_ptr,walk,no_dcls,source,tree_level);

/*	Modified on:	11 August 1971 by PG */
/*	Modified on:	22 September 1971 by PAB */
/*	Modified on:	28 February 1978 by PCK for options(main) */
/*	Modified on:	29 November 1979 by PCK to display output with tree level indentation */

dcl	(p, q, node_ptr) ptr;

dcl	(addr, fixed, null, length, string, substr) builtin;

dcl	 display_exp entry(ptr,fixed bin);

dcl	display_any_node_name	ext entry(char(*) aligned,ptr,fixed bin),
	display_statement		ext entry(ptr,bit(1) aligned,fixed bin),
	display_symbol		ext entry(ptr,fixed bin),
	display_block		ext entry(ptr,bit(1) aligned,bit(1) aligned,bit(1) aligned,fixed bin),
	ioa_			ext entry options(variable),
	decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying),
	convert_binary_integer_$decimal_string entry(fixed bin(15)) returns(char(12) varying),
	ii			fixed bin(18),
	tree_level		fixed bin,
	(no_dcls,source,walk)	bit(1) aligned,
	(i,j)			fixed bin(17);

dcl	display_stat_$brief_display bit(1) ext static;


dcl	context_bits(20) bit(1) unaligned based(addr(q->context.types)),
	context_bit_names(20) char(11) aligned int static init(
	"structure","fixed","float","bit","char","ptr","offset","area","label",
	"entry","file","label_const","entry_const","file_const","condition",
	"format","builtin","generic","picture","parameter");


dcl	n fixed bin(15);

dcl	btype char(12),
	block_type(6) char(12) int static init(" root block", "n ext proc",
	 "n int proc", " begin block", "n on unit", " quick sub"),
	itype fixed bin(15);

dcl	bit_names(5) char(16) static varying
	init("like ", "no_stack ", "get_data ", "flush_at_call ", "text_displayed ");

dcl	nonquick_reasons (13) char (24) internal static varying
	init ("auto_adjustable ", "returns_star ", "stack_extended ", "invoked_by_format ",
	"format_stmt ", "io_stmts ", "assigned_to_entry_var ",
	"condition_stmts ", "no_owner ", "recursive_call ", "options_non_quick ", "options_variable ",
	"never_referenced ");

dcl	line char(80) varying,
	word bit(36) unaligned based,
	b36 bit(36) aligned;

dcl	pl1_stat_$constant_list ptr ext static,
	pl1_stat_$defined_list ptr ext static,
	pl1_stat_$temporary_list ptr ext static;


%include token;
%include block;
%include default;
%include list;
%include statement;
%include symbol;
%include context;
%include nodes;

			/*eject*/
	p=node_ptr;
start:
	if p=null
	then do;
		call ioa_("^vxblock ptr is NULL",tree_level);
		go to ret;
	     end;

	if p->node.type^=block_node
	then do;
		call display_any_node_name("display_block: arg is not a block node,
arg =",p,tree_level+1);
		go to ret;
	     end;

	itype= fixed(p->block.block_type,9);
	if itype<=6 & itype>=1 
	then btype=block_type(itype);
	else btype = convert_binary_integer_$decimal_string(itype);

	call ioa_("^/^vxBLOCK ^p is a^a",tree_level,p,btype);
	call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b));
	i=p->block.level;
	if i ^= 0 then call ioa_("^vxlevel = ^d",tree_level,i);

	ii=p->block.symbol_block;
	if ii ^= 0 then call ioa_("^vxruntime symbol block is ^6w",tree_level,ii);

	i = p -> block.last_auto_loc;
	if i ^= 0 then call ioa_("^vxlast auto loc = ^6w",tree_level,i);

	i = p -> block.number_of_entries;
	if i ^= 0 then call ioa_("^vxnumber of entries = ^d",tree_level,i);

	call ioa_("^vxprefix = ^4o",tree_level,fixed(p->block.prefix,12));
	call ioa_("^vxfather = ^p",tree_level,p->block.father);

	if p->block.options_main
	     then call ioa_("^vxoptions_main",tree_level);

	line = "";
	b36 = addr(p -> block.like_attribute) -> word;

	do i = 1 to hbound(bit_names,1);
	     if substr(b36,i,1)
	     then line = line || bit_names(i);
	     end;

	if length(line) ^= 0 then call ioa_("^vx^a",tree_level,line);

	line = "nonquick reasons: ";
	do i = 1 to hbound (nonquick_reasons, 1);
	     if substr (string (p -> block.why_nonquick), i, 1) = "1"b
	     then do;
		     if length (line) + length (nonquick_reasons (i)) > 80
		     then do;
			     call ioa_ ("^vx^a",tree_level,line);
			     line = "                  ";
			end;

		     line = line || nonquick_reasons (i);
		end;
	end;

	if length (line) > length ("nonquick reasons: ")
	then call ioa_ ("^vx^a",tree_level,line);

	call ioa_("^vxnumber = ^d",tree_level,p->block.number);

	if p->block.owner ^= null
	     then call ioa_("^vxowner = ^p",tree_level,p->block.owner);

	q = p -> block.return_values;
	if q^=null
	then do;
		if display_stat_$brief_display then call ioa_("^vxreturn values = ^p",tree_level,q);
		else do;
		call ioa_("^vxreturn values:",tree_level);

		do while(q^=null);
			call display_exp((q->list.element(2)),tree_level+1);
			q=q->list.element(1);
			end;
		end;
	end;

	q = p -> block.return_count;
	if q^=null
	then do;
	     if display_stat_$brief_display then call ioa_("^vxreturn count = ^p",tree_level,q);
	     else do;
		call ioa_("^vxreturn count:",tree_level);
		call display_exp(q,tree_level+1);
		end;
	end;

	do i = 1 to 3;
	     q = p -> block.free_temps(i);
	     if q ^= null then call ioa_("^vxfree temps(^d) = ^p",tree_level,i,q);
	     end;

	i = p -> block.enter.start;
	j = p -> block.enter.end;
	if i + j ^= 0
	then call ioa_("^vxenter.start = ^o, enter.end = ^o",tree_level,i,j);

	i = p -> block.leave.start;
	j = p -> block.leave.end;
	if i + j ^= 0
	then call ioa_("^vxleave.start = ^o, leave.end = ^o",tree_level,i,j);

	q = p -> block.entry_list;
	if q ^= null then call ioa_("^vxentry list = ^p",tree_level,q);

	q=p->block.plio_ps;
	if q ^= null then call ioa_("^vxplio_ps= ^p",tree_level,q);

	q=p->block.plio_fa;
	if q ^= null then call ioa_("^vxplio_format_area= ^p",tree_level,q);

	q=p->block.plio_ffsb;
	if q ^= null then call ioa_("^vxplio_ffsb= ^p",tree_level,q);

	q=p->block.plio_ssl;
	if q ^= null then call ioa_("^vxplio_ssl= ^p",tree_level,q);

	q=p->block.plio_fab2;
	if q ^= null then call ioa_("^vxplio_fab2= ^p",tree_level,q);

	q = p -> block.declaration;
	if q = null
	then call ioa_("^vxno dcls",tree_level);
	else do;
	     if display_stat_$brief_display | no_dcls then call ioa_("^vxdeclarations = ^p",tree_level,q);
	     else do;
		call ioa_("^vxdeclarations:",tree_level);
dcl_loop: 	call display_symbol(q,tree_level+1);
		q=q->symbol.next;
		if q^=null then go to dcl_loop;
		end;
	     end;

ck_context:
	q=p->block.context;
	if q = null
	then call ioa_("^vxno context",tree_level);
	else do;
	     if display_stat_$brief_display then call ioa_("^vxcontext = ^p",tree_level,q);
	     else do;
		call ioa_("^vxcontext:",tree_level);
ctxt_loop:	call ioa_("^vxidentifier is ^a, attributes are:",tree_level,q->context.token->token.string);
		do i = 1 to 20;
		if context_bits(i) then call ioa_("^vx^a",tree_level,context_bit_names(i));
		end;
		q=q->context.next;
		if q^=null then go to ctxt_loop;
	     end;
	     end;

	if p->block.father=null
	then do;
		if pl1_stat_$constant_list^=null
		then do;
		     if display_stat_$brief_display then call ioa_("^vxconstants = ^p",tree_level,pl1_stat_$constant_list);
		     else do;
			call ioa_("^vxconstants:",tree_level);

			q=pl1_stat_$constant_list;
			do while(q^=null);
				call display_symbol(q,tree_level+1);
				q=q->symbol.multi_use;
			end;
		     end;
		end;

		if pl1_stat_$temporary_list^=null
		then do;
		     if display_stat_$brief_display then call ioa_("^vxtemporaries = ^p",tree_level,pl1_stat_$temporary_list);
		     else do;
			call ioa_("^vxtemporaries:",tree_level);

			q=pl1_stat_$temporary_list;
			do while(q^=null);
				call display_symbol(q,tree_level+1);
				q=q->symbol.multi_use;
			end;
		     end;
		end;

		if pl1_stat_$defined_list ^= null
		then do;
		     if display_stat_$brief_display
		     then call ioa_("^vxdefined overlays = ^p",tree_level,pl1_stat_$defined_list);
		     else do;
			call ioa_("^vxdefined overlays:",tree_level);

			do q = pl1_stat_$defined_list repeat q -> symbol.multi_use while(q ^= null);
			     call display_symbol(q,tree_level+1);
			     end;
			end;
		     end;
	end;

	q=p->block.default;
	if q^=null then do;
	     if display_stat_$brief_display then call ioa_("^vx^vxdefaults = ^p",tree_level,tree_level,q);
	     else do;
		call ioa_("^vxdefault:",tree_level);
default_loop:	call display_symbol(q,tree_level+1);
		q=q->default.next;
		if q^=null then go to default_loop;
	     end;
		end;

	q = p -> block.prologue;
	if q = null
	then call ioa_("^vxno prologue",tree_level);
	else do;
	     if display_stat_$brief_display then call ioa_("^vxprologue = ^p",tree_level,q);
	     else do;
		call ioa_("^vxprologue:",tree_level);
pro_loop: 	call display_statement(q,"0"b,tree_level+1);
		q=q->statement.next;
		if q^=null then go to pro_loop;
		end;
	     end;

	q = p -> block.main;
	if q = null
	then call ioa_("^vxno main",tree_level);
	else do;
	     if display_stat_$brief_display then call ioa_("^vxmain = ^p",tree_level,q);
	     else do;
		call ioa_("^vxmain:",tree_level);
main_loop:	call display_statement(q,source,tree_level+1);
		q=q->statement.next;
		if q^=null then go to main_loop;
		end;
	     end;


	q=p->block.son;
	if q = null
	then call ioa_("^vxno sons",tree_level);
	else if ^walk | display_stat_$brief_display then call ioa_("^vxson = ^p",tree_level,q);
		else do;
			call ioa_("^vxson:",tree_level);
			call display_block(q,walk,no_dcls,source,tree_level+1);
		     end;

	if p->block.brother=null
	then call ioa_("^vxno brothers",tree_level);
	else if ^walk | display_stat_$brief_display then call ioa_("^vxbrother = ^p",tree_level,p->block.brother);
		else do;
			call ioa_("^vxEND BLOCK ^p^/",tree_level,p);
			p=p->block.brother;
			call ioa_("^vxbrother:",tree_level);
			go to start;
		     end;

ret:	call ioa_("^vxEND BLOCK ^p^/",tree_level,p);
	return;
end display_block;




		    display_constant.pl1            11/15/82  1819.8rew 11/15/82  1502.9        7974



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_constant: proc(pt,tree_level);

/*	Modified: 29 November 1979 by PCK to print tree level indented output */

dcl	pt ptr,
	tree_level fixed bin,
	fixed_bin fixed bin based,
	ioa_ entry options(variable);

%include symbol;

	call ioa_("^/^vxCONSTANT ^p",tree_level,pt -> symbol.initial);
	call ioa_("^vxvalue = ^w^/",tree_level,pt -> symbol.initial -> fixed_bin);

	end;




		    display_exp.pl1                 11/15/82  1819.8rew 11/15/82  1503.1      152613



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/*	prints expressions

	Modified on:	22 September 1970 by P. Green for Version II
	Modified on:	28 February 1978 by PCK for the stop operator
	Modified on:	Dec 1978 by David Spector for cross_reference.set_reference bit
	Modified on:	25 April 1979 by PCK to implement 4-bit decimal
	Modified on:	17 May 1979 by RAB for reference.substr
	Modified on:	6 June 1979 by PG for rank and byte
	Modified 791017 by PG to print all info in a temporary node
	Modified on:	29 November 1979 by PCK to print tree level indented output
	Modified on:	26 Dec 1979 by PCK for by name assignment
	Modified on:	23 March 1980 by RAB for reference.(padded aligned)_for_store_ref
 	Modified on:	24 June 1980 by PCK to correctly indent list nodes
	Modified on:	27 June 1980 by PCK to decode data type of reference node
	Modified on:	11 September 1980 by M. N. Davidoff to print temporary node info instead of garbage
	Modified on:	15 September 1980 by M. N. Davidoff to decode reference.address
*/
/* format: style3 */
display_exp:
     proc (a, tree_level);

dcl	(a, p, q, s)	ptr,
	tree_level	fixed bin,
	display_stat_$brief_display
			bit (1) ext static,
	display_any_node_name
			entry (char (*) aligned, ptr, fixed bin);
dcl	(binary, substr, addr, fixed, string, length, null, hbound, baseno, rel)
			builtin;
dcl	decode_node_id	entry (ptr, bit (1) aligned) returns (char (120) varying),
	display_list	entry (ptr, fixed bin),
	display_constant	entry (ptr, fixed bin);
dcl	ioa_		entry options (variable);
dcl	ioa_$nnl		entry options (variable);
dcl	(i, n)		fixed bin (15),
	line		char (96),
	lp		fixed bin;
dcl	b36		bit (36) aligned,
	m		fixed bin (18),
	word_bit		bit (36) aligned based (p),
	op_name		char (20) aligned,
	op_number		bit (9) aligned,
	1 op_number_structure
			based (addr (op_number)) aligned,
	  2 op_class	bit (5) unaligned,
	  2 op_relative	bit (4) unaligned;

/* include files */

%include op_codes;
%include cross_reference;
%include label;
%include nodes;
%include symbol;
%include operator;
%include temporary;
%include token;
%include token_types;
%include reference;

/* internal static */

dcl	units		(7) char (5) int static options (constant) aligned
			init ("bit ", "digit", "char", "half", "word", "mod2", "mod4");

dcl	bit_names		(30) char (20) varying static
			init ("array", "varying", "shared", "put_data", "processed", "inhibit", "big_offset",
			"big_length", "has_modword", "padded", "aligned", "long", "forward", "ic", "temp", "defined",
			"evaluated", "allocate", "allocated", "aliasable", "even", "", "aggregate", "hit_zero",
			"dont_save", "fo_in_qual", "hard_to_load", "substr", "padded_for_store", "aligned_for_store");

dcl	data_type_name	(1:24) char (20) var aligned
			init ("real_fix_bin_1", "real_fix_bin_2", "real_flt_bin_1", "real_flt_bin_2",
			"complex_fix_bin_1", "complex_fix_bin_2", "complex_flt_bin_1", "complex_flt_bin_2",
			"real_fix_dec", "real_flt_dec", "complex_fix_dec", "complex_flt_dec", "char_string",
			"bit_string", "label_constant", "local_label_variable", "label_variable", "entry_variable",
			"ext_entry_in", "ext_entry_out", "int_entry", "int_entry_other", "unpacked_ptr", "packed_ptr")
			int static options (constant);

dcl	address_name	(9) char (8) varying static init ("b0", "b1", "b2", "b3", "b4", "b5", "b6", "b7", "storage");

dcl	value_name	(24) char (12) varying static
			init ("a", "q", "aq", "string_aq", "complex_aq", "decimal_aq", "b0", "b1", "b2", "b3", "b4",
			"b5", "b6", "b7", "storage", "indicators", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");

dcl	op_offset		(0:20) fixed bin (15) int static
			initial (0, 1, 8, 15, 25, 35, 46, 61, 65, 81, 92, 108, 117, 120, 131, 137, 153, 169, 185, 194,
			210);

/* format: ^delnl */

dcl	op_names		(0:210) char (20) aligned internal static initial (
			"ZERO!!",
			"UNUSED 1-0",		/* class 1	1 */
			"add",
			"sub",
			"mult",
			"div",
			"negate",
			"exp",

			"UNUSED 2-0",		/* class 2	8 */
			"and_bits",
			"or_bits",
			"xor_bits",
			"not_bits",
			"cat_string",
			"bool_fun",

			"UNUSED 3-0",		/* class 3	15 */
			"assign",
			"assign_size_ck",
			"assign_zero",
			"copy_words",
			"copy_string",
			"make_desc",
			"assign_round",
			"pack",
			"unpack",

			"UNUSED 4-0",		/* class 4	25 */
			"UNUSED 4-1",
			"UNUSED 4-2",
			"UNUSED 4-3",
			"less_than",
			"greater_than",
			"equal",
			"not_equal",
			"less_or_equal",
			"greater_or_equal",

			"UNUSED 5-0",		/* class 5	35 */
			"jump",
			"jump_true",
			"jump_false",
			"jump_if_lt",
			"jump_if_gt",
			"jump_if_eq",
			"jump_if_ne",
			"jump_if_le",
			"jump_if_ge",
			"jump_three_way",

			"UNUSED 6-0",		/* class 6	46 */
			"std_arg_list",
			"return_words",
			"std_call",
			"return_bits",
			"std_entry",
			"return_string",
			"ex_prologue",
			"allot_auto",
			"param_ptr",
			"param_desc_ptr",
			"std_return",
			"allot_ctl",
			"free_ctl",
			"stop",

			"mod_bit",		/* class 7	61 */
			"mod_byte",
			"mod_half",
			"mod_word",

			"bit_to_char",		/* class 8	65 */
			"bit_to_word",
			"char_to_word",
			"half_to_word",
			"word_to_mod2",
			"word_to_mod4",
			"word_to_mod8",
			"rel_fun",
			"baseno_fun",
			"desc_size",
			"bit_pointer",
			"index_before_fun",
			"index_after_fun",
			"verify_ltrim_fun",
			"verify_rtrim_fun",
			"digit_to_bit",

			"ceil_fun",		/* class 9	81 */
			"floor_fun",
			"round_fun",
			"sign_fun",
			"abs_fun",
			"trunc_fun",
			"byte",
			"rank",
			"index_rev_fun",
			"search_rev_fun",
			"verify_rev_fun",

			"index_fun",		/* class 10	92 */
			"off_fun",
			"complex_fun",
			"conjg_fun",
			"mod_fun",
			"repeat_fun",
			"verify_fun",
			"translate_fun",
			"UNUSED 10-8",
			"real_fun",
			"imag_fun",
			"length_fun",
			"pl1_mod_fun",
			"search_fun",
			"allocation_fun",
			"reverse_fun",

			"addr_fun",		/* class 11	108 */
			"addr_fun_bits",
			"ptr_fun",
			"baseptr_fun",
			"addrel_fun",
			"codeptr_fun",
			"environmentptr_fun",
			"stackbaseptr_fun",
			"stackframeptr_fun",

			"min_fun",		/* class 12	117 */
			"max_fun",
			"pos_dif_fun",

			"UNUSED 13-0",		/* class 13	120 */
			"stack_ptr",
			"empty_area",
			"UNUSED 13-3",
			"enable_on",
			"revert_on",
			"signal_on",
			"lock_fun",
			"stacq_fun",
			"clock_fun",
			"vclock_fun",

			"bound_ck",		/* class 14	131 */
			"range_ck",
			"loop",
			"join",
			"allot_based",
			"free_based",

			"UNUSED 15-0",		/* class 15	137 */
			"r_parn",
			"l_parn",
			"r_format",
			"c_format",
			"f_format",
			"e_format",
			"b_format",
			"a_format",
			"x_format",
			"skip_format",
			"column_format",
			"page_format",
			"line_format",
			"picture_format",
			"bn_format",

			"get_list_trans",		/* class 16	153 */
			"get_edit_trans",
			"get_data_trans",
			"put_list_trans",
			"put_edit_trans",
			"put_data_trans",
			"terminate_trans",
			"stream_prep",
			"record_io",
			"fortran_read",
			"fortran_write",
			"ftn_file_manip",
			"ftn_trans_loop",
			"put_control",
			"put_field",
			"put_field_chk",

			"UNUSED 17-0",		/* class 17	169 */
			"UNUSED 17-1",
			"return_value",
			"allot_var",
			"free_var",
			"get_file",
			"get_string",
			"put_file",
			"put_string",
			"open_file",
			"close_file",
			"read_file",
			"write_file",
			"locate_file",
			"do_fun",
			"do_spec",

			"rewrite_file",		/* class 18	185 */
			"delete_file",
			"unlock_file",
			"lock_file",
			"UNUSED 18-4",
			"refer",
			"prefix_plus",
			"nop",
			"assign_by_name",

			"sqrt_fun",		/* class 19	194 */
			"sin_fun",
			"sind_fun",
			"cos_fun",
			"cosd_fun",
			"tan_fun",
			"tand_fun",
			"asin_fun",
			"asind_fun",
			"acos_fun",
			"acosd_fun",
			"atan_fun",
			"atand_fun",
			"log2_fun",
			"log_fun",
			"log10_fun",

			"exp_fun");		/* class 20 (end)	210 */

/* format: revert */

/* program */

	p = a;
	if p = null
	then do;
		call ioa_ ("^/^vxdisplay_exp: pointer is NULL^/", tree_level);
		return;
	     end;
	if p -> node.type = token_node
	then do;
		call ioa_ ("^/^vxTOKEN ^p is ^a", tree_level, p, p -> token.string);
		if p -> token.type = bit_string
		then call ioa_ ("^vxtype is bit_string", tree_level);
		else if p -> token.type = char_string
		then call ioa_ ("^vxtype is char_string", tree_level);

		call ioa_ ("");
		return;
	     end;
	if p -> node.type = block_node
	then do;
		call ioa_ ("^/^vxBLOCK ^p^/", tree_level, p);
		return;
	     end;
	if p -> node.type = label_node
	then do;
		call ioa_ ("^/^vxLABEL ^p is ^a^/", tree_level, p, p -> label.token -> token.string);
		return;
	     end;
	if p -> node.type = cross_reference_node
	then do;
		do p = p repeat p -> cross_reference.next while (p ^= null);
		     call ioa_ ("^/^vxXREF ^p, ^a^[ set^]^/", tree_level, p, decode_node_id (p, "0"b),
			p -> cross_reference.set_reference);
		end;
		return;
	     end;
	if p -> node.type = symbol_node
	then do;
		call ioa_ ("^/^vxSYMBOL ^p is ^a^/", tree_level, p, p -> symbol.token -> token.string);
		return;
	     end;
	if p -> node.type = reference_node
	then do;
		s, q = p -> reference.symbol;
		if s = null
		then call ioa_ ("^/^vxREFERENCE ^p", tree_level, p);
		else do;
			if q -> node.type = symbol_node | q -> node.type = label_node
			then q = q -> symbol.token;
			else ;			/* is already token from parse */

			call ioa_$nnl ("^/^vxREFERENCE ^p is ^a, symbol is ^p", tree_level, p, q -> token.string,
			     p -> reference.symbol);

			if p -> reference.data_type ^= 0
			then call ioa_$nnl (", data type is ^d (^a)", p -> reference.data_type,
				data_type_name (p -> reference.data_type));


			call ioa_ ("");

			if s -> node.type = symbol_node
			then if s -> symbol.constant & ^s -> symbol.entry & s -> symbol.initial ^= null
			     then call display_constant (s, tree_level + 1);
		     end;

		m = p -> reference.c_offset;
		if m ^= 0
		then call ioa_ ("^vxc_offset = ^d", tree_level, m);
		m = p -> reference.c_length;
		if m ^= 0
		then call ioa_ ("^vxc_length = ^d", tree_level, m);

		b36 = substr (p -> word_bit, 10, 5) || p -> reference.inhibit || string (p -> reference.other)
		     || string (p -> reference.bits) || string (p -> reference.more_bits);
		if b36 ^= "0"b
		then do;
			line = "";
			lp = 1;

			do i = 1 to hbound (bit_names, 1);
			     if substr (b36, i, 1)
			     then do;
				     n = length (bit_names (i));
				     if n > 0
				     then do;
					     substr (line, lp, n) = bit_names (i);
					     lp = lp + n + 1;

					     if lp > 72
					     then do;
						     call ioa_ ("^vx^a", tree_level, line);
						     lp = 1;
						     line = "";
						end;
					end;
				end;
			end;

			if lp > 1
			then call ioa_ ("^vx^a", tree_level, line);
		     end;

		if ^p -> reference.no_address
		then call ioa_ (
			"^vx^[perm ^]address = ^[^spr^.3b|^;^[^s^;(base = ^.3b)^] ^]^.3b^a^[^s^; (tag = ^.3b)^]^[ inhibit^]^[^s^; (op = ^.3b)^]"
			, tree_level, p -> reference.perm_address, p -> reference.address.ext_base,
			p -> reference.address.base = ""b, p -> reference.address.base, p -> reference.address.offset,
			decode_tag (p -> reference.address.tag), p -> reference.address.tag = ""b,
			p -> reference.address.tag, p -> reference.address.inhibit, p -> reference.address.op = ""b,
			p -> reference.address.op);

		b36 = string (p -> reference.address_in);
		if b36 ^= "0"b
		then do;
			line = "address is in:";
			lp = 16;

			do i = 1 to length (string (p -> reference.address_in));
			     if substr (b36, i, 1)
			     then do;
				     n = length (address_name (i));
				     substr (line, lp, n) = address_name (i);
				     lp = lp + n + 1;
				end;
			end;

			call ioa_ ("^vx^a", tree_level, line);
		     end;

		b36 = string (p -> reference.value_in);
		if b36 ^= "0"b
		then do;
			line = "value is in:";
			lp = 14;

			do i = 1 to length (string (p -> reference.value_in));
			     if substr (b36, i, 1)
			     then do;
				     n = length (value_name (i));
				     substr (line, lp, n) = value_name (i);
				     lp = lp + n + 1;

				     if lp > 72
				     then do;
					     call ioa_ ("^vx^a", tree_level, line);
					     lp = 1;
					     line = "";
					end;

				end;
			end;

			if lp > 1
			then call ioa_ ("^vx^a", tree_level, line);
		     end;

		i = p -> reference.ref_count;
		if i ^= 0
		then call ioa_ ("^vxreference count = ^d", tree_level, i);

		m = fixed (p -> reference.units, 3);
		if m ^= 0
		then call ioa_ ("^vxunits = ^a", tree_level, units (m));

		i = fixed (p -> reference.store_ins, 18);
		if i ^= 0
		then call ioa_ ("^vxstored into at ^6w", tree_level, i);

		q = p -> reference.offset;
		if q ^= null
		then call show_exp ("offset");
		q = p -> reference.length;
		if q ^= null
		then call show_exp ("length");
		q = p -> reference.qualifier;
		if q ^= null
		then call show_exp ("qualifier");
		q = p -> reference.subscript_list;
		if baseno (q) ^= (18)"0"b
		then if q ^= null
		     then call show_exp ("subscript list");
		     else ;
		else do;
			i = fixed (rel (q), 18);
			if i ^= 0
			then call ioa_ ("^vxfractional offset is ^6w", tree_level, i);
		     end;
		call ioa_ ("^vxEND REFERENCE ^p^/", tree_level, p);
		return;
	     end;

	if p -> node.type = list_node
	then do;
		call display_list (p, tree_level);
		return;
	     end;

	if p -> node.type = temporary_node
	then do;
		call ioa_ ("^/^vxTEMPORARY ^p", tree_level, p);
		call ioa_ ("^vxnext = ^p", tree_level, p -> temporary.next);
		call ioa_ ("^vxsize = ^d", tree_level, p -> temporary.size);
		call ioa_ ("^vxlocation = sp|^6w", tree_level, (p -> temporary.location));
		call ioa_ ("^vxref_count = ^d", tree_level, p -> temporary.ref_count);
		call ioa_ ("^vxsymbol = ^p", tree_level, p -> temporary.symbol);
		call ioa_ ("^vxlast_freed = ^6w", tree_level, (p -> temporary.last_freed));
		call ioa_ ("^vxEND TEMPORARY ^p^/", tree_level, p);
		return;
	     end;

	if p -> node.type ^= operator_node
	then do;
		call display_any_node_name ("display_exp: arg node not handled by display_exp,
arg =", p, tree_level + 1);
		return;
	     end;
	n = p -> operator.number;
	op_number = p -> operator.op_code;
	op_name = op_names (op_offset (fixed (op_class, 5)) + fixed (op_relative, 4));

	line = "";
	lp = 1;

	if p -> operator.shared
	then do;
		substr (line, lp, 6) = "shared";
		lp = lp + 7;
	     end;

	if p -> operator.optimized
	then do;
		substr (line, lp, 9) = "optimized";
		lp = lp + 10;
	     end;

	if p -> operator.processed
	then do;
		substr (line, lp, 9) = "processed";
		lp = lp + 10;
	     end;

	if lp = 1
	then call ioa_ ("^/^vxOPERATOR ^p is ^a, ^d operands", tree_level, p, op_name, n);
	else call ioa_ ("^/^vxOPERATOR ^p is ^a, (^va), ^d operands", tree_level, p, op_name, lp - 2, line, n);
	do i = 1 to n;
	     if p -> operator.operand (i) = null
	     then call ioa_ ("^vxOPERAND (^d) of ^p = NULL", tree_level, i, p);
	     else do;
		     call ioa_ ("^vxOPERAND (^d) of ^p =", tree_level, i, p);
		     call display_exp ((p -> operator.operand (i)), tree_level + 1);
		end;
	end;
	if n ^= 0
	then call ioa_ ("^vxEND OPERATOR ^p, ^d operands^/", tree_level, p, n);
	else call ioa_ ("");

	return;

show_exp:
     proc (message);

dcl	message		char (*);

	if display_stat_$brief_display
	then call ioa_ ("^vx^a exp = ^p", tree_level, message, q);
	else do;
		call ioa_ ("^vx^a follows:", tree_level, message);
		call display_exp (q, tree_level + 1);
		call ioa_ ("^vx^a ended", tree_level, message);
	     end;
     end show_exp;

decode_tag:
     procedure (tag) returns (char (4) varying);

dcl	tag		bit (6);

dcl	designator	fixed bin (4);

dcl	designator_names	(0:15) char (2) varying internal static options (constant)
			initial ("n", "au", "qu", "du", "ic", "al", "ql", "dl", "x0", "x1", "x2", "x3", "x4", "x5",
			"x6", "x7");

dcl	it_designator_names (0:15) char (3) varying internal static options (constant)
			initial ("f1", "itp", "42", "its", "sd", "scr", "f2", "f3", "ci", "i", "sc", "ad", "di", "dic",
			"id", "idc");

	designator = binary (substr (tag, 3), 4);
	goto modification (binary (substr (tag, 1, 2), 2));

modification (0):					/* register (r) */
	if designator = 0
	then return ("");
	else return ("," || designator_names (designator));

modification (1):					/* register then indirect (ri) */
	if designator = 0
	then return (",*");
	else return ("," || designator_names (designator) || "*");

modification (2):					/* indirect then tally (it) */
	return ("," || it_designator_names (designator));

modification (3):					/* indirect then register (ir) */
	return (",*" || designator_names (designator));
     end decode_tag;

     end display_exp;




		    display_list.pl1                11/15/82  1819.8rew 11/15/82  1503.1       13824



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_list: proc(q,tree_level) recursive;			/* prints initial lists */

/*	Modified on:	23 October 1970 by PG */
/*	Modified on:	19 November 1979 by PCK to print a tree level indented listing */

dcl	(p,q,r) ptr,
	tree_level fixed bin,
	(ioa_,ioa_$nnl) entry options(variable),
	display_any_node_name entry(char(*) aligned,ptr,fixed bin),
	display_exp entry(ptr,fixed bin),
	(i,n) fixed bin(15);

dcl	null builtin;

%include token;
%include list;
%include nodes;
	p = q;
begin:
	if p=null then return;
	if p->node.type ^= list_node
	then do;
		call display_any_node_name("display_list: arg is not a list node, arg=",p,tree_level+1);
		return;
	end;
	n=p->list.number;
	call ioa_("^/^vxLIST ^p, ^d elements",tree_level,p,n);
	do i=1 to n;
	r=p->list.element(i);
	if r ^= null
	then do; call ioa_("^vxELEMENT (^d) of ^p =",tree_level,i,p);
		call display_exp(r,tree_level+1);  end;
	else call ioa_("^vxELEMENT (^d) of ^p = NULL",tree_level,i,p);
	end;

	call ioa_("^vxEND LIST ^p^/",tree_level,p);

	return;
	end display_list;




		    display_source.pl1              11/15/82  1819.8rew 11/15/82  1503.2       16497



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_source:
	proc(pt,tree_level);

/*	Modified: 29 Nov 1979 by PCK to print a tree level indented listing */

dcl	tree_level fixed bin;
dcl	(p,pt) ptr;
dcl	(addr,null) builtin;
dcl	1 based_words based aligned,
	2 word1 bit(36),
	2 word2 bit(36);
dcl	date char(24) aligned;
dcl	ioa_ entry options(variable);
dcl	decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying);
dcl	date_time_ entry(fixed bin(71), char(*) aligned);
dcl	display_any_node_name entry(char(*) aligned,ptr,fixed bin);
%include nodes;
%include token;
%include token_list;
%include source_list;

	p = pt;
	if p = null
	then do;
		call ioa_("^/^vxdisplay_source: ptr is NULL^/",tree_level);
		return;
	     end;

	if p->node.type ^= source_node
	then do;
		call display_any_node_name("display_source: node is not a source_node, arg=",p,tree_level+1);
		return;
	     end;

	call ioa_("^/^vxSOURCE ^p, ^a",tree_level,p,p -> source.name->token.string);
	call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b));
	call ioa_("^vxseg_ptr = ^p, length = ^d, pathname = ^a",tree_level,p -> source.seg_ptr,p -> source.source_length,p -> source.pathname);
	call date_time_(p -> source.dtm,date);
	call ioa_("^vxuid = ^w, dtm = ^w^w (^a)^/",tree_level, p -> source.uid, p -> source.dtm,
		addr(p -> source.dtm) -> word2, date);
	return;
end display_source;




		    display_stat_.alm               11/15/82  1819.8rew 11/15/82  1533.1        3825



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"	display_stat_
	name	display_stat_
	use	linkc
	join	/link/linkc
"
	segdef	brief_display
	bss	brief_display,1
	end




		    display_statement.pl1           11/15/82  1819.8rew 11/15/82  1503.3       44766



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


display_statement:	procedure(p,sourceb,tree_level);

/*	Modified on:	22 September 1970 by PG. */
/*	Modified on:	 7 January 1971 by BLW	*/
/*	Modified on:	24 May 1971 by ACF	*/
/*	Modified on:	25 July 1971 by PG */
/*	Modified on:	6 June 1977 by RAB */
/*	Modified on:	29 Nov 1979 by PCK to print a tree level indented listing */
/*	Modified on:	17 Mar 1980 by PCK to display expanded_by_name */

dcl	(p, q) ptr,
	tree_level fixed bin,
	sourceb bit(1) aligned,
	cu_$arg_count entry returns(fixed bin),
	display_any_node_name ext entry(char(*) aligned, ptr,fixed bin),
	(ioa_,ioa_$nnl) ext entry options(variable), display_exp ext entry(ptr,fixed bin),
	decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying),
	ios_$write_ptr entry(ptr,fixed bin,fixed bin),
	(addr,fixed,length,min,null,ptr) builtin,
	n fixed bin(15);

dcl	itype fixed bin(15),
	line char(132) aligned varying,
	st(0:38) char(12) int static options(constant)
	init("unknown", "allocate", "assignment", "begin", "call", "close",
	     "declare", "delay", "delete", "display", "do", "else clause",
	     "end", "entry", "exit", "format", "free", "get", "go to", "if",
	     "locate", "null", "on", "open", "procedure", "put", "read",
	     "return", "revert", "rewrite", "signal", "stop",
	     "system", "unlock", "wait", "write", "default","continue","pause");

%include list;
%include nodes;
%include source_list;
%include statement;
%include token_list;

begin:
	if p=null
	then do;
		call ioa_("^/^vxdisplay_statement: ptr is NULL^/",tree_level);
		return;
	     end;
	if p->node.type^=statement_node
	then do;
		call display_any_node_name("display_statement: arg is not a statement node,
arg =",p,tree_level+1);
		return;
	     end;
	itype=fixed(p->statement.statement_type,17,0);
	if itype > hbound(st,1) then itype = 0;
	call ioa_("^/^vx^a STATEMENT ^p, next = ^p, back = ^p",tree_level,st(itype),p,p->statement.next,
		p->statement.back);
	call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b));

	if cu_$arg_count() > 1
	then if sourceb
	     then do;
		m = p->statement.source.segment;
		if p->statement.source.length ^= 0
		then do; 
			call ioa_$nnl("^vxSOURCE:	",tree_level);
			call ios_$write_ptr((source.seg_ptr),(p->statement.
source.start),min(p->statement.source.length,120));
			call ioa_("");
		     end;
		end;
	m = p -> object.start;
	if m ^= 0
	then if m = p->object.finish then call ioa_("^vxno object code, ic = ^o",tree_level,m);
	     else call ioa_("^vxobject code start = ^o, finish = ^o",tree_level,m,p->object.finish);

	if p->statement.prefix ^= "111110000000"b then call ioa_("^vxprefix = o^4o",tree_level,
			fixed(p->statement.prefix,12,0));
	line = "";
	if p->statement.optimized then line = "optimized ";
	if p->statement.generated then line = line || "generated ";
	if p->statement.free_temps then line = line || "free_temps ";
	if p->statement.LHS_in_RHS then line = line || "LHS_in_RHS ";
	if p->statement.processed then line = line || "processed ";
	if p->statement.put_in_profile then line = line || "put_in_profile ";
	if p->statement.snap then line = line || "snap ";
	if p->statement.system then line = line || "system ";
	if p->statement.irreducible then line = line || "irreducible ";
	if p->statement.checked then line = line || "checked ";
	if p->statement.save_temps then line = line || "save_temps ";
	if p->statement.suppress_warnings then line = line || "suppress_warnings ";
	if p->statement.force_nonquick then line = line || "force_nonquick ";
	if p->statement.expanded_by_name then line = line || "expanded_by_name ";
	if length(line) ^= 0 then call ioa_("^vx^a",tree_level,line);
	m=p->statement.reference_count;
	if m ^= 0
	then call ioa_("^vxreference count = ^d",tree_level,m);
	q=p->statement.reference_list;
	if q ^= null then call ioa_("^vxreference list = ^p",tree_level,q);
	q = p -> statement.state_list;
	if q ^= null then call ioa_("^vxstate list = ^p",tree_level,q);
	q=p->statement.labels;
	if q ^= null
	then do;
		call ioa_("^vxlabels:",tree_level);
		do while(q^=null);
		if q->list.element(2)->node.type=token_node
		then call ioa_(q->list.element(2)->t_table.string);
		else call display_exp((q->list.element(2)),tree_level+1);		/* for arrays */
		q=q->list.element(1);
		end;
	     end;
	q=p->statement.root;
	if q ^= null
	then do;
		call ioa_("^vxroot:",tree_level);
		call display_exp(q,tree_level+1);
	     end;
	call ioa_("^vxEND ^a STATEMENT ^p^/",tree_level,st(itype),p);
	return;
end display_statement;




		    display_symbol.pl1              11/15/82  1819.8rew 11/15/82  1503.4       95292



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/*	Modified on:	10 August 1971 by PG */
/*	Modified on: 14 July 1978 by PCK for unsigned binary */
/*	Modified on: 25 April 1979 by PCK to implement 4-bit decimal */
/*	Modified on: 29 November 1979 by PCK to print a tree level indented listing */

/* This program prints a formatted dump of the symbol table pointed to
    by p. */

display_symbol: proc(a,tree_level);

dcl (a,p,q,vector) ptr, 
    line char(96),
    tree_level fixed bin,
    lp fixed bin;

dcl i fixed bin(31);
dcl n fixed bin(15);
dcl k fixed bin;
dcl	based_bitstring bit(36) aligned based;

dcl display_any_node_name ext entry(char(*) aligned, ptr,fixed bin);
dcl ioa_ ext entry options(variable);
dcl decode_node_id entry(ptr,bit(1)) returns(char(120) varying);
dcl ( display_array, display_exp, display_constant)
	ext entry(ptr,fixed bin);
dcl (fixed,string,length,null) builtin;

dcl	display_stat_$brief_display bit(1) ext static;

dcl boundary_type(0:7) char(5) int static aligned init("----","bit ","digit","byte","half","word","mod2","mod4");
dcl declare_type(0:5) char(8) int static init("--------","declare ","expl ctx","context ",
					"implicit","compiler");


% include symbol;
%include default;
%include label;
%include statement;
% include nodes;
%include token_list;
%include list;
%include label_array_element;
%include declare_type;

dcl names(89) char(20) varying int static initial(

	 /* data_type */

"structure",
"fixed",
"float",
"bit",
"char",
"ptr",
"offset",
"area",
"label",
"entry",
"file",
"arg_descriptor",
"storage_block",
"unused_1",
"condition",
"format",
"builtin",
"generic",
"picture",

	 /* misc_attributes */

"dimensioned",
"initialed",
"aligned",
"unaligned",
"signed",
"unsigned",
"precision",
"varying",
"local",
"decimal",
"binary",
"real",
"complex",
"variable",
"reducible",
"irreducible",
"returns",
"position",
"internal",
"external",
"like",
"member",
"non_varying",
"options",
"variable_arg_list",	 /* options(variable) */
"alloc_in_text",		 /* options(constant) */

	 /* storage_class */

"auto",
"based",
"static",
"controlled",
"defined",
"parameter",
"param_desc",
"constant",
"temporary",
"return_value",

	 /* file_attributes */

"print",
"input",
"output",
"update",
"stream",
"reserved_1",
"record",
"sequential",
"direct",
"interactive",	 /* env(interactive) */
"reserved_2",
"reserved_3",
"stringvalue",	 /* env(stringvalue) */
"keyed",
"reserved_4",
"environment",

	 /* compiler_developed */

"aliasable",
"packed",
"passed_as_arg",
"allocate",
"set",
"exp_extents",
"refer_extents",
"star_extents",
"isub",
"put_in_symtab",
"contiguous",
"put_data",
"overlayed",
"error",
"symtab_processed",
"overlayed_by_builtin",
"defaulted",
"connected"
);

p=a;

if p = null then do;
	call ioa_("^/^vxdisplay_symbol: ptr is NULL^/",tree_level);
	return;
	end;

if p->node.type=label_node
 then do;
	call ioa_("^/^vxLABEL ^p is ^a",tree_level,p,p->label.token->t_table.string);
	if p->label.statement ^= null
	then if ^ p->label.array
	     then call ioa_("^vxfor ^a",tree_level,decode_node_id((p -> label.statement),"0"b));
	     else do;
		call ioa_("^vxfor:",tree_level);
		vector = p->label.statement;

		if vector -> node.type = label_array_element_node
		then do while(vector ^= null);
		     call ioa_("^vx^4x^a",tree_level,decode_node_id((vector->label_array_element.statement),"0"b));
		     vector = vector->label_array_element.next;
		     end;

		else do i = 1 to vector->list.number;
		     if vector->element(i) = null
			then call ioa_("^vx^4xNULL",tree_level);
			else call ioa_("^vx^4x^a",tree_level,decode_node_id((vector->element(i)),"0"b));
		     end;
		end;
	call ioa_("^vxdeclared by ^a",tree_level,declare_type(fixed(p->label.dcl_type,3,0)));
	call ioa_("^vxblock = ^p, token = ^p, next = ^p, statement = ^p",tree_level,
		p->label.block_node,p->label.token,p->label.next,p->label.statement);
	if p->label.allocated then call ioa_("^vxallocated bit is ON",tree_level);
	i=p->label.location;
	if i ^= 0 then call ioa_("^vxlocation = ^6w",tree_level,i);
	if p->label.array then call ioa_("^vxarray bit is ON, low bound = ^d, high bound = ^d",tree_level,
	 p -> label.low_bound,p -> label.high_bound);
	call ioa_("^vxEND LABEL ^p^/",tree_level,p);
	return;
    end;


	if p->node.type = default_node
	then do;
		call ioa_("^/^vxDEFAULT ^p, ^a",tree_level,p,decode_node_id(p,"0"b));

		q = p -> default.predicate;
		if q ^= null then call show_exp("predicate");

		if p->default.system then call ioa_("^vxdefault is system",tree_level);
		if p->default.error then call ioa_("^vxdefault is error",tree_level);
		if p->default.no_defaults then call ioa_("^vxdefault is no defaults",tree_level);

		call ioa_("^vxsymbol for default follows",tree_level);
		call display_symbol((p -> default.symbol),tree_level+1);

		call ioa_("^vxEND DEFAULT ^p^/",tree_level,p);
		return;

	     end;

if p->symbol.node_type ^= symbol_node then do;
	call display_any_node_name("display_symbol: arg is not a symbol node,
arg =",p,tree_level+1);
	return;
	end;

call ioa_("^/^vxSYMBOL ^p, is ^a",tree_level,p,p->symbol.token->t_table.string);
if p -> symbol.dcl_type = by_declare
then call ioa_("^vxdeclared by declare on ^a",tree_level,decode_node_id(p,"0"b));
else call ioa_("^vxdeclared by ^a",tree_level,declare_type(fixed(p -> symbol.dcl_type,17,0)));

call ioa_("^vxblock = ^p, token = ^p, next = ^p",tree_level,
	p->symbol.block_node,p->symbol.token,
	p->symbol.next);

if p->symbol.multi_use ^= null then call ioa_("^vxmulti_use = ^p",tree_level,p->symbol.multi_use);

k = p->symbol.level;
if k ^= 0 then call ioa_("^vxlevel = ^d",tree_level,k);

k = p->symbol.scale;
if k ^= 0 then call ioa_("^vxscale = ^d",tree_level,k);

k = fixed(p -> symbol.runtime,18);
if k ^= 0 then call ioa_("^vxruntime = ^o",tree_level,k);

k = fixed(p -> symbol.runtime_offset,18);
if k ^= 0 then call ioa_("^vxruntime offset = ^o",tree_level,k);

if p->symbol.father ^= null then call ioa_("^vxfather = ^p",tree_level,p->symbol.father);
if p->symbol.brother ^= null then call ioa_("^vxbrother = ^p",tree_level,p->symbol.brother);
if p->symbol.son ^= null then call ioa_("^vxson = ^p",tree_level,p->symbol.son);

i=p->symbol.boundary;
if i ^= 0 then call ioa_("^vxboundary is ^a",tree_level,boundary_type(i));

if p->symbol.allocated then call ioa_("^vxallocated bit is ON",tree_level);

i=p->symbol.location;
if i^= 0 then call ioa_("^vxlocation = ^6w (^d decimal)",tree_level,i,i);

q=p->symbol.cross_references;
if q ^= null then call ioa_("^vxcross_ref = ^p",tree_level,q);

i=p->symbol.c_word_size;
if i ^= 0 then call ioa_("^vxc_word_size = ^d",tree_level,i);

i=p->symbol.c_bit_size;
if i ^= 0 then call ioa_("^vxc_bit_size = ^d",tree_level,i);

i=p->symbol.c_dcl_size;
if i ^= 0 then call ioa_("^vxc_dcl_size = ^d",tree_level,i);

if string(p -> symbol.attributes) = "0"b
then do;
     call ioa_("^vxNo attributes",tree_level);
     goto long;
     end;

line = "Attributes:";
lp = 13;

do i = 1 to length(string(p -> symbol.attributes));
     if substr(string(p -> symbol.attributes),i,1)
     then if i <= hbound(names,1)
	then do;
	     n = length(names(i));
	     substr(line,lp,n) = names(i);
	     lp = lp + n + 1;

	     if lp > 72
	     then do;
		call ioa_("^vx^a",tree_level,line);
		line = "";
		lp = 1;
		end;

	     end;
     end;

if lp > 1 then call ioa_("^vx^a",tree_level,line);

long:	if p -> node.type ^= symbol_node then goto done;

	q=p->symbol.initial;
	if p->symbol.constant
	then if q = null then call ioa_("^vxconstant value ptr is NULL",tree_level);
		       else call display_constant(p,tree_level+1);
	else do;
		if q ^= null
		 then if q->node.type ^= list_node then call display_any_node_name("initial= ",q,tree_level+1);
		else call show("initial attributes",display_initial);
	end;

	if p->symbol.picture
	then do;
		call ioa_("^vxpicture attributes follows:",tree_level);
		if p->pic_fixed then call ioa_("^vxpic_fixed",tree_level);
		if p->pic_float then call ioa_("^vxpic_float",tree_level);
		if p->pic_char  then call ioa_("^vxpic_char ",tree_level);

		call ioa_("^vxpic_scale = ^d, pic_size = ^d",tree_level,p->pic_scale,p->pic_size);
		call ioa_("^vxend of picture attributes",tree_level);
	end;


q=p->symbol.array;
if q ^= null then call show("array data",display_array);

q=p->symbol.descriptor;
if q ^= null then call show_exp("descriptor");

q=p->symbol.equivalence;
if q ^= null then call show_exp("equivalences");

q=p->symbol.reference;
if q ^= null then do;
	call ioa_("^vxreference follows:",tree_level);
	call display_exp(q,tree_level+1);
	end;


q = p->symbol.general;
if q ^= null then call display_any_node_name("general = ",q,tree_level+1);

q = p -> symbol.word_size;
if q ^= null then call show_exp("word size exp");

q=p->symbol.bit_size;
if q ^= null then call show_exp("bit size exp");

q=p->symbol.dcl_size;
if q ^= null then call show_exp("dcl size exp");

q = p -> symbol.symtab_size;
if q ^= null then call show_exp("symtab size exp");

done:

	call ioa_("^vxEND SYMBOL ^p^/",tree_level,p);

return;

show_exp:	proc(message);

dcl		message char(*) aligned;

		if display_stat_$brief_display
		then call ioa_("^vx^a = ^p",tree_level,message,q);
		else do;
		     call ioa_("^vx^a:",tree_level,message);
		     call display_exp(q,tree_level+1);
		     end;

		end;

show:		proc(message,prog);

dcl		message char(*) aligned,
		prog entry(ptr,fixed bin);

		if display_stat_$brief_display
		then call ioa_("^vx^a = ^p",tree_level,message,q);
		else do;
		     call ioa_("^vx^a:",tree_level,message);
		     call prog(q,tree_level+1);
		     end;

		end;

display_initial: proc(listp);

dcl	(listp,q) ptr;

	q=listp;
	do while(q^=null);
	call ioa_("^vxfactor = ",tree_level);
	call display_exp((q->list.element(1)),tree_level+1);
	if q->list.element(2) ^= null
	then if q->list.element(2)->node.type ^= list_node
	     then do;
		call ioa_("^vxvalue =",tree_level);
		call display_exp((q->list.element(2)),tree_level+1);
		end;
	     else call display_initial((q->list.element(2)));
	else call ioa_("vx^a",tree_level,"value = ""*""");
	q=q->list.element(3);
	end;
end display_initial;

end display_symbol;




		    display_xfer_vector.alm         11/15/82  1819.8rew 11/15/82  1533.2        5409



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

	name	display_xfer_vector
	entry	decode_node_id
decode_node_id:
	tra	<lang_util_>|[decode_node_id]
	end




		    meter_token_table.pl1           11/15/82  1819.8rew 11/15/82  1503.4       16668



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/*	Entry to gather some statistics about the hash table. */

meter_token_table:
     procedure;

/* automatic */

dcl	(tokcnt,tokwords,empty_slots,maximum) fixed bin(15);
dcl	n fixed bin;
dcl	p ptr;
dcl	sysprint file print;
dcl	i fixed bin;

/* builtins */

dcl	(currentsize, null) builtin;

/* entries */

dcl	com_err_ entry options (variable);

/* external static */

dcl	cg_static_$debug bit (1) aligned external static;

/* include files */

%include pl1_token_hash_table;
%include token;
%include system;

/* program */

	if ^cg_static_$debug
	then do;
		call com_err_ (0, "meter_token_table", "No tree available. -debug control argument must be used.");
		return;
	     end;

	maximum, n, tokcnt, tokwords, empty_slots = 0;
	do i = lbound (hash_table, 1) to hbound (hash_table, 1);

	     p = hash_table (i);

	     if p = null
	     then empty_slots = empty_slots + 1;

	     do while (p ^= null);
		tokcnt = tokcnt + 1;
		tokwords = tokwords + currentsize (p -> token);
		n = n + 1;
		p = p -> token.next;
	     end;

	     maximum = max (maximum, n);		/* find the maximum # of tokens in a slot */
	     n = 0;
	end;

	put file (sysprint) skip data (tokcnt, tokwords, empty_slots, maximum);
	put file (sysprint) skip list ("Average tokens/slot = ", tokcnt / float (dim (hash_table, 1)));
	put file (sysprint) skip;
	return;

     end;




		    peek.pl1                        11/15/82  1819.8rew 11/15/82  1503.5       17253



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


peek:	proc(string);

/*	Modified: 1 April 1980 by PCK to add by_name_agg	*/

dcl	string char(*);

dcl	p ptr static,
	set bit(1) aligned,
	debug entry,
	(index,null,ptr,substr) builtin,
	pl1_stat_$root ptr ext,
	cu_$arg_count entry returns(fixed bin),
	cv_oct_ entry(char(*) aligned) returns(fixed bin),
	n fixed bin;

%include by_name_agg;
%include reference;
%include operator;
%include symbol;
%include statement;
%include label;
%include list;
%include block;
%include context;
%include token;
%include cross_reference;
%include machine_state;
%include temporary;
%include array;
%include default;
%include sf_par;
%include fdata_nodes;

	set = "0"b;

join:	if cu_$arg_count() = 0 then p = null;
	else do;
	     n = index(string,"|");
	     if n = 0 then p = ptr(pl1_stat_$root,cv_oct_((string)));
	     else p = ptr(baseptr(cv_oct_(substr(string,1,n-1))),cv_oct_(substr(string,n+1)));
	     end;

	if ^ set then call debug;

	return;

l:	p -> reference.symbol,
	p -> symbol.reference,
	p -> operator.operand(1),
	p -> block.son,
	p -> token.next,
	p -> temporary.next,
	p -> context.next,
	p -> label.next,
	p -> cross_reference.next,
	p -> list.element(1),
	p -> machine_state.next,
	p -> array.bounds,
	p -> bound.lower,
	p -> default.next,
	p -> sf_par.parsym,
	p -> data_list.next,
	p -> by_name_agg.next,
	p -> statement.root = p;
	return;

peek$set: entry(string);

	set = "1"b;
	goto join;

	end;




		    show_declaration.pl1            11/15/82  1819.8rew 11/15/82  1503.7       23481



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


show_declaration: proc;

/*	Modified: 29 Nov 1979 by PCK to print tree level indented listing */
/*	Modified: 25 Jun 1980 by PCK to properly indent block listing */

dcl	missing(10) bit(1) int static,
	(i,j,n,code) fixed bin(17),
	tree_level fixed bin initial(0),
	p ptr,
	display_symbol ext entry(ptr,fixed bin),
	symb(10) char(68) varying int static,
	cu_$arg_count ext entry(fixed bin(17)),
	cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(17)),
	n_args fixed bin(17) int static,
	ioa_ ext entry options(variable),
	pl1_stat_$root ptr ext static;

dcl	(length,null) builtin;

dcl	arg_string char(n) based;

%include block;
%include symbol;
 
	call cu_$arg_count(n_args);
	if n_args=0 then return;

	j = 0;
	do i = 1 to n_args;
	     call cu_$arg_ptr(i,p,n,code);

	     if code ^= 0
	     then do;
		call ioa_("NO ARG ^d",i);
		return;
		end;

	     if n = 0 then go to loop;

	     if j >= 10
	     then do;
		call ioa_("Only 10 symbols allowed");
		n_args = 10;
		goto l;
		end;

	     j = j + 1;
	     symb(j) = p -> arg_string;
	     missing(j) = "1"b;
loop:	end;

	if j = 0 then return;
	n_args=j;

l:	call search(pl1_stat_$root,tree_level+1);

	do i = 1 to n_args;
	     if missing(i)
	     then call ioa_("No declaration found for ^a",symb(i));
	     end;

	return;

search:	     proc(pt,tree_level);

dcl	     pt ptr;	/* points at block node */
dcl	     tree_level fixed bin;

dcl	(p,q) ptr;

%include token;

	     if pt = null then return;

	     call ioa_("^/^vxStart of block ^p",tree_level,pt);

	     p = pt -> block.declaration;
	     do while(p ^= null);

		q = p -> symbol.token;
		n = q -> token.size;

		do i = 1 to n_args;
		     if n = length(symb(i))
		     then if symb(i) = q -> token.string
		     then do;
			missing(i) = "0"b;
			call display_symbol(p,tree_level+1);
			goto do_next;
			end;
		end;

do_next:		p = p -> symbol.next;
		end;

	     q = pt -> block.son;

	     do while(q^=null);
		call search((q),tree_level+1);
		q = q -> block.brother;
	     end;

	     call ioa_("^vxEnd of block ^p^/",tree_level,pt);
	     end;

	end show_declaration;




		    show_ms.pl1                     11/15/82  1819.8rew 11/15/82  1503.8       37593



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


show_ms:	proc;

dcl	(i,n) fixed bin,
	p ptr unal,
	lword char(8),
	ioa_ entry options(variable);

dcl	(abs,null) builtin;


%include machine_state;

show:	if m_s_p = null
	then do;
	     call ioa_("Machine state pointer is null");
	     return;
	     end;

	call ioa_("MACHINE STATE ^p: indicators = ^d, next = ^p",m_s_p,indicators,next);

	if indicators = -2
	then do;
	     call ioa_("^/INDICATOR REFERENCES:");
	     call prt(indicators_ref(2));
	     call prt(indicators_ref(3));
	     end;

	if a_reg.number ^= 0
	then do;
	     call ioa_("^/A REGISTER: # = ^d, size = ^d, length = ^d, offset = ^d, constant = ^d",
	      a_reg.number,a_reg.size,a_reg.length,a_reg.offset,a_reg.constant);
	     call ioa_("changed by ^12w at ^o",a_reg.instruction,a_reg.changed);

	     do i = 1 to a_reg.number;
		call prt(a_reg.variable(i));
		end;

	     if a_reg.locked
	     then do;
		call ioa_("locked");
		if a_reg.number_h_o ^= 0
		then do;
		     call ioa_("has offset of ^d references",a_reg.number_h_o);
		     do i = 1 to a_reg.number_h_o;
			call prt(a_reg.has_offset(i));
			end;
		     end;
		end;

	     end;

	if q_reg.number ^= 0
	then do;
	     call ioa_("^/Q REGISTER: # = ^d, size = ^d, length = ^d, offset = ^d, constant = ^d",
	      q_reg.number,q_reg.size,q_reg.length,q_reg.offset,q_reg.constant);
	     call ioa_("changed by ^12w at ^o",q_reg.instruction,q_reg.changed);

	     do i = 1 to q_reg.number;
		call prt(q_reg.variable(i));
		end;

	     if q_reg.locked
	     then do;
		call ioa_("locked");
		if q_reg.number_h_o ^= 0
		then do;
		     call ioa_("has offset of ^d references",q_reg.number_h_o);
		     do i = 1 to q_reg.number_h_o;
			call prt(q_reg.has_offset(i));
			end;
		     end;
		end;

	     end;

	p = string_reg.variable;
	if p ^= null
	then do;
	     call ioa_("^/STRING REGISTER: size = ^d, offset = ^d",string_reg.size,string_reg.offset);
	     call prt(p);
	     end;

	p = complex_reg.variable;
	if p ^= null
	then do;
	     call ioa_("^/COMPLEX REGISTER: size = ^d, scale = ^d",complex_reg.size,complex_reg.scale);
	     call prt(p);
	     end;

	p = decimal_reg.variable;
	if p ^= null
	then do;
	     call ioa_("^/DECIMAL REGISTER: size = ^d, scale = ^d",decimal_reg.size,decimal_reg.scale);
	     call prt(p);
	     end;

	do i = 0 to 7;
	     n = index_regs(i).type;
	     if n ^= 0
	     then do;
		call ioa_("^/INDEX REGISTER ^d: type = ^d, constant = ^o",i,
		 n,index_regs(i).constant);
		call ioa_("used at ^o, changed by ^12w at ^o",index_regs(i).used,
		 index_regs(i).instruction,index_regs(i).changed);
		if abs(n) >= 2 then call prt(index_regs(i).variable);
		end;
	     end;

	do i = 1 to 6;
	     n = base_regs(i).type;
	     if n ^= 0
	     then do;
		call ioa_("^/BASE REGISTER ^d: type = ^d, constant = ^o",i,
		 n,base_regs(i).constant);
		call ioa_("used at ^o, changed by ^12w at ^o",base_regs(i).used,
		 base_regs(i).instruction,base_regs(i).changed);
		p = base_regs(i).variable;
		if n < 3 then call prt(p);
		else if substr("110001101100"b,n,1)
		     then call ioa_("variable is ^p",p);
		if base_regs(i).locked ^= 0
		     then call ioa_("locked = ^d",base_regs(i).locked);
		end;

	     end;

	call ioa_("^/END MACHINE STATE ^p^/",m_s_p);
	return;

show_ms$pt: entry(pt);

dcl	pt ptr;

	m_s_p = pt;
	goto show;

prt:	     proc(q);

%include reference;
%include symbol;
%include token;

dcl	     (q,t) ptr unal;

	     if q = null then return;

	     t = q -> reference.symbol -> symbol.token;
	     if q -> reference.shared then call ioa_("variable ^p is ^a",q,t -> token.string);
	     else call ioa_("variable ^p is ^a, ref count = ^d",q,t -> token.string,q -> ref_count);

	     end;

	end;




		    show_statement.pl1              11/15/82  1819.8rew 11/15/82  1503.9       28332



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


show_statement: proc(string);

/*	Modified: 29 Nov 1979 by PCK to print a tree level indented listing */
/*	Modified: 24 Jun 1980 by PCK to properly indent the output of show_stm */

dcl	string	char(*);	/* source id of statement to show */

dcl	(k,n) fixed bin(15),
	tree_level fixed bin initial(0),
	ln fixed bin(15),
	(sn,fn) fixed bin(6),
	p ptr,
	number int static fixed bin(31),
	any int static bit(1),
	pl1_stat_$root ptr ext,
	ioa_ entry options(variable),
	cv_dec_ entry(char(*) aligned) returns(fixed bin),
	display_statement entry(ptr,bit(1) aligned,fixed bin);

dcl	(fixed,index,null,substr) builtin;


%include block;
%include statement;

if pl1_stat_$root = null
   then do;
	call ioa_("No tree available");
	return;
        end;
if string = "" then do;
	call ioa_("show_statement line#.statement# (s# is opt.)");
	return;
	end;

	fn = 0;

	n = index(string,".");

	if n = 0
	then do;
	     any = "1"b;
	     ln = cv_dec_((string));
	     sn = 0;
	     end;
	else do;
	     any = "0"b;
	     k = index(substr(string,n+1),".");
	     if k = 0
	     then do;
		ln = cv_dec_(substr(string,1,n-1));
		sn = cv_dec_(substr(string,n+1));
		end;
	     else do;
		fn = cv_dec_(substr(string,1,n-1));
		ln = cv_dec_(substr(string,n+1,k-1));
		sn = cv_dec_(substr(string,n+k+1));
		end;
	     end;

	if any then call ioa_("Searching for line ^d",ln);
	else call ioa_("Searching for statement ^d on line ^d",sn,ln);

	number = 0;
	call show_stm(pl1_stat_$root -> block.son,tree_level+1);

	if number = 0 then call ioa_("Statement not found.");

show_stm:      proc(ptx,tree_level);

dcl	     ptx ptr unaligned;
dcl	     tree_level fixed bin;

dcl	     (p,q,pt) ptr;

	     pt = ptx;
	     if pt = null then return;

	     call ioa_("^/^vxStart of block ^p",tree_level,pt);

	     p = pt -> block.prologue;

	     call check_stm(p,tree_level);

	     p = pt -> block.main;

	     call check_stm(p,tree_level);

	     q = pt -> block.son;



	     do while(q^=null);
		call show_stm((q),tree_level+1);
		q = q -> block.brother;
	     end;

	     call ioa_("^vxEnd of block ^p^/",tree_level,pt);

	     end;


check_stm:     proc(pt,tree_level);

dcl	     (pt,q) ptr,
	     tree_level fixed bin,
	     this_sn fixed bin(9);

	     q = pt;
	     do while(q ^= null);

		if any then this_sn = 0;
		else this_sn = fixed(q -> statement.statement_number,5);

		if fixed(q -> statement.line_number,14) = ln
		then if this_sn = sn
		     then if fixed(q -> statement.file_number,8) = fn
			then do;
			     number = number + 1;
			     call display_statement(q,"1"b,tree_level+1);
			     end;

		q = q -> statement.next;
		end;

	     end;

	end;




		    stop_at.pl1                     11/15/82  1819.8rew 11/15/82  1504.0       11772



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


stop_at:	proc(string);

dcl	string char(*) unaligned,
	(index, substr) builtin,
	ln fixed bin(14),
	fn fixed bin(8),
	sn fixed bin(5),
	(k,n) fixed bin,
	cv_dec_ entry(char(*) aligned) returns(fixed bin),
	(pl1_stat_$stop_id, cg_static_$stop_id) bit(27) external static;

	n = index(string,".");
	fn = 0;

	if n = 0
	then do;
	     ln = cv_dec_((string));
	     sn = 1;
	     end;
	else do;
		k = index(substr(string,n+1),".");
		if k = 0
		then do;
		     ln = cv_dec_(substr(string,1,n-1));
		     sn = cv_dec_(substr(string,n+1));
		     end;
		else do;
		     fn = cv_dec_(substr(string,1,n-1));
		     ln = cv_dec_(substr(string,n+1,k-1));
		     sn = cv_dec_(substr(string,n+k+1));
		     end;
	     end;

	cg_static_$stop_id,
	pl1_stat_$stop_id = bit(fn,8) || bit(ln,14) || bit(sn,5);

	end;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
