



		    adjust_count.pl1                07/31/89  1433.2r w 07/31/89  1338.2       21834



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


/* this routine  is called to adjust the reference counts in a subtree.
   If a given node in the tree has no reference count, no further
   processing is necessary.  If it has a count, the count is reduced by one.
   If that reduces it to zero, the node is freed and the routine is called to
   process the subexpressions.  */

adjust_count: proc(pt);

dcl	(pt,t,s) ptr;
dcl	shared bit(1) aligned;
dcl	i fixed bin(15);
dcl	null builtin;

%include nodes;
%include reference;
%include operator;
%include op_codes;
%include list;
%include language_utility;

begin:
	t = pt;
	if t = null then return;
	if t->node.type = reference_node
	     then do;
		if t->reference.shared then return;
		t->reference.ref_count = t->reference.ref_count-1;
		if t->reference.ref_count = 0
		     then do;
			if t->reference.offset ^= null then call adjust_count((t->reference.offset));
			if t->reference.length ^= null then call adjust_count((t->reference.length));
			if t->reference.qualifier ^= null then call adjust_count((t->reference.qualifier));
			call free_node(t);
			end;
		return;
		end;
	if t->node.type = operator_node
	     then if t->operator.number > 0
		then if t->operator.operand(1) ^= null
		     then do;
			s = t->operator.operand(1);

			shared = s->reference.shared;

			if ^shared
			then do;
			     if t->operator.op_code = std_call
				then i = 2;
				else i = 1;
			     if s->reference.ref_count - i ^= 0
			     then do;
				s->reference.ref_count = s->reference.ref_count - 1;
				return;
				end;
			     end;

			if ^t->operator.optimized
			then do i = 1 to t->operator.number;
			     call adjust_count((t->operator.operand(i)));
			     end;

			if ^shared
			     then call free_node(t);
			     else t -> operator.optimized = "1"b;
			return;
			end;
	if t->node.type = list_node
	     then do i = 1 to t->list.number;
		call adjust_count((t->list.element(i)));
		end;
	end; /* adjust_count */





		    binary_to_octal_string.pl1      10/03/83  1728.7rew 10/03/83  1007.1       14976



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


binary_to_octal_string: procedure(integer,nonvarying);

	vs = "0"b;
	go to begin;

dcl integer fixed bin(35) parameter;
dcl (addr,mod,substr) builtin;
dcl number fixed bin(35);
dcl bit_number bit(36) based(addr(number)) aligned;
dcl string char(12);
dcl nonvarying char(12);
dcl varying char(12) varying;
dcl 1 bit_string_overlay aligned based(addr(string)),
    2 bit_string(0:11) bit(9) unaligned;
dcl (i,j,l) fixed bin;
dcl vs bit(1) aligned;
dcl spaces char(12) aligned internal static initial((12)" ");

binary_to_octal_var_string: entry(integer,varying);

	vs = "1"b;
begin:
	number = integer;
	i = 0;
	if number < 0
	then do;
		number = -number;
		i = 1;
		substr(string,1,1) = "-";
	     end;

	j = index(bit_number,"1"b);
	if j = 0
	then do;
		string = "0";
		i = 1;
		go to return;
	     end;

	l = mod(j,3);
	if l = 0
	then j = j - 2;
	else j = j - l + 1;

	bit_number = substr(bit_number,j);
	do j = j to 34 by 3;
	bit_string(i) = "000110"b || substr(bit_number,1,3);
	bit_number = substr(bit_number,4);
	i = i + 1;
	end;

return:
	if vs
	then varying = substr(string,1,i);
	else nonvarying = substr(spaces,1,(12-i))||substr(string,1,i);
end;




		    bindec.alm                      10/03/83  1728.7rew 10/03/83  1007.1       15498



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

" quick binary to decimal conversion program for v2pl1
" Barry L. Wolman, 17 May 1973
"
"	dcl bindec entry(fixed bin) returns(char(12) aligned)
"	y = bindec(x)
"
"	dcl bindec$vs entry(fixed bin) returns(char(12) varying)
"	z = bindec$vs(x)
"
	entry	bindec
	entry	vs

	equ	t,56		in stack frame of caller!!!
"
	bool	blank,040

	include	eis_micro_ops

bindec:	epp2	0|2,*		get ptr to x
	btd	(pr),(pr)		convert to decimal
	desc9a	2|0,4
	desc9ls	6|t,12
	epp2	0|4,*		get ptr to y
	mvne	(pr),(),(pr)		move into y with editing
	desc9ls	6|t,12
	vfd	18/edit,18/5
	desc9a	2|0,12
	short_return
"
vs:	epp2	0|2,*		get ptr to x
	btd	(pr),(pr)		and convert
	desc9a	2|0,4
	desc9ls	6|t,12
	epp2	0|4,*		get ptr to z
	mvne	(pr),(),(pr)	move into t(pr)get with editing
	desc9ls	6|t,12
	vfd	18/edit,18/5
	desc9a	2|0,12
	scmr	(pr),(du)		scan from right for blank
	desc9a	2|0,12
	vfd	o9/040
	arg	6|t
	ttn	no_blanks
	ldq	6|t		get number non-blank characters
	stq	2|-1		set length of varying string
	lda	12,dl		compute number of leading blanks
	sba	6|t
	mlr	(pr,rl,al),(pr,rl)	eliminate leading blanks
	desc9a	2|0,ql
	desc9a	2|0,ql
	short_return
"
no_blanks:
	lda	12,dl
	sta	2|-1
	short_return
"
edit:	vfd	9/lte+3,o9/blank,9/mfls+10,9/enf,9/mvc+1
	end




		    binoct.alm                      10/03/83  1728.7rew 10/03/83  1007.1       17136



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

" BINOCT - BINARY TO OCTAL ASCII CONVERSION FOR PL/1 PROGRAMS
"	4/2/74 - Richard A. Barnes
"	Improved 9/3/76 by Noel I. Morris
"
" This version based on bin_to_oct by Gordon Benedict
"
" Calling sequence:
"
" dcl	b36 aligned bit(36), s12 aligned char(12),
"	binoct entry(aligned bit(36)) returns(aligned char(12));
"
"	s12 = binoct(b36);
"
	segdef	binoct
"
	equ	pr0,0
	equ	pr1,1
	equ	pr2,2
"
binoct:	
	epp1	pr0|2,*		get ptr to number to be converted
	epp2	pr0|4,*		get ptr to result
"
"	we will use last few bytes of the result string
"	as a temporary location for the translation
"
	mvt	(pr),(pr)		unpack and translate
	desc6a	pr1|0,6		6-bit bytes...
	desc9a	pr2|1(2),6	-> 9-bit bytes...
	arg	table		under translation
"
	mvn	(pr),(pr)		make into ASCII
	desc4ns	pr2|1(4),12	4-bit bytes...
	desc9ns	pr2|0,12		-> 9-bit bytes
"
	short_return
"
table:
	vfd	5/0,4/0,5/0,4/1,5/0,4/2,5/0,4/3,5/0,4/4,5/0,4/5,5/0,4/6,5/0,4/7
	vfd	5/1,4/0,5/1,4/1,5/1,4/2,5/1,4/3,5/1,4/4,5/1,4/5,5/1,4/6,5/1,4/7
	vfd	5/2,4/0,5/2,4/1,5/2,4/2,5/2,4/3,5/2,4/4,5/2,4/5,5/2,4/6,5/2,4/7
	vfd	5/3,4/0,5/3,4/1,5/3,4/2,5/3,4/3,5/3,4/4,5/3,4/5,5/3,4/6,5/3,4/7
	vfd	5/4,4/0,5/4,4/1,5/4,4/2,5/4,4/3,5/4,4/4,5/4,4/5,5/4,4/6,5/4,4/7
	vfd	5/5,4/0,5/5,4/1,5/5,4/2,5/5,4/3,5/5,4/4,5/5,4/5,5/5,4/6,5/5,4/7
	vfd	5/6,4/0,5/6,4/1,5/6,4/2,5/6,4/3,5/6,4/4,5/6,4/5,5/6,4/6,5/6,4/7
	vfd	5/7,4/0,5/7,4/1,5/7,4/2,5/7,4/3,5/7,4/4,5/7,4/5,5/7,4/6,5/7,4/7
"
	end




		    compare_expression.pl1          10/03/83  1728.7rew 10/03/83  1007.1       26901



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


compare_expression: proc(ap,bp) reducible returns(bit(1) aligned);

dcl	(ap,bp) ptr;	/* pointers at nodes to be compared */

dcl	(a,b,r) ptr,
	(i,n) fixed bin,
	b_op_code bit(9) aligned,
	null builtin;

%include list;
%include nodes;
%include operator;
%include reference;
%include symbol;
%include op_codes;

	a = ap;
	b = bp;

	if a = b then goto exit;

	if a = null then goto fail;
	if b = null then goto fail;

	if a -> node.type ^= b -> node.type then goto fail;

	if a -> node.type = temporary_node then go to fail;

	if a -> node.type = token_node then go to fail;

	if a -> node.type = operator_node
	then do;
	     b_op_code = b -> operator.op_code;
	     if a -> operator.op_code ^= b_op_code then goto fail;
	     if a -> operator.number ^= b -> operator.number then goto fail;

	     do i = 1 to a -> operator.number;
		if a -> operand(i) ^= b -> operand(i)
		then if ^ compare_expression((a -> operand(i)),(b -> operand(i)))
		     then goto fail;

		end;

	     if b_op_code = std_call
	     then do;
		r = b -> operand(2);
		if r -> node.type = operator_node
		     then r = r -> operand(1);
		if r -> reference.symbol -> symbol.irreducible
		     then goto fail;
		end;

	     goto exit;
	     end;

	if a -> node.type = list_node
	then do;
	     if a -> list.number ^= b -> list.number then goto fail;

	     do i = 1 to a -> list.number;
		if a -> element(i) ^= b -> element(i)
		then if ^ compare_expression((a -> element(i)),(b -> element(i)))
		     then goto fail;

		end;

	     goto exit;
	     end;

	if a -> reference.symbol ^= b -> reference.symbol then goto fail;
	if a -> reference.c_length ^= b -> reference.c_length then goto fail;
	if a -> reference.c_offset ^= b -> reference.c_offset then goto fail;
	if a -> reference.units ^= b -> reference.units then goto fail;
	if a -> reference.array_ref ^= b -> reference.array_ref then goto fail;
	if a -> reference.modword_in_offset ^= b -> reference.modword_in_offset then goto fail;

	if a -> reference.length ^= b -> reference.length
	then if ^ compare_expression((a -> reference.length),(b -> reference.length))
	     then goto fail;

	if a -> reference.offset ^= b -> reference.offset
	then if ^ compare_expression((a -> reference.offset),(b -> reference.offset))
	     then goto fail;

	if a -> reference.qualifier ^= b -> reference.qualifier
	then if ^ compare_expression((a -> reference.qualifier),(b -> reference.qualifier))
	     then goto fail;

exit:	return("1"b);

fail:	return("0"b);
	end;




		    constant_length.pl1             10/03/83  1728.7rew 10/03/83  1007.1       19845



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


/* Check to see if the length argument is equal to a constant	*/

constant_length:
     procedure (P_tree, P_constant_value) returns (bit (1) aligned);

/* parameter */

dcl	(
	P_tree		ptr,
	P_constant_value	fixed bin (71)
	)		parameter;

/* automatic */

dcl	tree		ptr;

/* builtins */

dcl	null		builtin;

/* program */

	tree = P_tree;

	if tree -> reference.length = null
	then do;
		if tree -> reference.c_length ^= P_constant_value
		then return ("0"b);

		return ("1"b);
	     end;

	if tree -> reference.length -> node.type = operator_node
	then if tree -> reference.length -> operator.op_code = range_ck
	     then if tree -> reference.length -> operand (2) -> node.type = reference_node
		then if tree -> reference.length -> operand (2) -> reference.symbol -> symbol.constant
		     then if constant_value ((tree -> reference.length -> operand (2) -> reference.symbol))
			     ^= P_constant_value
			then return ("0"b);
			else return ("1"b);

	return ("0"b);

/* get the initial value of a fixed binary variable with a scale factor of zero */

constant_value:
     procedure (sym_ptr) returns (fixed bin (71));

/* parameter */

dcl	sym_ptr		ptr;

/* based */

dcl	integer_1		based fixed bin (35);
dcl	integer_2		based fixed bin (71);

/* automatic */

dcl	initial_value	fixed bin (71);

	if sym_ptr -> symbol.c_dcl_size > max_p_fix_bin_1
	then initial_value = sym_ptr -> symbol.initial -> integer_2;
	else initial_value = sym_ptr -> symbol.initial -> integer_1;

	return (initial_value);

     end /* constant_value */;

/* include files */

%include nodes;
%include op_codes;
%include operator;
%include reference;
%include symbol;
%include system;
     end /* constant_length */;




		    convert.pl1                     07/31/89  1433.2r w 07/31/89  1338.2      214029



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


/* Modified 780427 by PG to get ready for unsigned */
/* Modified 790419 by PCK to implement 4-bit decimal */
/* Modified 790840 by PCK to fix 1791 */
/* Modified 800103 by RAB to fix 1680 in which passing a label constant as arg
   sometimes fails. */
/* Modified 830509 BIM to check explicit_packed as part of alignment. ycch. */

convert: 	proc (tree, bv_target_type) returns (ptr);

/* parameters */

dcl	(tree ptr,
	bv_target_type bit (36) aligned) parameter;

/* automatic */

dcl	(p,r,target_ref,target,input,output,inlength,tlength,return_tree) ptr,
	(pointer1,pointer2) (32) ptr aligned,
	(m, n, svprec) fixed bin;

dcl	(alignment_ok, known, sign_type_ok, validate_bit) bit(1) aligned, 
	long_bit bit(1) aligned init("0"b),
	target_must_be_integer bit(1) aligned init("0"b),
	keep_full_precision bit(1) aligned init("0"b),
	suppress_bit bit(1) aligned init("1"b),
	varying_input bit(1) aligned init("0"b),
	varying_result bit(1) aligned init("0"b);

dcl	1 itype like type;
dcl	1 otype like type;
dcl	1 inpicture like type;
dcl	1 tpicture like type;

/* based */

dcl	value1 bit(2304) aligned based(addr(pointer1(1)));
dcl	value2 bit(2304) aligned based(addr(pointer2(1)));
dcl	char_target char(outclength) based aligned;
dcl	bit_target bit(outclength) based aligned;

/* builtin */

dcl	(null,binary,addr,bit,divide,fixed,sign,min,max,abs,log10,string,substr,ceil) builtin;

/* conditions */

dcl	(conversion,fixedoverflow,overflow,underflow,size,stringsize) condition;

/* defined */

dcl	defined_itype bit (36) defined (itype);
dcl	defined_otype bit (36) defined (otype);

/* entries */

dcl	(pl1_stat_$util_abort, pl1_stat_$util_error) variable external static entry(fixed bin, ptr);

/* external static */

dcl	pl1_stat_$cur_statement ptr ext static;

/* internal static */

dcl	plain_desc_type (46) fixed bin int static /* map descriptor types ignoring precision, varying, unsigned attributes */
		init (	1, 1, 3, 3, 5, 5, 7, 7, 9, 10, 11, 12,
			13, 14, 15, 16, 17, 18, 19, 19, 21, 21, 23, (9)0, 1, 1, (8)0, 9, 10, 11, 12);

dcl	simplify_for_message (0:46) fixed bin int static initial (10, (12)1, 4, 5, 7, 8, 10, 6, 2, 2, 3, 3, 9,
	(9)0, 1, 1, (8)0, (4)1);	/* maps descriptor types into subscripts for message array, below. */

/* The values of the simplify array, and the subscripts into the message array, are assigned as follows:
	1 = arithmetic	6 = area
	2 = bit		7 = label
	3 = char		8 = entry
	4 = ptr		9 = file
	5 = offset	10 = structure or undefined
*/

dcl	message (9, 9) fixed bin int static init (
					   0,-234,-234, 231, 231, 249, 229, 223, 251,
					-236,   0,-487, 231, 231, 249, 229, 223, 251,
					-236,-489,   0, 231, 231, 249, 229, 223, 251,
					 227, 225, 225,   0,   0, 249, 229, 223, 251,
					 227, 225, 225,   0,   0, 249, 229, 223, 251,
					 227, 225, 225, 231, 231,   0, 229, 223, 251,
					 227, 225, 225, 231, 231, 249,   0, 223, 251,
					 227, 225, 225, 231, 231, 249, 229,   0, 251,
					 227, 225, 225, 231, 231, 249, 229, 223,   0);

/* program */

	suppress_bit = "0"b;
	go to start;

to_integer:
	entry (tree, bv_target_type) returns (ptr);

	target_must_be_integer = "1"b;
	suppress_bit = "0"b;

from_builtin:
	entry (tree, bv_target_type) returns (ptr);

start:
	validate_bit = "0"b;
	known = "0"b;
	outscale_prec = 0;
	tlength = null;
	string (otype) = bv_target_type & convert_mask;
	string (inpicture) = "0"b;
	string (tpicture) = "0"b;
	go to common;

validate:	entry(tree,target_ref);

	suppress_bit = "0"b;
	validate_bit="1"b;
	goto meet;

to_target_fb:	entry(tree,target_ref) returns(ptr);

	validate_bit = "0"b;
	keep_full_precision = "1"b;
	goto meet;

to_target:	entry(tree,target_ref) returns(ptr);

	suppress_bit  ,
	validate_bit="0"b;

		/*   the second argument is a reference_node,
		     get output type and other output attributes,
		     therefore   the known bit is on     */
meet:
	known = "1"b;

	/* initialize important vars, just in case */

	outscale_prec = 0;
	tlength = null;

	string (inpicture) = "0"b;
	string (tpicture) = "0"b;
	if target_ref = null then call print(248);
	if target_ref->node.type ^= reference_node then call print(248);

	target = target_ref->reference.symbol;

	if target->node.type=label_node
	then do;
		defined_otype = label_mask;
		goto common;
	end;

	if target->symbol.bit | target->symbol.char | target->symbol.picture
	then do;
		tlength = target_ref->reference.length;
		outclength = target_ref->reference.c_length;

		if target_ref->reference.varying_ref
		then do;
			known = "0"b;
			varying_result = "1"b;
		end;
	end;

	else
	if target->symbol.fixed | target->symbol.float
	then do;
		tlength = null;
		outprec = target->symbol.c_dcl_size;
		outscale = target->symbol.scale;
	end;

	else
	if target->symbol.arg_descriptor
	then do;
		tlength = null;
		outprec = default_fix_bin_p;
		outscale = 0;
		defined_otype = integer_type;
		goto common;
	end;

	string (otype) = substr (string (target -> symbol.attributes), 1, 36) & convert_mask;

	if target->symbol.picture
	then do;
		string(tpicture) = string(otype);

		if target->symbol.pix.pic_char
		then	defined_otype = defined_otype & ^picture_mask | char_mask;
		else do;
			defined_otype = defined_otype & ^picture_mask  & ^unaligned_mask | aligned_mask | decimal_mask;

			outprec = target->symbol.pix.pic_size;

			if ^target->symbol.complex
			then	defined_otype = defined_otype | real_mask;

			if target->symbol.pix.pic_fixed
			then do;
				defined_otype = defined_otype | fixed_mask;
				outscale = target->symbol.pix.pic_scale;
			end;
			else	defined_otype = defined_otype | float_mask;
		end;
	end;

		/*   get input type and other input attributes   */

common:
	outtype = pl1_descriptor_type(defined_otype,(outprec));
	inlength = null;
	inscale_prec = 0;
	if tree = null then call print(248);

	if tree->node.type = token_node then go to token_input;

	if tree->node.type = operator_node
	then	r = tree->operator.operand(1);
	else	r = tree;

	if r = null then call print(248);

	if r->node.type = label_node
	then	if outtype = label_dtype
		then	if validate_bit
			then	return;
			else	goto assign_it;
		else	call print(message(7,simplify_for_message(outtype)));

	if r->node.type ^= reference_node then call print(248);

/* The input is a reference or an operator. */

	input = r->reference.symbol;
	if input->node.type=label_node
	then do;
		intype = label_dtype;
		goto meet2;
	end;

	if input->symbol.fixed | input->symbol.float
	then do;
		inprec = input->symbol.c_dcl_size;
		inscale = input->symbol.scale;
	end;

	if input->symbol.bit | input->symbol.char | input->symbol.picture
	then	if r->reference.varying_ref
		then do;
			varying_input = "1"b;
			inclength = 0;
			inlength = create_operator(length_fun,2);
			inlength->operator.processed = "1"b;
			inlength->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
			inlength->operand(2) = tree;
		end;
		else do;
			inclength = r->reference.c_length;
			inlength = r->reference.length;
		end;

	if input->symbol.arg_descriptor
	then do;
		inlength = null;
		inprec = default_fix_bin_p;
		inscale = 0;
		defined_itype = integer_type;
	end;
	else	defined_itype = substr (string (input -> symbol.attributes), 1, 36);

	if input->symbol.picture
	then do;
		string(inpicture) = string(itype);

		if input->symbol.pix.pic_char
		then	defined_itype = defined_itype & ^picture_mask | char_mask;
		else do;
			defined_itype = defined_itype & ^picture_mask & ^unaligned_mask | aligned_mask | decimal_mask;

			inprec = input->symbol.pix.pic_size;

			if ^input->symbol.complex
			then	defined_itype = defined_itype | real_mask;

			if input->symbol.pix.pic_fixed
			then do;
				defined_itype = defined_itype | fixed_mask;
				inscale = input->symbol.pix.pic_scale;
			end;
			else	defined_itype = defined_itype | float_mask;
		end;
	end;

	intype = pl1_descriptor_type(defined_itype,(inprec));

/* check the legality of this attempted conversion. */

meet2:
	if validate_bit & plain_desc_type(intype)=plain_desc_type(outtype)
	then return;

	if simplify_for_message(intype)>9 then call pl1_stat_$util_abort(130,input);
	if simplify_for_message(outtype)>9 then call pl1_stat_$util_abort(136,null);

	if intype ^= outtype
	then do;
		m = message(simplify_for_message(intype),simplify_for_message(outtype));

		if m ^= 0
		then if ^otype.char | string (inpicture) = "0"b
		     then call print (m);
	     end;

	if validate_bit
	then return;

/* If input and output are identical no conversion is done. */

	if otype.bit | otype.char
	then do;
		alignment_ok = "1"b;
		sign_type_ok = "1"b;
	     end;
	else do;
		alignment_ok = ((itype.aligned = otype.aligned) | (itype.unaligned = otype.unaligned)) & (itype.explicit_packed = otype.explicit_packed);
		sign_type_ok = itype.unsigned = otype.unsigned;

		if alignment_ok
		then do;
			otype.aligned = itype.aligned;
			otype.unaligned = itype.unaligned;
		     end;

		if sign_type_ok
		then otype.unsigned = itype.unsigned;
	     end;

	if known
	then	if intype=outtype & inprec=outprec & inscale=outscale & inlength=tlength & alignment_ok & sign_type_ok
		| otype.char & inprec=outprec & string(inpicture)^="0"b
		then do;
			return_tree = tree;
			goto ret;
		end;
		else go to assign_it;
	else do;
		if plain_desc_type(intype) = plain_desc_type(outtype) & alignment_ok & sign_type_ok
		then do;
			return_tree = tree;

			if target_must_be_integer
			&  inscale^=0
			then do;
				outprec = max(inprec-inscale,1);
				outscale = 0;

				goto assign_it;
			end;

			goto ret;
		end;

		if otype.char
		&  string(inpicture)^="0"b
		then do;
			return_tree = tree;
			goto ret;
		end;

		call get_target_size;

		if target_must_be_integer
		&  outscale^=0
		then do;
			outprec = min(max(outprec-outscale,1),max_p_fix_bin_1);
			outscale = 0;
		end;

		go to assign_it;
	end;

/* The input is a token.  It will be converted to conform to the target. If the target
   size is known it is used, otherwise the language rules are used to determine the size.
   If the target is a variable length string an assignment is generated.  All constants
   are declared by calls to declare_constant.	*/

token_input:
	if (string (otype) & computational_mask) = ""b
	then	call pl1_stat_$util_abort(246,tree);	/* target isn't computational */

	if (tree->token.type & is_constant)="0"b
	then	call print(247);

	on conversion, overflow, underflow, fixedoverflow call print(252);
	on size call print(442);
	on stringsize call print(-192);

	inclength = tree->token.size;

	/* The input token is either bit, char, or arithmetic. */

	if tree->token.type=bit_string
	then do;					/* BIT */
		intype=bit_dtype;
		if inclength ^= 0 then inclength = inclength - 1;
		if tree->token.string="b"		/* null bit-string */
		then	tree = create_token("",bit_string);
	end;

	else
	if tree->token.type=char_string
	then	intype = char_dtype;		/* CHAR */

	else do;					/* ARITHMETIC */
		call char_to_numeric_(addr(value1),intype,inscale_prec,addr(tree->token.string),(inclength));
		intype = divide(intype,2,15,0);
	end;

	if ^known
	then call get_target_size;
	else if ^target -> symbol.picture & otype.decimal & ^keep_full_precision
	     then call get_target_size;

	if target_must_be_integer
	&  inscale^=0
	&  intype ^= char_dtype	/* inscale overlays inclength */
	&  intype ^= bit_dtype	/* .. */
	then do;
		outprec = min(max(outprec-outscale,1),max_p_fix_bin_1);
		outscale = 0;
	end;

	outtype = pl1_descriptor_type (defined_otype, (outprec));	/* in case outprec changed */

	/* Now do the assignment. There are three cases...char, bit, or arithmetic */

	if otype.char				/* CHAR TARGET */
	then do;
		if tree->token.type & is_arith_constant
		then do;
			call print(-234);

			if outclength > characters_per_double & known
			then do;
				svprec = outclength;
				call get_target_size;
				long_bit = "1"b;
			end;

			call assign_(addr(value2),outtype*2,(outclength),addr(value1),intype*2,inscale_prec);

			addr(value1)->char_target  = addr(value2)->char_target;
		end;
		else

		if tree->token.type = bit_string
		then do;
			n = tree -> token.size;
			if n ^= 0 then n = n - 1;
			if outclength > characters_per_double & known
			then do;
				svprec = outclength;
				outclength = n;
				long_bit = "1"b;
			end;
(stringsize):		addr(value1)->char_target = substr(tree->token.string,1,n);

			call print(-487);
		end;

		else
		if tree->token.type = char_string
		then do;
			if outclength > characters_per_double & known
			then do;
				svprec = outclength;
				outclength = tree->token.size;
				long_bit = "1"b;
			end;
(stringsize):		addr(value1)->char_target = tree->token.string;
		end;
	end;
	else

	if otype.bit				/* BIT TARGET */
	then do;
		if tree->token.type & is_arith_constant
		then do;
			call print(-234);

			if outclength > bits_per_double & known
			then do;
				svprec = outclength;
				call get_target_size;
				long_bit = "1"b;
			end;

			call assign_(addr(value2),outtype*2,(outclength),addr(value1),intype*2,inscale_prec);

			addr(value1)->bit_target = addr(value2)->bit_target;
		end;

		else
		if tree->token.type=bit_string
		then do;
			n = tree -> token.size ;
			if n ^= 0 then n = n - 1;
			if outclength > bits_per_double & known
			then do;
				svprec = outclength;
				outclength = n;
				long_bit = "1"b;
			end;
(stringsize):		addr(value1)->bit_target = bit(substr(tree -> token.string,1,n));
		end;

		else
		if tree->token.type=char_string
		then do;
			if outclength > bits_per_double & known
			then do;
				svprec = outclength;
				outclength = tree->token.size;
				long_bit = "1"b;
			end;
(stringsize):		addr(value1)->bit_target = bit(tree->token.string);

			call print(-489);
		end;
	end;
	else do;					/* ARITHMETIC TARGET */
		if (tree -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant
		then call print(-236);

		call assign_(addr(value1),outtype*2+binary(otype.unaligned,1),outscale_prec,
			addr(tree->token.string),char_dtype*2,(tree->token.size));
	end;

	if tlength^=null | long_bit
	then do;

		/* declare the string constant and then assign it */

		tree = declare_constant(value1,(defined_otype),(outclength),0);
		if long_bit then outprec = svprec;
		go to assign_it;
	end;

	if varying_result
	then	if target->symbol.dcl_size=null
		then	outclength = min(outclength,target->symbol.c_dcl_size);

	tree  ,
	return_tree = declare_constant(value1,(defined_otype),(outprec),(outscale));

	if varying_result
	then	if target->symbol.dcl_size^=null
		then	goto assign_it;

	goto ret;

/* This conversion must be done at runtime */

assign_it:
	if target_must_be_integer
	then	outprec = max(min(outprec,max_p_fix_bin_1),1);

	output = create_operator(assign,2);
	if otype.bit | otype.char
	then	output->operand(1) = declare_temporary((defined_otype),outclength,0,tlength);
	else	output->operand(1) = declare_temporary((defined_otype),(outprec),(outscale),tlength);

	output->operand(2) = tree;
	output->operator.processed = "1"b;

	if varying_result
	then do;
		output->operand(1) = copy_expression(output->operand(1));

		output->operand(1)->reference.c_length = min(outclength,target->symbol.c_dcl_size);

		if target->symbol.dcl_size^=null
		then do;
			r = create_operator(min_fun,3);
			r->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
			r->operand(2) = copy_expression(target->symbol.dcl_size);
			r->operand(2) = expression_semantics((target->symbol.block_node),pl1_stat_$cur_statement,(r->operand(2)),"0"b);
			r->operand(2) = convert$to_integer((r->operand(2)),integer_type);
			if target->symbol.refer_extents
			then	r->operand(2) = fill_refer((r->operand(2)),(target_ref->reference.qualifier),"1"b);
			r->operand(3) = declare_constant$integer((outclength));

			output->operand(1)->reference.length = r;
			output->operand(1)->reference.c_length = 0;
		end;
	end;

	return_tree = output;

ret:
	if string(inpicture) ="0"b & string(tpicture) ="0"b
	then	return(return_tree);

	if string(inpicture)^="0"b
	&  string(tpicture)^="0"b
	then do;
	    	if return_tree->node.type=operator_node
		then	if return_tree->operator.op_code=pack
			then	return(return_tree);

		if ^ itype.char	/* input is not a character picture */
		 & target->symbol.general->reference.symbol->symbol.initial
		   = input->symbol.general->reference.symbol->symbol.initial
		then	return(return_tree);
	end;

	if string(inpicture)^="0"b	/*   input is a picture   */
	& ^itype.char	/*   input is not a pic char   */
	& ^otype.char	/*   output is not a character string or pic char   */
	then do;
		output = create_operator(unpack,2);
		output->operand(1) = declare_temporary((defined_itype & undesirable_mask),(inprec),(inscale),null);
		output->operator.processed = "1"b;

		if return_tree->node.type=operator_node
		then	if return_tree->operator.op_code^=std_call
			then do;				/* must be convert-created assign */
				output->operand(2) = return_tree->operand(2);
				return_tree->operand(2) = output;
			end;
			else do;
				output->operand(2) = return_tree;
				return_tree = output;
			end;
		else do;
			output->operand(2) = return_tree;
			return_tree = output;
		end;
	end;

	if string(tpicture) ^= "0"b
	then do;
		output = create_operator(pack,2);
		p = target->symbol.general->reference.symbol->symbol.initial;
		output->operand(1) = declare_picture_temp(p->picture_image.chars,
			(p->picture_image.scalefactor),
			(tpicture.complex),
			(tpicture.unaligned));

		output->operand(2) = return_tree;
		output->operator.processed = "1"b;

		return_tree = output;
	end;

	return(return_tree);

/* subroutine to issue diagnostics.	*/

print: proc(m);

dcl	symbol ptr;
dcl	m fixed bin;

	symbol = null;

	if tree=null then goto print_;

	if tree->node.type^=reference_node
	&  tree->node.type^=token_node
	then	goto print_;

	if tree->node.type=reference_node
	then	if tree->reference.symbol->symbol.dcl_type=by_compiler then goto print_;

	m = m+1;
	symbol = tree;

print_:
	if m > 0
	then	call pl1_stat_$util_abort(m,symbol);
	else	if ^suppress_bit
		then	call pl1_stat_$util_error(-m,symbol);

	end print;

/* subroutine to determine the target size, prec, and scale. */

get_target_size: proc;

/* automatic */

dcl	(oprec, oscale) fixed bin(15);

/* internal static */

/* The following array maps descriptor type codes into indexes into the action_index matrix. */

dcl	simplify (46) fixed bin int static initial (1, 1, 2, 2, 1, 1, 2, 2, 3, 4, 3, 4, 5, 6, 7, 8, 9, 10,
	11, 11, 12, 12, 13, (9)0, 1, 1, (8)0, 3, 4, 3, 4);

/* The following matrix maps combinations of source type and target type into an action index.
   The values of the simplify matrix correspond to the subscripts of action_index, and are assigned
   as follows:
	1 = fixed bin	8 = entry
	2 = float bin	9 = structure
	3 = fixed dec	10 = area
	4 = float dec	11 = bit
	5 = ptr		12 = char
	6 = offset	13 = file
	7 = label
*/

dcl	action_index(13,13) fixed bin(15) int static initial(
		20, 1, 3, 2, 0, 0, 0, 0, 0, 0, 4, 5, 0,
		22,20, 0,11, 0, 0, 0, 0, 0, 0,12,13, 0,
		 8, 6,20, 7, 0, 0, 0, 0, 0, 0, 9,10, 0,
		21,14,22,20, 0, 0, 0, 0, 0, 0,15,16, 0,
		 0, 0, 0, 0,20,20, 0, 0, 0, 0, 0, 0, 0,
		 0, 0, 0, 0,20,20, 0, 0, 0, 0, 0, 0, 0,
		 0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0, 0, 0,
		 0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0, 0,
		 0, 0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0,
		 0, 0, 0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0,
		17,19,18,18, 0, 0, 0, 0, 0, 0,20,20, 0,
		17,19,18,18, 0, 0, 0, 0, 0, 0,20,20, 0,
		 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,20);

/* program */

	go to action (action_index (simplify (intype), simplify (outtype)));

action(0):					/* conversion error */
	if known then goto exit;			/* It is not an error if the known bit is on */

						/* bin float -> dec fixed */
	call print(261);

action(1):					/* bin fixed -> bin float */
	outprec = min(inprec,max_p_flt_bin_2);
	go to exit;

action(2):					/* bin fixed -> dec float */
	outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec);
	go to exit;

action(3):					/* bin fixed -> dec fixed */
	outprec = min(fixed(ceil(inprec/3.32e0))+1,max_p_dec);
	outscale = fixed(ceil(inscale/3.32e0));
	go to exit;

action(4):					/* bin fixed -> bit */
	outprec = min(max_p_fix_bin_2,max(inprec-inscale,0));
	go to exit;

action(5):					/* bin fixed -> char */
	outprec = min(fixed(ceil(inprec/3.32e0))+1,max_p_dec)+3;
	outscale = fixed(ceil(abs(inscale)/3.32e0))*sign(inscale);
	if outscale<0 | outscale>outprec
		then outprec = outprec+fixed(log10(abs(outscale)))+1;
	outscale = 0;
	if itype.complex then outprec = outprec*2+1;
	go to exit;

action(6):					/* dec fixed -> bin float */
	outprec = min(fixed(ceil(inprec*3.32e0)),max_p_flt_bin_2);
	go to exit;

action(7):					/* dec fixed -> dec float */
	outprec = inprec;
	go to exit;

action(8):					/* dec fixed -> bin fixed */
	oprec = min(fixed(ceil(inprec*3.32e0))+1,max_p_fix_bin_2);
	oscale = fixed(ceil(inscale*3.32e0));
	if oscale < min_scale | oscale > max_scale
	then	if target_must_be_integer & oscale > 0
		then oscale = oprec - ((fixed(ceil(inprec*3.32e0))+1) - fixed(ceil(abs(inscale)*3.32e0)));
		else call print(479);
	outprec = oprec;
	outscale = oscale;
	go to exit;

action(9):					/* dec fixed -> bit */
	outprec = min(max_p_fix_bin_2,max(fixed(ceil((inprec-inscale)*3.32e0)),0));
	go to exit;

action(10):					/* dec fixed -> char */
	outprec = inprec+3;
	if inscale<0 | inscale>inprec
		then outprec = outprec+fixed(log10(abs(inscale)))+1;
	if itype.complex then outprec = outprec *2 +1;
	go to exit;

action(11):					/* bin float -> dec float */
	outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec);
	go to exit;

action(12):					/* bin float -> bit */
	outprec = min(inprec,max_p_fix_bin_2);
	go to exit;

action(13):					/* bin float -> char */
	outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec) + 7;
	if itype.complex then outprec = outprec*2+1;
	go to exit;

action(14):					/* dec float -> bin float */
	outprec = min(fixed(ceil(inprec*3.32e0)),max_p_flt_bin_2);
	go to exit;

action(15):					/* dec float -> bit */
	outprec = min(fixed(ceil(inprec*3.32e0)),max_p_fix_bin_2);
	go to exit;

action(16):					/* dec float -> char */
	outprec = inprec+7;
	if itype.complex then outprec = outprec*2+1;
	go to exit;

action(17):					/* bit or char -> fixed bin */
	outprec = max_p_fix_bin_2;
	go to exit;

action(18):					/* bit or char -> fixed or float dec */
	outprec = max_p_dec;
	go to exit;

action(19):					/* bit or char -> float bin */
	outprec = max_p_flt_bin_2;
	go to exit;

action(20):					/* bit or char -> bit or char  any copy */
	outprec = inprec;
	outscale = inscale;

	if varying_input
	then do;
	     tlength = inlength;
	     tlength -> operand(2) = share_expression(tree);
	     end;
	else tlength = share_expression(inlength);
	go to exit;

action(21):					/* dec float -> bin fixed */
	outprec = min(fixed(ceil(inprec*3.32e0)) + 1,max_p_fix_bin_2);
	outscale = 0;
	go to exit;

action(22):					/* bin float -> bin fixed */
						/* dec float -> dec fixed */
	outprec = inprec;
	outscale = 0;

exit:

	end get_target_size;

%include pl1_descriptor_type_fcn;

%include semant;
%include picture_image;
%include declare_type;
%include desc_dcls;
%include std_descriptor_types;
%include mask;
%include nodes;
%include op_codes;
%include operator;
%include pl1_symbol_type;
%include reference;
%include symbol;
%include system;
%include token;
%include token_types;
	end convert;




		    copy_expression.pl1             07/31/89  1433.2r w 07/31/89  1338.2       66483



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


/* Modified 3 October 1980 by M. N. Davidoff to eliminate internal static for previous.  Fixes 2023.
*/
/* format: style3 */
copy_expression:
     procedure (a) returns (pointer);

dcl	a		ptr unaligned;
dcl	father		ptr;
dcl	stepfather	ptr;

/* automatic */

dcl	i		fixed bin;
dcl	inptr		ptr;
dcl	nodetype		bit (9) aligned;
dcl	outptr		ptr;
dcl	p		ptr;

/* builtin */

dcl	null		builtin;

/* external static */

dcl	pl1_stat_$util_abort
			external static entry (fixed bin (15), ptr) variable;

%include language_utility;
%include array;
%include symbol;
%include declare_type;
%include list;
%include nodes;
%include operator;
%include op_codes;
%include reference;

/* program */

	inptr = a;

	if inptr = null
	then return (inptr);

	nodetype = inptr -> node.type;

	if nodetype = operator_node
	then do;
		if inptr -> operator.number = 0
		then return (inptr);

		if inptr -> operator.operand (1) ^= null
		then if inptr -> operator.operand (1) -> node.type = reference_node
		     then if ^inptr -> operator.operand (1) -> reference.shared
			then do;
				inptr -> operator.operand (1) -> reference.ref_count =
				     inptr -> operator.operand (1) -> reference.ref_count + 1;
				return (inptr);
			     end;

		outptr = create_operator ((inptr -> operator.op_code), (inptr -> operator.number));

		do i = 1 to inptr -> operator.number;
		     if inptr -> operator.operand (i) ^= null
		     then outptr -> operator.operand (i) = copy_expression (inptr -> operator.operand (i));
		end;

		outptr -> operator.processed = inptr -> operator.processed;

		if outptr -> operator.op_code = std_call
		then if outptr -> operator.operand (1) ^= null
		     then do;
			     p = outptr -> operator.operand (3) -> operator.operand (2);
			     outptr -> operator.operand (1) = p -> list.element (p -> list.number);
			end;

		return (outptr);
	     end;

	else if nodetype = list_node
	then do;
		outptr = create_list ((inptr -> list.number));

		do i = 1 to inptr -> list.number;
		     outptr -> list.element (i) = copy_expression (inptr -> list.element (i));
		end;

		return (outptr);
	     end;

	else if nodetype = reference_node
	then do;
		if inptr -> reference.symbol ^= null
		then do;
			p = inptr -> reference.symbol;
			if p -> node.type = symbol_node
			then if p -> symbol.constant & ^p -> symbol.file & ^p -> symbol.entry & ^p -> symbol.format
			     then return (inptr);
		     end;

		if ^inptr -> reference.shared
		then do;
			inptr -> reference.ref_count = inptr -> reference.ref_count + 1;
			return (inptr);
		     end;

		outptr = create_reference ((inptr -> reference.symbol));

		outptr -> reference = inptr -> reference;

		if outptr -> reference.offset ^= null
		then outptr -> reference.offset = copy_expression (inptr -> reference.offset);

		if outptr -> reference.length ^= null
		then outptr -> reference.length = copy_expression (inptr -> reference.length);

		if outptr -> reference.qualifier ^= null
		then outptr -> reference.qualifier = copy_expression (inptr -> reference.qualifier);

		return (outptr);
	     end;

	else if nodetype = token_node | nodetype = label_node | nodetype = sf_par_node | nodetype = block_node
	then return (inptr);

	else if nodetype = array_node
	then do;
		outptr = create_array ();
		outptr -> array = inptr -> array;
		outptr -> array.element_size = copy_expression (inptr -> array.element_size);
		outptr -> array.element_size_bits = copy_expression (inptr -> array.element_size_bits);
		outptr -> array.virtual_origin = copy_expression (inptr -> array.virtual_origin);
		outptr -> array.bounds = copy_expression (inptr -> array.bounds);
		outptr -> array.element_descriptor = copy_expression (inptr -> array.element_descriptor);

		return (outptr);
	     end;

	else if nodetype = bound_node
	then do;
		outptr = create_bound ();
		outptr -> bound = inptr -> bound;
		outptr -> bound.next = copy_expression (inptr -> bound.next);
		outptr -> bound.lower = copy_expression (inptr -> bound.lower);
		outptr -> bound.upper = copy_expression (inptr -> bound.upper);
		outptr -> bound.desc_multiplier = copy_expression (inptr -> bound.desc_multiplier);
		outptr -> bound.multiplier = copy_expression (inptr -> bound.multiplier);

		return (outptr);
	     end;

	else if nodetype = symbol_node
	then return (copy_symbol (inptr, null));

	call pl1_stat_$util_abort (32, inptr);

	return (inptr);

/* Copy the sons of a symbol node.

   The caller is responsible for threading the new symbol.next chain onto an
   existing symbol.next chain for a block. */

copy_sons:
     entry (father, stepfather);

	stepfather -> symbol.son = null;

	if father -> symbol.son = null
	then return;

	stepfather -> symbol.son = copy_symbol ((father -> symbol.son), stepfather);

	return;

/* This procedure copies a symbol node.  If the symbol node is a structure
   declaration, this procedure makes a prefix walk of the member symbol nodes
   and copies them also.  The brothers of the root are copied if stepfather is
   not null. */

copy_symbol:
     procedure (root, stepfather) returns (ptr);

dcl	root		ptr;
dcl	stepfather	ptr;

dcl	more_nodes	bit (1) aligned;
dcl	new_s		ptr;
dcl	new_tree		ptr;
dcl	previous		ptr;
dcl	s		ptr;

	s = root;
	new_tree, previous, new_s = copy_symbol_node (root);
	new_s -> symbol.father = stepfather;

	more_nodes = "1"b;
	do while (more_nodes);
	     if s -> symbol.son ^= null
	     then do;
		     new_s -> symbol.son, previous -> symbol.next = copy_symbol_node ((s -> symbol.son));
		     new_s -> symbol.son -> symbol.father = new_s;
		     s = s -> symbol.son;
		     previous, new_s = new_s -> symbol.son;
		end;
	     else do;
		     more_nodes = "0"b;
		     do while (s ^= root -> symbol.father & ^more_nodes);
			if s -> symbol.brother ^= null & (s ^= root | stepfather ^= null)
			then more_nodes = "1"b;
			else do;
				s = s -> symbol.father;
				new_s = new_s -> symbol.father;
			     end;
		     end;

		     if more_nodes
		     then do;
			     new_s -> symbol.brother,
				previous -> symbol.next = copy_symbol_node ((s -> symbol.brother));
			     new_s -> symbol.brother -> symbol.father = new_s -> symbol.father;
			     s = s -> symbol.brother;
			     previous, new_s = new_s -> symbol.brother;
			end;
		end;
	end;

	return (new_tree);

copy_symbol_node:
     procedure (s) returns (ptr);

dcl	s		ptr;

dcl	p		ptr;

	p = create_symbol (null, null, by_compiler);

	p -> symbol = s -> symbol;
	p -> symbol.dcl_type = by_compiler;
	p -> symbol.next, p -> symbol.multi_use = null;
	p -> symbol.reference = copy_expression (s -> symbol.reference);
	p -> symbol.reference -> reference.symbol = p;
	p -> symbol.array = copy_expression (s -> symbol.array);
	p -> symbol.general = copy_expression (s -> symbol.general);
	p -> symbol.initial = copy_expression (s -> symbol.initial);

	return (p);
     end copy_symbol_node;

     end copy_symbol;

     end copy_expression;




		    copy_unique_expression.pl1      07/31/89  1433.2r w 07/31/89  1338.3       23859



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


copy_unique_expression:   proc(qp) returns(ptr);

dcl	(arg,p,q,qp)	ptr;
dcl	(i,n)		fixed bin(15);
dcl	null		builtin;

%include nodes;
%include reference;
%include operator;
%include list;
%include language_utility;
%include op_codes;

	/* gets unique copy of processed tree (thus a unique value) */

	/* this program fails if subnodes of the tree (other than the
	   result of std_call and last element of a list) have reference
	   counts greater than 1 */

	q = qp;

	if q = null then return(q);

	if q -> node.type = reference_node
	   then do;
	        if q -> reference.shared & q -> reference.processed
		 then p = q;
		 else do;
		      p = create_reference(null);
		      p -> reference = q -> reference;
		      if ^ p -> reference.shared
			then p -> reference.ref_count = 1;
		      if p -> reference.qualifier ^= null
		         then p -> reference.qualifier = copy_unique_expression((p -> reference.qualifier));
		      if p -> reference.length ^= null
		         then p -> reference.length = copy_unique_expression((p -> reference.length));
		      if p -> reference.offset ^= null
		         then p-> reference.offset = copy_unique_expression((p -> reference.offset));
		      end;
	        return(p);
	        end;

	if q -> node.type = operator_node
	   then do;
	        n = q -> operator.number;
	        p = create_operator((q -> operator.op_code),n);
	        p -> operator = q -> operator;

	        do i = 1 to n;
		 p -> operand(i) = copy_unique_expression((p -> operand(i)));
	        end;

	        if p -> operator.op_code = std_call
		 then if p -> operand(3)^= null
		      then do;
			 arg = p -> operand(3) -> operand(2);
			 arg -> element(arg -> list.number) = p -> operand(1);
			 if p -> operand(1) ^= null
			    then p -> operand(1) -> reference.ref_count = 2;
			 end;

	        return(p);
	        end;

	if q -> node.type = list_node
	   then do;
	        p = create_list((q -> list.number));
	        p -> list = q -> list;

	        do i = 1 to p -> list.number - 1;
		 p -> element(i) = copy_unique_expression((p -> element(i)));
	        end;

	        return(p);
	        end;

	return(q);

	end;




		    create_array.pl1                10/03/83  1728.7rew 10/03/83  1007.2       11547



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

create_array: proc returns(ptr) ;

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	1 pl1_nodes_template_$array_template external like array aligned;

dcl	p ptr;
dcl	null builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include nodes;
%include array;


			/*      */

	pl1_stat_$node_uses(8) = pl1_stat_$node_uses(8) + 1;

	allocate array in(tree_area) set(p);

	p->array = pl1_nodes_template_$array_template;

	return(p);

	end create_array;




		    create_block.pl1                07/31/89  1433.2r w 07/31/89  1338.3       25776



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


/*	This procedure allocates and initializes a block node.

	Modified on:	10 August 1970 by P. Green for Version II
	Modified on:	30 October 1970 by PG for updated node format
	Modified on:	 5 January 1971 by BLW for updated node format
	Modified on:	1 July 1971 by JDM for these changes to the block node:
			   1) descriptors_used replaced by filler_field
			   2) max_arg_no replaced by filler
			   3) max_par_no replaced by filler1
			   4) last_temp replaced by entry_info
	Modified on:	22 September 1971 by PAB to add IO items to node
	Modified on:	11 February 1977 to add text_displayed bit
	Modified on:	April 1977 by RHS for new allocation methods
	Modified on:	April 3 1977 by P.Green to tell why blocks are non-quick
	Modified on:	22 Ocober 1980 by M. N. Davidoff to diagnose block.number too big; fixes 1960.
*/
/* format: style3 */
create_block:
     procedure (type, father) returns (ptr);

dcl	type		bit (9) aligned;
dcl	father		ptr;

/* automatic */

dcl	p		ptr;
dcl	q		ptr;

/* builtin */

dcl	(char, ltrim, null) builtin;

/* external static */

dcl	1 pl1_nodes_template_$block_template
			aligned like block external static;
dcl	pl1_stat_$node_uses (32) fixed bin external static;
dcl	1 pl1_stat_$statement_id
			external static,
	  2 file_number	bit (8),
	  2 line_number	bit (14),
	  2 statement_number
			bit (5);

%include block;
%include block_types;
%include nodes;
%include pl1_tree_areas;
%include token_types;
%include language_utility;

/* program */

	pl1_stat_$node_uses (1) = pl1_stat_$node_uses (1) + 1;
	if pl1_stat_$node_uses (1) > max_block_number
	then call parse_error$no_text (385, create_token (ltrim (char (max_block_number)), dec_integer));

	allocate block in (tree_area) set (p);

	p -> block = pl1_nodes_template_$block_template;
	p -> block.node_type = block_node;
	p -> block.source_id = pl1_stat_$statement_id;
	p -> block.father = father;
	p -> block.block_type = type;
	p -> block.no_stack = type = internal_procedure | type = begin_block;
	p -> block.number = pl1_stat_$node_uses (1);
	p -> block.owner = null;

	if father ^= null
	then if father -> block.son = null
	     then father -> block.son = p;
	     else do;
		     do q = father -> block.son repeat q -> block.brother while (q -> block.brother ^= null);
		     end;

		     q -> block.brother = p;
		end;

	return (p);
     end create_block;




		    create_bound.pl1                10/03/83  1728.7rew 10/03/83  1007.2       11502



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

create_bound: proc returns(ptr) ;
/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	1 pl1_nodes_template_$bound_template external like bound aligned;

dcl	p ptr,
	null builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include nodes;
%include array;

			/*      */

	pl1_stat_$node_uses(9) = pl1_stat_$node_uses(9) + 1;

	allocate bound in(tree_area) set(p);

	p->bound = pl1_nodes_template_$bound_template;

	return(p);

	end create_bound;




		    create_context.pl1              10/03/83  1728.7rew 10/03/83  1007.2       12798



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

create_context:
	proc(cblock,t) returns(ptr);

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	(cblock, p, t) ptr;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include context;
%include nodes;
%include block;
	pl1_stat_$node_uses(7) = pl1_stat_$node_uses(7) + 1;

	allocate context in(tree_area) set(p);

	p->context.node_type=context_node;
	string(p->context.bits)="0"b;
	p->context.token=t;			/* this points to the token table entry */
	p->context.next=cblock->block.context;	/* push node onto context chain */
	cblock->block.context=p;		/* . . . . */

	return(p);
end create_context;




		    create_cross_reference.pl1      10/03/83  1728.7rew 10/03/83  1007.2       10980



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

create_cross_reference: proc returns(ptr) ;

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	p ptr,
	null builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include cross_reference;
%include nodes;

	pl1_stat_$node_uses(16) = pl1_stat_$node_uses(16) + 1;

	allocate cross_reference in(tree_area) set(p);
	p -> node_type = cross_reference_node;
	p -> next = null;
	return(p);

	end;




		    create_default.pl1              10/03/83  1728.7rew 10/03/83  1007.2        9000



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


create_default: proc returns(ptr);

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	1 pl1_nodes_template_$default_template external like default aligned;

dcl	d ptr;
dcl	null builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include default;
%include nodes;

	pl1_stat_$node_uses(12) = pl1_stat_$node_uses(12) + 1;
	allocate default in(tree_area) set(d);

	d->default = pl1_nodes_template_$default_template;

	return(d);
end create_default;




		    create_identifier.pl1           10/03/83  1728.7rew 10/03/83  1007.2       13428



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

create_identifier:
	procedure returns(ptr);
/*	returns a ptr to the token_node whose string is created by the
	concatenation of "cp." and a decimal integer. */
/*	Modified on:	11 August 1970 by P. Green for Version II */
/*	Modified on:	 5 January 1971 by BLW for in-line conversion */

dcl	substr builtin,
	bindec$vs entry(fixed bin(15)) returns(char(12) varying),
	pl1_stat_$compiler_created_index fixed bin(15) ext static;
dcl	create_token ext entry(char(*) aligned,bit(9) aligned) returns(ptr);

%include token_types;
	pl1_stat_$compiler_created_index = pl1_stat_$compiler_created_index+1;
	return(create_token("cp."||bindec$vs(pl1_stat_$compiler_created_index),identifier));
end create_identifier;




		    create_label.pl1                10/03/83  1728.7rew 10/03/83  1007.2       19152



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

create_label:
     proc (cblock, t, type) returns (ptr);
						/*	Modified on:	12 October 1970 by P. Green */
						/*	Modified on:	 5 January 1971 by BLW for new node format */
						/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl 1 pl1_nodes_template_$label_template external like label aligned;

dcl (cblock, t, t1, p) ptr;
dcl  create_identifier entry () returns (ptr);
dcl  n fixed bin (15);
declare (null, string) builtin;
dcl  pl1_stat_$node_uses (32) fixed bin ext;
dcl  type bit (3) aligned;

%include pl1_tree_areas;
%include nodes;
%include block;
%include label;
%include token_list;
%include token;

	if t = null then t1 = create_identifier (); else t1 = t;

	pl1_stat_$node_uses (15) = pl1_stat_$node_uses (15) + 1;

	allocate label in (tree_area) set (p);

	p -> label = pl1_nodes_template_$label_template;


	if cblock -> block.end_declaration = null
	then cblock -> block.declaration = p;
	else cblock -> block.end_declaration -> label.next = p;
	cblock -> block.end_declaration = p;
	p -> label.block_node = cblock;

	p -> label.multi_use = t1 -> token.declaration;	/* push onto multi_use chain */
	t1 -> token.declaration = p;			/* .. */

	string (p -> label.source_id) = string (pl1_stat_$statement_id);

	p -> label.dcl_type = type;

	p -> label.token = t1;



	return (p);
     end create_label;




		    create_list.pl1                 10/03/83  1728.7rew 10/03/83  1007.2       14328



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

create_list: proc(n) returns(ptr) ;

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	(n,i,nodetype) fixed bin(15);
dcl	p ptr;

dcl	pl1_stat_$free_ptr(18) ptr ext static;

dcl	(fixed,null) builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include nodes;

%include list;

begin:
	if n=2
	then nodetype = fixed(list_node,15,0);
	else nodetype = fixed(operator_node,15,0);

	if (n=2 | n=3) & pl1_stat_$free_ptr(nodetype)^=null
	then do;
		p = pl1_stat_$free_ptr(nodetype);
		pl1_stat_$free_ptr(nodetype) = p->list.element(1);
	end;
	else do;
	     pl1_stat_$node_uses(11) = pl1_stat_$node_uses(11) + 1;
	     allocate list in(xeq_tree_area) set(p);
	     end;

	p->list.node_type = list_node;
	do i=1 to n;
	p->list.element(i)=null;
	end;
	return(p);
	end;




		    create_operator.pl1             10/03/83  1728.7rew 10/03/83  1007.2       17073



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

create_operator:
	proc(type,n) returns(ptr) ;

/*	this procedure allocates and initializes an operator node. */
/*	Modified on:	10 August 1970 by P. Green for Version II */

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	type bit(9) aligned,
	(i,n,nodetype) fixed bin(15),
	p ptr;

dcl	pl1_stat_$free_ptr(18) ptr ext static;

dcl	null builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

%include pl1_tree_areas;
%include operator;
%include nodes;

	if n=2
	then	nodetype = fixed(list_node,15,0);
	else	nodetype = fixed(operator_node,15,0);

	if (n=2 | n=3) & pl1_stat_$free_ptr(nodetype)^=null
	then do;
		p = pl1_stat_$free_ptr(nodetype);
		pl1_stat_$free_ptr(nodetype) = p->operator.operand(1);
	end;
	else do;
	     pl1_stat_$node_uses(3) = pl1_stat_$node_uses(3) + 1;
	     allocate operator in(xeq_tree_area) set(p);
	     end;

	p->operator.node_type = operator_node;
	p->operator.number=n;
	p->operator.op_code=type;
	p->operator.shared,
	p->operator.processed,
	p->operator.optimized = "0"b;
	do i=1 to n;
		p->operator.operand(i)=null;
	end;
	return(p);
	end create_operator;




		    create_reference.pl1            10/03/83  1728.7rew 10/03/83  1007.3       15957



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

create_reference: proc(s) returns(ptr);
/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	1 pl1_nodes_template_$reference_template external like reference aligned;

dcl	(p,s) ptr,

	nodetype fixed bin(15);

dcl	pl1_stat_$free_ptr(18) ptr ext static;

dcl	(addr,fixed,null,string) builtin;
dcl	pl1_stat_$node_uses(32) fixed bin ext;

dcl	use_xeq bit(1) aligned;

%include pl1_tree_areas;
%include nodes;
%include reference;

	use_xeq = "1"b;

begin:
	nodetype = fixed(reference_node,15,0);
	p = pl1_stat_$free_ptr(nodetype);

	if p^=null
	then	pl1_stat_$free_ptr(nodetype) = p->reference.symbol;
	else do;
	     pl1_stat_$node_uses(4) = pl1_stat_$node_uses(4) + 1;
	     if use_xeq
		then allocate reference in(xeq_tree_area) set(p);
		else allocate reference in(tree_area) set(p);
	     end;

	p->reference = pl1_nodes_template_$reference_template;

	p -> reference.symbol = s;

	return(p);

for_symbol:	entry(s) returns(ptr);
	use_xeq = "0"b;
	go to begin;

	end;




		    create_statement.pl1            10/03/83  1728.7rew 10/03/83  1007.3       53973



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


/*	This procedure allocates and initializes a statement node.
	Modified on:	April 1977 by RHS for new allocation methods
	Modified on:	14 March 1980 by M. N. Davidoff to add some comments
*/
/* format: style3 */
create_statement:
     proc (statement_type, father_block, label_ptr, conditions) returns (pointer);

dcl	(i, nodetype)	fixed bin (15),
	statement_type	bit (9) aligned,
	(lab, p, q, qq, ref, t, father_block, label_ptr)
			ptr;
dcl	conditions	bit (12) aligned;

dcl	pl1_stat_$node_uses (32) fixed bin ext;
dcl	(
	pl1_stat_$source_seg,
	pl1_stat_$st_length
	)		fixed bin (11) ext static,
	pl1_stat_$st_start	fixed bin (23) ext static,
	pl1_stat_$cur_block ptr ext,
	pl1_stat_$cur_statement
			ptr ext,
	pl1_stat_$free_ptr	(18) ptr ext static;

dcl	(fixed, null, string)
			builtin;

%include pl1_tree_areas;
%include token_list;
%include label;
%include reference;
%include list;
%include statement;
%include block;
%include nodes;
%include statement_types;

	if father_block = null
	then i = 3;

	else if father_block -> node.type = statement_node/* for inserting a statement */
	then i = 3;

	else i = 1;

	go to common;

create_statement$prologue:
     entry (statement_type, father_block, label_ptr, conditions) returns (ptr);

	i = 2;

common:
	nodetype = fixed (statement_node, 15, 0);
	p = pl1_stat_$free_ptr (nodetype);

	if p ^= null
	then pl1_stat_$free_ptr (nodetype) = p -> statement.next;
	else do;
		pl1_stat_$node_uses (2) = pl1_stat_$node_uses (2) + 1;
		allocate statement in (xeq_tree_area) set (p);
	     end;

	p -> statement.node_type = statement_node;
	p -> statement.statement_type = statement_type;
	p -> statement.optimized, p -> statement.free_temps, p -> statement.LHS_in_RHS, string (p -> statement.bits) = "0"b;

	p -> statement.reference_count, p -> statement.ref_count_copy, p -> statement.object.start,
	     p -> statement.object.finish = 0;

	if i = 3
	then do;

/* Use statement numbering information from statement being processed by top level of expression_semantics,
   unless we are doing a do statement. */

		q = pl1_stat_$cur_statement;

		if q ^= null
		then if q -> statement.statement_type = do_statement
						/* for do_semantics */
		     then q = father_block;

		if q = null
		then q = father_block;

		p -> statement.source.segment = q -> statement.source.segment;
		p -> statement.source.start = q -> statement.source.start;
		p -> statement.source.length = q -> statement.source.length;
		string (p -> statement.source_id) = string (q -> statement.source_id);
	     end;
	else do;
		p -> statement.source.segment = pl1_stat_$source_seg;
		p -> statement.source.start = pl1_stat_$st_start;
		p -> statement.source.length = pl1_stat_$st_length;
		string (p -> statement.source_id) = string (pl1_stat_$statement_id);
	     end;

	p -> statement.labels = label_ptr;
	p -> statement.prefix = conditions;

	p -> statement.next, p -> statement.root, p -> statement.state_list, p -> statement.reference_list = null;

	go to action (i);

action (1):					/* end of the main sequence */
	if father_block -> block.end_main = null
	then father_block -> block.main = p;
	else father_block -> block.end_main -> statement.next = p;
	p -> statement.back = father_block -> block.end_main;
	father_block -> block.end_main = p;
	return (p);

action (2):					/* end of the prologue sequence */
	if father_block -> block.end_prologue = null
	then father_block -> block.prologue = p;
	else father_block -> block.end_prologue -> statement.next = p;
	p -> statement.back = father_block -> block.end_prologue;
	father_block -> block.end_prologue = p;
	return (p);

action (3):
	if father_block = null
	then do;

/* No statements preceding cur_statement in prologue. */

		t = pl1_stat_$cur_block -> block.prologue;
		goto con;
	     end;

	if string (p -> statement.source_id) ^= string (father_block -> statement.source_id)
	then do;

/* p has become the first statement node of the corresponding source statement. */

		p -> statement.put_in_profile, p -> statement.free_temps = "1"b;

		t = father_block -> statement.next;
		if t ^= null
		then do;
con:
			t -> statement.put_in_profile, t -> statement.free_temps = "0"b;

			if t -> statement.statement_type ^= entry_statement
			     & q -> statement.statement_type ^= do_statement
			then do;
				do qq = t -> statement.labels repeat qq -> list.element (1) while (qq ^= null);
				     if qq -> list.element (2) -> node.type = label_node
				     then qq -> list.element (2) -> label.statement = p;
				     else if qq -> list.element (2) -> node.type ^= token_node
				     then do;
					     ref = qq -> element (2);
					     lab = ref -> reference.symbol;
					     lab -> label.statement -> element (ref -> reference.c_offset + 1) = p;
					end;
				end;

				p -> statement.reference_count = t -> statement.reference_count;
				t -> statement.reference_count = 0;
				p -> statement.labels = t -> statement.labels;
				t -> statement.labels = null;
			     end;
		     end;
	     end;

	if father_block ^= null
	then do;					/* insert into the main sequence */
		p -> statement.back, q = father_block;
		p -> statement.next = q -> statement.next;
		q -> statement.next = p;

		q = p -> statement.next;
		if q ^= null
		then q -> statement.back = p;
	     end;
	else do;
		p -> statement.back = null;
		p -> statement.next = pl1_stat_$cur_block -> block.prologue;
		pl1_stat_$cur_block -> block.prologue = p;
		p -> statement.next -> statement.back = p;
	     end;

	return (p);

     end;




		    create_storage.pl1              10/03/83  1728.7rew 10/03/83  1007.3       10764



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

/* This procedure merely allocates a block of N words */

create_storage: proc(n) returns(ptr) ;

/*	Modified on:	April 1977 by RHS for new allocation methods */

dcl	n fixed bin,
	p ptr;

dcl	pl1_stat_$node_uses(32) fixed bin ext;

dcl	storage(n) fixed based(p);

%include pl1_tree_areas;

	pl1_stat_$node_uses(14) = pl1_stat_$node_uses(14) + n;

	allocate storage in(tree_area) set(p);
	return(p);

	end;




		    create_symbol.pl1               10/03/83  1728.7rew 10/03/83  1007.3       29151



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

/* Originally coded by Paul Green, July, 1970 */
/*	Modified on:	 5 January 1971 by BLW for new node format */
/*	Modified on:	30 October 1970 by PG for updated node format */
/*	Modified on:	14 September 1970 by P. Green for Version II */
/*	Modified on:	April 1977 by RHS for new allocation methods */
/* This procedure is called to create a symbol table in
   cblock, pointed to by token, and having the given type.
   If cblock is null, the symbol is left floating.
   If token is null, create_identifier is called to produce a
   uniquely named identifier.  */

create_symbol:
     proc (cblock, token, type) returns (ptr);
dcl 1 pl1_nodes_template_$symbol_template external like symbol aligned;

dcl (cblock, token, tok_pt, p) pointer,
     type bit (3) aligned,
     k fixed bin (21) init (0),			/* this is used only by the "token" incl file	*/
    (n, nodetype) fixed bin (15);

dcl  pl1_stat_$free_ptr (18) ptr ext static;
dcl  pl1_stat_$node_uses (32) fixed bin ext;

dcl  create_identifier external entry returns (ptr),
     create_reference$for_symbol external entry (ptr) returns (ptr);

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

%include pl1_tree_areas;
% include symbol;
% include block;
%include token_list;


% include nodes;
/* Begin processing */

	if token = null then tok_pt = create_identifier (); else tok_pt = token;

	nodetype = fixed (symbol_node, 15, 0);
	p = pl1_stat_$free_ptr (nodetype);

	if p ^= null
	then pl1_stat_$free_ptr (nodetype) = p -> symbol.next;
	else do;
	     pl1_stat_$node_uses (6) = pl1_stat_$node_uses (6) + 1;
	     allocate symbol in (tree_area) set (p);
	end;
	p -> symbol = pl1_nodes_template_$symbol_template;

	if cblock = null
	then p -> symbol.block_node = null;
	else do;
	     p -> symbol.block_node = cblock;

	     if cblock -> block.end_declaration = null
	     then cblock -> block.declaration = p;
	     else cblock -> block.end_declaration -> symbol.next = p;

	     cblock -> block.end_declaration = p;
	end;

	p -> symbol.multi_use = tok_pt -> t_table.declaration; /* push this symbol onto multi_use chain */
	tok_pt -> t_table.declaration = p;		/* update pointer to first symbol */

	p -> symbol.token = tok_pt;			/* set pointer back to token table */
	p -> symbol.dcl_type = type;			/* assign type as passed to us	*/
	p -> symbol.node_type = symbol_node;		/* identify this node		*/

	p -> symbol.reference = create_reference$for_symbol (p);

	return (p);

     end create_symbol;




		    create_token.pl1                10/03/83  1728.7rew 10/03/83  1007.3        7263



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


%include create_token;

/* Entry to initialize the hash table used by create_token.  Note that the length of the hash table
   must be a prime number */

init_hash_table:
     entry ();

	allocate hash_table_structure in (tree_area);
	hash_table (*) = null;
	return;

     end /* create_token */;




		    decbin.pl1                      10/03/83  1728.7rew 10/03/83  1007.3        9459



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


/* Procedure to convert string to binary.  String assumed to conform
   to the syntax [+|-]digit*	*/

decbin:	proc(string) returns(fixed bin);

dcl	string char(*) aligned;

dcl	(i,number,sign) fixed bin,
	c char(1),
	(binary,length,substr,unspec) builtin;

	i,sign = 1;
	c = substr(string,1,1);
	if c = "+" then i = 2;
     else if c = "-" then do; i = 2; sign = -1; end;

	number = 0;
	do i = i to length(string);
	     c = substr(string,i,1);
	     number = number * 10 + binary(unspec(c),9) - 48;
	     end;

	return(sign * number);
	end;




		    declare_constant.pl1            07/31/89  1433.2r w 07/31/89  1338.3       66933



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


/* Modified 780425 by PG to prepare for reformatting of symbol node */
/* Modified 780712 by PG for unsigned */
/* Modified 790419 by PCK to implement 4-bit decimal */

declare_constant:
     procedure (value, bv_input_type, size, scale) returns (ptr);

/* parameters */

dcl	value bit (*) aligned;
dcl	bv_input_type bit (36) aligned;
dcl	(size, scale) fixed bin (31);

/* automatic */

dcl	(p, q, p1, ref, pv, last, save) ptr;
dcl	(boundary, i, j, word_size, bit_size, value_size) fixed bin(31);
dcl	copy bit(18432);		/* max size of constant is 512 words */
dcl	1 ctype like type;
dcl	1 itype like type;

/* based */

dcl	const_value bit(value_size) aligned based;
dcl	new_value bit(value_size) aligned based(pv);
dcl	space bit(value_size)  aligned based;

/* builtin */

dcl	(addr, bit, divide, hbound, index, max, null, string, substr) builtin;

/* external static */

dcl	pl1_stat_$constant_list ptr external static;

/* internal static */

dcl	zero bit(36) int static init("0"b);

/* include files */

%include language_utility;
%include symbol;
%include pl1_symbol_type;
%include reference;
%include system;
%include mask;
%include boundary;
%include declare_type;

/* program */

	string (itype) = bv_input_type;
	string (ctype) = string (itype) & declare_constant_mask;
	if ctype.ptr then do;
				boundary = mod2_;
				bit_size = bits_per_word*2;
				go to search;
			  end;
	if ctype.offset then do;
				boundary = word_;
				bit_size = bits_per_word;
				go to search;
			 end;
	if ctype.decimal then do;
				boundary = character_;
				ctype.unaligned = itype.unaligned;
				if ctype.unaligned
				then do;
					if ctype.float
					then bit_size = size + 3;
					else bit_size = size + 1;

					bit_size = bit_size + mod(bit_size,2);
					bit_size = divide(bit_size,packed_digits_per_character,24,0) * bits_per_character;
				     end;
				else do;
					if ctype.float
					then bit_size = size + 2;
					else bit_size = size + 1;

					bit_size = bit_size * bits_per_character;
				     end;
				if ctype.complex
				then bit_size = bit_size * 2;
				go to search;
			end;
	if ctype.char then do;
				boundary = character_;
				bit_size = size*bits_per_character;
				go to search;
			end;
	if ctype.bit | ctype.arg_descriptor
		then do;
				boundary = bit_;
				bit_size = size;
				go to search;
			end;

/* this is a binary constant */

	if ctype.fixed
	then	if itype.unaligned
		then	if itype.unsigned
			then	bit_size = size;
			else	bit_size = size + 1;
		else	if size>max_p_fix_bin_1
			then	bit_size = bits_per_word*2;
			else	bit_size = bits_per_word;

	else	if itype.unaligned
		then	bit_size = size+bits_per_binary_exponent+1;
		else	if size>max_p_flt_bin_1
			then	bit_size = bits_per_word*2;
			else	bit_size = bits_per_word;

	if ctype.complex then bit_size = bit_size*2;
	if bit_size > bits_per_word
		then boundary = mod2_;
		else boundary = word_;

	ctype.unaligned = itype.unaligned;
	ctype.unsigned = itype.unsigned;

/* search the chain of constants to find one who's value is equal to this value.
   If no such constant can be found, make a new constant declaration.	*/

search:
	word_size = divide(bit_size+bits_per_word-1,bits_per_word,31,0);
	value_size = word_size * bits_per_word;

	substr(copy,1,value_size) = substr(value,1,bit_size);

	pv = addr(copy);

	save  ,
	last = null;
	p = pl1_stat_$constant_list;

	do while(p^=null);
		if p->symbol.c_word_size >= word_size
		then	if p->symbol.initial->const_value = new_value
			then do;
				if word_size = 0
				then	if word_size ^= p -> symbol.c_word_size
					then	go to again;

				save = p;

				if p->symbol.c_bit_size^=bit_size then goto new_symbol;
				if substr (string (p -> symbol.attributes), 1, 36) ^= string (ctype) then go to again;
				if p->symbol.c_dcl_size ^= size then goto again;
				if p->symbol.scale ^= scale then goto again;

				return(p->symbol.reference);
			end;
			else;
		else	last = p;

again:
		p = p->symbol.multi_use;
	end;

/* create a new symbol node to represent this constant.	*/

new_symbol:
	q = create_symbol(null,null,by_compiler);
	q -> symbol.boundary = boundary;
	substr (string (q -> symbol.attributes), 1, 36) = string (ctype);
	q->symbol.c_dcl_size = size;
	q->symbol.scale = scale;
	q->symbol.c_word_size = word_size;
	q->symbol.c_bit_size = bit_size;
	q->symbol.internal,
	q->symbol.constant = "1"b;

	q->symbol.packed = q->symbol.unaligned;

	q->symbol.allocate = save=null;
	ref = q->symbol.reference;
	if ctype.bit | ctype.char then ref->reference.c_length = size;
	ref->reference.padded_ref = "1"b;

/* If this value exists as the value of another constant then
   this declaration will be equivalenced to the declaration of the other constant. */

	if save^=null
	then do;
		if save->symbol.equivalence = null
			then q->symbol.equivalence = save;
			else q->symbol.equivalence = save->symbol.equivalence;

		do p1 = q -> symbol.equivalence repeat p1 -> symbol.equivalence while(p1 -> symbol.equivalence ^= null);
		end;
		p1 -> symbol.boundary = max(boundary,p1 -> symbol.boundary);

		q->symbol.initial = save->symbol.initial;
	     end;
	else do;
		if word_size > 0
		then do;
			q->symbol.initial,p1 = create_storage((word_size));
			p1->space = substr(copy,1,bit_size);
		     end;
		else	q -> symbol.initial = addr(zero);
	     end;

/* hook this symbol node into the chain of constants keeping the chain ordered by size. */

	if last=null
	then do;
		q->symbol.multi_use=pl1_stat_$constant_list;
		pl1_stat_$constant_list=q;
	end;
	else do;
		q->symbol.multi_use=last->symbol.multi_use;
		last->symbol.multi_use=q;
	end;

	return(ref);

/* Entry points to allow easy declaration of constant values by the compiler. */

dcl	integer fixed bin(31);
dcl	integer_image bit(bits_per_word) aligned based(addr(integer));
dcl	bits aligned bit(*);
dcl	char aligned char(*);
dcl	char_image aligned bit(length(char)*bits_per_character) based(addr(char));

dcl	length builtin;

	/* following is table giving binary precision corresponding
	   to decimal precision, it is used by declare_constant$integer
	   to adjust computed binary precision so that it matches the
	   precision that would be used if a decimal integer were
	   converted to binary */

dcl	prectab(0:10) fixed binary static init(0,5,8,11,15,18,21,25,28,31,35);

integer: entry(integer) returns(ptr);

	i = index(bit(integer,31),"1"b);
	if i = 0 then i = 1; else i = 31 - i + 1;

	do j = 0 to hbound(prectab,1)-1;
	     if i = prectab(j) then goto ok;
	     if i ^> prectab(j+1)
	     then do;
		i = prectab(j+1);
		goto ok;
		end;
	     end;

	i = max_p_fix_bin_1;

ok:	return(declare_constant(integer_image,integer_type,i,0));

desc: entry(bits) returns(ptr);

	return(declare_constant(bits,arg_desc_type,length(bits),0));

bit: entry(bits) returns(ptr);

	return(declare_constant(bits,bit_type,length(bits),0));

char: entry(char) returns(ptr);

	return(declare_constant(char_image,char_type,length(char),0));

     end;




		    declare_descriptor.pl1          07/31/89  1433.2r w 07/31/89  1338.3      172926



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



/****^  HISTORY COMMENTS:
  1) change(87-06-26,Huen), approve(87-06-26,MCR7712), audit(87-12-01,RWaters),
     install(87-12-01,MR12.2-1005):
     Fix bug1895
  2) change(88-01-29,RWaters), approve(88-01-29,MCR7724), audit(88-02-05,Huen),
     install(88-02-16,MR12.2-1024):
     Treat explicit_packed as packed.
                                                   END HISTORY COMMENTS */


/* format: style2 */

declare_descriptor:
     proc (cblk, stmnt, ps, loc, bit2) returns (ptr);

/*	Modified 780616 by PG for unsigned
	Modified:	790106 by RAB to fix 1811 (bad descriptors for interleaved
		packed arrays if array of structures is unpacked)	
	Modified:	810626 by EBush to remove the limit of 128 descriptors
		per constant size structure
          Modified: 871806 by RWaters to fix 1895 by diagnosing bad returns
		options
	Modified: 882801 by RW to accept symbol.explicit_packed as packed
*/

	dcl     (s, d, r, stmnt, blk, cblk, q, loc, st, ps)
				 ptr;
	dcl     (first, ptr_saver)	 ptr;
	dcl     (offset, size)	 fixed bin (15);
	dcl     scale		 fixed bin (12);
	dcl     bit2		 bit (2) aligned;
	dcl     (constant, actl, array_desc, cross_section, before_get_size, top_level, star_extents, controlled,
	        use_new)		 bit (1) aligned;

	dcl     pl1_stat_$util_abort	 variable static ext entry (fixed bin (15), ptr);

	dcl     max_desc		 (512) fixed bin (31);
						/* reserve 512 words in the stack */

	dcl     basic_desc		 bit (36) aligned based (addr (desc.bit_type));

	dcl     bit_image		 bit (size * bits_per_word) aligned based (addr (max_desc));

	dcl     1 desc		 based (addr (max_desc)),
		2 spacer		 (offset) fixed bin (31),
		2 basic_desc_image	 aligned,
		  3 bit_type	 unaligned,
		    4 flag	 unal bit (1),
		    4 type	 unal bit (6),
		    4 packed	 unal bit (1),
		    4 number_dims	 unal bit (4),
		  3 size		 unal bit (24),
		2 desc_image	 fixed bin (31);

/* internal static */

	dcl     star_bits		 bit (36) aligned internal static init ("100000000000000000000000000000000000"b);

/* builtins */

	dcl     (null, substr, string, fixed, bit, addr, unspec)
				 builtin;

/* program */

	before_get_size = "0"b;
	actl = "0"b;
	st = stmnt;

common:
	s = ps;
	use_new = "1"b;

	array_desc = substr (bit2, 1, 1);
	cross_section = substr (bit2, 2, 1);

/* see if a descriptor has already been made which can be
	   used in the present case.   */

	if ^(s -> symbol.based | s -> symbol.temporary | s -> symbol.position | actl)
	then if s -> symbol.dimensioned & ^array_desc
	     then if s -> symbol.array -> array.element_descriptor ^= null
		then if ^((s -> symbol.parameter | s -> symbol.controlled)
			& (s -> symbol.star_extents | s -> symbol.exp_extents))
		     then return (copy ((s -> symbol.array -> array.element_descriptor)));
		     else ;
		else ;
	     else if s -> symbol.descriptor ^= null
	     then if s -> symbol.star_extents & s -> symbol.parameter
		     & s -> symbol.descriptor -> reference.symbol -> symbol.descriptor = null
		then use_new = "0"b;
		else return (copy ((s -> symbol.descriptor)));
	     else ;
	else ;

	if before_get_size
	then call set_star (s);

	blk = s -> symbol.block_node;
	if blk = null
	then blk = cblk;

	controlled = s -> symbol.controlled & (st = null | actl);
	star_extents =
	     (s -> symbol.star_extents | (s -> symbol.parameter & s -> symbol.exp_extents)) & (st = null | actl);

	if s -> symbol.exp_extents | s -> symbol.star_extents
	then do;
		constant = "0"b;
		if (^actl | s -> symbol.descriptor = null) & use_new
		then do;
			d = create_symbol (blk, null, by_compiler);
			d -> symbol.boundary = word_;
			if s -> symbol.temporary | s -> symbol.return_value | s -> symbol.based
			     | (s -> symbol.parameter & ^star_extents) | (s -> symbol.controlled & ^before_get_size)
			then d -> symbol.temporary = "1"b;
			else do;
				d -> symbol.allocate = "1"b;
				if s -> symbol.controlled & before_get_size
				then do;
					d -> symbol.controlled = "1"b;
					d -> symbol.descriptor = s;
				     end;
				else d -> symbol.auto = "1"b;
			     end;

			d -> symbol.aligned, d -> symbol.variable, d -> symbol.internal,
			     d -> symbol.arg_descriptor = "1"b;
			r = d -> symbol.reference;
		     end;
		else do;
			r = copy ((s -> symbol.descriptor));
			d = r -> reference.symbol;
		     end;
	     end;
	else do;
		if before_get_size
		then return (null);

		constant = "1"b;
		r = create_reference (null);
	     end;

	if star_extents & ^s -> symbol.return_value
	then do;
		d -> symbol.location = s -> symbol.location;
		d -> symbol.allocated = s -> symbol.allocated;

		if d -> symbol.allocated
		then q = declare_pointer (blk);
		else do;
			q = create_operator (param_desc_ptr, 3);
			q -> operand (1) = declare_temporary (pointer_type, 0, 0, null);
			q -> operand (2) = declare_constant$integer (fixed (d -> symbol.location, 31));
			q -> operand (3) = blk;
		     end;

		r -> reference.qualifier = q;
		d -> symbol.param_desc = "1"b;
		d -> symbol.auto = "0"b;
	     end;


/* call the builder to create the descriptor.	*/

	size, offset = 0;
	top_level = "1"b;
	first = null;

	call builder (s);

	if constant
	then do;
		d = declare_constant$desc (bit_image) -> reference.symbol;
		do while (first ^= null);
		     ptr_saver = first -> reference.symbol;
		     first -> reference.symbol = d;
		     first = ptr_saver;
		end;
	     end;
	else do;
		if s -> symbol.parameter & array_desc & st = null
		then if ^(before_get_size & s -> symbol.structure)
		     then d -> symbol.descriptor = declare_constant$desc (bit_image) -> reference.symbol;
		d -> symbol.c_word_size = size;
		d -> symbol.c_bit_size = size * bits_per_word;
	     end;

	d -> symbol.reference -> reference.units = 0;

	return (d -> symbol.reference);


/* Special entry point for making assignments to controlled descriptors
  at allocate time */

ctl:
     entry (cblk, stmnt, ps, loc, bit2) returns (ptr);
	actl = "1"b;
	before_get_size = "0"b;
	st = create_statement (null_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
	go to common;

/* Entry point for calls to declare_descriptor before all extents and bounds
   have been calculated by get_size */

param:
     entry (cblk, stmnt, ps, loc, bit2) returns (ptr);
	actl = "0"b;
	st = stmnt;
	before_get_size = "1"b;
	go to common;

/* routine to propagate star_extents bit upwards */

set_star:
     proc (pp);
	dcl     (pp, p, d)		 pointer;
	p = pp;

	do d = p -> symbol.son repeat d -> symbol.brother while (d ^= null);
	     call set_star (d);

	     p -> symbol.star_extents = p -> symbol.star_extents | d -> symbol.star_extents;
	     p -> symbol.exp_extents = p -> symbol.exp_extents | d -> symbol.exp_extents;
	end;

     end set_star;

/* subroutine to make a copy of a reference node only if offset|length|qual
   are non-null */

copy:
     proc (ref) returns (ptr);

	dcl     ref		 ptr,
	        p			 ptr;

	p = ref;

	if p -> reference.offset ^= null | p -> reference.length ^= null | p -> reference.qualifier ^= null
	then p = copy_expression ((p));

	return (p);

     end;

/* subroutine to build a descriptor and fill it in.	*/

builder:
     proc (pp);

	dcl     (p, q, b, sf, pp)	 ptr;
	dcl     (i, m, mdims, ndims, nbounds, type)
				 fixed bin (15);
	dcl     (cdcl, have_star)	 bit (1);

	p = pp;

	type = pl1_descriptor_type (substr (string (p -> symbol.attributes), 1, 36), (p -> symbol.c_dcl_size));

	offset = size;
	if offset ^= 0
	then r -> reference.units = word_;
	size = size + 1;

	if size > 512
	then call pl1_stat_$util_abort (28, s);

	desc.type = bit (fixed (type, 6), 6);
	desc.flag = "1"b;
	desc.packed = p -> symbol.packed | p -> symbol.explicit_packed;
/* the bit image made for parameters may have this bit incorrectly be "0"b */

/* Get number of bounds to process */

	ndims = 0;
	do sf = p repeat sf -> symbol.father while (sf ^= null & (array_desc | sf ^= s));
	     if sf -> symbol.array ^= null
	     then ndims = ndims + sf -> symbol.array -> array.own_number_of_dimensions;

	     if cross_section
	     then if sf = s
		then go to set_mdims;
	end;

set_mdims:
	if ndims > 15
	then call pl1_stat_$util_abort (492, s);

	mdims = ndims;

	if ndims ^= 0
	then desc.number_dims = bit (fixed (ndims, 4), 4);
	else desc.number_dims = "0"b;

	desc.size = "0"b;

/* fill in the size field of the descriptor.	*/

	if p -> symbol.char | p -> symbol.bit | p -> symbol.area | p -> symbol.float | p -> symbol.fixed
	     | p -> symbol.picture
	then desc.size = bit (fixed (p -> symbol.c_dcl_size, 24), 24);

	if p -> symbol.fixed
	then do;
		scale = p -> symbol.scale;
		if scale < 0
		then scale = scale + 1000000000000b;
		substr (desc.size, 1, 12) = bit (scale, 12);
	     end;

	if p -> symbol.structure
	then do;
		m = 0;
		q = p -> symbol.son;
		do while (q ^= null);
		     m = m + 1;
		     q = q -> symbol.brother;
		end;
		desc.size = bit (fixed (m, 24), 24);
	     end;

	if ^constant
	then do;
		cdcl, have_star = "0"b;
		if p -> symbol.dcl_size = null
		then cdcl = "1"b;
		else if p -> symbol.dcl_size -> node.type = token_node
		then if p -> symbol.dcl_size -> token.type = dec_integer
		     then do;
			     cdcl = "1"b;
			     desc.size = bit (fixed (token_to_binary ((p -> symbol.dcl_size)), 24), 24);
			end;
		     else have_star = p -> symbol.dcl_size -> token.type = asterisk;

		if (p -> symbol.bit | p -> symbol.char | p -> symbol.area) & ^cdcl
		then if star_extents
		     then do;
			     if have_star
			     then do;
				     q = create_operator (desc_size, 2);
				     q -> operand (2) = copy_expression ((r));
				     q -> operand (2) -> reference.c_offset = offset;
				     p -> symbol.dcl_size = q;

				     if ^p -> symbol.area & ^p -> symbol.varying
				     then p -> symbol.reference -> reference.length = q;
				end;

			     desc.size = (24)"1"b;
			end;
		     else do;
			     q = create_operator (make_desc, 3);
			     q -> operand (1) = d -> symbol.reference;
			     q -> operand (2) = declare_constant$desc (string (desc.bit_type));
			     if ^actl
			     then do;
				     q -> operand (3) = p -> symbol.dcl_size;
				     if controlled
				     then do;
					     p -> symbol.symtab_size = p -> symbol.dcl_size;
					     q = create_operator (desc_size, 2);
					     q -> operand (2) = copy_expression ((r));
					     q -> operand (2) -> reference.c_offset = offset;
					     p -> symbol.dcl_size = q;
					end;
				     else call assignf (q, offset);
				end;
			     else do;
				     q -> operand (3) = p -> symbol.symtab_size;
				     call assignf (q, offset);
				end;
			end;
		else if star_extents | (controlled & ^actl)
		then ;
		else call assignf (declare_constant$desc (basic_desc), offset);
	     end;

/* process the array attribute by putting the bounds and multipliers in the descriptor.	*/

	if ndims ^= 0
	then do;
		r -> reference.units = word_;
		sf = p;

/* In dimensioned structures the bound nodes get factored down when get_size
   (and thus get_array_size) gets called.  If the bounds have been factored
   down, number_of_dimensions tells us how many bounds get processed.  If
   they have not been factored down, we use the sum of own_number_of_dimensions
   for the element and each of its ancestors to determine how many bounds get
   processed.
*/


		do while (mdims > 0);

		     do while (sf -> symbol.array = null);
			sf = sf -> symbol.father;
		     end;

		     b = sf -> symbol.array -> array.bounds;

		     if before_get_size
		     then nbounds = sf -> symbol.array -> array.own_number_of_dimensions;
		     else nbounds = sf -> symbol.array -> array.number_of_dimensions;

		     sf = sf -> symbol.father;

		     do i = 1 to nbounds;
			size = size + 3;
			if size > 512
			then call pl1_stat_$util_abort (28, s);
			if ^constant & ^before_get_size
						/* before_get_size --> parameter --> bounds are either constant or * */
			then do;
				if b -> bound.lower = null
				then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
				if b -> bound.upper = null
				then b -> bound.upper = declare_constant$integer ((b -> bound.c_upper));
			     end;

			call do_lbound;
			offset = offset + 1;
			call do_hbound;		/* input here */
			offset = offset + 1;
			call do_mult;

			offset = offset + 1;
			b = b -> bound.next;
			mdims = mdims - 1;
			if mdims = 0
			then go to record_reference;
		     end;

		end;

	     end;

/* Record a reference to the descriptor either in the symbol node or in the array node.  */

record_reference:
	q = copy_expression ((r));
	q -> reference.c_offset = offset - ndims * 3;
	if offset = 0
	then q -> reference.units = 0;

	if p -> symbol.dimensioned & ^array_desc
	then if p -> symbol.array -> array.element_descriptor = null & top_level
	     then p -> symbol.array -> array.element_descriptor = q;
	     else ;
	else if p -> symbol.descriptor = null
	then p -> symbol.descriptor = q;


/* If this is a constant descriptor chain this reference so that its symbol ptr
   can be filled in when the symbol node is created. */

	if constant
	then do;
		q -> reference.symbol = first;
		first = q;
	     end;

/* If this is a structure call the builder to create descriptors for the members.
   The members descriptors are part of the structure's descriptor.  */

	if p -> symbol.structure
	then do;
		top_level = "0"b;

		do q = p -> symbol.son repeat q -> symbol.brother while (q ^= null);
		     call builder (q);
		end;
	     end;

do_lbound:
     procedure;

	declare lbound_constant	 bit (1) aligned;

	lbound_constant = "0"b;
	if star_extents
	then if b -> bound.lower -> node.type = token_node
	     then if b -> bound.lower -> token.type = dec_integer
						/* has to be that or * */
		then do;
			lbound_constant = "1"b;
			b -> bound.c_lower = token_to_binary ((b -> bound.lower));
		     end;
		else ;				/* not dec integer */
	     else lbound_constant = "1"b;		/* not token at all, error */

	lbound_constant = lbound_constant | constant;

	if lbound_constant
	then desc_image = b -> bound.c_lower;
	else if star_extents
	then do;
		unspec (desc_image) = star_bits;
		b -> bound.lower = copy_expression ((r));
		b -> bound.lower -> reference.c_offset = offset + 1;
	     end;
	else if controlled
	then if ^actl
	     then do;
		     if b -> bound.symtab_lower = null
		     then b -> bound.symtab_lower = b -> bound.lower;
		     if b -> bound.lower -> node.type = token_node
		     then if b -> bound.lower -> token.type = dec_integer
			then return;
		     b -> bound.lower = copy_expression ((r));
		     b -> bound.lower -> reference.c_offset = offset + 1;
		end;
	     else call assignf ((b -> bound.symtab_lower), offset + 1);
	else call assignf ((b -> bound.lower), offset + 1);

     end do_lbound;

do_hbound:
     procedure;

	declare hbound_constant	 bit (1) aligned;

	hbound_constant = "0"b;

	if star_extents
	then if b -> bound.upper -> node.type = token_node
	     then if b -> bound.upper -> token.type = dec_integer
						/* has to be that or * */
		then do;
			hbound_constant = "1"b;
			b -> bound.c_upper = token_to_binary ((b -> bound.upper));
		     end;
		else ;				/* not dec integer */
	     else hbound_constant = "1"b;		/* not token at all, error */

	hbound_constant = constant | hbound_constant;

	if hbound_constant
	then desc_image = b -> bound.c_upper;
	else if star_extents
	then do;
		unspec (desc_image) = star_bits;
		b -> bound.upper = copy_expression ((r));
		b -> bound.upper -> reference.c_offset = offset + 1;
	     end;
	else if controlled
	then if ^actl
	     then do;
		     if b -> bound.symtab_upper = null
		     then b -> bound.symtab_upper = b -> bound.upper;
		     if b -> bound.upper -> node.type = token_node
		     then if b -> bound.upper -> token.type = dec_integer
			then return;
		     b -> bound.upper = copy_expression ((r));
		     b -> bound.upper -> reference.c_offset = offset + 1;
		end;
	     else call assignf ((b -> bound.symtab_upper), offset + 1);
	else call assignf ((b -> bound.upper), offset + 1);

     end do_hbound;

do_mult:
     procedure;

	if star_extents
	then do;
		unspec (desc_image) = star_bits;
		if b -> bound.desc_multiplier = null
		then do;
			b -> bound.desc_multiplier, b -> bound.multiplier = copy_expression ((r));
			b -> bound.desc_multiplier -> reference.c_offset = offset + 1;
		     end;
	     end;
	else if constant
	then desc_image = b -> bound.c_desc_multiplier;
	else if controlled
	then if ^actl
	     then do;
		     b -> bound.desc_multiplier, b -> bound.multiplier = copy_expression ((r));
		     b -> bound.desc_multiplier -> reference.c_offset = offset + 1;
		end;
	     else call assignm ((b -> bound.symtab_multiplier), offset + 1);
	else call assignf ((b -> bound.desc_multiplier), offset + 1);
     end do_mult;
     end builder;

/* subroutine to make an assignment to a descriptor.	*/

assignf:
     proc (e, offset);

	dcl     (e, p, q, stp)	 ptr;
	dcl     offset		 fixed bin (15);

	stp = st;

common:
	p = create_operator (assign, 2);
	p -> operand (1) = copy_expression ((r));
	p -> operand (1) -> reference.c_offset = offset;
	q = copy_expression ((e));

	if s -> symbol.refer_extents
	then call refer_extent (q, loc);

	p -> operand (2) = q;

	if s -> symbol.based | s -> symbol.temporary | s -> symbol.position | s -> symbol.controlled
	     | s -> symbol.parameter | s -> symbol.return_value
	then do;
		if stp = null   /* Bug 1895: diagnose bad returns options */
		then do;
			if s -> symbol.reference -> reference.padded_ref
			then call pl1_stat_$util_abort (37,s);   /* in stmnt */
			else call pl1_stat_$util_abort (22,s);   /* in dcl */
		     end;
		q = create_statement (assignment_statement, (stp -> statement.back), null, (stp -> statement.prefix));
		q -> statement.root = expression_semantics (blk, q, p, "0"b);
	     end;
	else do;
		q = create_statement$prologue (assignment_statement, blk, null, (blk -> block.prefix));
		q -> statement.root = p;
		if cblk ^= blk
		then q -> statement.root = expression_semantics (cblk, q, (q -> statement.root), "0"b);
	     end;

	return;

/* Special entry point for generating multiplier assignments to controlled descriptors */

assignm:
     entry (e, offset);

	stp = stmnt;
	go to common;

     end assignf;

%include pl1_descriptor_type_fcn;

/* include files */

%include semant;
%include symbol;
%include array;
%include reference;
%include statement;
%include block;
%include operator;
%include statement_types;
%include op_codes;
%include system;
%include declare_type;
%include boundary;
%include nodes;
%include token;
%include token_types;
     end /* declare_descriptor */;




		    declare_integer.pl1             07/31/89  1433.2r w 07/31/89  1338.3       12105



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

declare_integer:	proc(cur_block) returns(ptr);

declare	(cur_block,s) pointer;
declare	null builtin;
%include language_utility;
%include boundary;
%include declare_type;
%include symbol;
%include system;


	s = create_symbol(cur_block,(null),by_compiler);

	substr (string (s -> symbol.attributes), 1, 36) = integer_type;

	s->symbol.auto  ,
	s->symbol.allocate = "1"b;

	s->symbol.boundary=word_;
	s->symbol.c_word_size=1;
	s->symbol.c_bit_size=bits_per_word;
	s->symbol.c_dcl_size=default_fix_bin_p;

	return(s->symbol.reference);

	end declare_integer;




		    declare_picture.pl1             07/31/89  1433.2r w 07/31/89  1338.3       26694



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


declare_picture:	proc(string,symbol_ptr,error_code);

dcl	string char(*) aligned;
dcl	symbol_ptr ptr;
dcl	error_code fixed bin(15);

dcl	n_storage_nodes fixed bin;

dcl	pl1_stat_$node_uses(32) fixed bin ext static;

dcl	bit_value bit(648) aligned based(addr(picture_constant));

dcl	(addr,substr) builtin;

dcl	picture_info_ ext entry(char(*)aligned,ptr,fixed bin(15));

%include language_utility;
%include picture_constant;
%include picture_image;
%include picture_types;
%include reference;
%include symbol;
%include system;

	call picture_info_(string,addr(picture_constant),error_code);

	if error_code^=0
	then do;
		picture_constant.piclength = 64;

		/* following code is inserted only to prevent future faults */

		symbol_ptr->symbol.pix.pic_fixed = "1"b;
		symbol_ptr->symbol.pix.pic_size = default_fix_dec_p;
		goto skip;
	end;

	symbol_ptr->symbol.pix.pic_size = picture_constant.prec;

	if picture_constant.type = real_fixed_picture
	then	symbol_ptr->symbol.pix.pic_fixed = "1"b;
	else	symbol_ptr->symbol.pix.pic_float = "1"b;

	if symbol_ptr->symbol.pix.pic_fixed
	then	symbol_ptr->symbol.pix.pic_scale = picture_constant.scale-picture_constant.scalefactor;

	if picture_constant.type=char_picture
	then	symbol_ptr->symbol.pix.pic_char = "1"b;

	if symbol_ptr->symbol.complex
	then do;
		if picture_constant.type = real_fixed_picture
		then	picture_constant.type = cplx_fixed_picture;
		else	if picture_constant.type = real_float_picture
			then	picture_constant.type = cplx_float_picture;

		symbol_ptr->symbol.reference->reference.c_length,
		symbol_ptr->symbol.c_dcl_size = 2 * picture_constant.varlength;
	end;

	else do;
		symbol_ptr->symbol.reference->reference.c_length  ,
		symbol_ptr->symbol.c_dcl_size = picture_constant.varlength;
	end;

skip:

	/* Note that we really should use unspec(addr(picture_constant) -> picture_image) */

	/* We don't want the picture constant to be allocated unless absolutely necessary
	   (e.g., for I/O), but we don't want to turn off allocate bit if it was
	   turned on for a previous picture.  Since declare_constant normally turns
	   the bit on, we must go to some trouble to do this right. */

	n_storage_nodes = pl1_stat_$node_uses(14);
	symbol_ptr->symbol.general = declare_constant$bit(substr(bit_value,1,72+picture_constant.piclength*9));
	if n_storage_nodes ^= pl1_stat_$node_uses(14)
	     then symbol_ptr->symbol.general->reference.symbol->symbol.allocate = "0"b;

	end declare_picture;




		    declare_picture_temp.pl1        07/31/89  1433.2r w 07/31/89  1338.3       25155



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




/****^  HISTORY COMMENTS:
  1) change(87-04-15,RWaters), approve(87-04-15,MCR7635),
     audit(87-04-28,Huen), install(87-05-21,MR12.1-1033):
     Fix bug #1869
                                                   END HISTORY COMMENTS */

/* Modified 86/06/21 by RW to allow do loop indexes to be picture variables
*/
declare_picture_temp: proc (pic_str, scalefac, complex_bit, unaligned_bit) returns (ptr);


	dcl     (p, s)		 ptr;
	dcl     p_str		 char (256) varying aligned;
	dcl     pl1_stat_$temporary_list external static pointer;
	dcl     pic_str		 char (*) aligned;
	dcl     (complex_bit, unaligned_bit) bit (1) aligned;
	dcl     scalefac		 fixed bin (31) aligned;
	dcl     aligned_bit		 bit (1);
	dcl     null		 builtin;


%include declare_type;
%include semant;
%include token_types;
%include picture_image;
%include symbol;
%include reference;

	aligned_bit = ^unaligned_bit;
	do s = pl1_stat_$temporary_list repeat s -> symbol.multi_use while (s ^= null);
	     if s -> symbol.picture
	     then if s -> symbol.aligned = aligned_bit
		then if s -> symbol.complex = complex_bit
		     then do;
			     if s -> symbol.general ^= null then do;
				     p = s -> symbol.general -> reference.symbol -> symbol.initial;
				     if p -> picture_image.chars = pic_str
				     then if p -> picture_image.scalefactor = scalefac
					then return ((s -> symbol.reference));
				end;
			end;

	end;

	s = create_symbol (null, null, by_compiler);
	s -> symbol.aligned = aligned_bit;
	s -> symbol.unaligned = unaligned_bit;
	s -> symbol.complex = complex_bit;
	s -> symbol.temporary,
	     s -> symbol.picture = "1"b;
	if scalefac = 0
	then s -> symbol.general = create_token ((pic_str), char_string);
	else do;
		p_str = pic_str;
		p_str = p_str || "f(";
		p_str = p_str || bindec$vs (scalefac);
		p_str = p_str || ")";		/* this done in small increments for better concatenation code */

		s -> symbol.general = create_token ((p_str), char_string);
	     end;

	call get_size (s);

	s -> symbol.multi_use = pl1_stat_$temporary_list;
	pl1_stat_$temporary_list = s;

	return ((s -> symbol.reference));

     end;




		    declare_pointer.pl1             07/31/89  1433.2r w 07/31/89  1338.3       11313



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

declare_pointer:	proc(cur_block) returns(ptr);

dcl	(cur_block,s) ptr;
dcl	null builtin;

%include language_utility;
%include boundary;
%include declare_type;
%include symbol;
%include system;


	s=create_symbol(cur_block,(null),by_compiler);

	s->symbol.ptr  ,
	s->symbol.auto  ,
	s->symbol.allocate = "1"b;

	s->symbol.boundary=mod2_;
	s->symbol.c_word_size=2;
	s->symbol.c_bit_size=bits_per_word+bits_per_word;

	return(s->symbol.reference);

	end declare_pointer;




		    declare_temporary.pl1           07/31/89  1433.2r w 07/31/89  1338.3       24435



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

declare_temporary:	proc(type,precision,scale,length) returns(ptr);

/*	Modified: 1 May 1979 by PCK to implement 4-bit decimal */

dcl	(length,s,q) ptr;
dcl	scale fixed bin(15);
dcl	precision fixed bin(31);
dcl	type bit(36) aligned;
dcl	bit36 bit(36) based(addr(s->symbol.data_type));

dcl	pl1_stat_$temporary_list ptr ext static;

dcl	(addr,null) builtin;

%include language_utility;
%include symbol;
%include boundary;
%include mask;

%include reference;
%include declare_type;
			/*      */

	if length=null
	& (type & picture_mask)="0"b
	then do s=pl1_stat_$temporary_list repeat s->symbol.multi_use while(s^=null);
		if ^s->symbol.reference->reference.shared then goto next_temporary;
		if bit36^=type then goto next_temporary;
		if s->symbol.c_dcl_size^=precision then goto next_temporary;
		if s->symbol.scale^=scale then goto next_temporary;
		if s->symbol.dcl_size^=null then goto next_temporary;
		return(s->symbol.reference);
next_temporary:
	end;

	s = create_symbol(null,null,by_compiler);
	bit36=type;
	s->symbol.c_dcl_size=precision;
	s->symbol.scale=scale;
	s->symbol.dcl_size=length;
	s->symbol.temporary = "1"b;
	s->symbol.exp_extents = length ^= null;

	if	s->symbol.unaligned
	then if	s->symbol.binary
	|	s->symbol.ptr
	|	s->symbol.decimal
	then	s->symbol.packed = "1"b;

	call get_size(s);

	if s->symbol.bit | s->symbol.char | s->symbol.picture
	then do;
		q = s->symbol.reference;
		q -> reference.padded_ref = "1"b;
		if s->symbol.varying
		then	q->reference.varying_ref = "1"b;
		else do;
			q->reference.c_length = s->symbol.c_dcl_size;
			q->reference.length = s->symbol.dcl_size;
		end;
		if q->reference.length^=null
		then do;
			q->reference.shared = "0"b;
			q->reference.ref_count = 1;
		end;
	end;

	if s->symbol.storage_block then s->symbol.boundary = mod2_;
	s->symbol.multi_use=pl1_stat_$temporary_list;
	pl1_stat_$temporary_list=s;

	return(s->symbol.reference);

	end declare_temporary;




		    decode_node_id.pl1              10/03/83  1728.7rew 10/03/83  1007.5       16146



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


decode_node_id: proc(pt,caps) returns(char(120) varying);

dcl	pt ptr,		/* points at any node */
	caps bit(1) aligned; /* TRUE if capitals desired */

dcl	k fixed bin,
	bindec$vs entry(fixed bin(15)) returns(char(12) varying),
	v char(120) varying;

dcl	statement(0:1) char(10) aligned static
	 init("statement ", "STATEMENT "),
	on(0:1) char(4) aligned static init(" on ", " ON "),
	line(0:1) char(5) aligned static init("line ", "LINE "),
	file(0:1) char(9) aligned static init(" of file ", " OF FILE ");

dcl	(addr,fixed,string) builtin;

%include nodes;
%include source_id;
%include source_list;
%include token;

	string(source_id) = string(pt -> node.source_id);
	go to begin;

decode_source_id:
	entry(id, caps) returns(char(120) varying);

dcl	1 id like source_id;

	string(source_id) = string(id);

begin:
	k = fixed(caps,1);

	m = fixed(source_id.statement_number,5);
	if m = 1 then v = "";
	else do;
	     v = statement(k) || bindec$vs(m);
	     v = v || on(k);
	     end;

	v = v || line(k);
	v = v || bindec$vs(fixed(source_id.line_number,14));

	m = fixed(source_id.file_number,8);

	if m ^= 0
	then do;
	     v = v || file(k);
	     v = v || bindec$vs(m);
	     v = v || " (";
	     v = v || source.name -> token.string;
	     v = v || ")";
	     end;

	return(v);
	end;




		    display_pl1_map.pl1             10/03/83  1728.7rew 10/03/83  1007.0       31320



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


/* program to print map of generated object code

   Modified: 22 May 1971 by BLW for Version II
   Modified: 24 July 1972 by BLW
   Modified: 13 Feb 1977 by RAB for multiple conditions/on-unit	*/

display_pl1_map: proc(pt);

dcl	pt ptr;		/* points at root block */

dcl	p ptr,
	line aligned char(120) int static,
	n fixed bin(17),
	pl1_print$non_varying_nl entry(char(*) aligned,fixed bin),
	pos fixed bin int static,
	old_id bit(27) int static,
	bindec entry(fixed bin) returns(char(12)),
	binoct entry(fixed bin) returns(char(12));

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

%include block;
%include block_types;
%include statement;
%include statement_types;
%include operator;

	call pl1_print$non_varying_nl("",0);
	call pl1_print$non_varying_nl((7)"   LINE    LOC   ",0);

	line = "";
	pos = 1;
	old_id = "0"b;
	call prt_block(pt -> block.son);

	if pos > 1 then call pl1_print$non_varying_nl(line,pos-4);

prt_block:     proc(ptx);

dcl	     ptx ptr unaligned;

dcl	     (pt,p) ptr;

	     pt = ptx;
	     if pt = null then return;

	     if pt -> block.block_type = begin_block
	     then do;
db:		call prt_block(pt -> block.brother);
		return;
		end;

	     if pt -> block.block_type = on_unit then goto db;

	     goto l1;

prt_other_block: entry(ptx);

	     pt = ptx;

l1:	     p = pt -> block.prologue;
	     if p = null then goto do_main;

	     do while(p ^= null);
		call prt_statement(p);
		p = p -> statement.next;
		end;

do_main:	     p = pt -> block.main;
	     do while(p ^= null);
		call prt_statement(p);
		p = p -> statement.next;
		end;

	     /* since the code_generator turns the processed bit ON for
	        each block, turning it OFF will indicate that we have
	        processed it */

	     pt -> block.processed = "0"b;

	     call prt_block(pt -> block.son);

	     if pt -> block.block_type ^= begin_block
	     then if pt -> block.block_type ^= on_unit
		then call prt_block(pt -> block.brother);

	     end;

prt_statement: proc(q);

dcl	     q ptr,
	     bit_s_id bit(27),
	     (i,ln) fixed bin;

	     i = q -> statement.object.start;
	     if i = q -> statement.object.finish then goto no;

	     bit_s_id = string(q -> statement.source_id);
	     if bit_s_id = old_id then goto no;

	     ln = fixed(substr(bit_s_id,9,14),14);
	     substr(line,pos+3,4) = substr(bindec(ln),9,4);
	     substr(line,pos+8,6) = substr(binoct(i),7,6);

	     ln = fixed(substr(bit_s_id,1,8),8);
	     if ln ^= 0 then substr(line,pos,2) = substr(bindec(ln),11,2);

	     pos = pos + 17;

	     if pos >= 112
	     then do;
		call pl1_print$non_varying_nl(line,pos-4);
		line = "";
		pos = 1;
		end;

	     old_id = bit_s_id;

no:	     if q -> statement.statement_type = begin_statement
	     then call prt_other_block(q -> statement.root);
	     else if q -> statement.statement_type = on_statement
		then if q -> statement.root -> operand(3) -> block.processed
		     then call prt_other_block(q -> statement.root -> operand(3));

	     end;

	end;




		    display_pl1_text.pl1            10/03/83  1728.7rew 10/03/83  1007.5      105435



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


/* program to display binary text produced by pl/1 compiler

   Revised Version: 20 January, 1969 by BLW
	Modified: 18 April 1971 by BLW for Version II
	Modified: 19 August 1972 by BLW
	Modified:	1 August 1974 by RAB for relocatable constants
	Modified:	11 February 1977 by RAB for multiple conditions per on-unit	*/

display_pl1_text: proc(pt);

dcl	pt	ptr;	/* points at root block node */

dcl	p ptr,
	n fixed bin,
	(cg_static_$text_base,cg_static_$text_reloc_base,cg_static_$encoded_values,
	 cg_static_$constant_list,cg_static_$format_list,cg_static_$sym_use_base,
	 cg_static_$label_list) ptr ext static,
	line char(60) varying int static,
	old_id bit(27) int static,
	blk_pt ptr int static,
	(block_count fixed bin,nested_proc bit(1)) int static,
	display_text entry(ptr,ptr,ptr,fixed bin,fixed bin),
	display_text$display_ascii entry(ptr,fixed bin(31)),
	bindec ext entry(fixed bin) returns(char(12)),
	bindec$vs entry(fixed bin) returns(char(12) varying),
	display_text$display_abs entry(ptr,ptr,fixed bin(31)),
	pl1_print$non_varying_nl entry(char(*) aligned,fixed bin),
	pl1_print$unaligned_nl entry(char(*) unaligned,fixed bin),
	pl1_print$varying_nl entry(char(*) varying);

dcl	(addr,addrel,bit,divide,fixed,length,null,ptr,string,substr) builtin;

dcl	encode_names(6) char(20) varying int static init("size of ",
	 "offset of ", "virtual origin of ",
	 "lower bound of ", "upper bound of ", "multiplier of ");

%include cgsystem;
%include block;
%include statement;
%include symbol;
%include array;
%include reference;
%include operator;
%include list;
%include label;
%include ev_node;
%include token;
%include block_types;
%include statement_types;

	line = "";
	block_count = 0;
	nested_proc, old_id = "0"b;
	call prt_block(pt -> block.son);
	return;

prt_block:     proc(pt);

dcl	     pt ptr unaligned;	/* points at block node */

dcl	     (p,p1,q,r_pt,t_pt,bp,text_base,text_reloc_base,sym_use_base) ptr,
	     (size,type,i,k) fixed bin,
	     put_const bit(1) aligned,
	     name char(32) varying;

	     bp = pt;
	     if bp = null then return;

	     text_base = cg_static_$text_base;
	     text_reloc_base = cg_static_$text_reloc_base;
	     sym_use_base = cg_static_$sym_use_base;

	     if bp -> block.block_type = begin_block
	     then do;
db:		call prt_block(bp -> block.brother);
		return;
		end;

	     if bp -> block.block_type = on_unit then goto db;

	     call entry_name((bp -> block.main),name);
	     line = "BEGIN PROCEDURE "||name;

	     if nested_proc then goto common;

	     nested_proc = "1"b;

do_consts:     p = cg_static_$constant_list;
	     if p = null then goto ce;

	     /* display all constant nodes without equivalent ptr */

	     put_const = "1"b;
	     do while(p ^= null);

		if p -> symbol.equivalence ^= null then goto next_const;

		if p -> symbol.allocated
		then do;

		     if put_const
		     then do;
			call pl1_print$non_varying_nl("CONSTANTS",9);
			put_const = "0"b;
			end;

		     t_pt = addrel(text_base,p -> symbol.location);
		     r_pt = addrel(text_reloc_base,p -> symbol.location);

		     if p -> symbol.char
		     then do;

			q = p -> symbol.array;

			if p -> symbol.varying
			then do;

			     if q = null then k = p -> symbol.c_word_size;
			     else k = q -> array.c_element_size;

			     do i = 1 by k to p -> symbol.c_word_size;
				call display_text$display_abs(t_pt,r_pt,1);
				call display_text$display_ascii(addrel(t_pt,1),(p -> symbol.c_dcl_size));
				t_pt = addrel(t_pt,k);
				end;

			     end;
			else do;
			     if q = null then k = p -> symbol.c_dcl_size;
			     else k = p -> symbol.c_word_size * chars_per_word;

			     call display_text$display_ascii(t_pt,(k));
			     end;

			end;
		     else call display_text$display_abs(t_pt,r_pt,(p -> symbol.c_word_size));

		     call pl1_print$non_varying_nl("",0);

		     end;

next_const:	p = p -> symbol.multi_use;
		end;

ce:	     p = cg_static_$encoded_values;
	     if p = null then goto formats;

	     call pl1_print$non_varying_nl("ENCODED VALUES",0);

	     do while(p ^= null);
		q = p -> ev_node.name;

		if q = null
		then do;
		     call pl1_print$non_varying_nl("",0);
		     goto cf;
		     end;

		call pl1_print$varying_nl(encode_names(p -> ev_node.code)
		 || q -> token.string);

cf:		p1 = p -> ev_node.equiv;
		do while(p1 ^= null);
		     q = p1 -> ev_equiv.name;
		     if q = null then goto cg;
		     call pl1_print$varying_nl(encode_names(p1 -> ev_equiv.code)
		      || q -> token.string);
cg:		     p1 = p1 -> ev_equiv.next;
		     end;

		call display_text(text_base,text_reloc_base,sym_use_base,
		 (p -> ev_node.first),p -> ev_node.last - p -> ev_node.first);

		p = p -> ev_node.next;
		end;

	     call pl1_print$non_varying_nl("",0);

formats:	     p = cg_static_$format_list;
	     if p = null then goto label_arrays;

	     call pl1_print$non_varying_nl("FORMATS",0);

	     do while(p ^= null);
		q = p -> element(2);
		call display_text$display_abs(addrel(text_base,q -> symbol.location),
		 addrel(text_reloc_base,q -> symbol.location),(q -> symbol.c_word_size));
		call pl1_print$non_varying_nl("",0);

		p = p -> element(1);
		end;

label_arrays:
	     p = cg_static_$label_list;
	     if p = null then go to common;

	     call pl1_print$non_varying_nl("LABEL ARRAYS",0);

	     do while(p ^= null);
		q = p -> element(2);
		call display_text(text_base,text_reloc_base,sym_use_base,
		 (q->label.location), q->label.high_bound - q->label.low_bound + 1);
		call pl1_print$non_varying_nl("",0);

		p = p -> element(1);
		end;

	     goto common;

prt_on_unit:   entry(pt);

	     bp = pt;

	     call entry_name((bp -> block.main),name);
	     line = "BEGIN CONDITION "||name;
	     goto com;

prt_begin_block: entry(pt);

	     bp = pt;

	     block_count = block_count+1;
	     name = substr(bindec(block_count),11,2);
	     line = "BEGIN BLOCK "||name;

com:	     text_base = cg_static_$text_base;
	     text_reloc_base = cg_static_$text_reloc_base;
	     sym_use_base = cg_static_$sym_use_base;

common:	     blk_pt = bp;

	     if bp -> block.number_of_entries = 1 then goto do_main;

	     p = bp -> block.prologue;

	     if p = null
	     then if bp -> block.plio_ps = null
		then goto do_main;

	     call pl1_print$varying_nl(line);
	     line = "PROLOGUE SEQUENCE";

	     if bp -> block.block_type = begin_block
	     then if bp -> block.plio_ps = null
		then goto do_prol; else goto pr_dt;

	     call pl1_print$varying_nl(line);
	     line = "";

pr_dt:	     n = bp -> enter.start;
	     call display_text(text_base,text_reloc_base,sym_use_base,n,bp -> enter.end - n);

do_prol:	     do while(p ^= null);
		call prt_statement(p);
		p = p -> statement.next;
		end;

	     if bp -> block.block_type ^= begin_block
	     then do;
		n = bp -> leave.start;
		call display_text(text_base,text_reloc_base,sym_use_base,n,
		 bp -> leave.end - n);
		end;

	     line = "MAIN SEQUENCE";

do_main:	     p = bp -> block.main;
	     do while(p ^= null);
		call prt_statement(p);
		p = p -> statement.next;
		end;

	     bp -> block.text_displayed = "1"b;

	     call prt_block(bp -> block.son);

	     if bp -> block.block_type = begin_block
	     then do;
		call pl1_print$varying_nl("  END BLOCK "||name);
		return;
		end;

	     if bp -> block.block_type = on_unit
	     then do;
		call pl1_print$varying_nl("  END CONDITION "||name);
		return;
		end;

	     call pl1_print$varying_nl("  END PROCEDURE "||name);

	     call prt_block(bp -> block.brother);
	     end;

prt_statement: proc(tq);

dcl	     (tq,q) ptr,	/* points at statement node */
	     bit_s_id bit(27),
	     stm char(133),
	     heading char(132) varying,
	     sixht char(6) int static init((6)"	"),
	     nl char(1) int static init("
"),
	     c char(1),
	     blank bit(1),
	     source_pt ptr,
	     ename char(32) varying,
	     st_type bit(9),
	     (i,j,l,ln,sn,k,c2) fixed bin,
	     c1 fixed bin(21);

dcl	     source_segment char(262143) aligned based(source_pt);

dcl	     1 fake	aligned based(source_pt),
	     2 skip	char(c1-1) unaligned,
	     2 sub_str	char(c2) unaligned;

%include source_list;

	     q = tq;
	     st_type = q -> statement.statement_type;

	     i = q -> statement.object.start;
	     j = q -> statement.object.finish;
	     if i = j
	     then do;
		if st_type = begin_statement then goto l1;
		if st_type = continue_statement then goto l1;
		if st_type = do_statement then goto l1;
		if st_type = end_statement then goto l1;
		return;
		end;

l1:	     if st_type = entry_statement | st_type = procedure_statement
	     then do;
		if length(line) ^= 0 then call pl1_print$varying_nl(line);
		call entry_name(q,ename);
		line = "ENTRY TO "||ename;
		end;

	     bit_s_id = string(q -> statement.source_id);
	     if bit_s_id = old_id
	     then if length(line) = 0
		then goto show;

	     if bit_s_id = "0"b
	     then if length(line) ^= 0
		then call pl1_print$varying_nl(line);
		else;
	     else do;

		if length(line) ^= 0
		then do;
		     substr(stm,1,60) = line;
		     k = 60;
		     end;
		else do;
		     substr(stm,1,6) = sixht;
		     k = 6;
		     end;

		ln = fixed(substr(bit_s_id,9,14),14);
		sn = fixed(substr(bit_s_id,23,5),5);

		heading = substr(stm,1,k);
		heading = heading || "STATEMENT ";
		heading = heading || bindec$vs(sn);
		heading = heading || " ON LINE ";
		heading = heading || bindec$vs(ln);

		ln = fixed(substr(bit_s_id,1,8),8);
		if ln ^= 0
		then do;
		     heading = heading || " OF FILE ";
		     heading = heading || bindec$vs(ln);
		     end;

		call pl1_print$varying_nl(heading);
		end;

	     line = "";
	     old_id = bit_s_id;
	     if bit_s_id = "0"b then goto show;

	     c2 = q -> statement.source.length;
	     if c2 <= 0 then goto show;

	     /* there is a source statement, extract ptr to seg */

	     m = q -> statement.source.segment;
	     source_pt = source.seg_ptr;

	     c1 = q -> statement.source.start+1;

beg:	     if c1 < 2 then goto write;

	     c = substr(source_segment,c1-1,1);

	     if c ^= nl
	     then if c ^= ";"
		then do;
		     c1 = c1 - 1;
		     c2 = c2 + 1;
		     goto beg;
		     end;

write:	     call pl1_print$unaligned_nl(fake.sub_str,c2);

	     if substr(source_segment,c1+c2-1,1) ^= nl
	     then call pl1_print$non_varying_nl("",0);

show:	     if st_type = entry_statement | st_type = procedure_statement
	        then do;
		   l = q -> statement.labels -> list.element(2) -> reference.symbol -> symbol.location;
		   call display_text$display_abs(addrel(cg_static_$text_base,i),
					   addrel(cg_static_$text_reloc_base,i),l-i);
		   i = l;
		   end;

     	     call display_text(cg_static_$text_base,cg_static_$text_reloc_base,
	       cg_static_$sym_use_base,i,j-i);

	     if st_type = begin_statement
	     then call prt_begin_block(q -> statement.root);
	     else if st_type = on_statement
		then if ^ q -> statement.root -> operand(3) -> block.text_displayed
		     then call prt_on_unit(q -> statement.root -> operand(3));

	     end;

entry_name:    proc(pt,value);

dcl	     pt ptr,	/* points at statement node */
	     value char(32) varying;

dcl	     p ptr;

	     p = pt -> statement.labels -> element(2) -> reference.symbol -> symbol.token;
	     value = p -> token.string;
	     end;

	end;




		    display_text.pl1                10/03/83  1728.7rew 10/03/83  1007.5      179541



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


/* program to display output text produced by pl/1

   Initial Version: 17 October, 1968
	Modified: 19 August 1972 by BLW
	Modified:	20 February 1973 by RAB for multiple base-regs
	Modified:	3 July 1973 by RAB for EIS	
	Modified:	21 December 1976 by RAB to fix 1565	
	Modified: 5 May 1977 by SHW for new format pl1_operator_names
	Modified 770630 by PG to fix 1615 (stop printing fill(000) field for TCT and SCD)
	Modified: 9 August 1978 by PCK to print the name of the external entry operator with the entry sequence
	Modified: 25 April 1979 by PCK to implement 4-bit decimal
	Modified:	20 August 1979 by RAB to recognize 04 for andnot
*/

display_text: proc (t_pt, r_pt, s_pt, delta, number);

/* parameters */

	dcl     t_pt		 ptr,		/* points at text base */
	        r_pt		 ptr,		/* points at relocation base */
	        s_pt		 ptr,		/* points at symbol use base */
	        delta		 fixed bin,	/* offset of starting position */
	        number		 fixed bin;	/* number to print */

	dcl     (p, q, s, sym_pt, tok_pt, line_pt, pt) ptr,
	        (i, j, k, m, mop, n, save_k, irand, nrands, ndesc) fixed bin,
	        (fract_offset, offset, size, scale) fixed bin (18),
	        (ignore_ic_mod, double, eis, eis_desc, need_comma, ext_base, itag, has_ic, decimal) bit (1),
	        ht		 char (1) int static aligned init ("	"), /* tab */
	        htht		 char (2) int static aligned init ("		"), /* two tabs */
	        c			 char (1),
	        cstring		 char (12),
	        op_code		 char (5),
	        tag		 char (3),
	        line		 char (256);

/* entries */

	dcl     binoct		 entry (aligned bit (*)) returns (char (12) aligned),
	        pl1_print$string_ptr_nl entry (ptr, fixed bin);

/* external static */

	dcl     (cg_static_$text_pos	 fixed bin,
	        pl1_operators_$operator_table,
	        pl1_operator_names_$first fixed bin (18),
	        pl1_operator_names_$pl1_operator_names_
	        )			 external static;

/* builtins */

	dcl     (addr, addrel, char, divide, fixed, length, ltrim, min, null, ptr, rel, string, substr) builtin;

%include operator_names;

%include op_mnemonic_dcl_;

	dcl     1 name_pair		 aligned based (p),
		2 rel_ptr		 unaligned bit (18),/* ptr to ascii string */
		2 size		 unaligned bit (18);/* size of string */

	dcl     based_string	 aligned char (size) based (p);

	dcl     digit		 (0:9) char (1) aligned int static
				 init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

	dcl     relocation		 (-1:11) char (1) aligned int static
				 init ("a", "t", "1", "2", "3", "l", "d", "s", "7", "8", "i", "r", "e");

	dcl     base		 (0:7) char (4) aligned int static
				 init ("pr0|", "pr1|", "pr2|", "pr3|", "pr4|", "pr5|", "pr6|", "pr7|");

	dcl     modifier		 (0:63) char (3) aligned int static
				 init ("n", "au", "qu", "du", "ic", "al", "ql", "dl",
				 "0", "1", "2", "3", "4", "5", "6", "7",
				 "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...",
				 "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*",
				 (8) (1)"...",
				 (8) (1)"...",
				 "*n", "*au", "*qu", "...", "*ic", "*al", "*ql", "...",
				 "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7");

	dcl     word		 (0:1) bit (36) aligned based (p);

	dcl     1 instruction	 based (p) aligned,
		2 base		 unaligned bit (3),
		2 offset		 unaligned bit (15),
		2 op_code		 unaligned bit (10),
		2 unused		 unaligned bit (1),
		2 ext_base	 unaligned bit (1),
		2 tag		 unaligned bit (6);

	dcl     1 half		 based (p) aligned,
		2 left		 unaligned bit (18),
		2 right		 unaligned bit (18);

	dcl     1 rel_tab		 based (p) aligned,
		2 dummy_l		 unaligned bit (14),
		2 left		 unaligned bit (4),
		2 dummy_r		 unaligned bit (14),
		2 right		 unaligned bit (4);

	dcl     1 mod_factor	 aligned,
		2 ext_base	 bit (1) unal,
		2 length_in_reg	 bit (1) unal,
		2 indirect_descriptor bit (1) unal,
		2 tag		 bit (4) unal;

	dcl     mf		 (3) fixed bin (6) int static init (30, 12, 3); /* location of modification factor fields in EIS inst */

	dcl     1 packed_ptr_st	 based aligned,
		2 packed_ptr	 ptr unal;

	dcl     (ebase, len_reg, ic)	 (3) bit (1) aligned;
	dcl     desc_word		 char (8) varying;

	dcl     desc_op		 (0:9) char (8) varying int static
				 init ("desc9a", "descb", "desc9fl", "desc9ls", "desc9ts", "desc9ns", "desc4fl", "desc4ls", "desc4ts", "desc4ns");

	dcl     eis_modifier	 (0:15) char (3) aligned int static
				 init ("n", "au", "qu", "du", "ic", "al", "ql", "...",
				 "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");

	dcl     bool_word		 (0:15) char (6) aligned int static varying
				 init ("clear", "and", "andnot", "move", "andnot", "", "xor", "or",
				 "", "", "", "", "invert", "", "nand", "set");

	dcl     1 descriptor	 based aligned,	/* EIS alphanumeric and bit operand descriptor */
		2 address		 bit (18) unal,
		2 char		 bit (2) unal,
		2 bit		 bit (4) unal,
		2 length		 bit (12) unal;

	dcl     1 four_bit_descriptor	 based aligned,	/* EIS 4-bit operand descriptor */
		2 address		 bit (18) unal,
		2 char		 bit (3) unal,
		2 bit		 bit (3) unal,
		2 length		 bit (12) unal;

%include symbol;
%include token;
%include declare_type;
%include cgsystem;
%include nodes;

begin:	p = addrel (t_pt, delta);
	q = addrel (r_pt, delta);
	s = addrel (s_pt, delta);

	line_pt = addr (line);
	eis = "0"b;
	irand = 0;

	do i = 1 to number;

	     tag = "   ";
	     substr (line, 1, 6) = binoct (rel (p));
	     substr (line, 7, 2) = "  ";

	     call insert_relocation;

	     cstring = binoct (p -> word (0));

	     if ^eis
	     then do;
		     mop = fixed (p -> instruction.op_code, 10);
		     op_mnemonic_ptr = addr (op_mnemonic_$op_mnemonic_ (mop));
		     op_code = op_mnemonic.name;
		end;
	     else do;
		     mop = 0;
		     op_mnemonic_ptr = addr (op_mnemonic_$op_mnemonic_ (0));
		end;

	     if op_code = ".... "
	     then do;
not_ins:		     substr (line, 13, 3) = "   ";
		     substr (line, 16, 5) = substr (cstring, 1, 5);
		     substr (line, 21, 7) = substr (cstring, 6, 7);
		     k = 28;
		     goto prt;
		end;

	     if op_mnemonic.num_words > 1
	     then do;

/* EIS */

		     call init_eis;

		     substr (line, 13, 4) = substr (cstring, 1, 3);
		     substr (line, 17, 4) = substr (cstring, 4, 3);
		     substr (line, 21, 4) = substr (cstring, 7, 3);
		     substr (line, 25, 3) = substr (cstring, 10, 3);

		     substr (line, 28, 1) = ht;
		     substr (line, 29, 5) = op_code;
		     substr (line, 34, 1) = ht;

		     k = 35;

		     do j = 1 to ndesc;
			string (mod_factor) = substr (p -> word (0), mf (j), 7);
			ebase (j) = mod_factor.ext_base;
			len_reg (j) = mod_factor.length_in_reg;

			substr (line, k, 1) = "(";
			k = k + 1;
			need_comma = "0"b;

			if ebase (j)
			then do;
				substr (line, k, 2) = "pr";
				k = k + 2;
				need_comma = "1"b;
			     end;

			if len_reg (j)
			then do;
				if need_comma
				then do;
					substr (line, k, 1) = ",";
					k = k + 1;
				     end;
				substr (line, k, 2) = "rl";
				k = k + 2;
				need_comma = "1"b;
			     end;

			if mod_factor.tag
			then do;
				if need_comma
				then do;
					substr (line, k, 1) = ",";
					k = k + 1;
				     end;
				ic (j) = mod_factor.tag = "0100"b; /* IC */
				substr (line, k, 2) = eis_modifier (fixed (mod_factor.tag, 4));
				k = k + 2;
			     end;
			else ic (j) = "0"b;

			substr (line, k, 2) = "),";
			k = k + 2;
		     end;


		     if substr (p -> word (0), 10, 1)
		     then do;
			     substr (line, k, 12) = "enablefault,";
			     k = k + 12;
			end;

		     if desc_word = "desc9a" | desc_word = "desc4a"
		     then if ndesc < 3
			then if (substr (op_code, 1, 3) ^= "scd") & (substr (op_code, 1, 3) ^= "tct")
			     then do;
				     if substr (op_code, 1, 3) = "scm"
				     then substr (line, k, 5) = "mask(";
				     else substr (line, k, 5) = "fill(";

				     k = k + 5;
				     substr (line, k, 3) = substr (cstring, 1, 3);
				     k = k + 3;
				     substr (line, k, 1) = ")";
				     k = k + 1;
				end;
			     else k = k - 1;	/* flush trailing , */
			else k = k - 1;		/* .. */
		     else if desc_word = "descb"
		     then do;
			     substr (line, k, 5) = "fill(";
			     k = k + 5;
			     substr (line, k, 1) = digit (fixed (substr (p -> word (0), 1, 1), 1));
			     k = k + 1;
			     substr (line, k, 1) = ")";
			     k = k + 1;
			     if op_code ^= "cmpb "
			     then do;
				     substr (line, k, 6) = ",bool(";
				     k = k + 6;
				     j = fixed (substr (p -> word (0), 6, 4), 4);
				     m = length (bool_word (j));
				     if m > 0
				     then do;
					     substr (line, k, m) = bool_word (j);
					     k = k + m;
					end;
				     else do;
					     substr (line, k, 1) = digit (fixed (substr (p -> word (0), 6, 1), 1));
					     substr (line, k + 1, 1) = digit (fixed (substr (p -> word (0), 7, 3), 3));
					     k = k + 2;
					end;
				     substr (line, k, 1) = ")";
				     k = k + 1;
				end;
			end;
		     else if substr (p -> word (0), 11, 1)
		     then do;
			     substr (line, k, 5) = "round";
			     k = k + 5;
			end;
		     else k = k - 1;

		     irand = 0;
		     go to prt;
		end;

	     double, ignore_ic_mod = "0"b;

	     eis_desc = eis & desc_word ^= "arg";
	     if eis_desc
	     then do;
		     substr (line, 13, 2) = "  ";
		     substr (line, 15, 6) = substr (cstring, 2, 5);
		     substr (line, 21, 3) = substr (cstring, 7, 2);
		     substr (line, 24, 4) = substr (cstring, 9, 4);

		     substr (line, 28, 1) = ht;

		     if decimal
		     then desc_word = desc_op (2 + fixed (p -> four_bit_descriptor.bit, 3));
		     else if desc_word = "desc9a" & p -> four_bit_descriptor.bit = "100"b
		     then desc_word = "desc4a";
		     if irand > 1
		     then if op_code = "dtb  " | op_code = "mvne "
			then desc_word = desc_op (0);
			else ;
		     else if op_code = "btd  "
		     then desc_word = desc_op (0);

		     substr (line, 29, length (desc_word)) = desc_word;
		     k = length (desc_word) + 29;

		     ext_base = ebase (irand);
		     itag = len_reg (irand);
		     if itag
		     then tag = eis_modifier (fixed (substr (p -> descriptor.length, 9, 4), 4));
		     has_ic = ic (irand);
		     go to chk_ext;
		end;

	     if op_code = "rpd  " then goto set;
	     if op_code = "rpt  " then goto set;

	     if p -> instruction.unused then goto not_ins;

	     if op_mnemonic.num_desc ^= 0
	     then do;
		     tag = substr (binoct ((p -> instruction.tag)), 1, 2);
		     ignore_ic_mod = "1"b;
		     goto set;
		end;

	     if p -> instruction.tag
	     then do;
		     tag = modifier (fixed (p -> instruction.tag, 6));
		     if tag = "..." then goto not_ins;
		end;

set:	     substr (line, 13, 2) = "  ";
	     substr (line, 15, 6) = substr (cstring, 2, 5);
	     substr (line, 21, 5) = substr (cstring, 7, 4);
	     substr (line, 26, 2) = substr (cstring, 11, 2);

	     substr (line, 28, 1) = ht;
	     k = 29;

	     if ^eis & op_mnemonic.dtype = 1 & ^p -> instruction.ext_base
	     then op_code = rtrim (op_code) || "x";
	     substr (line, k, 5) = op_code;

	     c = substr (line, k + 3, 1);

	     double = substr (op_code, 1, 2) = "df" | substr (op_code, 3, 2) = "aq" | substr (op_code, 4, 2) = "aq";

	     ext_base = p -> instruction.ext_base | (^eis & op_mnemonic.dtype = 1); /* force PR format for aXdb/sXbd */

	     itag = p -> instruction.tag ^= "000000"b;
	     has_ic = p -> instruction.tag = "000100"b;	/* IC */

	     k = 34;
chk_ext:
chk_ext1:	     substr (line, k, 1) = ht;
	     k = k + 1;

	     save_k = k;

	     if ^eis
	     then if p -> instruction.unused
		then do;

/* have rpd | rpt instruction */

			tag = digit (fixed (p -> instruction.tag, 6));
			offset = fixed (substr (p -> half.left, 1, 8), 8);
			ignore_ic_mod = "1"b;
			goto sk;
		     end;

	     if ext_base
	     then do;
		     substr (line, k, 4) = base (fixed (p -> instruction.base, 3));
		     offset = fixed (p -> instruction.offset, 15);
		     if offset > 16384 then offset = offset - 32768;
		     k = k + 4;
		     j = 13;
		end;
	     else do;
		     offset = fixed (p -> half.left, 18);

		     if offset > 131072
		     then do;
			     if tag = "du " then goto sk;
			     if tag = "dl " then goto sk;
			     offset = offset - 262144;/* 2's comp */
			end;

sk:		     j = 14;
		end;

	     substr (line, j, 1) = cstring;

	     call bin2dec (offset);

	     if eis_desc
	     then do;
		     if desc_word = "descb"
		     then fract_offset = fixed (p -> descriptor.char, 2) * bits_per_char + fixed (p -> descriptor.bit, 4);
		     else if substr (desc_word, 1, 5) = "desc4"
		     then fract_offset = fixed (p -> four_bit_descriptor.char, 3);
		     else fract_offset = fixed (p -> descriptor.char, 2);
		     if fract_offset ^= 0
		     then do;
			     substr (line, k, 1) = "(";
			     k = k + 1;
			     call bin2dec (fract_offset);
			     substr (line, k, 1) = ")";
			     k = k + 1;
			end;
		end;

	     if itag
	     then do;
		     substr (line, k, 1) = ",";
		     substr (line, k + 1, 3) = tag;

		     k = k + 2;
		     if substr (line, k, 1) ^= " " then k = k + 1;
		     if substr (line, k, 1) ^= " " then k = k + 1;
		end;
	     else if eis_desc
	     then do;
		     substr (line, k, 1) = ",";
		     k = k + 1;
		     if desc_word = "desc9ls" | desc_word = "desc4ls"
		     then do;
			     call bin2dec (fixed (substr (p -> descriptor.length, 7, 6), 6));
			     substr (line, k, 1) = ",";
			     k = k + 1;
			     scale = fixed (substr (p -> descriptor.length, 1, 6), 6);
			     if scale >= 32
			     then scale = scale - 64;
			     call bin2dec (scale);
			end;
		     else call bin2dec (fixed (p -> descriptor.length, 12));
		end;

	     if ignore_ic_mod then goto chk_base;

	     if has_ic
	     then do;
		     substr (line, k, 2) = htht;
		     k = k + 2;

		     pt = addrel (p, offset - irand);
		     substr (line, k, 6) = binoct (rel (pt));

		     k = k + 6;

		     if substr (op_code, 1, 1) = "t" then goto prt;
		     if fixed (rel (pt), 18) > cg_static_$text_pos then goto prt;

		     substr (line, k, 1) = " ";
		     k = k + 1;

equal:		     substr (line, k, 2) = "= ";
		     substr (line, k + 2, 12) = binoct (pt -> word (0));
		     k = k + 14;

		     if double
		     then do;
			     substr (line, k, 1) = " ";
			     substr (line, k + 1, 12) = binoct (pt -> word (1));
			     k = k + 13;
			end;

		     goto prt;
		end;

chk_base:	     if ^ext_base then goto prt;

	     if p -> instruction.base ^= "000"b & op_code ^= "tsp2" /* Assumes that tsp2 is used only to invoke entry operators */
	     then do;
		     if s -> word (0) = "0"b then goto prt;

		     sym_pt = s -> packed_ptr;
		     if sym_pt = null then goto prt;

		     if sym_pt -> symbol.dcl_type = by_compiler
		     then if ^sym_pt -> symbol.entry
			then goto prt;

		     j = 2 - divide (k - save_k, 10, 17, 0);
		     substr (line, k, j) = htht;
		     k = k + j;

		     if sym_pt -> node.type = label_node
		     then go to put;

		     tok_pt = sym_pt -> symbol.father;
		     if tok_pt = null then goto put;

		     do while (tok_pt -> symbol.father ^= null);
			tok_pt = tok_pt -> symbol.father;
		     end;

		     tok_pt = tok_pt -> symbol.token;
		     j = tok_pt -> token.size;
		     substr (line, k, j) = tok_pt -> token.string;
		     k = k + j;

		     substr (line, k, 1) = ".";
		     k = k + 1;

put:		     tok_pt = sym_pt -> symbol.token;
		     j = tok_pt -> token.size;
		     substr (line, k, j) = tok_pt -> token.string;
		     k = k + j;

		     goto prt;
		end;

	     if op_code = "xec  "
	     then do;
		     pt = addrel (addr (pl1_operators_$operator_table), offset);
		     mop = fixed (pt -> instruction.op_code, 10);
		     op_mnemonic_ptr = addr (op_mnemonic_$op_mnemonic_ (mop));
		     if op_mnemonic.num_words > 1
		     then do;

/* we are executing an EIS instruction in pl1_operators_ */

			     call init_eis;

			     do j = 1 to ndesc;
				ebase (j) = "1"b;
				len_reg (j) = ^decimal;
				ic (j) = "0"b;
			     end;

			     irand = 0;
			end;
		end;

	     if itag then goto prt;

	     if substr (op_code, 1, 1) ^= "t"
	     then do;
		     if offset >= pl1_operator_names_$first then goto prt;
		     pt = addrel (addr (pl1_operators_$operator_table), offset);
		     substr (line, k, 2) = htht;
		     k = k + 2;
		     goto equal;
		end;

	     op_names_pt = addr (pl1_operator_names_$pl1_operator_names_);

	     if offset >= operator_names.first & offset <= operator_names.last
	     then do;
		     pt = addr (operator_names.names (offset));
		     goto str_info;
		end;

	     else if offset >= operator_names.first_special & offset <= operator_names.last_special
	     then do;
		     do j = 1 to operator_names.number_special;
			if operator_names.special (j).offset = offset
			then do;
				pt = addr (operator_names.special (j).namep);
				goto str_info;
			     end;
		     end;
		     goto prt;
		end;
str_info:	     size = fixed (pt -> name_pair.size, 18);
	     pt = ptr (pt, pt -> name_pair.rel_ptr);

	     substr (line, k, 2) = htht;
	     k = k + 2;

	     substr (line, k, size) = pt -> based_string;
	     k = size + k;

prt:	     call pl1_print$string_ptr_nl (line_pt, k - 1);

	     if eis
	     then do;
		     irand = irand + 1;
		     if irand > nrands
		     then do;
			     eis = "0"b;
			     irand = 0;
			end;
		     else if irand > ndesc
		     then op_code, desc_word = "arg";
		end;

	     p = addrel (p, 1);
	     q = addrel (q, 1);
	     s = addrel (s, 1);
	end;

	return;

display_text$display_abs: entry (t_pt, r_pt, n_words);

	dcl     n_words		 fixed bin;	/* size of block to be displayed */

	p = t_pt;
	q = r_pt;
	line_pt = addr (line);

	do i = 1 to n_words;

	     substr (line, 1, 6) = binoct (rel (p));
	     substr (line, 7, 2) = "  ";
	     call insert_relocation;
	     substr (line, 13, 3) = "   ";
	     substr (line, 16, 12) = binoct (p -> word (0));

	     k = 27;

	     call pl1_print$string_ptr_nl (line_pt, k);
	     p = addrel (p, 1);
	     q = addrel (q, 1);
	end;

	return;

display_text$display_ascii: entry (t_pt, n_chars);

	dcl     n_chars		 fixed bin;	/* size of string to be displayed */

	dcl     nc		 fixed bin,
	        char_string		 char (4) aligned based (p);

	p = t_pt;
	nc = n_chars;
	line_pt = addr (line);


	do i = 1 by 4 to nc;

	     substr (line, 1, 6) = binoct (rel (p));
	     substr (line, 7, 2) = "  ";
	     substr (line, 9, 4) = "aa  ";

	     cstring = binoct (p -> word (0));
	     k = 13;
	     do j = 1 by 3 to 12;
		substr (line, k, 4) = substr (cstring, j, 3);
		k = k + 4;
	     end;

	     substr (line, 28, 1) = ht;

	     k = min (4, nc - i + 1);
	     substr (line, 29, k) = substr (p -> char_string, 1, k);

	     call pl1_print$string_ptr_nl (line_pt, k + 28);
	     p = addrel (p, 1);
	end;


insert_relocation: proc;

/* inserts relocation characters in line */

	if r_pt = null
	then do;
		substr (line, 9, 4) = "aa  ";
		return;
	     end;

	if q -> rel_tab.dummy_l then k = fixed (q -> rel_tab.left, 4);
	else k = -1;

	substr (line, 9, 1) = relocation (k);

	if q -> rel_tab.dummy_r then k = fixed (q -> rel_tab.right, 4);
	else k = -1;

	substr (line, 10, 3) = relocation (k);

     end;


bin2dec: proc (number);

	dcl     number		 fixed bin (18);

	substr (line, k, length (ltrim (char (number)))) = ltrim (char (number));
	k = k + length (ltrim (char (number)));

     end;


init_eis: proc;

	eis = "1"b;
	nrands = op_mnemonic.num_words - 1;
	ndesc = op_mnemonic.num_desc;
	decimal = op_mnemonic.dtype = 2;
	desc_word = desc_op (op_mnemonic.dtype);

     end;

     end;




		    error.pl1                       07/31/89  1433.2rew 07/31/89  1329.4       19260



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



/****^  HISTORY COMMENTS:
  1) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
     install(89-07-31,MR12.3-1066):
     Removed the obsolete parameter source_line from the call to error_().
                                                   END HISTORY COMMENTS */


/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
error:
     proc (err_no, statement_pt, token_pt);

dcl      err_no fixed bin (15) parameter;
dcl      (statement_pt, token_pt) ptr parameter;

dcl      n fixed bin;
dcl      p pointer;

dcl      (null, string) builtin;

dcl      pl1_stat_$err_stm ptr ext;
%page;
%include language_utility;
%page;
%include source_id;
%page;
%include statement;
%page;
%include source_list;
%page;
/* program */
	pl1_stat_$err_stm, p = statement_pt;
	if p = null then do;
	     string (source_id) = "0"b;
	     call error_$no_text (err_no, source_id, token_pt);
	end;
	else
	     call error_ (err_no, p -> statement.source_id, token_pt, (p -> statement.source.segment),
		(p -> statement.source.start), (p -> statement.source.length));

	return;
%page;
/*
 *
 */
error$omit_text:
     entry (err_no, statement_pt, token_pt);

	pl1_stat_$err_stm, p = statement_pt;
	if p = null then do;
	     string (source_id) = "0"b;
	     call error_$no_text (err_no, source_id, token_pt);
	end;
	else
	     call error_$no_text (err_no, p -> statement.source_id, token_pt);
	return;
     end error;




		    error_.pl1                      07/31/89  1433.2rew 07/31/89  1329.4       51300



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



/****^  HISTORY COMMENTS:
  1) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
     install(89-07-31,MR12.3-1066):
     Removed the obsolete parameter source_line.
                                                   END HISTORY COMMENTS */


/*	Error buffering program.				*/
/* If the listing option is on it saves up to 100 error message numbers
 * and related information in an array.  It then calls
 * pll_error_print$write_out which constructs the error message and
 * prints it on the user's console.  Later error$finish is called to sort
 * the error array by statement id and print all of the messages on the
 * listing.
*/
/*	Written by:	J.D. Mills
 *	On:		18 January 1969
 *	Rewritten in pl1 on 28 JULY 1969 by the author.
 *	Modified on:	11 August 1970 by P. Green for Version II
 *	Modified on:	20 April 1979 by R. Barnes to prevent a
 *			fault if source_seg < 0
 *        Modified on:        830909 BIM to signal error if in debug mode
 *	Modified on	020889 RW reformatted and removed
 *			obsolete parameter "source_line"
*/
/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
error_:
     procedure (en, source_id, tp, source_seg, source_start, source_length);

dcl      en fixed bin (15) parameter;
dcl      source_seg fixed bin (8) parameter;
dcl      source_start fixed bin (23) parameter;
dcl      source_length fixed bin (11) parameter;
dcl      tp pointer parameter;

dcl      n fixed bin (17),
         sg fixed bin (11),
         (ss, sl) fixed bin (31),
         (p, q) ptr;

dcl      pl1_stat_$listing_on bit (1) aligned external static;
dcl      ei fixed bin (17) internal static;
dcl      ei_max fixed bin (17) internal static options (constant) initial (100);

dcl      (addr, divide, null, string) builtin;

dcl      1 error_info (100) internal static,
	 2 token_pt ptr,
	 2 error_number fixed bin (17),
	 2 statement_id like source_id;

dcl      1 image based,				/* image of error_info array */
	 2 token_pt ptr,
	 2 error_number fixed bin (15),
	 2 statement_id like source_id;

declare	cg_static_$debug bit (1) aligned external static;
declare	cu_$cl entry;

%page;
%include language_utility;
%page;
%include nodes;
%page;
%include operator;
%page;
%include op_codes;
%page;
%include reference;
%page;
%include symbol;
%page;
%include source_id;
%page;
/* start */
	sg = source_seg;
	ss = source_start;
	sl = source_length;

common:
	p = tp;

/* traverse the node pointer until we can get a token_node */
	do while (p ^= null);
	     if p -> node.type = token_node then
		goto found_token_node;
	     else if p -> node.type = symbol_node then do;
		p = p -> symbol.token;
		goto found_token_node;
	     end;
	     else if p -> node.type = label_node then do;
		p = p -> symbol.token;
		goto found_token_node;
	     end;
	     else if p -> node.type = reference_node then
		p = p -> reference.symbol;
	     else if p -> node.type = operator_node then do;
		if p -> operator.op_code = std_call then
		     p = p -> operator.operand (1);
		else
		     p = null;
	     end;
	     else /* bizzare type of node */
		p = null;
	end;

found_token_node:
	if pl1_stat_$listing_on then
	     if ei <= ei_max then do;

		q = addr (error_info (ei));
		q -> image.token_pt = p;
		q -> image.error_number = en;
		if sg >= 0 then
		     string (q -> image.statement_id) = string (source_id);
		else
		     string (q -> image.statement_id) = "0"b;
		ei = ei + 1;

	     end;

	call pl1_error_print$write_out (en, source_id, p, sg, ss, sl, 0);

	if cg_static_$debug then
	     call cu_$cl;
	return;
%page;
error_$no_text:
     entry (en, source_id, tp);

	sg, ss, sl = 0;
	goto common;
%page;
/* error_$finish entry.
 *	Sort the error messages by error number and then dump them
 *	into the source listing
*/
error_$finish:
     entry;

dcl      (i, j, k, d) fixed bin (17),
         (buff_pt, pj, pk) ptr,
         temp_id bit (27),
         buffer (8);				/* for temp storage during interchange */
dcl      pl1_stat_$error_width fixed bin ext static;

	pl1_stat_$error_width = 120;
	buff_pt = addr (buffer);

	if ei > ei_max then do;
	     ei = ei_max;
	     call pl1_print$non_varying_nl (
		"Implementation restriction - Only 100 error messages may be printed in the listing.", 0);
	end;

	ei = ei - 1;

/* Sort the error messages using Shell sort */
	d = ei;
down:
	d = 2 * divide (d, 4, 17, 0) + 1;
	do i = 1 to ei - d;
	     k = i + d;
	     pk = addr (error_info (k));
	     temp_id = string (pk -> image.statement_id);
up:
	     j = k - d;
	     pj = addr (error_info (j));

	     if string (pj -> image.statement_id) > temp_id then do;
		buff_pt -> image = pk -> image;
		pk -> image = pj -> image;
		pj -> image = buff_pt -> image;

		if j > d then do;
		     k = j;
		     goto up;
		end;
	     end;
	end;

	if d > 1 then
	     goto down;

%page;
/* The error messages are sorted, now write them onto listing segment. */

	do j = 1 to ei;
	     pj = addr (error_info (j));
	     call pl1_error_print$listing_segment (pj -> image.error_number, pj -> image.statement_id,
		pj -> image.token_pt);
	end;
%page;
error_$initialize_error:
     entry;

	ei = 1;

     end error_;




		    free_node.pl1                   10/03/83  1728.7rew 10/03/83  1007.5       22365



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


free_node:	proc(arg);

dcl	(arg,p,q) ptr,
	nodetype fixed bin(15);

dcl	pl1_stat_$free_ptr(18) ptr ext static;

dcl	(fixed,null) builtin;



%include pl1_tree_areas;
%include nodes;
%include symbol;
%include token;
%include block;
%include statement;
%include reference;
%include array;
%include list;
%include context;
%include label;
%include operator;

			/*      */

	p = arg;
	if p=null then goto ret;

	nodetype = fixed(p->node.type,15,0);

	if p->node.type=operator_node
	then do;
		if p->operator.number=2
		then do;
			nodetype = fixed(list_node,15,0);
			goto free_list;
		end;

		if p->operator.number^=3 then goto ret;

free_operator:
		p->operand(1) = pl1_stat_$free_ptr(nodetype);

		goto set;
	end;

	if p->node.type=list_node | p->node.type=label_array_element_node
	then do;
		if p->list.number=3
		then do;
			nodetype = fixed(operator_node,15,0);
			goto free_operator;
		end;

		if p->list.number^=2 then goto ret;

free_list:
		p->list.element(1) = pl1_stat_$free_ptr(nodetype);

		goto set;
	end;

	if p->node.type=reference_node
	then do;
		p->reference.symbol = pl1_stat_$free_ptr(nodetype);

		goto set;
	end;

	if p->node.type=symbol_node
	then do;
		if p->symbol.block_node^=null
		then	if p->symbol.block_node->block.end_declaration=p
			then	goto ret;

		p->symbol.next = pl1_stat_$free_ptr(nodetype);

		if p->symbol.token ^= null
		then do;
			if p->symbol.token->token.declaration=p
			then do;
				p->symbol.token->token.declaration = p->symbol.multi_use;

				goto set;
			end;

			q = p;

			do while(q->symbol.multi_use^=p);
				q = q->symbol.multi_use;
			end;

			q->symbol.multi_use = p->symbol.multi_use;
		end;

		goto set;
	end;

	if p->node.type=statement_node
	then do;
		p->statement.back->statement.next = p->statement.next;
		p->statement.next->statement.back = p->statement.back;

		p->statement.next = pl1_stat_$free_ptr(nodetype);

		goto set;
	end;

	goto ret;

set:
	pl1_stat_$free_ptr(nodetype) = p;

ret:

end free_node;




		    get_array_size.pl1              07/31/89  1433.2r w 07/31/89  1338.4      157797



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


get_array_size: proc(sym,units);

/* Modified 780807 by PG to fix 1651 (not checking for array that is too big)
   Modified 781128 by RAB to fix 1801 (array.element_boundary set incorrectly for interleaved arrays)
   Modified 781206 by RAB to fix 1796 (size of star extent array in structure calc incorrectly)
   Modified 790419 by PCK to implement 4-bit decimal
*/

/* parameters */

dcl	(sym ptr,
	units fixed bin (15)) parameter;

/* automatic */

dcl	is_packed_star_param bit(1) aligned;
dcl	(blk, s, a, b, t, p, q, dm, m) ptr;
dcl	(cm, cdm, c) fixed bin (24);
dcl	n fixed bin (15);
dcl	optable(6:7) bit(9) aligned initial(word_to_mod2,word_to_mod4);

/* builtins */

dcl	(binary, divide, null, min, max, mod) builtin;

/* conditions */

dcl	size condition;

/* external static */

dcl	(pl1_stat_$util_error,pl1_stat_$util_abort) variable static ext entry(fixed bin(15),ptr);
dcl	pl1_stat_$eis_mode bit(1) aligned ext static;
dcl	pl1_stat_$eis bit(1) aligned ext static;

/* internal static */

dcl	ctable(6:7) fixed bin(15) int static initial(2,4);
dcl	factor(7) fixed bin(15) int static initial(1,0,9,18,36,36,36);
dcl	round(5) fixed bin(15) int static initial(36,0,4,2,1);


	s = sym;

	blk = s->symbol.block_node;
	s->symbol.reference->reference.array_ref = "1"b;
	a = s->symbol.array;
	if a->array.element_boundary = 0 then a->array.element_boundary = s->symbol.boundary;

	a->array.offset_units = min(units,word_);

	a->array.c_element_size = s->symbol.c_word_size;
	a->array.c_element_size_bits = s->symbol.c_bit_size;
	a->array.element_size = s->symbol.word_size;
	a->array.element_size_bits = s->symbol.bit_size;

/* Insure that the element size is rounded upward to modulo the boundary requirement. */

	if a->element_boundary > a->offset_units   /* offset_units give the units in which the element size is measured. */
	then	if a->element_boundary > word_
		then	if a->element_size = null
			then do;
				c = ctable(a->element_boundary);
				a->c_element_size = divide(a->c_element_size+c-1,c,31,0)*c;
			end;
			else do;
				q = create_operator(optable(a->element_boundary),2);
				q->operand(2) = a->element_size;
				a->element_size = q;
			end;

		else	if a->element_boundary  = character_
			then do;
				if a->element_size = null
				then do;
					a->c_element_size = divide(a->c_element_size+bits_per_character-1,bits_per_character,31,0);
				end;
				else do;
					q = create_operator(bit_to_char,2);
					q->operand(2) = a->element_size;
					a->element_size = q;
				end;

				a->offset_units = character_;
			end;


/* If the array is a packed star_extent parameter, we must express offsets and sizes in bits */

	is_packed_star_param = s -> symbol.packed
			 & s -> symbol.star_extents
			 & s -> symbol.parameter;

	if is_packed_star_param
	then do;
		if a -> array.offset_units = character_
		then	if a -> array.element_size = null
			then	a -> array.c_element_size = a -> array.c_element_size * bits_per_character;
			else	a -> array.element_size = multf((a -> array.element_size),
					declare_constant$integer(bits_per_character));

		a -> array.offset_units = bit_;
		go to build_multipliers;
	end;


/* If the element size is constant and the units are less than word, try and convert
   the size to a value expressed in higher units.	*/

	if a->array.element_size ^= null then go to build_multipliers;
	if a->array.offset_units >= word_ then go to build_multipliers;

	if a->array.offset_units = bit_
	then	if pl1_stat_$eis_mode
		then	if mod(a->array.c_element_size,bits_per_word)=0
			then do;
				a->array.offset_units = word_;
				a->array.c_element_size = divide(a->array.c_element_size,bits_per_word,31,0);
			end;
			else	goto build_multipliers;
		else	if mod(a->array.c_element_size,bits_per_character)=0
			then do;
				a->array.offset_units = character_;
				a->array.c_element_size = divide(a->array.c_element_size,bits_per_character,31,0);
			end;
			else	goto build_multipliers;

	if a->array.offset_units = character_
	then	if pl1_stat_$eis_mode
		then	if mod(a->array.c_element_size,characters_per_word)=0
			then do;
				a->array.offset_units = word_;
				a->array.c_element_size = divide(a->array.c_element_size,characters_per_word,31,0);
			end;
			else	goto build_multipliers;
		else	if mod(a->array.c_element_size,characters_per_half)=0
			then do;
				a->array.offset_units = half_;
				a->array.c_element_size = divide(a->array.c_element_size,characters_per_half,31,0);
			end;
			else	goto build_multipliers;

	if a->array.offset_units = half_
	then	if mod(a->array.c_element_size,2)=0
		then do;
			a->array.offset_units = word_;
			a->array.c_element_size = divide(a->array.c_element_size,2,31,0);
		end;

/* walk down the bound pairs and construct two multipliers for each bound pair.
   The descriptor multiplier is used only when the array is accessed
   as a parameter.  It is expressed in bits if the array is packed and
   in words if it is unpacked.  The other multiplier is used by this procedure and
   is expressed in the units given by offset_units.  Multipliers are computed by the
   following rule:

	m(n) = element_size
	m(n-1) = (hb(n)-lb(n)+1)*m(n)
	m(n-2) = (hb(n-1)-lb(n-1)+1)*m(n-1)
	   .
	   .
	   .
	m(1) = (hb(2)-lb(2)+1)m(2)

   The address of an element is :
	addr(a(i(1),i(2),...i(n)) = B-V+(i(1)*m(1)+i(2)*m(2)...i(n)*m(n))
	B = the beginning of storage for the array ( the offset of its first element).
	V = the virtual origin (lb(1)*m(1)+lb(2)*m(2)...lb(n)*m(n))
		the address of the 0th element.
								*/

/* the first multiplier is the element size.  It is converted to bits when used
   as the descriptor multiplier of a packed array. */

build_multipliers:
	on size call pl1_stat_$util_abort (357, s);	/* array s won't fit in 262144 words */
	m = a->array.element_size;
	cm = a->array.c_element_size;

	if m = null then m = declare_constant$integer((cm));

	if s->symbol.packed
	then	c = factor(a->array.offset_units);
	else	c = 1;

	cdm = c*cm;

	if c = 1
	then	dm = m;
	else	dm = multf(m,declare_constant$integer((c)));

/* loop down the bound pairs and compute the multipliers and virtual origin.	*/

	do b = a->array.bounds repeat b->bound.next while(b^=null);

/* if the multiplier is constant insure that it is included in the object program.	*/

		if m = null then m = declare_constant$integer((cm));
		if dm = null then dm = declare_constant$integer((cdm));

/* check for decimal integer constant bounds. */

		if b->bound.lower^=null then if b->bound.lower->node.type = token_node
		then	if b->bound.lower->token.type = dec_integer
			then do;
				b->bound.c_lower = token_to_binary((b->bound.lower));
				b->bound.lower = null;
			end;

		if b->bound.upper^=null then if b->bound.upper->node.type = token_node
		then	if b->bound.upper->token.type = dec_integer
			then do;
				b->bound.c_upper = token_to_binary((b->bound.upper));
				b->bound.upper = null;
			end;

/* if this is an auto or defined array evaluate its bounds in the prologue.  If any
   multiplier is an expression evaluate it in the prologue.	*/

		if s->symbol.auto | s->symbol.defined
		then do;
			if b->bound.lower ^= null
				then b->bound.lower = assignf(b->bound.lower);
			if b->bound.upper ^= null
				then b->bound.upper = assignf(b->bound.upper);
			if m->node.type = operator_node
				then m = assignf((m));
		end;

/* If this is a star extent array the multipliers are given by the descriptor.
   Otherwise we compute them and save them in the bound nodes.  */

		if ^(s->symbol.star_extents & s->symbol.parameter)
		then do;
			b->bound.multiplier = m;
			b->bound.c_multiplier = cm;
			if s->symbol.controlled & b->bound.desc_multiplier ^= null
			then b->bound.symtab_multiplier = dm;
			else b->bound.desc_multiplier = dm;
			b->bound.c_desc_multiplier = cdm;
		end;

/* add this term to the virtual origin.				*/

		call virtue(a,b);

/* develop the next multiplier.	*/

		if b->bound.lower = null
		then	if b->bound.c_lower = 1
			then	if b->bound.upper = null
				then	if cm = 0
					then do;
						m = multf(m,declare_constant$integer((b->bound.c_upper)));
						cm = 0;
						dm = multf(dm,declare_constant$integer((b->bound.c_upper)));
						cdm = 0;
					end;
					else do;
						m = null;
(size):						cm = b->bound.c_upper*cm;
						dm = null;
(size):						cdm = b->bound.c_upper*cdm;
					end;
				else do;
					m = multf(m,(b->bound.upper));
					cm = 0;
					dm = multf(dm,(b->bound.upper));
					cdm = 0;
				end;
			else do;
				c = b->bound.c_lower-1;
				if b->bound.upper = null
				then do;
					c = b->bound.c_upper-c;
					if cm = 0
					then do;
						m = multf(m,declare_constant$integer((c)));
						cm = 0;
						dm = multf(dm,declare_constant$integer((c)));
						cdm = 0;
					end;
					else do;
						m = null;
(size):						cm = c*cm;
						dm = null;
(size):						cdm = c*cdm;
					end;
				end;
				else do;
					t = subf(b->bound.upper,declare_constant$integer((c)));
					m = multf(m,t);
					cm = 0;
					dm = multf(dm,t);
					cdm = 0;
				end;
			end;

		else do;
			if b->bound.upper = null
				then t = subf(declare_constant$integer(b->bound.c_upper+1),b->bound.lower);
				else t = subf(b->bound.upper,subf(b->bound.lower,declare_constant$integer(1)));
			m = multf(m,t);
			cm = 0;
			dm = multf(dm,t);
			cdm = 0;
		end;

		if cm<0
		then	call pl1_stat_$util_error(168,s);
		else	if cm = 0
			then	if m = null
				then	call pl1_stat_$util_abort(168,s);

		a->array.number_of_dimensions = a->array.number_of_dimensions+1;
	end;

/* the last multiplier gives the total array size exclusive of any
   rounding forced by succeeding structure members.		*/

/* record the total size of the array measured in bits.	*/

	s->symbol.bit_size = null;
	s->symbol.c_bit_size = 0;
	c = factor(a->array.offset_units);

	if cm = 0
	then	if c = 1
		then	s->symbol.bit_size = m;
		else	s->symbol.bit_size = multf(m,declare_constant$integer((c)));
	else
(size):		s -> symbol.c_bit_size = cm * c;

/* store the array size in the symbol node.	*/
	s->symbol.word_size = m;
	s->symbol.c_word_size = cm;

/* if this is a structure copy its bounds and multipliers onto all contained members
   at every level. */

	if s->symbol.structure then call interleaved(s);

	if is_packed_star_param
	then	units = a->array.offset_units;
	else	units = max(units,a->array.offset_units);

	return;

/* subroutine to make a prologue assignment. */

assignf: proc(e) returns(ptr);

dcl	e ptr unal,
	(p,q) ptr;

	q = create_operator(assign,2);
	q->operand(2) = e;
	p,q->operand(1) = declare_integer(blk);
	p->reference.symbol->symbol.c_dcl_size = max_offset_precision;
	p = create_statement$prologue(assignment_statement,blk,null,(blk->block.prefix));
	p->statement.root = copy_expression((q));

	return(q->operand(1));

	end;


/* subroutine to create expressions. */

addf:	proc(e1,e2) returns(ptr);

dcl	(e1,e2) ptr unal,
	q ptr;
dcl	opcode bit(9) aligned;

	if e1 = null then return(e2);
	opcode = add;
	go to common;

subf:	entry(e1,e2) returns(ptr);

	opcode = sub;

common:
	q = create_operator(opcode,3);
	q->operand(2) = e1;
	q->operand(3) = e2;

	return(q);

	end;

multf:	proc(e1,e2) returns(ptr);

dcl	(e1,e2) ptr;

dcl	(arg(2), q) ptr,
	i fixed bin(15),
	based_integer fixed bin(35) based;

	arg(1) = e1;
	arg(2) = e2;

	do i=1 to 2;
		if arg(i)->node.type=reference_node
		then	if arg(i)->reference.symbol->node.type=symbol_node
			then	if arg(i)->reference.symbol->symbol.constant
				then	if arg(i)->reference.symbol->symbol.initial->based_integer=0
					then	return(arg(i));
					else	if arg(i)->reference.symbol->symbol.initial->based_integer=1
						then	return(arg(3-i));
	end;

	q = create_operator((mult),3);
	q->operand(2) = e1;
	q->operand(3) = e2;

	return(q);

	end;

/* subroutine to add a term to the virtual origin. */

virtue: proc(a,b);

dcl	(a,b) ptr;

	if b->lower = null
	then	if b->c_lower = 1
		then	if b->c_multiplier = 0
			then	a->virtual_origin = addf(a->virtual_origin,b->multiplier);
			else	a->c_virtual_origin = a->c_virtual_origin+b->c_multiplier;
		else	if b->c_multiplier = 0
			then	a->virtual_origin = addf(a->virtual_origin,multf((b->multiplier),
					declare_constant$integer((b->c_lower))));
			else	a->c_virtual_origin = a->c_virtual_origin+b->c_multiplier*b->c_lower;
	else	a->virtual_origin = addf(a->virtual_origin,multf((b->multiplier),(b->lower)));

	end virtue;

/* subroutine to distribute the bounds and multipliers of a dimensioned structure onto
   all of its contained members at every level.  The virtual origin of the members
   is recomputed to include the bounds inherited from its containing structures. */

interleaved: proc(d);

dcl	(equal,packed_eq) bit(1);
dcl	(d,p,q,a1,b,b1,v) ptr;

dcl	create_array entry returns(ptr);
dcl	create_bound entry returns(ptr);

	do p = d->symbol.son repeat p->symbol.brother while(p^=null);
		a1=p->symbol.array;
		packed_eq = s->symbol.packed = p->symbol.packed;
		if a1=null
		then do;
			p->symbol.dimensioned = "1"b;
			equal = "1"b;
			p->symbol.array,a1 = create_array();
			a1->array=a->array;
			a1->array.number_of_dimensions  ,
			a1->array.own_number_of_dimensions  ,
			a1->array.c_virtual_origin=0;
			a1->array.virtual_origin=null;
			a1->array.element_size_bits = p->symbol.bit_size;
			a1->array.c_element_size_bits = p->symbol.c_bit_size;
			a1->array.element_size = p->symbol.word_size;
			a1->array.c_element_size = p->symbol.c_word_size;
			a1->array.element_boundary = p->symbol.boundary;	/* Fixes 1801. */
			b1=null;
		end;
		else do;
			equal = a->array.offset_units = a1->array.offset_units;
			if ^equal
			then do;
				a1->array.offset_units = bit_;
				a1->array.c_virtual_origin = 0;
				a1->array.virtual_origin = null;
				a1->array.element_size = a1->array.element_size_bits;
				a1->array.c_element_size = a1->array.c_element_size_bits;
			end;

			do b = a1->array.bounds repeat b->bound.next while(b^=null);
				if ^equal
				then do;
					b->bound.multiplier = b->bound.desc_multiplier;
					b->bound.c_multiplier = b->bound.c_desc_multiplier;
					call virtue(a1,b);
				end;

				b1 = b;
			end;
		end;

/* this code copies the bounds from the father to the son */
/* If "equal" the multipliers are copied without change, otherwise the descriptor
   multipliers are used as the standard multipliers and their units are converted to
   bits when necessary.	*/

		p->symbol.exp_extents   = d->symbol.exp_extents;
		p->symbol.refer_extents = d->symbol.refer_extents;
		p->symbol.star_extents  = d->symbol.star_extents;
		a1->array.interleaved = "1"b;
		p->symbol.connected = "0"b;
		p->symbol.reference->reference.array_ref = "1"b;

		do b = a->array.bounds repeat b->bound.next while(b^=null);
			q = create_bound();
			q->bound=b->bound;
			q->bound.next=null;
			q->bound.lower = copy_expression(b->bound.lower);
			q->bound.upper = copy_expression(b->bound.upper);

			if equal
			then do;
				q->bound.multiplier = copy_expression(b->bound.multiplier);
				q->bound.c_multiplier = b->bound.c_multiplier;
				if packed_eq
				then do;
					q->bound.desc_multiplier = copy_expression(b->bound.desc_multiplier);
					q->bound.c_desc_multiplier = b->bound.c_desc_multiplier;
				end;
				else do;
					q->bound.desc_multiplier = copy_expression(multf((b->bound.desc_multiplier),
							declare_constant$integer(bits_per_word)));
					q->bound.c_desc_multiplier = b->bound.c_desc_multiplier*bits_per_word;
				end;
			end;
			else do;
				if s->symbol.packed & p->symbol.packed
				then do;
					q->bound.c_multiplier = b->bound.c_desc_multiplier;
					q->bound.multiplier = copy_expression(b->bound.desc_multiplier);
					q->bound.c_desc_multiplier = b->bound.c_desc_multiplier;
					q->bound.desc_multiplier = q->bound.multiplier;
				end;
				else do;
					q->bound.c_multiplier = b->bound.c_desc_multiplier*bits_per_word;
					q->bound.multiplier = copy_expression(multf((b->bound.desc_multiplier),
							declare_constant$integer(bits_per_word)));
					q->bound.c_desc_multiplier = q->bound.c_multiplier;
					q->bound.desc_multiplier = q->bound.multiplier;
				end;

				call virtue(a1,q);
			end;

/*  get the next bound.	*/

			if b1 = null
			then	a1->array.bounds = q;
			else	b1->bound.next = q;

			b1 = q;
		end;

/* add the structure's number of dimensions to the member's number of dims */

		a1->array.number_of_dimensions=a1->array.number_of_dimensions+
			a->array.number_of_dimensions;

/* add the structure's virtual origin to the member's virtual origin */

		if equal
		then do;
			a1->array.virtual_origin = addf(a1->array.virtual_origin,a->array.virtual_origin);
			a1->array.c_virtual_origin = a1->array.c_virtual_origin +
					a->array.c_virtual_origin;
		end;

		if p->symbol.structure
		then	call interleaved(p);
	end;

	end interleaved;

/* include files */

%include language_utility;
%include array;
%include block;
%include boundary;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include statement;
%include statement_types;
%include symbol;
%include system;
%include token;
%include token_types;
     end /* get_array_size */;




		    get_size.pl1                    07/31/89  1433.2r w 07/31/89  1338.4      119682



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


/* format: style2,idind30 */
get_size:
     proc (sym);

/* Modified 780712 by PG for unsigned */
/* Modified 790419 by PCK to implement 4-bit decimal */
/* Modified 830427 BIM to implement options (packed) for ptrs */

	dcl     (sym, s, q, p, b)	        ptr;
	dcl     (n, e, i)		        fixed bin (15);
	dcl     units		        fixed bin (3);

	dcl     pl1_stat_$util_abort	        ext static variable entry (fixed bin (15), ptr);

	dcl     pl1_stat_$eis_mode	        bit (1) aligned ext static;

	dcl     convert_map		        (7) fixed bin (31) int static initial (1, 0, 9, 18, 36, 36, 36);
	dcl     round		        (4) fixed bin (15) int static initial (36, 0, 4, 2);

	dcl     optable		        (4) bit (9) aligned
				        initial (bit_to_word, ""b, char_to_word, half_to_word);

	dcl     file_conditions	        (7) char (13) int static
				        initial ("key", "record", "endpage", "endfile", "name", "transmit",
				        "undefinedfile");

	dcl     (divide, fixed, null, length, max)
				        builtin;

%include language_utility;
%include symbol;
%include block;
%include statement;
%include statement_types;
%include nodes;
%include reference;
%include token;
%include operator;
%include op_codes;
%include boundary;
%include system;

	s = sym;

	b = s -> symbol.block_node;

	if s -> symbol.bit | s -> symbol.char | s -> symbol.area
	then do;
		if s -> symbol.dcl_size ^= null & (s -> symbol.auto | s -> symbol.defined)
		then do;
			p = create_statement$prologue (assignment_statement, b, null, (b -> block.prefix));
			q, p -> statement.root = create_operator (assign, 2);
			q -> operand (2) = s -> symbol.dcl_size;
			p, q -> operand (1), s -> symbol.dcl_size = declare_integer (b);
			p -> reference.symbol -> symbol.c_dcl_size = max_length_precision;
		     end;

		if s -> symbol.varying
		then s -> symbol.reference -> reference.varying_ref = "1"b;
		else if ^s -> symbol.area
		then do;
			s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;
			s -> symbol.reference -> reference.length = s -> symbol.dcl_size;
		     end;
	     end;

	if s -> symbol.structure
	then do;
		units = s -> symbol.reference -> reference.c_length;
		go to get_bit_size;
	     end;

	if s -> symbol.packed
	then do;
		if s -> symbol.char
		then do;
			units = character_;
			s -> symbol.word_size = s -> symbol.dcl_size;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.bit
		then do;
			units = bit_;
			s -> symbol.word_size = s -> symbol.dcl_size;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.binary
		then do;
			units = bit_;
			if s -> symbol.float
			then s -> symbol.c_word_size = s -> symbol.c_dcl_size + 1 + bits_per_binary_exponent;
			else if s -> symbol.unsigned
			then s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			else s -> symbol.c_word_size = s -> symbol.c_dcl_size + 1;

			if s -> symbol.complex
			then s -> symbol.c_word_size = 2 * s -> symbol.c_word_size;
			go to get_boundary;
		     end;

		if s -> symbol.decimal
		then do;
			units = character_;
			s -> symbol.c_word_size = (s -> symbol.c_dcl_size + 1 + 2 * fixed (s -> symbol.float));
			s -> symbol.c_word_size =
			     divide (s -> symbol.c_word_size + mod (s -> symbol.c_word_size, 2),
			     packed_digits_per_character, 24, 0);
			if s -> symbol.complex
			then s -> symbol.c_word_size = 2 * s -> symbol.c_word_size;
			go to get_boundary;
		     end;

		if s -> symbol.ptr
		then do;
			units = bit_;
			s -> symbol.c_word_size = bits_per_packed_ptr;
			go to get_boundary;
		     end;

		if s -> symbol.picture
		then do;
			units = character_;

			if s -> symbol.general = null
			then s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			else do;
				if s -> symbol.general -> node.type = token_node
				then do;

/* usual case */

					s -> symbol.c_word_size = length (s -> symbol.general -> token.string);

					call declare_picture (s -> symbol.general -> token.string, s, e);
					if e ^= 0
					then call pl1_stat_$util_abort (e, s);
				     end;
				else s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;

				s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			     end;

			go to get_boundary;
		     end;
	     end;
	else do;
		if s -> symbol.ptr
		then do;
			units = word_;
			if ^s -> symbol.explicit_packed
			then s -> symbol.c_word_size = words_per_pointer;
			else s -> symbol.c_word_size = words_per_packed_pointer;
			go to get_boundary;
		     end;

		if s -> symbol.binary
		then do;
			units = word_;

			if s -> symbol.float
			then if s -> symbol.c_dcl_size > max_p_flt_bin_1
			     then s -> symbol.c_word_size = words_per_flt_bin_2;
			     else s -> symbol.c_word_size = words_per_flt_bin_1;
			else if s -> symbol.c_dcl_size > max_p_fix_bin_1
			then s -> symbol.c_word_size = words_per_fix_bin_2;
			else s -> symbol.c_word_size = words_per_fix_bin_1;

			if s -> symbol.complex
			then s -> symbol.c_word_size = 2 * s -> symbol.c_word_size;
			go to get_boundary;
		     end;

		if s -> symbol.char
		then do;
			units = character_;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			s -> symbol.word_size = s -> symbol.dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.bit
		then do;
			units = bit_;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			s -> symbol.word_size = s -> symbol.dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.decimal
		then do;
			units = character_;
			s -> symbol.c_word_size = (s -> symbol.c_dcl_size + 1 + fixed (s -> symbol.float));
			if s -> symbol.complex
			then s -> symbol.c_word_size = 2 * s -> symbol.c_word_size;
			go to get_boundary;
		     end;

		if s -> symbol.entry
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_entry_var;
			go to get_boundary;
		     end;

		if s -> symbol.label
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_label_var;
			goto get_boundary;
		     end;

		if s -> symbol.file
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_file_var;
			goto get_boundary;
		     end;

		if s -> symbol.format
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_format;
			goto get_boundary;
		     end;

		if s -> symbol.offset
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_offset;
			go to get_boundary;
		     end;

		if s -> symbol.area
		then do;
			units = word_;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			s -> symbol.word_size = s -> symbol.dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.picture
		then do;
			units = character_;

			if s -> symbol.general = null
			then s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			else do;
				if s -> symbol.general -> node.type = token_node
				then do;

/* usual case */

					s -> symbol.c_word_size = length (s -> symbol.general -> token.string);

					call declare_picture (s -> symbol.general -> token.string, s, e);
					if e ^= 0
					then call pl1_stat_$util_abort (e, s);
				     end;
				else s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;

				s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			     end;

			go to get_boundary;
		     end;

		if s -> symbol.storage_block
		then do;
			units = word_;
			s -> symbol.c_word_size = s -> symbol.c_dcl_size;
			go to get_boundary;
		     end;

		if s -> symbol.condition
		then do;
			units = word_;
			s -> symbol.c_word_size = words_per_condition_var;
			do i = 1 to 7;
			     if s -> symbol.token -> token.string = file_conditions (i)
			     then s -> symbol.c_word_size = 8;
			end;
			goto get_boundary;
		     end;

		units = word_;
	     end;

/* compute the required boundary.	*/

get_boundary:
	if s -> symbol.packed
	then if s -> symbol.decimal | s -> symbol.char | s -> symbol.picture
	     then s -> symbol.boundary = character_;
	     else s -> symbol.boundary = bit_;
	else do;
		s -> symbol.boundary = word_;

		if s -> symbol.fixed & s -> symbol.binary
		then if s -> symbol.c_word_size > words_per_fix_bin_1
		     then s -> symbol.boundary = mod2_;

		if s -> symbol.float & s -> symbol.binary
		then if s -> symbol.c_word_size > words_per_flt_bin_1
		     then s -> symbol.boundary = mod2_;

		if s -> symbol.label | s -> symbol.entry | s -> symbol.file | s -> symbol.format
		     | s -> symbol.condition | s -> symbol.area
		then s -> symbol.boundary = mod2_;

		if s -> symbol.ptr
		then if s -> symbol.explicit_packed
		     then s -> symbol.boundary = word_;
		     else s -> symbol.boundary = mod2_;
	     end;

	if ^s -> symbol.member
	then s -> symbol.boundary = max (s -> symbol.boundary, word_);

/* determine the size in bits excluding any rounding.	*/

get_bit_size:
	if s -> symbol.word_size = null
	then s -> symbol.c_bit_size = s -> symbol.c_word_size * convert_map (units);
	else if units = bit_
	then s -> symbol.bit_size = s -> symbol.word_size;
	else s -> symbol.bit_size = multf ((s -> symbol.word_size), declare_constant$integer (convert_map (units)));

/* if the units are less than word and this is not a packed item, then round the size to words.	*/

	if units < word_ & ^s -> symbol.packed
	then do;
		if s -> symbol.word_size = null
		then s -> symbol.c_word_size =
			divide (s -> symbol.c_word_size + round (units) - 1, round (units), 31, 0);
		else do;
			q = create_operator (optable (units), 2);
			q -> operand (2) = s -> symbol.word_size;
			s -> symbol.word_size = q;
		     end;

		units = word_;
	     end;

/* if this is a varying string add one to the word size.	*/

	if s -> symbol.varying
	then if s -> symbol.word_size = null
	     then s -> symbol.c_word_size = s -> symbol.c_word_size + words_per_varying_string_header;
	     else s -> symbol.word_size =
		     addf ((s -> symbol.word_size), declare_constant$integer (words_per_varying_string_header));

/* if this is an array call get_array size to find the total size and to compute the
   multipliers and virtual origin used by subscripted references to the array elements.	*/

	if s -> symbol.array ^= null
	then call get_array_size (s, units);

/* if this is a level 1 packed item round the size to words.	*/

	if s -> symbol.packed & ^s -> symbol.member & units < word_
	then if s -> symbol.word_size ^= null
	     then do;
		     q = create_operator (optable (units), 2);
		     q -> operand (2) = s -> symbol.word_size;
		     s -> symbol.word_size = q;
		end;
	     else s -> symbol.c_word_size = divide (s -> symbol.c_word_size + round (units) - 1, round (units), 31, 0);

/* if this is a member of a structure try to improve the units in which the size is expressed.	*/

	if ^s -> symbol.member
	then goto exit;

	if units = word_
	then if ^s -> symbol.structure
	     then units = max (s -> symbol.boundary, units);
	if s -> symbol.word_size ^= null
	then go to exit;
	if units >= word_
	then go to exit;

	if units = bit_
	then if pl1_stat_$eis_mode
	     then if s -> symbol.c_word_size = divide (s -> symbol.c_word_size, bits_per_word, 31, 0) * bits_per_word
		then do;
			units = word_;
			s -> symbol.c_word_size = divide (s -> symbol.c_word_size, bits_per_word, 31, 0);
		     end;
		else goto exit;
	     else if s -> symbol.c_word_size
		     = divide (s -> symbol.c_word_size, bits_per_character, 31, 0) * bits_per_character
	     then do;
		     units = character_;
		     s -> symbol.c_word_size = divide (s -> symbol.c_word_size, bits_per_character, 31, 0);
		end;
	     else goto exit;

	if units = character_
	then if pl1_stat_$eis_mode
	     then if s -> symbol.c_word_size
		     = divide (s -> symbol.c_word_size, characters_per_word, 31, 0) * characters_per_word
		then do;
			units = word_;
			s -> symbol.c_word_size = divide (s -> symbol.c_word_size, characters_per_word, 31, 0);
		     end;
		else goto exit;
	     else if s -> symbol.c_word_size
		     = divide (s -> symbol.c_word_size, characters_per_half, 31, 0) * characters_per_half
	     then do;
		     units = half_;
		     s -> symbol.c_word_size = divide (s -> symbol.c_word_size, characters_per_half, 31, 0);
		end;
	     else goto exit;

	if units = half_
	then if s -> symbol.c_word_size = divide (s -> symbol.c_word_size, 2, 31, 0) * 2
	     then do;
		     units = word_;
		     s -> symbol.c_word_size = divide (s -> symbol.c_word_size, 2, 31, 0);
		end;

exit:
	if s -> symbol.member
	then s -> symbol.reference -> reference.c_length = units;

/* subroutine to do arithmetic. */

multf:
     proc (a, b) returns (ptr);

	dcl     (a, b, c)		        ptr;
	dcl     opcode		        bit (9) aligned;

	opcode = mult;
	go to common;

addf:
     entry (a, b) returns (ptr);

	opcode = add;
common:
	c = create_operator (opcode, 3);
	c -> operand (2) = a;
	c -> operand (3) = b;
	return (c);
     end;

     end /* get_size */;




		    lang_util_.alm                  10/03/83  1728.7rew 10/03/83  1007.0       38529



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

"
	macro	utility_entry
	entry	&2
"
&2:
	tra	&1$&2
	&end

"	entry vector for bound_lang_util_
"
	name	lang_util_
"
	utility_entry	create_array,create_array
	utility_entry	create_block,create_block
	utility_entry	create_bound,create_bound
	utility_entry	create_context,create_context
	utility_entry	create_cross_reference,create_cross_reference
	utility_entry	create_default,create_default
	utility_entry	create_label,create_label
	utility_entry	create_symbol,create_symbol
	utility_entry	create_token,create_token
	utility_entry	create_token,init_hash_table
	utility_entry	create_token,protected
	utility_entry	create_identifier,create_identifier
	utility_entry	bindec,bindec
	utility_entry	binoct,binoct
	utility_entry	bindec,vs
	utility_entry	token_to_binary,token_to_binary
	utility_entry	create_list,create_list
	utility_entry	create_operator,create_operator
	utility_entry	create_reference,create_reference
	utility_entry	create_statement,create_statement
	utility_entry	create_storage,create_storage
	utility_entry	create_statement,prologue
	utility_entry	tree_manager,init
	utility_entry	tree_manager,truncate
	utility_entry	free_node,free_node
	utility_entry	get_size,get_size
	utility_entry	refer_extent,refer_extent
	utility_entry	declare_constant,declare_constant
	utility_entry	declare_constant,integer
	utility_entry	declare_constant,desc
	utility_entry	declare_constant,bit
	utility_entry	declare_constant,char
	utility_entry	declare_descriptor,declare_descriptor
	utility_entry	declare_descriptor,ctl
	utility_entry	declare_descriptor,param
	utility_entry	declare_integer,declare_integer
	utility_entry	declare_picture,declare_picture
	utility_entry	declare_pointer,declare_pointer
	utility_entry	declare_temporary,declare_temporary
	utility_entry	optimizer,optimizer
	utility_entry	compare_expression,compare_expression
	utility_entry	copy_expression,copy_expression
	utility_entry	copy_expression,copy_sons
	utility_entry	reserve,declare_lib
	utility_entry	reserve,clear
	utility_entry	reserve,read_lib
	utility_entry	reserve,rename_parse
	utility_entry	convert,convert
	utility_entry	convert,from_builtin
	utility_entry	convert,validate
	utility_entry	convert,to_integer
	utility_entry	convert,to_target_fb
	utility_entry	convert,to_target
	utility_entry	share_expression,share_expression
	utility_entry	decbin,decbin
	utility_entry	parse_error,parse_error
	utility_entry	decode_node_id,decode_node_id
	utility_entry	decode_source_id,decode_source_id
	utility_entry	error,error
	utility_entry	error_,error_
	utility_entry	error_,no_text
	utility_entry	error_,finish
	utility_entry	error_,initialize_error
	utility_entry	pl1_print,varying
	utility_entry	pl1_print,varying_nl
	utility_entry	pl1_print,non_varying
	utility_entry	pl1_print,non_varying_nl
	utility_entry	pl1_print,string_ptr
	utility_entry	pl1_print,string_ptr_nl
	utility_entry	pl1_print,for_lex
	utility_entry	pl1_print,unaligned_nl
	utility_entry	merge_attributes,merge_attributes
	utility_entry	display_pl1_map,display_pl1_map
	utility_entry	display_pl1_text,display_pl1_text
	utility_entry	sym_sort_alphabetic,by_size
	utility_entry	compile_formats,compile_formats
	utility_entry	assign_storage,assign_storage
	utility_entry	compile_link,compile_link
	utility_entry	gen_pl1_linkage,gen_pl1_linkage
	utility_entry	gen_pl1_linkage,init_linkage
	utility_entry	gen_pl1_symbol,beg_symbol
	utility_entry	gen_pl1_symbol,end_symbol
	utility_entry	generate_definition,generate_definition
	utility_entry	pl1_signal_catcher,pl1_signal_catcher
	utility_entry	sym_sort_alphabetic,sym_sort_alphabetic
	utility_entry	declare_picture_temp,declare_picture_temp
	utility_entry	copy_unique_expression,copy_unique_expression
"
" The following entry doesn't fit the macro...
"
	entry	mst
mst:
	tra	mst$block_nodes
"
	end




		    merge_attributes.pl1            07/31/89  1433.2r w 07/31/89  1338.4       27837



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


/* procedure to merge attributes from t (template) into s (symbol).
   Return value is "1"b if some attribute could not be merged, else "0"b
   Modified 780712 by PG to modify s only if no errors occurred
*/

merge_attributes:
	procedure (bv_s, bv_t) returns (bit (1) aligned);

/* parameters */

declare	(bv_s, bv_t) ptr parameter;

/* automatic */

declare	(dummy_qualifier, s, t) ptr;
declare	1 dummy aligned like symbol;
declare	e bit(1) aligned;

/* builtins */

declare	(null,string) builtin;

/* program */

	t = bv_t;
	s = bv_s;

	/* Make a copy of s in case an error is found later... */

	dummy = s -> symbol;			/* structure assignment */
	dummy_qualifier = dummy.reference -> reference.qualifier;
	e = "0"b;

	/* Now merge into the dummy symbol, setting the error flag if applicable. */

	string(dummy.attributes) = string(dummy.attributes) | string(t->symbol.attributes);

	if dummy.initial = null
	then dummy.initial = copy_expression(t->symbol.initial);
	else if t->symbol.initial ^= null then e="1"b;

	if dummy.general = null
	then dummy.general = t->symbol.general;
	else if t->symbol.general ^= null then e="1"b;

	if dummy.equivalence = null
	then dummy.equivalence = t->symbol.equivalence;
	else if t->symbol.equivalence ^= null then e="1"b;

	if dummy.array = null
	then dummy.array = copy_expression(t->symbol.array);
	else if t->symbol.array ^= null then e="1"b;

	if dummy_qualifier = null
	then dummy_qualifier = t->symbol.reference->reference.qualifier;
	else if t->symbol.reference->reference.qualifier ^= null then e = "1"b;

	if dummy.dcl_size = null
	then if t->symbol.returns
	     then if t->symbol.dcl_size ^= null
		then do;
		     dummy.dcl_size = copy_expression(t->symbol.dcl_size);
		     dummy.dcl_size->symbol.token =
			create_token(dummy.token->token.string||"[return_value]",(identifier));
		     end;
		else;
	     else dummy.dcl_size = copy_expression(t->symbol.dcl_size);
	else if t->symbol.dcl_size ^= null then e="1"b;

	if dummy.c_dcl_size = 0
	then do;
		dummy.c_dcl_size = t->symbol.c_dcl_size;
		dummy.scale = t->symbol.scale;
	     end;
	else do;
		if t->symbol.c_dcl_size ^= 0 then e="1"b;
		if t->symbol.scale ^= 0 then e="1"b;
	     end;

	/* If no errors were discovered, it is OK to change the input node. */

	if e = "0"b
	then do;
		s -> symbol = dummy;		/* structure assignment */
		dummy.reference -> reference.qualifier = dummy_qualifier;
	     end;

	return(e);

/* include files */

%include symbol;
%include reference;
%include token;
%include token_types;
%include language_utility;

     end /* merge attributes */;




		    optimizer.pl1                   07/31/89  1433.2r w 07/31/89  1338.4      354339



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


/* Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement */
/* Modified 790807 by PG to remove jump_three_way */

optimizer: proc(root);

dcl	root ptr;		/* points at root block node */
dcl	(blk,stm,p,q) ptr;
dcl	set_level fixed bin;
dcl	(doing_loop,inhibit_walk,state_is_discarded) bit(1) aligned;
dcl	statement_type bit(9) aligned;
dcl	pl1_stat_$cur_statement ptr ext static;
dcl	pl1_stat_$stop_id bit(27) ext static;
dcl	(ioa_,ioa_$nnl) entry options(variable), debug entry();
dcl	(s_list,p_list,free,freec,p_tail,freep,freep_tail,l_list) ptr int static;

dcl	n fixed bin(15);

dcl	1 primary		based aligned,
	2 node_type	bit(9) unaligned,
	2 reserved	bit(12) unaligned,
	2 number		fixed binary(14) unaligned,
	2 computation	ptr unaligned,
	2 statement	ptr unaligned,
	2 last		ptr unaligned,
	2 next		ptr unaligned;

dcl	1 secondary	based aligned,
	2 node_type	bit(9) unaligned,
	2 reserved	bit(12) unaligned,
	2 number		fixed binary(14) unaligned,
	2 operation	ptr unaligned,
	2 primary		ptr unaligned,
	2 last		ptr unaligned,
	2 next		ptr unaligned;

dcl	1 chain		based aligned,
	2 node_type	bit(9) unaligned,
	2 reserved	bit(12) unaligned,
	2 number		fixed binary(14) unaligned,
	2 value		ptr unaligned,
	2 next		ptr unaligned initial(null);

dcl	(null,string,substr) builtin;

%include language_utility;
%include block;
%include statement;
%include operator;
%include symbol;
%include boundary;
%include label;
%include list;
%include reference;
%include op_codes;
%include statement_types;
%include nodes;

begin:
	inhibit_walk = "0"b;
	set_level = 0;
	s_list,p_list,free,freec,p_tail,freep,freep_tail,l_list=null;
	blk=root->block.son;
scan:
	do while(blk->block.son ^= null);
	blk=blk->block.son;
	end;
statements:
	doing_loop = "0"b;
	do stm = blk->block.prologue, blk->block.main;
	state_is_discarded = "0"b;
	do stm = stm repeat stm->statement.next while(stm^=null);
	pl1_stat_$cur_statement = stm;
	if string(stm -> statement.source_id) = string(pl1_stat_$stop_id)
	then do;
		call ioa_$nnl("optimizer at ^p: ^a^/DB ",stm,decode_node_id(stm,"0"b));
		call debug;
	     end;
	statement_type = stm->statement.statement_type;
	if statement_type = entry_statement
	     then do;
		call clear;
		state_is_discarded = "0"b;
		end;
	     else if statement_type ^= procedure_statement
		then if statement_type ^= format_statement
		then do;
		     if stm->statement.labels ^= null
		     then do;
			call intersection(stm,1);	/* order of calls is crucial */
			call intersection(stm,2);	/* leave proper info on prim's for cg 
						   or create new state */
			end;
		     if ^ state_is_discarded
			then call reduce(stm->statement.root,stm,"0"b,"0"b);
		     if statement_type = return_statement | statement_type = stop_statement
		     then state_is_discarded = "1"b;
		     else if statement_type = begin_statement
			then call erase;
		     end;
	end;
	end;
	call clear;

/* process the list of loop operators */

	p = l_list;
	do while(p ^= null);
	     doing_loop = "1"b;
	     q = p -> chain.value;
	     call reduce(q->operand(1),q,"0"b,"0"b);
	     call clear;
	     if p -> chain.next = null
	     then do;
		p -> chain.next = freec;
		freec = l_list;
		l_list = null;
		go to next_block;
		end;
	     p = p -> chain.next;
	     end;

/* set blk to point to the next block node. */

next_block:
	if blk->block.brother ^= null
		then blk=blk->block.brother;
		else if blk->block.father ^= null
			then do;
				blk=blk->block.father;
				go to statements;
			     end;
			else return;
	go to scan;


/* this routine walks down the tree matching all computations against the primary list,
and entering all reducible computations into the primary list if they are not already
there.  If an operator or reference node matches a computation in the primary list,
the parent node is modified to refer to the node that is in the primary list, and the
reference count of that node is increased by one.  The reference count, if any,
in the matching node is decreased by one and ,if possible, the node is freed.
All operators which could alter the value of a variable are recognized
and any computation which depends on these variables is removed from the primary list.  */

/* inhibit is an input parameter used to prevent commoning or entry onto the
   primary list of any node contained in a loop subtree.

   irreducible is an output parameter set when an operator node is found to be
   irreducible.  An operator is irreducible if it:

	1. is a call to an irreducible entry.
	2. produces side effects or output that depends on something
	   other than its formal input.
	3. contains any of the above.

irreducible_op is a local variable used to determine if a given node is an irreducible
operator.  If it is irreducible it is not put on the primary list, but contained
subexpression may be put on the list if they are not themselves irreducible.

The top operaotor of an argument subexpression is never commoned
or put on the primary list, but it is not considered irreducible in the
sense that it does not make its containing operator irreducible.  This
is because if the containing operator is a reducible function the
programmer has declared that the function won't alter its argument.  If
the containing operator is an irreducible function, we don't need to
pass back this information.  Since at the level where
we process the argument, we don't know wheither or not the containing
function is reducible, we don't set the irreducible bit for the
top operator of an argument.

Before the code_generator phase, reference.inhibit = "1"b means that the reference
is the base of a defined variable (used for its address not its value) and should
not be commoned.  This prevents conversion of the reference to a temporary by the
code generator, which would destroy the address.

Note that a given invocation of reduce cannot return unless it is at the bottom of the tree
or has just called erase or has been commoned.  This insures that all set contexts
are scanned.  A commoned subtree cannot contain a set context because if it did, it
would be irreducible and therefore not in the primary list.  */

reduce: proc(pt,parent,irreducible,inhibit);

dcl	pt ptr unaligned;
dcl	(parent,p,q,p1,p2,p3,s1,tp) ptr;
dcl	(i,j)fixed bin(15);
dcl	opcode bit(9) aligned;
dcl	(irreducible,sets_operand1,inhibit,signal_op,new_primary,
	irreducible_op,jump_op,irreducible_entry,addr_op,
	sets_reference,irreducible_sons,inhibit_sons,irreducible_2)
	bit(1) aligned;


begin:
	p = pt;
	if p=null then return;
	if p->node.type = reference_node
		then do;
			p1 = p->reference.symbol;
			if p1->node.type = symbol_node
			     then do;

				/* The aliasable bit of a reference node means that the storage
				   identified by this reference is potentially accessable via
				   another name, this is a potential alias.  The circumstances
				   that cause the aliasable bit of the symbol node to be set are:

					The variable is used as an argument to addr.
					(note that put string(x), read into(x),  read or locate set(x)
					all take addr of x.)
					The variable is the base of a defined variable.
					The variable is defined.
					The variable is based.
					The variable is external.
					The variable is a parameter.
					The variable is passed as an argument by_reference and is static or controlled.

				The reference is aliasable (potentially aliased) if its symbol node
				has the aliasable bit or if it is a reference to a nonlocal automatic
				variable that is passed as an argument by_reference.  */

				p->reference.aliasable = p1->symbol.aliasable|
					(p1->symbol.auto&(blk^=p1->symbol.block_node)&p1->symbol.passed_as_arg);

				/* this code is executed to exclude from optimization those simple references
				   that are done by the code generator.  If they were included here,
				   the size of the tree would be very large.  */

				if p->reference.offset=null
				     then if p->reference.qualifier=null
					then if p->reference.length=null
					     then if p1->symbol.temporary
						then return;
						else if p->reference.units=word_ | p->reference.units=0
						     then if p -> reference.ref_count = 0
							then if ^ (p1->symbol.packed & p1->symbol.member)
							     then if p = p1 -> symbol.reference
								then return;
								else do;
								     p2 = p1 -> symbol.reference;
								     if compare_expression(p,p2)
									then pt = p2;
								     return;
								     end;
				end;

/* search the primary list for a previously computed instance of this reference.  */

			q = p_list;
			if ^inhibit
			then if ^ p->reference.inhibit
			then do;
			do while(q^=null);
			p2 = q -> primary.computation;
			if p = p2
			   then return;
			   else if compare_expression(p2,p)
			     then do;

/* replace this reference with the previously computed one.  */

				pt = p2;
				p2->reference.ref_count = p2->reference.ref_count+1;
				call adjust_count(p);
				return;
				end;
			q = q->primary.next;
			end;
			end;

/* determine the reducibility of this reference while reducing its sons.  */

			irreducible_op = "0"b;
			if ^ inhibit_walk
			then if ^p->reference.shared		/* shared references have no sons */
			     then do;
				call reduce_ref_sons(p,irreducible_op);
				end;
			irreducible = irreducible|irreducible_op;
			if inhibit|irreducible_op|p->reference.inhibit then return;

/* no temporaries can go on the primary list */

			if p1 -> node.type = symbol_node
			then if p1 -> symbol.temporary
			     then return;

/* only unshared references should go on the primary list */

			if p -> reference.shared
			then do;
			     p = copy_expression((p));
			     p -> reference.shared = "0"b;
			     p -> reference.ref_count = 1;
			     pt = p;
			     end;

/* put this reference on the primary list.  */

			q = create_node(p_list,1);
			q->primary.computation = p;
			q->primary.statement = pl1_stat_$cur_statement;
			call record_secondaries(p,1);
			return;
		     end;
	if p->node.type = list_node
		then do;
			do i = 1 to p->list.number;
			call reduce(p->list.element(i),p,irreducible,inhibit);
			end;
			return;
		     end;
	if p->node.type ^= operator_node then return;

/* join operators should be handled like list nodes except that they are always irreducible */

	opcode = p->operator.op_code;

	if opcode = join
		then do;
			do i = 1 to p->operator.number;
			call reduce(p->operator.operand(i),p,irreducible,inhibit);
			end;
			irreducible = "1"b;
			return;
		     end;

/* classify this operator and determine if it is irreducible.  */

	jump_op = opcode>=jump & opcode<=jump_if_ge;
	signal_op = opcode=record_io|opcode=allot_ctl|opcode=signal_on|opcode=terminate_trans|opcode=stream_prep|
		opcode=open_file|opcode=close_file|opcode=allot_based|(opcode>=get_list_trans & opcode<=put_data_trans)|
		opcode=lock_fun|opcode=stacq_fun;
	irreducible_op = signal_op|jump_op|p->operator.number=0|opcode=return_words|
		(opcode>=return_bits & opcode<=allot_auto)|opcode=free_ctl|
		(opcode>=empty_area & opcode<=vclock_fun)|(opcode>=loop & opcode<=nop);
	sets_operand1 = ^(opcode=return_words|opcode=return_bits|opcode=return_string|opcode=std_entry|
		jump_op|p->operator.number=0|(opcode>=loop & opcode<=nop));
	addr_op = opcode = addr_fun | opcode = addr_fun_bits;

	if addr_op
	     then addr_op = p -> operand(2) -> node.type = reference_node;

	irreducible = irreducible|irreducible_op;


/* search the primary list for a previously computed instance of this operator.
   If one is found, make the parent of this node point to it. */


	q=p_list;
	if ^(inhibit|irreducible_op|parent->node.type = list_node)
	then do;
	do while(q^=null);
	p2 = q -> primary.computation;
	if p = p2
	     then return;
	     else if compare_expression(p2,p)
		then do;
			p1 = p2->operand(1);
			if p1->reference.shared
				then do;
					p1,p2->operand(1) = copy_expression((p1));
					p1->reference.shared = "0"b;
					p1->reference.ref_count = 1;
				     end;
			pt = p2;
			p1->reference.ref_count = p1->reference.ref_count+1;
			call adjust_count(p);
			return;
		     end;
	q=q->primary.next;
	end;
	end;

/* If the operator can produce a signal that is allowed to alter storage and return,
   process it as if it was a call to an external entry.  */

	if signal_op
	     then do;
		irreducible_sons = "0"b;

		if opcode = get_data_trans
		     then do;
			if p->operand(1) = null
			     then call erase;		/* this is get data;  */
			     else do;
				p = p->operand(1);		/* join operator */
				do i = 1 to p->operator.number;
				call set((p->operand(i)));
				end;
				end;
			call external_call;
			return;
			end;

		if opcode = get_edit_trans | opcode = get_list_trans
		     then do;
			call reduce(p->operand(1),p,irreducible_op,inhibit);
			q = p->operand(2);
			if ^ q -> reference.shared
			     then call reduce_ref_sons(q,irreducible_sons);
			call set(q);
			call external_call;
			call check_and_reduce_target(2 /* ,q,p,irreducible_sons */);
			return;
			end;

		if opcode = allot_ctl
		     then do;
			call reduce(p -> operand(2),p,irreducible_op,inhibit);
			call set((p->operand(1)));
			call external_call;
			call reduce(p->operand(1),p,irreducible_op,inhibit);
			return;
			end;

		if opcode = allot_based
		then do;
		     q = p -> operand(1);

		     /* set option evaluated first and only once */

		     if ^ q -> reference.shared
			then call reduce_ref_sons(q,irreducible_sons);

		     /* operations after this point may be retried */

		     call external_call;

		     call reduce(p -> operand(2),p,irreducible_op,inhibit);

		     if p -> operand(3) ^= null
		     then do;
			call reduce(p -> operand(3),p,irreducible_op,inhibit);
			call set((p -> operand(3)));
			end;

		     call set(q);
		     call external_call;
		     call check_and_reduce_target(1 /* ,q,p,irreducible_sons */);
		     return;
		     end;

		if opcode = lock_fun | opcode = stacq_fun
		then do;
		     do i = 2 to p->operator.number;
			call reduce(p->operand(i),p,irreducible_op,inhibit);
			end;

		     q = p -> operand(1);
		     if ^ q -> reference.shared
			then call reduce_ref_sons(q,irreducible_sons);

		     if opcode = stacq_fun
			then call set((p -> operand(2)));
			else call external_call;
		     call set(q);

		     call check_and_reduce_target(1 /* ,q,p,irreducible_sons */);
		     return;
		     end;

		do i = 1 to p->operator.number;
		call reduce(p->operand(i),p,irreducible_op,inhibit);
		end;
		call external_call;
		return;
		end;

/* all operators processed after this point do not produce conditions of interest to the optimizer.  */

	if opcode = free_based
	then do;
	     call reduce(p -> operand(2),p,irreducible_op,inhibit);
	     call reduce_ref_sons((p -> operand(1)),irreducible_op);

	     if p -> operand(3) ^= null
	     then do;
		call reduce(p -> operand(3),p,irreducible_op,inhibit);
		call set((p -> operand(3)));
		end;

	     /* last block of code here is nonstandard and corresponds to runtime action */

	     if p -> operand(1) -> reference.qualifier -> node.type = reference_node
		then call set((p -> operand(1) -> reference.qualifier));

	     return;
	     end;

	if opcode = fortran_read
	     then do;
		do i = 1 to 9;
		call reduce(p->operand(i),p,irreducible_op,inhibit);
		end;
		p1 = p->operand(10);
		if p1 ^= null		/* check for an I/O list */
		     then do i = 1 to p1->list.number;
			call set((p1->list.element(i)));
			call reduce(p1->operand(i),p1,irreducible_op,inhibit);
			end;
		return;
		end;

/* reduce the second operand of all non-addr_op operators that have at least two operands. 
  (we omit reduction of the second operand of addr_ops to avoid code optimizations
   for short strings done by the code generator) */

	if p->operator.number >= 2
	then if ^ addr_op
	     then do;
		irreducible_2 = "0"b;
		call reduce(p -> operand(2),p,irreducible_2,inhibit);
		irreducible_op = irreducible_op | irreducible_2;
		end;
	     else do;
		tp = p -> operand(2);
		tp->reference.aliasable = tp->reference.symbol->symbol.aliasable;
		if ^ tp -> reference.shared
		     then call reduce_ref_sons(tp,irreducible_op);
		end;

	if opcode = std_call
	then do;

/* Calls to internal procedures and entry variables may set anything.  Calls to external
   entries can set: arguments passed by reference, aliased variables, and variables declared in a flush_at_call block.
   The flush_at_call bit indicates that this block contains an on-unit, or an
   internal procedure whose name is assigned or passed as an argument.  Therefore,
   any call out from this block could result in the invocation of the on-unit or
   internal procedure and could set any variable known to this block.  */

/* The operands of a std_call operator are processed somewhat differently than the
   operands of other operators.  We want to reduce the arguments of the call before
   flushing the primary list, but we do not want to actually reduce a reference
   node being passed as an argument until after the primary list is cleared
   (because of some code optimizations done by the code generator).  The solution
   we adopt is to reduce any length, qualifier, or offset expression on
   a reference before clearing primary list and to not reduce the reference at
   all. */

/* the top operator of an argument expression passed to an irreducible entry cannot
be commoned because it is usable as a variable in the called procedure.  */

	     p3 = p->operand(2);
	     if p3->node.type = reference_node
		then irreducible_entry = p3->reference.symbol->symbol.irreducible;
		else irreducible_entry = "1"b;

	     irreducible_op = irreducible_op|irreducible_entry;
	     if irreducible_entry
	     then do;
		p3 = p -> operand(3);
		if p3 ^= null
		then do;
		     q = p3 -> operand(2);

		     do i = 1 to q -> list.number;
			tp = q -> element(i);
			if tp -> node.type ^= reference_node
			then call reduce(q -> element(i),q,irreducible_op,inhibit);
			else do;
			     if ^ tp -> reference.shared
				then call reduce_ref_sons(tp,irreducible_op);
			     end;
			end;
		     end;

		q = p -> operand(2);
		if q -> node.type = operator_node then q = q -> operand(1);
		q = q -> reference.symbol;

		if q -> symbol.variable | q -> symbol.internal | q->symbol.temporary
		then do;
		     call erase;
		     end;
		else do;
		     if p3 ^= null
		     then do;
			q = p3 -> operand(2);

			do i = 1 to q -> list.number;
			     tp = q->list.element(i);
			     if tp->node.type = reference_node
				then call set(tp);
			     end;

			end;
		     call external_call;
		     end;

		end;

	     else do;
		p3 = p -> operand(3);
		if p3 ^= null
		     then call reduce(p3 -> operand(2),p3,irreducible_op,inhibit);
		end;

	     end;

/* reduce operands 3 through n for all operators that have them, except std_call.  */

	if opcode ^= std_call
	     then do i = 3 to p->operator.number;
	          call reduce(p->operand(i),p,irreducible_op,inhibit);
	          end;



/* If this operator is reducible and stores its output into operand1, put it on the primary list. */

	inhibit_sons = inhibit;
	sets_reference,
	irreducible_sons,
	new_primary = "0"b;
	if sets_operand1
	     then if p->operator.operand(1) ^= null
		then if p->operator.operand(1)->node.type = reference_node
		     then do;

			/* we must reduce descendents of operand(1) before it is set */

			sets_reference = "1"b;
			q = p->operand(1);
			if ^ q->reference.shared
			then do;
			     call reduce_ref_sons(q,irreducible_sons);
			     inhibit_sons = inhibit_sons | irreducible_sons;
			     irreducible_op = irreducible_op | irreducible_sons;
			     end;

			if ^(irreducible_op | inhibit | parent->node.type = list_node)
			then do;
				new_primary = "1"b;
				p1=create_node(p_list,1);
				p1->primary.computation = p;
				p1->primary.statement = pl1_stat_$cur_statement;
				call record_secondaries(p,2); /* record all but operand 1 as secondaries. */
				if ^ q->reference.shared
				     then call record_secondaries(q,0); /* record descendents of opnd1
								   as secondaries */
			     end;
			end;

/* If the operator places its output into a variable the variable must be processed
   by the "set" routine to purge the primary list of any computation that depends on
  the value of this variable.  NOTE:  we must set the reference's aliasable bit
  here, because it may not yet have been reduced */

	if sets_reference
	     then do;
		if q->reference.symbol->node.type = symbol_node
		then if ^(q->reference.symbol->symbol.temporary
			|q->reference.symbol->symbol.return_value)
			then do;
			     s1 = q -> reference.symbol;
			     q -> reference.aliasable = s1 -> symbol.aliasable |
				(s1->symbol.auto&(blk^=s1->symbol.block_node)&s1->symbol.passed_as_arg);

			     call set(q);

			     if ^ q->reference.shared
			     then if ^ inhibit_sons
				then inhibit_sons = inhibit_sons | sons_were_set(q);
			     end;
		end;



/* if this operator was entered on the primary list, record operand 1 as a secondary.
   This strange order is necessary to insure that i=i+1 is not retained as a primary,
   but a=b+c is retained.  Futhermore, a=b+c;a=10; must flush the add operator.  */

	if new_primary
	     then if p_list ^= null
		then if p_list->primary.computation = p
			     then if ^p->operand(1)->reference.symbol->symbol.temporary
				then call record_secondaries((p->operand(1)),-1);

/* reduce operand one of all operators. */

	inhibit_walk = sets_reference;
	inhibit_sons = inhibit_sons|(opcode=loop|opcode=ftn_trans_loop);
	if p->operator.number>0
	     then if p->operator.operand(1) ^= null
		then call reduce(p->operand(1),p,irreducible_op,inhibit_sons);

	irreducible = irreducible|irreducible_op;
	inhibit_walk = "0"b;

/* If the operator is a loop operator which does not immediately contain another
loop operator, and we are not processing the inside of a loop now, then put this
operator on the loop chain.  */

	if opcode = loop
	then if ^ doing_loop
	then if p -> operand(1) -> operator.op_code ^= loop
	then do;
		if freec = null
		then do;
		     freec = create_list(2);
		     freec -> list.element(2) = null;
		     end;
		p1 = freec;
		freec = p1 -> chain.next;
		p1 -> chain.next = l_list;
		l_list = p1;
		p1 -> chain.value = p;
	     end;

/* if the operator is a transfer check to see if it goes to a statement futher down in
this block.  If it does, then attach the current p_list to the statement by taking the intersection
of the list already on the statement and the current p_list.  Each time a transfer is processed the
reference count in the statement node is decreased by one.  When the optimizer encounters the
labeled statement it will check to see if all references have been processed by checking
for a reference count of one.  If all references have been processed it will continue its optimization
using the intersection of its current p_list and the list attached to the statement.  If all
references have not been processed it will erase its p_list.   If the operator is an
unconditional transfer mark the state as discarded.   */

	if jump_op
	then do;
		q=p->operand(1);
		if q -> node.type = label_node
		then do;
		     if q -> label.block_node = blk
			then call process_jump_target((q -> label.statement));
		     end;
		else if q -> node.type = reference_node
		     then do;
			s1 = q -> reference.symbol;
			if s1 -> node.type = label_node
			then if s1 -> label.block_node = blk
			then if q -> reference.offset = null
			     then call process_jump_target((s1->label.statement->element(q->reference.c_offset + 1)));
			     else do;
				q = s1 -> label.statement;
				do j = 1 to q -> list.number;
				     if q -> element(j) ^= null
				          then call process_jump_target((q -> element(j)));
				     end;
				end;
			end;

		if opcode = jump
		     then state_is_discarded = "1"b;

		/* set bit for cg's use in optimizing if statements */

		if irreducible_2
		then if p -> operator.number = 2	/* jump_true | jump_false */
		     then stm -> statement.irreducible = "1"b;
	     end;
	return;


reduce_ref_sons:	proc(pt,irreducible_sons);

dcl	(p,pt) ptr;
dcl	irreducible_sons bit(1) aligned;

	p = pt;
	if p -> reference.length ^= null
	     then call reduce(p -> reference.length,p,irreducible_sons,inhibit);
	if p -> reference.qualifier ^= null
	     then call reduce(p -> reference.qualifier,p,irreducible_sons,inhibit);
	if p -> reference.offset ^= null
	     then call reduce(p -> reference.offset,p,irreducible_sons,inhibit);

	end; /* reduce_ref_sons */


/* this routine searches the primary list for sons of operand(1) of an operator
   to see if they were set when operand(1) was set.  if so, operand(1) should
   not be put on the primary list */

sons_were_set:	proc(pt) reducible returns(bit(1) aligned);

dcl	(p,pt) ptr;

	p = pt;

	if ^ check((p->reference.qualifier))
	then if ^ check((p->reference.offset))
	     then if ^ check((p->reference.length))
		then return("0"b);

	return("1"b);

check:	proc(pt) reducible returns(bit(1) aligned);

dcl	(p,pt,q) ptr;

	p = pt;

	if p = null then go to ok;
	if p -> node.type = reference_node
	then if p -> reference.shared
	     then go to ok;

	do q = p_list repeat q -> primary.next while(q ^= null);
	     if q -> primary.computation = p then go to ok;
	     end;

	return("1"b);
ok:	return("0"b);

	end; /* check */

	end; /* sons_were_set */


/* this routine, called for a signal_op, checks to see if a target can
   be reduced after the operation has taken place */

check_and_reduce_target:	proc(i /* ,q,p,irreducible_sons */);

dcl	i fixed bin;

	if ^ q -> reference.shared
	then if ^ irreducible_sons
	     then irreducible_sons = irreducible_sons | sons_were_set(q);

	if ^ irreducible_sons
	then do;
	     inhibit_walk = "1"b;
	     call reduce(p -> operand(i),p,irreducible_op,inhibit);
	     inhibit_walk = "0"b;
	     end;

	end; /* check_and_reduce_target */


/* this routine does the actual processing for targets of  jump_op's */

process_jump_target: proc(pt);

dcl	(pt,p1,p2,p4,q) ptr;

	p1 = pt;

	if p1->statement.ref_count_copy = 0
	     then p1->statement.ref_count_copy=p1->statement.reference_count-1;
	     else p1->statement.ref_count_copy=p1->statement.ref_count_copy-1;
	if string(p1->statement.source_id) < string(pl1_stat_$cur_statement->statement.source_id)
		then return;
	if p1->statement.optimized
		then call intersection(p1,2);
		else do;
			p1->statement.optimized="1"b;
			q=p_list;
			do while(q^=null);
			p4=p1->statement.reference_list;
			p2=create_node(p4,0);
			p1->statement.reference_list=p4;
			p2->primary.computation=q->primary.computation;
			p2->primary.statement=q->primary.statement;
			q=q->primary.next;
			end;
		     end;

	end; /* process_jump_target */

	end; /* reduce */
			

/* this routine walks down a tree recognizing references to variables
and enters them in the secondary list if they are not already in the list.  */

record_secondaries: proc(pt,start);

dcl	(p,pt,q,p1,p2) ptr;
dcl	(i,start) fixed bin(15);

	/* start :
		-1	record pt but not its descendents
		0	record pt's descendent but not pt
		1	record pt and its descendents
		2	record operands 2-n of operator pt */

begin:
	p = pt;
	if p=null then return;
	if p->node.type = list_node
		then do;
			do i = 1 to p->list.number;
			call record_secondaries((p->list.element(i)),1);
			end;
			return;
		     end;
	if p->node.type = operator_node
		then do;
			do i=start to p->operator.number;
			call record_secondaries((p->operand(i)),1);
			end;
			return;
		     end;

	if p->node.type ^= reference_node then return;

	p1 = p->reference.symbol;
	if p1 ->node.type ^= symbol_node then return;

	if start >= 0
	then do;
	     if p->reference.qualifier ^= null then call record_secondaries((p->reference.qualifier),1);
	     if p->reference.offset ^= null then call record_secondaries((p->reference.offset),1);
	     if p->reference.length ^= null then call record_secondaries((p->reference.length),1);
	     end;

	if start = 0 then return;

	if p1 -> symbol.constant | p1 -> symbol.temporary then return;

/* search the secondary list to see if the variable is in the list */

	q=s_list;
	do while(q^=null);
	     p2 = q->secondary.operation;
	     if p2 = p then goto chain_it;
	     if p->reference.symbol = p2->reference.symbol
	     then if compare_expression(p2,p)
		then go to chain_it;
	     q=q->secondary.next;
	     end;

/* make a new secondary entry for the variable		*/

	q=create_node(s_list,2);
	q->secondary.primary=null;
	q->secondary.operation=p;


/* add this primary to the list of primaries effected by this secondary */

chain_it:
	if freec = null
		then do;
			freec = create_list(2);
			freec->list.element(2) = null;
		     end;
	p1=freec;
	freec=p1->chain.next;
	p1->chain.next=q->secondary.primary;
	q->secondary.primary=p1;
	p1->chain.value=p_list;
	end record_secondaries;

/* this routine removes entries from the secondary list and related
primary list.						*/

set: proc(pt);

dcl	(p,pt,q,p1,q1,p2,s) ptr;
dcl	c_offset fixed bin(24);
dcl	p1_unal ptr unal auto;	/* used for better code in the comparisons */


begin:
	p = pt;
	if p=null then return;
	if p->node.type ^= reference_node then return;
	p1_unal, p1 = p->reference.symbol;
	if p1->node.type ^= symbol_node then return;
	s = p1->symbol.son;
	do while(s^=null);
	set_level = set_level + 1;
	call set((s->symbol.reference));
	set_level = set_level - 1;
	s = s->symbol.brother;
	end;
	if p->reference.aliasable
		then do;
			q = s_list;
			do while(q^=null);
			q1 = q->secondary.operation->reference.symbol;
			if q->secondary.operation->reference.aliasable
			     then if compare_alias(p1,q1)
				then do;
					call free_them;
					q1 = q->secondary.next;
					call release_node(q,s_list,2);
					q = q1;
					go to next;
				     end;
			q = q->secondary.next;
next:
			end;
			return;
		     end;

/* If the set was done with a pseudovariable, set the argument of the pseudovariable */

	if p1 -> symbol.defined
	     then call set((p -> reference.qualifier));

/* if this variable has been the argument of string, unspec, real, or imag, we
   must remove all computations depending on this symbol because the offset and
   c_offset may have been changed during processing.  Also, ancestors may have
   been affected */

	if p1 -> symbol.overlayed_by_builtin & (p1 -> symbol.member | p1 -> symbol.dimensioned)
	then do;
	     do while(p1 ^= null);
		if ^ p1 -> symbol.overlayed_by_builtin | ^ (p1 -> symbol.member | p1 -> symbol.dimensioned)
		     then return;
		q = s_list;
		do while(q ^= null);
		     if q -> secondary.operation -> reference.symbol = p1	/* p1_unal not used because p1 changes */
		     then do;
			call free_them;
			q1 = q -> secondary.next;
			call release_node(q,s_list,2);
			q = q1;
			end;
		     else q = q -> secondary.next;
		     end;
		if set_level > 0
		     then return;
		p1 = p1 -> symbol.father;
		end;
	     return;
	     end;

/* if this is an array element with variable offset or array reference or string, remove all computations	*/
/* that are a function of any element of this array or string.		*/

	if (p1->symbol.array ^= null & (p->reference.array_ref | p-> reference.offset ^= null)) | p1->symbol.bit | p1->symbol.char
		then do;
			q=s_list;
			do while(q^=null);
			if q->secondary.operation->reference.symbol=p1_unal
				then do;
					call free_them;
					q1=q->secondary.next;
					call release_node(q,s_list,2);
					q=q1;
				     end;
				else q=q->secondary.next;
			end;
		return;
	     end;

/* if this is an array element with constant offset, remove all computations
   that are a function of this element or any array reference or array
   element with variable offset of this array. handle storage_block 
  references in a similar manner */

	if p1 -> symbol.array ^= null | p1 -> symbol.storage_block
	then do;
	     q = s_list;
	     c_offset = p -> reference.c_offset;
	     do while (q ^= null);
		q1 = q -> secondary.operation;
		if q1 -> reference.symbol = p1_unal
		then if q1 -> reference.c_offset = c_offset | q1 -> reference.array_ref | q1 -> reference.offset ^= null
		     then do;
			call free_them;
			q1 = q -> secondary.next;
			call release_node(q,s_list,2);
			q = q1;
			go to next_a;
			end;
		q = q -> secondary.next;
next_a:
		end;
	     return;
	     end;

/* this is not an array element or array reference or string.			*/

	q=s_list;
	do while(q^=null);
	if q->secondary.operation->reference.symbol = p1_unal
		then do;
			call free_them;
			call release_node(q,s_list,2);
			return;
		     end;
	q=q->secondary.next;
	end;
	return;

/* This entry frees all computations that depend on anything that can be set by a
   call to an external procedure, otherthan the arguments passed by-reference.  */

external_call: entry;

declare free_flag bit(1);

	q = s_list;
	do while(q^=null);
	q1 = q->secondary.operation;
	p2 = q1->reference.symbol->symbol.block_node;
	if p2 = null
	     then free_flag = q1->reference.aliasable;
	     else free_flag = q1->reference.aliasable|p2->block.flush_at_call;
	if free_flag
		then do;
			call free_them;
			q1 = q->secondary.next;
			call release_node(q,s_list,2);
			q = q1;
		     end;
		else q = q->secondary.next;
	end;
	return;

/* subroutine to free all primary list entries that depend on the secondary
   entry identified by the pointer q.  */

free_them: proc;

dcl	p1 ptr;

begin:
	p1 = q->secondary.primary;
	do while(p1^=null);
	call release_node((p1->chain.value),p_list,1);
	if p1->chain.next=null
		then do;
			p1->chain.next = freec;
			freec = q->secondary.primary;
			return;
		     end;
	p1 = p1->chain.next;
	end;

	end free_them;

%include compare_alias;
	end set;

/* these routines are utility programs to create and free nodes	*/
/* i=0 for statement list primary nodes. i=1 for p_list primary nodes. i=2 for secondary nodes. */

release_node: proc(pt,list_head,i);

dcl	(p,pt,list_head) ptr;
dcl	i fixed bin(15);

begin:
	p = pt;
	if p->primary.computation = null
		then return;		/* this is an attempt to release an already freed primary */
	if p->primary.next ^=null
		then p->primary.next->primary.last=p->primary.last;
	if p->primary.last =null
		then list_head=p->primary.next;
		else p->primary.last->primary.next=p->primary.next;
	if i=1
		then do;				/* this is a primary node */
			if freep = null then freep_tail = p;
			p->primary.computation=null;	/* null indicates that it is free */
			p->primary.next=freep;
			freep=p;
			if p=p_tail then p_tail=p->primary.last;
		     end;
		else do;
			p->primary.next = free;
			free=p;
		     end;
	p->primary.last=null;
	end release_node;


create_node: proc(list_head,i) returns(ptr);

dcl	(list_head,p) ptr;
dcl	i fixed bin(15);

begin:
	if free = null
		then p = create_list(4);
		else do;
			p=free;
			free=free->list.element(4);
		     end;
	p->list.element(3)=null;
	p->list.element(4)=list_head;
	if i=1 & list_head=null then p_tail=p;
	if list_head ^= null then list_head->list.element(3)=p;
	list_head=p;
	return(p);
	end create_node;


/* erase everything from the primary and secondary lists.  */

clear: proc;

	call erase;
	if p_tail ^= null
		then do;
			p_tail->list.element(4) = free;
			free = p_list;
			p_list,p_tail = null;
		     end;
	end clear;

/* erase all primaries except those whose operands are constants. */

erase: proc;

dcl	(p,q) ptr;

begin:
	q=s_list;
	do while(q^=null);
	p=q->secondary.primary;
	do while(p^=null);
	if p->chain.value->primary.computation ^= null
	     then call release_node((p->chain.value),p_list,1);
	if p->chain.next = null
		then do;
			p->chain.next=freec;
			freec=q->secondary.primary;
			go to continue;
		     end;
	p=p->chain.next;
	end;
continue:
	call release_node(q,s_list,2);
	q=s_list;
	end;

/* put free primaries on the free list.  It is safe to do this because no
more secondaries exist and therefore no references exist.			*/

/* the primary list may still contain computations whose operands are constants */

	if freep_tail ^= null
		then do;
			freep_tail->primary.next=free;
			free=freep;
			freep_tail,freep=null;
		     end;
	end erase;


/* this routine gets the intersection of the p_list and the primary list
attached to the statement node.  If i=2 the statement node list is replace by this intersection.
If i=1 the primary list p_list is replaced by the intersection.  If the state has been
discarded and i = 2, the primary list p_list is replaced by the union of p_list and the
statement node list.  */

intersection: proc(pstate,p_i);

dcl	(pstate,state,p,q,t) ptr;
dcl	(i,n,p_i) fixed bin(15);

begin:
	state = pstate;
	i = p_i;

	n = 0;
	do q=state->statement.labels repeat q->list.element(1) while(q^=null);
	     n = n + 1;
	end;

	if state -> statement.ref_count_copy = 0 then state -> statement.ref_count_copy =
	 state -> statement.reference_count;

	if i=1 & state->statement.ref_count_copy ^= n
		then do;
			call clear;
			q=state->statement.reference_list;
			do while(q^=null);
			t = state -> statement.reference_list;
			call release_node(q,t,0);
			q, state->statement.reference_list = t;
			end;
			return;
		     end;

	if ^state->statement.optimized  /* label was never referenced */
	then if i=1 | state->statement.ref_count_copy = n
	     then return;

	if i = 2 & state_is_discarded & p_list = null
	then do;
	     do p = state -> statement.reference_list repeat p -> primary.next while(p ^= null);
		t = create_node(p_list,1);
		t -> primary.computation = p -> primary.computation;
		t -> primary.statement = p -> primary.statement;
		call record_secondaries((t -> primary.computation),1);
		end;
	     state_is_discarded = "0"b;
	     return;
	     end;

	if i=2 then p=state->statement.reference_list;
		else p=p_list;
	do while(p^=null);
	if i=2 then q=p_list;
		else q=state->statement.reference_list;
	do while(q^=null);
	if q->primary.computation = p->primary.computation
		then do;
			p=p->primary.next;
			go to next;
		     end;
	q=q->primary.next;
	end;

/* this element is not common to both lists, remove it (or if i = 2 &
   state_is_discarded, add it to p_list).  */

	q=p->primary.next;
	if i=2
	then if state_is_discarded
	     then do;
		t = create_node(p_list,1);
		t -> primary.computation = p -> primary.computation;
		t -> primary.statement = p -> primary.statement;
		call record_secondaries((t -> primary.computation),1);
		end;
	     else do;
		t = state -> statement.reference_list;
		call release_node(p,t,0);
		state -> statement.reference_list = t;
		end;
	else call release_node(p,p_list,1);
	p=q;
next:
	end;

	if i = 2 then state_is_discarded = "0"b;


	end intersection;


dump_primary: entry;
dcl	display_exp entry(ptr);
	do q = p_list repeat q->primary.next while(q^=null);
	call display_exp((q->primary.computation));
	call ioa_("^/");
	end;
	return;

dump_secondary: entry;
	do q = s_list repeat q->secondary.next while(q^=null);
	call display_exp((q->secondary.operation));
	call ioa_("^/");
	end;
	return;
     end /* optimizer */;




		    parse_error.pl1                 07/31/89  1433.2rew 07/31/89  1328.3       25182



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
     install(89-07-31,MR12.3-1066):
     Removed the obsolete parameter source_line from the call to error_().
                                                   END HISTORY COMMENTS */


/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

parse_error:
     proc (error_number, error_ptr);

dcl      (error_number, n) fixed bin (15),
         pl1_stat_$source_seg fixed bin (11) ext static,
         source_seg fixed bin (8) init (0),
         sli fixed bin (15) init (0) int static,
         start fixed bin (23),
         length fixed bin (11),
         (error_ptr, s) ptr,
         text bit (1) aligned init ("0"b);

%include source_id;

dcl      (addr, binary, null, string) builtin;


dcl      pl1_stat_$cur_statement ptr ext static,
         pl1_stat_$source_ptr ptr ext static,
         pl1_stat_$st_start fixed bin (23) ext static,
         pl1_stat_$st_length fixed bin (17) ext static;


%include language_utility;
%include token_list;
%include statement;

/*      */

	text = "1"b;

no_text:
     entry (error_number, error_ptr);

	s = pl1_stat_$cur_statement;

	if text then do;
	     if s ^= null then do;
		string (source_id) = string (s -> statement.source_id);
		start = s -> statement.source.start;
		length = s -> statement.source.length;
		source_seg = s -> statement.source.segment;
	     end;
	     else do;
		string (source_id) = string (pl1_stat_$statement_id);
		start = pl1_stat_$st_start;
		length = pl1_stat_$st_length;
		source_seg = pl1_stat_$source_seg;
	     end;

	     call error_ (error_number, source_id, error_ptr, source_seg, start, length);
	end;

	else
	     call error_ (error_number, pl1_stat_$statement_id, error_ptr, source_seg, 0, 0);

     end parse_error;




		    pl1_error_print.pl1             07/31/89  1433.2r w 07/31/89  1338.4       72270



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


/* Print PL/I error messages.

   Initial Version: 14 June, 1968 by BLW
	Modified:	30 July 1969 by JDM for pl1 
	Modified:	10 January 1970 by CTC for new error message format 
         Rewritten:	17 August 1970 by P. Green for Version II
	Modified: 16 January 1971 by BLW to print text of bad statement 
	Modified:	13 February 1977 by RAB to fix 1577
	Modified: 770712 by PG to add pl1_severity_
	Modified 771020 by PG to fix 1677
	Modified 780807 by PG to permit char(256) tokens to be substituted for "$".
	Modified 23 October 1980 by M. N. Davidoff to fix 1977, an unitialized variable causes tokens to be quoted when
		they shouldn't be.
*/
/* format: style3 */
pl1_error_print:
     procedure;

/* parameter */

dcl	count		fixed bin (31);
dcl	error_number	fixed bin (15);
dcl	source_line	fixed bin (15);
dcl	source_seg	fixed bin (11);
dcl	start		fixed bin (31);
dcl	1 statement_id	like source_id;
dcl	token_pt		ptr;

/* automatic */

dcl	brief		bit (1) aligned;
dcl	console		bit (1) aligned;
dcl	error_messages	ptr;
dcl	head		char (261) varying;
dcl	message_length	fixed bin (21);
dcl	message_start	fixed bin (21);
dcl	no_message	bit (1) aligned;
dcl	sev		fixed bin;
dcl	source_pt		ptr;

/* based */

dcl	1 message_segment	aligned based (error_messages),
	  2 index_block	(0:500),
	    3 message_pointer
			fixed bin (15),		/* Pointer to start of message */
	    3 severity	fixed bin (15),		/* Severity level for this message */
	    3 len		fixed bin (15),		/* Number of characters in this message */
	  2 message_block	char (248000) unaligned;	/* Text for all messages */

/* builtin */

dcl	(hbound, lbound, length, max, maxlength, min, null, search, string, substr, verify)
			builtin;

/* entry */

dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);

/* external static */

dcl	cg_static_$debug	bit (1) aligned external static;
dcl	pl1_severity_	fixed bin (35) external static;
dcl	pl1_stat_$abort_label
			label external static;
dcl	pl1_stat_$brief_error_mode
			bit (1) aligned external static;
dcl	pl1_stat_$err_stm	ptr external static;
dcl	pl1_stat_$error_memory
			bit (504) aligned external static;
dcl	pl1_stat_$error_messages
			ptr external static;
dcl	pl1_stat_$error_width
			fixed bin external static;
dcl	pl1_stat_$greatest_severity
			fixed bin external static;
dcl	pl1_stat_$last_severity
			fixed bin (15) external static;
dcl	1 pl1_stat_$last_statement_id
			like source_id external static;
dcl	pl1_stat_$severity_plateau
			fixed bin external static;

%include token;
%include token_types;
%include token_list;
%include source_list;
%include source_id;
%include language_utility;

write_out:
     entry (error_number, statement_id, token_pt, source_seg, start, count, source_line);

	m = source_seg;

	if m > -1
	then source_pt = source.seg_ptr;
	else source_pt = null;

	pl1_stat_$error_width = min (pl1_stat_$error_width, maxlength (head));
	console = "1"b;
	goto begin;

listing_segment:
     entry (error_number, statement_id, token_pt);

	m = 0;
	pl1_stat_$error_width = 120;
	console = "0"b;

begin:
	error_messages = pl1_stat_$error_messages;
	brief = pl1_stat_$brief_error_mode | error_messages = null;
	sev = 2;
	no_message = "1"b;

	if error_messages ^= null
	then if lbound (message_segment.index_block, 1) <= error_number
		& error_number <= hbound (message_segment.index_block, 1)
	     then do;
		     message_start = message_segment.index_block (error_number).message_pointer;
		     message_length = message_segment.index_block (error_number).len;
		     no_message = message_start = -1;

		     if ^no_message
		     then sev = message_segment.index_block (error_number).severity;
		end;

	pl1_stat_$last_severity = sev;
	pl1_severity_, pl1_stat_$greatest_severity = max (pl1_stat_$greatest_severity, sev);

	if console
	then do;
		if sev >= pl1_stat_$severity_plateau
		then call print_message;

		pl1_stat_$err_stm = null;

		if sev > 3
		then goto pl1_stat_$abort_label;
	     end;
	else call print_message;

	return;

print_message:
     procedure;

dcl	inserted		bit (1) aligned;
dcl	scan_index	fixed bin (21);
dcl	word		char (261) varying;

	if sev = 1
	then call ioa_$rsnnl ("^/WARNING ^d", head, 0, error_number);

	else if sev = 4
	then call ioa_$rsnnl ("^/FATAL ERROR ^d", head, 0, error_number);

	else call ioa_$rsnnl ("^/ERROR ^d, SEVERITY ^d", head, 0, error_number, sev);

	if string (statement_id) ^= ""b & m > -1
	then do;
		word = decode_source_id (statement_id, "1"b);

		if substr (word, 1, 1) = "S"
		then head = head || " IN ";
		else head = head || " ON ";

		head = head || word;
	     end;

	if cg_static_$debug & pl1_stat_$err_stm ^= null
	then do;
		call ioa_$rsnnl (" (^p)", word, 0, pl1_stat_$err_stm);
		head = head || word;
	     end;

	call print_line (head);

	if console & (brief | substr (pl1_stat_$error_memory, error_number, 1))
	then do;
		if token_pt ^= null
		then call ioa_ ("^a", quote_token (token_pt));

		call print_source_statement;

		return;
	     end;

	else if no_message
	then return;

	substr (pl1_stat_$error_memory, error_number, 1) = "1"b;

/* Error message construction. */

	inserted = token_pt = null;
	scan_index = 1;
	head = "";
	do while (next_string ());
	     if ^inserted & substr (word, 1, 1) = "$"
	     then do;
		     word = quote_token (token_pt) || substr (word, 2);
		     inserted = "1"b;
		end;

	     if length (head) = 0
	     then head = word;

	     else if length (head) + 1 + length (word) <= pl1_stat_$error_width
	     then head = head || " " || word;
	     else do;
		     call print_line (head);
		     head = word;
		end;
	end;

	call print_line (head);

	if console
	then call print_source_statement;

	return;

/* Extract the next word from the current message. */

next_string:
     procedure returns (bit (1) aligned);

dcl	word_length	fixed bin (21);

dcl	message		char (message_length) defined (message_segment.message_block) position (message_start);

	word_length = verify (substr (message, scan_index), " ") - 1;
	if word_length < 0
	then return ("0"b);

	scan_index = scan_index + word_length;

	word_length = search (substr (message, scan_index), " ") - 1;
	if word_length < 0
	then word_length = length (substr (message, scan_index));

	word = substr (message, scan_index, word_length);
	scan_index = scan_index + word_length;

	return ("1"b);
     end next_string;

/* Quote a token if necessary. */

quote_token:
     procedure (p) returns (char (259) varying);

dcl	p		ptr;

dcl	type		bit (9) aligned;

	type = p -> token.type;

	if type = identifier | type = isub | type = char_string | (type & is_delimiter) = is_delimiter
	then return ("""" || p -> token.string || """");

	else if type = bit_string
	then return ("""" || substr (p -> token.string, 1, max (length (p -> token.string) - 1, 0)) || """b");

	else return (p -> token.string);
     end quote_token;

print_source_statement:
     procedure;

dcl	1 segment		aligned based (source_pt),
	  2 spacer	char (start) unaligned,
	  2 line		char (count) unaligned;

	if brief | source_pt = null | string (statement_id) = ""b
	     | string (statement_id) = string (pl1_stat_$last_statement_id) | count <= 0 | start < 0
	then return;

	string (pl1_stat_$last_statement_id) = string (statement_id);
	call ioa_ ("SOURCE:^-^a", segment.line);
     end print_source_statement;

print_line:
     procedure (line);

dcl	line		char (*) varying;

	if console
	then call ioa_ ("^a", line);
	else call pl1_print$varying_nl (line);
     end print_line;

     end print_message;

     end pl1_error_print;




		    pl1_nodes_template_.cds         10/04/83  1030.7rew 10/04/83  1025.4       72504



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


pl1_nodes_template_:
     procedure;

/* Written April 1977 by R.Schoeman to use cds templates for node templates.	*/
/* Modified: 27 March 1980 by PCK to implement by name assignment */


dcl 1 my_cds_args aligned like cds_args;

dcl  create_data_segment_ entry (ptr, fixed bin (35));

dcl (addr, binary, length, null, rel, size, unspec) builtin;

dcl  p ptr;
dcl  code fixed bin (35) init (0);

dcl 1 auto_pl1_nodes_template_ aligned,
    2 array_template like array aligned,
    2 block_template like block aligned,
    2 bound_template like bound aligned,
    2 by_name_agg_template like by_name_agg aligned,
    2 default_template like default aligned,
    2 label_template like label aligned,
    2 reference_template like reference aligned,
    2 symbol_template like symbol aligned;


dcl	com_err_ entry options(variable);


%include cds_args;
%include nodes;
%include array;
%include block;
%include by_name_agg;
%include default;
%include label;
%include reference;
%include symbol;


	unspec (my_cds_args) = "0"b;

	unspec (auto_pl1_nodes_template_) = "0"b;



	my_cds_args.have_text = "1"b;
	my_cds_args.num_exclude_names = 0;
	my_cds_args.exclude_array_ptr = null;

	my_cds_args.seg_name = "pl1_nodes_template_";
	my_cds_args.sections(1).struct_name = "auto_pl1_nodes_template_";
	my_cds_args.sections (1).len = size (auto_pl1_nodes_template_) ;
	my_cds_args.sections (1).p = addr (auto_pl1_nodes_template_);




	array_template.node_type = array_node;
	array_template.interleaved = "0"b;

	array_template.number_of_dimensions,
	     array_template.offset_units,
	     array_template.own_number_of_dimensions,
	     array_template.size_units,
	     array_template.element_boundary,
	     array_template.c_element_size,
	     array_template.c_element_size_bits,
	     array_template.c_virtual_origin = 0;

	array_template.element_size,
	     array_template.element_size_bits,
	     array_template.virtual_origin,
	     array_template.bounds,
	     array_template.symtab_virtual_origin,
	     array_template.symtab_element_size,
	     array_template.element_descriptor = null;

	/* BLOCK NODE.  The following fields are initialized in create_block: */
	/*		block.node_type, block.number, block.owner, block.father, */
	/*		block.source_id, block.no_stack */

	block_template.node_type = block_node;
	block_template.brother,
	     block_template.son,
	     block_template.declaration,
	     block_template.end_declaration,
	     block_template.default,
	     block_template.end_default,
	     block_template.context,
	     block_template.prologue,
	     block_template.end_prologue,
	     block_template.return_values,
	     block_template.return_count,
	     block_template.main,
	     block_template.end_main,
	     block_template.free_temps (1),
	     block_template.free_temps (2),
	     block_template.free_temps (3),
	     block_template.entry_list,
	     block_template.temp_list,
	     block_template.o_and_s,
	     block_template.plio_ps,
	     block_template.plio_fa,
	     block_template.plio_ffsb,
	     block_template.plio_ssl,
	     block_template.plio_fab2 = null;

	block_template.level,
	     block_template.symbol_block,
	     block_template.entry_info,
	     block_template.last_auto_loc,
	     block_template.number_of_entries,
	     block_template.enter.start,
	     block_template.enter.end,
	     block_template.leave.start,
	     block_template.leave.end = 0;

	block_template.prefix = "111110000000"b;	/* default conditions */
	string(block_template.why_nonquick) = "0"b;

	block_template.like_attribute,
	     block_template.get_data,
	     block_template.flush_at_call,
	     block_template.processed,
	     block_template.text_displayed = "0"b;

	block_template.prologue_flag = "0"b;
	block_template.pad = "0"b;

	/* BOUND NODE. */

	bound_template.node_type = bound_node;
	bound_template.c_lower,
	     bound_template.c_upper,
	     bound_template.c_multiplier,
	     bound_template.c_desc_multiplier = 0;

	bound_template.next,
	     bound_template.lower,
	     bound_template.upper,
	     bound_template.desc_multiplier,
	     bound_template.symtab_lower,
	     bound_template.symtab_upper,
	     bound_template.symtab_multiplier,
	     bound_template.multiplier = null;

	by_name_agg_template.node_type = by_name_agg_node;
	by_name_agg_template.pad = "0"b;
	by_name_agg_template.ok_to_free = "1"b;
	by_name_agg_template.token,
	     by_name_agg_template.father,
	     by_name_agg_template.left_brother,
	     by_name_agg_template.right_brother,
	     by_name_agg_template.son,
	     by_name_agg_template.next = null;

	default_template.node_type = default_node;
	default_template.next,
	     default_template.predicate,
	     default_template.symbol = null;
	default_template.system,
	     default_template.error,
	     default_template.no_defaults = "0"b;


	label_template.node_type = label_node;
	label_template.next = null;

	label_template.used_as_format,
	     label_template.used_in_goto,
	     label_template.array,
	     label_template.allocated,
	     label_template.symbol_table = "0"b;

	label_template.cross_reference,
	     label_template.statement = null;

	label_template.location,
	     label_template.low_bound,
	     label_template.high_bound = 0;


	reference_template.node_type = reference_node;

	reference_template.subscript_list,
	     reference_template.qualifier,

/* The following reference must be FULLY qualified to avoid an
   apparent ambiguity with reference_template.address.offset.	*/

	     auto_pl1_nodes_template_.reference_template.offset,
	     reference_template.length = null;

	reference_template.ref_count,
	     reference_template.units,
	     reference_template.data_type,
	     reference_template.c_offset,
	     reference_template.c_length = 0;

	reference_template.store_ins = "0"b;

	reference_template.put_data_sw,
	     reference_template.relocation,
	     reference_template.array_ref,
	     reference_template.varying_ref,
	     reference_template.processed,

	     string (reference_template.bits),
	     string (reference_template.more_bits),
	     string (reference_template.info) = "0"b;
	string (reference_template.address) = "0000000000000000000000000001"b; /* no_address */

	reference_template.shared = "1"b;


	symbol_template.node_type = symbol_node;	/* identify this node		*/

	symbol_template.runtime,
	     symbol_template.runtime_offset = (18)"0"b;
	string (symbol_template.source_id) = (27)"0"b;

	symbol_template.cross_references,
	     symbol_template.initial,
	     symbol_template.array,
	     symbol_template.descriptor,
	     symbol_template.equivalence,
	     symbol_template.general,
	     symbol_template.father,
	     symbol_template.brother,
	     symbol_template.son,
	     symbol_template.next,
	     symbol_template.word_size,
	     symbol_template.bit_size,
	     symbol_template.symtab_size,
	     symbol_template.dcl_size = null;

	symbol_template.pix.pic_scale,
	     symbol_template.pix.pic_size,
	     symbol_template.level,
	     symbol_template.location,
	     symbol_template.scale,
	     symbol_template.boundary,
	     symbol_template.size_units,
	     symbol_template.c_word_size,
	     symbol_template.c_bit_size,
	     symbol_template.c_dcl_size = 0;

	symbol_template.reserved,
	     symbol_template.pix.pic_fixed,
	     symbol_template.pix.pic_float,
	     symbol_template.pix.pic_char,
	     symbol_template.allocated = "0"b;

	string (symbol_template.attributes) = "0"b;



	call create_data_segment_ (addr (my_cds_args), code);

	if code ^= 0
	then call com_err_(code, "pl1_nodes_template_");

     end;




		    pl1_print.pl1                   10/06/92  0045.8r w 10/06/92  0040.6       61506



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




/****^  HISTORY COMMENTS:
  1) change(92-09-10,Zimmerman), approve(92-09-10,MCR8257), audit(92-09-18,Vu),
     install(92-10-06,MR12.5-1023):
     Fix segment overflow in source section of listing.
                                                   END HISTORY COMMENTS */


/*	print routines for use by the PL/1 compiler in writing into the listing */
/*	segment.  There are four entries for the combinations of varying and non-*/
/*	varying character string parameters and for with and without new-line	*/
/*	characters appended to the string before transmission.		*/

/*	Written by:	J.D. Mills	*/
/*	On		22 January 1969				*/
/*	Modified by:	B. L. Wolman on 16 May 1969 to use cv_string */
/*	Modified by:	B. L. Wolman on 21 May 1969 to accept ptr to string */
/*	Rewritten in pl1 replacing cv_string with substr on 28 JULY 1969 by the author. */
/*	Modified on:	20 August 1970 by P. Green for Version II */
/*	Modified on:	17 January 1974 by R. A. Barnes for 256K segments */
/*	Modified 770502 by PG to rewrite $for_lex entry to work with EIS lex */

pl1_print$varying:	proc(var_string);

/* parameters */

dcl	var_string	char(*) varying aligned;

/* automatic */

dcl	l_suff	fixed bin,
	arg_length	fixed bin(21);

/* based */

declare	string char (261120) aligned based (pl1_stat_$list_ptr);

/* builtins */

declare (	length, substr) builtin;

/* conditions */

declare	listing_overflow condition;

/* external static */

dcl (	pl1_stat_$list_ptr		ptr,
	pl1_stat_$max_list_size	fixed bin(21),
	pl1_stat_$char_pos		fixed bin(21)) static external;

/* internal static */

declare	NL	character(1) aligned static internal initial("
");

/* program */

/*	Entry to write a varying character string sans new-line character into the listing segment.	*/

	l_suff=0;
	go to l1;

/*	Entry to write a varying character string avec new-line character into the listing segment.	*/

pl1_print$varying_nl:	entry(var_string);

	l_suff=1;

l1:	arg_length=length(var_string);

	if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
	then signal condition(listing_overflow);

	substr(string,pl1_stat_$char_pos,arg_length)=var_string;
	goto done;

/*	Entry to write a non-varying character string sans new-line character into the listing segment.	*/

pl1_print$non_varying:	entry(nv_string,size);

dcl	nv_string char(*) aligned,
	size fixed bin(35);

	l_suff=0;
	go to l2;

/*	Entry to write non-varying character string avec new-line character into the listing segment.	*/

pl1_print$non_varying_nl:	entry(nv_string,size);

	l_suff=1;

l2:	if size > 0
	then arg_length=size;
	else arg_length=length(nv_string);

	if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
	then signal condition(listing_overflow);
	substr(string,pl1_stat_$char_pos,arg_length)=nv_string;

done:	pl1_stat_$char_pos=pl1_stat_$char_pos + arg_length;

	if l_suff ^= 0
	then do;
	     substr(string,pl1_stat_$char_pos,1) = NL;
	     pl1_stat_$char_pos = pl1_stat_$char_pos+1;
	     end;

	return;

/*	Entry to write string given by ptr into listing without nl */

pl1_print$string_ptr: entry(pt,size);

dcl	pt ptr;	/* points at string */
dcl	based_string char(size) aligned based(pt);

	l_suff = 0;
	goto l3;

/*	Entry to write string given by ptr into listing with nl */

pl1_print$string_ptr_nl: entry(pt,size);

	l_suff = 1;

l3:	arg_length = size;

	if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
	then signal condition(listing_overflow);

	substr(string,pl1_stat_$char_pos,arg_length)=based_string;

	goto done;

pl1_print$for_lex:
	entry (bv_source_ptr, bv_line_number, bv_line_start, bv_line_length, bv_suppress_line_numbers,
	     bv_line_begins_in_comment);

/* parameters */

declare (	bv_source_ptr ptr,
	bv_line_number fixed bin (14),
	bv_line_start fixed bin (21),
	bv_line_length fixed bin (21),
	bv_suppress_line_numbers bit (1) aligned,
	bv_line_begins_in_comment bit (1) aligned
	) parameter;

/* automatic */

declare	line_number_string picture "zzzzzzzz9";

/* external static */

declare	pl1_stat_$source_seg fixed bin (8) external static;

/* internal static */

declare SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK fixed bin internal static options (constant) init (10);
	
/* program */

/* A source program cannot be more than a single segment in length, but the
   LISTING (including headers, incl. files, etc.) of the source can exceed
   a single segment. Thus this check. We could do it in two parts (one for
   the line number field, if we're not supressing them) and the other for
   the actual line... but it's more efficient to only do the check once.
   If we're going msf on the listing (which is guaranteed if we approach 
   msf in this phase) doing it a few characters early won't hurt.  phx21284 */

	if pl1_stat_$char_pos + SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK
	     + bv_line_length >= pl1_stat_$max_list_size
	     then signal condition(listing_overflow);
	

	if ^bv_suppress_line_numbers
	then do;
		line_number_string = bv_line_number;
		substr (string, pl1_stat_$char_pos,
		     SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK) = line_number_string;  /* move in digits + 1 blank */

		if pl1_stat_$source_seg > 0
		then do;
			line_number_string = pl1_stat_$source_seg;
			substr (string, pl1_stat_$char_pos, 3) = substr (line_number_string, 7, 3);
		     end;

		pl1_stat_$char_pos = pl1_stat_$char_pos + SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK;

		if bv_line_begins_in_comment
		then substr (string, pl1_stat_$char_pos - 1, 1) = "*";
	     end;

	substr (string, pl1_stat_$char_pos, bv_line_length) = substr (bv_source_ptr -> based_string,
	     bv_line_start, bv_line_length);
	pl1_stat_$char_pos = pl1_stat_$char_pos + bv_line_length;
	return;

/*	Entry to write unaligned string avec new-line character into the listing segment */

pl1_print$unaligned_nl:	entry(unal_string,size);

dcl	unal_string char(*) unaligned;

	if size > 0
	then arg_length = size;
	else arg_length = length(unal_string);

	if arg_length + pl1_stat_$char_pos >= pl1_stat_$max_list_size
	then signal condition(listing_overflow);

	substr(string,pl1_stat_$char_pos,arg_length) = unal_string;

	l_suff = 1;
	goto done;
	end;




		    pl1_signal_catcher.pl1          10/03/83  1728.7rew 10/03/83  1007.7       33552



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

/* Modified 7/01/81 by EBush to add recognition of "null_pointer" condition. */

pl1_signal_catcher: proc (mc_ptr, name, co_ptr, info_ptr, continue);

	dcl     (mc_ptr, co_ptr, info_ptr) ptr,
	        name		 char (*) unaligned,
	        continue		 bit (1) aligned;

	dcl     (cg_static_$cur_statement, pl1_stat_$cur_statement) ptr ext,
	        pl1_stat_$phase	 fixed bin ext,
	        cg_static_$debug	 bit (1) aligned ext,
	        (p, q, source_pt)	 ptr,
	        errno		 fixed bin,
	        n			 fixed bin,
	        cond		 char (32),
	        (error, error$omit_text) entry (fixed bin, ptr, ptr),
	        parse_error		 entry (fixed bin, ptr),
	        ioa_		 entry options (variable);

	dcl     1 source_structure	 based (source_pt),
		2 spacer		 char (p -> statement.source.start) unal,
		2 output		 char (p -> statement.source.length) unal;

	dcl     code		 fixed bin (35);	/* needed by iox_$put_chars but never examined */
	dcl     program_interrupt	 condition;

	declare any_other		 condition;

	dcl     (addr, fixed, length, null, ptr) builtin;

%include pl1_tree_areas;
%include statement;
%include source_list;
%include token;
%include nodes;

	on any_other system;			/* In case of recursive faults ! */
	if pl1_stat_$phase <= 4
	then do;
		errno = pl1_stat_$phase + 333;
		p = pl1_stat_$cur_statement;
	     end;

	else do;
		errno = 310;
		p = cg_static_$cur_statement;
	     end;
	if p = null
	then if pl1_stat_$phase ^= 1 | cg_static_$debug
	     then do;

/* refuse to handle the condition */

refuse:		     continue = "1"b;
		     return;
		end;

	     else ;

	else if p -> node.type ^= statement_node
	then if p -> node.type ^= symbol_node | cg_static_$debug
	     then go to refuse;

	cond = name;
	if cond = "null_pointer" then go to ok;
	if cond = "out_of_bounds" then goto ok;
	if cond = "illegal_opcode" then goto ok;
	if cond = "no_read_permission" then go to ok;
	if cond = "no_write_permission" then go to ok;
	if cond = "no_execute_permission" then go to ok;
	if cond = "null_pointer" then goto ok;
	if cond = "storage"
	then do;
		if pl1_stat_$phase = 2		/* semantics */
		then errno = 365;
		go to ok;
	     end;
	if cond = "size" then go to ok;
	if cond = "fixedoverflow" then goto ok;
	if cond = "illegal_modifier" then goto ok;
	if cond = "not_in_call_bracket" then go to ok;
	if cond = "not_in_execute_bracket" then go to ok;
	if cond = "not_in_read_bracket" then go to ok;
	if cond ^= "not_in_write_bracket" then go to refuse;

/* condition is one we recognize */


ok:	if ^cg_static_$debug
	then do;
		n = length (name);
		allocate token in (tree_area) set (q);
		q -> node.type = token_node;
		q -> token.string = cond;

		if p ^= null
		then if p -> node.type = statement_node
		     then call error (errno, p, q);
		     else call error$omit_text (errno, p, q);
		else call parse_error (errno, q);

/* call to error should abort compilation and never return */

	     end;
	goto refuse;


     end;




		    pl1_stat_.alm                   10/03/83  1728.7rew 10/03/83  1007.7       74538



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

"	pl1_stat_, fortran_stat_
"	External static storage segment for PL/1 and Fortran Version II
"	B. L. Wolman, 10 January 1971
"
"	Modified: 24 May 1979 by PCK to implement options(packed_decimal)
"	Modified: 26 May 1979 by D. Spector for -single_symbol_list, -ssl
"	Modified: 26 Dec 1979 by PCK to implement by name assignment
"	Modified: 27 October 1980 to increase length of pl1_stat_$options

	name	pl1_stat_
	use	textc
	use	linkc
	join	/link/linkc
	join	/text/textc


"	FIXED SCALARS.

	use	linkc

	segdef	error_width
error_width:
	dec	70			" width of console line

	segdef	compiler_created_index
	bss	compiler_created_index,1	" used by create_identifier

	segdef	index
	bss	index,1

	segdef	st_start
	bss	st_start,1		" start of statement in source seg

	segdef	st_length
	bss	st_length,1		" length of statement (in chars)

	segdef	line_count		" number of lines in source program.
	bss	line_count,1

	segdef	tree_vec_index
tree_vec_index:
	dec	-1			" index in extra free seg list

"	BIT-STRING SCALAR.

	segdef	error_memory
	bss	error_memory,14		" 500 bits to remember if text has been printed.

"	FIXED SCALARS.

	segdef	char_pos			" character offset into listing segment
	bss	char_pos,1

	segdef	convert_len		" bit count of converted segment
	bss	convert_len,1

	segdef	condition_index
	bss	condition_index,1

	segdef	last_source		" index of last source file in source_list.
last_source:
          dec       -1

	segdef	cur_level
	bss	cur_level,1

	segdef	greatest_severity
	bss	greatest_severity,1

	segdef	last_severity
last_severity:
	dec	0

	segdef	last_statement_id
last_statement_id:
	dec	0

	segdef	max_list_size		" maximum size in chars of listing seg
	bss	max_list_size,1

	segdef	phase
	bss	phase,1

	segdef	profile_length
	bss	profile_length,1

	segdef	severity_plateau
	bss	severity_plateau,1

	segdef	source_seg		" subscript of current source segment in source_list.
	bss	source_seg,1

	segdef	statement_id
	bss	statement_id,1

	segdef	stop_id
	bss	stop_id,1

	segdef	version			version of compiler being used
version:
	dec	0

	segdef	expl_continuation_count
	bss	expl_continuation_count,1

"	ONE-WORD BIT STRING SCALARS.

	segdef	level_0_colon
	bss	level_0_colon,1

	segdef	level_0_equal
	bss	level_0_equal,1

	segdef	brief_error_mode		" command option
	bss	brief_error_mode,1

	segdef	debug_semant		" command option
	bss	debug_semant,1

	segdef	error_flag
	bss	error_flag,1

	segdef	generate_symtab
	bss	generate_symtab,1

	segdef	had_data_io
	bss	had_data_io,1

	segdef	hollerith_mode
	bss	hollerith_mode,1

	segdef	eis_mode
eis_mode:
	oct	400000000000

	segdef	apostrophe_mode
	bss	apostrophe_mode,1

	segdef	card_input
	bss	card_input,1

	segdef	convert_switch
	bss	convert_switch,1

	segdef	check_ansi
	bss	check_ansi,1

	segdef	listing_on		" command option
	bss	listing_on,1

	segdef	optimize			" command option
	bss	optimize,1

	segdef	multi_type
	bss	multi_type,1

	segdef	no_quick_blocks
	bss	no_quick_blocks,1

	segdef	check_bounds		" fortran command option
	bss	check_bounds,1

	segdef	use_old_area		" to support the new area operator
	bss	use_old_area,1

	segdef	compiler_invoked
compiler_invoked:
	dec	0

	segdef	stmnt_unreachable		" tells if stmnt is unreachable
stmnt_unreachable:
	dec	0

	segdef	new_fortran_option		" fortran command option
new_fortran_option:
	dec	0

	segdef	print_cp_dcl		" command option
	bss	print_cp_dcl,1

	segdef	profile			" profile option
	bss	profile,1

	segdef	single_symbol_list		" command option
	bss	single_symbol_list,1

	segdef	table			" command option
	bss	table,1

	segdef	unaligned_dec		" a variable with the unaligned and decimal attributes exists
	bss	unaligned_dec,1
	segdef	options_packed_dec		" options(packed_decimal) specified on the main procedure
	bss	options_packed_dec,1

"	POINTER SCALARS.

	even
	segdef	constant_list
	bss	constant_list,2

	segdef	defined_list
	bss	defined_list,2

	segdef	dummy_block
	bss	dummy_block,2

	segdef	ok_list
	bss	ok_list,2

	segdef	error_messages		" ptr to error messages segment
	bss	error_messages,2

	segdef	temporary_list
	bss	temporary_list,2

	segdef	cur_block
	bss	cur_block,2

	segdef	cur_statement
	bss	cur_statement,2

	segdef	equivalence_base
	bss	equivalence_base,2

	segdef	err_stm
err_stm:	its	-1,1,n

	segdef	source_list_ptr		" ptr to source_list
	bss	source_list_ptr,2

	segdef	token_list_ptr		" ptr to token_list
	bss	token_list_ptr,2

	segdef	list_ptr			" ptr to listing segment
	bss	list_ptr,2

	segdef	convert_ptr		" ptr to converted segment
	bss	convert_ptr,2

	segdef	list3_node
	bss	list3_node,2

	segdef	list5_node
	bss	list5_node,2

	segdef	quick_pt
	bss	quick_pt,2

	segdef	root			" ptr to root block
	bss	root,2

	segdef	validate_proc
	bss	validate_proc,2

	segdef	one			" ptr to token "1", dec_integer
	bss	one,2

	segdef	LHS
	bss	LHS,2

	segdef	LHS_ref

	bss	LHS_ref,2

	segdef	format_list
	bss	format_list,2

	segdef	hash_table_ptr		" ptr to create_token's hash table.
	bss	hash_table_ptr,2

	segdef	by_name_free_list		" ptr to free list used by
	bss	by_name_free_list,2		" expand_by_name

	segdef	by_name_parts_tree		" ptr to tree of by_name_agg
	bss	by_name_parts_tree,2	" nodes used by expand_primitive

	segdef	by_name_parts_free_list	" ptr to free list of by_name_agg
	bss	by_name_parts_free_list,2	" nodes 

	segdef	by_name_ref_list		" ptr to list of list nodes
	bss	by_name_ref_list,2		" (by_name_ref nodes) built by
					" expand_by_name

"	LABEL SCALARS.

	segdef	unwind			" used by parse
	bss	unwind,4

	segdef	abort_label		" used by command
	bss	abort_label,4

"	ENTRY SCALARS

	segdef	util_abort
	bss	util_abort,4

	segdef	util_error
	bss	util_error,4

"	AGGREGATES, arranged in order of increasing size.


	segdef	user_id		"dcl pl1_stat_$user_id char(32) ext aligned;
	bss	user_id,8

	segdef	seg_name		"dcl pl1_stat_$seg_name char(32) varying ext static;
seg_name: dec	0
	bss	,8

	segdef	options		"dcl pl1_stat_$options char(400) varying ext static;
options:	dec	0
	bss	,100

"	POINTER VECTORS

	even
	segdef	tree_area_ptr
tree_area_ptr:
	its	-1,1,n

	segdef	xeq_tree_area_ptr
xeq_tree_area_ptr:
	its	-1,1,n

	segdef	free_ptr		" dcl pl1_stat_$free_ptr(18) ext ptr;
	bss	free_ptr,2*18

	segdef	locator		"dcl pl1_stat_$locator(128) ptr ext;
	bss	locator,2*128

	segdef	compiler_name	"dcl pl1_stat_$compiler_name char(8) var
compiler_name:
	dec	3
	aci	"pl1     "

	segdef	modetable		"dcl fortran_stat_$modetable(0:52) ext static
	bss	modetable,53

	segdef	pathname		"dcl pl1_stat_$pathname char(168) var ext;
	bss	pathname,43


"	NODE USAGE INFORMATION.

	use	textc
	segdef	max_node_type
max_node_type:
	dec	20

	segdef	node_name		"dcl pl1_stat_$node_name(1) char(12) ext
node_name:
	aci	"block       "
	aci	"statement   "
	aci	"operator    "
	aci	"reference   "
	aci	"token       "
	aci	"symbol      "
	aci	"context     "
	aci	"array       "
	aci	"bound       "
	aci	"format      "
	aci	"list        "
	aci	"default     "
	aci	"state       "
	aci	"source      "
	aci	"label       "
	aci	"xref        "
	aci	"sf_par      "
	aci	"temporary   "
	aci	"label_array_"
	aci	"by_name_agg "
	segdef	node_size		"dcl pl1_stat_$node_size(1) fixed bin ext
node_size:
	oct	54  " 53+1	block (53+1 means 53 words for the node +1 for eveness)
	oct	14		statement
	oct	4		operator (average of 3, formula = 1 + n)
	oct	14		reference
	oct	6		token (average of 8 chars, formula = 4 + n/2)
	oct	34		symbol
	oct	4   " 3+1		context
	oct	14		array
	oct	16  " 15+1	bound
	oct	4		format value
	oct	4		list (average of 3, formula = 1 + n)
	oct	14  " 13+1	default
	oct	422		machine state
	oct	20		source (average of 36 chars, formula = 7 + n/4)
	oct	12		label
	oct	2		cross reference
	oct	4		sf_par
	oct	10		temporary
	oct	4		label_array_element
	oct	7		by_name_agg
	use	linkc
	segdef	node_uses		"dcl pl1_stat_$node_uses(1) fixed bin ext
	bss	node_uses,20

	end




		    pl1_symbol_print.pl1            05/31/89  1426.9rew 05/31/89  1256.2      369873



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-04-15,RWaters), approve(87-04-15,MCR7639), audit(87-04-28,Huen),
     install(87-05-21,MR12.1-1033):
     Fix bug #2092
  2) change(87-06-25,Huen), approve(87-06-25,MCR7696), audit(87-06-25,RWaters),
     install(87-12-01,MR12.2-1005):
     Fix bug2149
  3) change(88-01-29,RWaters), approve(88-01-29,MCR7724), audit(88-02-05,Huen),
     install(88-02-16,MR12.2-1024):
     Treat explicit_packed as packed.
  4) change(89-04-04,Huen), approve(89-04-04,MCR8092), audit(89-05-24,RWaters),
     install(89-05-31,MR12.3-1050):
     Fix bug2195 - Emit the "NAME DECLARED BY THE DECLARE STATEMENT AND NEVER
     REFERENCED" section when all of the declared variables were not
     referenced. Fix bug2194 - List only referenced external variables under
     the "EXTERNAL VARIABLES ARE USED" section.
                                                   END HISTORY COMMENTS */

/* Modified on:	June 23 1975 by EEW for new object map
   Modified 770404 by PG to explain why blocks are not quick.
   Modified 5 May 1977 by SHW for new pl1_operator_names_
   Modified 14 July 1978 by PCK for unsigned binary
   Modified Dec 1978 by David Spector:
	1. Fixed begin block/on unit 'on line xxx' bug
	2. New filling of last column out to 132 columns and indenting continuation lines
	3. Eliminated "internal" from builtin and generic functions
	4. Allowed more space on line for long identifiers
	5. Changed "uses condition statements" nonquick reason to "enables or reverts conditions"
	6. Containing-block qualification for duplicate identifiers
	7. Containing-structure qualification for duplicate identifiers
	8. Cross-reference lists ordered within each source input file
	9. Increased maximum number of symbols listed from 2500 to 3072
	10. Marked cross-references as 'set' or not
	11. Placed "unsigned" attribute after "packed"
	12. Fixed stringrange bug for long procedure names
	13. Storage tables for internal static and automatic variables
   Modified 18 Jan 1979 by RAB to resume printing "set" if symbol.set is on
   Modified 26 May 1979 by D. Spector for -single_symbol_list (-ssl)
   Modified 26 May 1979 by D. Spector to not list undeclared level 2+ names
   Modified 13 Nov 1979 by Peter Krupp to fix bug 1859
   Modified 25 March 1980 by M. N. Davidoff to increase maximum number of symbols listed from 3072 to 4096.
  Modified 830415 BIM to deal with tokens as labels rather than ref nodes.
  Modified 860811 RW to not call "print" when "-ssl" flag is on when there are no symbols
  Modified 870625 SH to print the negative scale factors correctly in the listing.
  Modified 882801 RW to believe explicit_packed is also packed.
  Modified 891703 SH to emit the "NAMES DECLARED BY THE DECLARE STATEMENT AND
     NEVER REFERENCED" section when all of the declared variables were not
     referenced. (pl1_2195)
  Modified 891703 SH to list only referenced external variables under the 
     "EXTERNAL VARIABLES ARE USED" section. (pl1_2194)
*/
/* format: style3 */
pl1_symbol_print:
     proc (root, do_cp_dcl, no_object);

dcl	root		ptr,
	(do_cp_dcl, no_object)
			bit (1) aligned;

dcl	digits_pic	picture "-------9";		/* fixed decimal (8) */
dcl	(i, j, k, m, n, size, int_static_list_length, auto_list_length, unused, unused_members)
			fixed bin (17),
	(p, q)		ptr,
	line		aligned char (132),
	(
	dt1		(4) init (by_declare, by_explicit_context, by_context, by_compiler),
	dt2		(4) init (by_declare, by_explicit_context, by_implication, by_compiler)
	)		bit (3) aligned,
	s		char (1) varying,
	declare_type	(4) char (24) varying int static
			init ("DECLARE STATEMENT.", "EXPLICIT CONTEXT.", "CONTEXT OR IMPLICATION.", "COMPILER.");

dcl	pl1_stat_$single_symbol_list
			bit (1) aligned external static;
dcl	cg_static_$used_operator
			bit (900) ext,
	cg_static_$bit_count
			fixed bin ext,
	(
	cg_static_$ext_proc_list,
	cg_static_$ext_var_list,
	cg_static_$root,
	cg_static_$objmap_pt
	)		ptr ext,
	pl1_operator_names_$pl1_operator_names_
			ext;

dcl	1 name_pair	aligned based,
	  2 rel_ptr	unaligned bit (18),
	  2 size		unaligned bit (18);

dcl	based_string	aligned char (size) based;

dcl	(addr, bin, divide, fixed, hbound, length, ltrim, index, mod)
			builtin;
dcl	(null, ptr, string, substr)
			builtin;

dcl	symbol_list	(4096) ptr;
dcl	1 int_static_list_st
			aligned,
	  2 int_static_list (1024) ptr unaligned;	/* For efficiency */
dcl	1 auto_list_st	aligned,
	  2 auto_list	(1024) ptr unaligned;	/* For efficiency */

dcl	sym_sort_alphabetic entry (ptr, fixed bin);
dcl	binoct		entry (bit (18) aligned) returns (char (12) aligned),
	ioa_$rsnpnnl	entry options (variable),
	cg_error		entry (fixed bin, fixed bin),
	pl1_print$varying_nl
			entry (char (*) varying),
	pl1_print$non_varying_nl
			entry (char (*) aligned, fixed bin);

dcl	FF		char (1) static aligned init ("");
%include nodes;
%include declare_type;
%include operator_names;
%include list;
%include block;
%include block_types;
%include symbol;
%include reference;
%include statement;
%include token;
%include object_map;

/* program */

	call pl1_print$varying_nl (FF || "	NAMES DECLARED IN THIS COMPILATION.");

/* NOTE: the strings used in the following calls contain tabs */

	call pl1_print$varying_nl ("
IDENTIFIER	     OFFSET    LOC STORAGE CLASS   DATA TYPE		ATTRIBUTES AND REFERENCES");
	call pl1_print$varying_nl (
	     "								(* indicates a set context)");

	int_static_list_length = 0;			/* Initialize storage table saved lists */
	auto_list_length = 0;

/* Create lists of symbols and print them */

	if pl1_stat_$single_symbol_list
	then do;
		n, unused, unused_members = 0;
		call select_all_symbols (root);
		if n > 1
		then do;
			call sym_sort_alphabetic (addr (symbol_list), n);
			call pl1_print$varying_nl ("");
						/* Print newline */
			call print (0);		/* Print all symbols */
		     end;
		else call pl1_print$varying_nl ("THERE WERE NO NAMES DECLARED IN THIS COMPILATION.");
	     end;
	else do i = 1 to 4 while (i ^= 4 | do_cp_dcl);	/* Print up to 4 separate lists */

/* Get all declarations of desired types */

		n, unused, unused_members = 0;

		call sort_on_dcl_type (root, (dt1 (i)), (dt2 (i)));

		if n > hbound (symbol_list, 1)
		then do;
full:
			call cg_error (327, hbound (symbol_list, 1));
			n = hbound (symbol_list, 1);
		     end;

		if n > 1
		then call sym_sort_alphabetic (addr (symbol_list), n);

		if i ^= 1
		then do;
			size = n;
			k = 0;			/* All symbol indicator */
		     end;
		else do;
			size = n - (unused + unused_members);
			k = -1;			/* Referenced symbol indicator */
		     end;

		if size = 0
		then call pl1_print$varying_nl ("
THERE WERE NO NAMES DECLARED BY " || declare_type (i));
		else do;
			if size = 1
			then s = "";
			else s = "S";

			call pl1_print$varying_nl ("
NAME" || s || " DECLARED BY " || declare_type (i));

			call print (k);		/* Print symbols according to indicator */
		     end;

		if i = 1 & unused > 0
		then do;
			if unused = 1
			then s = "";
			else s = "S";

			call pl1_print$varying_nl ("
NAME" || s || " DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED.");

			call print (1);		/* Print non_referenced symbols */
		     end;

	     end;

/* Print storage requirements */

	if no_object
	then return;

	call pl1_print$varying_nl ("
STORAGE REQUIREMENTS FOR THIS PROGRAM.");

	q = cg_static_$objmap_pt;

	call ioa_$rsnpnnl ("^/^-Object^-Text^-Link^-Symbol^-Defs^-Static^/Start^10x0^7x0^10o^12o^8o^12o", line, k,
	     fixed (q -> object_map.linkage_offset, 18), fixed (q -> object_map.symbol_offset, 18),
	     fixed (q -> object_map.definition_offset, 18), fixed (q -> object_map.static_offset, 18));

	call pl1_print$non_varying_nl (line, k);

	call ioa_$rsnpnnl ("Length^10o^8o^10o^12o^8o^12o", line, k, divide (cg_static_$bit_count, 36, 17, 0),
	     fixed (q -> object_map.text_length, 18), fixed (q -> object_map.linkage_length, 18),
	     fixed (q -> object_map.symbol_length, 18), fixed (q -> object_map.definition_length, 18),
	     fixed (q -> object_map.static_length, 18));

	call pl1_print$non_varying_nl (line, k);

	call pl1_print$varying_nl ("");

	call pl1_print$varying_nl (
	     "BLOCK NAME	         STACK SIZE     TYPE		WHY NONQUICK/WHO SHARES STACK FRAME");

	p = cg_static_$root -> block.son;

	do while (p ^= null);
	     call prt_block (p);

	     if p -> block.son ^= null		/* This code walks the tree of blocks by */
	     then p = p -> block.son;			/* recursing down the son chain until it */
	     else if p -> block.brother ^= null		/* runs out, then it switches to the brother */
	     then p = p -> block.brother;		/* chain (of the last son) until it runs out, then it */
	     else do;				/* picks up the brother chains it missed the first time */
		     p = p -> block.father;		/* down the tree. */
		     do while (p -> block.brother = null & cg_static_$root ^= p);
			p = p -> block.father;
		     end;
		     p = p -> block.brother;
		end;
	end;

	call print_int_static_table (int_static_list_st, int_static_list_length);

	call print_auto_table (auto_list_st, auto_list_length);

	if cg_static_$used_operator
	then ;
	else goto chk_ext;

	call pl1_print$varying_nl ("
THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM.");

	line = "";
	i, k = 1;
	j = 0;
	op_names_pt = addr (pl1_operator_names_$pl1_operator_names_);

look:
	n = index (substr (cg_static_$used_operator, k), "1"b);

	if n ^= 0
	then do;

		k = k + n - 1;
		if k >= operator_names.first & k <= operator_names.last
		then do;
			p = addr (operator_names.names (k));
			goto place;
		     end;

		do n = 1 to operator_names.number_special;
		     if operator_names.special (n).offset = k
		     then do;
			     p = addr (operator_names.special (n).namep);
			     goto place;
			end;
		end;

		goto step;

place:
		size = fixed (p -> name_pair.size, 18);
		p = ptr (p, p -> name_pair.rel_ptr);

		substr (line, i, size) = p -> based_string;

		j = i + size - 1;
		i = i + 20;

		if i >= 121
		then do;
			call pl1_print$non_varying_nl (line, j);
			line = "";
			i = 1;
			j = 0;
		     end;

step:
		k = k + 1;
		goto look;
	     end;

	if j ^= 0
	then call pl1_print$non_varying_nl (line, j);

chk_ext:
	p = cg_static_$ext_proc_list;
	call print_list (1);			/* List ext. entry info */

	p = cg_static_$ext_var_list;
	call print_list (2);			/* List ext. variable info */
done:
	call pl1_print$varying_nl ("");

	return;

print_list:
     proc (ext_code);

/* parameters */

dcl	ext_code		fixed bin;		/* Print_list 1: external entries,
					    2: external variables */

/* automatic */
dcl	(hder_no_ext, hder_has_ext)
			char (512) varying;
dcl	sym2		ptr;

	if ext_code = 1
	then do;
		hder_no_ext = "
NO EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM.";
		hder_has_ext = "
THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM.";
	     end;
	else do;
		hder_no_ext = "
NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM.";
		hder_has_ext = "
THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM.";
	     end;

	if (p ^= null)
	then do;
		n = 0;

		do while (p ^= null);
		     sym2 = p -> element (2);

		     if ((sym2 -> symbol.cross_references ^= null) | (sym2 -> symbol.allocate))
		     then do;
			     n = n + 1;
			     symbol_list (n) = sym2;
			end;
		     p = p -> element (1);
		end;

		if (n > 0)
		then do;

			call pl1_print$varying_nl (hder_has_ext);
			call sym_sort_alphabetic (addr (symbol_list), n);
			line = "";
			i = 1;
			j = 0;

			do k = 1 to n;
			     p = symbol_list (k) -> symbol.token;
			     size = p -> token.size;

			     if i + size >= 121
			     then do;
				     call pl1_print$non_varying_nl (line, j);
				     line = " ";
				     i = 1;
				     j = 0;
				end;

			     substr (line, i, size) = p -> token.string;
			     j = i + size - 1;
			     if size = 30
			     then size = size + 1;

			     m = mod (size, 30);
			     if m ^= 0
			     then size = size + (30 - m);
			     i = i + size;
			end;

			if j ^= 0
			then call pl1_print$non_varying_nl (line, j);
		     end;
		else call pl1_print$varying_nl (hder_no_ext);
	     end;
	else call pl1_print$varying_nl (hder_no_ext);

     end;

prt_block:
     proc (pt);

dcl	pt		ptr;

dcl	(bp, fp)		ptr,
	(bt1, bt2, info_len)
			fixed bin,
	(name1, name2)	char (256) varying;

dcl	1 bline		aligned,
	  2 name		char (29) unal,
	  2 sp1		char (4) unal,
	  2 size		picture "-----9" unal,
	  2 sp2		char (1) unal,
	  2 type		char (19) unal,
	  2 sp3		char (1) unal,
	  2 info		char (70);

dcl	block_type	(5) char (18) varying int static
			init ("root block", "external procedure", "internal procedure", "begin block", "on unit");

dcl	nonquick_reasons	(13) char (40) varying aligned internal static options (constant)
			init ("uses auto adjustable storage", "uses returns(char(*)) or returns(bit(*))",
			"is called during a stack extension", "is invoked by a format statement",
			"contains a format statement", "uses I/O statements", "is assigned to an entry variable",
			"enables or reverts conditions", "is called by several nonquick procedures",
			"calls itself recursively", "is declared options(non_quick)",
			"is declared options(variable)", "is never referenced");

	bp = pt;
	string (bline) = "";

	call block_name (bp, name1, bt1);
	if length (name1) > length (bline.name)
	then call pl1_print$varying_nl (name1);
	else bline.name = name1;

	bline.type = block_type (bt1);

	if bp -> block.no_stack
	then do;
		fp = bp;
		do while (fp -> block.no_stack);
		     if fp -> block.owner = null
		     then fp = fp -> block.father;
		     else fp = fp -> block.owner;
		end;

		call block_name (fp, name2, bt2);
		name1 = "shares stack frame of ";
		if bt2 ^= bin (begin_block) & bt2 ^= bin (on_unit)
		then do;
			name1 = name1 || block_type (bt2);
			name1 = name1 || " ";
		     end;
		name1 = name1 || name2;
		bline.info = name1;
		info_len = length (name1);
	     end;
	else do;
		bline.size = bp -> block.last_auto_loc;
		info_len = 0;

		if bt1 = bin (external_procedure)	/* special-case the main procedure */
		then do;
			bline.info = "is an external procedure";
			info_len = length ("is an external procedure");
		     end;
		else do i = 1 to hbound (nonquick_reasons, 1);
			if substr (string (bp -> block.why_nonquick), i, 1)
			then do;
				if info_len > 0	/* if something already printed... */
				then if i = hbound (nonquick_reasons, 1)
				     then do;
					     substr (bline.info, info_len + 1, 6) = ", and ";
					     info_len = info_len + 6;
					end;
				     else if substr (string (bp -> block.why_nonquick), i + 1) = ""b
				     then do;
					     substr (bline.info, info_len + 1, 6) = ", and ";
					     info_len = info_len + 6;
					end;
				     else do;
					     substr (bline.info, info_len + 1, 2) = ", ";
					     info_len = info_len + 2;
					end;

				n = length (nonquick_reasons (i));
				if info_len + n + 1 > length (bline.info)
				then do;
					call pl1_print$non_varying_nl (string (bline),
					     length (string (bline)) - length (bline.info) + info_len);
					string (bline) = "";
					info_len = 0;
				     end;

				substr (bline.info, info_len + 1, n) = nonquick_reasons (i);
				info_len = info_len + n;
			     end;
		     end;
	     end;

	if info_len > 0 & info_len < length (bline.info)
	then do;
		substr (bline.info, info_len + 1, 1) = ".";
		info_len = info_len + 1;
	     end;

	call pl1_print$non_varying_nl (string (bline), length (string (bline)) - length (bline.info) + info_len);

     end;						/* end of prt_block */

block_name:
     proc (blkp, name, type);

dcl	blkp		ptr,
	name		char (256) varying,
	type		fixed bin;

dcl	blk		ptr;
dcl	name_ptr		ptr;

	blk = blkp;
	type = fixed (blk -> block_type, 3);

	if blk -> block_type = begin_block | blk -> block_type = on_unit
	then do;
		if blk -> block.block_type = begin_block
		then name = "begin block";
		else name = "on unit";
		name = name || " on line ";
number_name:
		if blk -> block.file_number ^= "0"b
		then do;
			digits_pic = fixed (blk -> block.file_number, 8);
			name = name || ltrim (digits_pic);
			name = name || "-";
		     end;
		digits_pic = fixed (blk -> block.line_number, 14);
		name = name || ltrim (digits_pic);
	     end;
	else do;
		name_ptr = blk -> block.main -> statement.labels -> list.element (2);
		if name_ptr -> reference.node_type = reference_node
		then name = name_ptr -> reference.symbol -> symbol.token -> token.string;
		else if name_ptr -> token.node_type = token_node
		then name = name_ptr -> token.string;
		else do;
			name = "<unknown>";
			go to number_name;
		     end;
	     end;

     end;

/* Select all symbols and store in list */

select_all_symbols:
     proc (pt);

dcl	pt		ptr;			/* points at block node */
dcl	dt		bit (3) aligned,
	null		builtin,
	(block_pt, sym_pt)	ptr;

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

	     sym_pt = block_pt -> block.declaration;
	     do while (sym_pt ^= null);

		dt = sym_pt -> symbol.dcl_type;

		if dt = by_compiler			/* Compiler-declared symbol */
		then if ^do_cp_dcl
		     then go to step;

		if n = hbound (symbol_list, 1)
		then goto full;

		n = n + 1;
		symbol_list (n) = sym_pt;

		if sym_pt -> symbol.cross_references = null & ^sym_pt -> symbol.allocate
		then if sym_pt -> symbol.level <= 1
		     then unused = unused + 1;
		     else unused_members = unused_members + 1;

step:
		sym_pt = sym_pt -> symbol.next;
	     end;

	     sym_pt = block_pt -> block.son;
	     if sym_pt ^= null
	     then call select_all_symbols (sym_pt);

	     block_pt = block_pt -> block.brother;
	end;

     end;

/* Procedure to fill in an array with pointers to all declarations of a given
   declare type.

   Initial Version: 13 January 1969 by JDM for Version I
	Modified: 23 Februrary 1971 by BLW for Version II	*/

sort_on_dcl_type:
     proc (pt, dtp1, dtp2);

dcl	pt		ptr,			/* points at block node */
	dtp1		bit (3) aligned,		/* first declare type */
	dtp2		bit (3) aligned;		/* second declare type */

dcl	(dt, dt1, dt2)	bit (3) aligned,
	null		builtin,
	(block_pt, sym_pt)	ptr;


	dt1 = dtp1;
	dt2 = dtp2;

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

	     sym_pt = block_pt -> block.declaration;
	     do while (sym_pt ^= null);

		dt = sym_pt -> symbol.dcl_type;

		if dt ^= dt1
		then if dt ^= dt2
		     then goto step;

		if n = hbound (symbol_list, 1)
		then goto full;

		n = n + 1;
		symbol_list (n) = sym_pt;

		if sym_pt -> symbol.cross_references = null & ^sym_pt -> symbol.allocate
		then if sym_pt -> symbol.level <= 1
		     then unused = unused + 1;
		     else unused_members = unused_members + 1;

step:
		sym_pt = sym_pt -> symbol.next;
	     end;

	     sym_pt = block_pt -> block.son;
	     if sym_pt ^= null
	     then call sort_on_dcl_type (sym_pt, dt1, dt2);

	     block_pt = block_pt -> block.brother;
	end;

     end;

print:
     proc (ignore_code);

/* parameters */

dcl	ignore_code	fixed bin;		/* Print -1: referenced,
						          0: all,
						         +1: non-referenced declarations. */

/* automatic */

dcl	(sym_pt, p)	ptr;
dcl	ref_list		(1024) ptr unaligned;
dcl	(k, ctype, dtype, ext, cur_attrib_col, nn, bo, i, name_width, ignore)
			fixed bin;
dcl	next_k		fixed bin;		/* index of next non-ignored name */
dcl	ref_list_length	fixed bin;
dcl	wo		fixed bin (18);
dcl	id		char (256) varying;
dcl	name		char (256) varying;
dcl	temp		char (296) varying;
dcl	number		char (12) varying;
dcl	c6		char (6);
dcl	ref_too_many	bit (1);
dcl	prev_dupl		bit (1);			/* last name was duplicate of current */
dcl	next_dupl		bit (1);			/* next name is dupl of current */
dcl	id_printed	bit (1);
dcl	something_to_print	bit (1);
dcl	ignore_symbol	bit (1);

/* pictures */

dcl	six_digits	picture "------9";

/* internal static */

dcl	char_per_line	fixed bin int static init (132);

dcl	int_ext		(0:1) char (8) int static options (constant) init ("internal", "external");

dcl	class_name	(0:23) char (20) aligned int static
			init ("ILLEGAL 0", "ILLEGAL 1", "automatic", "ILLEGAL 3", "based", "ILLEGAL 5",
			"internal static", "external static", "internal ctl", "external ctl", "defined",
			"ILLEGAL 11", "parameter", "ILLEGAL 13", "param descriptor", "ILLEGAL 15", "constant",
			"constant", "temporary", "ILLEGAL 19", "return value", "ILLEGAL 21", "stack reference",
			"constant");

dcl	dt		(0:26) char (17) aligned varying int static
			init ("unknown", "fixed bin", "fixed dec", "float bin", "float dec", "complex fixed bin",
			"complex fixed dec", "complex float bin", "complex float dec", "char", "varying char",
			"bit", "varying bit", "label", "label variable", "entry", "entry variable", "file",
			"file variable", "pointer", "offset", "structure", "area", "condition", "format",
			"format variable", "picture");

dcl	file_attr_words	(16) char (11) varying int static
			init ("print", "input", "output", "update", "stream", "", "record", "sequential", "direct",
			"interactive", "", "", "stringvalue", "keyed", "namelist", "environment");

dcl	auto_static_const	bit (10) int static init ("1010000100"b);

dcl	indent		fixed bin int static init (2);/* indentation for continuation lines */

dcl	line_pt		ptr;

dcl	1 sl,
	  2 symbol	char (20) unal,
	  2 sp1		char (1) unal,
	  2 word_offset	char (6) unal,
	  2 bit_offset	(4) char (1) unal,
	  2 sp2		char (1) unal,
	  2 location	char (6) unal,
	  2 sp3		char (1) unal,
	  2 class		char (15) unal,
	  2 sp4		char (1) unal,
	  2 data_type	char (25) unal,
	  2 sp6		char (1) unal,
	  2 attributes	char (60) unal;

dcl	line		char (132) defined (sl);

dcl	(bit, ltrim, verify)
			builtin;

dcl	digit		(0:9) char (1) aligned int static
			initial ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

%include cgsystem;
%include label;
%include cross_reference;

	line_pt = addr (line);
	ignore = ignore_code;

/* The following code selects symbols for printing and determines whether duplicates occur */
	next_dupl = "0"b;
	k = 0;					/* No current symbol */
	do next_k = 1 to n;				/* Scan symbol_list */

/* Consider symbol symbol_list (next_k) only if it is not to be ignored */
/* Ignore non-referenced variables if "ignore" is */
/* negative, referenced variables if "ignore" */
/* is positive non-zero. */
	     begin;
dcl	sym_pt		ptr;
dcl	referenced	bit (1);
		sym_pt = symbol_list (next_k);
		ignore_symbol = "0"b;		/* Assume symbol is not to be ignored */
		if ignore ^= 0 | sym_pt -> symbol.level > 1
		then do;
			referenced = (sym_pt -> symbol.cross_references ^= null | sym_pt -> symbol.allocate);
						/* identifier is referenced */
			if ignore < 0 & ^referenced | ignore > 0 & referenced
			     | sym_pt -> symbol.level > 1 & ^referenced
			then ignore_symbol = "1"b;
		     end;
	     end;
	     if ^ignore_symbol
	     then do;
		     if k ^= 0
		     then do;
			     prev_dupl = next_dupl;
			     next_dupl =
				(symbol_list (k) -> symbol.token -> token.string
				= symbol_list (next_k) -> symbol.token -> token.string);
			     call print_k;
			end;
		     k = next_k;
		end;
	end;
	prev_dupl = "0"b;
	call print_k;				/* Print last symbol (there must be one) */
	return;

/* Print symbol table entry for current symbol */
print_k:
     proc;
	sym_pt = symbol_list (k);
	call init_attrib;
	dtype, ctype = 0;
	id = sym_pt -> symbol.token -> token.string;	/* save identifier for later */
	id_printed = "0"b;
	if sym_pt -> node.type = label_node
	then do;
		ctype = 16;
		sl.data_type = dt (13);

		if sym_pt -> label.array
		then do;
			temp = "array(";

			if sym_pt -> label.low_bound ^= 1
			then do;
				six_digits = sym_pt -> label.low_bound;
				temp = temp || ltrim (six_digits);
				temp = temp || ":";
			     end;

			six_digits = sym_pt -> label.high_bound;
			temp = temp || ltrim (six_digits);
			temp = temp || ")";
			call attrib (temp);		/* "array(low:high)" */
		     end;
		go to set_loc;
	     end;

	if sym_pt -> symbol.builtin
	then do;
		sl.data_type = "builtin function";
		goto done;
	     end;

	if sym_pt -> symbol.generic
	then do;
		sl.data_type = "generic function";
		goto done;
	     end;

	ext = fixed (sym_pt -> symbol.external, 1);

	if sym_pt -> symbol.entry
	then do;

		if sym_pt -> symbol.variable
		then do;
			dtype = 16;
			goto have_type;
		     end;

		dtype = 15;
		if sym_pt -> symbol.external & sym_pt -> symbol.initial = null
		then ctype = 23;
		else ctype = 16;

		call attrib ((int_ext (ext)));	/* "internal" or "external" entry constant */
		goto set_loc;
	     end;

	if sym_pt -> symbol.condition
	then do;
		ctype = 22;
		dtype = 23;
		goto set_loc;
	     end;

	if sym_pt -> symbol.fixed
	then do;
		dtype = 1;
		goto arith;
	     end;

	if sym_pt -> symbol.float
	then do;
		dtype = 3;

arith:
		if sym_pt -> symbol.decimal
		then dtype = dtype + 1;
		if sym_pt -> symbol.complex
		then dtype = dtype + 4;
		goto have_type;
	     end;

	if sym_pt -> symbol.char
	then do;
		dtype = 9;
		goto str;
	     end;

	if sym_pt -> symbol.bit
	then do;
		dtype = 11;

str:
		if sym_pt -> symbol.varying
		then dtype = dtype + 1;
		goto have_type;
	     end;

	if sym_pt -> symbol.picture
	then do;
		dtype = 26;
		go to have_type;
	     end;

	if sym_pt -> symbol.label
	then do;
		dtype = 13;
		goto cv;
	     end;

	if sym_pt -> symbol.format
	then do;
		dtype = 24;
		goto cv;
	     end;

	if sym_pt -> symbol.file
	then do;
		dtype = 17;

cv:
		if sym_pt -> symbol.variable
		then dtype = dtype + 1;
		goto have_type;
	     end;

	if sym_pt -> symbol.ptr
	then dtype = 19;
	else if sym_pt -> symbol.offset
	then dtype = 20;
	else if sym_pt -> symbol.structure
	then dtype = 21;
	else if sym_pt -> symbol.area
	then dtype = 22;

have_type:
	ctype = 2 * index (string (sym_pt -> symbol.storage_class), "1"b) + ext;

	if sym_pt -> symbol.allocated
	then if string (sym_pt -> symbol.storage_class) & auto_static_const
	     then do;

/* Save variables for later printout in storage table */
		     if sym_pt -> symbol.level <= 1
		     then do;			/* Members of structures ignored */
			     if ctype = 6
			     then do;		/* Internal static */
				     if int_static_list_length = hbound (int_static_list, 1)
				     then call cg_error (327, int_static_list_length);
				     else do;
					     int_static_list_length = int_static_list_length + 1;
					     int_static_list (int_static_list_length) = sym_pt;
					end;
				end;
			     else if ctype = 2
			     then do;		/* Automatic */
				     if auto_list_length = hbound (auto_list, 1)
				     then call cg_error (327, auto_list_length);
				     else do;
					     auto_list_length = auto_list_length + 1;
					     auto_list (auto_list_length) = sym_pt;
					end;
				end;
			end;

set_loc:
		     sl.location = substr (binoct (bit (fixed (sym_pt -> symbol.location, 18), 18)), 1, 6);
		end;

	sl.class = substr (class_name (ctype), 1, 15);

	if sym_pt -> node.type = label_node
	then goto done;

	p = sym_pt -> symbol.reference;
	if p -> reference.offset = null
	then do;
		nn = p -> reference.c_offset * convert_offset (p -> reference.units);
		wo = divide (nn, bits_per_word, 17, 0);
		bo = mod (nn, bits_per_word);

		if wo ^= 0
		then do;
			c6 = substr (binoct (bit (wo, 18)), 1, 6);

			substr (c6, 1, verify (c6, "0") - 1) = " ";
						/* Suppress leading zeros */

			sl.word_offset = c6;
		     end;

		if bo ^= 0
		then do;
			if wo = 0
			then substr (sl.word_offset, 6, 1) = "0";

			sl.bit_offset (1) = "(";

			sl.bit_offset (3) = digit (mod (bo, 10));

			bo = divide (bo, 10, 17, 0);
			sl.bit_offset (2) = digit (mod (bo, 10));

			sl.bit_offset (4) = ")";
		     end;

	     end;

	if sym_pt -> symbol.c_dcl_size ^= 0
	then do;
		digits_pic = sym_pt -> symbol.c_dcl_size;
		number = ltrim (digits_pic);

		if substr ("110011000000000000000000000000"b, dtype, 1)
		then do;
			number = number || ",";
			digits_pic = sym_pt -> symbol.scale;
			number = number || ltrim (digits_pic);
		     end;

		temp = dt (dtype);
		temp = temp || "(";
		temp = temp || number;
		temp = temp || ")";
		sl.data_type = temp;
	     end;
	else sl.data_type = dt (dtype);

	if sym_pt -> symbol.local
	then do;
		call attrib ("local");
	     end;

	if sym_pt -> symbol.initialed
	then do;
		call attrib ("initial");
	     end;

	if sym_pt -> symbol.array ^= null
	then do;
		call attrib ("array");
	     end;

	if sym_pt -> symbol.father ^= null | dtype = 21
	then do;
		temp = "level " || digit (sym_pt -> symbol.level);
		call attrib (temp);

/* Qualify by structure */
		if sym_pt -> symbol.level > 1 & (prev_dupl | next_dupl)
		then do;
			do p = sym_pt repeat p -> symbol.father while (p -> symbol.level > 1);
			end;			/* find level 1 containing structure */
			call attrib ("in structure"); /* Print the structure qualification */
			temp = """";
			temp = temp || p -> symbol.token -> token.string;
						/* Name of containing structure */
			temp = temp || """";
			call attrib (temp);
		     end;

		if sym_pt -> symbol.packed | sym_pt -> symbol.explicit_packed
		then do;
			call attrib ("packed");
		     end;

	     end;

	if sym_pt -> symbol.packed | sym_pt -> symbol.explicit_packed
	then call attrib ("packed");

	if sym_pt -> symbol.unsigned
	then do;
		call attrib ("unsigned");
	     end;

	if ^sym_pt -> symbol.aligned
	then do;
		call attrib ("unaligned");
	     end;

	if sym_pt -> symbol.file
	then do i = 1 to hbound (file_attr_words, 1);
		if substr (string (sym_pt -> symbol.file_attributes), i, 1)
		then call attrib ((file_attr_words (i)));
	     end;

done:
	if string (sym_pt -> symbol.source_id) ^= (27)"0"b
	then do;
		call file_line (sym_pt);
		temp = "dcl " || number;
		call attrib (temp);			/* make sure "dcl" and number are on same line */

/* Qualify by block */
		p = sym_pt -> symbol.block_node;	/* Find containing block */
		if (prev_dupl | next_dupl) & p -> block.main ^= null
		then do;				/* This is a duplicate symbol not contained in the root block */
			call block_name (p, name, dtype);
						/* Print block qualification */
			if dtype = bin (begin_block) | dtype = bin (on_unit)
			then do;
				temp = "in ";	/* begin block on line xxx */
				temp = temp || name;
				call attrib (temp);
			     end;
			else do;
				call attrib ("in procedure");
						/* procedure "name" */
				temp = """";
				temp = temp || name;
				temp = temp || """";
				call attrib (temp);
			     end;
		     end;
	     end;

/* Process cross-reference list */
	p = sym_pt -> symbol.cross_references;
	ref_too_many = "0"b;
	ref_list_length = 0;

/* Create list of cross references */
	do while (p ^= null);
	     if ref_list_length = hbound (ref_list, 1)
	     then ref_too_many = "1"b;
	     else do;
		     ref_list_length = ref_list_length + 1;
		     ref_list (ref_list_length) = p;
		end;
	     p = p -> cross_reference.next;
	end;

/* Sort the cross reference list within each included file.
   (Note: list stored in REVERSE order).
   Algorithm is insertion sort, which is the most efficient since list is usually
   ordered already. */

	begin;
dcl	temp		ptr;
dcl	compare		bit (1);			/* Compare next items */
dcl	i		fixed bin;		/* Next item to be ordered */
dcl	j1		fixed bin;		/* Current item being ordered */
dcl	j2		fixed bin;		/* Previous item to compare with */

	     do i = 2 to ref_list_length;
		compare = "1"b;
		do j1 = i repeat j2 while (compare & j1 > 1);
						/* "Bubble" item back to proper place */
		     j2 = j1 - 1;			/* Next previous candidate for comparison */
		     if ref_list (j2) -> cross_reference.file_number = ref_list (j1) -> cross_reference.file_number
		     then do;
			     if ref_list (j2) -> cross_reference.line_number
				< ref_list (j1) -> cross_reference.line_number
			     then do;
				     temp = ref_list (j1);
						/* Exchange items in wrong order */
				     ref_list (j1) = ref_list (j2);
				     ref_list (j2) = temp;
				end;
			     else compare = "0"b;	/* Stop bubbling when right order found */
			end;
		end;
	     end;
	end;

/* Print the cross reference list */
	if ref_list_length ^= 0
	then do;
		if sym_pt -> symbol.set
		then call attrib ("set");
		call attrib ("ref");
		if ref_too_many
		then call attrib ("(more)");
		do i = ref_list_length to 1 by -1;
		     call file_line ((ref_list (i)));
		     temp = number;
		     if ref_list (i) -> cross_reference.set_reference
		     then temp = temp || "*";
		     call attrib (temp);
		end;
	     end;

	if something_to_print
	then call output_line;

	return;

     end;						/* End print_k */

/* Convert source line number to char string */
file_line:
     proc (node_pt);
dcl	node_pt		ptr;

	if node_pt -> cross_reference.file_number = "0"b
	then number = "";
	else do;
		digits_pic = fixed (node_pt -> cross_reference.file_number, 8);
		number = ltrim (digits_pic);
		number = number || "-";
	     end;

	digits_pic = fixed (node_pt -> cross_reference.line_number, 14);
	number = number || ltrim (digits_pic);

     end;						/* End of file_line */

attrib:
     proc (input_string);				/* store leading space and item in "attributes" column */
dcl	input_string	char (296) varying;

	if length (input_string) + cur_attrib_col > char_per_line
	then call output_line;			/* item too big to fit on line */
	if length (input_string) + cur_attrib_col > char_per_line
	then call pl1_print$varying_nl ((82)" " || input_string);
						/* item too big even for line of its own */
	else do;
		substr (line, cur_attrib_col + 1, length (input_string)) = input_string;
						/* item fits on line */
		cur_attrib_col = cur_attrib_col + length (input_string) + 1;
						/* include leading space */
		something_to_print = "1"b;
	     end;
     end;

output_line:
     proc;					/* print out and initialize current print line */
	if ^id_printed
	then do;
		name_width = 38;			/* Print identifier. Try for maximum width. */
		if sl.location ^= ""
		then name_width = 31;		/* Narrower if there is a loc. */
		if sl.word_offset ^= ""
		then name_width = 20;		/* Narrowest if an offset. */
		if length (id) <= name_width
		then substr (line, 1, length (id)) = id;/* Name fits into available space. */
		else call pl1_print$varying_nl (id);	/* Doesn't fit. */
		id_printed = "1"b;
	     end;
	call pl1_print$varying_nl (substr (line, 1, cur_attrib_col - 1));
	call init_attrib;
	cur_attrib_col = cur_attrib_col + indent;
     end;

init_attrib:
     proc;					/* initialize storing attributes in print line */
	something_to_print = "0"b;
	cur_attrib_col = 80;			/* col 80 will get a leading space */
	line = "";				/* store spaces in print line (sl) */
     end;

     end;						/* End of print. */

print_int_static_table:
     proc (int_static_list_st, int_static_list_length);

dcl	1 int_static_list_st
			aligned,
	  2 int_static_list (1024) ptr unaligned;	/* For efficiency */
dcl	int_static_list_length
			fixed bin;

dcl	i		fixed bin;
dcl	tabs		(4) internal static options (constant) fixed bin init (1, 8, 36, 1000);

dcl	(loc_item, name_item, procedure_item)
			char (256) varying;

	if int_static_list_length = 0
	then return;				/* No internal static variables */
	call pl1_print$varying_nl ("
STORAGE FOR INTERNAL STATIC VARIABLES.
");
	call column_print (tabs, "   LOC", "IDENTIFIER", "BLOCK NAME", "");
	call sort_storage_list (int_static_list_st, int_static_list_length, 0);
						/* Sort on location */
	do i = 1 to int_static_list_length;
	     call format_items ((int_static_list (i)), loc_item, name_item, procedure_item);
						/* Get strings */
	     call column_print (tabs, loc_item, name_item, procedure_item, "");
	end;
     end;						/* End of print_int_static_table */

print_auto_table:
     proc (auto_list_st, auto_list_length);

dcl	1 auto_list_st	aligned,
	  2 auto_list	(1024) ptr unaligned;	/* For efficiency */
dcl	auto_list_length	fixed bin;

dcl	(i, ignored_type)	fixed bin;
dcl	tabs		(4) internal static options (constant) fixed bin init (1, 26, 33, 61);

dcl	p		ptr;

dcl	(stack_frame_item, loc_item, name_item, procedure_item, previous_stack_frame_item)
			char (256) varying;

	if auto_list_length = 0
	then return;				/* No automatic variables */
	previous_stack_frame_item = "";
	call pl1_print$varying_nl ("
STORAGE FOR AUTOMATIC VARIABLES.
");
	call column_print (tabs, "STACK FRAME", "   LOC", "IDENTIFIER", "BLOCK NAME");
	call sort_storage_list (auto_list_st, auto_list_length, 1);
						/* Sort on location and stack frame */
	do i = 1 to auto_list_length;
	     p = auto_list (i) -> symbol.block_node;	/* Find stack frame owner */
	     if p -> block.owner ^= null
	     then p = p -> block.owner;
	     call block_name (p, stack_frame_item, ignored_type);
	     call format_items ((auto_list (i)), loc_item, name_item, procedure_item);
						/* Get strings */
	     if stack_frame_item = previous_stack_frame_item
	     then stack_frame_item = "";		/* Blank out duplicate stack frame names */
	     else previous_stack_frame_item = stack_frame_item;
	     call column_print (tabs, stack_frame_item, loc_item, name_item, procedure_item);
	end;
     end;						/* End of print_auto_table */

column_print:
     proc (tabs, v1, v2, v3, v4);

dcl	tabs		(4) fixed bin;
dcl	(v1, v2, v3, v4)	char (256) varying;

dcl	line		char (512) varying;

	line = v1;
	call print_item (tabs (2), v2);
	call print_item (tabs (3), v3);
	if v4 ^= ""
	then call print_item (tabs (4), v4);
	if line ^= ""
	then call pl1_print$varying_nl (line);
	return;

print_item:
     proc (tab, input_string);

dcl	tab		fixed bin;
dcl	input_string	char (256) varying;

dcl	copy		builtin;

	if length (line) < tab - 1
	then line = line || copy (" ", tab - 1 - length (line));
						/* Input string fits on same line */
						/* Pad to tab */
	else do;					/* Previous item exceeded current tab */
		call pl1_print$varying_nl (line);	/* Print all but current item */
		line = copy (" ", tab - 1);		/* Pad next line to tab */
	     end;
	line = line || input_string;			/* Store item on current line */
     end;						/* End of print_item */

     end;						/* End of column_print */

sort_storage_list:
     proc (saved_list_st, saved_list_length, sorting_field);

dcl	1 saved_list_st	aligned,
	  2 saved_list	(1024) ptr unaligned;	/* For efficiency */
dcl	saved_list_length	fixed bin;
dcl	sorting_field	fixed bin;

dcl	(d, i, j, k)	fixed bin;
dcl	ignored_type	fixed bin;
dcl	(p1, p2)		ptr;
dcl	p1_owner		ptr;
dcl	p2_owner		ptr;
dcl	(compare, interchange)
			bit (1);
dcl	p1_owner_name	char (256) varying;
dcl	p2_owner_name	char (256) varying;

/* Sort saved list of symbols on location or loc/stack owner.
   Algorithm is Shell sort. */

	d = saved_list_length;
	do while (d > 1);
	     d = 2 * divide (d, 4, 17, 0) + 1;
	     do i = 1 to saved_list_length - d;
		k = i + d;
		p2 = saved_list (k);
		compare = "1"b;
		do while (compare);
		     compare = "0"b;
		     j = k - d;
		     p1 = saved_list (j);
		     if sorting_field = 0
		     then interchange = p1 -> symbol.location > p2 -> symbol.location;
		     else do;
			     p1_owner = p1 -> symbol.block_node;
						/* Find stack frame owners of p1 and p2 */
			     if p1_owner -> block.owner ^= null
			     then p1_owner = p1_owner -> block.owner;
			     p2_owner = p2 -> symbol.block_node;
			     if p2_owner -> block.owner ^= null
			     then p2_owner = p2_owner -> block.owner;
			     if p1_owner = p2_owner
			     then interchange = p1 -> symbol.location > p2 -> symbol.location;
						/* Sort symbols with same stack owner by loc */
			     else do;
				     call block_name (p1_owner, p1_owner_name, ignored_type);
						/* Sort symbols by stack owner's name */
				     call block_name (p2_owner, p2_owner_name, ignored_type);
				     interchange = p1_owner_name > p2_owner_name;
				end;
			end;
		     if interchange
		     then do;
			     saved_list (j) = saved_list (k);
						/* Interchange out-of-order symbols */
			     saved_list (k) = p1;
			     if j > d
			     then do;
				     k = j;
				     compare = "1"b;
				end;
			end;
		end;
	     end;
	end;

     end;						/* End of sort_storage_list */

format_items:
     proc (sym_pt, loc_item, name_item, procedure_item);

dcl	sym_pt		ptr;
dcl	(loc_item, name_item, procedure_item)
			char (256) varying;

dcl	type		fixed bin;
dcl	bit		builtin;

/* Get various strings from symbol node ptr */

	loc_item = substr (binoct (bit (fixed (sym_pt -> symbol.location, 18), 18)), 1, 6);
	name_item = sym_pt -> symbol.token -> token.string;
	call block_name ((sym_pt -> symbol.block_node), procedure_item, type);

     end;						/* End of format_items */

     end;						/* End of pl1_symbol_print. */




		    refer_extent.pl1                07/31/89  1433.2r w 07/31/89  1338.4       15228



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


refer_extent: proc(p,q);

dcl	(p,q,r) ptr;
dcl	(i,n) fixed bin(15);
dcl	null builtin;
%include language_utility;
%include nodes;
%include reference;
%include operator;
%include op_codes;

begin:
	if p = null then return;
	if p->node.type = reference_node
		then do;
			r = p->reference.qualifier;
			call refer_extent(r,q);
			p->reference.qualifier = r;
			r = p->reference.offset;
			call refer_extent(r,q);
			p->reference.offset = r;
			r = p->reference.length;
			call refer_extent(r,q);
			p->reference.length = r;
			return;
		     end;
	if p->node.type = operator_node
		then do;
			if p->op_code = refer
			then do;
				p = p->operand(2);
				if p->node.type=token_node
				then	p = create_reference(p);
				if q->node.type=reference_node
				then	if q->reference.shared
					&  q->reference.qualifier=null
					&  q->reference.offset=null
					&  q->reference.length=null
					then do;
						p->reference.qualifier = q;
						return;
					end;

				p->reference.qualifier = copy_expression((q));
				return;
			end;

			do i = 1 to p->operator.number;
			r = p->operand(i);
			call refer_extent(r,q);
			p->operand(i) = r;
			end;
			return;
		     end;
	end refer_extent;




		    reserve.pl1                     07/31/89  1433.2r w 07/31/89  1338.4       88200



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


reserve$declare_lib:	proc(number) returns(ptr);

dcl	(p,q,s) ptr,
	(error_number,i,k,m,n,number) fixed bin(15),
	test_string char(20) varying aligned,

	(declared_array,renamed_array) bit(216) aligned int static,
	parallel_ptr_number fixed bin(15) int static,
	parallel_ptr(40) ptr int static,

	pl1_stat_$use_old_area bit(1) aligned ext static,

	pl1_stat_$root ptr ext static;

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

%include language_utility;
%include boundary;
%include declare_type;
%include op_codes;
%include operator;
%include parameter;
%include reference;
%include symbol;
%include system;
%include token;
%include token_list;
%include token_types;

	p=reserve$read_lib(number);

	if substr(declared_array,number,1)
	then do;
		s=p->token.declaration;
		do while(s->symbol.block_node^=pl1_stat_$root);
			s=s->symbol.multi_use;
			if s=null then goto dcl_entry;
		end;

		return(s->symbol.reference);
	end;

dcl_entry:
	substr(declared_array,number,1)="1"b;
	s=create_symbol(pl1_stat_$root,p,by_compiler);
	s->symbol.boundary=mod2_;
	s->symbol.allocate  ,
	s->symbol.entry  ,
	s->symbol.constant  ,
	s->symbol.external  ,
	s->symbol.irreducible = "1"b;

	return(s->symbol.reference);

read_lib:	entry(number) returns(ptr);

	if substr(renamed_array,number,1)
	then do;
		test_string=reserved_name(number);
		m=length(test_string);
		do i=1 to 39 by 2;
			p=parallel_ptr(i);
			n=p->token.size;
			if m=n
			then	if p->token.string=test_string
				then do;
					p=parallel_ptr(i+1);
					goto read_lib_ret;
				end;
			if n=2*m+1
			then	if p->token.string=substr(test_string,1,m)||"$"||substr(test_string,1,m)
				then do;
					p=parallel_ptr(i+1);
					goto read_lib_ret;
				end;
		end;
	end;
	else	p=create_token((reserved_name(number)),identifier);

read_lib_ret:
	return(p);

reserve$clear:	entry returns(ptr);

	parallel_ptr_number=0;
	declared_array ,
	renamed_array = "0"b;

	return(null);

dcl	number_of_reserved_names fixed bin(15) int static initial(200),
	reserved_name(200) char(20) varying aligned int static init
(	/*  1*/     "free_$free_",
	/*  2*/     "stat_",
	/*  3*/     "area_",
	/*  4*/     "system_condition_",
	/*  5*/     "alloc_",
	/*  6*/     "bound_",
	/*  7*/	  "on_data_$get_onloc",
	/*  8*/     "on_data_$get_onfield",
	/*  9*/     "on_data_$get_onchar",
	/* 10*/     "on_data_$get_oncode",
	/* 11*/     "on_data_$set_onchar",
	/* 12*/     "on_data_$get_onfile",
	/* 13*/     "on_data_$get_onkey",
	/* 14*/     "on_data_$getonsource",
	/* 15*/     "datmk_",
	/* 16*/     "snap_",
	/* 17*/     "xp2_",
	/* 18*/     "dxp1_",
	/* 19*/     "cxp1_",
	/* 20*/     "dcxp1_",
	/* 21*/     "xp3_",
	/* 22*/     "dxp2_",
	/* 23*/     "cxp2_",
	/* 24*/     "dcxp2_",
	/* 25*/     "sqrt_",
	/* 26*/     "dsqrt_",
	/* 27*/     "csqrt_",
	/* 28*/     "dcsqrt_",
	/* 29*/     "exp_",
	/* 30*/     "dexp_",
	/* 31*/     "cexp_",
	/* 32*/     "dcexp_",
	/* 33*/     "log_",
	/* 34*/     "dlog_",
	/* 35*/     "clog_",
	/* 36*/     "dclog_",
	/* 37*/     "log_$log2_",
	/* 38*/     "dlog_$dlog2_",
	/* 39*/     "clog_$clog2_",
	/* 40*/     "dclog_$dclog2_",
	/* 41*/     "log_$log10_",
	/* 42*/     "dlog_$dlog10_",
	/* 43*/     "clog_$clog10_",
	/* 44*/     "dclog_$dclog10_",
	/* 45*/     "log_$atanh_",
	/* 46*/     "dlog_$datanh_",
	/* 47*/     "catan_$catanh_",
	/* 48*/     "dcatan_$dcatanh_",
	/* 49*/     "log_$lone_",
	/* 50*/     "dlog_$dlone_",
	/* 51*/     "clog_$clone_",
	/* 52*/     "dclog_$dclone_",
	/* 53*/     "sin_",
	/* 54*/     "dsin_",
	/* 55*/     "csin_",
	/* 56*/     "dcsin_",
	/* 57*/     "sin_$sind_",
	/* 58*/     "dsin_$dsind_",
	/* 59*/     "csin_$csind_",
	/* 60*/     "dcsin_$dcsind_",
	/* 61*/     "sin_$cos_",
	/* 62*/     "dsin_$dcos_",
	/* 63*/     "csin_$ccos_",
	/* 64*/     "dcsin_$dccos_",
	/* 65*/     "sin_$cosd_",
	/* 66*/     "dsin_$dcosd_",
	/* 67*/     "csin_$ccosd_",
	/* 68*/     "dcsin_$dccosd_",
	/* 69*/     "tan_",
	/* 70*/     "dtan_",
	/* 71*/     "csin_$ctan_",
	/* 72*/     "dcsin_$dctan_",
	/* 73*/     "tan_$tand_",
	/* 74*/     "dtan_$dtand_",
	/* 75*/     "csin_$ctand_",
	/* 76*/     "dcsin_$dctand_",
	/* 77*/     "asin_",
	/* 78*/     "dasin_",
	/* 79*/     "casin_",
	/* 80*/     "dcasin_",
	/* 81*/     "asin_$asind_",
	/* 82*/     "dasin_$dasind_",
	/* 83*/     "casin_$casind_",
	/* 84*/     "dcasin_$dcasind_",
	/* 85*/     "asin_$acos_",
	/* 86*/     "dasin_$dacos_",
	/* 87*/     "casin_$cacos_",
	/* 88*/     "dcasin_$dcacos_",
	/* 89*/     "asin_$acosd_",
	/* 90*/     "dasin_$dacosd_",
	/* 91*/     "casin_$cacosd_",
	/* 92*/     "dcasin_$dcacosd_",
	/* 93*/     "asin_$atan_",
	/* 94*/     "dasin_$datan_",
	/* 95*/     "catan_",
	/* 96*/     "dcatan_",
	/* 97*/     "asin_$atand_",
	/* 98*/     "dasin_$datand_",
	/* 99*/     "catan_$catand_",
	/*100*/     "dcatan_$dcatand_",
	/*101*/     "atan2_",
	/*102*/     "datan2_",
	/*103*/     "catan2_",
	/*104*/     "dcatan2_",
	/*105*/     "atan2_$atand2_",
	/*106*/     "datan2_$datand2_",
	/*107*/     "catan2_$catand2_",
	/*108*/     "dcatan2_$dcatand2_",
	/*109*/     "sinh_",
	/*110*/     "dsinh_",
	/*111*/     "csin_$csinh_",
	/*112*/     "dcsin_$dcsinh_",
	/*113*/     "sinh_$cosh_",
	/*114*/     "dsinh_$dcosh_",
	/*115*/     "csin_$ccosh_",
	/*116*/     "dcsin_$dccosh_",
	/*117*/     "tanh_",
	/*118*/     "dtanh_",
	/*119*/     "csin_$ctanh_",
	/*120*/     "dcsin_$dctanh_",
	/*121*/     "asinh_",
	/*122*/     "dasinh_",
	/*123*/     "casin_$casinh_",
	/*124*/     "dcasin_$dcasinh_",
	/*125*/     "asinh_$acosh_",
	/*126*/     "dasinh_$dacosh_",
	/*127*/     "casin_$cacosh_",
	/*128*/     "dcasin_$dcacosh_",
	/*129*/     "erf_",
	/*130*/     "derf_",
	/*131*/     "cerf_",
	/*132*/     "dcerf_",
	/*133*/     "erf_$erfc_",
	/*134*/     "derf_$derfc_",
	/*135*/     "cerf_$cerfc_",
	/*136*/     "dcerf_$dcerfc_",
	/*137*/     "exerfc_",
	/*138*/     "dexerfc_",
	/*139*/     "cexerfc_",
	/*140*/     "dcexerfc_",
	/*141*/     "cabs_",
	/*142*/     "dcabs_",
	/*143*/     "cfmp_",
	/*144*/     "dcfmp_",
	/*145*/     "cfdp_",
	/*146*/     "dcfdp_",
	/*147*/     "iexp_",
	/*148*/     "round_",
	/*149*/     "round_$expon_",
	/*150*/     "round_$adexp_",
	/*151*/	  "freen_",
	/*152*/	  "plio_$plio_sw_",
	/*153*/	  "plio_$open1",
	/*154*/	  "plio_$close",
	/*155*/	  "plio_$get_value_data",
	/*156*/	  "plio_$put_value_data",
	/*157*/	  "plio_$get_value_list",
	/*158*/	  "plio_$put_value_list",
	/*159*/	  "plio_$get_value_edit",
	/*160*/	  "plio_$put_value_edit",
	/*161*/	  "area_assign_",
	/*162*/	  "exit_",
	/*163*/	  "stop_",
	/*164*/	  "char_to_arith_",
	/*165*/	  "char_to_bit_",
	/*166*/	  "arith_to_char_",
	/*167*/	  "bit_to_char_",
	/*168*/	  "ftnio_$init",
	/*169*/	  "ftnio_",
	/*170*/	  "ftnio_$finish",
	/*171*/	  "diexp_",
	/*172*/	  "arith_to_arith_",
	/*173*/	  "bit_to_arith_",
	/*174*/	  "arith_to_bit_",
	/*175*/	  "decimal_op_",
	/*176*/	  "multi_decimal_op_",
	/*177*/	  "plio2_$set_pageno",
	/*178*/	  "pl1_before_bit_",
	/*179*/	  "pl1_before_char_",
	/*180*/	  "translate_$trans_2_",
	/*181*/	  "translate_$trans_3_",
	/*182*/	  "complex_decimal_op_",
	/*183*/	  "plio2_$get_lineno",
	/*184*/	  "plio2_$get_pageno",
	/*185*/	  "pl1_valid_picture_",
	/*186*/	  "pl1_date_",
	/*187*/	  "pl1_time_",
	/*188*/	  "pl1_after_bit_",
	/*189*/	  "pl1_after_char_",
	/*190*/	  "pl1_decat_bit_",
	/*191*/	  "pl1_decat_char_",
	/*192*/	  "alloc_$storage_",
	/*193*/	  "complex_binary_op_",
	/*194*/	  "on_data_$setonsource",
	/*195*/	  "decimal_exp_",
	/*196*/	  "decimal_exp2_",
	/*197*/	  "xp22_",
	/*198*/	  "dxp12_",
	/*199*/	  "cxp12_",
	/*200*/	  "dcxp12_"
					);

rename_parse:	entry(number,return_bit);

dcl	return_bit bit(1) aligned;

	k=number+1;

	if t_table.type ^= left_parn then go to error1;

l:	k=k+1;
	if t_table.type ^= left_parn then go to error1;

	k=k+1;
	if t_table.type ^= identifier then go to error2;

	test_string=t_table.string;
	do i=1 to number_of_reserved_names;
		if reserved_name(i)=test_string then goto replace;
	end;

	go to error3;

replace:
	if i = 1		/* free_$free_	*/
	|  i = 3		/* area_		*/
	|  i = 5		/* alloc_		*/
	|  i = 151	/* freen_		*/
	|  i = 192	/* alloc_$storage	*/
	then pl1_stat_$use_old_area = "1"b;

	k=k+1;
	if t_table.type ^= comma then go to error4;

	k=k+1;
	if t_table.type ^= identifier then go to error5;

	parallel_ptr_number=parallel_ptr_number+2;
	if parallel_ptr_number>40 then goto error7;

	substr(renamed_array,i,1)="1"b;
	parallel_ptr(parallel_ptr_number-1)=token_list(k-2);
	parallel_ptr(parallel_ptr_number)=token_list(k);

	k=k+1;
	if t_table.type ^= right_parn then go to error6;

	k=k+1;
	if t_table.type = comma then go to l;
	if t_table.type ^= right_parn then go to error6;

	number=k+1;
	return_bit="1"b;
	return;

error1:	error_number=161;			/* no left parn */
	go to error_finish;

error2:	error_number=162;			/* Name1 is not an identifier */
	go to error_finish;

error3:	error_number=163;			/* Name1 could not be matched with a reserved name. */
	go to error_finish;

error4:	error_number=164;			/* No comma */
	go to error_finish;

error5:	error_number=165;			/* Name2 is not an identifier. */
	go to error_finish;

error6:	error_number=166;			/* No matching right parn */
	goto error_finish;

error7:	error_number=94;

error_finish:
	call parse_error(error_number,token_list(k));
	return_bit="0"b;

	end reserve$declare_lib;




		    share_expression.pl1            07/31/89  1433.2r w 07/31/89  1338.4       16128



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

share_expression:	proc(a) returns(ptr);

dcl	(a,p,inptr,outptr) ptr,

	n fixed bin(15),

	nodetype bit(9) aligned;

dcl	null builtin;

%include language_utility;
%include nodes;
%include operator;
%include reference;
%include symbol;

	inptr = a;
	outptr = null;

	if inptr=null then goto ret;
	nodetype = inptr->node.type;

	if nodetype=operator_node
	then do;
		p = inptr->operand(1);
		if p=null then goto copy;

		if ^p->reference.shared
		then	p->reference.ref_count = p->reference.ref_count+1;
		else do;
			p = create_reference((inptr->operand(1)));
			p->reference = inptr->operand(1)->reference;
			p->reference.shared = "0"b;
			p->reference.ref_count = 2;
			inptr->operand(1) = p;
		end;

		outptr = inptr;
		goto ret;
	end;

	if nodetype=reference_node
	then do;
		if ^inptr->reference.shared
		then	inptr->reference.ref_count = inptr->reference.ref_count + 1;

		outptr = inptr;
		go to ret;
	end;

copy:
	outptr = copy_expression((inptr));

ret:
	return(outptr);

	end share_expression;




		    sym_sort_alphabetic.pl1         10/03/83  1728.7rew 10/03/83  1007.7       17415



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


/* This procedure is called with an array of ptrs to symbol table nodes and a
   count of the nodes.  It does a Shell sort alphabetizing the entries on the
   basis of the string in the token pointed to by the symbol.

   Modified 20 Nov 1978 by David Spector to change symbol_list from 2000 to 3072.
   Modified 25 March 1980 by M. N. Davidoff so calling sequence does not depend on pl1_symbol_print's internal limit.
*/
/* format: style3 */
sym_sort_alphabetic:
     proc (symbol_list_ptr, nn);

dcl	symbol_list_ptr	ptr;
dcl	nn		fixed bin;

dcl	list		(nn) ptr based (symbol_list_ptr);

dcl	(d, i, j, k)	fixed bin;
dcl	(p, p1, p2)	ptr;
dcl	by_size		bit (1) aligned;

dcl	divide		builtin;

%include symbol;
%include token;

/* program */

	by_size = "0"b;
	goto start;

by_size:
     entry (symbol_list_ptr, nn);

	by_size = "1"b;

start:
	d = nn;

	do while (d > 1);
	     d = 2 * divide (d, 4, 15, 0) + 1;

	     do i = 1 to nn - d;
		k = i + d;
		p2 = list (k) -> symbol.token;

up:
		j = k - d;
		p1 = list (j) -> symbol.token;

		if by_size
		then do;
			if p1 -> token.size > p2 -> token.size
			then goto inter;
			if p1 -> token.size < p2 -> token.size
			then goto ok;
		     end;

		if p1 -> token.string <= p2 -> token.string
		then goto ok;

inter:
		p = list (j);
		list (j) = list (k);
		list (k) = p;

		if j > d
		then do;
			k = j;
			goto up;
		     end;

ok:
	     end;
	end;
     end sym_sort_alphabetic;




		    token_to_binary.alm             10/03/83  1728.7rew 10/03/83  1007.8       10989



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

" Quick decimal to binary conversion program for v2pl1
" Barry L. Wolman, 17 May 1973
"
"	dcl token_to_binary entry(ptr) returns(fixed bin)
"	n = token_to_binary(p)
"
"	where p points at v2pl1 token node
"
	entry	token_to_binary
	include	token

token_to_binary:
	epp2	0|2,*		get ptr to token node
	epp2	2|0,*
	epp3	0|4,*		get ptr to output result
	lda	2|token.size	get size of string
	ldq	2|token.string	get first character of string
	anq	=o777000,du
	cmpq	=a+,du		check for leading + or -
	tze	signed
	cmpq	=a-,du
	tze	signed
	dtb	(pr,rl),(pr)	convert unsigned
	desc9ns	2|token.string,al
	desc9a	3|0,4
	short_return
signed:
	dtb	(pr,rl),(pr)	convert signed
	desc9ls	2|token.string,al
	desc9a	3|0,4
	short_return
	end




		    tree_manager.pl1                10/03/83  1728.7rew 10/03/83  1007.8       28053



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


/*	This procedure and entries manage the multiple segments used for free
   storage by the pl1 and fortran compilers.			*/

/*	Extensively rewritten to use standard no-free areas for the
compiler's own storage and thus eliminate the compiler's use of
the "rename" option in April,1976 by RHS.

	Modified:	4 May 1977 by RAB for new release_area_ protocol	*/

tree_manager$init: proc (abort_label_par);

dcl  abort_label_par label;

dcl  abort_label label internal static;

dcl  pl1_stat_$condition_index fixed bin (31) ext static,
     pl1_stat_$root ptr ext static,
     pl1_stat_$free_ptr (18) ptr ext static;

dcl  sys_info$max_seg_size ext static fixed bin (35);

dcl  i fixed bin (17);
dcl  code fixed bin (35);


dcl  first_time bit (1) aligned internal static init ("1"b);

dcl (null, addr, ptr, substr, unspec) builtin;


dcl  define_area_ external entry (ptr, fixed bin (35)),
     release_area_ external entry (ptr),
     ioa_ entry options (variable);

%include area_info;
%include pl1_tree_areas;

dcl 1 my_area_info like area_info internal static;


%include token_list;
%include source_list;

	abort_label = abort_label_par;		/* Where to go if call to define or release_area fails. */

	if pl1_stat_$tree_area_ptr ^= null
	then call release_area_ (pl1_stat_$tree_area_ptr);

	if pl1_stat_$xeq_tree_area_ptr ^= null
	then call release_area_ (pl1_stat_$xeq_tree_area_ptr);


	if first_time
	then do;
	     unspec (my_area_info) = "0"b;
	     my_area_info.version = 1;
	     my_area_info.extend = "1"b;
	     my_area_info.no_freeing = "1"b;
	     my_area_info.owner = "pl1";
	     my_area_info.size = sys_info$max_seg_size;
	     first_time = "0"b;
	end;


	my_area_info.areap = null;

	call define_area_ (addr (my_area_info), code);

	if code ^= 0
	then goto call_failed;

	pl1_stat_$tree_area_ptr = my_area_info.areap;

	allocate source_list in (tree_area) set (pl1_stat_$source_list_ptr);

	allocate token_list in (tree_area) set (pl1_stat_$token_list_ptr);

	my_area_info.areap = null;

	call define_area_ (addr (my_area_info), code);

	if code ^= 0
	then goto call_failed;

	pl1_stat_$xeq_tree_area_ptr = my_area_info.areap;

tr:
	do i = 1 to 18;
	     pl1_stat_$free_ptr (i) = null;
	end;

	pl1_stat_$condition_index = 0;

	return;

call_failed:
	call ioa_ ("Compiler failed in allocating temporary storage.");
	goto abort_label;

tree_manager$truncate: entry;

	pl1_stat_$root = null;
	if pl1_stat_$tree_area_ptr ^= null
	then call release_area_ (pl1_stat_$tree_area_ptr);
	if pl1_stat_$xeq_tree_area_ptr ^= null
	then call release_area_ (pl1_stat_$xeq_tree_area_ptr);

	goto tr;

     end;




*/
                                          -----------------------------------------------------------


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

*/
