



		    alloc_semantics.pl1             07/31/89  1431.7r w 07/31/89  1338.4       82233



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


alloc_semantics:	proc(cur_block,stmnt,tree);

/*	Modified: 14 August 1978 by PCK to fix 1735
	Modified:	15 August 1978 by RAB to fix 1733
	Modified:	16 August 1978 by RAB to fix 1772, 1773, & 1774	*/
/*	Modified: 15 Jan 1979 by DS to fix 1783 */

dcl	(cur_block,stmnt,tree) ptr,
	(a,adam,area,b,d,dst,l,locator,next,o,p,r,s,source,size,st) ptr,

	(n,i,processed_bounds,own_num_bounds,number) fixed bin(15);

dcl	(null,hbound,string) builtin;

dcl	ref_targ_cnt fixed bin(15) init(0);

dcl 	ref_targ(16) pointer;

dcl	pl1_stat_$use_old_area external static bit(1) aligned;

dcl	opcode bit(9) aligned;

%include semant;

%include array;
%include boundary;
%include list;
%include nodes;
%include operator;
%include op_codes;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include symbol_bits;
%include system;

	source = tree->operand(1);

	if source->node.type = label_node
	then	call semantic_translator$abort(373,source);	/* alloc or free a label constant */

	s = source->reference.symbol;

	if s->node.type = label_node
	then	call semantic_translator$abort(373,s);	/* alloc or free a label constant array */

	if s->symbol.father^=null
	then	call semantic_translator$abort(273,s);

	area = tree->operand(2);
	locator = source->reference.qualifier;

	st = stmnt;
	context = "0"b;

	if tree->operator.op_code=allot_var
	then	number = 5;	/* allot_var */
	else	number = 151;	/* free_var */

	if s->symbol.controlled
	then do;
		if area ^= null then call semantic_translator$abort(114,s);
		r = s->symbol.descriptor;
		d = r->reference.symbol;
		if d->symbol.controlled
		then if number = 5
		     	then do;  /* We must allocate a controlled descriptor before we allocate the symbol */
				dst = create_statement(allocate_statement,(st->statement.back),null,(st->statement.prefix));
				dst->statement.root,
				o = create_operator(allot_ctl,2);
				o->operand(1) = r;
				o->operand(2) = declare_constant$integer((d->symbol.c_word_size));
				r = declare_descriptor$ctl(cur_block,st,s,null,"1"b);
				o->operator.processed = "1"b;
			     end;
			else do;  /* We must free a controlled descriptor after we free the data */
				st = create_statement(free_statement,st,null,(st->statement.prefix));
				st->statement.root,
				o = create_operator(free_ctl,1);
				o->operand(1) = r;
				o->operator.processed = "1"b;
			     end;
		else;
		if number = 5
		then do;
			o = create_operator(allot_ctl,2);
			call getsize;
			o->operand(2) = size;
		     end;
		else o = create_operator(free_ctl,1);
		o->operand(1) = source;
		tree = o;
		if number = 151
		     then return;
		     else go to set_next;
	end;

	if ^s->symbol.based
	then	call semantic_translator$abort(115,s);

	if number=151
	then	goto process_area;

	if locator->node.type=operator_node
	then	if locator->operator.op_code=assign | locator->operator.op_code = ptr_fun
		then do;
			locator = locator->operand(2);
			l = locator->reference.symbol;
		end;
		else call semantic_translator$abort(68,s);
	else	l = locator->reference.symbol;

	call propagate_bit(l,set_bit);

	if l->symbol.offset
	then	if area=null
		then do;
			area = copy_expression(l->symbol.general);

			if area=null
			then	call semantic_translator$abort(116,l);

			area = expression_semantics((l->symbol.block_node),stmnt,area,"0"b);

			goto assign_ptr;
		end;
		else do;
			st = create_statement(assignment_statement,st,null,(st->statement.prefix));
			st->statement.root  ,
			o = create_operator(off_fun,3);
			o->operand(3) = share_expression(area);

			o->operand(1) = locator;

			locator  ,
			o->operand(2) = declare_pointer(cur_block);

			st->statement.processed = "1"b;

			goto create_addr;
		end;

	if ^l->symbol.ptr
	then	call semantic_translator$abort(117,l);

	if l->symbol.unaligned & pl1_stat_$use_old_area	/* the new area package needs no  ass. stat at all */
	then do;
assign_ptr:
				/* allot_var */
		st = create_statement(assignment_statement,st,null,(st->statement.prefix));
		st->statement.root  ,
		o = create_operator(assign,2);
		o->operand(1) = locator;
		locator  ,
		o->operand(2) = declare_pointer(cur_block);
	end;

process_area:
	if area^=null
	then do;
		if area->node.type^=reference_node
		then	call semantic_translator$abort(491,null);

		if ^area->reference.symbol->symbol.area
		then	call semantic_translator$abort(118,area);
	end;
	else if pl1_stat_$use_old_area
	     then do;
		area = reserve$declare_lib(1);
		area->reference.symbol->symbol.allocate = "1"b;

		if number=5
		then	number = 192;		/* alloc_$storage_ */
		end;

create_addr:
	call getsize;	/* this subroutine sets the "size" ptr	*/

	if pl1_stat_$use_old_area
	then do;

		p = create_operator(addr_fun,2);
		p->operand(1) = declare_temporary(pointer_type,0,0,null);
		p->operand(2) = area;
		area = p;

		p = create_list(3);
	
		p->list.element(2) = area;
	
		if number=5	/* allot_var */
		|  number=192			/* alloc_$storage_ */
		then do;
			p->list.element(1) = size;
			p->list.element(3) = locator;
		end;
		else do;
			p->list.element(1) = locator;
			p->list.element(3) = size;
		end;
	
		o = create_operator(std_call,3);
		o->operand(2) = reserve$declare_lib(number);
		o->operand(3) = create_operator(std_arg_list,3);
		o->operand(3)->operand(1) = declare_temporary(storage_block_type,8,0,null);
		o->operand(3)->operand(2) = p;
	
	     end;

	else do;
		if number = 151
		then do;
			opcode = free_based;
			p = source;	/* op1 of free_based operator is source ptr, i.e. based var */
		     end;
		else do;
			opcode = allot_based;
			p = locator;	/* op1 of allot_based is locator ptr */
		     end;

		o = create_operator(opcode,3);
		o->operand(2) = size;
		o->operand(3) = area;
		o->operand(1) = p;

	     end;


	tree = o;

	if number=151 then return;

	goto set_next;

init_only:entry(locexp,stmnt,tree);
	dcl locexp ptr;

	st=stmnt;
	locator=locexp;
	s=tree;

set_next:
	next = st->statement.next;

	adam = s;

	do while(s ^= null);
		if s ^= adam
		then do;
			if s->symbol.refer_extents
			then do;
				call build_assignment(s->symbol.dcl_size);

				if s->symbol.array^=null 
				then do;
					own_num_bounds=s->symbol.array->own_number_of_dimensions;
					processed_bounds=0;

					do b = s->symbol.array->array.bounds repeat b->bound.next
					     while(processed_bounds < own_num_bounds);
						call build_assignment(b->bound.lower);
						call build_assignment(b->bound.upper);
						processed_bounds=processed_bounds+1;
					end;
				end;
			end;
		end;

		if s->symbol.initial^=null
		|  s->symbol.area
		then	call expand_initial(s,(next->statement.back),locator);

		if s -> symbol.son ^= null
		then	s = s -> symbol.son;
		else do;
			do while(s->symbol.brother=null & s ^= adam);
				s = s->symbol.father;
			end;

			s = s->symbol.brother;
		end;

	end;

getsize:	proc;

dcl 	constant fixed bin;
dcl	modified bit(1) aligned;

	size = copy_expression(s->symbol.word_size);
	if size=null
	then	size = declare_constant$integer((s->symbol.c_word_size));
	else do;
		if number=151 & s->symbol.refer_extents
		then	call refer_extent(size,locator);
		size = expression_semantics((s->symbol.block_node),stmnt,size,context);
		size = convert$to_integer(size,integer_type);
		call simplify_expression(size,constant,modified);
		if modified
		then	size=declare_constant$integer((constant));
	end;

	p = size;
	if p->node.type=operator_node
	then 	p = p->operand(1);

	if p->reference.symbol->symbol.c_dcl_size>max_p_fix_bin_1
	then do;
		r = create_operator(assign,2);
		r->operand(1) = declare_temporary(integer_type,max_p_fix_bin_1,0,null);
		r->operand(2) = size;
		size = r;
	end;
end;

build_assignment:	proc(p);

dcl	p ptr unal,
	(o,q,st) ptr;

	q = p;

	if q = null then goto exit;
	if q->node.type^=operator_node then goto exit;
	if q->operator.op_code^=refer then goto exit;
	do i=1 to ref_targ_cnt;
		if q->operator.operand(2)=ref_targ(i) 
		then goto exit;
		else 	if compare_expression((q->operator.operand(2)),ref_targ(i))
			then goto exit;
	end;

	st = create_statement(assignment_statement,(next->statement.back),null,(stmnt->statement.prefix));

	st->statement.generated = "1"b;
	st->statement.root  ,
	o = create_operator(assign,2);
	o->operand(2) = copy_expression(q->operand(1));

	if q->operand(2)->node.type=reference_node
	then	o->operand(1) = copy_expression(q->operand(2));
	else	o->operand(1) = create_reference((q->operand(2)));

	o->operand(1)->reference.qualifier = share_expression(locator);

	if ref_targ_cnt<hbound(ref_targ,1) 
	then do;
		ref_targ_cnt=ref_targ_cnt+1;
		ref_targ(ref_targ_cnt)=q->operator.operand(2);
	end;

exit:
	end build_assignment;

	end alloc_semantics;




		    builtin.pl1                     07/31/89  1431.7rew 07/31/89  1329.4     1010817



/****^  ******************************************************
        *                                                    *
        * Copyright, (C) Honeywell Bull Inc., 1987           *
        *                                                    *
        * 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):
     Fixes bugs #1926,2145
  2) change(87-06-26,Huen), approve(87-06-26,MCR7712), audit(87-12-01,RWaters),
     install(87-12-01,MR12.2-1005):
     Fix bug2042
  3) change(88-01-29,RWaters), approve(88-01-29,MCR7724), audit(88-02-05,Huen),
     install(88-02-16,MR12.2-1024):
     Allow option(constant) variables as arguments to builtin functions.
  4) change(89-03-28,Huen), approve(89-03-28,MCR8077), audit(89-04-03,JRGray),
     install(89-04-24,MR12.3-1032):
     Fix bug 2193 - Display the existing error message (#127) when the first
     argument to hbound builtin is not an array value.
  5) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu),
     install(89-07-31,MR12.3-1066):
     Fix reference thru null pointer in action (33).
                                                   END HISTORY COMMENTS */

/* format: style2,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
builtin:
     proc (cur_block, statement_ptr, input_tree, subscripts, builtin_symbol, context) returns (ptr);

/* Modified 770617 by PG to add clock, vclock, stacq
   Modified 780213 by RAB to fix 1707	
   Modified 780329 by PCK to add stackframeptr, stackbaseptr, environmentptr, and codeptr builtins
   Modified 780412 by PG to fix 1723, and to fix unreported bugs in decat and unspec
   Modified 780807 by RAB to fix 1749
   Modified 780824 by PCK to fix 1701, 1766, and 1777
   Modified 780825 by RAB to fix 1780
   Modified Dec 1978 by David Spector to make addr arg non-set xref
   Modified 790416 by PCK to implement 4-bit decimal fix bugs 1826 and 1830
   Modified 790516 by RAB for reference.substr
   Modified 790606 by PG to add byte and rank
   Modified 791107 by BSG for index (reverse) etc.
   Modified: 26 Dec 1979 by PCK to implement by name assignment
   Modified 820726 by BIM for segno, wordno
   Modified 830909 by BIM never to have bif return unsigned.
		assign_op gets CONFUSED.
   Modified 870727 by RW to fix phx16821 & phx16584, invalid substr ranges.
   Modified 870523 by SH to fix bug 2042 by displaying new error 390 if the
		argument used in rank builtin is not a non_varying
		character string of length 1.
   Modified 880129 by RW to fix bug 1994 and bug 2186.
   Modified 890302 by SH to display error 127 if the first argument to hbound
	         builtin is not an array value. (pl1_2193)
   Modified 890714 by RW to check for null pointer in action(33)
*/

	dcl      (cur_block, builtin_symbol, statement_ptr, subscripts, input_tree, tree) ptr;

	dcl      (
	         arg (128),
	         ref (128),
	         arg_symbol (128),
	         length,
	         offset,
	         p,
	         q,
	         r,
	         rlength,
	         s,
	         t,
	         off,
	         save_arg_one
	         ) ptr,
	         cur_length (2) ptr,
	         (agg_ref, dcl_length) ptr init (null),
	         (units, cunits) fixed bin (3),
	         error_number fixed bin (15),
	         constant fixed bin,
	         (arg_number, builtin_number, code, i, indicator, jump_index, m, reserved_number, rprecision, rscale,
	         temp_size) fixed bin (31),
	         (c_length, c_offset, coff, integer, number, substr_index, p1, p2, q1, q2, rcount) fixed bin (31),
	         integer_24 fixed bin (24),
	         based_type bit (36) based,
	         (desc_reqd, decimal_result, arith_size_ck, string_size_ck) bit (1) aligned init ("0"b),
	         pseudo_variable bit (1) aligned init ("0"b),
	         (full_attribute_set, not_flag) bit (1) aligned,
	         bit4 bit (4) aligned,
	         modified bit (1) aligned,
	         opcode bit (9) aligned,
	         constant_string_length fixed bin (21),
	         constant_char_string char (constant_string_length) based,
	         constant_bit_string bit (constant_string_length) based,
	         builtin_string char (8) aligned,
	         collating_sequence char (128) aligned internal static init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

	dcl      pl1_data$long_collating_sequence char (512) aligned ext static;

	dcl      pl1_stat_$use_old_area bit (1) aligned ext static,
	         pl1_stat_$check_ansi bit (1) aligned ext static,
	         pl1_stat_$eis_mode bit (1) aligned ext static,
	         pl1_stat_$root ptr ext static,
	         pl1_stat_$cur_statement ptr ext static;

	dcl      (addr, bit, divide, fixed, max, min, null, reverse, string, substr, unspec) builtin;

/*
abs		13
acos		54
add		14
addr		33
addrel		41
after		55

allocation	36
asin		54
atan		25
atand		25
atanh		25
baseno		39
segno               70

baseptr		41
before		56
bin		15
binary		15
bit		18

bool		23
byte		68
ceil		16
char		18
clock		62
codeptr		63
collate		 1
collate9		59

complex		17
conjg		50
convert		46
copy		 9
cos		25

cosd		25
cosh		25
cplx		17
currentsize	64
date		31
dec		15

decat		24
decimal		18
dim		26
divide		14
dot		45

empty		28
environmentptr	63
erf		25
erfc		25
exp		25
fixed		 3

float		 2
floor		16
hbound		26
high		 5
high9		60

imag		19
index		 6
lbound		26
length		 7
lineno		30

log		25
log10		25
log2		25
low		 8
ltrim		57

max		20
maxlength		65
min		20
mod		21
multiply		14
null		29

nullo		44
onchar		51
oncode		53
onfield		42
onfile		42

onkey		42
onloc		42
onsource		52
pageno		30
pointer		34

prec		 4
prod		43
ptr		34
rank		69
real		19
rel		39
wordno		71
charno		72
bitno		73
addwordno 	41
addcharno 	41
addbitno		41
setwordno 	41
setcharno 	41
setbitno		41

reverse		27
round		22
rtrim		58
search		37
sign		38

sin		25
sind		25
sinh		25
size		47
sqrt		25

stac		40
stackbaseptr	61
stackframeptr	61
stacq		66
string		10
substr		11
substraddr	67
subtract		14
sum		43
tan		25

tand		25
tanh		25
time		32
translate		49
trunc		16

unspec		12
valid		48
vclock		62
verify		37
*/

	dcl      1 rtype like type;

	dcl      1 arg_type (128) like type;

	dcl      defined_arg_type (128) bit (36) defined (arg_type);

	dcl      1 as_if_type (128) like type;

	dcl      defined_as_if_type (128) bit (36) defined (as_if_type);

	dcl      targ_type bit (36) aligned;
	dcl      targ_prec fixed bin (31);

	dcl      save_context bit (36),
	         1 def_save_context defined (save_context),
		 2 aggregate bit (1),
		 2 arg_list bit (1),
		 2 left_side bit (1),
		 2 return bit (1),
		 2 evaluate_offset bit (1),
		 2 top bit (1),
		 2 RHS_aggregate bit (1),
		 2 return_from_empty bit (1),
		 2 ignore_based bit (1),
		 2 ext_param bit (1),
		 2 cross_section bit (1),
		 2 string_unspec bit (1);

	tree = input_tree;

	if def_context.top then
	     if statement_ptr -> statement.statement_type = call_statement then
		call semantic_translator$abort (224, builtin_symbol);

	if subscripts = null then
	     arg_number = 0;
	else
	     arg_number = subscripts -> list.number;

	builtin_number = builtin_symbol -> symbol.c_dcl_size;
	opcode = pl1_data$builtin_name.description (builtin_number).opcode;
	jump_index = pl1_data$builtin_name.description (builtin_number).jump_index;
	reserved_number = pl1_data$builtin_name.description (builtin_number).reserve_list_number;

	if pl1_stat_$check_ansi then
	     if pl1_data$builtin_name.description (builtin_number).nonstandard then
		call semantic_translator$error (202, builtin_symbol);


	indicator = pl1_data$builtin_name.description (builtin_number).check_indicator;

	if indicator = 1 then
	     if arg_number ^= pl1_data$builtin_name.description (builtin_number).number1 then
		call semantic_translator$abort (121, builtin_symbol);
	     else
		;
	else if indicator = 2 then
	     if arg_number < pl1_data$builtin_name.description (builtin_number).number1 then
		call semantic_translator$abort (122, builtin_symbol);
	     else
		;
	else if indicator = 3 then
	     if arg_number < pl1_data$builtin_name.description (builtin_number).number1
		| arg_number > pl1_data$builtin_name.description (builtin_number).number2 then
		call semantic_translator$abort (123, builtin_symbol);

	if def_context.left_side then do;
	     builtin_string = builtin_symbol -> symbol.token -> token.string;

	     if builtin_string ^= "real" & builtin_string ^= "imag" & builtin_string ^= "string"
		& builtin_string ^= "substr" & builtin_string ^= "unspec" & builtin_string ^= "onchar"
		& builtin_string ^= "onsource" & builtin_string ^= "pageno" then
		call semantic_translator$abort (244, builtin_symbol);
	     else
		pseudo_variable = "1"b;
	end;

	save_context = "0"b;

	do i = 1 to arg_number;

	     this_context = "0"b;
	     if i = 1 & (jump_index = 10 | jump_index = 12 | jump_index = 33) /*  string, unspec, addr */ then do;
		def_this_context.evaluate_offset = "1"b;

		if jump_index ^= 33 then
		     def_this_context.string_unspec = "1"b;
	     end;

	     if (jump_index = 46 & i = 1) /* convert */ | jump_index = 47 /* size */ then
		def_this_context.ignore_based = "1"b;

	     if i = 1
		& (def_context.f_offset_to_be_added | jump_index = 11 /* substr */
		| (jump_index >= 55 & jump_index <= 58)) /* after, before, ltrim, rtrim */ then
		def_this_context.f_offset_to_be_added = "1"b;

	     arg (i) =
		expression_semantics (cur_block, statement_ptr, (subscripts -> element (arg_number + 1 - i)),
		this_context);

	     if def_this_context.aggregate then do;
		if pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code = 5 then
		     if jump_index ^= 11 /* substr */ then
			goto err124;

		if pl1_data$builtin_name.description (builtin_number).aggregate_result then
		     if ^def_context.by_name_assignment then do;
			subscripts -> element (arg_number + 1 - i), arg (i) =
			     expand_primitive (cur_block, statement_ptr, arg (i), this_context);
		     end;
		     else
			go to err381;
	     end;

	     save_context = save_context | this_context;

	     ref (i) = arg (i);

	     do while (ref (i) -> node.type = operator_node);
		ref (i) = ref (i) -> operand (1);
	     end;

	     if ref (i) -> node.type = token_node then do;
		ref (i), arg_symbol (i) = null;
		if arg (i) -> token.type = dec_integer then
		     defined_arg_type (i) = dec_integer_type;
		else
		     defined_arg_type (i) = decoded_type (fixed (arg (i) -> token.type, 15));
	     end;
	     else if ref (i) -> node.type = label_node then do;
		arg_symbol (i) = ref (i);
		ref (i) = null;
		defined_arg_type (i) = "0"b;
	     end;
	     else if ref (i) -> node.type = reference_node then do;
		arg_symbol (i) = ref (i) -> reference.symbol;
		defined_arg_type (i) =
		     substr (string (arg_symbol (i) -> symbol.attributes), 1, 36) & ^dimensioned_mask
		     & ^initialed_mask;
	     end;
	end;

	this_context = "0"b;

/*   Processing of aggregate arguments   */

	if def_save_context.aggregate then
	     if pl1_data$builtin_name.description (builtin_number).aggregate_result then do;
		if jump_index = 24 /*   decat   */ then
		     call semantic_translator$abort (478, builtin_symbol);

		if def_context.left_side then
		     call propagate_bit (arg_symbol (1), set_bit);

		def_context.aggregate = "1"b;
		tree = expand_arguments ();

		goto exit;
	     end;

	do i = 1 to min (arg_number, pl1_data$builtin_name.description (builtin_number).number_of_descriptions);

	     code = pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code;
	     string (type) = pl1_data$builtin_name.description (builtin_number).descriptor (i).type;

	     if code = 0 then
		goto next_descriptor;

	     if code = 1 then
		if string (type) & defined_arg_type (i) then
		     goto conv_arg;
		else
		     goto err124;

	     if code = 2 then
		goto conv_arg;

	     if code = 3 | code = 11 then do;
		if code = 11 then
		     if arg_type (i).complex then
			goto err124;

		if arg_type (i).picture | arg_type (i).decimal | arg_type (i).char then do;
		     if arg_type (i).decimal then
			string (type) = defined_arg_type (i) & ^fixed_mask | float_mask;
		     else if arg_type (i).complex then
			string (type) = float_decimal_complex_mask;
		     else
			string (type) = float_decimal_real_mask;
		     t = convert$from_builtin ((arg (i)), string (type));
						/* call by value to protect arg(i) */
		     if t -> node.type = operator_node then
			t = t -> operand (1) -> reference.symbol;
		     else
			t = t -> reference.symbol;
		     targ_type = string (type);
		     if decimal_result then
			targ_prec = max (targ_prec, t -> symbol.c_dcl_size);
		     else if i = 1 then do;
			decimal_result = "1"b;
			targ_prec = t -> symbol.c_dcl_size;
		     end;
		end;
		string (type) = float_mask | binary_mask;
		goto conv_arg;
	     end;

	     if code = 4 then do;
		if arg_type (i).bit then
		     string (type) = fixed_binary_real_mask;
		else if arg_type (i).char then
		     string (type) = fixed_decimal_real_mask;
		else if arg_type (i).picture then
		     if arg_symbol (i) -> symbol.complex then
			if arg_symbol (i) -> symbol.pix.pic_float then
			     string (type) = float_decimal_complex_mask;
			else
			     string (type) = fixed_decimal_complex_mask;
		     else if arg_symbol (i) -> symbol.pix.pic_float then
			string (type) = float_decimal_real_mask;
		     else
			string (type) = fixed_decimal_real_mask;
		else if defined_arg_type (i) & arithmetic_mask then
		     string (type) = defined_arg_type (i);
		else
		     goto err124;

		goto conv_arg;
	     end;

	     if code = 5 then do;
		string (type) = fixed_binary_real_mask;

		if arg_type (i).fixed | arg_type (i).float then do;
		     ref (i), arg (i) = convert$to_integer (arg (i), integer_type);

		     if ref (i) -> node.type = operator_node then do;
			ref (i) -> operator.processed = "1"b;
			ref (i) = ref (i) -> operand (1);
		     end;

		     arg_symbol (i) = ref (i) -> reference.symbol;
		     defined_arg_type (i) = integer_type;

		     goto next_descriptor;
		end;

		goto conv_arg;
	     end;

	     if code = 6 then do;
		if arg (i) -> node.type = reference_node then
		     if symbol_is_constant (arg_symbol (i)) then
			if ^arg_type (i).fixed | ^arg_type (i).binary | ^arg_type (i).real then
			     arg (i) = subscripts -> element (arg_number + 1 - i);
			else
			     goto next_descriptor;
		     else
			goto err124;

		if arg (i) -> node.type ^= token_node then
		     goto err124;


		if arg (i) -> token.type ^= dec_integer then
		     goto err124;

		string (type) = fixed_binary_real_mask;

		goto conv_arg;
	     end;

	     if code = 7 then do;
		if arg_type (i).bit | arg_type (i).char then
		     string (type) = defined_arg_type (i);
		else if arg_type (i).binary | arg_type (i).picture | arg_type (i).decimal then
		     string (type) = char_mask;
		else
		     goto err124;

		goto conv_arg;
	     end;

	     if code = 8 then do;
		if arg_type (i).bit then
		     string (type) = bit_mask;
		else if arg_type (i).fixed | arg_type (i).float then do;
		     ref (i), arg (i) = convert$to_integer (arg (i), integer_type);

		     if ref (i) -> node.type = operator_node then do;
			ref (i) -> operator.processed = "1"b;
			ref (i) = ref (i) -> operand (1);
		     end;

		     arg_symbol (i) = ref (i) -> reference.symbol;
		     defined_arg_type (i) = integer_type;

		     go to next_descriptor;
		end;
		else
		     string (type) = fixed_binary_real_mask;

		go to conv_arg;

	     end;

	     if code = 9 then
		if ref (i) = null then
		     goto err124;
		else
		     goto next_descriptor;

	     if code = 10 then do;
		if (defined_arg_type (i) & computational_mask) = "0"b then
		     goto err124;

		goto next_descriptor;
	     end;

	     if code = 12 then do;
		if ^arg_type (i).label & ^arg_type (i).entry & ^arg_type (i).format
		     & arg (i) -> node.type ^= label_node then
		     go to err124;
		go to next_descriptor;
	     end;

conv_arg:
	     call convert_arg;

next_descriptor:
	end;

	string (rtype) = defined_arg_type (1) & ^unaligned_mask | aligned_mask;

	rprecision, rscale = 0;
	rlength = null;

	do i = 1 to arg_number;
	     if ref (i) ^= null then
		if ref (i) -> reference.varying_ref then do;
		     if i = 1 then
			if jump_index = 9 /* copy */ | jump_index = 24 /* decat */ | jump_index = 27 /* reverse */
			     | jump_index = 49 /* translate */ then do;
			     rlength = create_length_fun (arg (1));
			     string (rtype) = string (rtype) & ^varying_mask;
			end;
		end;
	end;

	if arg_number ^= 0 & arg_symbol (1) ^= null then
	     if arg_symbol (1) -> node.type = symbol_node then do;
		rprecision = arg_symbol (1) -> symbol.c_dcl_size;
		if arg_type (1).bit | arg_type (1).char then
		     if rlength = null then
			rprecision = ref (1) -> reference.c_length;
		     else
			rprecision = 0;

		rscale = fixed (arg_symbol (1) -> symbol.scale, 31, 0);

		if ref (1) ^= null & rlength = null then
		     if jump_index = 9 /* copy */ | jump_index = 24 /* decat */ | jump_index = 27 /* reverse */
			| jump_index = 49 /* translate */ then do;
			rlength = share_expression ((ref (1) -> reference.length));
			string (rtype) = string (rtype) & ^varying_mask;
		     end;

	     end;

	goto action (jump_index);

action (0):
	call semantic_translator$abort (131, builtin_symbol);
	goto ret;

action (1):					/* collate */
	tree = declare_constant$char (collating_sequence);

	goto ret;

action (2):					/* float */
	string (rtype) = float_mask;

	if arg_number = 2 then
	     rprecision = constant_value (arg_symbol (2));
	else do;
	     rprecision = 0;
	     if pl1_stat_$check_ansi then
		call semantic_translator$error (172, builtin_symbol);
	end;

	goto convert_to_arith;

action (3):					/* fixed */
						/* Warn users away from fixed(<dec_integer_constant>...) */
	if arg (1) -> node.type = token_node then
	     if arg (1) -> token.type = dec_integer then
		call semantic_translator$error (484, null);

	string (rtype) = fixed_mask;

	if arg_number = 3 then
	     rscale = constant_value (arg_symbol (3));
	else
	     rscale = 0;

	if arg_number >= 2 then
	     rprecision = constant_value (arg_symbol (2));
	else do;
	     rprecision = 0;
	     if pl1_stat_$check_ansi then
		call semantic_translator$error (172, builtin_symbol);
	end;

	goto convert_to_arith;

action (4):					/* prec
   precision */
	if arg_type (1).char then
	     string (rtype) = fixed_decimal_real_mask | aligned_mask;
	else if arg_type (1).bit then
	     string (rtype) = fixed_binary_real_mask | aligned_mask;

	if arg_type (1).float & arg_number = 3 then
	     call semantic_translator$abort (167, builtin_symbol);

	if arg_number = 3 then
	     rscale = constant_value (arg_symbol (3));

	rprecision = constant_value (arg_symbol (2));

	full_attribute_set = "1"b;

	goto check_prec_scale;

action (5):					/* high */
	arg (2) = arg (1);
	ref (2) = ref (1);
	arg_symbol (2) = arg_symbol (1);

	arg (1), ref (1) = declare_constant ("001111111"b, char_type, 1, 0);
	arg_symbol (1) = arg (1) -> reference.symbol;

	arg_number = 2;
	string (rtype) = char_type;

	goto repeat;

action (6):					/* index */
	if arg_type (1).bit & arg_type (2).bit then
	     string (type) = bit_mask;
	else
	     string (type) = char_mask;

	do i = 1 to 2;
	     call convert_arg;
	end;

	if type.char then
	     if check_reverse (arg (1)) then do;
		opcode = index_rev_fun;		/* Will use reverse index */
		arg (1) = arg (1) -> operator.operand (2);
						/* Use the unreversed thing */
		if check_reverse (arg (2)) /* If 2 is a reverse too, .. */ then
		     arg (2) = arg (2) -> operator.operand (2);
						/* Eliminate it.. or */
		else
		     arg (2) = make_builtin_reference ("reverse", 1, arg (2), null, null);
	     end;

	string (rtype) = fixed_binary_real_mask;
	rprecision = max_length_precision;

	goto create_operator_node;

action (7):					/* length */
action (65):					/* maxlength */
	if arg (1) -> node.type = operator_node then
	     if arg (1) -> op_code = std_call then do;
		s = create_statement (call_statement, (statement_ptr -> statement.back), null,
		     (statement_ptr -> statement.prefix));
		s -> statement.root = share_expression (arg (1));
	     end;

	if ref (1) -> reference.varying_ref then do;
	     if jump_index = 7 then do;

/* length */

		string (rtype) = integer_type;
		rprecision = max_length_precision;
		goto create_operator_node;
	     end;

	     else do;

/* maxlength */

		if arg_symbol (1) -> symbol.dcl_size = null then
		     tree = declare_constant$integer ((arg_symbol (1) -> symbol.c_dcl_size));
		else do;
		     tree = copy_expression (arg_symbol (1) -> symbol.dcl_size);
		     if arg_symbol (1) -> symbol.refer_extents then
			call refer_extent (tree, (ref (1) -> reference.qualifier));
		     tree = expression_semantics ((arg_symbol (1) -> symbol.block_node), statement_ptr, tree, "0"b);
		     tree = convert$to_integer (tree, integer_type);
		end;

		goto ret;
	     end;
	end;

	if ref (1) -> reference.length = null then
	     tree = declare_constant$integer ((ref (1) -> reference.c_length));
	else
	     tree = ref (1) -> reference.length;

	goto ret;

action (8):					/* low */
	arg (2) = arg (1);
	ref (2) = ref (1);
	arg_symbol (2) = arg_symbol (1);

	arg (1), ref (1) = declare_constant ("000000000"b, char_type, 1, 0);
	arg_symbol (1) = arg (1) -> reference.symbol;

	arg_number = 2;
	string (rtype) = char_type;

	goto repeat;

action (9):					/* copy */
repeat:
	if symbol_is_constant (arg_symbol (2)) then
	     m = constant_value (arg_symbol (2));

	if ref (1) -> reference.varying_ref then
	     length = rlength;
	else if ref (1) -> reference.length ^= null then
	     length = ref (1) -> reference.length;
	else if ^symbol_is_constant (arg_symbol (2)) then
	     length = declare_constant$integer ((ref (1) -> reference.c_length));
	else
	     length = null;

	if length ^= null then do;
	     rprecision = 0;
	     arg (2) = share_expression (arg (2));
	     if ref (1) -> reference.c_length = 1 then
		rlength = arg (2);
	     else do;
		rlength = create_operator (mult, 3);
		rlength -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
		rlength -> operand (2) = length;
		rlength -> operand (3) = arg (2);
		rlength -> operator.processed = "1"b;
	     end;
	end;
	else do;
	     rprecision = ref (1) -> reference.c_length * max (m, 0);
	     if jump_index ^= 9 /* we have told users we will NOT optimize this for copy */ then
		if m = 1 then
		     goto return_arg1;
	end;

	goto create_operator_node;

action (10):					/* string */
	if arg (1) -> node.type = token_node then do;
	     i = 1;
	     if arg_type (1).bit then
		string (type) = defined_arg_type (1);
	     else
		string (type) = char_mask;

	     call convert_arg;

	     if def_context.left_side then
		call semantic_translator$abort (141, builtin_symbol);

	     goto return_arg1;
	end;

	if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
	     arg (1), ref (1) = copy_expression ((ref (1)));

	string (rtype) = defined_arg_type (1);

	if def_context.left_side then
	     call propagate_bit (arg_symbol (1), set_bit);

	if arg (1) -> node.type = operator_node then do;
	     if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join | arg_type (1).structure
		| ref (1) -> reference.array_ref then
		call semantic_translator$abort (294, builtin_symbol);

	     i = 1;
	     if arg_type (1).bit then
		string (type) = defined_arg_type (1);
	     else
		string (type) = char_mask;

	     call convert_arg;

	     if def_context.left_side then
		call semantic_translator$abort (141, builtin_symbol);

	     goto return_arg1;
	end;

	if arg_type (1).structure then do;
	     p = arg_symbol (1);
	     do while (p -> symbol.structure);
		p = p -> symbol.son;
	     end;

	     if p -> symbol.bit then
		units = bit_;
	     else if p -> symbol.char | p -> symbol.picture then
		units = character_;
	     else
		goto err124;

	     call check_strings ((arg_symbol (1) -> symbol.son));

	     goto aggregate;
	end;

	if arg_type (1).bit | arg_type (1).char | arg_type (1).picture then do;
	     if ^ref (1) -> reference.array_ref then do;
		if ^arg_type (1).picture then
		     goto return_arg1;
		else do;
		     units = character_;
		     c_length = ref (1) -> reference.c_length;
		     length = null;
		     goto make_reference;
		end;
	     end;

	     if arg_type (1).bit then
		units = bit_;
	     else
		units = character_;

	     if arg_symbol (1) -> symbol.packed then
		goto aggregate;

	     if def_context.left_side then
		call semantic_translator$abort (141, builtin_symbol);
	     else
		call semantic_translator$abort (142, builtin_symbol);
	     goto ret;
	end;
	else do;
	     if arg (1) -> reference.array_ref then
		call semantic_translator$abort (139, arg_symbol (1));

	     i = 1;
	     string (type) = char_mask;
	     call convert_arg;

	     goto return_arg1;
	end;

action (11):					/* substr */
	if rtype.bit then
	     units = bit_;
	else
	     units = character_;

	if arg (1) -> node.type = operator_node then do;
	     if def_context.left_side then
		call semantic_translator$abort (148, builtin_symbol);

	     ref (1) = arg (1) -> operand (1);
	end;
	else if def_context.left_side then do;
	     call propagate_bit (arg_symbol (1), set_bit);
	     arg_symbol (1) -> symbol.passed_as_arg = "1"b;
	end;

/* If user didn't specify 3rd argument (new length), or stringrange is enabled, save info
	   about length of first argument now. */

	if arg_number = 2 | substr (statement_ptr -> statement.prefix, 8, 1) /* stringrange */ then do;
	     if ref (1) -> reference.varying_ref then do;
		length = create_length_fun (arg (1));
		c_length = 0;
	     end;
	     else do;
		length = ref (1) -> reference.length;
		c_length = ref (1) -> reference.c_length;
		if length ^= null then
		     if arg (1) -> node.type = operator_node | ref (1) -> reference.ref_count > 1 then
			length = share_expression (length);
	     end;

	     if arg_number = 2 & substr (statement_ptr -> statement.prefix, 8, 1) then
		if length ^= null then
		     length = share_expression (length);
	end;

/* Compute (offset - 1) and save it in "offset". */

	if symbol_is_constant (arg_symbol (2)) then do;
	     offset = null;
	     c_offset = constant_value (arg_symbol (2)) - 1;
	end;
	else do;
	     c_offset = 0;

	     if arg (2) -> node.type = operator_node then
		if arg (2) -> operator.op_code = add then
		     if arg (2) -> operand (3) -> node.type = reference_node then
			if symbol_is_constant ((arg (2) -> operand (3) -> reference.symbol)) then
			     if constant_value ((arg (2) -> operand (3) -> reference.symbol)) = 1 then
				if fb1_value ((arg (2) -> operand (3) -> reference.symbol)) then do;
				     r = arg (2) -> operand (2);
				     if r -> node.type = operator_node then
					r = r -> operand (1);

				     if fb1_value ((r -> reference.symbol)) then do;
					offset = arg (2) -> operand (2);
					go to chk_context;
				     end;
				end;

	     offset = create_operator (sub, 3);
	     offset -> operand (2) = arg (2);
	     offset -> operand (3) = declare_constant$integer (1);
	end;

chk_context:
	if def_context.arg_list then do;
	     tree, p = create_operator (assign, 2);
	     r = create_symbol (null, null, by_compiler);
	     r -> symbol.temporary = "1"b;
	     p -> operand (1) = r -> symbol.reference;
	     p -> operand (2) = arg (1);
	end;

	if arg (1) -> node.type = operator_node | arg_symbol (1) -> symbol.picture then do;
	     s = create_symbol (null, null, by_compiler);
	     p = s -> symbol.reference;
	     t = ref (1) -> reference.symbol;
	     s -> symbol = t -> symbol;		/* structure assignment */
	     s -> symbol.next = null;
	     s -> symbol.reference = p;
	     s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
	     s -> symbol.return_value, s -> symbol.temporary = "0"b;
	     p -> reference.qualifier = arg (1);
	     p -> reference.shared = "0"b;
	     p -> reference.ref_count = 1;

	     if s -> symbol.picture then do;
		s -> symbol.picture = "0"b;
		s -> symbol.char = "1"b;
		s -> symbol.general = null;
	     end;

	     if arg (1) -> node.type ^= operator_node then do;

/* move the offset from the defined variable up */

		if ref (1) = arg_symbol (1) -> symbol.reference then
		     p -> reference.qualifier, ref (1) = copy_expression ((ref (1)));
		else if ref (1) -> reference.ref_count > 1 then do;
		     ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
		     r = create_reference (null);
		     r -> reference = ref (1) -> reference;
		     r -> reference.ref_count = 1;
		     call reuse_qual_and_offset (r);
		     p -> reference.qualifier, ref (1) = r;
		end;
		p -> reference.offset = ref (1) -> reference.offset;
		p -> reference.c_offset = ref (1) -> reference.c_offset;
		p -> reference.units = ref (1) -> reference.units;
		p -> reference.modword_in_offset = ref (1) -> reference.modword_in_offset;
		ref (1) -> reference.offset = null;
		ref (1) -> reference.c_offset = 0;
		ref (1) -> reference.modword_in_offset = "0"b;

/* this must not be commoned by optimizer */

		ref (1) -> reference.inhibit = "1"b;
	     end;
	end;
	else do;
	     p = create_reference ((ref (1) -> reference.symbol));
	     p -> reference = ref (1) -> reference;	/* structure assignment */
	     p -> reference.shared = "0"b;
	     p -> reference.ref_count = 1;
	     if ^ref (1) -> reference.shared then do;
		rcount, ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
		if rcount > 0 then
		     call reuse_qual_and_offset (p);	/* we may have substr(varying,<expr>) */
	     end;
	end;

/* Begin filling in the new reference node expressing the
	   result of substr.  Save the original argument because
	   we still need some of the info in it. */

	save_arg_one = arg (1);
	arg (1) = p;

	arg (1) -> reference.varying_ref, arg (1) -> reference.padded_ref, arg (1) -> reference.aligned_ref = "0"b;

	off = arg (1) -> reference.offset;
	coff = arg (1) -> reference.c_offset;
	cunits = arg (1) -> reference.units;
	call offset_adder (off, coff, cunits, (arg (1) -> reference.modword_in_offset), (offset), (c_offset), units,
	     "0"b, arg (1) -> reference.fo_in_qual);
	arg (1) -> reference.offset = off;
	arg (1) -> reference.c_offset = coff;
	arg (1) -> reference.units = cunits;
	arg (1) -> reference.modword_in_offset = "0"b;

	if ^pl1_stat_$eis_mode then
	     if arg (1) -> reference.offset ^= null then
		if arg (1) -> reference.units <= half_ then do;
		     if arg (1) -> reference.units = bit_ then
			opcode = mod_bit;
		     else if arg (1) -> reference.units = character_ then
			opcode = mod_byte;
		     else
			opcode = mod_half;

		     p = create_operator (opcode, 3);
		     p -> operand (1), p -> operand (2) =
			declare_temporary (integer_type, default_fix_bin_p, 0, null);
		     p -> operand (3) = arg (1) -> reference.offset;

		     arg (1) -> reference.offset = p;
		end;

/* Fill in length of result. */

	if arg_number = 2 then
	     if length = null & offset = null then
		arg (1) -> reference.c_length = c_length - c_offset;
	     else do;
		p = create_operator (sub, 3);
		p -> operand (1) = declare_temporary (fixed_binary_real_mask, default_fix_bin_p, 0, null);
		p -> operand (2) = length;
		p -> operand (3) = offset;

		arg (1) -> reference.length = p;
		arg (1) -> reference.c_length = 0;

		if length = null then
		     p -> operand (2) = declare_constant$integer (c_length);

		if offset = null then
		     p -> operand (3) = declare_constant$integer (c_offset);
		else do;
		     if offset -> node.type = operator_node then
			offset = expression_semantics (cur_block, statement_ptr, offset, "0"b);

		     offset = share_expression (offset);
		end;
	     end;
	else if symbol_is_constant (arg_symbol (3)) then do;
	     arg (1) -> reference.c_length = constant_value (arg_symbol (3));
	     arg (1) -> reference.length = null;
	end;
	else do;
	     arg (1) -> reference.c_length = 0;
	     arg (1) -> reference.length = arg (3);
	end;

	if substr (statement_ptr -> statement.prefix, 8, 1) /* stringrange */ then
	     if symbol_is_constant (arg_symbol (2)) /* if 2nd arg (offset) is a constant */
		& arg (1) -> reference.length = null /* and new length is constant */
		& length = null /* and old length is constant */ then do;
						/* then make checks now */
		substr_index = constant_value (arg_symbol (2));

		if substr_index < 1 then
		     call semantic_translator$error (147, builtin_symbol);

/* if there is a problem here, diagnose it later */
		if arg (1) -> reference.c_length < 0 then
		     c_length = substr_index - 1;

		if c_length < (substr_index + arg (1) -> reference.c_length - 1) then
		     call semantic_translator$error (147, builtin_symbol);
	     end;
	     else do;
		if arg (1) -> reference.length = null then do;
		     arg (1) -> reference.length = declare_constant$integer ((arg (1) -> reference.c_length));
		     arg (1) -> reference.c_length = 0;
		end;

/* Generate operator to check that:
			   0 <= new_length <= (orig_length - offset + 1) */

		p = create_operator (range_ck, 4);
		p -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
		p -> operand (2) = arg (1) -> reference.length;
		p -> operand (3) = declare_constant$integer (0);

		p -> operand (4) = create_operator (sub, 3);
		p -> operand (4) -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);

/* Fill in length of original argument */

		if length = null then
		     p -> operand (4) -> operand (2) = declare_constant$integer (c_length);
		else
		     p -> operand (4) -> operand (2) = length;

		if offset = null then
		     p -> operand (4) -> operand (3) = declare_constant$integer (c_offset);
		else
		     p -> operand (4) -> operand (3) = copy_expression ((offset));

		if offset = null & length = null then
		     if c_offset < 0 | c_offset > c_length then
			call semantic_translator$abort (147, builtin_symbol);
		     else
			;
		else do;
		     r = create_operator (range_ck, 4);
		     r -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
		     r -> operand (2) = p -> operand (4) -> operand (3);
		     r -> operand (3) = declare_constant$integer (0);
		     r -> operand (4) = copy_expression ((p -> operand (4) -> operand (2)));

		     p -> operand (4) -> operand (3) = r;
		end;

		arg (1) -> reference.length = p;
	     end;

/* fix to avoid problems later in convert 
	   if a constant substr length is < 0 */
	if arg (1) -> reference.c_length < 0 then do;
	     call semantic_translator$error (147, builtin_symbol);
	     arg (1) -> reference.c_length = 0;
	end;

	arg (1) -> reference.length =
	     expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.length), "0"b);
	if arg (1) -> reference.length ^= null then
	     arg (1) -> reference.length = convert$to_integer ((arg (1) -> reference.length), integer_type);

	arg (1) -> reference.offset =
	     expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
	if arg (1) -> reference.offset ^= null then
	     arg (1) -> reference.offset = convert$to_integer ((arg (1) -> reference.offset), integer_type);

	arg (1) -> reference.substr = "1"b;

	call simplify_offset (arg (1), context);

	if def_context.arg_list then do;
	     tree -> operand (2) = arg (1);
	     tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
	     goto ret;
	end;

	goto return_arg1;

action (12):					/* unspec */
	if arg (1) -> node.type = token_node then do;
	     call semantic_translator$error (485, null);
	     i = 1;
	     string (type) = defined_arg_type (1);
	     call convert_arg;
	end;

	if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
	     arg (1), ref (1) = copy_expression ((ref (1)));

	string (rtype) = bit_mask;
	units = bit_;

	if def_context.left_side then
	     if arg (1) -> node.type = operator_node then
		call semantic_translator$abort (148, builtin_symbol);
	     else do;
		call propagate_bit (arg_symbol (1), set_bit);
		arg_symbol (1) -> symbol.passed_as_arg = "1"b;
	     end;

	if arg_type (1).structure | ref (1) -> reference.array_ref then do;
	     if pl1_stat_$check_ansi then
		call semantic_translator$error (172, builtin_symbol);
	     goto aggregate;
	end;

	if ref (1) -> reference.varying_ref then do;
	     length = create_length_fun (arg (1));
	     c_length = 0;
	end;
	else do;
	     length = ref (1) -> reference.length;
	     c_length = ref (1) -> reference.c_length;
	end;

	if arg_symbol (1) -> symbol.bit then
	     goto make_reference;

	if arg_symbol (1) -> symbol.char | arg_symbol (1) -> symbol.picture then do;
	     if length ^= null then do;
		p = create_operator (mult, 3);
		p -> operand (2) = length;
		p -> operand (3) = declare_constant$integer (bits_per_character);
		length = p;
	     end;
	     else
		c_length = c_length * bits_per_character;

	     goto make_reference;
	end;

aggregate:
	if arg (1) -> node.type = operator_node then
	     call semantic_translator$abort (294, builtin_symbol);

	if arg_symbol (1) -> symbol.array ^= null & ^ref (1) -> reference.array_ref then do;
	     c_length = arg_symbol (1) -> symbol.array -> array.c_element_size_bits;
	     length = copy_expression (arg_symbol (1) -> symbol.array -> array.element_size_bits);
	end;
	else do;
	     c_length = arg_symbol (1) -> symbol.c_bit_size;
	     length = copy_expression (arg_symbol (1) -> symbol.bit_size);

	     if ref (1) -> reference.offset ^= null then
		if ref (1) -> reference.offset -> node.type = list_node then
		     call semantic_translator$abort (338, ref (1));
	end;

	if units = character_ then
	     if length ^= null then do;
		p = create_operator (bit_to_char, 2);
		p -> operand (2) = length;

		length = p;
	     end;
	     else
		c_length = divide (c_length, bits_per_character, 15, 0);


	if arg_symbol (1) -> symbol.defined then
	     if arg_symbol (1) -> symbol.structure | ref (1) -> reference.array_ref then
		arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);

make_reference:
	if arg (1) -> node.type = operator_node then do;
	     call make_assignment;

	     if agg_ref = null then
		arg (1) = p -> operand (1);
	     else do;
		arg (1) = agg_ref;
		defined_arg_type (1) = string (agg_ref -> reference.symbol -> symbol.attributes);
		c_length = agg_ref -> reference.symbol -> symbol.c_bit_size;
		length = copy_expression (agg_ref -> reference.symbol -> symbol.bit_size);
	     end;

	     if arg_type (1).bit | jump_index = 12 then
		units = bit_;
	     else
		units = character_;
	end;

	if def_context.arg_list then do;
	     tree, p = create_operator (assign, 2);
	     r = create_symbol (null, null, by_compiler);
	     r -> symbol.temporary = "1"b;
	     p -> operand (1) = r -> symbol.reference;
	     p -> operand (2) = arg (1);
	end;

	if units = character_ then
	     string (rtype) = char_mask;
	else
	     string (rtype) = bit_mask;

	rtype.unaligned = arg_symbol (1) -> symbol.packed;

	if ^arg_symbol (1) -> symbol.overlayed_by_builtin then
	     call propagate_bit (arg_symbol (1), overlayed_by_builtin_bit);

	p = declare_defined_overlay (string (rtype), c_length, 0, length, arg (1));

/* we omit setting ref(1)->reference.c_length=0 because ref(1) might be a constant and,
	   therefore, still a symbol.reference since copy_expression works differently here */
	ref (1) -> reference.length = null;

	p -> reference.padded_ref = "0"b;


/*  move the offsets from the defined variable up */

	p -> reference.qualifier = arg (1);
	p -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;
	p -> reference.offset = arg (1) -> reference.offset;
	p -> reference.c_offset = arg (1) -> reference.c_offset;
	p -> reference.units = arg (1) -> reference.units;
	p -> reference.modword_in_offset = arg (1) -> reference.modword_in_offset;

	if ^pl1_stat_$eis_mode then
	     if p -> reference.offset ^= null then
		if p -> reference.units <= half_ then do;
		     if p -> reference.units = bit_ then
			opcode = mod_bit;
		     else if p -> reference.units = character_ then
			opcode = mod_byte;
		     else
			opcode = mod_half;

		     offset = create_operator (opcode, 3);
		     offset -> operand (1), offset -> operand (2) =
			declare_temporary (integer_type, default_fix_bin_p, 0, null);
		     offset -> operand (3) = p -> reference.offset;

		     p -> reference.offset = offset;
		end;

	if (p -> reference.units = character_ | p -> reference.units = digit_) & units = bit_ & pl1_stat_$eis_mode
	then do;					/* string(bit_structure) or unspec */
	     p -> reference.c_offset = p -> reference.c_offset * bits_per_character;

	     if p -> reference.units = digit_ then
		p -> reference.c_offset = divide (p -> reference.c_offset, packed_digits_per_character, 24, 0);

	     if p -> reference.offset ^= null & ^p -> reference.modword_in_offset then
		if p -> reference.units = character_ then do;
		     offset = create_operator (mult, 3);
		     offset -> operand (2) = declare_constant$integer (bits_per_character);
		     offset -> operand (3) = p -> reference.offset;
		     p -> reference.offset = offset;
		end;
		else do;
		     offset = create_operator (digit_to_bit, 2);
		     offset -> operand (2) = p -> reference.offset;
		     p -> reference.offset = offset;
		end;
	     p -> reference.units = bit_;
	end;

	if p -> reference.qualifier -> node.type = reference_node then do;
	     p -> reference.qualifier -> reference.c_offset = 0;
	     p -> reference.qualifier -> reference.offset = null;
	     p -> reference.qualifier -> reference.modword_in_offset = "0"b;
	     p -> reference.qualifier -> reference.inhibit = "1"b;
	end;

	p -> reference.length = fill_refer ((p -> reference.length), (ref (1) -> reference.qualifier), "1"b);
	p -> reference.length = expression_semantics (cur_block, statement_ptr, (p -> reference.length), "0"b);
	if p -> reference.length ^= null then
	     p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);

	p -> reference.offset = expression_semantics (cur_block, statement_ptr, (p -> reference.offset), "0"b);
	if p -> reference.offset ^= null then
	     p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);

	call simplify_offset (p, context);

	if def_context.arg_list then do;
	     tree -> operand (2) = p;
	     tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
	end;
	else
	     tree = p;

	goto ret;

action (13):					/* abs */
	string (rtype) = defined_arg_type (1) & ^unaligned_mask & ^complex_mask | real_mask | aligned_mask;

	goto create_operator_node;

action (14):					/* add
   divide
   multiply
   subtract */
	string (rtype) = "0"b;

	do i = 1 to 2;
	     defined_as_if_type (i) = defined_arg_type (i);

	     if as_if_type (i).bit then
		defined_as_if_type (i) = fixed_binary_real_mask;
	     else if as_if_type (i).char then
		defined_as_if_type (i) = fixed_decimal_real_mask;
	     else if as_if_type (i).picture then
		if arg_symbol (i) -> symbol.complex then
		     if arg_symbol (i) -> symbol.pix.pic_float then
			defined_as_if_type (i) = float_decimal_complex_mask;
		     else
			defined_as_if_type (i) = fixed_decimal_complex_mask;
		else if arg_symbol (i) -> symbol.pix.pic_float then
		     defined_as_if_type (i) = float_decimal_real_mask;
		else
		     defined_as_if_type (i) = fixed_decimal_real_mask;
	end;

	if as_if_type (1).fixed & as_if_type (2).fixed then
	     string (rtype) = string (rtype) | fixed_mask;
	else
	     string (rtype) = string (rtype) & ^fixed_mask | float_mask;

	if as_if_type (1).decimal & as_if_type (2).decimal then
	     string (rtype) = string (rtype) | decimal_mask;
	else
	     string (rtype) = string (rtype) & ^decimal_mask | binary_mask;

	if ^as_if_type (1).complex & ^as_if_type (2).complex then
	     string (rtype) = string (rtype) | real_mask;
	else
	     string (rtype) = string (rtype) & ^real_mask | complex_mask;

	string (type) = string (rtype);

	do i = 1 to 2;
	     call convert_arg;
	end;

	if rtype.float & arg_number = 4 then
	     call semantic_translator$abort (167, builtin_symbol);

	if arg_number = 4 then
	     rscale = constant_value (arg_symbol (4));

	rprecision = constant_value (arg_symbol (3));

	if rtype.decimal & rprecision > max_p_dec then
	     goto err146;

	if rtype.fixed & rprecision > max_p_fix_bin_2 | rtype.float & rprecision > max_p_flt_bin_2 then
	     goto err146;

	arg_number = 2;

	goto create_operator_node;

action (15):					/* bin
   binary
   dec
   decimal */
	string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;

	if arg_number = 3 then
	     rscale = constant_value (arg_symbol (3));
	else
	     rscale = 0;

	if arg_number >= 2 then
	     rprecision = constant_value (arg_symbol (2));
	else
	     rprecision = 0;

	goto convert_to_arith;

action (16):					/* ceil
   floor
   trunc */
	if arg_type (1).complex then
	     goto err124;

	if arg_type (1).fixed then
	     if arg_type (1).binary then
		rprecision = min (max_p_fix_bin_2, max (rprecision - rscale + 1, 1));
	     else
		rprecision = min (max_p_dec, max (rprecision - rscale + 1, 1));
	rscale = 0;

	goto create_operator_node;

action (17):					/* complex
   cplx */
	string (rtype) = "0"b;

	do i = 1 to 2;
	     defined_as_if_type (i) = defined_arg_type (i);

	     if as_if_type (i).bit then
		defined_as_if_type (i) = fixed_binary_real_mask;
	     else if as_if_type (i).char then
		defined_as_if_type (i) = fixed_decimal_real_mask;
	     else if as_if_type (i).picture then
		if arg_symbol (i) -> symbol.pix.pic_float then
		     defined_as_if_type (i) = float_decimal_real_mask;
		else
		     defined_as_if_type (i) = fixed_decimal_real_mask;

	     if as_if_type (i).complex then
		goto err124;
	end;

	if as_if_type (1).fixed & as_if_type (2).fixed then
	     string (rtype) = string (rtype) | fixed_mask;
	else
	     string (rtype) = string (rtype) & ^fixed_mask | float_mask;

	if as_if_type (1).decimal & as_if_type (2).decimal then
	     string (rtype) = string (rtype) | decimal_mask;
	else
	     string (rtype) = string (rtype) & ^decimal_mask | binary_mask;

	string (type) = string (rtype);
	string (rtype) = string (rtype) & ^real_mask | complex_mask;

	do i = 1 to 2;
	     call convert_arg;
	end;

	p1 = arg_symbol (1) -> symbol.c_dcl_size;
	p2 = arg_symbol (2) -> symbol.c_dcl_size;
	q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
	q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);

	rscale = max (q1, q2);

	if rtype.fixed & rtype.binary then
	     rprecision = min (max_p_fix_bin_2, max (p1 - q1, p2 - q2) + rscale);
	else
	     rprecision = min (max_p_flt_bin_2, max (p1 - q1, p2 - q2) + rscale);

	if rtype.decimal then
	     rprecision = min (max_p_dec, max (p1 - q1, p2 - q2) + rscale);

	goto create_operator_node;

action (18):					/* bit
   char */
	string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;

	string_size_ck = "1"b;

	if arg_number = 2 then
	     if symbol_is_constant (arg_symbol (2)) then do;
		rprecision = constant_value (arg_symbol (2));
		rlength = null;
	     end;
	     else do;
		rprecision = 0;
		rlength = copy_expression ((arg (2)));
	     end;

	full_attribute_set = arg_number > 1;

	if arg (1) -> node.type = token_node then do;
	     arg (1) = convert$from_builtin (arg (1), string (rtype));
	     if ^full_attribute_set then
		rprecision = arg (1) -> reference.c_length;
	     opcode = assign;
	     arg_number = 1;

	     goto create_operator_node;
	end;

	goto convert_label;

action (19):					/* imag
   real */
	string (rtype) = string (rtype) & ^complex_mask | real_mask;

	if ^def_context.arg_list then do;
	     if arg_symbol (1) -> symbol.packed then
		string (rtype) = string (rtype) & ^aligned_mask | unaligned_mask;

	     t = declare_defined_overlay (string (rtype), rprecision, (rscale), rlength, arg (1));
	     s = t -> reference.symbol;

	     s -> symbol.boundary = arg_symbol (1) -> symbol.boundary;

	     if def_context.left_side then
		call propagate_bit (arg_symbol (1), set_bit);

	     arg_symbol (1) -> symbol.overlayed_by_builtin = "1"b;

	     if opcode = imag_fun /* imag */ then
		if s -> symbol.decimal then do;
		     if s -> symbol.unaligned then do;
			t -> reference.units = digit_;
			t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_digit, 15, 0);
		     end;
		     else do;
			t -> reference.units = character_;
			t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_character, 15, 0);
		     end;
		end;
		else do;
		     if s -> symbol.packed then do;
			t -> reference.units = bit_;
			t -> reference.c_offset = s -> symbol.c_bit_size;
		     end;
		     else do;
			t -> reference.units = word_;
			t -> reference.c_offset = s -> symbol.c_word_size;
		     end;
		end;

	     if arg (1) -> node.type = operator_node then do;
		r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
		     (statement_ptr -> statement.prefix));
		r -> statement.root = share_expression (arg (1));
		r -> statement.generated = "1"b;

		ref (1) = arg (1) -> operand (1);
	     end;
	     else if arg (1) = arg_symbol (1) -> symbol.reference then
		arg (1), ref (1) = copy_expression ((arg (1)));

	     off = t -> reference.offset;
	     coff = t -> reference.c_offset;
	     cunits = t -> reference.units;

	     call offset_adder (off, coff, cunits, "0"b, (ref (1) -> reference.offset), (ref (1) -> reference.c_offset),
		(ref (1) -> reference.units), (ref (1) -> reference.modword_in_offset),
		ref (1) -> reference.fo_in_qual);

	     t -> reference.offset = off;
	     t -> reference.c_offset = coff;
	     t -> reference.units = cunits;
	     ref (1) -> reference.offset = null;
	     ref (1) -> reference.c_offset = 0;
	     ref (1) -> reference.modword_in_offset = "0"b;
	     ref (1) -> reference.inhibit = "1"b;
	     t -> reference.qualifier = arg (1);
	     t -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;

	     if t -> reference.offset ^= null then do;
		t -> reference.offset =
		     expression_semantics (cur_block, statement_ptr, (t -> reference.offset), "0"b);
		call simplify_offset (t, "0"b);
	     end;


	     tree = t;
	     goto ret;
	end;

	goto create_operator_node;

action (20):					/* max
   min */
	string (rtype) = "0"b;
	rprecision, rscale = 0;

	do i = 1 to arg_number;
	     defined_as_if_type (i) = defined_arg_type (i);

	     if as_if_type (i).bit then
		defined_as_if_type (i) = fixed_binary_real_mask;
	     else if as_if_type (i).char then
		defined_as_if_type (i) = fixed_decimal_real_mask;
	     else if as_if_type (i).picture then
		if arg_symbol (i) -> symbol.pix.pic_float then
		     defined_as_if_type (i) = float_decimal_real_mask;
		else
		     defined_as_if_type (i) = fixed_decimal_real_mask;

	     if as_if_type (i).complex then
		goto err124;
	end;

	do i = 1 to arg_number;
	     rtype.float = rtype.float | as_if_type (i).float;
	     rtype.binary = rtype.binary | as_if_type (i).binary;
	end;

	if ^rtype.float then
	     rtype.fixed = "1"b;

	if ^rtype.binary then
	     rtype.decimal = "1"b;

	rtype.real = "1"b;

	string (type) = string (rtype);

	do i = 1 to arg_number;
	     call convert_arg;
	     rprecision = max (rprecision, arg_symbol (i) -> symbol.c_dcl_size);
	     rscale = max (rscale, fixed (arg_symbol (i) -> symbol.scale, 31, 0));
	end;

	goto create_operator_node;

action (21):					/* mod */
	string (rtype) = real_mask | aligned_mask;
	rprecision, rscale = 0;

	do i = 1 to 2;
	     defined_as_if_type (i) = defined_arg_type (i);

	     if as_if_type (i).bit then
		defined_as_if_type (i) = fixed_binary_real_mask;
	     else if as_if_type (i).char then
		defined_as_if_type (i) = fixed_decimal_real_mask;
	     else if as_if_type (i).picture then
		if arg_symbol (i) -> symbol.pix.pic_float then
		     defined_as_if_type (i) = float_decimal_real_mask;
		else
		     defined_as_if_type (i) = fixed_decimal_real_mask;

	     if as_if_type (i).complex then
		goto err124;
	end;

	if as_if_type (1).fixed & as_if_type (2).fixed then
	     string (rtype) = string (rtype) | fixed_mask;
	else
	     string (rtype) = string (rtype) & ^fixed_mask | float_mask;

	if as_if_type (1).decimal & as_if_type (2).decimal then
	     string (rtype) = string (rtype) | decimal_mask;
	else
	     string (rtype) = string (rtype) & ^decimal_mask | binary_mask;

	string (type) = string (rtype);

	do i = 1 to 2;
	     call convert_arg;
	end;

	p1 = arg_symbol (1) -> symbol.c_dcl_size;
	p2 = arg_symbol (2) -> symbol.c_dcl_size;
	q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
	q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);

	rscale = max (q1, q2);

	if rtype.float then
	     rprecision = max (p1, p2);
	else if rtype.binary then
	     rprecision = min (max_p_fix_bin_2, p2 - q2 + rscale);
	else
	     rprecision = min (max_p_dec, p2 - q2 + rscale);

	goto create_operator_node;

action (22):					/* round */
	i = constant_value (arg_symbol (2));

	if rtype.fixed then do;
	     if rtype.decimal then
		rprecision =
		     max (1,
		     min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i, max_p_dec));
	     else
		rprecision =
		     max (1,
		     min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i,
		     max_p_fix_bin_2));
	     rscale = i;
	end;
	if rtype.float then do;
	     if i <= 0 then
		call semantic_translator$abort (271, builtin_symbol);

	     if rtype.decimal then
		rprecision = min (i, max_p_dec);
	     else
		rprecision = min (i, max_p_flt_bin_2);
	end;

	goto create_operator_node;

action (23):					/* bool */
	do i = 1 to 2;
	     if ref (i) -> reference.varying_ref then
		cur_length (i) = create_length_fun (arg (i));
	     else if ref (i) -> reference.length ^= null then
		cur_length (i) = share_expression ((ref (i) -> reference.length));
	     else
		cur_length (i) = null;
	end;

	if cur_length (1) = null & cur_length (2) = null then
	     rprecision = max (ref (1) -> reference.c_length, ref (2) -> reference.c_length);
	else do;
	     rprecision = 0;
	     rlength = create_operator (max_fun, 3);
	     rlength -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
	     rlength -> operand (2) = cur_length (1);
	     rlength -> operand (3) = cur_length (2);

	     if cur_length (1) = null then
		rlength -> operand (2) = declare_constant$integer ((ref (1) -> reference.c_length));

	     if cur_length (2) = null then
		rlength -> operand (3) = declare_constant$integer ((ref (2) -> reference.c_length));
	end;

	if ^arg_symbol (3) -> symbol.constant then do;
	     t = declare_temporary (bit_mask, 4, 0, null);
	     arg (3) = convert$to_target (arg (3), t);
	     goto create_operator_node;
	end;

	if rlength ^= null | rprecision > bits_per_double then
	     goto create_operator_node;

	bit4 = substr (arg_symbol (3) -> symbol.initial -> based_type, 1, 4);
	not_flag = substr (bit4, 1, 1);

	if not_flag then
	     bit4 = ^bit4;

	if bit4 = "0000"b then do;
	     tree = create_operator (assign, 2);
	     tree -> operand (2) = declare_constant$bit ("000000000000000000000000000000000000"b);
	end;
	else if bit4 = "0011"b then do;
	     tree = create_operator (assign, 2);
	     tree -> operand (2) = arg (1);
	end;
	else if bit4 = "0101"b then do;
	     tree = create_operator (assign, 2);
	     tree -> operand (2) = arg (2);
	end;

	else do;
	     if bit4 = "0001"b then
		opcode = and_bits;
	     else if bit4 = "0111"b then
		opcode = or_bits;
	     else if bit4 = "0110"b then
		opcode = xor_bits;

	     else do;
		opcode = and_bits;

		if bit4 = "0100"b then
		     m = 1;
		else
		     m = 2;

		r = create_operator (assign, 2);
		r -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
		r -> operand (2) = arg (m);

		p = create_operator (not_bits, 2);
		p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
		p -> operand (2) = r;

		arg (m) = p;
	     end;

	     tree = create_operator (opcode, 3);
	     tree -> operand (2) = arg (1);
	     tree -> operand (3) = arg (2);
	end;

	tree -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);

	if not_flag then do;
	     p = create_operator (not_bits, 2);
	     p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
	     p -> operand (2) = tree;

	     tree = p;
	end;

	goto ret;

action (24):					/* decat */
	if arg_type (1).bit & arg_type (2).bit then
	     string (type) = bit_mask;
	else do;
	     string (type) = char_mask;
	     reserved_number = reserved_number + 1;
	end;

	do i = 1 to 2;
	     call convert_arg;
	end;

	string (type) = bit_mask;			/* i will be 3 at this point */
	call convert_arg;

	do i = 1 to arg_number;
	     if ref (i) -> reference.varying_ref then do;
		length = create_length_fun (arg (i));

		p = create_operator (assign, 2);
		ref (i), p -> operand (1) = declare_temporary (string (rtype) & ^varying_mask, 0, 0, length);
		p -> operand (2) = arg (i);

		arg (i) = p;
		arg_symbol (i) = ref (i) -> reference.symbol;
	     end;
	end;

	desc_reqd = "1"b;

	goto create_call;

action (25):					/* atanh
   cosh
   erf
   erfc
   sinh
   tanh */
	if arg_type (1).complex then
	     reserved_number = reserved_number + 2;

	if rprecision > max_p_flt_bin_1 then
	     reserved_number = reserved_number + 1;

	goto create_call;

action (26):					/* dim
   hbound
   lbound */
	if arg_symbol (1) = null then
	     call semantic_translator$abort (127, builtin_symbol);

	if arg_symbol (1) -> node.type = label_node then do;
						/* bug 2193: Error 127 is printed when the first argument
		     to hbound is not an array value */
	     if ^(arg_symbol (1) -> label.array) then
		call semantic_translator$abort (127, builtin_symbol);
	     if reserved_number = 1 then
		number = arg_symbol (1) -> label.low_bound;
	     else if reserved_number = 2 then
		number = arg_symbol (1) -> label.high_bound;
	     else
		number = arg_symbol (1) -> label.high_bound - arg_symbol (1) -> label.low_bound + 1;

	     tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);

	     goto ret;
	end;

	if arg_symbol (1) -> symbol.array = null then
	     call semantic_translator$abort (127, builtin_symbol);

	if arg_symbol (1) -> symbol.defined then
	     arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);

	p = arg_symbol (1) -> symbol.array;

	if ^symbol_is_constant (arg_symbol (2)) then do;
	     ref (3), arg (3) = declare_constant$integer ((p -> array.number_of_dimensions));
	     arg_symbol (3) = arg (3) -> reference.symbol;

	     ref (4), arg (4) = declare_constant$integer (reserved_number);
	     arg_symbol (4) = arg (4) -> reference.symbol;

	     reserved_number = 6;
	     arg_number = 4;
	     string (rtype) = fixed_binary_real_mask;
	     rprecision = max_offset_precision;
	     rscale = 0;

	     goto create_call;
	end;

	integer = constant_value (arg_symbol (2));

	if integer > p -> array.number_of_dimensions | integer < 1 then
	     call semantic_translator$abort (128, builtin_symbol);

	p = p -> array.bounds;
	do i = 1 to arg_symbol (1) -> symbol.array -> array.number_of_dimensions - integer;
	     p = p -> bound.next;
	end;

	if p -> bound.lower ^= null then do;
	     call simplify_expression ((p -> bound.lower), constant, modified);
	     if modified then do;
		p -> bound.c_lower = constant;
		p -> bound.lower = null;
	     end;
	end;

	if p -> bound.upper ^= null then do;
	     call simplify_expression ((p -> bound.upper), constant, modified);
	     if modified then do;
		p -> bound.c_upper = constant;
		p -> bound.upper = null;
	     end;
	end;

	if reserved_number = 1 then
	     if p -> bound.lower = null then do;
		tree = declare_constant (unspec (p -> bound.c_lower), integer_type, max_offset_precision, 0);
		goto ret;
	     end;
	     else do;
		tree = copy_expression (p -> bound.lower);
		tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
		tree = expression_semantics (cur_block, statement_ptr, tree, this_context);

		arg (1) = tree;
		goto create_assign;
	     end;

	if reserved_number = 2 then
	     if p -> bound.upper = null then do;
		tree = declare_constant (unspec (p -> bound.c_upper), integer_type, max_offset_precision, 0);
		goto ret;
	     end;
	     else do;
		tree = copy_expression (p -> bound.upper);
		tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
		tree = expression_semantics (cur_block, statement_ptr, tree, this_context);

		arg (1) = tree;
		goto create_assign;
	     end;

	if p -> bound.upper = null & p -> bound.lower = null then do;
	     number = p -> bound.c_upper - p -> bound.c_lower + 1;
	     tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);

	     goto ret;
	end;

	arg (1) = copy_expression (p -> bound.upper);
	if arg (1) = null then
	     arg (1) = declare_constant$integer ((p -> bound.c_upper));
	else do;
	     arg (1) = fill_refer (arg (1), (ref (1) -> reference.qualifier), "1"b);

	     if arg (1) -> node.type = token_node then
		arg (1) = expression_semantics (cur_block, statement_ptr, arg (1), "0"b);

	     if arg (1) -> node.type = reference_node then
		if arg (1) -> reference.symbol -> symbol.arg_descriptor then do;
		     t = create_operator (assign, 2);
		     t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
		     t -> operand (2) = arg (1);
		     arg (1) = t;
		end;
	end;

	arg (2) = copy_expression (p -> bound.lower);
	if arg (2) = null then
	     arg (2) = declare_constant$integer (p -> bound.c_lower - 1);
	else do;
	     arg (2) = fill_refer (arg (2), (ref (1) -> reference.qualifier), "1"b);

	     if arg (2) -> node.type = token_node then
		arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);

	     if arg (2) -> node.type = reference_node then
		if arg (2) -> reference.symbol -> symbol.arg_descriptor then do;
		     t = create_operator (assign, 2);
		     t -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
		     t -> operand (2) = arg (2);
		     arg (2) = t;
		end;

	     p = create_operator (sub, 3);
	     p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_offset_precision, 0, null);
	     p -> operand (2) = arg (2);
	     p -> operand (3) = declare_constant$integer (1);

	     arg (2) = p;
	end;

	do i = 1 to 2;
	     arg (i) = expression_semantics (cur_block, statement_ptr, arg (i), "0"b);
	end;

	string (rtype) = fixed_binary_real_mask;
	rprecision = max_offset_precision;
	rscale = 0;

	goto create_operator_node;

action (27):					/* reverse */
	if check_reverse (arg (1)) then do;		/* reverse (reverse (..)) */
	     tree = arg (1) -> operator.operand (2);
	     go to ret;
	end;
	if is_this_constant (arg (1)) then do;
	     constant_string_length = arg (1) -> reference.c_length;
	     if arg_type (1).bit then
		tree = declare_constant$bit (reverse (arg_symbol (1) -> symbol.initial -> constant_bit_string));
	     else
		tree = declare_constant$char (reverse (arg_symbol (1) -> symbol.initial -> constant_char_string));
	     go to exit;
	end;
	if ref (1) -> reference.c_length = 1 then do;	/* reverse of 1 doesn't reverse */
	     tree = arg (1);
	     go to ret;
	end;
	goto create_operator_node;

action (28):					/* empty */
	if pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree
	     & pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree -> reference.symbol -> symbol.token then
	     call semantic_translator$abort (187, builtin_symbol);

	arg (2) = pl1_stat_$cur_statement -> statement.root -> operand (1);
	arg_symbol (2) = arg (2) -> reference.symbol;

	if string (arg_symbol (2) -> symbol.data_type) = "0"b then do;
	     arg_symbol (2) -> symbol.area = "1"b;
	     arg_symbol (2) -> symbol.c_dcl_size, arg_symbol (2) -> symbol.c_word_size = min_area_size;
	     integer_24 = min_area_size;
	end;
	else if ^arg_symbol (2) -> symbol.area then
	     call semantic_translator$abort (188, arg (2));
	else if arg_symbol (2) -> symbol.dcl_size = null then
	     integer_24 = arg_symbol (2) -> symbol.c_dcl_size;
	else
	     integer_24 = 0;			/* this will get reset anyway if dcl_size^=0	*/


	if arg_symbol (2) -> symbol.structure then
	     call semantic_translator$abort (265, arg_symbol (2));

	if arg (2) -> reference.array_ref then do;
	     t = expand_primitive (cur_block, statement_ptr, arg (2), "0"b);

	     do r = t repeat t -> operand (1) while (r -> operand (1) -> node.type = operator_node);
	     end;

	     arg (2) = r -> operand (1);
	end;
	else
	     r = null;

	if ^pl1_stat_$use_old_area then do;
	     p = create_operator (empty_area, 2);	/* op(1) of empty is the area, op(2) is its size */
	     p -> operand (1) = arg (2);
	     if integer_24 ^= 0 then
		p -> operand (2) = declare_constant$integer ((integer_24));
	     else do;
		q = copy_expression (arg_symbol (2) -> symbol.dcl_size);

		if arg_symbol (2) -> symbol.refer_extents then
		     q = fill_refer (q, (arg (2) -> reference.qualifier), "1"b);

		q = expression_semantics (cur_block, statement_ptr, q, "0"b);
		p -> operand (2) = q;
	     end;
	end;

	else do;

	     p = create_operator (copy_words, 3);
	     p -> operand (1) = arg (2);
	     p -> operand (2) = declare_constant$bit ((84)"0"b || bit (integer_24, 24) || (36)"0"b);
	     p -> operand (3) = declare_constant$integer (4);

	     if arg_symbol (2) -> symbol.dcl_size ^= null then do;
		if arg (2) -> reference.offset ^= null | arg (2) -> reference.c_offset ^= 0 then do;
						/* not to destroy the offsets of arg(2) used in copy_words */
		     q = create_reference (null);
		     q -> reference = arg (2) -> reference;
		     arg (2) = q;
		     if ^q -> reference.shared then do;
			q -> reference.ref_count = 0;
			if q -> reference.offset ^= null then
			     q -> reference.offset = copy_expression (q -> reference.offset);
			if q -> reference.qualifier ^= null then
			     q -> reference.qualifier = copy_expression (q -> reference.qualifier);
		     end;
		end;

		q = create_operator (assign, 2);
		q -> operand (1) = declare_integer (cur_block);
		q -> operand (2) = copy_expression (arg_symbol (2) -> symbol.dcl_size);

		if arg_symbol (2) -> symbol.refer_extents then
		     q -> operand (2) = fill_refer ((q -> operand (2)), (arg (2) -> reference.qualifier), "1"b);

		q -> operand (2) = expression_semantics (cur_block, p, (q -> operand (2)), "0"b);

		arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);

		q -> operand (1) -> reference.units = word_;
		q -> operand (1) -> reference.offset = arg (2) -> reference.offset;
		q -> operand (1) -> reference.c_offset = arg (2) -> reference.c_offset + 2;

		q -> operand (1) -> reference.qualifier = copy_expression ((arg (2)));

		arg (2) -> reference.offset = null;
		arg (2) -> reference.c_offset = 0;

		q -> operand (1) -> reference.symbol -> symbol.defined,
		     q -> operand (1) -> reference.symbol -> symbol.position,
		     q -> operand (1) -> reference.symbol -> symbol.overlayed, q -> operator.processed = "1"b;

		q -> operand (1) -> reference.shared, q -> operand (1) -> reference.symbol -> symbol.auto = "0"b;
		q -> operand (1) -> reference.ref_count = 1;


		tree = create_operator (join, 2);
		tree -> operand (1) = p;
		tree -> operand (2) = q;

		p = tree;
	     end;
	end;

	if r ^= null then do;
	     r -> operand (1) = p;
	     tree = t;
	end;
	else
	     tree = p;


	def_context.return_from_empty = "1"b;

	goto ret;

action (29):					/* null */
	p = null;
	tree = declare_constant (unspec (p), pointer_type, 0, 0);

	goto exit;

action (30):					/* lineno
   pageno */
	if def_save_context.aggregate then
	     goto err124;
	if def_context.left_side then do;
	     tree = create_operator (std_call, 3);
	     tree -> operand (2) = reserve$declare_lib (reserved_number - 7);
	     tree -> operand (3) = create_operator (std_arg_list, 3);
	     tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 6, 0, null);
	     tree -> operand (3) -> operand (2) = create_list (2);
	     tree -> operand (3) -> operand (2) -> element (1) = arg (1);

	     tree -> operand (3) -> operand (2) -> element (2) =
		convert$to_integer ((pl1_stat_$cur_statement -> statement.root -> operand (2)), integer_type);

	     def_context.return_from_empty = "1"b;

	     goto ret;
	end;

	rprecision = max_p_fix_bin_1;
	string (rtype) = integer_type;

	goto create_call;

action (31):					/* date */
	string (rtype) = char_mask;
	rprecision = 6;

	goto create_call;

action (32):					/* time */
	string (rtype) = char_mask;
	rprecision = 12;

	goto create_call;

action (33):					/* addr */
	if arg (1) -> node.type ^= reference_node & pl1_stat_$check_ansi then
	     call semantic_translator$abort (132, builtin_symbol);
	else if arg (1) -> reference.temp_ref then
	     call semantic_translator$error (299, builtin_symbol);
						/* temp must mean an expression */

	if arg_symbol (1) -> symbol.constant then
	     if arg_symbol (1) -> symbol.initial ^= null then
		call semantic_translator$abort (132, builtin_symbol);

	call propagate_bit (arg_symbol (1), aliasable_bit);
	call propagate_bit (arg_symbol (1), set_bit);
	if arg_symbol (1) -> symbol.cross_references ^= null then
	     arg_symbol (1) -> symbol.cross_references -> cross_reference.set_reference = "0"b;
						/* Arg of "addr" is not considered a set xref */

	if arg_symbol (1) -> symbol.defined & (arg (1) -> reference.array_ref | arg_symbol (1) -> symbol.structure)
	then do;
	     arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
	     if arg (1) -> reference.offset ^= null then
		arg (1) -> reference.offset =
		     expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
	end;

	if arg (1) -> reference.units < word_ & arg (1) -> reference.units ^= 0 | arg (1) -> reference.fo_in_qual then
	     opcode = addr_fun_bits;

	goto prepare_pointer;

action (34):					/* pointer
   ptr */
	if def_save_context.aggregate then
	     goto err124;
	if arg_type (1).offset then
	     if ^arg_type (2).area then
		call semantic_translator$abort (437, arg (2));
	     else
		goto prepare_pointer;

	if ^arg_type (1).ptr then
	     call semantic_translator$abort (438, arg (1));

	if pl1_stat_$check_ansi then
	     call semantic_translator$error (172, builtin_symbol);

	if ^arg_type (1).aligned then do;
	     p = create_operator (assign, 2);
	     p -> operand (1) = declare_temporary (pointer_type, 0, 0, null);
	     p -> operand (2) = arg (1);
	     arg (1) = p;
	end;

	if arg_type (2).bit then do;
	     i = 2;
	     string (type) = bit_mask;
	     call convert_arg;

	     goto prepare_pointer;
	end;

	if arg_type (2).char | defined_arg_type (2) & arithmetic_mask then do;
	     i = 2;
	     string (type) = fixed_binary_real_mask;
	     call convert_arg;

	     goto prepare_pointer;
	end;
	else
	     call semantic_translator$abort (436, arg (2));

action (35):					/* offset */
	if def_save_context.aggregate then
	     goto err124;
	string (rtype) = offset_mask;

	goto create_operator_node;

action (36):					/* allocation */
	if arg_symbol (1) -> symbol.father ^= null | ^arg_symbol (1) -> symbol.controlled then
	     call semantic_translator$abort (124, builtin_symbol);

/* prevent evaluation of a length expression when allocation = 0
	   (fixes bug 1645) */

	if ^arg (1) -> reference.shared then
	     arg (1) -> reference.length = null;

	string (rtype) = integer_type;
	rprecision = default_fix_bin_p;
	rscale = 0;
	rlength = null;

	goto create_operator_node;

action (37):					/* search
   verify */
	if check_reverse (arg (1)) then do;
	     arg (1) = arg (1) -> operator.operand (2);
	     if opcode = search_fun then
		opcode = search_rev_fun;
	     else
		opcode = verify_rev_fun;
	end;

	string (rtype) = fixed_binary_real_mask;
	rprecision = max_length_precision;

	goto create_operator_node;

action (38):					/* sign */
	if rtype.complex then
	     goto err124;

	string (rtype) = fixed_binary_real_mask;
	rprecision = default_fix_bin_p;
	rscale = 0;

	goto create_operator_node;

action (39):					/* baseno
   rel */
	if def_save_context.aggregate then
	     goto err124;
	if ^arg_type (1).ptr then
	     goto err124;

	string (rtype) = bit_mask;
	rprecision = 18;

	goto create_operator_node;

action (70):					/* segno */
	rprecision = 15;
	go to pointer_decomp_common;
action (71):					/* wordno */
	rprecision = 18;
	go to pointer_decomp_common;
action (72):					/* charno */
	rprecision = 21;
	go to pointer_decomp_common;
action (73):					/* bitno */
	rprecision = 24;

pointer_decomp_common:
	if def_save_context.aggregate then
	     goto err124;
	if ^arg_type (1).ptr then
	     goto err124;

	string (rtype) = fixed_binary_real_mask;
	rscale = 0;
	rlength = null;

	goto create_operator_node;

action (74):					/* setcharno ... addbitno */
	if def_save_context.aggregate then
	     goto err124;

	go to prepare_pointer;

action (40):					/* stac */
	string (rtype) = bit_mask;
	rprecision = 1;

	goto create_operator_node;

action (41):					/* addrel
   baseptr */
	if def_save_context.aggregate then
	     goto err124;
	goto prepare_pointer;

action (42):					/* onfield
   onfile
   onkey
   onloc */
	arg (1) = declare_temporary (char_mask, 256, 0, null);
	arg_symbol (1) = arg (1) -> reference.symbol;

	desc_reqd = "1"b;

	goto create_call;

action (43):					/* prod
   sum */
	if arg_symbol (1) = null then
	     call semantic_translator$abort (127, builtin_symbol);

	if arg_type (1).bit then do;
	     string (rtype) = fixed_binary_real_mask;
	     rprecision = max_p_fix_bin_2;
	     rscale = 0;
	end;
	else if arg_type (1).char then do;
	     string (rtype) = fixed_decimal_real_mask;
	     rprecision = max_p_dec;
	     rscale = 0;
	end;
	else if arg_type (1).picture then do;
	     rprecision = arg_symbol (1) -> symbol.pix.pic_size;
	     rscale = arg_symbol (1) -> symbol.pix.pic_scale;
	     if arg_type (1).complex then
		if arg_symbol (1) -> symbol.pix.pic_float then
		     string (rtype) = float_decimal_complex_mask;
		else
		     string (rtype) = fixed_decimal_complex_mask;
	     else if arg_symbol (1) -> symbol.pix.pic_float then
		string (rtype) = float_decimal_real_mask;
	     else
		string (rtype) = fixed_decimal_real_mask;
	end;

	if rtype.fixed then
	     if opcode = mult & rscale ^= 0 then do;
		if rtype.binary then
		     rprecision = max_p_flt_bin_2;
		else
		     rprecision = max_p_dec;
		rscale = 0;
		string (type), string (rtype) = string (rtype) & ^fixed_mask | float_mask;
	     end;
	     else if rtype.binary then
		rprecision = max_p_fix_bin_2;
	     else
		rprecision = max_p_dec;

	if arg (1) -> node.type ^= operator_node then
	     arg (1) = expand_primitive (cur_block, statement_ptr, arg (1), "0"b);

	if arg (1) -> operator.op_code ^= loop then
	     call semantic_translator$abort (127, builtin_symbol);

product:
	p = arg (1);
	do while (p -> operand (1) -> node.type = operator_node);
	     if p -> operand (1) -> operator.op_code = loop then
		p = p -> operand (1);
	     else
		goto leave;
	end;

leave:
	r = create_operator (opcode, 3);
	r -> operand (3) = p -> operand (1);

	q = create_operator (assign, 2);
	q -> operand (2) = r;

	t = create_symbol (cur_block, null, by_compiler);
	substr (string (t -> symbol.attributes), 1, 36) = string (rtype) & undesirable_mask & ^unaligned_mask;
	t -> symbol.c_dcl_size = rprecision;
	t -> symbol.scale = rscale;
	t -> symbol.auto, t -> symbol.precision, t -> symbol.allocate = "1"b;

	call declare (t);

	t = t -> symbol.reference;

	q -> operand (1), r -> operand (2) = t;

	p -> operand (1) = expression_semantics (cur_block, statement_ptr, q, this_context);

	r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
	     (statement_ptr -> statement.prefix));
	r -> statement.generated = "1"b;

	p = create_operator (assign, 2);
	p -> operand (1) = t;
	if opcode = add then
	     p -> operand (2) = create_token ("0", dec_integer);
	else
	     p -> operand (2) = create_token ("1", dec_integer);

	r -> statement.root = operator_semantics (cur_block, r, p, this_context);

	r = create_statement (assignment_statement, r, null, (r -> statement.prefix));
	r -> statement.generated = "1"b;
	r -> statement.root = operator_semantics (cur_block, r, arg (1), this_context);

	tree = t;

	goto ret;

action (44):					/* nullo */
	i = -1;
	tree = declare_constant (unspec (i), offset_mask, 0, 0);

	goto exit;

action (45):					/* dot */
	p = create_operator (mult, 3);
	p -> operand (2) = arg (1);
	p -> operand (3) = arg (2);

	p = expand_infix (cur_block, statement_ptr, p, "0"b);

	if p -> operator.op_code ^= loop then
	     call semantic_translator$abort (190, builtin_symbol);
	if p -> operand (1) -> operator.op_code ^= mult then
	     call semantic_translator$abort (190, builtin_symbol);

	r = p -> operand (1) -> operand (1);
	string (rtype) = string (r -> reference.symbol -> symbol.attributes);
	rprecision = constant_value (arg_symbol (3));
	if arg_number = 4 then
	     rscale = constant_value (arg_symbol (4));

	arg (1) = p;

	goto product;

action (46):					/* convert */
	arith_size_ck, string_size_ck = "1"b;

	if def_save_context.aggregate then
	     goto err124;
	if arg (1) -> node.type ^= reference_node then
	     goto err124;

	tree = convert$to_target_fb (arg (2), arg (1));

	goto ret;

action (47):					/* size */
action (64):					/* currentsize */
	if arg (1) -> node.type ^= reference_node then
	     goto err124;
	if arg (1) -> reference.symbol -> symbol.father ^= null then
	     goto err124;

	p = arg (1) -> reference.symbol -> symbol.word_size;

	if p = null then
	     tree =
		declare_constant (unspec (arg (1) -> reference.symbol -> symbol.c_word_size), integer_type,
		max_offset_precision, 0);
	else do;
	     tree = copy_expression ((p));
	     if jump_index = 64 then
		if arg_symbol (1) -> symbol.refer_extents then
		     call refer_extent (tree, (arg (1) -> reference.qualifier));

	     tree =
		expression_semantics ((arg (1) -> reference.symbol -> symbol.block_node), statement_ptr, tree,
		this_context);
	     arg (1) = tree;

	     goto create_assign;
	end;

	goto ret;

action (48):					/* valid */
	if def_save_context.aggregate then
	     goto err124;
	if arg (1) -> node.type ^= reference_node then
	     goto err124;
	if ^arg_symbol (1) -> symbol.picture then
	     goto err124;

	string (rtype) = bit_mask;
	rprecision = 1;

	arg_number = 2;
	arg (2) = arg_symbol (1) -> symbol.general;
	if arg (2) -> node.type ^= reference_node then
	     call semantic_translator$abort (440, arg_symbol (1));

	goto create_call;

action (49):					/* translate */
	goto create_operator_node;

action (50):					/* conjg */
	goto create_operator_node;

action (51):					/* onchar */
	string (rtype) = char_mask;
	rprecision = 1;

	goto create_call;

action (52):					/* onsource */
	goto action (42);

make_call:					/* this code is entered only for onsource & onchar pseudovariables */
	if pl1_stat_$cur_statement -> statement.root -> operand (1) ^= input_tree
	     & pl1_stat_$cur_statement -> statement.root -> operand (1)
	     ^= input_tree -> reference.symbol -> symbol.token then
	     if pl1_stat_$cur_statement -> statement.root -> op_code = assign then
		call semantic_translator$abort (187, builtin_symbol);
	     else
		arg (1) = null;			/*   get list(onchar | onsource);   */

	else do;					/*   onsource | onchar = ...;   */
	     def_context.return_from_empty = "1"b;
	     arg (1) =
		expression_semantics (cur_block, statement_ptr,
		(pl1_stat_$cur_statement -> statement.root -> operand (2)), "0"b);

	     if arg (1) -> node.type = token_node then
		arg (1) = convert (arg (1), char_mask);

	     if arg (1) -> node.type = operator_node then
		ref (1) = arg (1) -> operand (1);
	     else
		ref (1) = arg (1);
	end;

	if arg (1) = null | jump_index = 52 /*   get list(onchar|onsource);  |  onsource = ...;   */ then do;
	     s = create_symbol (cur_block, null, by_compiler);
	     s -> symbol.char, s -> symbol.auto, s -> symbol.passed_as_arg, s -> symbol.reference -> reference.shared =
		"1"b;

	     if jump_index = 52 then do;
		s -> symbol.varying = "1"b;
		s -> symbol.c_dcl_size = 256;
	     end;
	     else
		s -> symbol.c_dcl_size = 1;

	     s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;

	     call declare (s);

	     if ^def_context.return_from_empty then
		arg (1) = s -> symbol.reference;
	     else do;
		p = create_operator (assign, 2);
		p -> operand (1) = s -> symbol.reference;
		p -> operand (2) = arg (1);

		p -> operand (1) -> reference.c_length = t -> operand (1) -> reference.c_length;
		p -> operand (1) -> reference.length = share_expression ((t -> operand (1) -> reference.length));

		q = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
		     (statement_ptr -> statement.prefix));
		q -> statement.root = p;

		arg (1) = p -> operand (1);
	     end;
	end;

	tree = create_operator (std_call, 3);
	tree -> operand (2) = reserve$declare_lib ((reserved_number));
	tree -> operand (3) = create_operator (std_arg_list, 3);
	tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4, 0, null);
	tree -> operand (3) -> operand (2) = create_list (1);
	tree -> operand (3) -> operand (2) -> element (1) = arg (1);

	if ^def_context.return_from_empty then do;
	     p = tree;
	     tree = create_operator (join, 3);
	     tree -> operand (1) = create_operator (assign, 2);
	     tree -> operand (1) -> operand (1) = share_expression (arg (1));
	     tree -> operand (1) -> operand (2) = share_expression (t);
						/*   result of create_call, to get_onchar or to getonsource   */
	     tree -> operand (2) = share_expression (arg (1));
	     tree -> operand (3) = p;
	end;

	goto exit;

action (53):					/* oncode */
	string (rtype) = integer_type;
	rprecision = default_fix_bin_p;

	goto create_call;

action (54):					/* acos
   asin
   atan
   atand
   cos
   cosd
   exp
   log
   log10
   log2
   sin
   sind
   sqrt
   tan
   tand */
	if arg_number > 1 then
	     rprecision = max (rprecision, arg_symbol (2) -> symbol.c_dcl_size);

	if arg_type (1).complex then
	     goto action (25);

	goto create_operator_node;

action (55):					/* after */
	if arg_type (1).bit & arg_type (2).bit then
	     string (type) = bit_mask;
	else
	     string (type) = char_mask;

	do i = 1 to 2;
	     call convert_arg;
	end;

make_add:
	offset = create_operator (add, 3);
	offset -> operand (2) = create_index_or_verify ();
	offset -> operand (3) = declare_constant$integer (1);

	tree = make_builtin_reference ("substr", 2, arg (1), offset, null);
	go to exit;

action (56):					/* before */
	if arg_type (1).bit & arg_type (2).bit then
	     string (type) = bit_mask;
	else
	     string (type) = char_mask;

	do i = 1 to 2;
	     call convert_arg;
	end;

	tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), create_index_or_verify ());
	go to exit;

action (57):					/* ltrim */
	if arg_number = 1 then
	     arg (2) = declare_constant$char (" ");	/* <blank> */

	go to make_add;

action (58):					/* rtrim */
	if arg_number = 1 then
	     arg (2) = declare_constant$char (" ");	/* <blank> */

	if ref (1) -> reference.varying_ref then
	     p = create_length_fun (arg (1));
	else if ref (1) -> reference.length = null then
	     p = declare_constant$integer ((ref (1) -> reference.c_length));
	else
	     p = share_expression ((ref (1) -> reference.length));

	length = create_operator (sub, 3);
	length -> operand (2) = p;
	length -> operand (3) = create_index_or_verify ();

	tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), length);
	go to exit;

action (59):					/* collate9 */
	tree = declare_constant$char (pl1_data$long_collating_sequence);

	goto ret;

action (60):					/* high9 */
	arg (2) = arg (1);
	ref (2) = ref (1);
	arg_symbol (2) = arg_symbol (1);

	arg (1), ref (1) = declare_constant ("111111111"b, char_type, 1, 0);
	arg_symbol (1) = ref (1) -> reference.symbol;

	arg_number = 2;
	string (rtype) = char_type;

	goto repeat;

action (61):					/* stackbaseptr */
						/* stackframeptr */
	go to prepare_pointer;

action (62):					/* clock */
						/* vclock */
	string (rtype) = integer_type;
	rprecision = 71;
	go to create_operator_node;

action (63):					/* codeptr */
						/* environmentptr */
	go to prepare_pointer;

action (66):					/* stacq */
	string (rtype) = bit_mask;
	rprecision = 1;
	go to create_operator_node;

action (67):					/* substraddr */
	go to err359;

action (68):					/* byte */
	string (rtype) = char_type;
	rprecision = 1;
	go to create_operator_node;

action (69):					/* rank */
	if ^constant_length (ref (1), 1) then
	     call semantic_translator$abort (390, arg_symbol (1));
						/* first arg to rank must be char(1) */

	string (rtype) = integer_type;
	rprecision = 9;
	go to create_operator_node;

prepare_pointer:
	rprecision, rscale = 0;

	rlength = null;

	string (rtype) = pointer_type;

	goto create_operator_node;

create_call:
	p = create_list (arg_number + 1);
	do i = 1 to arg_number;
	     p -> element (i) = arg (i);
	end;

	tree = create_operator (std_call, 3);
	tree -> operand (2) = reserve$declare_lib ((reserved_number));

	if jump_index = 24 /* decat */ | jump_index = 25 /* math bifs */ | jump_index = 26 /* lbound, hbound, dim */
	then do;
	     tree -> operand (2) -> reference.symbol -> symbol.irreducible = "0"b;
	     tree -> operand (2) -> reference.symbol -> symbol.reducible = "1"b;
	end;

	tree -> operand (3) = create_operator (std_arg_list, 3);
	tree -> operand (3) -> operand (2) = p;

	if desc_reqd then do;

/* we will have star extents return value */

	     tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4 * arg_number + 6, 0, null);
	     q, tree -> operand (3) -> operand (3) = create_list (arg_number + 1);

	     s = create_symbol (cur_block, null, by_compiler);

	     string (s -> symbol.data_type) = string (arg_symbol (1) -> symbol.data_type);
	     string (s -> symbol.misc_attributes) = string (arg_symbol (1) -> symbol.misc_attributes);

	     s -> symbol.dimensioned, s -> symbol.initialed, s -> symbol.variable, s -> symbol.position,
		s -> symbol.internal, s -> symbol.external, s -> symbol.like, s -> symbol.member = "0"b;

	     s -> symbol.return_value, s -> symbol.passed_as_arg, s -> symbol.star_extents = "1"b;

	     s -> symbol.dcl_size = create_token ("*", asterisk);

	     call declare (s);

	     q -> element (arg_number + 1) = s -> symbol.descriptor;

	     do i = 1 to arg_number;
		q -> element (i) =
		     declare_descriptor (cur_block, statement_ptr, arg_symbol (i), (ref (i) -> reference.qualifier),
		     "0"b);
	     end;

	     p -> element (p -> list.number), tree -> operand (1) = s -> symbol.reference;

	     tree -> operand (1) -> reference.ref_count = 3;
	     tree -> operand (1) -> reference.shared = "0"b;
	     tree -> operand (1) -> reference.length -> operand (1) =
		declare_temporary (integer_type, max_offset_precision, 0, null);
	     tree -> operand (1) -> reference.length -> operator.processed = "1"b;

	     call check_star_extents ((tree -> operand (2) -> reference.symbol), p);

	     statement_ptr -> statement.force_nonquick = "1"b;
	     call make_non_quick ((statement_ptr -> statement.root), "001"b);

	     p = create_statement (call_statement, (statement_ptr -> statement.back), null,
		(statement_ptr -> statement.prefix));
	     p -> statement.root = tree;
	     p -> statement.processed = "1"b;
	end;
	else do;
	     t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
	     s = copy_expression (t -> reference.symbol);
	     s -> symbol.passed_as_arg = "1"b;
	     q = s -> symbol.reference;
	     q -> reference.shared = "0"b;
	     q -> reference.ref_count = 2;

	     p -> element (p -> list.number), tree -> operand (1) = q;

	     temp_size = 2 * (arg_number + 1) + 2;

	     if jump_index = 26 /*   hbound, lbound, dim   */ then do;

/* this has star_extent args but constant extent return_value */

		temp_size = 4 * (arg_number + 1) + 2;

		tree -> operand (3) -> operand (3), q = create_list (arg_number + 1);

		ref (5) = q;
		arg_symbol (5) = s;

		do i = 1 to q -> list.number;
		     q -> element (i) =
			declare_descriptor (cur_block, statement_ptr, arg_symbol (i),
			(ref (i) -> reference.qualifier), (ref (i) -> reference.array_ref));
		end;
	     end;

	     tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, temp_size, 0, null);
	end;

	if def_context.left_side /*   only onchar and onsource has this property   */ then do;
	     if jump_index = 51 /*   onchar   */ then
		reserved_number = 11;		/*   on_data_$set_onchar   */
	     else
		reserved_number = 194;		/*   on_data_$setonsource   */

	     tree -> operand (2) -> reference.symbol -> symbol.irreducible = "1"b;
	     t = tree;

	     goto make_call;
	end;

	goto exit;

create_assign:
	t = create_operator (assign, 2);
	t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
	t -> operand (2) = arg (1);

	tree = t;

	goto exit;

convert_to_arith:
	arith_size_ck = "1"b;			/* This makes us check size-enabled after assign_op  is made */
	string (rtype) = string (rtype) | aligned_mask;

	if arg_type (1).char then
	     defined_arg_type (1) = fixed_decimal_real_mask;
	else if arg_type (1).bit then
	     defined_arg_type (1) = fixed_binary_real_mask;
	else if arg_type (1).picture then
	     if arg_symbol (1) -> symbol.complex then
		if arg_symbol (1) -> symbol.pix.pic_float then
		     defined_arg_type (1) = float_decimal_complex_mask;
		else
		     defined_arg_type (1) = fixed_decimal_complex_mask;
	     else if arg_symbol (1) -> symbol.pix.pic_float then
		defined_arg_type (1) = float_decimal_real_mask;
	     else
		defined_arg_type (1) = fixed_decimal_real_mask;

	if ^rtype.fixed & ^rtype.float then do;
	     rtype.fixed = arg_type (1).fixed;
	     rtype.float = arg_type (1).float;
	end;

	if ^rtype.decimal & ^rtype.binary then do;
	     rtype.decimal = arg_type (1).decimal;
	     rtype.binary = arg_type (1).binary;
	end;

	if ^rtype.real & ^rtype.complex then do;
	     rtype.real = arg_type (1).real;
	     rtype.complex = arg_type (1).complex;
	end;

	full_attribute_set = arg_number > 1;

check_prec_scale:
	rlength = null;

	if rscale < min_scale | rscale > max_scale then
	     goto err146;

	if rtype.decimal then
	     if rprecision > max_p_dec then
		goto err146;
	     else
		;

	else if rtype.fixed then
	     if rprecision > max_p_fix_bin_2 then
		goto err146;
	     else
		;
	else if rprecision > max_p_flt_bin_2 then
	     goto err146;

convert_label:
	if rprecision < 0 then
	     goto err481;

	if full_attribute_set then do;
	     t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
	     tree = convert$to_target_fb (arg (1), t);
	end;
	else
	     tree = convert$from_builtin (arg (1), string (rtype));

	goto ret;

create_operator_node:
	if rprecision < 0 then
	     goto err481;

	t = declare_temporary (string (rtype), rprecision, (rscale), rlength);

	tree = create_operator (opcode, arg_number + 1);
	tree -> operand (1) = t;

	do i = 1 to arg_number;
	     tree -> operand (i + 1) = arg (i);
	end;

	tree -> operator.processed = "1"b;

	goto exit;

return_arg1:
	tree = arg (1);

	goto ret;

expand_arguments:
     proc () returns (ptr);

	dcl      (p, q, r) ptr,
	         (lpp, jpp) ptr init (null),
	         (lp, jp, cp) (128) ptr init ((128) null),
	         (i, j, k, lll) fixed bin (15),
	         (jcount, lcount) fixed bin (15) init (0),
	         ll (128) fixed bin (15) init ((128) 0);

	dcl      (full_processing, pure_array) bit (1) aligned init ("0"b);

	do i = 1 to arg_number;
	     p = subscripts -> element (i);

	     if p -> node.type = operator_node then
		if p -> op_code = loop then do;
		     lp (i) = p;
		     lcount = lcount + 1;

		     do q = p repeat q -> operand (1) while (q -> op_code = loop);
			ll (i) = ll (i) + 1;
		     end;

		     p = q;

		     if lpp = null then do;
			lpp = lp (i);
			lll = ll (i);
		     end;
		end;

	     if p -> node.type = operator_node then
		if p -> op_code = join then do;
		     jp (i) = p;
		     jcount = jcount + 1;
		end;

	     if jp (i) ^= null then
		if jpp = null then
		     jpp = p;
		else
		     ;
	     else
		cp (i) = p;

	     if lp (i) ^= null & cp (i) ^= null then
		pure_array = "1"b;
	end;

	if lpp ^= null then
	     do i = 1 to arg_number;
		if ll (i) ^= lll & ll (i) ^= 0 then
		     call semantic_translator$abort (79, null);
	     end;

	if pure_array then
	     if jpp ^= null then
		call semantic_translator$abort (79, null);
	     else do;
		p = create_list ((arg_number));
		do i = 1 to arg_number;
		     p -> element (i) = cp (i);
		end;

		p = builtin (cur_block, statement_ptr, tree, p, builtin_symbol, "0"b);
	     end;

	if jpp ^= null then
	     jpp = merge (jpp, jp);

	if lpp = null then
	     return (jpp);

	q = lpp;

	do i = 2 to lll;
	     q = q -> operand (1);
	end;

	if jpp ^= null then
	     q -> operand (1) = jpp;
	else
	     q -> operand (1) = p;

	if lcount = 1 then
	     return (lpp);

	do i = 1 to arg_number;

	     p = lpp;
	     q = lp (i);

	     if q ^= null & q ^= p then
		do j = 1 to lll;

		     if ^compare_expression ((p -> operand (4)), (q -> operand (4))) then do;
			if p -> operand (4) -> node.type = reference_node then
			     if p -> operand (4) -> reference.symbol -> symbol.constant then
				if q -> operand (4) -> node.type = reference_node then
				     if q -> operand (4) -> reference.symbol -> symbol.constant then
					call semantic_translator$abort (79, null);

			full_processing = "1"b;
		     end;

		     p = p -> operand (1);
		     q = q -> operand (1);
		end;
	end;

	if ^full_processing then
	     return (lpp);

	if lcount = 2 then do;
	     p = lpp;
	     q = null;

	     do i = arg_number to 1 by -1 while (q = null);
		q = lp (i);
	     end;

	     do i = 1 to lll;

		jpp = create_operator (bound_ck, 4);
		jpp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
		jpp -> operand (2) = p -> operand (4);
		jpp -> operand (3) = q -> operand (4);
		jpp -> operand (4) = share_expression ((q -> operand (4)));

		p -> operand (4) = jpp;
		p = p -> operand (1);
		q = q -> operand (1);
	     end;

	     return (lpp);
	end;

	r = lpp;

	do i = 1 to lll;

	     jpp = create_operator (bound_ck, 4);
	     p = create_operator (min_fun, lcount + 1);
	     q = create_operator (max_fun, lcount + 1);
	     p -> operand (1), q -> operand (1), jpp -> operand (1) =
		declare_temporary (integer_type, default_fix_bin_p, 0, null);
	     jpp -> operand (2) = p;
	     jpp -> operand (3) = q;
	     jpp -> operand (4) = share_expression (q);

	     r -> operand (4) = jpp;
	     r = r -> operand (1);

	     k = 2;

	     do j = 1 to arg_number;
		if lp (j) ^= null then do;
		     p -> operand (k) = share_expression ((lp (j) -> operand (4)));
		     q -> operand (k) = share_expression ((lp (j) -> operand (4)));

		     k = k + 1;
		     lp (j) = lp (j) -> operand (1);
		end;
	     end;
	end;

	return (lpp);

merge:
     proc (p, rp) returns (ptr);

	dcl      (
	         p,
	         pp,
	         q,
	         o1,
	         o2,
	         o3,
	         rp (128),
	         rpp (128)
	         ) ptr,
	         (i, j, k) fixed bin (15),
	         unmatch_bound bit (1) aligned init ("0"b);

	if p -> node.type = operator_node then do;
	     if p -> op_code = loop then do;
		do i = 1 to arg_number;
		     if cp (i) = null then do;
			if rp (i) -> node.type ^= operator_node then
			     call semantic_translator$abort (79, null);
			if rp (i) -> op_code ^= loop then
			     call semantic_translator$abort (79, null);

			if ^compare_expression ((p -> operand (4)), (rp (i) -> operand (4))) then
			     unmatch_bound = "1"b;
		     end;
		end;

		if unmatch_bound then do;
		     o1 = create_operator (bound_ck, 4);
		     o2 = create_operator (min_fun, jcount + 1);
		     o3 = create_operator (max_fun, jcount + 1);

		     o2 -> operand (1), o3 -> operand (1), o1 -> operand (1) =
			declare_temporary (integer_type, default_fix_bin_p, 0, null);
		     o1 -> operand (2) = o2;
		     o1 -> operand (3) = o3;
		     o1 -> operand (4) = share_expression (o3);

		     k = 2;

		     do i = 1 to arg_number;
			if cp (i) = null then do;
			     o2 -> operand (k) = share_expression ((rp (i) -> operand (4)));
			     o3 -> operand (k) = share_expression ((rp (i) -> operand (4)));
			     k = k + 1;
			end;
		     end;

		     p -> operand (4) = o1;
		end;

		pp = p -> operand (1);

		do i = 1 to arg_number;
		     if cp (i) = null then
			rpp (i) = rp (i) -> operand (1);
		end;

		p -> operand (1) = merge (pp, rpp);

		return (p);
	     end;

	     if p -> op_code = join then do;
		do i = 1 to arg_number;
		     if cp (i) = null then do;
			if rp (i) -> node.type ^= operator_node then
			     call semantic_translator$abort (79, null);
			if rp (i) -> op_code ^= join then
			     call semantic_translator$abort (79, null);
		     end;
		end;

		do j = 1 to p -> operator.number;
		     pp = p -> operand (j);

		     do i = 1 to arg_number;
			if cp (i) = null then
			     rpp (i) = rp (i) -> operand (j);
			else if j > 1 then
			     cp (i) = share_expression (cp (i));
		     end;

		     p -> operand (j) = merge (pp, rpp);
		end;

		return (p);
	     end;
	end;

	do i = 1 to arg_number;
	     if cp (i) = null then
		if rp (i) -> node.type = operator_node then
		     if rp (i) -> op_code = loop | rp (i) -> op_code = join then
			call semantic_translator$abort (79, null);
	end;

	q = create_list ((arg_number));

	do i = 1 to arg_number;
	     if cp (i) = null then
		q -> element (i) = rp (i);
	     else
		q -> element (i) = cp (i);
	end;

	return (builtin (cur_block, statement_ptr, tree, q, builtin_symbol, "0"b));

     end merge;

     end expand_arguments;

check_reverse:
     proc (p) returns (bit (1) aligned);

/* See if pointer points to a call on reverse operator, unshared */
	dcl      p ptr;

	if p -> node.type = operator_node then
	     if p -> operator.op_code = reverse_fun then
		if p -> operator.operand (1) -> reference.shared
		     | p -> operator.operand (1) -> reference.ref_count = 1 then
		     return ("1"b);
	return ("0"b);

     end check_reverse;

is_this_constant:
     proc (p) returns (bit (1) aligned);

	dcl      p ptr;

	if p -> node.type = reference_node then
	     if p -> reference.symbol -> symbol.constant then
		if ^p -> reference.varying_ref then
		     if p -> reference.length = null & p -> reference.offset = null & p -> reference.c_offset = 0 then
			return ("1"b);
	return ("0"b);

     end is_this_constant;

check_strings:
     proc (pt);

	dcl      (p, pt) ptr;

	p = pt;

	do while (p ^= null);

	     if p -> symbol.structure then
		call check_strings ((p -> symbol.son));

	     else if units = bit_ & ^p -> symbol.bit | units = character_ & ^p -> symbol.char & ^p -> symbol.picture
		then
		call semantic_translator$abort (139, arg_symbol (1));

	     p = p -> symbol.brother;
	end;

     end check_strings;

convert_arg:
     proc;

	dcl      suppress_diagnostic bit (1) aligned;

	if defined_arg_type (i) & structure_mask then
	     return;

	if string (type) & arithmetic_mask then do;
	     if defined_arg_type (i) & arithmetic_mask then
		;
	     else if arg_type (i).bit then do;
		type.fixed = ^type.float;
		type.binary = ^type.decimal;
		type.real = ^type.complex;
	     end;

	     else if arg_type (i).char then do;
		type.fixed = ^type.float;
		type.decimal = ^type.binary;
		type.real = ^type.complex;
	     end;

	     if ^type.fixed & ^type.float then do;
		type.fixed = arg_type (i).fixed;
		type.float = arg_type (i).float;
	     end;

	     if ^type.decimal & ^type.binary then do;
		type.decimal = arg_type (i).decimal;
		type.binary = arg_type (i).binary;
	     end;

	     if ^type.real & ^type.complex then do;
		type.real = arg_type (i).real;
		type.complex = arg_type (i).complex;
	     end;
	end;

	suppress_diagnostic = i = 1 & (jump_index = 17 | jump_index = 19);

	if arg (i) -> node.type = token_node then
	     if suppress_diagnostic then
		arg (i) = convert$from_builtin (arg (i), string (type));
	     else
		arg (i) = convert (arg (i), string (type));

	else if type.decimal & arg_type (i).decimal & ^arg_symbol (i) -> symbol.char then
	     ;
	else if type.binary & arg_type (i).binary & type.real = arg_type (i).real & type.fixed = arg_type (i).fixed then
	     ;
	else if suppress_diagnostic then
	     arg (i) = convert$from_builtin (arg (i), string (type));
	else
	     arg (i) = convert (arg (i), string (type));

	ref (i) = arg (i);
	defined_arg_type (i) = string (type);

	if ref (i) -> node.type = operator_node then do;
	     ref (i) -> operator.processed = "1"b;	/* to prevent operator_semantics from calling convert$validate */
	     ref (i) = ref (i) -> operand (1);
	end;

	arg_symbol (i) = ref (i) -> reference.symbol;

     end convert_arg;

make_assignment:
     proc;

	p = create_operator (assign, 2);
	r = create_symbol (null, null, by_compiler);
	r -> symbol.temporary = "1"b;
	p -> operand (1) = r -> symbol.reference;
	p -> operand (2) = arg (1);

	r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
	     (statement_ptr -> statement.prefix));
	r -> statement.root = p;
	r -> statement.generated = "1"b;

	if arg (1) -> node.type = operator_node then
	     if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join then do;
		def_this_context.RHS_aggregate = "1"b;

		r -> statement.root = expand_assign (cur_block, r, (r -> statement.root), this_context, agg_ref);
		return;
	     end;

	r -> statement.root = operator_semantics (cur_block, r, (r -> statement.root), this_context);
	agg_ref = r -> statement.root -> operand (1);
	if agg_ref -> reference.shared then do;
	     agg_ref -> reference.shared = "0"b;
	     agg_ref -> reference.ref_count = 1;
	end;

     end make_assignment;

/**/
declare_defined_overlay:
     proc (p_type, p_precision, p_scale, p_length, qual) returns (ptr);

/* pools defined overlays in a similar fashion as declare_temporary
	   pools temporarys.  Used for unspec, string, imag, real */

	dcl      p_type bit (36) aligned,
	         (p_precision, precision) fixed bin (31),
	         (p_scale, scale) fixed bin (15),
	         (p_length, length) ptr,
	         qual ptr;

	dcl      units fixed bin (3);
	dcl      c_offset fixed bin (24);
	dcl      (r, s, t) ptr;
	dcl      pl1_stat_$defined_list ptr ext;
	dcl      (addr, null) builtin;
	dcl      bit36 bit (36) based (addr (s -> symbol.data_type));
	dcl      found bit (1) aligned;

/* Assumption:  if length is not null, then length must not be an
	   unshared processed tree, because otherwise ref_count goes too
	   high */

	precision = p_precision;
	scale = p_scale;
	length = p_length;

/* the qualifier's units and c_offset are used so that simplify_offset
	   will correctly handle cases of substr(string(..),<expr>...) */

	if qual -> node.type = reference_node then do;
	     units = qual -> reference.units;
	     c_offset = qual -> reference.c_offset;
	end;
	else
	     units, c_offset = 0;

	found = "0"b;

/* search for suitable symbol */

	s = pl1_stat_$defined_list;

	do while (s ^= null & ^found);
	     if bit36 = p_type & s -> symbol.position = "1"b & s -> symbol.c_dcl_size = precision
		& s -> symbol.scale = scale & s -> symbol.dcl_size = length
		& s -> symbol.reference -> reference.shared & s -> symbol.reference -> reference.c_offset = c_offset
		& s -> symbol.reference -> reference.units = units then
		found = "1"b;
	     else
		s = s -> symbol.multi_use;
	end;

	if ^found then do;

/* None found -- make one with declare_temporary's help.
	        Note that although declare_temporary makes unshared
	        temporaries if length ^= null, that they are unique. */

	     r = copy_expression (declare_temporary (p_type, precision, scale, length));

	     s = create_symbol (null, null, by_compiler);
	     t = r -> reference.symbol;
	     s -> symbol = t -> symbol;
	     s -> symbol.next = null;
	     s -> symbol.reference = r;
	     r -> reference.symbol = s;
	     r -> reference.units = units;
	     r -> reference.c_offset = c_offset;

	     s -> symbol.packed = s -> symbol.unaligned;
	     s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
	     s -> symbol.temporary = "0"b;

	     s -> symbol.multi_use = pl1_stat_$defined_list;
	     pl1_stat_$defined_list = s;
	end;

/* we need a unique reference node */

	r = copy_expression (s -> symbol.reference);
	r -> reference.shared = "0"b;
	r -> reference.ref_count = 1;
	r -> reference.units = 0;
	r -> reference.c_offset = 0;

	return (r);

     end;

/*  subroutine to create a length_fun operator and return a ptr to it  */

create_length_fun:
     proc (op2) returns (ptr);

	dcl      (op2, p) pointer;
	p = create_operator (length_fun, 2);
	p -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
	p -> operand (2) = share_expression (op2);
	p -> operator.processed = "1"b;
	return (p);
     end create_length_fun;






/*  subroutine to increment a reference node's qualifier and offset's reference count	*/

reuse_qual_and_offset:
     proc (p_param);

	dcl      (p, p_param) ptr;

	p = p_param;

	if p -> reference.qualifier ^= null then
	     p -> reference.qualifier = share_expression ((p -> reference.qualifier));
	if p -> reference.offset ^= null then
	     p -> reference.offset = share_expression ((p -> reference.offset));

     end reuse_qual_and_offset;


/* function to see if a symbol represents an unpacked real fixed binary integer value */

fb1_value:
     proc (s) returns (bit (1) aligned);

	dcl      s ptr;

	if s -> symbol.fixed & s -> symbol.binary & ^s -> symbol.complex & ^s -> symbol.packed
	     & s -> symbol.c_dcl_size <= max_p_fix_bin_1 & s -> symbol.scale = 0 then
	     return ("1"b);

	else
	     return ("0"b);

     end fb1_value;


/* function to create an index or verify operator and operands for after, before, ltrim, or rtrim */

create_index_or_verify:
     proc returns (ptr);

	dcl      p ptr;

	p = create_operator (opcode, 3);
	p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_length_precision, 0, null);
	p -> operand (2) = share_expression (arg (1));
	p -> operand (3) = arg (2);
	p -> operator.processed = "1"b;
	return (p);

     end create_index_or_verify;

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

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

/* parameter */

	dcl      sym_ptr ptr;

/* based */

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

/* constant */

	dcl      max_24_bit_integer fixed bin (24) int static options (constant) init (111111111111111111111111b);

/* builtin */

	dcl      abs builtin;

/* automatic */

	dcl      initial_value fixed bin (71);

	dcl      convert builtin;

/* Accept the constant's bit pattern. */

	if sym_ptr -> symbol.constant then
	     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;

/* Convert the symbol's initializing token string. */

	else if sym_ptr -> symbol.alloc_in_text then
	     if sym_ptr -> symbol.initial -> list.element (1) -> token.string = "1" then
		initial_value =
		     convert (initial_value, sym_ptr -> symbol.initial -> list.element (2) -> token.string);

	     else
		initial_value = max_24_bit_integer + 1; /* ERROR */
	else
	     initial_value = max_24_bit_integer + 1;	/* ERROR */

	if abs (initial_value) > max_24_bit_integer then
	     go to err146;

	return (initial_value);

     end /* constant_value */;

/* Return true if symbol is a constant. */

symbol_is_constant:
     proc (sym_ptr) returns (bit (1));

	dcl      sym_ptr ptr;

	if sym_ptr -> symbol.constant | (sym_ptr -> symbol.alloc_in_text & sym_ptr -> symbol.array = null ()) then
	     return ("1"b);
	else
	     return ("0"b);
     end symbol_is_constant;				/**/
make_builtin_reference:
     proc (builtin_name, nargs, arg1, arg2, arg3) returns (ptr);

/* constructs a builtin reference and processes it.  the context given to builtin
   is passed through */

	dcl      builtin_name char (*),
	         nargs fixed bin (15),
	         (arg1, arg2, arg3) ptr;

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

/* since we don't know if the builtin is declared, we declare
	   a special symbol in the root block */

	n = nargs;
	p = create_token ("cp.bif." || builtin_name, identifier);

	if p -> token.declaration = null then do;

/* we must make a symbol */

	     do i = number_of_names to 1 by -1 while (pl1_data$builtin_name (i).name ^= builtin_name);
	     end;

	     s = create_symbol ((pl1_stat_$root), p, by_compiler);

	     s -> symbol.builtin = "1"b;
	     s -> symbol.c_dcl_size = i;
	     p -> token.declaration = s;
	end;

	else
	     s = p -> token.declaration;

	subs = create_list (n);
	if n > 0 then do;
	     subs -> element (n) = arg1;
	     if n > 1 then do;
		subs -> element (n - 1) = arg2;
		if n > 2 then
		     subs -> element (n - 2) = arg3;
	     end;
	end;

	return (builtin (cur_block, statement_ptr, (s -> symbol.reference), subs, s, context));

     end;

/*      */
err124:
	error_number = 124;
	goto abort;

err146:
	error_number = 146;
	goto abort;

err481:
	error_number = 481;
	goto abort;

err359:
	error_number = 359;
	goto abort;

err381:
	error_number = 381;
	goto abort;

abort:
	call semantic_translator$abort (error_number, builtin_symbol);

ret:
	if def_context.arg_list & tree -> node.type = reference_node & ^pseudo_variable then do;
	     arg (1) = tree;
	     string (rtype) = string (tree -> reference.symbol -> symbol.attributes);
	     if jump_index ^= 46 /* we dont change result type for convert!	*/ then
		rtype.varying = "0"b;
	     arg_number = 1;
	     opcode = assign;
	     goto create_operator_node;
	end;

	if arith_size_ck then			/* since we will mark the operator as processed, we must do the */
						/* work of op_semantics in changeing an assign to an assign_size_ck */
						/* if size or stringrange are enabled and the left hand side of the  */
						/* assignment is subject to the condition.	*/
	     if substr (statement_ptr -> statement.prefix, 6, 1) then
		if arg_type (1).fixed | arg_type (1).float then
		     if tree -> node.type = operator_node then
			if tree -> operator.op_code = assign then
			     tree -> operator.op_code = assign_size_ck;

	if string_size_ck then
	     if substr (statement_ptr -> statement.prefix, 9, 1) then
		if arg_type (1).char | arg_type (1).bit then
		     if tree -> node.type = operator_node then
			if tree -> operator.op_code = assign then
			     tree -> operator.op_code = assign_size_ck;

exit:
	if decimal_result then do;
	     targ_type = targ_type & ^dimensioned_mask & ^initialed_mask;
	     t = declare_temporary (targ_type, targ_prec, 0, null);
	     tree = convert$to_target_fb (tree, t);
	end;

	if tree -> node.type = operator_node then
	     tree -> operator.processed = "1"b;
	else
	     tree -> reference.processed = "1"b;

	return (tree);

/* include files */

%include semant;
%include array;
%include block;
%include boundary;
%include builtin_table;
%include cross_reference;
%include decoded_token_types;
%include declare_type;
%include label;
%include list;
%include mask;
%include nodes;
%include operator;
%include op_codes;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include pl1_symbol_type;
%include symbol_bits;
%include system;
%include token;
%include token_types;

     end builtin;




		    check_star_extents.pl1          10/03/83  1727.1rew 10/03/83  1006.4       19080



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


check_star_extents:	proc(ps,plist);

/* In any procedure call, if an operator_node having an output temporary with a length
   expression appears as an argument in a position corresponding to a star extent parameter
   descriptor (or in any position if the procedure is declared options(variable)), that
   procedure and any procedures invoked in arguments following that one must be made
   non-quick in order to avoid destroying the argument by shortening the stack.  (This fixes
   bug 816.)  This program is called only when it has been determined by the caller that
   descriptors are required.

   Written by:	Richard A. Barnes	13 December 1973	*/

dcl	(ps,plist) ptr;

dcl	options_variable bit(1) aligned;
dcl	(i,k,n) fixed bin;
dcl	(a,arg_list,s) ptr;

dcl	(fixed,null) builtin;

dcl	make_non_quick entry(ptr, bit (36) aligned);

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


	s = ps;
	arg_list = plist;

	n = arg_list -> list.number - fixed(s -> symbol.returns,1);

	do k = 1 to n;
	     a = arg_list -> element(k);
	     if a -> node.type = operator_node
	     then if a -> operand(1) -> reference.length ^= null
	     then do;
		if s -> symbol.constant
		then if s -> symbol.equivalence ^= null
		     then do;
			     s -> symbol.equivalence -> block.why_nonquick.stack_extended_by_args = "1"b;
			     s -> symbol.equivalence -> block.no_stack = "0"b;
			end;

		do i = k + 1 to n;
		     call make_non_quick((arg_list -> element(i)), "001"b);	/* block.why_nonquick.stack_extended_by_args */
		     end;

		return;
		end;

	     end;
end;




		    compare_declaration.pl1         07/31/89  1431.7r w 07/31/89  1338.4       52542



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


compare_declaration:	proc(pa,pb,ignore_aligned) returns(bit(1) aligned);

/* Modified 780712 by PG for unsigned */

dcl	(asize,bsize,pa,pb,a,b,ba,bb,as,bs) ptr;

dcl	(c_asize,c_bsize) fixed bin(31);

dcl	(i,ndims) fixed bin;

dcl	(array_bit, a_reference, b_reference) bit(1) aligned;

dcl	ignore_aligned bit(1) aligned;

dcl	(null,string,unspec) builtin;

	asize,bsize = null;
	c_asize,c_bsize = 0;
	if pa = pb then goto exit;
	if pa = null | pb = null then goto fail;

	if pa->node.type = reference_node
	then do;

		/* we're comparing for purposes of optimizing an assignment */

		a = pa->reference.symbol;
		array_bit = pa->reference.array_ref;
		a_reference = "1"b;
	end;
	else do;

		/* we're comparing entire declaration OR we were called by compare_declaration to process a structure member */

		a = pa;
		array_bit = a->symbol.dimensioned;
		a_reference = "0"b;
	end;

	if pb->node.type = reference_node
	then do;
		b = pb->reference.symbol;
		array_bit = array_bit | pb->reference.array_ref;
		b_reference = "1"b;
	end;
	else do;
		b = pb;
		array_bit = array_bit | b->symbol.dimensioned & ^ a_reference;
		b_reference = "0"b;
	end;

	if string(a->symbol.data_type) ^= string(b->symbol.data_type) then goto fail;
	if a->symbol.binary ^= b->symbol.binary then goto fail;
	if a->symbol.real ^= b->symbol.real then goto fail;
	if a->symbol.scale ^= b->symbol.scale then goto fail;
	if a->symbol.aligned ^= b->symbol.aligned
	then	if ^ ignore_aligned
		then	goto fail;
		else	if ^ (a->symbol.bit | a->symbol.char)
			then	goto fail;

	if a -> symbol.unsigned ^= b -> symbol.unsigned
	then go to fail;

	if a->symbol.varying ^= b->symbol.varying then goto fail;

	if a->symbol.picture
	then	if unspec(a->symbol.general->reference.symbol->symbol.initial->picture_image)
			^=unspec(b->symbol.general->reference.symbol->symbol.initial->picture_image)
		then	goto fail;

	asize = a->symbol.dcl_size;
	bsize = b->symbol.dcl_size;
	c_asize = a->symbol.c_dcl_size;
	c_bsize = b->symbol.c_dcl_size;

	if (a->symbol.bit|a->symbol.char) & a_reference & ^array_bit & ^a->symbol.varying
	then do;
		asize = pa->reference.length;
		c_asize = pa->reference.c_length;
	end;

	if (b->symbol.bit|b->symbol.char) & b_reference & ^array_bit & ^b->symbol.varying
	then do;
		bsize = pb->reference.length;
		c_bsize = pb->reference.c_length;
	end;

	if c_asize^=c_bsize
	then	goto fail;

	if asize^=bsize
	then	if a_reference & b_reference
		then	if ^ compare_expression(asize,bsize)
			then	goto fail;
			else;
		else 	goto fail;

	if array_bit
	then	if a->symbol.dimensioned^=b->symbol.dimensioned
		then	if a_reference
			then	goto fail;
			else do;
				if b->symbol.dimensioned
				then	if b->symbol.array->array.own_number_of_dimensions ^= 0
					then	goto fail;
					else;
				else	if a->symbol.array->array.own_number_of_dimensions ^= 0
					then	goto fail;
				array_bit = "0"b;
			end;

	if array_bit
	then do;
		if a->symbol.array->array.own_number_of_dimensions ^= b->symbol.array->array.own_number_of_dimensions
		then	goto fail;

		if a_reference
		then do;
			if a->symbol.array->array.number_of_dimensions ^= b->symbol.array->array.number_of_dimensions
			then	goto fail;

			if a->symbol.array->array.interleaved ^= b->symbol.array->array.interleaved
			then	goto fail;

			ndims = b->symbol.array->array.number_of_dimensions;
		end;
		else	ndims = b->symbol.array->array.own_number_of_dimensions;

		ba = a->symbol.array->array.bounds;
		bb = b->symbol.array->array.bounds;

		do i = 1 to ndims while(ba ^= null);
			if a->symbol.star_extents^=b->symbol.star_extents then goto fail;

			if ba->bound.c_lower ^= bb->bound.c_lower then goto fail;
			if ba->bound.c_upper ^= bb->bound.c_upper then goto fail;

			if ba->bound.lower=null & bb->bound.lower^=null
			then do;
				if bb->bound.lower->node.type^=reference_node
				then	goto fail;
				if ^bb->bound.lower->reference.symbol->symbol.constant
				then	goto fail;
			end;		else

			if ba->bound.lower^=null & bb->bound.lower=null
			then do;
				if ba->bound.lower->node.type^=reference_node
				then	goto fail;
				if ^ba->bound.lower->reference.symbol->symbol.constant
				then	goto fail;
			end;		else

			if ^compare_expression((ba->bound.lower),(bb->bound.lower))
			then	goto fail;

			if ba->bound.upper=null & bb->bound.upper^=null
			then do;
				if bb->bound.upper->node.type^=reference_node
				then	goto fail;
				if ^bb->bound.upper->reference.symbol->symbol.constant
				then	goto fail;
			end;		else

			if ba->bound.upper^=null & bb->bound.upper=null
			then do;
				if ba->bound.upper->node.type^=reference_node
				then	goto fail;
				if ^ba->bound.upper->reference.symbol->symbol.constant
				then	goto fail;
			end;		else

			if ^compare_expression((ba->bound.upper),(bb->bound.upper))
			then	goto fail;

			ba = ba->bound.next;
			bb = bb->bound.next;
		end;
	end;

	if a->symbol.structure
	then do;
		as = a->symbol.son;
		bs = b->symbol.son;

		do while(as ^= null);
			if bs=null
			then	goto fail;

			if ^compare_declaration(as,bs,"0"b)
			then	goto fail;

			as = as->symbol.brother;
			bs = bs->symbol.brother;
		end;

		if bs^=null
		then	goto fail;
	end;

exit:
	return("1"b);

fail:
	return("0"b);

%include semant;

%include array;
%include nodes;
%include picture_image;
%include reference;
%include symbol;

	end compare_declaration;




		    context_processor.pl1           07/31/89  1431.7r w 07/31/89  1338.4      105705



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


/* Modified 780814 by PG to fix 1771 (incorrectly diagnosing refer-with-like error.
   Modified: 30 August 1979 by PCK to remove refer-with-like diagnostic
   Modified: 30 August 1979 by PCK to fix 1804 and 1823
   Modified: 22 September 1980 by M. N. Davidoff to set symbol.structure after like attribute is expanded.  Fixes 2013.
   Modified: 16 February 1981 by M. N. Davidoff to allow likes to likes and to implement 1952
	(diagnose dcl 1 a, 2 b like a).
   Modified: 23 February 1981 by M. N. Davidoff to resolve like references before any like attributes are expanded.
	Fixes 2057.
   Modified: 10 June 1981 by PCK to fix bug 2074--faulting on declarations
     with factored like attributes and qualifed references as like targets
*/
/* format: style3,ifthenstmt */
context_processor:
     procedure (P_root, P_abort);

dcl	P_root		ptr;			/* (Input) */
dcl	P_abort		label variable;		/* (Output) */

/* automatic */

dcl	b		ptr;
dcl	root		ptr;
dcl	s		ptr;

/* builtin */

dcl	null		builtin;

/* external static */

dcl	pl1_stat_$check_ansi
			bit (1) aligned external static;
dcl	pl1_stat_$cur_statement
			ptr 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 semant;
%include block;
%include nodes;
%include reference;
%include context;
%include declare_type;
%include symbol;
%include token;

/* program */

	root = P_root;

/* Make a prefix walk over the block nodes to process the contextual
   declarations. */

	do b = root repeat next_prefix_walk_block_node (b) while (b ^= null);
	     call process_block_context (b);
	end;

/* Make a prefix walk over the block nodes to resolve all like references. */

	P_abort = process_next_block;

	do b = root repeat next_prefix_walk_block_node (b) while (b ^= null);
	     if b -> block.like_attribute
	     then do s = b -> block.declaration repeat s -> symbol.next while (s ^= null);
		     pl1_stat_$cur_statement = s;
		     pl1_stat_$statement_id = s -> symbol.source_id;

		     if s -> node.type = symbol_node
		     then if s -> symbol.like then call resolve_like_reference (b, s);
		end;
process_next_block:
	end;

/* Make a prefix walk over the block nodes to expand all like attributes. */

	do b = root repeat next_prefix_walk_block_node (b) while (b ^= null);
	     if b -> block.like_attribute
	     then do s = b -> block.declaration repeat s -> symbol.next while (s ^= null);
		     pl1_stat_$cur_statement = s;
		     pl1_stat_$statement_id = s -> symbol.source_id;

		     if s -> node.type = symbol_node
		     then if s -> symbol.like then call expand_like_attribute (s);
		end;
	end;

	return;

/* Find the next block node in a prefix walk of all the block nodes. */

next_prefix_walk_block_node:
     procedure (P_b) returns (ptr);

dcl	P_b		ptr;			/* (Input) */

/* automatic */

dcl	b		ptr;

/* program */

	if P_b -> block.son ^= null then return (P_b -> block.son);

	do b = P_b repeat b -> block.father while (b ^= null);
	     if b -> block.brother ^= null then return (b -> block.brother);
	end;

	return (b);
     end next_prefix_walk_block_node;

/* Process the contextual declarations in a block. */

process_block_context:
     procedure (P_b);

dcl	P_b		ptr;			/* (Input) */

/* automatic */

dcl	b		ptr;
dcl	c		ptr;
dcl	cb		ptr;
dcl	d		ptr;
dcl	found_block	ptr;
dcl	found_context	bit (1) aligned;
dcl	found_declaration	ptr;
dcl	s		ptr;

/* Scan the context chain for this block.  For each context, search the block
   symbol chains from this block out. */

	b = P_b;
	do c = b -> block.context repeat c -> context.next while (c ^= null);
	     found_block, found_declaration = null;
	     found_context = "0"b;

	     if c -> context.parameter
	     then do;
		     do d = c -> context.token -> token.declaration repeat d -> symbol.multi_use
			while (d ^= null & ^found_context);

			if d -> symbol.block_node = b /* possible previous declaration */
			then if context_matches (c, d)
			     then do;
				     found_context = "1"b;
				     found_block = b;
				     found_declaration = d;
				end;
		     end;

/* Undeclared parameters must not have contextually derived attributes added
   to them, even for strong contexts such as ptr, area, file, since a default
   statement could still supply proper attributes. */

		     if ^found_context
		     then do;
			     d = create_symbol (b, (c -> context.token), by_context);
			     d -> symbol.parameter = "1"b;
			     call print (214, d);
			end;
		end;

	     else do;
		     do cb = b repeat cb -> block.father while (cb ^= null & ^found_context);
			do d = c -> context.token -> token.declaration repeat d -> symbol.multi_use
			     while (d ^= null & ^found_context);

			     if d -> symbol.block_node = cb
						/* possible previous declaration */
			     then if context_matches (c, d)
				then do;
					found_context = "1"b;
					found_block = cb;
					found_declaration = d;
				     end;
			end;
		     end;

		     if ^found_context
		     then do;
			     found_declaration =
				create_symbol ((root -> block.son), (c -> context.token), by_context);
			     found_declaration -> symbol.data_type = c -> context.bits.types;

			     if c -> context.ptr then call print (69, found_declaration);
			     if c -> context.area then call print (74, found_declaration);
			     if c -> context.file then call print (75, found_declaration);
			     if c -> context.condition then call print (133, found_declaration);
			end;
		end;

	     if c -> context.condition
	     then if b ^= root -> block.son & b ^= found_block
		then do;				/* make storage for condition in current block */
			s = create_symbol (b, (c -> context.token), by_compiler);
			s -> symbol.condition = "1"b;
			s -> symbol.equivalence = found_declaration;
		     end;
	end;

	return;

/* Match a context with a previous declaration. */

context_matches:
     procedure (c, d) returns (bit (1) aligned);

dcl	c		ptr;			/* (Input) */
dcl	d		ptr;			/* (Input) */

	if c -> context.parameter
	then if d -> symbol.level > 1 then return ("0"b);
	     else if d -> node.type = symbol_node then d -> symbol.parameter = "1"b;

	if c -> context.condition
	then if d -> symbol.condition & d -> symbol.dcl_type = by_compiler then return ("0"b);

	return ("1"b);
     end context_matches;

     end process_block_context;

/* Resolve the like reference in a like attribute. */

resolve_like_reference:
     procedure (P_b, P_s);

dcl	P_b		ptr;			/* (Input) */
dcl	P_s		ptr;			/* (Input) */

/* automatic */

dcl	like		ptr;
dcl	s		ptr;

/* program */

	s = P_s;

/* There may not be a like reference.  The parse already printed a message. */

	if s -> symbol.general = null then return;

/* Make sure a structure qualified reference doesn't have subscripts or
   pointer qualification.  The parse should really have caught this. */

	like = null;

	if s -> symbol.general -> node.type = reference_node
	then do;
		if s -> symbol.general -> reference.offset ^= null
		     | s -> symbol.general -> reference.qualifier ^= null
		then call error_exit (119, s);
		if s -> symbol.general -> reference.symbol -> node.type = symbol_node
		then like = s -> symbol.general -> reference.symbol;
	     end;

	if like = null
	then if ^lookup (P_b, s, (s -> symbol.general), like, ""b) then call error_exit (120, s);

	if like -> node.type ^= symbol_node then call error_exit (120, s);

	s -> symbol.general = like -> symbol.reference;

return_from_resolve_like_reference:
	return;

/* Print an error message and exit resolve_like_reference. */

error_exit:
     procedure (m, s);

dcl	m		fixed bin (15);		/* (Input) */
dcl	s		ptr;			/* (Input) */

	s -> symbol.general = null;
	call print (m, s);
	goto return_from_resolve_like_reference;
     end error_exit;

     end resolve_like_reference;

/* Expand a like attribute. */

expand_like_attribute:
     procedure (P_s);

dcl	P_s		ptr;			/* (Input) */

/* automatic */

dcl	1 check_ansi	aligned,
	  2 like_to_like	bit (1),
	  2 sons_contain_like
			bit (1);
dcl	like		ptr;
dcl	like_count	fixed bin;
dcl	p		ptr;
dcl	q		ptr;
dcl	s		ptr;

/* internal static */

dcl	max_like_loop_count fixed bin internal static options (constant) initial (100);
						/* Error message 389 must be changed when this limit is
						   changed. */

/* program */

	s = P_s;
	check_ansi = ""b;

	if s -> symbol.general = null then return;	/* already expanded the like attribute */

	if s -> symbol.son ^= null then call error_exit (189, s);

/* Find the ultimate like target. */

	like = s -> symbol.general -> reference.symbol;
	check_ansi.like_to_like = like -> symbol.like;
	do like_count = 1 to max_like_loop_count while (like -> symbol.general ^= null);
	     if like = s then call error_exit (388, s);	/* recursive like reference */
	     like = like -> symbol.general -> reference.symbol;
	end;

	if like_count > max_like_loop_count then call error_exit (389, s);

/* If the like reference refers to a father of the symbol with the like
   attribute we are expanding, then the like attribute is recursive. */

	do p = s -> symbol.father repeat p -> symbol.father while (p ^= null);
	     if like = p then call error_exit (388, s);
	end;

/* Expand the like attribtue. */

	call copy_expression$copy_sons (like, s);

	s -> symbol.general = null;

	if s -> symbol.son = null then call error_exit (120, s);

	s -> symbol.structure = "1"b;

/* Code for correctly diagnosing misuse of the refer option would go here. */

	do p = s -> symbol.son repeat p -> symbol.next while (p ^= null);
	     p -> symbol.dcl_type = s -> symbol.dcl_type;
	     p -> symbol.block_node = s -> symbol.block_node;
	     p -> symbol.source_id = s -> symbol.source_id;

/* The following code for the case in which symbol.param_desc is on is
   probably never executed.  Nothing in the parse sets that bit.  It seems
   like an attempt to make the like attribute in descriptors work by changing
   the name of the symbol node to something that will never be looked up.  See
   PL/I suggestion 1812. */

	     if s -> symbol.param_desc
	     then p -> symbol.token = s -> symbol.token;
	     else do;
		     p -> symbol.multi_use = p -> symbol.token -> token.declaration;
		     p -> symbol.token -> token.declaration = p;
		end;

/* Like attributes in sons are expanded because fathers precede sons in the
   symbol.next chain. */

	     if p -> symbol.like then check_ansi.sons_contain_like = "1"b;

	     q = p;
	end;

	q -> symbol.next = s -> symbol.next;
	s -> symbol.next = s -> symbol.son;

	if pl1_stat_$check_ansi
	then do;
		if check_ansi.like_to_like then call print (386, s);
		if check_ansi.sons_contain_like then call print (387, s);
	     end;

return_from_expand_like_attribute:
	return;

/* Print an error message and exit expand_like_attribute. */

error_exit:
     procedure (m, s);

dcl	m		fixed bin (15);		/* (Input) */
dcl	s		ptr;			/* (Input) */

	call print (m, s);
	goto return_from_expand_like_attribute;
     end error_exit;

     end expand_like_attribute;

/* Print an error message. */

print:
     procedure (m, s);

dcl	m		fixed bin (15);		/* (Input) */
dcl	s		ptr;			/* (Input) */

	call error_$no_text (m, s -> symbol.source_id, s);
     end print;

     end context_processor;




		    declare.pl1                     07/31/89  1431.7r w 07/31/89  1338.4      123723



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


declare: proc(ps);

dcl	(ps,s,b,d,p,q,p1,rv) ptr;
dcl	(i,n) fixed bin(15);
dcl	cdesc bit(1);

dcl	pl1_stat_$eis_mode bit(1) aligned ext static;

dcl	condition_abreviations(9) char(8) int static
		initial("conv","fofl","ofl","strg","strz","subrg","undf","ofl","zdiv");
dcl	condition_constants(9) char(16) int static varying
		initial("conversion","fixedoverflow","overflow","stringrange","stringsize",
		"subscriptrange","undefinedfile","underflow","zerodivide");
dcl	(string,fixed,null,substr) builtin;

	s = ps;
	if s=null then return;
	if s->node.type ^= symbol_node
	then do;
		if s -> label.array
		then	call declare_label_array;
		return;
	end;

	if s->symbol.boundary ^= 0 then return;
	if s->symbol.father ^= null then return;

	if s->symbol.son ^= null
	then do;
		if s->symbol.level ^= 1
		then do;
			call semantic_translator$error(149,s);
			s->symbol.level = 1;
		end;

		call declare_structure(s);

		go to exit;
	end;

	if s-> symbol.structure
	then do;
		call semantic_translator$error(98,s);
		s->symbol.structure = "0"b;
		s->symbol.level = 0;
	end;


/* call validate to supply defaults and check for correctness of the declared attributes.	*/

	call validate(s);

/* Set the aliasable bit */

	if s -> symbol.based | s -> symbol.parameter | s -> symbol.defined | s -> symbol.external
	then s -> symbol.aliasable = "1"b;

/* set the padded bit for this level one scalar.	*/

	if s->symbol.packed
	then	s->symbol.reference->reference.padded_ref =
			^(s->symbol.based|s->symbol.parameter|s->symbol.defined);

	b=s->symbol.block_node;

/* if parameter, returns descriptor, or controlled variable, replace the asterisks with references to descriptors.	*/

	cdesc = s->symbol.parameter | s->symbol.return_value | s->symbol.controlled;

	if cdesc
	then	if s->symbol.star_extents | s->symbol.exp_extents
		then	s->symbol.descriptor = declare_descriptor$param((s->symbol.block_node),null,s,null,"1"b);

/* determine the storage size and boundary requirement.	*/

	call get_size(s);

/* Make sure the value will fit in a segment */

	if s -> symbol.c_word_size > max_words_per_variable
	then call semantic_translator$error (357,s);

/* If the variable requires a descriptor and has constant extents, declare_
   descriptor must be called after the extents have been calculated in order
   to actually declare the constant descriptor */

	if cdesc
	then	if s->symbol.descriptor = null
		then	s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);

/* A character string constant is genenerated for condition constants */

	if s->symbol.condition
	then do;
		if s->symbol.dcl_type ^= by_compiler then s->symbol.equivalence = s;
		do i = 1 to 9;
			if s->symbol.token->token.string = condition_abreviations(i)
			then do;
				s->symbol.general = declare_constant$char((condition_constants(i)));
				go to loop_exit;
			end;
		end;

		s->symbol.general = declare_constant$char((s->symbol.token->token.string));
	end;
loop_exit:

/* If this is an entry process its returns descriptor and parameter descriptors.

   Entry constants denoting entry points in this program have an initial pointer
   which points to an entry or procedure statement and an equivalence pointer which
   points to the block node containing the entry or procedure statement.  Entry variables
   and external entry constants in other programs do not have these pointers but do have a descriptor
   list attached to their general pointer.	

   If a return_value is an aggregate or has star_extents, we delay declaring it
   by copying it so that function can get a unique copy each time the function
   is invoked, because of addressing and descriptor problems.  This fixes
   bugs 1217 and 1311.			*/

	if s->symbol.entry
	then do;
		if s->symbol.returns
		& (s->symbol.constant & s->symbol.initial=null
		 | s->symbol.variable)
		then do;
			rv = s->symbol.dcl_size;
			rv->symbol.return_value = "1"b;
			if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
			then do;
				s->symbol.dcl_size = copy_expression(s->symbol.dcl_size);
				call declare(rv);
				s->symbol.dcl_size->symbol.star_extents = rv->symbol.star_extents;
			end;
			else	call declare(rv);
		end;

		do p=s->symbol.general repeat p->element(2) while(p^=null);
			p->element(1)->symbol.param_desc = "1"b;
			call declare((p->element(1)));
		end;

		if s->symbol.variable then go to allocate;
		p=s->symbol.initial;
		if p = null then go to allocate;

/* this is an entry constant declared by a label prefix */

		/* make sure it was not multiply declared */

		d = s->symbol.token->token.declaration;
		p1 = null;
		do while(d^=null);
			if	d->symbol.block_node = b & d^=s
			then if	d->node.type = symbol_node
			then if	d->symbol.entry & d->symbol.constant
			then do;
				call semantic_translator$abort(213,s);
				if p1 = null
				then	s->symbol.token->token.declaration = d->symbol.multi_use;
				else	p1->symbol.multi_use = d->symbol.multi_use;
			end;

			p1 = d;
			d = d->symbol.multi_use;
		end;

		p=p->statement.root;
		n=p->operator.number;
		if s->symbol.returns then n = n-1;
		p1=null;

		do i=1 to n;
			q=create_list(2);
			if ^lookup((s->symbol.equivalence),null,(p->operator.operand(i)),d,"0"b)
				then call semantic_translator$abort(194,(p->operand(i)));
			if d->node.type ^= symbol_node then call semantic_translator$abort(196,d);
			d->symbol.parameter = "1"b;
			if d->symbol.location = 0 then d->symbol.location = i;
				else if d->symbol.location ^= i
					then d->symbol.allocated ="1"b;
			q->element(1)=d;
			if s->symbol.general = null then s->symbol.general = q;
			if p1 ^= null then p1->element(2)=q;
			p1=q;
		end;

/* Use the parameters of the entry as templates to create parameter descriptors.  The
   parameter descriptors are processed as if they were in the same block as the
   parameter from which they were derived so that they will recieve the same defaults.  */

		do q = s->symbol.general repeat q->element(2) while(q^=null);
			q->element(1),d = copy_expression(q->element(1));
			d->symbol.param_desc = "1"b;
			d->symbol.parameter = "1"b;
			call declare(d);
		end;

/* Search the list of return values attached to the block node of the procedure and
   find a return value whose attributes match the attributes of the value returned
   by this entry.  If such a value is found, replace this return value with the  value
   already recorded in the block node.  If no such value can be found, record this return
   value in the block node.  When more than one return value is recorded in the block
   node an automatic integer variable is declared and a pointer to it is also recorded
   in the block node.  During semantic translation of an entry statement this automatic
   variable is assigned a number which identifies which return type is to be used
   on return from the procedure.  During semantic translation of the return statement
   code is generated to test the value of that automatic variable and assign the return
   value to the proper return parameter.	*/

/* If there is no return value, a null list element will be on the list
   of return values to represent that entry statement's "null" return value.	 */

		n = n+1;

		p = s->symbol.equivalence;

		do q = p->block.return_values repeat q->element(1) while(q^=null);
			if s->symbol.dcl_size = null
			then if q->element(2) = null
			     then goto allocate;	/* simply use this null list node */
			     else;

			else if compare_declaration((q->element(2)),(s->symbol.dcl_size),"0"b)
			     then do;
				p1 = q->element(2);
				if p1->symbol.location ^= n
				then	p1->symbol.allocated ="1"b;
				s->symbol.initial->statement.root->operator.operand(n) = p1->symbol.token;
				go to make_descr;
			     end;
		end;

		if p->block.return_values ^= null & p->block.return_count = null
		then	p->block.return_count = declare_integer(p);

		q = create_list(2);
		q->element(1) = p->block.return_values;
		p->block.return_values = q;
		q->element(2) = s->symbol.dcl_size;

		if s->symbol.dcl_size = null
		then goto allocate;

		s->symbol.dcl_size->symbol.location = n;

/* copy the return parameter's declaration to create a return descriptor that will be
   used as the return temporary when this entry is invoked.  */

make_descr:
		rv, s->symbol.dcl_size = copy_expression(s->symbol.dcl_size);
		rv->symbol.return_value = "1"b;
		rv->symbol.parameter = "0"b;
		if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
		then	if rv->symbol.structure & ^ rv->symbol.star_extents
			then	call set_star(rv);
			else;
		else	call declare(rv);

		if rv->symbol.star_extents
		then do;
			p -> block.why_nonquick.returns_star_extents = "1"b;
			p -> block.no_stack = "0"b;
		     end;
	end;

/* create prologue to allocate automatic variables with variable sizes.	*/

allocate:
	if s->symbol.auto
	then do;
		if s->symbol.word_size ^= null
		then do;
			p1 = s->symbol.word_size;

			if p1->node.type = operator_node
			then do;
				q=create_operator(assign,2);
				q->operator.operand(2)=s->symbol.word_size;
				q->operator.operand(1),s->symbol.word_size,p1 = declare_integer(b);
				p1->reference.symbol->symbol.c_dcl_size = max_offset_precision;
				p=create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
				p->statement.root=q;
			end;

			q=create_operator(allot_auto,2);
			q->operator.operand(2)=p1;
			q->operator.operand(1),
			s->symbol.reference->reference.qualifier=declare_pointer(b);
			p=create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
			p->statement.root=q;
		end;

		if(s->symbol.area|s->symbol.initialed)
		then	call expand_initial(s,null,null);
		go to exit;
	end;

/* parameters which appear in more than one position are accessed via an
   automatic pointer set by the entry.  All other parameters are accessed via a
   pointer valued operator whose 2nd operand is the parameter's position.	*/

	if s->symbol.parameter
	then do;
		if s->symbol.allocated
		then	q=declare_pointer(b);
		else do;
			q=create_operator(param_ptr,3);
			q->operator.operand(2) = declare_constant$integer(fixed(s->symbol.location));
			q->operator.operand(3) = b;
		end;

		s->symbol.reference->reference.qualifier=q;

		if s->symbol.packed
		then	if pl1_stat_$eis_mode
			then	s->symbol.reference->reference.fo_in_qual = "1"b;
			else do;
				p = create_operator(bit_pointer,2);
				p->operator.operand(2) = q;
				s->symbol.reference->reference.offset = p;
				s->symbol.reference->reference.units = bit_;
			end;

		return;
	end;


/* File constants are initialized by the prologue the
   first time it is executed in the process.	*/

	if s->symbol.file
	then	if s->symbol.constant
	then	call expand_initial(s,null,null);

/* packed based scalar variables are accessed via bit valued pointers and
   the bit offset contained in the pointer must be included as a term in the offset.  */

	if	s->symbol.based
	then if	s->symbol.packed
	then	if pl1_stat_$eis_mode
		then	s->symbol.reference->reference.fo_in_qual = "1"b;
		else do;
			q = create_operator(bit_pointer,2);
			s->symbol.reference->reference.offset = q;
			s->symbol.reference->reference.units = bit_;
		end;

exit:
	if s->symbol.auto & s->symbol.exp_extents
	then do;
		s -> symbol.block_node -> block.why_nonquick.auto_adjustable_storage = "1"b;
		s -> symbol.block_node -> block.no_stack = "0"b;
	     end;

/* if this is a return descriptor and no star extents where found then the storage class
   should be changed to temporary instead of return_value.  It is not possible to
   do this sooner as it will foul-up several programs that must be able to recognize
   return descriptors.  */

	if s->symbol.return_value & ^s->symbol.star_extents
	then	if s->symbol.structure
		then	call reset_ret_val(s);
		else do;
			s->symbol.return_value = "0"b;
			s->symbol.temporary = "1"b;
		end;


reset_ret_val:   proc(s);

dcl	(s,d) pointer;

	s->symbol.temporary="1"b;
	s->symbol.return_value="0"b;
	do d = s->symbol.son repeat d->symbol.brother while (d ^= null);
		call reset_ret_val(d);
	end;

	end reset_ret_val;


set_star:	proc(ps);

	/* propagates up star_extents in structure */

dcl	(ps,d,s) ptr;

	s = ps;
	do d = s->symbol.son repeat d->symbol.brother while(d ^= null);
	     call set_star(d);
	     s->symbol.star_extents = s->symbol.star_extents | d->symbol.star_extents;
	     end;

	end set_star;


declare_label_array:	proc;

	/* prepares a vector of statement pointers for a label array */

dcl	(lae,next,vector) ptr;
dcl	inc fixed bin;

	inc = 1 - s -> label.low_bound;
	vector = create_list(s -> label.high_bound - s -> label.low_bound + 1);

	do lae = s -> label.statement repeat next while(lae ^= null);
	     vector -> element(lae -> label_array_element.value + inc) = lae -> label_array_element.statement;
	     next= lae -> label_array_element.next;
	     call free_node(lae);
	     end;

	s -> label.statement = vector;

	end;


%include semant;
%include symbol;
%include block;
%include reference;
%include list;
%include operator;
%include statement;
%include op_codes;
%include statement_types;
%include nodes;
%include token;
%include token_types;
%include declare_type;
%include boundary;
%include label;
%include label_array_element;
%include system;
	end declare;




		    declare_structure.pl1           07/31/89  1431.7r w 07/31/89  1338.4      133335



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


declare_structure: proc(ps);

/* Modified 780724 by PG to call validate before copying storage_class of adam. */
/* Modified 790419 by PCK to implement 4-bit decimal */

dcl	(adam,base,bit_offset,allocate,ps,s,d,b,off,q) ptr;
dcl	n fixed bin(15);
dcl	coff fixed bin(31);
dcl	cdesc bit(1);

dcl	pl1_stat_$eis_mode bit(1) aligned ext static;

dcl	(min,max,null,fixed,divide,string,substr) builtin;

%include semant;
%include symbol;
%include array;
%include block;
%include reference;
%include operator;
%include statement;
%include op_codes;
%include nodes;
%include statement_types;
%include boundary;
%include list;
%include system;

	s = ps;
	b = s->symbol.block_node;
	adam = s;

/* Scan the structure to:
	1. propagate the refer and exp_extent bits upward.
	2. determine the boundary required by each member.
	3. determine the boundary required by the structure.
	4. determine the packing of the structure.
	5. Validate the structure and each of its members.
	6. Apply the father's alignment attributes to the sons.
	7. Copy the level 1 defined structure's base ref to the members.
	8. Copy the level 1 storage class to the members.
								*/
	cdesc = s->symbol.parameter | s->symbol.return_value | s->symbol.controlled;

	if cdesc
	then	s->symbol.descriptor = declare_descriptor$param((s->symbol.block_node),null,s,null,"1"b);

	call structure_scan(s);

/* set base to the locator value used to reference the level 1 structure.
   and set bit_offset the the proper bit_pointer value to use for packed members.	*/

	allocate,bit_offset,base = null;

	if	s->symbol.auto
	then if	s->symbol.exp_extents
	then do;
		base = declare_pointer(b);
		allocate = create_operator(allot_auto,2);
		allocate->operand(1) = base;
	end;

	if s->symbol.based
	then do;
		base = s->symbol.reference->reference.qualifier;
		if s->symbol.unaligned & s->symbol.packed
		then	if pl1_stat_$eis_mode
			then	s->symbol.reference->reference.fo_in_qual = "1"b;
			else	bit_offset = create_operator(bit_pointer,2);
	end;

	if s->symbol.parameter
	then do;
		if ^s->symbol.allocated
		then do;
			base = create_operator(param_ptr,3);
			base->operand(2) = declare_constant$integer(fixed(s->symbol.location));
			base->operand(3) = b;
		end;
		else	base = declare_pointer(b);

		if s->symbol.unaligned & s->symbol.packed
		then	if pl1_stat_$eis_mode
			then	s->symbol.reference->reference.fo_in_qual = "1"b;
			else do;
				bit_offset = create_operator(bit_pointer,2);
				bit_offset->operand(2) = base;
			end;
	end;

/* Set the qualifier field of the structure's reference node.  */

	s->symbol.reference->reference.qualifier = base;

/* set the padded bit for references to the level one structure.	*/

	if s->symbol.packed
	then do;
		s->symbol.reference->reference.padded_ref =
			^(s->symbol.based|s->symbol.parameter|s->symbol.defined);

		if s->symbol.reference->reference.padded_ref
		then	s->symbol.boundary = max(s->symbol.boundary,word_);
	end;

/* If this is a packed unaligned structure set the offset to include the bit_pointer.  */

	if bit_offset ^= null
	then do;
		s->symbol.reference->reference.offset = bit_offset;
		s->symbol.reference->reference.units = bit_;
	end;

/* Set the aliasable bit */

	if s -> symbol.based | s -> symbol.parameter | s -> symbol.defined | s -> symbol.external
	then s -> symbol.aliasable = "1"b;

/* scan the structure again and:

	1. compute each member's size and offset.
	2. determine the level 1 structure's size.
	3. make each member based on the level 1 structure's base pointer.
	4. initialize each member.
	5. set each members padded bit.
	6. process each entry variable's descriptor list and return descriptor.
	7. give each member the storage class bits of the level one structure.
								*/

	call get_structure_size(s);

	s->symbol.reference->reference.c_length = 0;

/* Make sure the value will fit in a segment */

	if s -> symbol.c_word_size > max_words_per_variable
	then call semantic_translator$error (357,s);

/* If this has constant extents and requires a descriptor, declare_descriptor
   must be called after all the extents are calculated in order to actually
   declare the constant descriptor.  If the descriptor template used for
   entry definitions has not been built, declare_descriptor must also be
   called. */

	if cdesc
	then	if s->symbol.descriptor = null
		then s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);
		else if s->symbol.parameter
		     then if s->symbol.descriptor->reference.symbol->symbol.descriptor = null
			then s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);


/* If this was automatic with variable extents, fill in the size field of the allot_auto operator */

	if allocate^=null
	then do;
		allocate->operand(2) = copy_expression(s->symbol.word_size);

		q = create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
		q->statement.root = allocate;
	end;

	call initialize(s);

	return;

/* subroutine to:
	1. propagate the refer, exp_extent, star_extent bits upward.
	2. determine the boundary required by each structure member.
	3. determine the boundary required by each structure.
	4. determine the packing of the structure.
	5. Validate the structure and each of its members.
	6. Apply the father's alignment attributes to the sons.
	7. Compute the logical level numbers of the sons.
							*/
structure_scan: proc(ps);

dcl	(ps,d,s) ptr;

	s = ps;

	if s->symbol.member
	then do;
		s->symbol.level = s->symbol.father->symbol.level+1;	/* set logical level */

		if ^(s -> symbol.aligned | s -> symbol.unaligned)
		then do;
			s -> symbol.aligned = s -> symbol.father -> symbol.aligned;
			s -> symbol.unaligned = s -> symbol.father -> symbol.unaligned;
		     end;
	     end;

	if s -> symbol.son = null
	then do;
		call validate (s);
		if s -> symbol.member
		then do;
			string(s->symbol.storage_class) = string(adam->symbol.storage_class);
			s->symbol.equivalence = adam->symbol.equivalence;
		end;
		call get_size(s);
		return;
	     end;

	s->symbol.structure,s->symbol.packed = "1"b;

	do d = s->symbol.son repeat d->symbol.brother while(d^=null);
		call structure_scan(d);
		s->symbol.packed = s->symbol.packed & d->symbol.packed;
		s->symbol.boundary = max(s->symbol.boundary,d->symbol.boundary);
		s->symbol.refer_extents = s->symbol.refer_extents | d->symbol.refer_extents;
		s->symbol.exp_extents = s->symbol.exp_extents |d->symbol.exp_extents;
		s->symbol.star_extents = s->symbol.star_extents | d->symbol.star_extents;
	end;

	call validate(s);

	if s -> symbol.member
	then do;
		string(s->symbol.storage_class) = string(adam->symbol.storage_class);
		s->symbol.equivalence = adam->symbol.equivalence;
	     end;

	if s -> symbol.aligned
	then do;
		s -> symbol.boundary = max(s -> symbol.boundary,word_);
		s -> symbol.packed = "0"b;
	     end;

	if s->symbol.dimensioned
	then	s->symbol.array->array.element_boundary = s->symbol.boundary;

	end structure_scan;

/* subroutine to:
	1.  compute each member's offset.
	2. determine the level 1 structure's size.
	3. make each member based on the level 1 structure's base pointer.
	4. make each member's offset include the proper bit pointer.
	5. initialize each member.
	6. set each members's padded bit.
	7. process each entry vairable's descriptor list and return descriptor.
									*/
get_structure_size: proc(ps);

dcl	(ps,s,d,f,r,q,p,fsize,rv,t) ptr;
dcl	(i,j,k) fixed bin(3);
dcl	 fc_size fixed bin(31);

dcl	opcodes(4) bit(9) aligned initial(bit_to_char,bit_to_word,char_to_word,half_to_word);

dcl	opcode_index(4,7) fixed bin(15) internal static init(0,0,1,0,2,2,2,
						   0,0,0,0,0,0,0,
						   0,0,0,0,3,3,3,
						   0,0,0,0,4,4,4);

dcl	round_const(4,7) fixed bin(15) int static initial(0,0,9,0,36,36,36,
						0,0,0,0, 0, 0, 0,
						0,0,0,0, 4, 4, 4,
						0,0,0,0, 2, 2, 2);

dcl	mod_const(6:7) fixed bin(15) int static initial(2,4);

dcl	mod_ops(6:7) bit(9) aligned  initial(word_to_mod2,word_to_mod4);

dcl	offset_ops(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);

	s = ps;
	j = s->symbol.boundary;
	f = s->symbol.reference;
	fc_size = 0;
	fsize = null;

	do d = s->symbol.son repeat d->symbol.brother while(d^=null);
		string(d->symbol.storage_class) = string(s->symbol.storage_class);
		d->symbol.aliasable = adam->symbol.aliasable;
		d->symbol.equivalence = adam->symbol.equivalence;
		r = d->symbol.reference;
		r->reference.qualifier = base;
		if pl1_stat_$eis_mode
		     then r -> reference.fo_in_qual = adam -> symbol.reference -> reference.fo_in_qual;
		i = d->symbol.boundary;

/* If this members boundary requirement is less stringent than the boundary
   forced upon it by the preceeding member, no rounding is needed and the
   actual boundary of the member will be up graded to that determined by the
   preceeding member.	*/

		if i<=j
		then do;
			d->symbol.boundary = j;
			go to get_offset;
		end;

/* If the current boundary is less than word then round it to that needed by this member.	*/

		if j < word_
		then do;
			if fsize = null
			then fc_size = divide(fc_size+round_const(j,i)-1,round_const(j,i),31,0);
			else do;
				q = create_operator(opcodes(opcode_index(j,i)),2);
				q->operand(2) = fsize;
				fsize = q;
			end;
		end;

/* If this member needs a mod boundary perform a mod operation on the current boundary.	*/

		if i > word_
		then do;
			if fsize = null
			then fc_size = divide(fc_size+mod_const(i)-1,mod_const(i),31,0)*mod_const(i);
			else do;
				q = create_operator(mod_ops(i),2);
				q->operand(2) = fsize;
				fsize = q;
			end;
		end;

/* set the units of the current boundary equal to the boundary requirement of this member.	*/

		j = i;


/* get this members offset by adding the fathers offset to the fathers current size.*/

get_offset:
		t = f->reference.offset;

		if	t ^= null
		then if	t -> node.type = operator_node
		then if	substr(t -> op_code,1,5) = substr(mod_bit,1,5)
		then	t = t -> operand(3);

		r->reference.offset = t;
		r->reference.c_offset = f->reference.c_offset;
		k,r->reference.units = f->reference.units;

		off = r->reference.offset;
		coff = r->reference.c_offset;

		call offset_adder(off,coff,k,"0"b,(fsize),(fc_size),j,"0"b,r->reference.fo_in_qual);

		r->reference.offset = off;
		r->reference.c_offset = coff;

		if r->reference.c_offset = 0 & r->reference.offset = null
		then	r->reference.units = 0;
		else	r->reference.units = min(k,word_);

/* If the offset is variable and the units are less than word and the offset is an expression
   containing anything otherthan a simple bit_pointer, then create the proper mod operator
   at the top of the expression.	*/

		if	^pl1_stat_$eis_mode
		then if	r->reference.offset ^= null
		then if	r->reference.units < word_
		then do;
			q = r->reference.offset;

			if q->node.type = operator_node
			then	if q->operator.op_code ^=bit_pointer
				then do;
					p = create_operator(offset_ops(r->reference.units),3);
					p->operand(3)=q;
					r->reference.offset = p;
				end;
				else;
			else do;
				p = create_operator(offset_ops(r->reference.units),3);
				p->operand(3) = q;
				r->reference.offset = p;
			end;
		end;

		if	pl1_stat_$eis_mode
		then if	r->reference.units=character_
		then if	d->symbol.bit | d->symbol.binary | d->symbol.ptr
		then do;
			r->reference.units = bit_;
			r->reference.c_offset = r->reference.c_offset * bits_per_character;

			if r->reference.offset^=null
			then do;
				p = create_operator(mult,3);
				p->operand(2) = declare_constant$integer(bits_per_character);
				p->operand(3) = r->reference.offset;
				r -> reference.offset = p;
			end;
		end;

/* set padded bit for this member.	*/

		if d->symbol.packed
		then do;
/* walk father chain looking for next structure element */
			do q = d repeat q->symbol.father while(q^=null);
				if q->symbol.brother ^= null then go to succ;
			end;
succ:
			if q = null
			then	r->reference.padded_ref = ^(d->symbol.based|d->symbol.parameter|d->symbol.defined);
			else	r->reference.padded_ref = q->symbol.brother->symbol.aligned;
		end;

/* If this is an entry variable then process its decriptors.	*/

		if d->symbol.entry
		then do;
			if d->symbol.returns
			then do;
				rv = d->symbol.dcl_size;
				rv->symbol.return_value = "1"b;
				if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
				then do;
					d->symbol.dcl_size = copy_expression(d->symbol.dcl_size);
					call declare(rv);
					d->symbol.dcl_size->symbol.star_extents = rv->symbol.star_extents;
				end;
				else	call declare(rv);
			end;
			do q = d->symbol.general repeat q->element(2) while(q^=null);
				q->element(1)->symbol.param_desc ="1"b;
				call declare((q->element(1)));
			end;
		end;

/* Determine the size of the member.  If it is not a sub-structure it was computed by
   get_size when the boundary was determined, otherwise it is computed now by calling
   get_structure_size.  In both cases the c_length field of the reference node serves
   to hold the units in which the size has been computed.  */

		if d->symbol.structure then call get_structure_size(d);

/* Add this members size to the father's current size.	*/

		call offset_adder(fsize,fc_size,j,"0"b,(d->symbol.word_size),(d->symbol.c_word_size),
			(r->reference.c_length),"0"b,"0"b);
		r->reference.c_length = 0;

		if (d->symbol.char|d->symbol.bit) & ^d->symbol.varying
		then do;
			r->reference.c_length = d->symbol.c_dcl_size;
			r->reference.length = d->symbol.dcl_size;
		end;

		if d->symbol.picture
		then	r->reference.c_length = d->symbol.c_dcl_size;
	end;

/* record the size of this structure in the symbol node, and the units in which the size
   is measured in the reference node.	*/

	s->symbol.reference->reference.c_length = j;
	s->symbol.word_size = fsize;
	s->symbol.c_word_size = fc_size;

/* call get_size to find the size in bits, to find the array size, to improve the units
   in which the size is measured, to round the size to an integeral number of words,etc.	*/

	call get_size(s);

	end get_structure_size;

initialize:	proc(p);

dcl	(p,q,r) ptr;

	r = p;

	do q = r repeat q->symbol.son while(q^=null);

		if  q->symbol.auto
		&  (q->symbol.initialed
		   |q->symbol.area)
		then	call expand_initial(q,null,null);

		call initialize((q->symbol.brother));

	end;

	end initialize;

     end /* declare_structure */;




		    defined_reference.pl1           07/31/89  1431.7r w 07/31/89  1338.5      116658



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


defined_reference: proc(blk,stmnt,input_tree,subs,s,context) returns(ptr);

/* Modified 780713 by PG for unsigned */
/* Modified 790419 by PCK to implement 4-bit decimal */

dcl	(blk,stmnt,tree,subs,new_subs,p,s,br,bs,a,input_tree,off,father_s) ptr;
dcl	(t,k,n,i,nsubs,ndims,nsubs_minus_ndims) fixed bin(15);
dcl	(father_dims,listdims(128)) fixed bin(15);
dcl	(co,coff) fixed bin(31);
dcl	cunits fixed bin(3);

dcl	op_table(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);
dcl	dims_processed bit(1) aligned;

dcl	pl1_stat_$eis_mode bit(1) aligned ext static,
	pl1_stat_$check_ansi bit(1) aligned ext static,

	pl1_stat_$root external static ptr;

dcl	(addr,null,fixed,string,substr) builtin;

	this_context = "0"b;
	t,k,n = 0;
		/* t is used by string_overlay: it says bit/char
		   k is the number of asterisks observed by isubs_or_stars
		   n is the number of the last isub or asterisk
		        observed by isubs_or_stars
		*/

	tree = copy_expression((input_tree));
	br = copy_expression(s->symbol.equivalence);

	father_s=s;
	do while(father_s->symbol.member);
	father_s=father_s->symbol.father;
	end;

	if father_s->symbol.dimensioned then father_dims=father_s->symbol.array->array.number_of_dimensions;
	else father_dims=0;




	if ^lookup((s->symbol.block_node),stmnt,br,bs,this_context)
	then	if br->node.type = token_node
		then do;
			call semantic_translator$error(77,br);
			bs = create_symbol((pl1_stat_$root->block.son),br,by_implication);
			call declare(bs);
			bs->symbol.allocate = "1"b;
		end;
		else	call print(175);
	else	if br->node.type=reference_node	/* lookup replaces the symbol field */
		then do;
			br->reference.symbol = bs->symbol.token;
			br->reference.length = copy_expression(s->symbol.equivalence->reference.length);
			br->reference.offset = copy_expression(s->symbol.equivalence->reference.offset);
			br->reference.qualifier = copy_expression(s->symbol.equivalence->reference.qualifier);
		end;

	if bs->node.type ^= symbol_node then call print(176);
	if pl1_stat_$check_ansi
	then	if bs->symbol.based
		then	call semantic_translator$error(173,s);
	if bs->symbol.defined | bs->symbol.constant then call print(176);

	/* the following line is present so that defined variables can
	    be processed by the code generator program which generates the
	     run-time symbol table */

	s -> symbol.reference -> reference.qualifier = bs -> symbol.reference;
	call propagate_bit(bs,aliasable_bit);
	if def_context.left_side then call propagate_bit(bs,set_bit);

	a = s->symbol.array;
	if a ^= null
	then ndims = a->array.number_of_dimensions;
	else ndims = 0;

	dims_processed = "0"b;
	if subs ^= null
	then 	do;
		nsubs = subs->list.number;
		if s->symbol.dimensioned
		then 	do;
			tree->reference.array_ref = "0"b;
			if nsubs < ndims then call print(81);
			if nsubs > ndims & ^s->symbol.entry then call print(82);
			if ^isubs_or_stars()
			then 	do;
				tree = subscripter(blk,stmnt,tree,subs,s);
				dims_processed = "1"b;
				end;
			end;
		else if isubs_or_stars() then call print(183);
		end;
	else	do;
		nsubs = 0;
		if isubs_or_stars() & ^s->symbol.dimensioned then call print(183);
		end;


/* add the offsets of the defined reference to those of the base */

	if father_s->symbol.position
	then do;

		if n>0 then call print(177);	/* isubs_or_stars AND position */
		if ^(string_overlay(father_s)&string_overlay(bs)) then call print(178);
		father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
		p = father_s -> symbol.initial;		/* the position value */
		if p -> node.type = token_node
		then if p -> token.type & is_arith_constant
		     then do;
			co = token_to_binary(p) - 1;
			p = null;
			goto l1;
			end;

		co = 0;
		p = copy_expression((p));

		this_context = "0"b;
		a = create_operator(sub,3);
		a->operand(2) = p;
		a->operand(3) = declare_constant$integer(1);
		p = a;
		p = expression_semantics((s->symbol.block_node),stmnt,p,this_context);
		if def_this_context.aggregate then call print(185);
		p = convert(p,integer_type);
l1:
		off = tree->reference.offset;
		coff = tree->reference.c_offset;
		cunits = tree->reference.units;

		call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),p,co,(t),"0"b,tree->reference.fo_in_qual);

		tree->reference.offset = off;
		tree->reference.c_offset = coff;
		tree->reference.units = cunits;
		tree->reference.modword_in_offset = "0"b;
	end;

	else	do;
		if match(father_s,bs) then goto build_ref;
		if n>0 then call print(179);	/* isubs_or stars AND non-matching */
		if string_overlay(father_s) & string_overlay(bs)
		     then father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
		     else call print(179);
	end;

/* build the return reference */

build_ref:
	if pl1_stat_$check_ansi
	then	if s->symbol.varying
		then	call semantic_translator$error(174,s);

	this_context = "0"b;
	def_this_context.evaluate_offset = "1"b;
	def_this_context.f_offset_to_be_added = "1"b;
	br = expression_semantics((s->symbol.block_node),stmnt,br,this_context);
	if bs->symbol.reference=br then br=copy_expression((br));
	if br->reference.units ^= 0 
	then do;
		off = tree->reference.offset;
		coff = tree->reference.c_offset;
		cunits = tree->reference.units;

		call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),
			        (br->reference.offset),(br->reference.c_offset),(br->reference.units),(br->reference.modword_in_offset),
			        tree->reference.fo_in_qual);

		tree->reference.offset = off;
		tree->reference.c_offset = coff;
		tree->reference.units = cunits;
		tree->reference.modword_in_offset = "0"b;
	end;

	tree->reference.qualifier = br;
	tree->reference.fo_in_qual = br->reference.fo_in_qual;
	tree->reference.defined_ref = "1"b;
	tree->reference.shared,br->reference.shared = "0"b;
	tree->reference.ref_count,br->reference.ref_count = 1;

	if ^dims_processed
	then	do;
		if nsubs > ndims
		then	do;
			nsubs_minus_ndims=nsubs-ndims;
			new_subs = create_list(nsubs_minus_ndims);
			do i = 1 to nsubs_minus_ndims;
				new_subs->element(i) =subs->element(i);
			end;
			subs=new_subs;
			end;
		else	subs=null;
		end;

	br->reference.offset = null;
	br->reference.units,br->reference.c_offset = 0;
	br->reference.modword_in_offset = "0"b;

	/* since br represents an address, prevent it from being commoned by the optimizer */

	br->reference.inhibit = "1"b;

	if	^pl1_stat_$eis_mode
	then if	tree->reference.offset ^= null
	then if	tree->reference.units < word_
	then do;
		p = tree->reference.offset;
		if p->node.type=operator_node
		then	if p->operator.op_code=mod_bit
			|  p->operator.op_code=mod_byte
			|  p->operator.op_code=mod_half
			then	goto ret;

		p = create_operator(op_table(tree->reference.units),3);
		p->operand(3) = tree->reference.offset;
		tree->reference.offset = p;
	end;

ret:
	return(tree);

/* subroutine to match the defined item's father against its base to determine the
   suitability for isub or simple defining.  */

match: proc(a,b) returns(bit(1) aligned);

dcl	(a,b,p,q) ptr;

	/* expanded 4-18-73 PAB for number of member dimensions */
	/* the extents should perhaps be checked at compile-and-or-run-time */

	dcl (pp,qq) ptr;


	if string(a->symbol.data_type)^=string(b->symbol.data_type)
	then	goto fail;

	if a->symbol.aligned ^= b->symbol.aligned
	then	goto fail;

	if a -> symbol.unsigned ^= b -> symbol.unsigned
	then	go to fail;

	if a->symbol.c_dcl_size ^= b->symbol.c_dcl_size
	then do;
		if a->symbol.array=null
		then	goto fail;

		if a->symbol.array->array.c_element_size^=b->symbol.c_dcl_size
		then	goto fail;
	end;

	if a->symbol.scale ^= b->symbol.scale
	then	goto fail;

	if a->symbol.structure
	then do;
		p = a->symbol.son;
		q = b->symbol.son;

		do while(p^=null);
			if q = null then go to fail;
	
			pp=p->symbol.array;
			qq=q->symbol.array;
			if (pp^=null | qq^=null )
			then do;
				if qq=null
				then	goto fail;

				if pp=null
				then	if ^p->symbol.structure
					then	if qq->array.own_number_of_dimensions^=0
						then	goto fail;
						else	;
					else	;
				else	if pp->array.own_number_of_dimensions
					^= qq->array.own_number_of_dimensions
					then	goto fail;
			end;
	
			if ^match(p,q) then go to fail;
			p = p->symbol.brother;
			q = q->symbol.brother;
		end;

		if q ^= null then go to fail;
	end;

	return("1"b);

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

/*  */
%include string_overlay;

/* subroutine to find or find and replace all Isubs or asterisks with subscripts from the defined reference */

isubs_or_stars: proc returns(bit(1) aligned);

dcl	p ptr;
dcl	i fixed bin(15);

		/* extended 4-18-73 PAB
		   to check that enough asterisks or isubs appear
		   and to check that the two are not mixed
		   and to check that the asterisks appear only at level 1 */


	n = 0;

	do i=1 to father_dims;
	listdims(i)=0;
	end;


	if br->node.type=reference_node
	then do;
		p = br->reference.offset;
		if p^=null
		then do i = 1 to p->list.number;
			call find(p->list.element(i));
		end;
	end;

	if n=0 then return("0"b);
	if father_dims=0 then return("1"b);		/* no isubs or asterisks expected */

	if k>0 then if k^= father_dims then call print(181);	/* asterisks appear - there must be exactly enough of them */
	if k>0 then
		do i=1 to father_dims;		/* asterisks appear - no isubs may appear */
		if listdims(i)^=0 then call print(181);
		end;
	else	do i=1 to father_dims;		/* no asterisks appear - exactly enough isubs must appear */
		if listdims(i)=0 then call print(181);
		end;

	return("1"b);

find: proc(p);

dcl	p ptr unal,
	(e,q) ptr;
dcl	i fixed bin(15);
dcl	recursif fixed bin(15);

	recursif=1;
	goto find_common;

find_r:	entry(p);		/* recursive entrypoint - not allowed to "see" asterisks */
	recursif=2;

find_common:
	e = p;

	if e = null then return;

	if e->node.type = operator_node
	then do;
		do i = 1 to e->operator.number;
			call find_r(e->operand(i));
		end;
		return;
	end;

	if e->node.type = reference_node
	then do;
		call find_r(e->reference.qualifier);
		call find_r(e->reference.offset);
		call find_r(e->reference.length);
		return;
	end;

	if e->node.type=list_node
			/* subscripts and arguments in expressions in the
			   subscripts of the base reference appear as
			   refp->ref.offset->list   */
	then do;
		do i=1 to e->list.number;
		call find_r(e->list.element(i));
		end;
		return;
	end;

	if e->node.type = token_node
	then do;
		if e->token.type = asterisk
			then do;
				if recursif=2 then return;	/* don't recognize
							   an asterisk except at
							   level 1 */
				k = k+1;
				n = k;
			     end;
			else do;
				if e->token.type ^= isub then return;
				n = decbin(substr(e->token.string,1,e->token.size-3));
				listdims(n)=1;
				s->symbol.isub = "1"b;
			     end;

		if n > father_dims then call print(181);
		if substr(stmnt->statement.prefix,7,1)  /* subscriptrange */
		|  subs=null
		then do;
			q = a->array.bounds;
			do i = 1 to n-1;
			q = q->bound.next;
			end;
			if q->bound.lower=null
			then	q->bound.lower = declare_constant$integer((q->bound.c_lower));
			if subs=null
			then	e = q->bound.lower;
			else do;
				if q->bound.upper = null
				then q->bound.upper = declare_constant$integer((q->bound.c_upper));
				e = create_operator(bound_ck,4);
				e->operand(1) = declare_temporary(integer_type,default_fix_bin_p,0,null);
				e->operand(2) = subs->list.element(subs->list.number+1-n);
				e->operand(3) = q->bound.lower;
				e->operand(4) = q->bound.upper;
			end;
		end;
		else	e = subs->list.element(subs->list.number+1-n);

		/* if isub subscripts are not processed now they will be found	*/
		/* hanging off of the base-reference as tokens, and processed within	*/
		/* the block the base reference is declared in, rather than the 	*/
		/* block in which they are found!!! (bug1395) -- RHS 8/75		*/

		/* isub must be converted to integer!! -- RAB 6/77		*/

		e = expression_semantics(blk,stmnt,e,this_context);
		e = convert$to_integer(e,integer_type);
	end;

	p = e;

	end find;

	end isubs_or_stars;

/* subroutine to print an error message and abort this statement.  */

print: proc(m);

dcl	m fixed bin(15);

	call semantic_translator$abort(m,s);
	end print;

%include semant;
%include symbol;

%include symbol_bits;

%include block;

%include reference;
%include semantic_bits;

%include token;

%include statement;

%include array;

%include list;

%include operator;

%include op_codes;

%include token_types;

%include nodes;

%include system;

%include declare_type;

%include boundary;

	end defined_reference;




		    do_semantics.pl1                07/31/89  1431.7r w 07/31/89  1338.5      115605



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


/* No journal comments present previous to 1983 !*/
/* Modified 830106 BIM to note beginning of loop in statement so */
/*		   compile_statement can align it to Y-pair. */
do_semantics:	proc(blk,stmnt,tree);

dcl	(blk,stmnt,tree) ptr,
	(cv,cvref,o,o1,o2,o3,o4,p,q,ref,s,spec,v) ptr,
	(first,last,next,label1,label2) ptr,
	(first_statement,last_statement,next_statement,label1_statement,prof) ptr,
	label_variable ptr,

	e(3) ptr,

	i fixed bin(15),
	sign_of_by fixed bin(15),

	(first_spec,first_time,multiple_spec) bit(1) aligned,
	opcode bit(9) aligned;

dcl	pl1_stat_$profile bit(1) aligned ext static;

/* builtins */

dcl	(null, string, substr) builtin;

%include semant;

%include block;
%include declare_type;
%include label;
%include list;
%include nodes;
%include operator;
%include op_codes;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include system;
%include token;
%include token_types;

			/*      */

	first_time = "1"b;
	last = tree->operand(1);
	spec = tree->operand(3);
	s = stmnt;
	last_statement = last->label.statement;
	if spec = null			/* "do;" statement */
	then do;
		last_statement->statement.reference_count = last_statement->statement.reference_count - 1;
		go to ret;
	     end;

	first_spec = "1"b;
	multiple_spec = spec->operand(6)^=null;

	if multiple_spec
	then do;
/* first: ; */
		first_statement = make_statement(s,null_statement,first);
		first->label.statement->statement.reference_count = 1;

		label_variable = declare_pointer(blk);
		label_variable->reference.symbol->symbol.set = "1"b;

		o = make_operator(jump,1,label_variable,null,null);
/* goto label_variable; */
		label1_statement = make_statement(last_statement,goto_statement,o);
		label1_statement->statement.reference_count = 2;
		label1_statement->statement.processed ="1"b;
	end;

	cv = tree->operand(2);

	if cv^=null
	then do;
		v = cv;

		if cv->node.type ^= reference_node
		then do;
			call semantic_translator$abort(145,cv);
			go to ret;
		end;

		if cv->reference.symbol->node.type ^= symbol_node
		then do;
			call semantic_translator$abort(145,cv);
			go to ret;
		end;

		if cv->reference.symbol->symbol.based
		then do;
			p = declare_pointer(blk);
			q = v->reference.qualifier;
			o = make_operator(assign,2,p,q,null);
/* v->R.qualifier=cv->R.qualifier */
			s = make_statement(s,assignment_statement,o);
			v->reference.qualifier = p;
		end;

		if v->reference.offset^=null
		then do;
			p = declare_integer(blk);
			q = v->reference.offset;
			o = make_operator(assign,2,p,q,null);
/* v->R.offset=cv->R.offset */
			s = make_statement(s,assignment_statement,o);
			v->reference.offset = p;
		end;

		if v->reference.length^=null
		then do;
			p = declare_integer(blk);
			q = v->reference.length;
			o = make_operator(assign,2,p,q,null);
/* v->R.length=cv->R.length */
			s = make_statement(s,assignment_statement,o);
			v->reference.length = p;
		end;
	end;

			/*      */

	do while(spec^=null);
		if multiple_spec
		then do;
/* label1: ; */
			label1_statement = make_statement(label1_statement,null_statement,label1);
			label1_statement->statement.reference_count = 2;

			o = make_operator(assign,2,label_variable,label1,null);
/* label_variable=label1; */
			s = make_statement(s,assignment_statement,o);
			s->statement.processed ="1"b;
		end;
		else do;
			label1_statement = last_statement;
			last_statement -> statement.reference_count = last_statement -> statement.reference_count - 1;
		end;

		e(1), e(2), e(3) = null;

		sign_of_by = 0;

		do i=1 to 3;
			if spec->operand(i)^=null
			then	if spec->operand(i)->node.type=token_node
				then do;
					e(i) = spec->operand(i);

					if i=3
					then	if spec->operand(3)->token.type & is_constant
						then	if substr(spec->operand(3)->token.string,1,1)="-"
							then	sign_of_by = -1;
							else	sign_of_by =  1;
				end;
				else do;
					if spec->operand(i)->node.type=operator_node
					then	if spec->operand(i)->operator.op_code=loop
						|  spec->operand(i)->operator.op_code=join
						then	call semantic_translator$abort(140,null);
						else	p = spec->operand(i)->operand(1);
					else	p = spec->operand(i);

					ref = p;

					if p->node.type = reference_node
					then do;
						if p->reference.array_ref
						then	call semantic_translator$abort(140,null);

						p = p->reference.symbol;

						if p->node.type = symbol_node
						then do;
							if p->symbol.area & spec->operand(4)=null
							then	call semantic_translator$abort(143,p);

							if p->symbol.dcl_size^=null & spec->operand(4)=null
							then	call semantic_translator$abort(144,p);
						end;
					end;

					if i=1
					then	e(1) = spec->operand(1);

					else	if p->symbol.constant & ref->reference.shared & i=2
						/* by is too complicated for this optimization */
					then	e(i) = spec->operand(i);

					else do;
/* e(i)=expr(i) */
						q = create_symbol(blk,null,by_compiler);

						if spec->operand(i)->node.type=operator_node
						then do;
							if spec->operand(i)->op_code^=std_call
							then do;
								q->symbol = p->symbol;
								q->symbol.next = null;
								q->symbol.block_node = blk;
								e(i)  ,
								spec->operand(i)->operand(1)  ,
								q->symbol.reference = copy_expression(p->symbol.reference);
								e(i)->reference.symbol = q;
							end;
							else do;
								e(i) = spec->operand(i)->operand(1);
								e(i)->reference.ref_count = e(i)->reference.ref_count+1;
							end;

							s = make_statement(s,assignment_statement,(spec->operand(i)));
						end;
						else do;
							e(i) = q->symbol.reference;
							q->symbol.temporary = "1"b;
							o = make_operator(assign,2,e(i),(spec->operand(i)),null);

							s = make_statement(s,assignment_statement,o);

							context = "0"b;

							s->statement.root = operator_semantics(blk,s,o,context);
						end;

						q->symbol.temporary = "0"b;
						q->symbol.auto  ,
						q->symbol.allocate  ,
						s->statement.processed = "1"b;
					end;
				end;
		end;

		if e(1)^=null
		then do;
			o = make_operator(assign,2,copy_ref(v),e(1),null);
/* v=e1; */
			s = make_statement(s,assignment_statement,o);
		end;

		if e(2)=null & e(3)=null & spec->operand(4)=null & spec->operand(5)=null
		then do;
			next_statement = label1_statement;
			goto next_spec;
		end;
/* next: ; */
		next_statement = make_statement(label1_statement,null_statement,next);
		next_statement->statement.reference_count = 1;
		string(next_statement->statement.source_id) = string(last_statement->statement.source_id);

		if spec->operand(2)^=null
		|  spec->operand(3)^=null
		|  spec->operand(4)^=null
		|  spec->operand(5)^=null & cv=null
		then do;
/* label2: ; */
			s = make_statement(s,null_statement,label2);
		          s->statement.begins_loop = "1"b;
			s->statement.reference_count = 2;

		end;

		if cv^=null
		then do;
			if e(2)^=null & e(3)=null
			then do;
				sign_of_by = 1;
				e(3) = create_token("1",dec_integer);
			end;

			if e(3)^=null
			then do;
				o = make_operator(add,3,null,copy_ref(v),share_expression(e(3)));
				o = make_operator(assign,2,copy_ref(v),o,null);
/* v=v+e3; */
				label1_statement = make_statement(label1_statement,assignment_statement,o);
				string(label1_statement->statement.source_id) = string(last_statement->statement.source_id);
			end;

			if spec->operand(4)^=null
			then do;
				o = make_operator(assign,2,copy_ref(v),(spec->operand(4)),null);
				label1_statement = make_statement(label1_statement,assignment_statement,o);
				string(label1_statement->statement.source_id) = string(last_statement->statement.source_id);
				o->operand(2) = expression_semantics(blk,label1_statement,(o->operand(2)),"0"b);
			end;

			if e(2)^=null
			then	if sign_of_by=0
				then do;
					cvref = copy_ref(v);
					if ^ cvref -> reference.shared
					     then cvref -> reference.ref_count = 2;

					o3 = make_operator(greater_or_equal,3,null,share_expression(e(3)),create_token("0",dec_integer));
					o4 = make_operator(greater_than,3,null,cvref,share_expression(e(2)));
					o1 = make_operator(and_bits,3,null,o3,o4);

					o3 = make_operator(less_than,3,null,share_expression(e(3)),create_token("0",dec_integer));
					o4 = make_operator(less_than,3,null,cvref,share_expression(e(2)));
					o2 = make_operator(and_bits,3,null,o3,o4);

					o = make_operator(or_bits,3,null,o1,o2);
					o = make_operator(jump_true,2,next,o,null);


/* if (e3>=0) & (v>e2) | (e3<0) & (v<e2) then goto next; */
					s = make_statement(s,if_statement,o);
				end;
				else do;
					if sign_of_by>0
					then	opcode = jump_if_gt;
					else	opcode = jump_if_lt;
					o = make_operator(opcode,3,next,copy_ref(v),share_expression(e(2)));

/* if v>e2 [v<e2] then goto next; */
					s = make_statement(s,if_statement,o);
				end;
		end;
	
		if spec->operand(5)^=null
		then do;
			if spec->operand(5)->node.type^=operator_node
			then	goto create_jump_operator;

			opcode = spec->operand(5)->operator.op_code;

			if opcode<less_than | opcode>greater_or_equal
			then	goto create_jump_operator;

			if opcode=equal
			then	opcode = jump_if_ne;	else
			if opcode=not_equal
			then	opcode = jump_if_eq;	else
			if opcode=less_than
			then	opcode = jump_if_ge;	else
			if opcode=greater_than
			then	opcode = jump_if_le;	else
			if opcode=less_or_equal
			then	opcode = jump_if_gt;
			else	opcode = jump_if_lt;

			o = spec->operand(5);
			o->operator.op_code = opcode;
			o->operand(1) = next;

			goto create_while_statement;

create_jump_operator:
			o = make_operator(jump_false,2,next,(spec->operand(5)),null);
/* if ^e5 then goto next; */
create_while_statement:
			s = make_statement(s,if_statement,o);
			o = expression_semantics(blk,s,o,"0"b);
		end;

		if e(3)^=null
		|  spec->operand(4)^=null
		|  spec->operand(5)^=null & cv=null
		then do;
			o = make_operator(jump,1,label2,null,null);
/* goto label2; */
			label1_statement = make_statement(label1_statement,goto_statement,o);
			string(label1_statement->statement.source_id) = string(last_statement->statement.source_id);
			label1_statement->statement.processed ="1"b;

			if pl1_stat_$profile
			then do;

				/* we want 2 profile entries for do statement, so put
				   out a statement with 0 id */

				prof = label2->label.statement;
				prof = create_statement(null_statement,prof,null,(prof->statement.prefix));
				string(prof->statement.source_id) = "0"b;
			end;
		end;

next_spec:
		if ^first_spec
		then do;
			o = make_operator(jump,1,first,null,null);
/* goto first */
			s = make_statement(s,goto_statement,o);
			first->label.statement->statement.reference_count = first->label.statement->statement.reference_count+1;
			s->statement.processed ="1"b;
		end;

		else do;
		     first_spec = "0"b;
		end;
		label1_statement  ,
		s = next_statement;
		spec = spec->operand(6);
	end;

	goto ret;


			/*      */

make_operator:	proc(opcode,number,opnd1,opnd2,opnd3) returns(ptr);

dcl	opcode bit(9) aligned,

	number fixed bin(15),

	(op,opnd1,opnd2,opnd3) ptr;

	op = create_operator(opcode,number);

	if number >= 1
	then do;
		op -> operator.operand (1) = opnd1;

		if number >= 2
		then do;
			op -> operator.operand (2) = opnd2;

			if number >= 3
			then op -> operator.operand (3) = opnd3;
		     end;
	     end;

	return(op);

	end make_operator;

make_statement:	proc(st,type,opnd) returns(ptr);

dcl	type bit(9) aligned,

	(opnd,st,stp) ptr;

	stp = create_statement(type,st,null,(st->statement.prefix));
	stp->statement.generated = "1"b;

	if type=null_statement
	then do;
		opnd = create_label(blk,null,by_compiler);
		opnd->label.statement = stp;
		stp->statement.labels = create_list(2);
		stp->statement.labels->list.element(2) = opnd;

		stp->statement.processed ="1"b;
	end;
	else	stp->statement.root = opnd;

	return(stp);

	end make_statement;

copy_ref:	proc(pt) returns(ptr);

dcl	(p,pt) ptr;

	if first_time
	then do;
	     first_time = "0"b;
	     return(pt);
	     end;

	if pt -> reference.shared
	     then return(pt);

	p = create_reference(null);
	p -> reference = pt -> reference;

	/* offset and length are known to be null or shared auto
	   variables, so only check qualifier */

	if p -> reference.qualifier ^= null
	     then p -> reference.qualifier = share_expression((p -> reference.qualifier));

	return(p);

	end copy_ref;

			/*      */

ret:
	call free_node(tree);

	end do_semantics;




		    expand_assign.pl1               09/19/89  1224.2rew 09/19/89  1012.8      297117



/****^  ***********************************************************
        *                                                         *
        * 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(86-07-15,Ginter), approve(86-07-15,MCR7287), audit(86-07-16,Mabey),
     install(86-07-28,MR12.0-1105):
     Bug fixes for the MR12.0 release of the compiler.
  2) change(87-04-15,RWaters), approve(87-04-15,MCR7635), audit(87-04-28,Huen),
     install(87-05-21,MR12.1-1033):
     Fix bug #2124
  3) change(89-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
     install(89-09-19,MR12.3-1068):
     Fix bug 1819.
                                                   END HISTORY COMMENTS */


/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
expand_assign:
     proc (blk, stmnt, input_tree, context, agg_ref) returns (ptr);

/* Modified 780619 by PG for unsigned */
/* Modified 780814 by RAB to fix 1743 */
/* Modified 790806 by RAB to fix 1841 (return((*) bit(*)) gets FATAL ERROR 310) */
/* Modified 790807 by RAB to fix 1847 (bad descriptor built when char(*) varying
   promoted to array.  Bug caused by maker not setting symbol.exp_extents) */
/* Modified: 17 Mar 1980 by PCK to implement by name assignment */
/* Modified 830427 BIM to not check refer extents when the assignment */
/*          is not an array assignment. */
/* Modified 850607 MM to fix 2109 by name assignments to retain the token */
/*	  pointer from the original structure in any temporary structures */
/*	  that are generated in the assignment. */
/* Modified 871504 RW to fix 2124 incompatible attributes in compiler variable */
/* Modified 880101 RW diagnose passing a label array as a parameter */

dcl      (agg_ref, blk, stmnt, tree, input_tree, a, b, s, sa, sb, t, p, q, qual, aqual, bqual) ptr,
         (a_for_return, sa_for_return) ptr,
         image ptr init (null);

dcl      k fixed bin (15),				/* used by fill_desc and descendants */
         constant fixed bin,
         (have_varying, modified) bit (1) aligned,
         (cross_section, doing_return, no_data_type, interleaved) bit (1) init ("0"b) aligned;

dcl      based_integer fixed bin (15) based;

dcl      pl1_stat_$locator (128) ptr ext static;
dcl      pl1_stat_$index fixed bin (15) ext static;

dcl      (addr, string, fixed, hbound, null, substr) builtin;
%page;
	s = stmnt;
	tree = input_tree;

	a = tree -> operand (1);
	b = tree -> operand (2);

	if a -> node.type ^= reference_node then
	     if a -> node.type = operator_node then
		if a -> op_code = loop | a -> op_code = join then
		     goto infix;
		else
		     call semantic_translator$abort (90, null);
	     else
		call semantic_translator$abort (90, null);

	sa = a -> reference.symbol;

	if sa -> node.type ^= symbol_node then
	     call semantic_translator$abort (91, null);

	if sa -> symbol.constant then
	     call semantic_translator$abort (91, null);

	if a -> reference.array_ref then do;
	     if sa -> symbol.array -> array.interleaved then
		interleaved = "1"b;

	     if a -> reference.offset ^= null then
		if a -> reference.offset -> node.type = list_node then
		     cross_section = "1"b;
	end;

	if ^a -> reference.array_ref & ^sa -> symbol.structure & string (sa -> symbol.data_type) ^= "0"b then
	     call semantic_translator$abort (93, b);

	if b -> node.type
	     =
	     token_node
	     /* we need a symbol node for use now but real processing of this	*/
	     /* token node will be done when op_semantics gets it later.		*/ then
	     b = convert (b, decoded_type (fixed (b -> token.type, 9)));

	if b -> node.type = reference_node then do;
	     sb = b -> reference.symbol;
	     qual = b -> reference.qualifier;

	     if b -> reference.array_ref then do;

		if sb -> node.type = label_node then	/* passing a label array as a prarmeter */
		     call semantic_translator$abort (83, b);
		else if sb -> node.type ^= symbol_node then
		     call semantic_translator$abort (195, null);
						/* somewhat inapropriate, but it shouldnt happen anyway */

		if b -> reference.offset ^= null then
		     if b -> reference.offset -> node.type = list_node then
			cross_section = "1"b;

		if sb -> symbol.array -> array.interleaved then
		     interleaved = "1"b;
	     end;
	end;

	if ^def_context.RHS_aggregate then
	     goto check_context;

	if b -> node.type ^= reference_node then
	     if b -> op_code = loop | b -> op_code = join then
		sb, qual = null;
	     else do;

/* expression is an aggregate-valued function reference.
			   This has been pulled out into its own statement, so
			   we can replace the operator with its result in this
			   tree. */

		tree -> operand (2), b = b -> operand (1);
		sb = b -> reference.symbol;
	     end;

	if stmnt -> statement.LHS_in_RHS then do;
	     stmnt -> statement.LHS_in_RHS = "0"b;

/*   a(*) = . . .   */
	     s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));

/*   t0 = b   */
	     q = create_operator (assign, 2);
	     p = create_symbol (null, null, by_compiler);
	     p -> symbol.temporary = "1"b;
	     q -> operand (1) = p -> symbol.reference;
	     q -> operand (2) = b;

	     s -> statement.root = expand_assign (blk, s, q, context, image);

/*   a = t0   */
	     b, tree -> operand (2) = image;
	     sb = b -> reference.symbol;
	end;

/* If the left hand side (LHS) is a temporary with no data type, replace it with a
   temporary whose type and extents are given by the right hand side (RHS).  */

	if string (sa -> symbol.data_type) = "0"b then do;
	     no_data_type = "1"b;

/*   to = . . .   */
	     if sb = null then
		sb = declare_expression (b, null, 1);

	     call maker (sb, sb, sa, "1"b, 1, b);

	     tree -> operand (1), agg_ref, a = copy_expression (sa -> symbol.reference);

	     if b -> node.type = reference_node then
		a -> reference.array_ref = b -> reference.array_ref;
	end;

check_context:
	if def_context.arg_list | def_context.return then do;
	     if ^sa -> symbol.star_extents then do;
		qual = a -> reference.qualifier;
		call maker (sa, sa, t, "0"b, 1, null);
	     end;
	     else do;
		if b -> node.type = operator_node then
		     if b -> operator.op_code ^= loop & b -> operator.op_code ^= join then do;

/* we are promoting scalar expression to aggregate (fixes 1743) */

			b = b -> operand (1);
			sb = b -> reference.symbol;
		     end;

		if sb = null then
		     sb = declare_expression (b, null, 1);


		doing_return = def_context.return;
		call maker (sa, sb, t, "0"b, 1, b);	/* pass sa to provide template for the temporary, 
						   sb to fill in star_extents info.		*/
	     end;

	     a_for_return = a;
	     sa_for_return = sa;

	     tree -> operand (1), agg_ref, a = copy_expression (t -> symbol.reference);

	     sa = t;

	     a -> reference.shared = "0"b;
	     a -> reference.ref_count = 2;

	     s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
	end;
	else
	     s = stmnt;

	if ^def_context.RHS_aggregate | def_context.by_name_assignment then
	     goto infix;

	if b -> node.type ^= reference_node | cross_section | interleaved then
	     goto infix;

	if ^compare_declaration (a, (b -> reference.symbol), "0"b) then
	     goto infix;


	if sa -> symbol.defined | sb -> symbol.defined then
	     goto infix;

	if a -> reference.array_ref ^= b -> reference.array_ref then
	     goto infix;

	if a -> reference.array_ref then
	     if substr (stmnt -> statement.prefix, 7, 1) then
		if sa -> symbol.refer_extents then do;
		     aqual = a -> reference.qualifier;
		     bqual = b -> reference.qualifier;
		     call check_refers (sa, sb);
		end;

	call process_offset (a);
	call process_offset (b);

	tree = make_copy (a, b);

	goto ret;

infix:
	tree = expand_infix (blk, s, tree, context);

	goto ret;
%page;
ret:
	if def_context.arg_list then do;
	     s -> statement.root = tree;
	     return (t -> symbol.reference);
	end;

	if def_context.return then do;
	     s -> statement.root = tree;

	     if sa_for_return -> symbol.star_extents then do;
		k = 0;
		call fill_desc (sa);

/* since the cg ignores the length expr when
			   compiling the return_words or return_bits
			   operators, and since prepare_operand expects
			   to see processed length exprs or no length exprs,
			   null the length expr */

		a -> reference.length = null;

		return (a);
	     end;

	     p = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
	     p -> statement.root, tree = make_copy (a_for_return, a);
	end;

	return (tree);
%page;
process_offset:
     proc (pt);

/* processes raw offset exprs */

dcl      (pt, a, sa, p) ptr;
dcl      i fixed bin;

	a = pt;

/* since the code generator ignores the length expr when compiling
	   the copy operators, and since prepare_operand expects to see
	   either processed length exprs or null length exprs, null the
	   length expr */

	a -> reference.length = null;

/* now, process the offset expr , if any */

	if a -> reference.offset ^= null then
	     if a -> reference.offset -> node.type = list_node then do;
		p = a -> reference.offset;

		do i = 1 to p -> list.number;
		     if p -> element (i) -> node.type = token_node then
			if p -> element (i) -> token.type = asterisk then
			     goto infix;
		end;

		if a -> reference.qualifier ^= null then do;
		     pl1_stat_$index = pl1_stat_$index + 1;
		     if pl1_stat_$index > hbound (pl1_stat_$locator, 1) then
			call semantic_translator$abort (70, null);
		     pl1_stat_$locator (pl1_stat_$index) = a;
		end;

		sa = a -> reference.symbol;
		a -> reference.offset = copy_expression (sa -> symbol.reference -> reference.offset);
		a = subscripter (blk, s, a, p, sa);

		if a -> reference.offset ^= null then do;
		     a -> reference.offset = expression_semantics (blk, s, (a -> reference.offset), "0"b);
		     a -> reference.offset = convert$to_integer ((a -> reference.offset), integer_type);

		     call simplify_offset (a, "0"b);
		end;

		if a -> reference.qualifier ^= null then
		     pl1_stat_$index = pl1_stat_$index - 1;
	     end;

     end;
%page;
/* subroutine to check that refer array extents are compatable.   */

check_refers:
     proc (asym, bsym);

dcl      (asym, bsym, anext, bnext, abound, bbound, p, q) ptr;
dcl      (own_bounds, processed_bounds) fixed bin;

	if asym -> symbol.array ^= null then do;
	     processed_bounds = 0;
	     bbound = bsym -> symbol.array -> array.bounds;
	     own_bounds = asym -> symbol.array -> own_number_of_dimensions;

	     do abound = asym -> symbol.array -> array.bounds repeat abound -> bound.next
		while (processed_bounds < own_bounds);
		if is_refer ((abound -> bound.upper)) then
		     if is_refer ((abound -> bound.lower)) then do;
			p = subtract_bounds (abound);
			q = subtract_bounds (bbound);
			call make_check_stmnt (p, q);
		     end;
		     else
			call make_check_stmnt (copy_expression (abound -> bound.upper),
			     copy_expression (bbound -> bound.upper));
		else if is_refer ((abound -> bound.lower)) then
		     call make_check_stmnt (copy_expression (abound -> bound.lower),
			copy_expression (bbound -> bound.lower));
		processed_bounds = processed_bounds + 1;
		bbound = bbound -> bound.next;
	     end;
	end;

	bnext = bsym -> symbol.son;

	do anext = asym -> symbol.son repeat anext -> symbol.brother while (anext ^= null);
	     call check_refers (anext, bnext);
	     bnext = bnext -> symbol.brother;
	end;

     end;
%page;
/* subroutine to test if a node is a refer operator node.   */

is_refer:
     proc (p) returns (bit (1) aligned);

dcl      p ptr;

	if p ^= null then
	     if p -> node.type = operator_node then
		if p -> operator.op_code = refer then
		     return ("1"b);

	return ("0"b);

     end;
%page;
/* subroutine to create an operator that subtracts the lower bound node from the upper bound node.   */

subtract_bounds:
     proc (p) returns (ptr);

dcl      (p, r) ptr;

	r = create_operator (sub, 3);
	r -> operator.operand (2) = copy_expression (p -> bound.upper);
	r -> operator.operand (3) = copy_expression (p -> bound.lower);
	return (r);

     end;
%page;
/* subroutine to create a bound_ck operator.   */

make_check_stmnt:
     proc (p, q);

dcl      (p, q, r) ptr;

	r = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
	r -> statement.root = create_operator (bound_ck, 4);
	call refer_extent (p, aqual);
	call refer_extent (q, bqual);
	r -> statement.root -> operator.operand (2) = p;
	r -> statement.root -> operator.operand (3) = q;
	r -> statement.root -> operator.operand (4) = copy_expression ((q));
	r -> statement.root = expression_semantics (blk, r, (r -> statement.root), "0"b);
     end;
%page;
/* subroutine to create assignments that fill in the descriptor of the left side.  */

fill_desc:
     proc (sp);

dcl      (sp, s, b) ptr;

	s = sp;

	call fill (s);

	if s -> symbol.dimensioned then do;
	     do b = s -> symbol.array -> array.bounds repeat b -> bound.next while (b ^= null);
		call fill (b);
		k = k + 3;
	     end;
	end;

	do b = s -> symbol.son repeat b -> symbol.brother while (b ^= null);
	     k = k + 1;
	     call fill_desc (b);
	end;
%page;
fill:
	proc (pt);

dcl      (pt, p, r, q, dr, size, d_template) ptr;
dcl      i fixed bin (15);

%include pl1_descriptor;

	     p = pt;

	     if p -> node.type = symbol_node then do;
		d_template =
		     sa_for_return -> symbol.descriptor -> reference.symbol -> symbol.descriptor -> symbol.initial;
		if s -> symbol.bit | s -> symbol.char then do;
		     r = copy_expression (p -> symbol.reference);
		     r = expression_semantics (blk, stmnt, r, context);
		     if r -> reference.varying_ref then do;
			if k > 0 | r -> reference.array_ref then do;
			     if p -> symbol.dcl_size = null then
				size = declare_constant$integer ((p -> symbol.c_dcl_size));
			     else do;
				size = copy_expression (p -> symbol.dcl_size);
				if p -> symbol.refer_extents then
				     call refer_extent (size, (a_for_return -> reference.qualifier));
				size = expression_semantics (blk, stmnt, size, "0"b);
			     end;
			end;
			else do;
			     size = create_operator ((length_fun), 2);
			     size -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
			     size -> operand (2) = r;
			end;
		     end;
		     else if r -> reference.length = null then
			size = declare_constant$integer ((r -> reference.c_length));
		     else
			size = r -> reference.length;
		     q = create_operator (make_desc, 3);
		     q -> operand (3) = size;
		     q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k).bit_type));
		end;
		else do;
		     q = create_operator (assign, 2);
		     q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k)));
		end;
		q -> operand (1), r = copy_expression (sa_for_return -> symbol.descriptor);
		r -> reference.c_offset = k;
		r -> reference.shared = "0"b;
		r -> reference.ref_count = 1;
		r = expression_semantics (blk, stmnt, r, context);
		dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
		     (stmnt -> statement.prefix));
		dr -> statement.root = q;
	     end;
	     else do;
		if p -> bound.lower = null then
		     p -> bound.lower = declare_constant$integer ((p -> bound.c_lower));
		if p -> bound.upper = null then
		     p -> bound.upper = declare_constant$integer ((p -> bound.c_upper));

		i = 0;
		do r = p -> bound.lower, p -> bound.upper, p -> bound.desc_multiplier;
		     i = i + 1;
		     q = create_operator (assign, 2);
		     q -> operand (1), dr = copy_expression (sa_for_return -> symbol.descriptor);
		     dr -> reference.units = word_;
		     dr -> reference.c_offset = k + i;
		     r = copy_expression ((r));
		     if s -> symbol.refer_extents then
			call refer_extent (r, (a_for_return -> reference.qualifier));
		     q -> operand (2) = expression_semantics (blk, stmnt, r, context);
		     dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
			(stmnt -> statement.prefix));
		     dr -> statement.root = q;
		end;
	     end;

	end fill;

     end fill_desc;
%page;
/* subroutine to create a copy operator.  */

make_copy:
     proc (a, b) returns (ptr);

dcl      (a, b, sb, p, q, ref, arrayp) ptr;
dcl      opcode bit (9) aligned;

/* Because get_array_size pads out the array element size if each
	   element must start on a > word_ boundary, a dangerous anomaly
	   could arise if the target is a nondimensioned structure while
	   the source is an array element.  Therefore, in such a case
	   the size of the nondimensioned structure must be used for
	   the assignment rather than the source size.  This fixes bug
	   1500.  */

	if b -> reference.symbol -> symbol.dimensioned & ^a -> reference.symbol -> symbol.dimensioned then
	     ref = a;
	else
	     ref = b;

	sb = ref -> reference.symbol;

	if sb -> symbol.dimensioned then
	     arrayp = sb -> symbol.array;
	else
	     arrayp = null;

	if sb -> symbol.packed then
	     opcode = copy_string;
	else
	     opcode = copy_words;

	if arrayp ^= null & ^ref -> reference.array_ref then
	     if sb -> symbol.packed then
		if arrayp -> array.element_size_bits = null then
		     p = declare_constant$integer ((arrayp -> array.c_element_size_bits));
		else
		     p = arrayp -> array.element_size_bits;
	     else if arrayp -> array.element_size = null then
		p = declare_constant$integer ((arrayp -> array.c_element_size));
	     else
		p = arrayp -> array.element_size;

	else if sb -> symbol.packed then
	     if sb -> symbol.bit_size = null then
		p = declare_constant$integer ((sb -> symbol.c_bit_size));
	     else
		p = sb -> symbol.bit_size;
	else if sb -> symbol.word_size = null then
	     p = declare_constant$integer ((sb -> symbol.c_word_size));
	else do;
	     p = sb -> symbol.word_size;
	     if sb -> symbol.temporary then
		sb -> symbol.word_size = expression_semantics (blk, stmnt, copy_expression ((p)), "0"b);
	end;

	this_context = "0"b;
	p = copy_expression ((p));
	if sb -> symbol.refer_extents then
	     call refer_extent (p, (b -> reference.qualifier));
	p = expression_semantics (blk, stmnt, p, this_context);

	call simplify_expression (p, constant, modified);
	if modified then
	     p = declare_constant$integer ((constant));

	q = create_operator (opcode, 3);
	q -> operand (1) = a;
	q -> operand (2) = b;
	q -> operand (3) = p;

	return (q);

     end make_copy;
%page;
/* subroutine to make a source-like declaration of a temporary.  */

maker:
     proc (t, e, s, given, level_number, er);

dcl      (s, p, q, f, a, r, t1, e1, s1, eb, subs) ptr;
dcl      (t, e) ptr;				/* t points to the param_desc (the target) symbol, e points to the expression symbol */
dcl      er ptr;					/* er points to the expression reference or is null */
dcl      (n, i, level_number, sdims) fixed bin (15);
dcl      (given, refer_extents, have_subs, ignore_e_array) aligned bit (1);

	n = 0;
	ignore_e_array, have_subs = "0"b;
	if ^given then
	     s = create_symbol (blk, null, by_compiler);
	string (s -> symbol.data_type) = string (t -> symbol.data_type);
	string (s -> symbol.misc_attributes) = string (t -> symbol.misc_attributes);
	s -> symbol.star_extents, s -> symbol.member, s -> symbol.external, s -> symbol.initialed = "0"b;

	refer_extents = e -> symbol.refer_extents;

	if t -> symbol.array ^= null then
	     if level_number = 1 then do;
		n, sdims = t -> symbol.array -> array.number_of_dimensions;
		if er ^= null then
		     if er -> node.type = reference_node then
			if ^er -> reference.array_ref then
			     if t = e then
				n, sdims = 0;
			     else
				ignore_e_array = "1"b;
			else if er -> reference.offset ^= null then
			     if er -> reference.offset -> node.type = list_node then do;
				subs = er -> reference.offset;
				have_subs = "1"b;
				sdims = 0;
			     end;
	     end;

	     else
		n, sdims = t -> symbol.array -> array.own_number_of_dimensions;

	s -> symbol.dimensioned = (n ^= 0);
	s -> symbol.block_node = t -> symbol.block_node;
	s -> symbol.general = t -> symbol.general;

	s -> symbol.pix = t -> symbol.pix;

	s -> symbol.c_dcl_size = t -> symbol.c_dcl_size;

	if t -> symbol.param_desc then
	     if t -> symbol.dcl_size ^= null then
		if t -> symbol.dcl_size -> node.type = token_node then
		     if t -> symbol.dcl_size -> token.type = asterisk then
			if e -> symbol.fixed | e -> symbol.float then do;
			     a = convert$from_builtin ((e -> symbol.reference),
				(substr (string (t -> symbol.attributes), 1, 36) & string_mask));
			     s -> symbol.c_dcl_size =
				a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
			end;
			else
			     s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;

	if doing_return then
	     if t -> symbol.dcl_size ^= null then
		if t -> symbol.dcl_size -> node.type = operator_node then
		     if t -> symbol.dcl_size -> operator.op_code = desc_size then
			if e -> symbol.fixed | e -> symbol.float then do;
			     a = convert$from_builtin ((e -> symbol.reference),
				(substr (string (t -> symbol.attributes), 1, 36) & string_mask));
			     s -> symbol.c_dcl_size =
				a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
			end;
			else
			     s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;

	if s -> symbol.entry then
	     s -> symbol.dcl_size = t -> symbol.dcl_size;
	else do;
	     s -> symbol.dcl_size = e -> symbol.dcl_size;
	     if s -> symbol.dcl_size ^= null then do;
		s -> symbol.exp_extents = "1"b;
		if s -> symbol.dcl_size -> node.type = token_node then
		     if s -> symbol.dcl_size -> token.type = dec_integer then
			s -> symbol.exp_extents = "0"b;
	     end;
	end;

	if refer_extents then do;
	     r = copy_expression (s -> symbol.dcl_size);
	     call refer_extent (r, qual);
	     s -> symbol.dcl_size = r;
	end;

	s -> symbol.scale = t -> symbol.scale;
	s -> symbol.level = level_number;

	if n ^= 0 then do;
	     s -> symbol.array, a = create_array ();
	     p = t -> symbol.array -> array.bounds;

	     if ^ignore_e_array then
		eb = e -> symbol.array;
	     else
		eb = null;

	     if eb ^= null then
		eb = eb -> array.bounds;

	     do i = 1 to n while (p ^= null);
		if have_subs then do;
		     if subs -> element (i) -> node.type ^= token_node then
			goto step;
		     if subs -> element (i) -> token.type ^= asterisk then
			goto step;

		     sdims = sdims + 1;
		end;

		q = create_bound ();
		q -> bound.c_lower = p -> bound.c_lower;
		q -> bound.c_upper = p -> bound.c_upper;

		q -> bound.lower = p -> bound.lower;
		q -> bound.upper = p -> bound.upper;

		if t -> symbol.param_desc then
		     if q -> bound.lower ^= null then
			if q -> bound.lower -> node.type = token_node then
			     if q -> bound.lower -> token.type = asterisk /* fill in star_extents from e */ then
				call use_eb;

		if doing_return then
		     if q -> bound.lower ^= null then
			if q -> bound.lower -> node.type = reference_node then
			     if q -> bound.lower -> reference.symbol -> node.type = symbol_node then
				if q -> bound.lower -> reference.symbol -> symbol.arg_descriptor then
				     call use_eb;

		if refer_extents then do;
		     r = copy_expression (q -> bound.lower);
		     call refer_extent (r, qual);
		     q -> bound.lower = r;
		     r = copy_expression (q -> bound.upper);
		     call refer_extent (r, qual);
		     q -> bound.upper = r;
		end;

		if q -> bound.lower ^= null then do;
		     call simplify_expression ((q -> bound.lower), constant, modified);

		     if modified then do;
			q -> bound.lower = null;
			q -> bound.c_lower = constant;
		     end;
		     else
			s -> symbol.exp_extents = "1"b;
		end;

		if q -> bound.upper ^= null then do;
		     call simplify_expression ((q -> bound.upper), constant, modified);

		     if modified then do;
			q -> bound.upper = null;
			q -> bound.c_upper = constant;
		     end;
		     else
			s -> symbol.exp_extents = "1"b;
		end;

		if a -> array.bounds = null then
		     a -> array.bounds = q;
		else
		     f -> bound.next = q;

		f = q;

step:
		p = p -> bound.next;

		if eb ^= null then
		     eb = eb -> bound.next;
	     end;

	     a -> array.own_number_of_dimensions = sdims;
	end;

	f = null;
	t1 = t -> symbol.son;
	e1 = e -> symbol.son;

	do while (t1 ^= null);
	     if e -> symbol.son = null then
		e1 = e;

	     if def_context.by_name_assignment /* Fixes 2109 */ then do;
		s1 = create_symbol (blk, (e1 -> symbol.token), by_compiler);
		call maker (t1, e1, s1, "1"b, level_number + 1, null);
	     end;
	     else
		call maker (t1, e1, s1, "0"b, level_number + 1, null);

	     s1 -> symbol.member = "1"b;
	     s1 -> symbol.father = s;
	     if f = null then
		s -> symbol.son = s1;
	     else
		f -> symbol.brother = s1;
	     f = s1;
	     t1 = t1 -> symbol.brother;
	     e1 = e1 -> symbol.brother;
	end;

	if level_number = 1 then do;
	     if s -> symbol.dcl_size ^= null then do;
		call simplify_expression ((s -> symbol.dcl_size), constant, modified);

		if modified then do;
		     s -> symbol.dcl_size = null;
		     s -> symbol.c_dcl_size = constant;
		end;
	     end;

	     s -> symbol.temporary = "1"b;
	     s -> symbol.position = "0"b;		/* fixes bug #2124 */
	     call declare (s);

	     if s -> symbol.word_size ^= null then do;	/* process aggregrate expression size for use by code generator */
		s -> symbol.word_size =
		     expression_semantics (blk, stmnt, copy_expression (s -> symbol.word_size), "0"b);

		call simplify_expression ((s -> symbol.word_size), constant, modified);

		if modified then do;
		     s -> symbol.word_size = null;
		     s -> symbol.c_word_size = constant;
		end;
	     end;
	end;


use_eb:
	proc;

	     if eb ^= null then do;
		q -> bound.lower = eb -> bound.lower;
		q -> bound.upper = eb -> bound.upper;
		q -> bound.c_lower = eb -> bound.c_lower;
		q -> bound.c_upper = eb -> bound.c_upper;
	     end;
	     else do;
		q -> bound.lower, q -> bound.upper = null;
		q -> bound.c_lower, q -> bound.c_upper = 1;
	     end;

	end use_eb;

     end maker;
%page;
/* subroutine to create a declaration which represents the result of an aggregate valued expression.  */

declare_expression:
     proc (tree, last, level_number) returns (ptr);

dcl      (tree, last, s, f, a, b) ptr;
dcl      (i, level_number) fixed bin (15);

	if tree = null then
	     return (null);

	if tree -> node.type = reference_node then do;
	     call maker ((tree -> reference.symbol), (tree -> reference.symbol), a, "0"b, level_number, null);
	     return (a);
	end;

	if tree -> node.type ^= operator_node then
	     return (tree);

	if tree -> operator.op_code = join then do;
	     b = null;
	     f = create_symbol (blk, null, by_compiler);
	     f -> symbol.structure = "1"b;

	     do i = 1 to tree -> operator.number;
		s = declare_expression ((tree -> operand (i)), null, level_number + 1);
		s -> symbol.father = f;
		s -> symbol.member = "1"b;

		if b ^= null then
		     b -> symbol.brother = s;
		else
		     f -> symbol.son = s;

		b = s;
	     end;

	     f -> symbol.level = level_number;

	     return (f);
	end;

	if tree -> operator.op_code = loop then do;
	     b = create_bound ();
	     b -> bound.next = last;
	     last = b;
	     b -> bound.c_lower = 1;
	     b -> bound.upper = tree -> operand (4);
	     if tree -> operand (4) -> node.type = reference_node then
		if tree -> operand (4) -> reference.symbol -> symbol.constant then do;
		     b -> bound.upper = null;
		     b -> bound.c_upper = tree -> operand (4) -> reference.symbol -> symbol.initial -> based_integer;
		end;

	     s = declare_expression ((tree -> operand (1)), last, level_number);

	     if last ^= null then do;
		s -> symbol.dimensioned = "1"b;
		s -> symbol.array = create_array ();
		s -> symbol.array -> array.bounds = last;

		s -> symbol.array -> array.own_number_of_dimensions =
		     s -> symbol.array -> array.own_number_of_dimensions + 1;
		s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;

		last = null;

		s -> symbol.reference -> reference.array_ref = "1"b;
	     end;

	     s -> symbol.array -> array.own_number_of_dimensions =
		s -> symbol.array -> array.own_number_of_dimensions + 1;
	     s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;

	     return (s);
	end;

	s = tree -> operand (1) -> reference.symbol;
	call maker (s, s, a, "0"b, level_number, null);

	if last ^= null & (s -> symbol.bit | s -> symbol.char) then do;
	     have_varying = "0"b;
	     a -> symbol.c_dcl_size = 0;
	     a -> symbol.dcl_size = size (tree);

	     if no_data_type & have_varying then do;
		a -> symbol.varying, a -> symbol.aligned = "1"b;
		a -> symbol.unaligned, a -> symbol.packed = "0"b;
	     end;
	     a -> symbol.exp_extents = "1"b;
	end;

	if a -> symbol.dcl_size ^= null then do;
	     call simplify_expression ((a -> symbol.dcl_size), constant, modified);

	     if modified then do;
		a -> symbol.dcl_size = null;
		a -> symbol.c_dcl_size = constant;
	     end;
	end;

	if level_number = 1 then do;
	     a -> symbol.temporary = "1"b;
	     call declare (a);

	     if a -> symbol.word_size ^= null then do;
		a -> symbol.word_size =
		     expression_semantics (blk, stmnt, copy_expression (a -> symbol.word_size), "0"b);
		call simplify_expression ((a -> symbol.word_size), constant, modified);

		if modified then do;
		     a -> symbol.word_size = null;
		     a -> symbol.c_word_size = constant;
		end;
	     end;
	end;

	return (a);

     end declare_expression;
%page;
/* subroutine to determine the size of a string array temporary.  */

size:
     proc (e) returns (ptr);

dcl      (e, s, q) ptr;
dcl      opcode bit (9) aligned;

	if e = null then
	     call semantic_translator$abort (195, null);

	if e -> node.type = reference_node then do;
	     s = e -> reference.symbol;
	     if s -> symbol.dcl_size = null then
		q = declare_constant$integer ((s -> symbol.c_dcl_size));
	     else
		q = s -> symbol.dcl_size;

	     if s -> symbol.varying then
		have_varying = "1"b;

	     q = copy_expression ((q));
	     this_context = "0"b;
	     if s -> symbol.refer_extents then
		call refer_extent (q, (e -> reference.qualifier));
	     q = expression_semantics (blk, stmnt, q, this_context);
	     return (q);
	end;

	if e -> node.type ^= operator_node then
	     call semantic_translator$abort (195, null);

	opcode = e -> operator.op_code;

	if opcode = cat_string then do;
	     q = create_operator (add, 3);
	     q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
	     q -> operand (2) = size ((e -> operand (2)));
	     q -> operand (3) = size ((e -> operand (3)));
	     return (q);
	end;

	if opcode = or_bits | opcode = and_bits | opcode = xor_bits | opcode = bool_fun then do;
	     q = create_operator (max_fun, 3);
	     q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
	     q -> operand (2) = size ((e -> operand (2)));
	     q -> operand (3) = size ((e -> operand (3)));
	     return (q);
	end;

	if opcode = repeat_fun then do;
	     q = create_operator (mult, 3);
	     q -> operand (2) = size ((e -> operand (2)));
	     q -> operand (3) = copy_expression (e -> operand (3));
	     return (q);
	end;

	q = size ((e -> operand (1)));

	if q -> node.type = operator_node then
	     if q -> operator.op_code = length_fun then
		if q -> operand (2) = e -> operand (2) then do;
		     if ^q -> operand (1) -> reference.shared then
			q -> operand (1) -> reference.ref_count = q -> operand (1) -> reference.ref_count - 1;
		     else do;
			q = q -> operand (2);
			if q -> node.type = operator_node then
			     q = q -> operand (1);
			if ^q -> reference.shared then
			     q -> reference.ref_count = q -> reference.ref_count - 1;
		     end;
		     return (size ((e -> operand (2))));
		end;

	return (q);

     end size;
%page;
%include semant;
%include array;
%include block;
%include boundary;
%include declare_type;
%include decoded_token_types;
%include list;
%include mask;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include symbol_bits;
%include system;
%include token;
%include token_types;

     end expand_assign;




		    expand_by_name.pl1              09/22/89  1408.7rew 09/22/89  1400.0      163674



/****^  ***********************************************************
        *                                                         *
        * 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,MCR8121), audit(89-08-09,Vu),
     install(89-09-22,MR12.3-1073):
     Changed references to error 134 to 135.
                                                   END HISTORY COMMENTS */


/* Written: 26 Dec 1979 by PCK to implement by name assignment
 * Modified 06 June 89 by RWaters changed references to error msg 134 to 135
 */
/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
expand_by_name:
     procedure (blk, stmnt, tree);

/* parameters */

dcl      (blk, stmnt, tree) ptr parameter;

/* external static */

dcl      pl1_stat_$by_name_parts_tree ptr external static;
dcl      pl1_stat_$by_name_parts_free_list ptr external static;
dcl      pl1_stat_$by_name_free_list ptr external static;
dcl      pl1_stat_$by_name_ref_list ptr external static;

/* builtins */

dcl      (null, addr) builtin;

/* constants */

dcl      TRUE bit (1) aligned internal static options (constant) init ("1"b);
dcl      FALSE bit (1) aligned internal static options (constant) init ("0"b);

/* automatic */

dcl      root_of_any_struc ptr;

/* global variables (automatic) */

dcl      CUR_STMNT ptr;
dcl      ERR_REF ptr;
dcl      TARGET_LIST ptr;
dcl      NO_OF_TARGETS fixed bin;
dcl      ASSIGNMENT_GENERATED bit (1) aligned;

%page;
/* program */

	ASSIGNMENT_GENERATED = FALSE;
	TARGET_LIST = tree -> operand (1);
	CUR_STMNT = stmnt;
	NO_OF_TARGETS = TARGET_LIST -> list.number;

/* Recycle the by_name_agg nodes created in the last invocation
 * of expand_by_name
 */

	if pl1_stat_$by_name_parts_tree ^= null then
	     call free_by_name_parts_tree;

/* Recycle the list nodes (by_name_ref nodes) created in the last
 * invocation of expand_by_name
 */

	if pl1_stat_$by_name_ref_list ^= null then
	     call free_by_name_refs;

/* Indicate the context of the structure references to lookup */

	this_context = (36)"0"b;
	def_this_context.suppress_cross_ref = TRUE;
	def_this_context.by_name_lookup = TRUE;

/* Process the LHS references of the assignment statement */

	call traverse_target_list;

/* Process the RHS references of the assignment statement */

	call traverse_expression ((tree -> operand (2)));

/* At this point all structure references in the statement have been
 * located and now may now be expanded according to the definition
 * of by name assignment
 */

/* Get a pointer to the root of a structure, any will do. */

	root_of_any_struc = pl1_stat_$by_name_ref_list -> list.element (1);

/* Traverse the set of structures and generate assignment statements */

	call traverse_structures (root_of_any_struc);

/* Issue a warning if the by name expansion generated no assignment statements */

	if ^ASSIGNMENT_GENERATED then do;
	     call semantic_translator$error (380, null);
	     stmnt -> statement.statement_type = null_statement;
	     stmnt -> statement.root = null;
	     tree = null;
	end;
	else
	     call build_assignment;

	return;
%page;
/* Examine each target of the assign by name statement, verify
 * that each reference is to a structure or an array of structures,
 * and append each target reference to pl1_stat_$by_name_ref_list
 */
traverse_target_list:
     procedure ();

dcl      i fixed bin;
dcl      (targ_ptr, s) ptr;

/* Build a linked list of pointers to the symbol nodes
 * of the targets; verify that each reference is to a structure.
 */

	def_this_context.left_side = TRUE;

	do i = 1 to TARGET_LIST -> list.number;
	     targ_ptr = TARGET_LIST -> list.element (i);
	     ERR_REF = targ_ptr;

/* targ_ptr must point to either a reference or token node */

	     if targ_ptr -> node.type ^= token_node & targ_ptr -> node.type ^= reference_node then
		call semantic_translator$abort (378, ERR_REF);

/* All targets must be structures; therefore, they must be declared.  */

	     if ^lookup (blk, stmnt, targ_ptr, s, this_context) then
		call semantic_translator$abort (379, ERR_REF);

	     if s -> node.type = label_node then
		call semantic_translator$abort (135, ERR_REF);

	     if ^s -> symbol.structure then
		call semantic_translator$abort (379, ERR_REF);

/* Add symbol node pointer to list */

	     call append (s);

	end;

/* All references with left side context have been processed */

	def_this_context.left_side = FALSE;
	return;

     end traverse_target_list;
%page;
/* Traverses an expression recursively and searches for structure references
 * that are (1) not part of a qualifier, (2) not in an argument list,
 * and (3) not in a subscript list.  All other structure references are
 * saved in a list for later use in expanding the assignment statement
 */
traverse_expression:
     procedure (operand_ptr);

dcl      operand_ptr ptr parameter;

dcl      i fixed bin;
dcl      s ptr;

	if operand_ptr -> node.type = operator_node then
	     do i = 2 to operand_ptr -> operator.number;
		call traverse_expression ((operand_ptr -> operand (i)));
	     end;
	else if lookup (blk, stmnt, operand_ptr, s, this_context) then do;
						/* If it is a reference to a label, do nothing */

	     if s -> node.type ^= symbol_node then
		return;

/* If it is a reference to a structure, save the reference */

	     if s -> symbol.structure then
		call append (s);

	end;

	return;

     end traverse_expression;
%page;
/*
 * Append a node onto pl1_stat_$by_name_ref_list
 */
append:
     procedure (sym_ptr);

dcl      sym_ptr ptr parameter;

dcl      by_name_ref ptr;

	by_name_ref = get_by_name_ref ();

/* Points to symbol node of structure referenced in statement,
 * and is used as a cursor during the traversal of the structures
 */

	by_name_ref -> list.element (1) = sym_ptr;

/* Points to next node in list */

	by_name_ref -> list.element (2) = pl1_stat_$by_name_ref_list;

	pl1_stat_$by_name_ref_list = by_name_ref;

	return;

     end append;
%page;
/* Simultaneously traverses the collection of structures representing the 
 * structure references in the by name assignment statement.  During
 * the traversal, a tree, called the by name parts tree, is built.
 * It is a tree representation of the by name parts list discussed in
 * the ANSI PL/I standard.  It is used by expand_primitive to determine
 * how to expand structure references in the by name assignment into
 * a tree of join operators.
 *
 *   The algorithm proceeds as follows:
 *	(1) A structure is selected for preorder traversal.
 *
 *	(2) As it is being traversed, the other structures are checked for
 *	    the existance of nodes at the same level.  If no such
 *	    nodes exist, the traversal of the substructure rooted at this
 *	    node is terminated;  the traversal of the rest of the structure
 *	    is continued.
 *
 *	(3) Next, the other structures are checked for nodes at the same
 *	    level that have identifiers that match the identifier of
 *	    node of the structure being traversed.  If a structure exists
 *	    that does not satisfy this condition, the traversal of
 *	    the substructure is terminated as before.
 *
 *	(4) When a leaf of the structure is encountered, all other structures
 *	    are checked for the existance of leaves with matching
 *	    identifiers on the same level.   If the matching leaves
 *	    are found in every structure, an intersection is recorded
 *	    using the symbols corresponding to the leaves.  Otherwise,
 *	    the traversal is continued until completed.
 */
traverse_structures:
     procedure (root);

dcl      root ptr parameter;

/*  global variables (automatic) */

dcl      SUB_STRUC ptr;
dcl      CUR_BNA_NODE ptr;
dcl      TRAVERSE_STRUCTURE bit (1) aligned;

/* Assume that the root node has been matched. */

	SUB_STRUC = root;
	pl1_stat_$by_name_parts_tree = get_by_name_agg ();
	pl1_stat_$by_name_parts_tree -> by_name_agg.ok_to_free = FALSE;
	CUR_BNA_NODE = pl1_stat_$by_name_parts_tree;
	call push;

/* Simulate recursive walk of structure */

	TRAVERSE_STRUCTURE = TRUE;

	do while (TRAVERSE_STRUCTURE);
	     if matching_ids_exist (SUB_STRUC) then do;
		if SUB_STRUC -> symbol.son = null then do;
		     call record_intersection;
		     call pop;
		end;
		else
		     call push;
	     end;
	     else
		call pop;
	end;

/*
 * Push implicit stacks
 */
push:
     procedure ();

dcl      (bna, by_name_ref) ptr;

	SUB_STRUC = SUB_STRUC -> symbol.son;

	bna = get_by_name_agg ();

	bna -> by_name_agg.token = SUB_STRUC -> symbol.token;
	bna -> by_name_agg.father = CUR_BNA_NODE;
	CUR_BNA_NODE -> by_name_agg.son = bna;

	CUR_BNA_NODE = bna;

	by_name_ref = pl1_stat_$by_name_ref_list;
	do while (by_name_ref ^= null);
	     by_name_ref -> list.element (1) = by_name_ref -> list.element (1) -> symbol.son;
	     by_name_ref = by_name_ref -> list.element (2);
	end;

     end push;

/*
 * Pop implicit stacks until a brother or the root is found;
 * delete nodes from the by name aggregate tree where necessary
 */
pop:
     procedure ();

dcl      (bna, by_name_ref) ptr;

	if SUB_STRUC -> symbol.brother = null then
	     do while (SUB_STRUC -> symbol.brother = null);
		SUB_STRUC = SUB_STRUC -> symbol.father;
		bna = CUR_BNA_NODE;
		CUR_BNA_NODE = CUR_BNA_NODE -> by_name_agg.father;

		if bna -> by_name_agg.ok_to_free then do;

		     if bna -> by_name_agg.left_brother ^= null then
			bna -> by_name_agg.left_brother -> by_name_agg.right_brother = null;
		     else
			bna -> by_name_agg.father -> by_name_agg.son = null;

		     call free_by_name_agg (bna);
		end;

		if SUB_STRUC = root then do;
		     TRAVERSE_STRUCTURE = FALSE;
		     return;
		end;

		by_name_ref = pl1_stat_$by_name_ref_list;
		do while (by_name_ref ^= null);
		     by_name_ref -> list.element (1) = by_name_ref -> list.element (1) -> symbol.father;
		     by_name_ref = by_name_ref -> list.element (2);
		end;
	     end;

	SUB_STRUC = SUB_STRUC -> symbol.brother;

	if CUR_BNA_NODE -> by_name_agg.ok_to_free then
	     bna = CUR_BNA_NODE;
	else do;
	     bna = get_by_name_agg ();
	     bna -> by_name_agg.left_brother = CUR_BNA_NODE;
	     CUR_BNA_NODE -> by_name_agg.right_brother = bna;
	     bna -> by_name_agg.father = CUR_BNA_NODE -> by_name_agg.father;
	     CUR_BNA_NODE = bna;
	end;

	CUR_BNA_NODE -> by_name_agg.token = SUB_STRUC -> symbol.token;

	by_name_ref = pl1_stat_$by_name_ref_list;
	do while (by_name_ref ^= null);
	     by_name_ref -> list.element (1) = by_name_ref -> list.element (1) -> symbol.father -> symbol.son;
	     by_name_ref = by_name_ref -> list.element (2);
	end;

	return;

     end pop;

/*
 * Do symbol nodes with identical identifiers exist in all structures
 * being traversed
 */
matching_ids_exist:
     procedure (symbol_ptr) returns (bit (1) aligned);

dcl      symbol_ptr ptr parameter;

dcl      (token_ptr, to_be_matched_ptr, to_be_fixed_ptr, sym_to_be_matched) ptr;
dcl      match bit (1) aligned;

	token_ptr = symbol_ptr -> symbol.token;

/* Assume that a match is possible */

	match = TRUE;

/* Now traverse list of symbol node pointers matching identifiers if possible */

	to_be_matched_ptr = pl1_stat_$by_name_ref_list;
	do while (to_be_matched_ptr ^= null & match);
	     sym_to_be_matched = to_be_matched_ptr -> list.element (1);
	     match = FALSE;
	     do while (sym_to_be_matched ^= null & ^match);

/* Check for matching identifiers */

		if token_ptr = sym_to_be_matched -> symbol.token then
		     match = TRUE;
		else
		     sym_to_be_matched = sym_to_be_matched -> symbol.brother;
	     end;

/* If a match is possible, both symbols must have the same
 * structure attribute.
 */

	     if match then do;
		match = (symbol_ptr -> symbol.structure = sym_to_be_matched -> symbol.structure);

		if match then do;			/* A match occurred, record it */
		     to_be_matched_ptr -> list.element (1) = sym_to_be_matched;
		     to_be_matched_ptr = to_be_matched_ptr -> list.element (2);
		end;
	     end;
	end;

	return (match);

     end matching_ids_exist;

/*
 * Create a by name aggregate node
 */
get_by_name_agg:
     procedure () returns (ptr aligned);

dcl      1 pl1_nodes_template_$by_name_agg_template like by_name_agg aligned external static;
dcl      pl1_stat_$node_uses (32) fixed bin ext static;

dcl      bna ptr aligned;

/* Return a node from the free list if there are any;
 * otherwise allocate one
 */

	if pl1_stat_$by_name_parts_free_list ^= null then do;
	     bna = pl1_stat_$by_name_parts_free_list;
	     pl1_stat_$by_name_parts_free_list = pl1_stat_$by_name_parts_free_list -> by_name_agg.next;
	end;
	else do;
	     allocate by_name_agg set (bna) in (xeq_tree_area);
	     pl1_stat_$node_uses (20) = pl1_stat_$node_uses (20) + 1;
	end;

	bna -> by_name_agg = pl1_nodes_template_$by_name_agg_template;
	return (bna);

     end get_by_name_agg;

/*
 * Record an intersection--successful matchup of names
 */
record_intersection:
     procedure ();

dcl      bna ptr;

	bna = CUR_BNA_NODE;

/* Retain all the nodes in the bna tree from the current node,
 * a leaf, to the root
 */

	do while (bna -> by_name_agg.ok_to_free);
	     bna -> by_name_agg.ok_to_free = FALSE;
	     bna = bna -> by_name_agg.father;
	end;

	ASSIGNMENT_GENERATED = TRUE;

	return;

     end record_intersection;

     end traverse_structures;
%page;
/*
 * Transforms the by name assignment into a form acceptable
 * to expression_semantics
 */
build_assignment:
     procedure ();

dcl      (new_stmnt, new_assignment, LHS_symbol, LHS_reference) ptr;
dcl      targ_idx fixed bin;

	stmnt -> statement.expanded_by_name = TRUE;
	tree -> operator.op_code = assign;

	if NO_OF_TARGETS = 1 then
	     tree -> operator.operand (1) = TARGET_LIST -> list.element (1);
	else do;
	     LHS_symbol = create_symbol (null, null, by_compiler);
	     LHS_symbol -> symbol.temporary = TRUE;
	     LHS_reference = LHS_symbol -> symbol.reference;
	     LHS_reference -> reference.shared = FALSE;
	     LHS_reference -> reference.ref_count = NO_OF_TARGETS + 1;

	     tree -> operator.operand (1) = LHS_reference;

	     new_stmnt = stmnt;
	     do targ_idx = 1 to NO_OF_TARGETS;
		new_stmnt = create_statement (assignment_statement, new_stmnt, null, (stmnt -> statement.prefix));
		new_assignment = create_operator (assign, 2);
		new_assignment -> operand (1) = TARGET_LIST -> list.element (targ_idx);
		new_assignment -> operand (2) = LHS_reference;
		new_stmnt -> statement.generated = TRUE;
		new_stmnt -> statement.expanded_by_name = TRUE;
		new_stmnt -> statement.root = new_assignment;
	     end;
	end;

	return;

     end build_assignment;
%page;
/*
 * Creates list nodes for pl1_stat_$by_name_ref_list
 */
get_by_name_ref:
     procedure () returns (ptr);

dcl      by_name_ref ptr;

/* Recycle a node on the free list if possible */

	if pl1_stat_$by_name_free_list = null then
	     by_name_ref = create_list (2);
	else do;
	     by_name_ref = pl1_stat_$by_name_free_list;
	     pl1_stat_$by_name_free_list = by_name_ref -> list.element (2);
	     by_name_ref -> list.element (*) = null;
	end;

	return (by_name_ref);

     end get_by_name_ref;
%page;
/*
 * Free a by name aggregate node by putting it on the free list
 */
free_by_name_agg:
     procedure (bna);

dcl      bna ptr parameter;

	bna -> by_name_agg.next = pl1_stat_$by_name_parts_free_list;
	pl1_stat_$by_name_parts_free_list = bna;

	return;

     end free_by_name_agg;
%page;
/*
 * Put list nodes on pl1_stat_$by_name_ref_list on
 * pl1_stat_$by_name_free_list
 */
free_by_name_refs:
     procedure ();

dcl      by_name_ref ptr;

/* Find last entry of list and then append the whole list to the free list */

	by_name_ref = pl1_stat_$by_name_ref_list;
	do while (by_name_ref -> list.element (2) ^= null);
	     by_name_ref = by_name_ref -> list.element (2);
	end;

	by_name_ref -> list.element (2) = pl1_stat_$by_name_free_list;
	pl1_stat_$by_name_free_list = pl1_stat_$by_name_ref_list;
	pl1_stat_$by_name_ref_list = null;

	return;

     end free_by_name_refs;
%page;
/*
 * Free the nodes of the by_name_parts tree during a postorder traversal
 */
free_by_name_parts_tree:
     procedure ();

/* global variables (automatic) */

dcl      CUR_BNA ptr;
dcl      TRAVERSE_TREE bit (1);

	CUR_BNA = pl1_stat_$by_name_parts_tree;

/* Tree has no subtrees */

	if CUR_BNA -> by_name_agg.son = null then do;
	     call free_by_name_agg (CUR_BNA);
	     pl1_stat_$by_name_parts_tree = null;
	     return;
	end;

/* Tree has at least 1 subtree */

	TRAVERSE_TREE = TRUE;

	do while (TRAVERSE_TREE);
	     if CUR_BNA -> by_name_agg.son = null then
		call pop;
	     else
		CUR_BNA = CUR_BNA -> by_name_agg.son;
	end;

	return;

/*
 * Pop implicit stacks freeing nodes as they are encountered
 */
pop:
     procedure ();

dcl      bna ptr;

	if CUR_BNA -> by_name_agg.right_brother = null then
	     do while (CUR_BNA -> by_name_agg.right_brother = null);
		bna = CUR_BNA;
		CUR_BNA = CUR_BNA -> by_name_agg.father;
		call free_by_name_agg (bna);

		if CUR_BNA = pl1_stat_$by_name_parts_tree then do;
		     call free_by_name_agg (CUR_BNA);
		     pl1_stat_$by_name_parts_tree = null;
		     TRAVERSE_TREE = FALSE;
		     return;
		end;

	     end;

	bna = CUR_BNA;
	CUR_BNA = CUR_BNA -> by_name_agg.right_brother;
	call free_by_name_agg (bna);

	return;

     end pop;

     end free_by_name_parts_tree;
%page;
%include by_name_agg;
%page;
%include declare_type;
%page;
%include list;
%page;
%include nodes;
%page;
%include op_codes;
%page;
%include operator;
%page;
%include pl1_tree_areas;
%page;
%include reference;
%page;
%include semant;
%page;
%include semantic_bits;
%page;
%include symbol;
%page;
%include statement_types;
%page;
%include statement;

     end expand_by_name;






		    expand_infix.pl1                07/31/89  1431.7r w 07/31/89  1338.5       81324



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


/*	Modified:	781219 by RAB to fix 1806 (ERROR 316 for star_extent exprs)	*/
/*	Modified: 17 Mar 1980 by PCK to implement by name assignment	*/

expand_infix: proc(blk,stmnt,tree,context) returns(ptr);

dcl	(blk,stmnt,tree,a,b,p,r,first) ptr;
dcl	loop5 ptr init(null);
dcl	(i,n,k) fixed bin(15);
dcl	opcode bit(9) aligned;

dcl	pl1_stat_$LHS ptr ext static;

dcl	(null,string,substr) builtin;

	n = tree->operator.number;
	this_context = "0"b;
	def_this_context.by_name_assignment = def_context.by_name_assignment;
	a = tree->operand(n-1);
	b = tree->operand(n);
	if n=3 then first = tree->operand(1); else first = null;
	opcode = tree->op_code;

	if a->node.type = reference_node
	then	a = process(a,this_context);

	if b->node.type = reference_node
	then	b = process(b,this_context);

	if a->node.type=operator_node
	then	if a->op_code^=loop
		&  a->op_code^=join
		then	if a->op_code ^= std_call 
			then	a = simplify_scalar(a);
			else	a = process(a,"0"b);

	if b->node.type=operator_node
	then	if b->op_code^=loop
		&  b->op_code^=join
		then	if b->op_code ^= std_call
			then	b = simplify_scalar(b);
			else	b = process(b,"0"b);

	if a->node.type ^= operator_node
	then do;
		k = 2;
		r = walk(b);
		goto ret;
	end;

	if b->node.type ^= operator_node
	then do;
		k = 3;
		r = walk(a);
		goto ret;
	end;

			/*   Both operands are operators, now check for promotions from structures to
			     arrays of structures   */

	if a->op_code=loop & b->op_code=join
	then do;
		do p = a repeat p->operand(1) while(p->operand(1)->op_code=loop);
		end;

		p->operand(1) = match((p->operand(1)),b);

		r = a;
		goto ret;
	end;

	if a->op_code=join & b->op_code=loop
	then do;
		do p = b repeat p->operand(1) while(p->operand(1)->op_code=loop);
		end;

		p->operand(1) = match(a,(p->operand(1)));

		r = b;
		goto ret;
	end;

	r = match(a,b);

ret:
	if r->op_code=loop
	&  loop5^=null
	then do;
		do p = loop5 repeat p->element(1) while(p^=null);
			p->element(2) = share_expression((p->element(2)));
		end;

		if r->operand(5)=null
		then	r->operand(5) = loop5;
		else do;
			do p = r->operand(5) repeat p->element(1) while(p->element(1)^=null);
			end;

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

	return(r);

process: proc(p,context) returns(ptr);

dcl	context bit(36) aligned;
dcl	(p,q) ptr;

	if p -> node.type = reference_node
	then	q = p;
	else	q = p->operand(1);

	if q->reference.symbol->symbol.structure
	|  q->reference.array_ref
	then	return(expand_primitive(blk,stmnt,q,context));
	else	return(simplify_scalar(p));

	end process;

/* subroutine to walk down the loop and join ops and create infix operators
   to incorporate a  scalar expression into an aggregate expression.  */

walk: proc(e) returns(ptr);

dcl	e ptr;
dcl	i fixed bin(15);

	if e->node.type = operator_node
	then	if e->op_code = loop
		then do;
			e->operand(1) = walk((e->operand(1)));
			return(e);
		end;

		else	if e->op_code = join
			then do;
				do i = 1 to e->operator.number;
					e->operand(i) = walk((e->operand(i)));
				end;
				return(e);
			end;

	if k=2
	then	return(match(share_expression(a),e));
	else	return(match(e,share_expression(b)));

	end walk;

/* subroutine to match to aggregate expressions and combine them.  */

match: proc(aa,bb) returns(ptr);

dcl	(a,b,aa,bb,p) ptr;
dcl	i fixed bin(15);

	a = aa;
	b = bb;

	if a->node.type ^= operator_node then go to scalar_a;
	if a->op_code ^= loop & a->op_code ^= join then go to scalar_a;
	if b->node.type ^= operator_node then go to scalar_b;
	if b->op_code ^= loop & b->op_code ^= join then go to scalar_b;

	if a->op_code^=b->op_code then goto fail;

	if a->op_code=loop
	then do;			/* both operands are arrays.  */
		if ^compare_expression((a->operand(4)),(b->operand(4)))
		then do;
			if  a->operand(4)->node.type=reference_node
			then if  a->operand(4)->reference.symbol->symbol.constant
			then if  b->operand(4)->node.type=reference_node
			then if  b->operand(4)->reference.symbol->symbol.constant
			then	goto fail;

			p = create_operator(bound_ck,4);
			p->operator.processed = "1"b;
			p->operand(1)=declare_temporary(integer_type,default_fix_bin_p,0,null);
			p->operand(2) = a->operand(4);
			p->operand(3) = b->operand(4);
			p->operand(4) = share_expression((p->operand(3)));
			a->operand(4) = p;
		end;

		a->operand(1) = match((a->operand(1)),(b->operand(1)));

		if b->operand(5)^=null
		then	if a->operand(5)=null
			then	a->operand(5) = b->operand(5);
			else do;
				do p = a->operand(5) repeat p->element(1) while(p->element(1)^=null);
				end;

				p->element(1) = b->operand(5);
			end;

		return(a);
	end;

	if a->operator.number ^= b->operator.number then go to fail;

	do i = 1 to a->operator.number;
		a->operand(i) = match((a->operand(i)),(b->operand(i)));
	end;

	return(a);

scalar_a:
	if b->node.type = operator_node
	then	if b->op_code = loop | b->op_code = join
		then	go to fail;

	go to combine;

scalar_b:
	if a->node.type = operator_node
	then	if a->op_code = loop | a->op_code = join
		then	go to fail;

combine:
	p = create_operator(opcode,n);
	p->operand(n-1) = a;
	p->operand(n)   = b;
			/*   May be called from builtin   */
	if first^=null
	then	p->operand(1) = first;
	else	p = operator_semantics(blk,stmnt,p,"0"b);

	return(p);

fail:
	call semantic_translator$abort(79,null);

	end match;

/* subroutine to remove a scalar sub-expression so that it is evaluated only once.   */

simplify_scalar:	proc(pp) returns(ptr);

dcl	(e,pp,p,q,st,sy,LHS_sy,r,ret_ptr) ptr;

	p = pp;

	if p->node.type=operator_node
	then do;
				/*   the std_call operator may have already been extracted   */
		if stmnt->statement.back->statement.root=p
		then	st = stmnt;
		else	st = create_statement(assignment_statement,(stmnt->statement.back),
				null,(stmnt->statement.prefix));


		st->statement.root = p;

		/* new symbol necessary to prevent optimizer's losing
		   temporary due to commoning of operator */

		q = create_symbol(blk,null,by_compiler);
		r = q->symbol.reference;

		r->reference = p->operand(1)->reference;
		q->symbol = r->reference.symbol->symbol;
		q->symbol.next = null;
		q->symbol.reference = r;
		r->reference.symbol = q;

		r->reference.shared = "0"b;
		r->reference.ref_count = 1;

		if p->op_code=std_call
		then do;
			r->reference.ref_count = 2;

			e = p->operand(3)->operand(2);
			e->element(e->list.number) = r;
		end;

		p->operand(1) = r;

		ret_ptr = r;

		goto ret1;
	end;

	if p->node.type = label_node
	then	return(p);

	if p->reference.offset^=null
	|  p->reference.length^=null
	|  p->reference.qualifier^=null
	then	goto create;

	if p->reference.symbol->node.type = label_node
	then	goto ret0;

	if p->reference.symbol->symbol.constant
	then	goto ret0;

	if p->reference.symbol->symbol.temporary
	then do;
		p->reference.ref_count = p->reference.ref_count - 1;
		ret_ptr = p;
		go to ret1;
	end;

	LHS_sy = pl1_stat_$LHS;
	if LHS_sy=null
	then	goto ret0;

	sy = p->reference.symbol;

	if LHS_sy->symbol.based
	|  LHS_sy->symbol.defined
	|  LHS_sy->symbol.parameter
	then do;
		if sy->symbol.member
		&  LHS_sy->symbol.structure
		then	goto create;

		if string(sy->symbol.attributes.data_type)=string(LHS_sy->symbol.attributes.data_type)
		then	goto create;
		else	goto ret0;
	end;

	if sy->symbol.dimensioned
	&  sy=LHS_sy
	then	goto create;

	if sy->symbol.member
	then do q = sy repeat q->symbol.father while(q^=null);
		if q=LHS_sy
		then	goto create;
	end;

	goto ret0;

create:
	st = create_statement(assignment_statement,(stmnt->statement.back),null,(stmnt->statement.prefix));
	r = create_operator(assign,2);
	sy = create_symbol(null,null,by_compiler);
	sy->symbol.temporary = "1"b;
	sy->symbol.reference->reference.shared = "0"b;
	sy->symbol.reference->reference.ref_count = 1;

	r->operand(1) = sy->symbol.reference;
	r->operand(2) = p;

	st->statement.root = expression_semantics(blk,st,r,"0"b);

	ret_ptr = r->operand(1);

ret1:
	/* this keeps temps from being released until after loop ends */

	if loop5=null
	then do;
		loop5 = create_list(2);
		loop5->element(2) = ret_ptr;
	end;
	else do;
		q = create_list(2);
		q->element(2) = ret_ptr;
		q->element(1) = loop5;
		loop5 = q;
	end;

	return(ret_ptr);

ret0:
	if ^ p -> reference.shared
	then	p->reference.ref_count = p->reference.ref_count - 1;

	return(p);

	end simplify_scalar;

%include semant;
%include declare_type;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include system;

	end expand_infix;




		    expand_initial.pl1              07/31/89  1431.7r w 07/31/89  1338.5      152406



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


/* Modified Dec 1978 by David Spector for new xref 'set' format */
/* Modified 79/04/19 by Peter Krupp to implement 4-bit decimal */

expand_initial: proc(sp,st,locator);

dcl	(s,sp,st,blk,p,q,lab,swt,increase,subscript,total_size,nest,allocate,one,ar,r,a,b,v,off) ptr;
dcl	(d,locator,stat) ptr;
dcl	(c_total_size,coff) fixed bin(31);
dcl	(n,i,total_elements) fixed bin(15);

dcl	units fixed bin(3);
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	(constant_extents,temporary_required) bit(1) aligned;

dcl	fab_image aligned bit(length(unspec(fab))) based(addr(fab));
dcl	1 fab,
	2 bits,
	3 fill1 bit(27),
	3 internal bit(1),
	3 fill2 bit(8),
	2 title char(32),
	2 line_size fixed bin(15),
	2 page_size fixed bin(15),
	2 buffer_size fixed bin(15);

dcl	(null,string,fixed,length,unspec,addr,binary,bit) builtin;

	s = sp;
	stat = st;
	one = declare_constant$integer(1);
	blk = s->symbol.block_node;
	s->symbol.allocate  ,
	s->symbol.set = "1"b;

	if s->symbol.constant
	then do;
		q = create_operator(jump_if_eq,3);
		q->operand(1),lab = create_label(blk,null,by_compiler);
		q->operand(2),swt = declare_integer(blk);
		q->operand(3) = one;

		swt->reference.symbol->symbol.static,
		swt->reference.symbol->symbol.internal,
		swt->reference.symbol->symbol.allocate = "1"b;
		swt->reference.symbol->symbol.auto = "0"b;
		/* int static is assumed to be initialized to zero */

		p = make_statement(if_statement,q);

		/* create an internal static file state block of 290 words and set the "general"
		pointer of the file constant's symbol node to point to the symbol node of the
		file state block.  */
			
		p = create_symbol(blk,create_token(s->symbol.token->token.string||".fsb"
			,identifier),by_compiler);
		p->symbol.c_dcl_size = 290;
		p->symbol.storage_block,p->symbol.static = "1"b;
		p->symbol.external = s->symbol.external;
		p->symbol.internal = s->symbol.internal;
		p->symbol.allocate = "1"b;
		call get_size(p);
		p->symbol.boundary = mod2_;
		s->symbol.general = p;
		
		/* create a file attribute block that contains the initial attribute set used when
		opening the file control block.    */
		
		string(fab.bits) = "0010"b||string(s->symbol.file_attributes);
				/* "001"b marks the file as version 2 */
		fab.internal = s->symbol.internal;
		fab.title = s->symbol.token->token.string;
		fab.line_size,fab.page_size,fab.buffer_size = 0;
		q = declare_constant$bit(fab_image);
		p->symbol.general = q->reference.symbol;
		
		
		/* generate prologue to assign the addr(fab) to the 1st pointer
		of the file constant, and the addr(fsb) to the 2nd pointer.  */
		
		a = create_operator(addr_fun,2);
		a->operand(2) = q;
		q = make_statement(assignment_statement,assignf((s->symbol.reference),a));
		a = create_operator(addr_fun,2);
		a->operand(2) = p->symbol.reference;
		q = copy_expression(s->symbol.reference);
		q->reference.shared = "0"b;
		q->reference.ref_count = 1;
		q->reference.c_offset = 2;
		q->reference.units = word_;
		q = make_statement(assignment_statement,assignf(q,a));

		p = make_statement(assignment_statement,assignf(swt,one));
		p = make_statement(null_statement,null);
		p->statement.labels = create_list(2);
		p->statement.labels->element(2) = lab;
		lab->label.statement = p;
		return;
	end;

	if s->symbol.area
	then do;
		if s->symbol.based | s->symbol.controlled
		then do;
			p  ,
			stat = create_statement(assignment_statement,stat,null,(stat->statement.prefix));
			p->statement.generated = "1"b;
		end;
		else	p = create_statement$prologue(assignment_statement,blk,null,(blk->block.prefix));

		p->statement.root  ,
		q = create_operator(assign,2);

		r = create_reference((s->symbol.token));

		if locator^=null
		then	r->reference.qualifier = copy_expression((locator));
	
		if s->symbol.father^=null
		then	call link_father();

		q->operand(1) = r;
		q->operand(2) = create_reference(create_token("empty",identifier));

		q->operand(2)->reference.offset = create_list(0);

		return;
	end;

	if s->symbol.initialed
	then do;
		q = s->symbol.initial;
		if s->symbol.dimensioned
		then	goto array_initialization;
		else do;
			r = create_reference((s->symbol.token));
			r->reference.qualifier = copy_expression((locator));

			if s->symbol.father^=null
			then	call link_father();

unravel:			if q->element(3)^=null
			then	call semantic_translator$abort(442,s);

			if q->element(1)->node.type^=token_node
			then	call semantic_translator$abort(442,s);

			if q->element(1)->token.type^=dec_integer
			then	call semantic_translator$abort(442,s);

			if token_to_binary((q->element(1)))^=1
			then	call semantic_translator$abort(442,s);

			if q->element(2) ^= null
			then	if q->element(2)->node.type = list_node
			then do;
				q = q->element(2);
				go to unravel;
			end;

			p = make_statement(assignment_statement,assignf(r,(q->element(2))));
		end;
	end;

	return;

/* prepare for array initialization by getting a subscript, code to increment the subscript,
   and a reference to an array element.	*/

array_initialization:
	subscript = declare_integer(blk);
	increase = assignf(subscript,addf(subscript,one));
	r = create_reference(s);
	r->reference = s->symbol.reference->reference;
	r->reference.array_ref = "0"b;
	r->reference.qualifier = copy_expression((locator));
	r->reference.symbol = s->symbol.token;

	if s->symbol.father^=null
	then	call link_father();

	a = s->symbol.array;
	n = a->array.number_of_dimensions;
	r->reference.offset = create_list(n);

	total_elements = 0;
	constant_extents = "1"b;

/* insure that the high and low bounds are available in the object program.	*/

	do b = a->array.bounds repeat b->bound.next while(b ^= null);
		if b->bound.lower=null
		then	b->bound.lower = declare_constant$integer((b->bound.c_lower));
		else	constant_extents = "0"b;

		if b->bound.upper=null
		then	b->bound.upper = declare_constant$integer((b->bound.c_upper));
		else	constant_extents = "0"b;

		if constant_extents
		then	if total_elements=0
			then	total_elements = b->bound.c_upper-b->bound.c_lower+1;
			else	total_elements = total_elements * (b->bound.c_upper-b->bound.c_lower+1);
	end;

/* if this is a vector call assign_initial to create assignments from the initial attribute
   to elements of the vector.  The number of elements  in the vector is assumed to be
   equal to or greater than the number of elements in the initial attribute. */

	if n = 1
	then do;
		if a->array.bounds->bound.c_lower = 1
		then	p = declare_constant$integer(0);
		else	p = subf((a->array.bounds->bound.lower),one);

		p = make_statement(assignment_statement,assignf(subscript,p));
		r->reference.offset->element(1) = subscript;
		p = make_statement(assignment_statement,assign_initial(q,null,0,"1"b,temporary_required));

		return;
	end;

/* Create a vector whose elements have the same attributes as the elements of
   the array.  The initial attribute values are assigned to the vector using
   the procedure assign_initial.  The vector is made large enough to
   hold all the values given in the initial attribute.	*/

	p=make_statement(assignment_statement,assignf(subscript,declare_constant$integer(0)));
	allocate = make_statement(null_statement,null);
	p = create_symbol(blk,null,by_compiler);
	p->symbol.auto = "1"b;
	string(p->symbol.data_type) = string(s->symbol.data_type);
	string(p->symbol.misc_attributes) = string(s->symbol.misc_attributes);
	p->symbol.member = "0"b;
	p->symbol.c_dcl_size = s->symbol.c_dcl_size;
	p->symbol.scale = s->symbol.scale;
	p->symbol.dcl_size = s->symbol.dcl_size;

	unspec (p->symbol.pix) = unspec (s->symbol.pix);
	if s -> symbol.picture then p -> symbol.general = s -> symbol.general;

	if p->symbol.varying
	then	p->symbol.reference->reference.varying_ref = "1"b;
	else do;
		p->symbol.reference->reference.c_length = s->symbol.reference->reference.c_length;
		p->symbol.reference->reference.length = s->symbol.reference->reference.length;
	end;

	p->symbol.boundary = s->symbol.boundary;

	v  ,
	p->symbol.array = create_array();
	v->array.number_of_dimensions = 1;
	v->array.own_number_of_dimensions = 1;
	v->array.virtual_origin  ,
	v->array.element_size = a->array.element_size;
	v->array.c_virtual_origin  ,
	v->array.c_element_size = a->array.c_element_size;
	v->array.c_element_size_bits = a->array.c_element_size_bits;
	v->array.offset_units = a->array.offset_units;

	b  ,
	v->array.bounds = create_bound();
	b->bound.c_lower = 1;
	b->bound.c_multiplier = v->array.c_element_size;
	b->bound.multiplier = v->array.element_size;
	if b->bound.multiplier = null
	then	b->bound.multiplier = declare_constant$integer((b->bound.c_multiplier));

	total_size = null;
	c_total_size = 0;
	ar = r;

	r = create_reference((p->symbol.token));
	r->reference.offset = create_list(1);
	r->reference.offset->element(1) = subscript;
	q = make_statement(assignment_statement,assign_initial(q,total_size,c_total_size,"1"b,temporary_required));

	if temporary_required
	then	if total_size=null
		then do;
			total_size = declare_constant$integer(c_total_size);
			c_total_size = 0;
		end;


/* set the upper bound of the vector to the number of items in the initial attribute.  */

	b->bound.upper = total_size;
	b->bound.c_upper = c_total_size;

/* set the size of the vector to the number of values found in the initial attribute
   times the size of an element of the vector.	*/

	if total_size = null
	then	if a->array.element_size = null
		then	c_total_size = c_total_size*a->array.c_element_size;
		else	total_size = multf((a->array.element_size),declare_constant$integer(c_total_size));
	else	if a->array.element_size = null
		then	if a->array.c_element_size ^= 1
			then	total_size = multf(total_size,declare_constant$integer((a->array.c_element_size)));
			else;
		else	total_size = multf(total_size,(a->array.element_size));

/* Change total_size and c_total_size to be in units of words */

	units = v->array.offset_units;
	if units < word_
	then do;
		if total_size ^= null
		then do;
			q = create_operator(optable(units),2);
			q->operand(2) = total_size;
			total_size = q;
		end;
		else	c_total_size = divide(c_total_size+round(units)-1,round(units),31,0);
	end;

	p->symbol.word_size = total_size;
	p->symbol.c_word_size = c_total_size;

	if total_size ^= null
	then do;
		p->symbol.exp_extents = "1"b;
		q = create_operator(allot_auto,2);
		p->symbol.reference->reference.qualifier  ,
		q->operand(1) = declare_pointer(blk);
		q->operand(2) = total_size;
		allocate->statement.root = copy_expression((q));
		allocate->statement.statement_type = assignment_statement;
	end;

/* create code to copy the elements of the vector into the array.  The bounds of the
   array are used to control the loop.  The number of elements in the vector is
   assumed to equal or exceed the number of elements in the array.	*/

	q = make_statement(assignment_statement,assignf(subscript,declare_constant$integer(0)));
	nest = create_operator(join,2);
	nest->operand(1) = increase;
	nest->operand(2) = assignf(ar,r);

	i = 0;

	do b = a->array.bounds repeat b->bound.next while(b^=null);
		i = i+1;
		q = create_operator(loop,5);
		q->operand(1) = nest;
		q->operand(2)  ,
		ar->reference.offset->element(i) = declare_integer(blk);
		q->operand(3) = b->bound.lower;
		q->operand(4) = b->bound.upper;
		nest = q;
	end;

	q = make_statement(assignment_statement,nest);

	return;

/* subroutine to assign the values of an initial attribute to a vector.	*/

assign_initial: proc(init,count,c_count,check_range,temporary_reqd) returns(ptr);

dcl	(init,count,numb,p,v,t,q,q1) ptr;
dcl	stack(1024) ptr unal;
dcl	(i,k,l,items,limit) fixed bin(15),
	n fixed bin(15) init(0);
dcl	(c_count,c_numb,case) fixed bin(31);

dcl	(check_range,temporary_reqd) bit(1) aligned;
dcl	hbound builtin;

	limit = divide(hbound(stack,1),2,15,0);
	items, l = 0;
	temporary_reqd = "0"b;

	do p = init repeat p->element(3) while(p^=null);
		t = p->element(1);		/* repetition factor */
		v = p->element(2);		/* value */

		n = 0;
		case = 1;

		if t->node.type = token_node
		then	if t->token.type = dec_integer
			then do;
				n = token_to_binary(t);
				if n < 6 then case = 0;
			end;
			else	check_range = "0"b;
		else	check_range = "0"b;

		if v=null
		then	;
		else	if v->node.type=list_node
			then	case = 2;

		go to action(case);

action(0):
		/* optimized special case */

		if count=null
		then	c_count = c_count+n;
		else	count = addf(count,declare_constant$integer((n)));

		do k = 1 to n;
			items = items + 1;
			l = l+2;
			if items > limit
			then	call semantic_translator$abort(264,s);

			stack(l-1) = increase;
			stack(l) = assignf(r,v);
		end;

		go to next;

action(1):
		/* normal case */

		temporary_reqd = "1"b;

		q = assignf(r,v);

		if count=null
		&  n^=0
		then	c_count = c_count+n;
		else	if count=null
			then	count = t;
			else	count = addf(count,t);

		q1 = create_operator(join,2);
		q1->operand(1) = increase;
		q1->operand(2) = q;
		q = create_operator(loop,5);
		q->operand(1) = q1;
		q->operand(2) = declare_integer(blk);
		q->operand(3) = one;
		q->operand(4) = t;

		items = items + 1;
		l = l+1;
		if items > limit
		then	call semantic_translator$abort(264,s);
		stack(l) = q;

		goto next;

action(2):
		/* difficult case -- initial value is a list */

		temporary_reqd = "1"b;

		numb = null;
		c_numb = 0;
		q = assign_initial(v,numb,c_numb,"0"b,"0"b);

		if t->node.type=token_node
		then	if t->token.type=dec_integer
			then	n = token_to_binary(t);
			else	check_range = "0"b;
		else	check_range = "0"b;

		if n^=0
		&  numb=null
		then	c_numb = c_numb*n;
		else	if numb=null
			then	numb=multf(declare_constant$integer(c_numb),t);
			else	numb = multf(numb,t);

		if count=null
		&  numb=null
		then	c_count = c_count+c_numb;
		else	if count=null
			then	if c_count=0
				then	count = numb;
				else do;
					count = addf(declare_constant$integer(c_count),numb);
					c_count = 0;
				end;
			else	if c_numb=0
				then	count = addf(count,numb);
				else	count = addf(count,declare_constant$integer(c_numb));

		q1 = create_operator(loop,5);
		q1->operand(1) = q;
		q1->operand(2) = declare_integer(blk);
		q1->operand(3) = one;
		q1->operand(4) = t;

		items = items + 1;
		l = l+1;
		if items > limit
		then	call semantic_translator$abort(264,s);
		stack(l) = q1;

next:
	end;

/* create a join of everything generated by this invocation of assign_initial. */

	q = create_operator(join,l);

	do i = 1 to l;
		q->operand(i) = stack(i);
	end;

	if check_range
	then	if constant_extents
		then	if count=null
			&  c_count^=total_elements
			then	call semantic_translator$abort(292,s);

	return(q);

	end assign_initial;

/* subroutine to make an assignment or arithmetic operators. */

assignf: proc(v,e) returns(ptr);

dcl	(v,e,q) ptr;
dcl	opcode bit(9) aligned;

	if e=null
	then	q = create_operator(nop,0);
	else do;
		q = create_operator(assign,2);
		q->operand(1) = v;
		q->operand(2) = e;
	end;

	go to exit;

addf: entry(v,e) returns(ptr);

	opcode = add;
	go to common;

subf: entry(v,e) returns(ptr);

	opcode = sub;
	go to common;

multf: entry(v,e) returns(ptr);

	opcode = mult;

common:
	q = create_operator(opcode,3);
	q->operand(2) = v;
	q->operand(3) = e;

exit:
	return(q);

	end;

/* subroutine to make a statement in the prologue or main code sequence. */

make_statement: proc(type,e) returns(ptr);

dcl	(e,p) ptr;
dcl	type bit(9) aligned;

	if s->symbol.based | s->symbol.controlled
	then do;
		p  ,
		stat = create_statement(type,stat,null,(stat->statement.prefix));
		p->statement.root = copy_expression((e));
		p->statement.generated = "1"b;
	end;
	else do;
		p = create_statement$prologue(type,blk,null,(blk->block.prefix));
		p->statement.root = copy_expression((e));
	end;

	return(p);

	end;

link_father:	proc();

dcl	(i,count) fixed bin(15);

dcl	(p,q) ptr;

	count = 0;

	do p = s->symbol.father repeat p->symbol.father while(p^=null);
		count = count+1;
	end;

	r->reference.length  ,
	q = create_list(count);
	p = s->symbol.father;

	do i=1 to count;
		q->element(i) = p->symbol.token;
		p = p->symbol.father;
	end;

	end link_father;

%include semant;
%include symbol;
%include boundary;
%include system;
%include label;
%include reference;
%include token;
%include token_types;
%include declare_type;
%include statement;
%include block;
%include statement_types;
%include op_codes;
%include operator;
%include array;
%include list;
%include nodes;

	end expand_initial;




		    expand_prefix.pl1               07/31/89  1431.7r w 07/31/89  1338.5       17460



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


expand_prefix: proc(blk,stmnt,tree,context) returns(ptr);

dcl	(blk,stmnt,tree,a) ptr;
dcl	opcode bit(9) aligned;
dcl	n fixed bin(15);
dcl	(string,null) builtin;

%include semant;

%include operator;
%include semantic_bits;

%include op_codes;

%include nodes;
			/*      */

	this_context = "0"b;
	def_this_context.by_name_assignment = def_context.by_name_assignment;

	a = tree->operator.operand(2);
	opcode = tree->operator.op_code;
	if a->node.type = reference_node
	then a = expand_primitive(blk,stmnt,a,this_context);
	else	if	a->node.type = operator_node
		then	if a->operator.op_code = std_call
			then a = expand_primitive(blk,stmnt,(a->operator.operand(1)),"0"b);
	call apply_prefix(a);
	return(a);

/* subroutine to create scalar operators applied to each scalar component of the aggregate.  */

apply_prefix: proc(e);

dcl	(p,e,t) ptr;
dcl	n fixed bin(15);

	if e->node.type = operator_node
		then do;
			if e->operator.op_code = loop
				then do;
					t = e->operand(1);
					call apply_prefix(t);
					e->operand(1) = t;
					return;
				     end;
			if e->operator.op_code = join
				then do;
					do n = 1 to e->operator.number;
					t = e->operand(n);
					call apply_prefix(t);
					e->operand(n) = t;
					end;
					return;
				     end;
		     end;
	p = create_operator(opcode,2);
	p->operator.operand(2) = e;
	e = p;
	e = operator_semantics(blk,stmnt,e,"0"b);
	return;
	end apply_prefix;

	end expand_prefix;




		    expand_primitive.pl1            07/31/89  1431.7r w 07/31/89  1338.5      149526



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




/****^  HISTORY COMMENTS:
  1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), audit(86-07-16,Mabey),
     install(86-07-28,MR12.0-1105):
     Bug fixes for the MR12.0 release of the compiler.
                                                   END HISTORY COMMENTS */


/*	Modified:	781219 by RAB to fix 1806 (star_extent exprs get ERROR 316)	*/
/*	Modified: 17 Mar 1980 by PCK to implement by name assignment */
/*		Also fixes 1878				 */
/*	Modified: 2 April 1980 by PCK to increase implementation limit
		of the number of substructures that may immediately
		be contained in a structure from a minimum of 256 to
		a minimum of 32767 */
/*	Modified: 7 June 1985 by MM to fix 2109 (by name assignments that
		generate temporaries aren't handled correctly.) */

/* format: style3 */
expand_primitive:
     proc (blk, stmnt, input_tree, context) returns (ptr);

dcl	(blk, stmnt, tree, input_tree, one, subs, loops, last, qual, p, a, b, s, symbols_block, bna)
			ptr;
dcl	(i, given, ndims, n, stars_given)
			fixed bin (15);
dcl	pds		bit (1) aligned;
dcl	pl1_stat_$eis_mode	bit (1) aligned ext static;
dcl	pl1_stat_$by_name_parts_tree
			ptr aligned ext static;

dcl	null		builtin;

	if input_tree -> node.type = operator_node
	then return (input_tree);

/* generates a LOOP/JOIN tree processed by subscripter and by expression_semantics */

	last, loops = null;
	this_context = "0"b;
	one = declare_constant$integer (1);
	stars_given, n = 0;

	if def_context.by_name_assignment
	then bna = pl1_stat_$by_name_parts_tree;
	else bna = null;

	s = input_tree -> reference.symbol;

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

	if s -> symbol.reference = input_tree | input_tree -> reference.array_ref
	then do;
		tree = create_reference ((input_tree -> reference.symbol));
		tree -> reference = input_tree -> reference;
	     end;
	else tree = input_tree;

/*  handling the case of unsubscripted array reference */

	if s -> node.type = label_node
	then do;
		b = create_bound ();
		b -> bound.c_lower = s -> label.low_bound;
		b -> bound.c_upper = s -> label.high_bound;
		b -> bound.c_multiplier = 1;
		subs = create_list (1);
		subs -> list.element (1) = create_token ("*", asterisk);
		given = 1;
	     end;
	else do;
		qual = tree -> reference.qualifier;

		subs = tree -> reference.offset;

		if subs = null
		then given = 0;
		else if subs -> node.type ^= list_node
		then do;
			given = 0;		/*   simplify-offset may have already split the
					     offset into offset and c_offset with disastrous
					     results, therefore, undo the work   */
			pds = tree -> reference.put_data_sw;
			tree -> reference = tree -> reference.symbol -> symbol.reference -> reference;
			tree -> reference.put_data_sw = pds;
			tree -> reference.shared = "0"b;
			tree -> reference.ref_count = 1;
			subs = null;
		     end;
		else do;
			subs = copy_expression ((subs));
						/* preserve original subs */
			given = subs -> list.number;
		     end;

		a = s -> symbol.array;

		if a ^= null
		then ndims = a -> array.number_of_dimensions;
		else ndims = 0;

/*   the case of an unsubscripted structure or a scalar   */
		if given = 0 & ndims = 0
		then return (expander (tree, bna));

		if ndims ^= given & given ^= 0
		then call semantic_translator$abort (81, s);

		b = a -> array.bounds;
		tree -> reference.offset = copy_expression (s -> symbol.reference -> reference.offset);
		if tree -> reference.length ^= null
		then tree -> reference.length = copy_expression (tree -> reference.length);
	     end;

/*   This reference is (or will be) a fully subscripted array reference.  
Implied asterisks will be added.  */

	if given = 0
	then do;
		n, given = ndims;
		subs = create_list (ndims);

		subs -> list.element (*) = create_token ("*", asterisk);
	     end;
	else do i = 1 to given;			/* count the asterisks */
		p = subs -> list.element (i);

		if p -> node.type = token_node
		then if p -> token.type = asterisk
		     then n = n + 1;
	     end;

	stars_given = n;

	do i = 1 to given;
	     p = subs -> list.element (i);

	     if p -> node.type = token_node
	     then if p -> token.type = asterisk
		then do;
			p = make_loop (n, b, s);
			n = n - 1;
			p -> operand (1) = loops;
			loops = p;
			if last = null
			then last = p;

			if b -> bound.c_lower ^= 1
			then do;
				if b -> bound.lower = null
				then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
				subs -> list.element (i) =
				     addf ((p -> operand (2)), subf (copy_expression (b -> bound.lower), one));
			     end;
			else subs -> list.element (i) = p -> operand (2);
		     end;

	     b = b -> bound.next;
	end;

	tree -> reference.array_ref = "0"b;

	if s -> node.type = label_node
	then do;
		p = subscripter (blk, stmnt, tree, subs, s);
		p -> reference.offset = expression_semantics (blk, stmnt, (p -> reference.offset), "0"b);
		call simplify_offset (p, context);
	     end;
	else if s -> symbol.structure
	then p = expander (tree, bna);
	else p = process_subscripted_reference (tree, subs);

	if last = null
	then return (p);

	last -> operand (1) = p;

	return (loops);

/* builds ALL loops for THIS level except as noted for the major structure */

expander:
     proc (tree, bna) returns (ptr);

/* parameters */

dcl	tree		ptr;			/* reference to be expanded into loop/join operators */
dcl	bna		ptr;			/* by name parts tree--for expanding structure refs
			in by name assignments	*/

/* automatic */

dcl	(s, a, q, qt, b, p, bnm, join_operator)
			ptr;
dcl	(k, i, n, m, our_last_index)
			fixed bin (15);
dcl	first_time	bit (1) aligned;
dcl	number_of_members	fixed bin (35);

	first_time = "1"b;
	s = tree -> reference.symbol;
	a = s -> symbol.array;

	if a ^= null
	then do;
		n = a -> array.number_of_dimensions;
		m = n + 1 - a -> array.own_number_of_dimensions;
		our_last_index = n - given + stars_given;
	     end;

/* If this is a structure call yourself for each son and collect the results.  */

	if s -> symbol.structure
	then do;

		k = 0;
		bnm = null;

/* Expand all members of the structure if this is ordinary
		   (not by name assignment) aggregate expansion, otherwise
		   use the by name parts tree to select members that
		   have names that match other structures in the by name
		   assignment. */

		if ^def_context.by_name_assignment
		then do;
			number_of_members = 0;
			do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
			     number_of_members = number_of_members + 1;
			end;

			if number_of_members > max_number_of_operands
			then call semantic_translator$abort (383, s);

			join_operator = create_operator (join, (number_of_members));
			do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
			     call expand_son (q, bnm);
			end;
		     end;
		else do;
			number_of_members = 0;
			do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
			     number_of_members = number_of_members + 1;
			end;

			if number_of_members > max_number_of_operands
			then call semantic_translator$abort (383, s);

			join_operator = create_operator (join, (number_of_members));
			do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
			     do q = s -> symbol.son repeat q -> symbol.brother
				while (q -> symbol.token ^= bnm -> by_name_agg.token);
			     end;
			     call expand_son (q, bnm);
			end;
		     end;

/* If this is not an array reference, return the join operator.  */

		if ^tree -> reference.array_ref
		then return (join_operator);

		q = join_operator;
		goto make_my_loops;
	     end;


	if ^tree -> reference.array_ref
	then do;
		if ^tree -> reference.processed
		then do;
			tree -> reference.qualifier = qual;

			tree = expression_semantics (blk, stmnt, tree, this_context);
		     end;

		return (tree);
	     end;


/* create a set of subscripts adjusted to compensate for the fact that the loop will run from
   1 to n rather than from lb to hb.	*/

	b = a -> array.bounds;
	q = create_list ((a -> array.number_of_dimensions));

	do i = 1 to n - given;
	     p = declare_index (our_last_index + 1 - i);
	     if b -> bound.c_lower ^= 1
	     then do;
		     if b -> bound.lower = null
		     then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
		     q -> list.element (i) = addf (p, subf (copy_expression (b -> bound.lower), one));
		end;
	     else q -> list.element (i) = p;

	     b = b -> bound.next;
	end;

	k = 0;

	do i = n - given + 1 to n;
	     k = k + 1;
	     q -> list.element (i) = copy_expression (subs -> list.element (k));
	end;

	q = process_subscripted_reference (tree, q);



/* make a loop operator for each dimension at THIS level; i.e., excluding inherited dimensions.  */

make_my_loops:
	b = a -> array.bounds;

	k = 0;

	if n ^= given
	then do i = m to n;
		p = make_loop (our_last_index - k, b, s);
		p -> operand (1) = q;
		q = p;
		b = b -> bound.next;
		k = k + 1;
	     end;

/* return the top loop operator.  */

	return (q);

/* Expands a son of a structure into loop and join operators */

expand_son:
     procedure (q, bnm);

/* parameters */

dcl	q		ptr;			/* A son of the structure being expanded by expander */
dcl	bnm		ptr;			/* The corresponding point in the by_name_parts_tree or null */

	k = k + 1;

	qt = create_reference (q);
	qt -> reference = q -> symbol.reference -> reference;
	qt -> reference.shared = "0"b;
	qt -> reference.ref_count = 1;
	qt -> reference.length = copy_expression (qt -> reference.length);
	qt -> reference.offset = copy_expression (qt -> reference.offset);

	if ^first_time
	then qt -> reference.qualifier = share_expression (qual);
	else do;
		first_time = "0"b;
		qt -> reference.qualifier = qual;

/* force temp, if any, to be unshared so
		   simplify_offset will not try to alter qualifier */

		if qual ^= null
		then if qual -> node.type = operator_node
		     then if qual -> operand (1) -> reference.shared
			then do;
				qual -> operand (1) = copy_expression (qual -> operand (1));
				qual -> operand (1) -> reference.shared = "0"b;
				qual -> operand (1) -> reference.ref_count = 1;
			     end;
	     end;

	qt -> reference.put_data_sw = tree -> reference.put_data_sw;

	if tree -> reference.array_ref
	then qt -> reference.array_ref = "1"b;
	else if qt -> reference.symbol -> symbol.array ^= null
	then if qt -> reference.symbol -> symbol.array -> array.own_number_of_dimensions ^= 0
	     then qt -> reference.array_ref = "1"b;
	     else qt -> reference.array_ref = "0"b;
	else qt -> reference.array_ref = "0"b;

	if ^qt -> reference.array_ref & subs ^= null
	then qt = process_subscripted_reference (qt, copy_expression ((subs)));

	join_operator -> operator.operand (k) = expander (qt, bnm);

	return;

     end /* expand_son */;

     end /* expander */;

process_subscripted_reference:
     proc (tree, subs) returns (ptr);

dcl	(tree, subs, p, s)	ptr;

dcl	constant		fixed bin,
	modified		bit (1) aligned;

dcl	pl1_stat_$locator	(128) ptr ext static,
	pl1_stat_$index	fixed bin (15) ext static;

	s = tree -> reference.symbol;

	if qual ^= null
	then do;
		pl1_stat_$index = pl1_stat_$index + 1;
		if pl1_stat_$index > hbound (pl1_stat_$locator, 1)
		then do;
			call semantic_translator$abort (70, s);
			return (null);
		     end;
		pl1_stat_$locator (pl1_stat_$index) = tree;
	     end;

	if s -> symbol.defined
	then p = defined_reference (blk, stmnt, tree, subs, s, this_context);
	else p = subscripter (blk, stmnt, tree, (subs), s);

	p -> reference.array_ref = "0"b;

	if s -> symbol.defined
	then ;
	else p -> reference.qualifier = qual;

	if p -> reference.offset ^= null
	then do;
		if ^pl1_stat_$eis_mode
		then call bit_ptr ((p -> reference.offset), qual);
		p -> reference.offset =
		     expression_semantics (symbols_block, stmnt, (p -> reference.offset), this_context);

		p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);

		call simplify_expression ((p -> reference.offset), constant, modified);

		if modified
		then do;
			p -> reference.offset = null;
			p -> reference.c_offset = constant;
		     end;
	     end;

	if p -> reference.length ^= null
	then do;
		p -> reference.length =
		     expression_semantics (symbols_block, stmnt, (p -> reference.length), this_context);
		p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);
	     end;

	call simplify_offset (p, context);

	if qual ^= null
	then pl1_stat_$index = pl1_stat_$index - 1;

	p -> reference.processed = "1"b;		/* otherwise expression_semantics might destroy offset, modword... */

	return (p);

     end process_subscripted_reference;

/* subroutine to create a loop operator */

make_loop:
     proc (i, b, s) returns (ptr);

dcl	i		fixed bin (15);
dcl	constant_field	fixed bin;
dcl	(p, q, b, s, lower, upper)
			ptr;
dcl	(constant, modified)
			bit (1) aligned;

	if b -> bound.lower = null
	then lower, b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
	else lower = copy_expression (b -> bound.lower);

	if b -> bound.upper = null
	then upper, b -> bound.upper = declare_constant$integer ((b -> bound.c_upper));
	else upper = copy_expression (b -> bound.upper);

	p = create_operator (loop, 5);
	p -> operand (2) = declare_index ((i));
	p -> operand (3) = one;

	if lower -> node.type = reference_node & upper -> node.type = reference_node
	then if lower -> reference.symbol -> node.type = symbol_node
		& upper -> reference.symbol -> node.type = symbol_node
	     then if lower -> reference.symbol -> symbol.constant & upper -> reference.symbol -> symbol.constant
		then constant = "1"b;
		else constant = "0"b;
	     else constant = "0"b;
	else constant = "0"b;

	if b -> bound.c_lower = 1
	then p -> operand (4) = upper;
	else if constant
	then p -> operand (4) = declare_constant$integer (b -> bound.c_upper - b -> bound.c_lower + 1);
	else p -> operand (4) = subf (upper, subf (lower, one));

	q = p -> operand (4);
	call refer_extent (q, qual);

	p -> operand (4) = expression_semantics (symbols_block, stmnt, q, this_context);
	p -> operand (4) = convert$to_integer ((p -> operand (4)), integer_type);

	call simplify_expression ((p -> operand (4)), constant_field, modified);

	if modified
	then p -> operand (4) = declare_constant$integer ((constant_field));

	return (p);

     end make_loop;

/* subroutine to declare an index variable.  */

declare_index:
     proc (i) returns (ptr);

dcl	i		fixed bin (7);
dcl	(t, d)		ptr;

	t = create_token ("s." || bindec$vs ((i)), identifier);

	do d = t -> token.declaration repeat d -> symbol.multi_use while (d ^= null);
	     if d -> symbol.block_node = blk
	     then return (d -> symbol.reference);
	end;

	d = create_symbol (blk, t, by_compiler);
	d -> symbol.fixed, d -> symbol.binary, d -> symbol.real, d -> symbol.auto, d -> symbol.allocate = "1"b;

	call declare (d);

	return (d -> symbol.reference);

     end declare_index;

/* subroutine to create expressions. */

addf:
     proc (a, b) returns (ptr);

dcl	(a, b, c)		ptr;
dcl	opcode		bit (9) aligned;

	opcode = add;

	go to common;

subf:
     entry (a, b) returns (ptr);

	opcode = sub;
common:
	c = create_operator (opcode, 3);
	c -> operand (2) = a;
	c -> operand (3) = b;

	return (c);

     end addf;

bit_ptr:
     proc (exp, q);

dcl	(exp, q)		ptr;
dcl	i		fixed bin (15);

	if exp = null
	then return;
	if exp -> node.type ^= operator_node
	then return;

	if exp -> op_code = bit_pointer
	then do;
		exp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
		exp -> operand (2) = share_expression (q);
		exp -> operator.processed = "1"b;
	     end;
	else do i = 2 to exp -> operator.number;
		call bit_ptr ((exp -> operand (i)), q);
	     end;

     end bit_ptr;

%include semant;
%include array;
%include by_name_agg;
%include declare_type;
%include label;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include semantic_bits;
%include symbol;
%include system;
%include token;
%include token_types;

     end expand_primitive;




		    expression_semantics.pl1        07/31/89  1431.7r w 07/31/89  1338.2      271125



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


/* format: style3 */
expression_semantics:
     proc (blk, stmnt, input_tree, context) returns (ptr);

/* Modified 770520 by PG to get defaulting of constants to agree with ANSI standard */
/* Modified 770701 by PG to fix 1609 (invalid initialization of automatic variables in prologue) */
/* Modified 770708 by PG to fix 1641 (default statements shouldn't be applied to string constants) */
/* Modified 780314 by PG to fix 1673 (don't default constants unless default statement explicitly touches constants) */
/* Modified 780322 by RAB to diagnose non array_or_entry followed by parenthesized list */
/* Modified Nov 1978 by DS to suppress redundant label and entry cross-references */
/* Modified 26 Dec 1979 by PCK to implement by name assignment */
/*	Modified: 28 April 1980 by PCK to fix 1959	*/

/* parameters */

dcl	(blk, stmnt, input_tree)
			ptr parameter;

/* automatic */

dcl	(tree, s, subs, d, p, q, b)
			ptr;
dcl	(i, n, t, asterisk_count)
			fixed bin (15);
dcl	opcode		bit (9) aligned;
dcl	(LHS_aggregate, pds, cross_section)
			bit (1) aligned;

/* builtins */

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

/* external static */

dcl	pl1_stat_$LHS	ptr ext static;
dcl	pl1_stat_$LHS_ref	ptr ext static;
dcl	pl1_stat_$root	ptr ext static;
dcl	pl1_stat_$locator	(128) ptr ext static;
dcl	pl1_stat_$index	fixed bin (15) ext static;

/* program */

	tree = input_tree;

	subs = null;
	cross_section, this_context = "0"b;
	def_this_context.ignore_based = def_context.ignore_based;
	def_this_context.suppress_cross_ref = def_context.suppress_cross_ref;

	if tree = null
	then goto ret;

	if tree -> node.type = operator_node
	then do;
		if tree -> operator.processed
		then goto ret;

		opcode = tree -> operator.op_code;

		if opcode < r_parn | opcode > lock_file
		then goto not_io;

		if ((opcode >= get_file) & (opcode <= locate_file) | (opcode >= rewrite_file) & (opcode <= lock_file))
		then do;
			call io_semantics (blk, stmnt, tree);
			if opcode ^= open_file & opcode ^= close_file
			then tree = null;		/* 7-18-72: all others handled
					   by recio or stream_prep */

			goto ret;
		     end;

		if opcode >= r_parn & opcode <= bn_format
		then do;
			call io_data_list_semantics$format_list_semantics (blk, stmnt, tree);
			tree -> operator.processed = "1"b;
			goto ret;
		     end;

		if opcode = put_data_trans
		then do;
			q = tree -> operand (2);
			if q -> node.type = token_node
			then do;
				p = create_reference (q);
				q, tree -> operand (2) = p;
			     end;
			if q -> node.type = reference_node
			then q -> reference.put_data_sw = "1"b;
		     end;

		if opcode = get_list_trans | opcode = get_edit_trans
		then def_this_context.left_side = "1"b;

not_io:
		if opcode = assign_by_name
		then do;
			call expand_by_name (blk, stmnt, tree);

			if stmnt -> statement.root = null
			then go to ret;
			else opcode = assign;
		     end;

		if opcode = refer | opcode = bit_pointer
		then if pl1_stat_$index > 0
		     then do;
			     p = pl1_stat_$locator (pl1_stat_$index) -> reference.qualifier;

			     if opcode = refer
			     then do;
				     tree = copy_expression (tree -> operand (2));
				     if tree -> node.type = token_node
				     then tree = create_reference (tree);

				     tree -> reference.qualifier = share_expression (p);
				     tree = expression_semantics (blk, stmnt, tree, this_context);

				     goto ret;
				end;
			     else do;
				     if p -> node.type = operator_node
				     then if p -> operator.op_code = assign
					then if p -> operand (1) -> reference.symbol -> symbol.aligned
					     then p = p -> operand (2);
				     tree -> operand (2) = share_expression (p);
				end;
			end;
		     else do;
			     if opcode = bit_pointer
			     then call semantic_translator$abort (291, null);

			     tree = tree -> operand (1);
			     tree = expression_semantics (blk, stmnt, tree, this_context);
			     goto ret;
			end;


		if opcode = assign
		then do;
			def_this_context.left_side = "1"b;

			if def_context.top
			then def_this_context.by_name_assignment = stmnt -> statement.expanded_by_name;

			tree -> operand (1) = expression_semantics (blk, stmnt, (tree -> operand (1)), this_context);
			LHS_aggregate = def_this_context.aggregate;

			if def_this_context.return_from_empty
			then do;
				tree = tree -> operand (1);
				goto ret;
			     end;

			do p = tree -> operand (1) repeat p -> operand (1) while (p -> node.type = operator_node);
			end;

			if p -> node.type ^= reference_node
			then call print (145);

			if def_context.top
			then do;
				pl1_stat_$LHS_ref = p;
				pl1_stat_$LHS = p -> reference.symbol;
			     end;

			if stmnt -> statement.expanded_by_name
			then def_this_context.by_name_assignment = def_context.top | def_context.by_name_assignment;

			def_this_context.aggregate, def_this_context.left_side = "0"b;
			tree -> operand (2) = expression_semantics (blk, stmnt, (tree -> operand (2)), this_context);
			def_context.RHS_aggregate = def_this_context.aggregate;
			def_this_context.aggregate = def_this_context.aggregate | LHS_aggregate;

			if def_this_context.return_from_empty
			then do;
				tree = tree -> operand (2);

				goto ret;
			     end;
		     end;
		else do;
			def_this_context.by_name_assignment = def_context.by_name_assignment;
			if opcode = do_fun
			then do;
				def_this_context.left_side = "1"b;
				tree -> operand (2) =
				     expression_semantics (blk, stmnt, (tree -> operand (2)), this_context);
				def_this_context.left_side = "0"b;
			     end;

			if opcode = do_spec		/* do loop while, repeat specs are only processed inside the loop */
			then do i = 1 to 3, 6;
				if tree -> operand (i) ^= null
				then tree -> operand (i) =
					expression_semantics (blk, stmnt, (tree -> operand (i)), this_context);
			     end;
			else do i = 1 to tree -> operator.number;
						/* normal operator...process all operands */
				if tree -> operand (i) ^= null
				then tree -> operand (i) =
					expression_semantics (blk, stmnt, (tree -> operand (i)), this_context);
			     end;
		     end;

		if opcode = return_value
		then do;
			tree = operator_semantics (blk, stmnt, tree, this_context);

			if tree ^= null
			then tree -> operator.processed = "1"b;

			goto ret;
		     end;

		if ^def_this_context.aggregate | opcode = allot_var | opcode = free_var | opcode = std_entry
		then do;
			tree = operator_semantics (blk, stmnt, tree, context);

			if tree ^= null
			then tree -> operator.processed = "1"b;

			goto ret;
		     end;

/*   Only aggregates will reach this point   */
		if opcode = std_entry | opcode = join
		then do;
			tree -> operator.processed = "1"b;
			goto ret;
		     end;

		if opcode >= jump
		then if opcode = prefix_plus | opcode = join | opcode >= get_list_trans & opcode <= put_data_trans
		     then ;
		     else call print (62);

		if opcode = assign & (def_context.arg_list | def_context.top)
		then do;
			this_context = context;

			if def_this_context.top
			then def_this_context.by_name_assignment = stmnt -> statement.expanded_by_name;

			tree = expand_assign (blk, stmnt, tree, this_context, null);
			tree -> operator.processed = "1"b;
			goto ret;
		     end;

		def_context.aggregate = "1"b;

		if opcode = copy_words
		then do;
			p = expand_primitive (blk, stmnt, (tree -> operand (1)), "0"b);

			do q = p repeat q -> operand (1) while (q -> operand (1) -> node.type = operator_node);
			end;

			tree -> operand (1) = q -> operand (1);
			q -> operand (1) = tree;
			tree = p;

			tree -> operator.processed = "1"b;
			goto ret;
		     end;

		if opcode = negate | opcode = not_bits | opcode = prefix_plus | opcode = put_field
		     | opcode = put_field_chk | (opcode >= get_list_trans & opcode <= put_data_trans)
		then tree = expand_prefix (blk, stmnt, tree, context);
		else tree = expand_infix (blk, stmnt, tree, context);

		tree -> operator.processed = "1"b;

		goto ret;
	     end;

	if tree -> node.type = token_node
	then do;
		if tree -> token.type = identifier
		then do;

			if ^lookup (blk, stmnt, tree, s, this_context)
			then do;
				call semantic_translator$error (77, tree);
				s = create_symbol ((pl1_stat_$root -> block.son), tree, by_implication);
				call declare (s);
				s -> symbol.allocate = "1"b;

				d = create_cross_reference ();
				d -> cross_reference.next = null;
				s -> symbol.cross_references = d;
				string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);
			     end;

			if s -> node.type = label_node
			then goto process_label;

			q = s -> symbol.reference;
			if q -> reference.offset = null & q -> reference.qualifier = null
			     & q -> reference.length = null & ^(s -> symbol.entry | s -> symbol.defined)
			then tree = q;
			else do;
				tree = copy_expression ((q));
				tree -> reference.shared = "0"b;
				tree -> reference.ref_count = 1;
				tree -> reference.qualifier = null;
			     end;
			go to process_reference;
		     end;

/* Default arithmetic constant tokens */

		if (tree -> token.type & is_arithmetic_constant) = is_arithmetic_constant
		then do b = blk repeat b -> block.father while (b ^= null);
			if b -> block.default ^= null
			then do;
				s = create_symbol (blk, null, by_compiler);
				s -> symbol.constant = "1"b;
				if tree -> token.loc ^= ""b
						/* "p" flag ON */
				then go to ignore_default_attempt;

/* constant contains an "e" implies is_float_constant */
				if (tree -> token.type & is_float_constant) = is_float_constant
				then s -> symbol.float = "1"b;
				else if index (tree -> token.string, "f") ^= 0
				then s -> symbol.fixed = "1"b;

/* constant contains an "i" implies is_imaginary_constant */
				if (tree -> token.type & is_imaginary_constant) = is_imaginary_constant
				then s -> symbol.complex = "1"b;
				else s -> symbol.real = "1"b;

				call validate (s);	/* now default the symbol */

				if ^s -> symbol.defaulted
						/* were any defaults applied? */
				then go to ignore_default_attempt;
						/* No */

				if ^s -> symbol.fixed & ^s -> symbol.float
						/* complete the scale */
				then s -> symbol.fixed = "1"b;

				if ^s -> symbol.binary & ^s -> symbol.decimal
						/* complete the base */
				then if (tree -> token.type & is_decimal_constant) = is_decimal_constant
				     then s -> symbol.decimal = "1"b;
				     else s -> symbol.binary = "1"b;

/* validate and the above code has now supplied
				the data type to coerce the literal constant to,
				except possibly for the size (length or precision) */

/* get a pointer to a reference to the converted constant */

				if s -> symbol.c_dcl_size = 0 & s -> symbol.dcl_size = null
				then tree = convert (tree, string (s -> symbol.attributes));
				else tree = convert$to_target (tree, (s -> symbol.reference));

ignore_default_attempt:
				call free_node (s);

				go to ret;
			     end;
		     end;				/* control comes here if there were no default statements */
		go to ret;
	     end;

	if tree -> node.type = label_node
	then do;
		s = tree;
		go to process_label;
	     end;

	if tree -> node.type ^= reference_node
	then goto ret;

	if tree -> reference.symbol -> node.type ^= token_node
	then do;
		s = tree -> reference.symbol;
		if s -> node.type ^= symbol_node
		then goto ret;			/* could be subscripted reference_node for labels */
		if s -> symbol.param_desc		/* the qualifier field should be fully processed */
		then do;
			tree -> reference.processed = "1"b;
			goto process_reference;
		     end;

		if ^tree -> reference.symbol -> symbol.based /* for init allocated based structures */
		     & ^tree -> reference.processed
		then tree -> reference.qualifier = null;/* for auto-adj storage class */

		goto process_reference;
	     end;

	subs = tree -> reference.offset;
	tree -> reference.offset = null;		/*   lookup never sees the offset field  */

	if ^lookup (blk, stmnt, tree, s, this_context)
	then do;
		q = tree -> reference.length;
		if q ^= null
		then do;
			p = create_token (tree -> reference.symbol -> token.string || """ in """
			     || q -> element (q -> list.number) -> token.string, identifier);
			call semantic_translator$abort (102, p);
		     end;

		if subs = null
		then do;
			pds = tree -> reference.put_data_sw;

			call semantic_translator$error (77, tree);
			s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol), by_implication);
			call declare (s);
			s -> symbol.allocate = "1"b;

			d = create_cross_reference ();
			d -> cross_reference.next = null;
			s -> symbol.cross_references = d;
			string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);

			if pds
			then do;
				tree -> reference.put_data_sw = "1"b;
				goto copy_ref;
			     end;

			goto process_reference;
		     end;

		do i = 1 to number_of_names;
		     if tree -> reference.symbol -> token.string = pl1_data$builtin_name (i).name
		     then do;
			     s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol),
				by_implication);

			     d = create_cross_reference ();
			     d -> cross_reference.next = null;
			     s -> symbol.cross_references = d;
			     string (d -> cross_reference.source_id) = string (stmnt -> statement.source_id);
			     s -> symbol.builtin = "1"b;
			     s -> symbol.c_dcl_size = i;

			     tree -> reference.offset = null;
			     tree -> reference.symbol = s;
			     s -> symbol.reference = tree;

			     tree = builtin (blk, stmnt, tree, subs, s, context);
			     goto ret;
			end;
		end;

		call semantic_translator$error (64, tree);
		s = create_symbol ((pl1_stat_$root -> block.son), (tree -> reference.symbol), by_implication);
		s -> symbol.entry = "1"b;
		s -> symbol.variable_arg_list = "1"b;
		call declare (s);
		s -> symbol.allocate = "1"b;
		tree = copy_expression (s -> symbol.reference);
	     end;

/* this name was found by lookup. */

	if s -> node.type = label_node
	then go to process_label;

copy_ref:
	p = s -> symbol.reference;
	q = tree -> reference.qualifier;
	pds = tree -> reference.put_data_sw;

	if q = null & subs = null & p -> reference.offset = null & p -> reference.qualifier = null
	     & p -> reference.length = null & ^s -> symbol.entry & ^pds
	then do;
		call free_node (tree);
		tree = p;
	     end;
	else do;
		tree -> reference = p -> reference;
		tree -> reference.shared, tree -> reference.aggregate, tree -> reference.processed = "0"b;
		tree -> reference.ref_count = 1;
		tree -> reference.put_data_sw = pds;

		if tree -> reference.offset ^= null
		then tree -> reference.offset = copy_expression (/* p-> */ tree -> reference.offset);

		if tree -> reference.length ^= null
		then tree -> reference.length = copy_expression (/* p-> */ tree -> reference.length);

		tree -> reference.qualifier = q;
	     end;

process_reference:
	if def_context.left_side
	then call propagate_bit (s, set_bit);
	else if s -> symbol.auto | s -> symbol.defined
	then if s -> symbol.dcl_type ^= by_compiler	/* ck this because left_side bit not always set */
	     then if s -> symbol.block_node ^= null
		then if s -> symbol.block_node -> block.prologue_flag
						/* are we processing prologue stmts? */
		     then call print (295);		/* invalid initialization of automatic variable */

	if tree -> reference.processed
	then if tree -> reference.array_ref | s -> symbol.structure
	     then goto set_aggregate_bit;
	     else goto ret;

	if s -> symbol.builtin
	then do;
		if s -> symbol.c_dcl_size = 0
		then do;
			do i = 1 to number_of_names;
			     if description (i).name = s -> symbol.token -> token.string
			     then do;
				     s -> symbol.c_dcl_size = i;
				     goto call_builtin;
				end;
			end;

			call semantic_translator$abort (63, s);
		     end;

call_builtin:
		tree = builtin (blk, stmnt, tree, subs, s, context);

		goto ret;
	     end;

	if s -> symbol.generic
	then do;
		tree = generic_selector (blk, stmnt, tree, subs, context);
		goto ret;
	     end;

/* this is a variable or named constant. */
/*   processing the qualifier   */

	if s -> symbol.based
	then if tree -> reference.qualifier ^= null
	     then q = tree -> reference.qualifier;
	     else if s -> symbol.reference -> reference.qualifier = null
	     then if ^def_context.ignore_based
		then call print (66);
		else q = null;
	     else q = copy_expression (s -> symbol.reference -> reference.qualifier);

	else if tree -> reference.qualifier ^= null
	then call print (67);
	else if ^s -> symbol.defined & s -> symbol.reference -> reference.qualifier ^= null
	then do;
		q = s -> symbol.reference -> reference.qualifier;
		if q -> node.type ^= reference_node
		then q = copy_expression ((q));
	     end;
	else q = null;

	if q ^= null
	then do;
		if q -> node.type = symbol_node
		then q = q -> symbol.reference;

		if tree -> reference.qualifier = null
		then p = s -> symbol.block_node;
		else p = blk;

		q = expression_semantics (p, stmnt, q, this_context);

		if def_this_context.aggregate
		then call print (68);

		tree -> reference.qualifier, q = convert (q, pointer_type);

		if q -> node.type = operator_node
		then if q -> op_code = assign
		     then if q -> operand (2) -> reference.symbol -> symbol.offset
			then do;
				q -> operator.processed = "0"b;
						/* offset -> .... */
				tree -> reference.qualifier, q = operator_semantics (blk, stmnt, q, "0"b);
				q -> operator.processed = "1"b;
			     end;

		pl1_stat_$index = pl1_stat_$index + 1;
		if pl1_stat_$index > 128
		then call print (70);
		pl1_stat_$locator (pl1_stat_$index) = tree;
	     end;

/*   processing the subscripts   */
/*   calling subscripter or defined_reference   */
/*   scalar, cross_section, or array(*,*,*)   */

	if s -> symbol.dimensioned & subs ^= null
	then do;
		asterisk_count = 0;

		do i = 1 to subs -> list.number;
		     if subs -> element (i) -> node.type = token_node
		     then if subs -> element (i) -> token.type = asterisk
			then asterisk_count = asterisk_count + 1;
		end;

		if asterisk_count = subs -> list.number
		then do;
			subs = null;
			tree -> reference.array_ref = "1"b;

			cross_section = "0"b;

			if def_context.arg_list & ^s -> symbol.defined
			then goto process_ref_sons;

			tree -> reference.offset = null;

			if q ^= null
			then pl1_stat_$index = pl1_stat_$index - 1;

			goto set_aggregate_bit;
		     end;
		else tree -> reference.array_ref, cross_section = asterisk_count ^= 0;

		if cross_section & def_context.evaluate_offset
		then if ^def_context.string_unspec
		     then call semantic_translator$abort (272, tree);
		     else do;
			     pl1_stat_$index = pl1_stat_$index - 1;

			     goto set_aggregate_bit;
			end;

		if def_context.arg_list
		then do;
			if cross_section
			then do;
				tree -> reference.offset = subs;
				def_context.cross_section = "1"b;

				if q ^= null
				then pl1_stat_$index = pl1_stat_$index - 1;

				goto ret;
			     end;

			if s -> symbol.defined
			then tree = defined_reference (blk, stmnt, tree, subs, s, context);
			else tree = subscripter (blk, stmnt, tree, subs, s);
		     end;

		else if ^(s -> symbol.structure | cross_section) | def_context.evaluate_offset
		then if s -> symbol.defined
		     then tree = defined_reference (blk, stmnt, tree, subs, s, context);
		     else tree = subscripter (blk, stmnt, tree, subs, s);

		if s -> symbol.entry & def_context.top & subs = null
		then subs = create_list (0);
	     end;

	else if subs ^= null & ^s -> symbol.entry
	then call neither_array_nor_entry;

/*   array_reference, or undimensioned scalar   */
	else if s -> symbol.defined & ^s -> symbol.structure & ^tree -> reference.array_ref
	then tree = defined_reference (blk, stmnt, tree, subs, s, context);

process_ref_sons:					/*   processing the offset   */
	if tree -> reference.offset ^= null
	then do;
		tree -> reference.offset =
		     expression_semantics ((s -> symbol.block_node), stmnt, (tree -> reference.offset), "0"b);
		tree -> reference.offset = convert$to_integer ((tree -> reference.offset), integer_type);
	     end;

/*   processing the length   */

	if tree -> reference.length ^= null
	then do;
		tree -> reference.length =
		     expression_semantics ((s -> symbol.block_node), stmnt, (tree -> reference.length), "0"b);
		tree -> reference.length = convert$to_integer ((tree -> reference.length), integer_type);
	     end;

	call simplify_offset (tree, context);

	if def_this_context.aggregate
	then call print (73);

	if q ^= null
	then pl1_stat_$index = pl1_stat_$index - 1;

/*   calls function   */

	if s -> symbol.entry
	then if subs ^= null
	     then do;
		     if cross_section
		     then call print (72);
		     p = create_operator (std_arg_list, 3);
		     p -> operand (2) = subs;
		     q = create_operator (std_call, 3);
		     q -> operand (2) = tree;
		     q -> operand (3) = p;
		     tree = q;

		     tree = function (blk, stmnt, tree, s, context);

		     if tree -> node.type = operator_node
		     then tree -> operator.processed = "1"b;
		     else tree -> reference.processed = "1"b;

		     goto ret;
		end;

set_aggregate_bit:					/*   turning on the aggregate bit   */
	tree -> reference.array_ref = tree -> reference.array_ref | cross_section;

	if subs ^= null
	then do;

/* put back subs on the reference node for use by expand_primitive */

		tree -> reference.offset = subs;

/* undo work of simplify_offset to avoid DISASTER! */

		tree -> reference.c_offset = s -> symbol.reference -> reference.c_offset;
		tree -> reference.units = s -> symbol.reference -> reference.units;
		string (tree -> reference.info.other) = "0"b;
	     end;

	if pl1_stat_$LHS ^= null & ^def_context.left_side & ^def_context.evaluate_offset
	then stmnt -> statement.LHS_in_RHS = temp_needed (tree, cross_section);

	if tree -> reference.array_ref & s -> symbol.defined & ^s -> symbol.overlayed
	then def_context.cross_section = "1"b;

	if s -> symbol.structure | tree -> reference.array_ref
	then def_context.aggregate = "1"b;

	if ^def_context.ignore_based
	then tree -> reference.processed = "1"b;

	goto ret;

/* this is a reference to a label constant. */

process_label:
	if s -> label.array
	then do;
		if subs ^= null
		then do;
			if subs -> list.number ^= 1
			then call print (80);
			p = subs -> element (1);
			if p -> node.type = token_node
			then if p -> token.type = asterisk
			     then cross_section = "1"b;
		     end;

		if subs = null | cross_section
		then do;
			tree = create_reference (s);
			tree -> reference.processed = "1"b;
			tree -> reference.array_ref = "1"b;
			def_context.aggregate = "1"b;
			call increment_label_array_counts;
			goto ret;
		     end;

		tree = subscripter (blk, stmnt, tree, subs, s);
		tree -> reference.offset = expression_semantics (blk, stmnt, (tree -> reference.offset), this_context);
		call simplify_offset (tree, "0"b);
		if def_this_context.aggregate
		then call print (73);
		tree -> reference.processed = "1"b;

		if tree -> reference.offset = null
		then do;
			q = s -> label.statement -> list.element (tree -> reference.c_offset + 1);
			if q ^= null
			then q -> statement.reference_count = q -> statement.reference_count + 1;
			else call print (494);
		     end;
		else call increment_label_array_counts;
	     end;
	else do;
		if subs ^= null
		then call neither_array_nor_entry;

		if s -> label.statement ^= null
		then s -> label.statement -> statement.reference_count =
			s -> label.statement -> statement.reference_count + 1;

		tree = s;
	     end;

ret:
	return (tree);

/* Is a temporary needed because of RHS-LHS overlap */

temp_needed:
     procedure (RHS_ref, RHS_cross_section) returns (bit (1) aligned);

/* parameters */

dcl	RHS_ref		ptr parameter;
dcl	RHS_cross_section	bit (1) aligned parameter;

/* external static */

dcl	(
	pl1_stat_$LHS,
	pl1_stat_$LHS_ref
	)		ptr ext static;

/* builtin */

dcl	(null, string)	builtin;

/* automatic */

dcl	(LHS_ref, LHS_sym, RHS_sym)
			ptr;
dcl	t		fixed bin;

	LHS_ref = pl1_stat_$LHS_ref;
	LHS_sym = pl1_stat_$LHS;
	RHS_sym = RHS_ref -> reference.symbol;

	if RHS_ref -> reference.array_ref
	then do;

		if defined_on (RHS_sym, LHS_sym)
		then return ("1"b);

		if defined_on (LHS_sym, RHS_sym)
		then return ("1"b);

		if cross_section_overlap ()
		then return ("1"b);

	     end;

	if string_overlay_possible ()
	then return ("1"b);

	return ("0"b);

/* Is s1 defined on s2? */

defined_on:
     procedure (s1, s2) returns (bit (1) aligned);

/* parameters */

dcl	(s1, s2)		ptr;

/* automatic */

dcl	s1_defined_on_s2	bit (1) aligned;

	if s1 -> symbol.defined & s1 -> symbol.equivalence ^= null
	then if s1 -> symbol.equivalence -> node.type = token_node
	     then if s1 -> symbol.equivalence = s2 -> symbol.token
		then s1_defined_on_s2 = "1"b;
		else s1_defined_on_s2 = "0"b;
	     else if s1 -> symbol.equivalence -> reference.symbol = s2
	     then s1_defined_on_s2 = "1"b;
	     else s1_defined_on_s2 = "0"b;
	else s1_defined_on_s2 = "0"b;

	return (s1_defined_on_s2);

     end /* defined_on */;

/* If the RHS reference is a possible reference to a cross-section,
   determine if possible RHS-LHS overlap will require an aggregate temp */

cross_section_overlap:
     procedure () returns (bit (1) aligned);

/* The RHS reference is a possible cross-section reference if any of
   the following conditions are satisfied:

   (1)	An explicit cross-section reference was given (e.g. a(i,*));
	This would be indicated by RHS_cross_section.

   (2)	A reference to a parameter with star extents was given.  This
	is the only valid way a parameter may be aliased to a cross-section.

   (3)	A reference to a variable with the defined attribute was given.
	If this is isub defining, the variable may be a cross-section of
	an array.

   Note:	These tests are rather crude; future implementations should attempt
	to refine them or to substitute a more systematic approach.
							*/

/* automatic */

dcl	(RHS_subs, LHS_subs)
			ptr;

	if (RHS_cross_section | (RHS_sym -> symbol.parameter & RHS_sym -> symbol.star_extents) | RHS_sym -> symbol.defined)
	     & (LHS_sym -> symbol.based | LHS_sym -> symbol.defined | LHS_sym -> symbol.parameter)
	     & LHS_sym -> symbol.dimensioned & string (LHS_sym -> symbol.data_type) = string (RHS_sym -> symbol.data_type)
	then return ("1"b);

	if LHS_sym = RHS_sym & RHS_cross_section
	then do;
		LHS_subs = LHS_ref -> reference.offset;
		RHS_subs = RHS_ref -> reference.offset;

		if LHS_subs = null | RHS_subs = null
		then return ("1"b);
		else if LHS_subs -> node.type ^= list_node | RHS_subs -> node.type ^= list_node
		then return ("1"b);
		else return (^stars_match ());

	     end;

	return ("0"b);

/* Determine if two unprocessed subscript lists have asterisks in
   corresponding positions. E.g., (*,i) and (*,i+1) do, and (*,i) and (i+1,*)
   don't. */

stars_match:
     procedure () returns (bit (1) aligned);

/* automatic */

dcl	i		fixed bin;

	do i = 1 to LHS_subs -> list.number;
	     if is_star ((LHS_subs -> list.element (i))) ^= is_star ((RHS_subs -> list.element (i)))
	     then return ("0"b);
	end;

	return ("1"b);

/* Determine if a subscript is an asterisk (denotes a cross-section) */

is_star:
     procedure (subscript) returns (bit (1) aligned);

/* parameter */

dcl	subscript		ptr;

	if subscript -> node.type ^= token_node
	then return ("0"b);

	if subscript -> token.type ^= asterisk
	then return ("0"b);

	return ("1"b);

     end /* is_star */;

     end /* stars_match */;

     end /* cross_section_overlap */;

/* Check for a possible string overlay--one that is valid PL/I
   If it is possible for both references to string overlay define one
   other, excluding the case of references to the same generation of 
   storage, a temporary is needed */

string_overlay_possible:
     procedure () returns (bit (1) aligned);

	t = 0;

	if LHS_sym -> symbol.aliasable & RHS_sym -> symbol.aliasable & LHS_sym -> symbol.packed & RHS_sym -> symbol.packed
	     & ^compare_expression (LHS_ref, RHS_ref) & string_overlay (LHS_sym) & string_overlay (RHS_sym)
	then do;

		if RHS_sym -> symbol.father ^= null
		then return ("1"b);

		if RHS_sym -> symbol.based | RHS_sym -> symbol.defined | RHS_sym -> symbol.parameter
		then return ("1"b);

	     end;

	return ("0"b);

     end /* string_overlay_possible */;
%include string_overlay;
     end /* temp_needed */;

/* increments reference counts of all statements pointed at by label array */

increment_label_array_counts:
     proc;

dcl	(q, vector)	ptr;
dcl	i		fixed bin;

	vector = s -> label.statement;
	do i = 1 to vector -> list.number;
	     q = vector -> list.element (i);
	     if q ^= null
	     then q -> statement.reference_count = q -> statement.reference_count + 1;
	end;

     end;


/* subroutine to print an error message */

print:
     proc (m);

dcl	m		fixed bin (15);

	if tree -> node.type = operator_node
	then p = null;
	else p = tree;

	call semantic_translator$abort (m, p);

     end;

/* prints appropriate error message */

neither_array_nor_entry:
     proc;

dcl	errno		fixed bin (15);

	if def_context.top & stmnt -> statement.statement_type = call_statement
	then errno = 224;				/* used $ where entry value needed */
	else errno = 370;				/* $ was followed by parenthesized list & is neither array nor entry */

	call print (errno);

     end;

%include semant;
%include block;
%include block_types;
%include boundary;
%include builtin_table;
%include cross_reference;
%include declare_type;
%include label;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include semantic_bits;
%include statement;
%include symbol;
%include symbol_bits;
%include system;
%include token;
%include token_types;
%include statement_types;

     end expression_semantics;




		    fill_refer.pl1                  07/31/89  1431.7r w 07/31/89  1338.5       16083



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


fill_refer: proc(pp,qq,copy) returns(ptr);

dcl	(pp,qq) ptr,
	copy bit(1) aligned;

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

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

	p = pp;
	if p = null then return(null);

	q = qq;

	if p -> node.type = reference_node
	then do;
	     p -> reference.qualifier = fill_refer((p -> reference.qualifier),q,copy);
	     p -> reference.offset = fill_refer((p -> reference.offset),q,copy);
	     p -> reference.length = fill_refer((p -> reference.length),q,copy);
	     return(p);
	     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(p);
			end;

		if copy then q = copy_expression((q));
		p -> reference.qualifier = q;
		return(p);
		end;

	     do i = 1 to p -> operator.number;
		p -> operand(i) = fill_refer((p -> operand(i)),q,copy);
		end;

	     return(p);
	     end;

	return(p);
	end;




		    function.pl1                    07/31/89  1431.7r w 07/31/89  1338.7      136746



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


/*	Modified:	1 July 1977 by RAB to fix 1637	*/
/*	Modified: 26 December 1979 by PCK to implement by name assignment */
/*	Modified: 23 June 1981 by EBush to increase max size of arg lists */

function: proc(blk,stmnt,input_tree,s,context) returns(ptr);

dcl	(blk,stmnt,tree,input_tree,s,p,old,arg_list,arg_list_op,p_desc_list,save_arg_list_op) ptr,
	(a,op,q,r,sa,t) ptr,
	(subs,sym,array_ptr,bound_ptr,based_ref,based_sym,descr_ptr) ptr,
	(newarray,newbound) ptr,
	(i,j,k,n,called,caller) fixed bin(15),
	desc_list ptr,

	descriptors_required bit(1);


dcl	pl1_stat_$locator(128) ptr ext static;
dcl	pl1_stat_$index fixed bin(15) ext static;

dcl	(addr,divide,hbound,length,null,substr) builtin;

%include semant;
%include array;
%include block;
%include declare_type;
%include list;
%include nodes;
%include op_codes;
%include operator;
%include quick_info;
%include reference;
%include semantic_bits;
%include statement;
%include statement_types;
%include symbol;
%include symbol_bits;
%include system;
%include token;
%include token_types;

	if input_tree->operator.processed then return(input_tree);

	if s -> symbol.constant & s -> symbol.equivalence ^= null
	then do;
		called = s -> symbol.equivalence -> block.number;
		caller = blk -> block.number;
		substr(quick_info(called),caller,1) = "1"b;
		if stmnt->statement.force_nonquick
		then do;
			s -> symbol.equivalence -> block.no_stack = "0"b;
			s -> symbol.equivalence -> block.why_nonquick.stack_extended_by_args = "1"b;
		end;
	end;

	tree = input_tree;

	n = 0;
	descriptors_required = "0"b;
	arg_list_op = tree->operand(3);
	arg_list = null;
	p_desc_list = s->symbol.general;

	if arg_list_op^=null
	then	if arg_list_op->operand(2)->list.number=0
		then do;
			save_arg_list_op = arg_list_op;

			arg_list_op  ,
			tree->operand(3) = null;
		end;

	if arg_list_op=null
	then	if p_desc_list=null
		then do;
		        if s->symbol.returns
			   then desc_list = create_list(1);
		        goto process_returns;
		     end;
		else	call print(85);

	if p_desc_list = null
	then do;
		if ^s->symbol.variable_arg_list
		then do;
			call semantic_translator$error(86,s);
			s->symbol.variable_arg_list = "1"b;
		end;

		descriptors_required = "1"b;
		n = arg_list_op->operand(2)->list.number;
	end;
	else do;
		do q = p_desc_list repeat q->element(2) while(q^=null);
			n = n+1;
			descriptors_required = descriptors_required | q->element(1)->symbol.star_extents;
		end;

		if s->symbol.dcl_size ^= null
		then	descriptors_required = descriptors_required | s->symbol.dcl_size->symbol.star_extents;

		if arg_list_op->operand(2)->list.number ^= n then call print(87);
	end;

			/*   process all the arguments   */
	arg_list = arg_list_op->operand(2);

	if arg_list->list.number > max_list_elements - 1
	then call semantic_translator$abort(340,create_token(bindec$vs(max_list_elements-1),dec_integer));

	do k = 1 to divide(n,2,15,0);
		q = arg_list->element(k);
		arg_list->element(k) = arg_list->element(n-k+1);
		arg_list->element(n-k+1) = q;
	end;

	k = arg_list->list.number;
	if s->symbol.returns
	     then k = k+ 1;
	desc_list = create_list(k);

	do k = 1 to arg_list->list.number;
		old=stmnt->statement.back;	/* prepare to nullify statements generated
						   for  k-th argument */
		this_context = "01"b;
		a = arg_list->element(k);
		if p_desc_list ^= null
		then	p = p_desc_list->element(1);
		else	p = null;

		desc_list->list.element(k) = null;

		if a->node.type=operator_node
		then do;
			if a->operator.op_code=assign	/*   assuming the only kind of assignment is to t0   */
			then	arg_list->element(k)  ,
				a = a->operand(2);

			goto by_value;
		end;

		if a->node.type = token_node
		then	if a->token.type & is_constant
			then	goto by_value;

		q = copy_expression((a));
		q = expression_semantics(blk,stmnt,q,this_context);

		if q->node.type^=reference_node
		then do;

			/* operator_semantics won't do right thing if we
			   build dummy assignment with return_value
			   source or varying string target, so we
			   match_arguments first.	*/

			if q->node.type^=operator_node
			then	goto undo;
			if q->op_code^=std_call
			then	goto undo;
			if ^q->operand(1)->reference.symbol->symbol.return_value
			then	if ^q->operand(1)->reference.symbol->symbol.varying
				then	goto undo;
			a = q;

			if p^=null
			then	if ^match_arguments((q->operand(1)),p)
				then	goto by_value;

			if descriptors_required
			then	desc_list->list.element(k) = share_expression((q->operand(1)->reference.symbol->symbol.descriptor));

			goto next;
		end;

		if q -> reference.symbol -> node.type ^= symbol_node	/* arg was label array constant element */
		then	goto undo;

		if q->reference.symbol->symbol.constant			/* arg was builtin like null */
		then	goto undo;

			/*   checking for cross-sections or defined arrays   */

		sym = q->reference.symbol;
		array_ptr = sym->symbol.array;
		descr_ptr = sym->symbol.descriptor;

		if def_this_context.cross_section
		then do;
			bound_ptr = array_ptr->array.bounds;
			subs = q->reference.offset;

			if sym->symbol.defined & ^ sym->symbol.overlayed
			then do;
				if sym->symbol.isub
				then do;
					call semantic_translator$error(296,sym);
					goto undo;
				end;

				based_ref = copy_expression(sym->symbol.equivalence);

				if ^lookup((sym->symbol.block_node),stmnt,based_ref,based_sym,"0"b)
				then	call semantic_translator$abort(175,sym);

				if based_ref->node.type^=reference_node
				then	call semantic_translator$abort(343,sym);

				based_ref->reference.symbol = based_sym->symbol.token;
				if subs=null
				then do;
					subs = copy_expression(based_ref->reference.offset);
					sym = based_sym;
				end;
				else do;
					t = copy_expression(based_ref->reference.offset);
					j = 0;

					do i = 1 to subs->list.number;
test:
						j = j+1;
						if j>t->list.number
						then	call semantic_translator$abort(175,sym);

						if t->element(j)->node.type^=token_node
						then	goto test;

						if t->element(j)->token.type^=asterisk
						then	goto test;

						if subs->element(i)->node.type=token_node
						then	if subs->element(i)->token.type=asterisk
							then	;
							else	t->element(j) = subs->element(i);
						else	t->element(j) = subs->element(i);
					end;

					subs = t;
					sym = based_sym;
				end;

				array_ptr = sym->symbol.array;
				descr_ptr = sym->symbol.descriptor;
				bound_ptr = array_ptr->array.bounds;

				based_ref->reference.offset = null;
				q = expression_semantics(blk,stmnt,based_ref,this_context);

				if q=sym->symbol.reference
				then	q = copy_expression((q));

				q->reference.offset = subs;
			end;
			else	based_ref = null;

			newarray = create_array();
			newarray->array = array_ptr->array;
			newarray->array.number_of_dimensions  ,
			newarray->array.own_number_of_dimensions = 0;
			newbound = null;

			do i = 1 to subs->list.number;
				if subs->element(i)->node.type=token_node
				then if	subs->element(i)->token.type=asterisk
				then do;
					newarray->array.number_of_dimensions  ,
					newarray->array.own_number_of_dimensions = newarray->array.number_of_dimensions + 1;

					if newbound=null
					then do;
						newbound = create_bound();
						newarray->array.bounds = newbound;
					end;
					else do;
						newbound->bound.next = create_bound();
						newbound = newbound->bound.next;
					end;

					newbound->bound = bound_ptr->bound;
					newbound->bound.next = null;

					if bound_ptr->bound.lower = null
					then	subs->element(i) = declare_constant$integer((bound_ptr->bound.c_lower));

					else	subs->element(i) = copy_expression(bound_ptr->bound.lower);
				end;

				bound_ptr = bound_ptr->bound.next;
			end;

			sym->symbol.array = newarray;
			sym->symbol.descriptor = null;

			if p^=null
			then if	^match_arguments(q,p)
			then do;
				call semantic_translator$error(47,q);
				sym->symbol.array = array_ptr;
				sym->symbol.descriptor = descr_ptr;
				goto undo;
			end;

			sym->symbol.array = array_ptr;
			q->reference.offset = copy_expression(sym->symbol.reference->reference.offset);

			if q -> reference.qualifier ^= null
			then do;
				pl1_stat_$index = pl1_stat_$index + 1;
				if pl1_stat_$index > hbound(pl1_stat_$locator,1)
				then	call print(70);
				pl1_stat_$locator(pl1_stat_$index) = q;
			end;

			q = subscripter(blk,stmnt,q,subs,sym);
			q->reference.offset = expression_semantics(blk,stmnt,(q->reference.offset),"0"b);
			call simplify_offset(q,"0"b);

			if q -> reference.qualifier ^= null
			then	pl1_stat_$index = pl1_stat_$index - 1;

			q->reference.array_ref = "1"b;
			sym->symbol.array = newarray;
		end;
		else do;
			if p^=null
			then if	^match_arguments(q,p)
			then do;
				call print(47);
				go to undo;
			end;

			if sym->symbol.defined
			then if sym->symbol.structure | q->reference.array_ref
			then do;
				q = defined_reference(blk,stmnt,q,null,sym,this_context);
				if q->reference.offset ^= null
				then do;
					q->reference.offset = expression_semantics(blk,stmnt,(q->reference.offset),"0"b);
					call simplify_offset(q,"0"b);
				end;
			end;
		end;

		a = q;
		sa = a->reference.symbol;
		call propagate_bit(sa,set_bit);
		call propagate_bit(sa,passed_as_arg_bit);

		if sa->symbol.static
		|  sa->symbol.controlled
		then	call propagate_bit(sa,aliasable_bit);

		if	sa->symbol.entry
		then if	sa->symbol.internal
		then if	sa->symbol.constant
		then do q = sa->symbol.block_node repeat q->block.father while(q^=null);
			q->block.flush_at_call = "1"b;
		end;

		if desc_list->list.element(k)^=null		/*   descriptor already made previously   */
		then	if ^descriptors_required
			then	call print(89);
			else	;
		else	if descriptors_required	/*   since not made elsewhere already   */
			then	desc_list->list.element(k) = declare_descriptor(blk,stmnt,sa,
					(a->reference.qualifier),
					a->reference.array_ref || def_this_context.cross_section);

		sym->symbol.array = array_ptr;
		sym->symbol.descriptor = descr_ptr;

		go to next;

undo:
		if old = null		/* if this was the first statement of the prologue       */
		then q = blk->block.prologue; /* the back ptr was null, so use the block.prologue ptr. */
		else q = old->statement.next;
		do q = q repeat q->statement.next while(q^=stmnt);
			q->statement.root = null;
			q->statement.statement_type = null_statement;
		end;

by_value:
		op = create_operator(assign,2);

		if p=null
		then do;
			q = create_symbol(null,null,by_compiler);
			q->symbol.temporary = "1"b;
			op->operand(1) = q->symbol.reference;
		end;
		else	op->operand(1) = p->symbol.reference;

		op->operand(2) = a;
		a  ,
		op = expression_semantics(blk,stmnt,op,this_context);

		if op->node.type=operator_node
		then	op = op->operand(1);

		if descriptors_required
		then	desc_list->list.element(k) = declare_descriptor(blk,stmnt,(op->reference.symbol),
					(op->reference.qualifier),(op->reference.array_ref));

next:
		arg_list->element(k) = a;

		if p_desc_list^=null
		then	p_desc_list = p_desc_list->element(2);
	end;

process_returns:
	if stmnt->statement.statement_type=call_statement
	&  def_context.top
	then	if ^s->symbol.returns
		then	;
		else do;
			do p = s->symbol.dcl_size repeat p->symbol.dcl_size while(p->symbol.entry);
				q = create_operator(std_call,3);
				q->operand(2) = tree->operand(2);
				q->operand(3) = create_operator(std_arg_list,3);
				q->operand(3) = tree->operand(3);

				tree->operand(2) = expression_semantics(blk,stmnt,q,"0"b);
				tree->operand(3) = null;

				if ^p->symbol.returns
				then	goto ret;
			end;

			call print(88);
		end;

	else	if ^s->symbol.returns
		then	call print(263);

	if s->symbol.returns
	then do;
		if arg_list_op=null
		then	tree->operand(3)  ,
			arg_list_op = save_arg_list_op;

		n = n+1;
		a = arg_list;
		arg_list_op->operand(2),arg_list = create_list(n);

		do k = 1 to n-1;
			arg_list->element(k) = a->element(k);
		end;

		q = s->symbol.dcl_size;

		if q->symbol.star_extents then descriptors_required = "1"b;

		if q->symbol.structure | q->symbol.dimensioned | q->symbol.star_extents
		then do;

			/* we get a unique copy of the return_value and declare it to fix bugs 1217 and 1311. */

			q = copy_expression(s->symbol.dcl_size);
			call declare(q);
		end;

		if descriptors_required
		then do;
			desc_list->list.element(n) = copy_expression(q->symbol.descriptor);

			if q->symbol.star_extents
			then do;
				desc_list->list.element(n)->reference.shared = "0"b;
				desc_list->list.element(n)->reference.ref_count = 1;
			end;
		end;

		tree->operand(1)  ,
		arg_list->element(n)  ,
		r = copy_expression(q->symbol.reference);
		r->reference.shared = "0"b;
		r->reference.ref_count = 2;

		if q->symbol.star_extents & (q->symbol.bit|q->symbol.char) & ^ q->symbol.varying
		then do;
			op = create_operator(desc_size,2);
			op->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
			op->operand(2) = desc_list->list.element(n);
			op->operator.processed = "1"b;
			desc_list->list.element(n)->reference.ref_count = 2;
			r->reference.length = op;
		end;
		else	r->reference.length = null;

		if q->symbol.dimensioned | q->symbol.structure | q->symbol.star_extents
		then do;
			def_context.aggregate = q->symbol.dimensioned | q->symbol.structure;

			if def_context.aggregate & def_context.by_name_assignment
			then call print(382);

			if q->symbol.star_extents
			then do;

				/* protect stack extension from shorteninng
				   by other procedures in this expression
				   (fixes 1637)	*/

				stmnt->statement.force_nonquick = "1"b;
				call make_non_quick((stmnt->statement.root),"001"b);
			end;

			q = create_statement(assignment_statement,
				(stmnt->statement.back),null,(stmnt->statement.prefix));
			q->statement.root = tree;

			arg_list->element(n)->reference.ref_count = 3;
		end;
	end;

	if descriptors_required
	then do;
		arg_list_op->operand(3)  = desc_list;
		call check_star_extents(s,arg_list);
	end;

/* Prepare a storage_block temporary large enough to hold
   the argument list.  Caution ****** this code depends on the
   format of the Multics standard argument list.  */

	if arg_list_op^=null
	then do;
		if descriptors_required
		then	n = n+n;

		if s->symbol.internal | s->symbol.variable
		then	n = n+1;

		arg_list_op->operand(1) = declare_temporary(storage_block_type,(n+1)*2,0,null);
	end;

ret:
	return(tree);

/* subroutine to print and error message and abort. */

print: proc(m);

dcl	m fixed bin(15);

dcl	pp ptr;

	if m^=47
	then	call semantic_translator$abort(m,s);

	pp = q;

	if pp->node.type=operator_node then pp = pp->operand(1);
	if pp->node.type=reference_node then pp = pp->reference.symbol;

	if pp->symbol.dcl_type^=by_compiler
	then	call semantic_translator$error(m,q);

	end print;


	end function;




		    generic_selector.pl1            07/31/89  1431.7r w 07/31/89  1338.8       55242



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


generic_selector:	proc(blk,stmnt,tree,subs,context) returns (ptr);

/*	Written 13 November 1972 by Richard A. Barnes */


dcl	(blk,stmnt,tree,subs) ptr;

dcl	(arg_list,a,alt,g,lp,old,p,q,r,st) ptr;
dcl	asym(subs->list.number) ptr;
dcl	(i,j,n_args) fixed bin(17);
dcl	leave_it bit(1) aligned;

dcl	(bool,hbound,null,string,substr) builtin;

%include semant;

%include semantic_bits;

%include list;

%include symbol;

%include reference;

%include token;

%include token_types;

%include nodes;

%include statement;

%include statement_types;

%include operator;

%include op_codes;

%include array;

%include declare_type;

%include picture_image;

/*  */

/* We will compare the arguments of the generic reference to each of the descriptor
   lists in the generic declaration until we get a hit */

/* First, we must get symbol nodes for each of the arguments

   (subs has the arguments in reverse order!) */

begin:
	st = stmnt;
	arg_list = subs;
	n_args = hbound(asym,1);
	g = tree->reference.symbol;

	j = 0;
	do i = n_args to 1 by -1;
		j = j + 1;
		leave_it = "0"b;
		old = st->statement.back;	/* prepare to nullify statements
					   generated for the j-th argument */
		this_context = "01"b;
		a = arg_list->list.element(i);
		if a->node.type = operator_node
		then do;
			if a->operator.op_code = assign /* assuming only kind of assignment is to t0 */
			     then arg_list->list.element(i) = a->operand(2);
			go to by_value;
		     end;
		if a->node.type = token_node
		     then if a->token.type & is_constant
			then do;
				leave_it = "1"b;
				go to by_value;
			     end;
		q = copy_expression((a));
		if q->node.type = reference_node
		     then if ^q->reference.shared
			then q->reference.ref_count = q->reference.ref_count - 1;
		q = expression_semantics(blk,st,q,this_context);
		if q->node.type ^= reference_node
		     then go to undo;
		if q->reference.symbol->symbol.constant
		     then go to undo;
		a = q;
		asym(j) = a->reference.symbol;
		go to next;

undo:		do q = old->statement.next repeat q->statement.next while (q^=st);
			q->statement.root = null;
			q->statement.statement_type = null_statement;
		end;

by_value:
		a = create_operator(assign,2);
		q = create_symbol(null,null,by_compiler);
		q->symbol.temporary = "1"b;
		a->operand(1) = q->symbol.reference;
		a->operand(2) = arg_list->list.element(i);
		a = expression_semantics(blk,st,a,this_context);
		q = a;
		if q->node.type = operator_node
		     then q = q->operand(1);
		asym(j) = q->reference.symbol;

next:
		if ^leave_it
		     then arg_list->list.element(i) = a;
	end;

/* Now the search for a suitable entry begins */

	do alt = g->symbol.general
	     repeat alt->list.element(3) while (alt ^= null);
		i = 0;
		do lp = alt->list.element(2) repeat lp->list.element(2) while (lp ^= null);
			i = i + 1;
			if i > n_args
			     then go to try_another;
			if lp->list.element(1) ^= null
			     then if ^compare_generic(asym(i),(lp->list.element(1)))
				     then go to try_another;
		end;
		if i = n_args then go to hit;

try_another:
	end;

/* We have failed to find a match */

	call semantic_translator$abort(65,tree);

/* We've got an entry reference, so let's build a std_call operator and process it */

hit:
	p = create_operator(std_arg_list,3);
	p->operand(2) = arg_list;
	q = create_operator(std_call,3);
	r = copy_expression(alt->list.element(1));
	q->operand(2) = expression_semantics((g->symbol.block_node),st,r,"0"b);
	q->operand(3) = p;
	q = expression_semantics(blk,st,q,context);
	stmnt = st;
	return(q);

/*  */
/* compare_generic checks to see if an argument fits the description given for a
   specific alternative in the generic declaration */

compare_generic:	proc(pa,pg) returns(bit(1) aligned);
dcl	(pa,pg) ptr;
dcl	(a,g,as,gs) ptr;
dcl	(genbits,argmask) bit(72) aligned;
dcl	asize fixed bin(24);
dcl	ascale fixed bin(7);
dcl	1 genmask aligned based(addr(genbits)),
		2 attributes unaligned like symbol.data_type,
		2 misc_attributes unaligned like symbol.misc_attributes;

begin:
	a = pa;
	g = pg;

	genbits = substr(string(g->symbol.attributes),1,72);
	genmask.precision = "0"b;
	argmask = substr(string(a->symbol.attributes),1,72) & genbits;
	if bool(genbits,argmask,"0110"b)	/* exclusive or */
	     then go to fail;

	if g->symbol.variable_arg_list
	     then if ^a->symbol.variable_arg_list
		     then go to fail;
	if g->symbol.non_varying
	     then if ^a->symbol.non_varying
		     then go to fail;

	if g->symbol.precision
	then do;
		asize = a->symbol.c_dcl_size;
		if asize < g->symbol.c_dcl_size
		     then go to fail;
		if asize > g->symbol.pic_size
		     then go to fail;
		if g->symbol.fixed
		then do;
			ascale = a->symbol.scale;
			if ascale < g->symbol.scale
			     then go to fail;
			if ascale > g->symbol.pic_scale
			     then go to fail;
		     end;
	     end;

	if g->symbol.array ^= null
	     then if g->symbol.array->array.number_of_dimensions ^= a->symbol.array->array.number_of_dimensions
		     then go to fail;

	if g -> symbol.picture
	then if g -> symbol.general -> reference.symbol -> symbol.initial -> picture_image.chars
	     ^= a -> symbol.general -> reference.symbol -> symbol.initial  -> picture_image.chars
	     then go to fail;

	if g->symbol.structure
	then do;
		gs = g->symbol.son;
		as = a->symbol.son;
		do while (gs ^= null);
			if as = null
			     then go to fail;
			if ^compare_generic(as,gs)
			     then go to fail;
			as = as->symbol.brother;
			gs = gs->symbol.brother;
		end;
		if as ^= null
		     then go to fail;
	     end;

/* We've passed the test */

	return("1"b);

/* We've flunked the test */

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



		    io_data_list_semantics.pl1      07/31/89  1431.7r w 07/31/89  1338.8      271530



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


io_data_list_semantics:proc(b,s_param,t_param);

/* updated 12-11-72 by PAB to make way for pictures */
/* Modified 780616 by PG for unsigned */
/* Modified Dec 1978 by David Spector for new 'set' xref format */




	dcl (trans_op,format_op) bit(9) aligned;	/* particular transmission operator */
	dcl  context_with_top_bit_on bit(36) init("000001000000000000000000000000000000"b)
		internal static options(constant) aligned;
	dcl decode_complex_fun(2) bit(9) aligned init(real_fun,imag_fun);

	dcl p_str char(256) varying aligned;
	dcl prefix bit(12) aligned;
	dcl (p,q,r,s,tt,tp,jp,op,bx,vp,pa_ptr,rr,pp,wp,vs,uncomplex_temp,format_ptr,length_ptr,ip,c_format_ptr,q2,
	     loop_ptr) ptr;

	dcl ctl_pointer(64) ptr unaligned;

	dcl 1 format_list_ptr_table(64) aligned,
	     2 it_factor fixed bin(31),
	     2 f_ptr pointer unaligned;
	dcl (nss,ri,sy) ptr;
	dcl (i,j,ki,k,n,constant_operands,pti,ctli,wi,si,de,pa_opnum,
	peti,first_peti,op_num,var_cnt,num_eaten,data_item_index,cur_rep,ctl_cnt) fixed bin(15) ;
	dcl c_length fixed bin (31);
	dcl bbin35 fixed bin(35) based;
	dcl (null,string,substr,hbound) builtin;
	dcl pl1_stat_$ok_list ptr external;
	dcl (get_of_noncomputational,data_format_found) bit(1) aligned ;
	dcl no_quick_edit bit(1) aligned init("0"b);	/* flag to disqualify put_edit_trans's from becoming put_fields */
	dcl (b,s_param,t_param) ptr;
	dcl t ptr;
	dcl (flt,fltt) ptr;
	dcl (fop,pa_type) bit(9) aligned;


/* program */

	s=s_param;
	prefix=s->statement.prefix;
	t=t_param;
	nss=s->statement.next;
	trans_op=t->operator.op_code;
	jp=t->operator.operand(1);

	if trans_op=get_data_trans then goto get_data_;

	if trans_op=get_edit_trans then goto edit_loop_;
	if trans_op=put_edit_trans then goto edit_loop_;

	if jp=null
	then	if trans_op=put_data_trans
		then	do;
			bx=b;
			     do while(bx^=null);
			     bx->block.get_data="1"b;	/* this means put block in S.T. */
			     bx=bx->block.father;
			     end;
			end;
		else;
	else call io_join_semantics(jp);

exit:	return;

edit_loop_:



	r=create_statement(assignment_statement,(nss->statement.back),null,prefix);
	/* make a format statement,
	   set PS.newformat and set PS.special_list_p=addr(format) */

	if b->block.plio_ps->list.element(32) =  null 	/* ps.new_format is unique in that both compiled 	*/
	then do;					/* code and plio runtime touch it.  Therefore we 	*/
		tt=create_symbol(null,null,by_compiler);/* cant let the optim. remove apparently redundent*/
		tt->symbol.binary,			/* assgnmts to it in the code.  To do this we	*/
		tt->symbol.fixed,			/* create a dummy symbol defined on it,thereby	*/
		tt->symbol.aligned,			/* making ps.new_format aliasable and hence	*/
		tt->symbol.overlayed,		/* unoptimizable.				*/
		tt->symbol.aliasable,
		tt->symbol.defined="1"b;
		tt->symbol.c_dcl_size=15;
		call declare(tt);

		rr=tt->symbol.reference;
		rr->reference.units=word_;
		rr->reference.c_offset=30;
		rr->reference.qualifier=copy_expression((b->block.plio_ps->list.element(1)->symbol.reference));
		b->block.plio_ps->list.element(32)=rr;
	end;

	r->statement.processed,r->statement.generated="1"b;

		r->statement.root,tt=create_operator(join,2);
			op,tt->operator.operand(1)=create_operator(assign,2);
			op->operator.operand(2)=declare_constant$integer(1);
			op->operator.operand(1)=b->block.plio_ps->list.element(ps_new_format+2);

			op,tt->operator.operand(2)=create_operator(assign,2);
			op->operator.operand(1)=b->block.plio_ps->list.element(ps_special_list+2);
			q,op->operator.operand(2)=create_operator(addr_fun,2);
			q->operator.operand(1)=declare_temporary(pointer_type,0,0,null);
			r=create_statement(format_statement,(nss->statement.back),null,prefix);
			r->statement.processed,r->statement.generated="1"b;
			tp=create_symbol(b,null,by_compiler);
			tp->symbol.constant,tp->symbol.format="1"b;
			tp->symbol.initial=r;	/* points at the format statement */
			q->operator.operand(2)=tp->symbol.reference;
			tp,r->statement.root=t->operator.operand(2);	/* format list */
			call io_data_list_semantics$format_list_semantics(b,r,tp);



	call io_join_semantics(jp);


end_edit_loop_:
	if trans_op=put_edit_trans	/* try to replace slow put_edit_tras with fast put_fields	*/
	then if ^no_quick_edit then do;
		pti = 0;
		call format_list_process(tp);	/* which builds an array of simple  format items	*/
		goto make_quick_puts;	/* which replace the put_edit_tras	*/
		end;
punt:
exit_2:
	if t->operator.operand(3)=null  then goto exit;
	t=t->operator.operand(3);		/* next (DL)(FL) pair */
	jp=t->operator.operand(1);
	goto edit_loop_;

/*  */
/*  This block of code creates a series of put_fields and put_field_chks instead of the orig. put_edit_tras */


make_quick_puts:

string(context) = "0"b;

r->statement.next->statement.root = expression_semantics(b,s_param,(r->statement.next->statement.root),context);

jp = r->statement.next->statement.root;

if jp->operator.op_code = join
then var_cnt = jp->operator.number;
else var_cnt = 1;

cur_rep = 0;
ctl_cnt = 0;
peti = 0;
data_format_found = "0"b;
do data_item_index = 1 to var_cnt;

next_format:
	call get_next_format;	/* this subroutine sets format_op */
	if format_op >= x_format
	then if format_op <= line_format
	     then do;
		ctl_cnt = ctl_cnt+1;
		if ctl_cnt>64 then goto punt;
		goto next_format;
		end;

	data_format_found = "1"b;
	ctl_cnt = 0;
	if jp->operator.op_code=join	/* jp points to the root of the ass. stat. after the format stat */
	then vp = jp->operand(data_item_index);
	else vp = jp;

	if vp->node.type ^= operator_node
	then goto err495;

	if vp->operator.op_code ^= put_edit_trans
	then do;
		if vp->operator.op_code = do_fun
		then goto punt;	/* an implied do-loop was here */
		if vp->operator.op_code = join
		then goto punt;	/* a structure was found here	*/
				/* maybe can be handled in future,one problem */
				/* is knowing length of output of conversion */

		if vp->operator.op_code = loop
		then do;	/* an array was expanded here	*/

			num_eaten = expand_loop_set_ptr(vp,vp,ip); /* the ip arg is a dummy, we dont use it here */
			first_peti = peti;
			do i = 1 to (num_eaten-1);
				call get_next_format;
				if format_list_ptr_table(first_peti).f_ptr ^=
				   format_list_ptr_table(peti).f_ptr
				then if ^compare_format((format_list_ptr_table(first_peti).f_ptr),
					(format_list_ptr_table(peti).f_ptr))
					then goto punt;	/* not all conversions for this item = */
				end;
		  	end;
		else goto err495;
		end;
	end;
cur_rep = 0;
ctl_cnt = 0;
peti = 0;
do data_item_index = 1 to var_cnt;

next_format_this_data_item:

	call get_next_format;
	op_num = format_ptr->operator.number;
	if format_op = skip_format
	then	ctli = 1;
	else	if format_op = column_format
		then	ctli = 2;
		else	if format_op = page_format
			then	ctli = 3;
			else 	if format_op = line_format
				then	ctli = 4;
				else	if format_op = x_format	/* I treat it as a control format */
					then ctli = 5;
					else ctli = 0;	/* not a control format */

	if ctli>0
	then do;
	     pp = create_operator(put_control,2);
	     pp->operand(1) = declare_constant$integer((ctli));
	     if op_num > 2
	     then pp->operand(2)=copy_unique_expression((format_ptr->operand(3)));
	     else pp->operand(2)=declare_constant$integer(1);	/* we'll be safe but some error checking could be done here	*/
	     ctl_cnt = ctl_cnt + 1;
	     ctl_pointer(ctl_cnt) = pp;
	     goto next_format_this_data_item;
	     end;

	else do;

		do op_num = op_num repeat op_num-1 while (format_ptr->operand(op_num) = null);
		     end;		/* treat null operands as if they dont exist & apply the defaults	*/
		if jp->operator.op_code=join	/* jp points to the root of the ass. stat. after the format stat */
		then do;
		     pa_type = operator_node;
		     pa_opnum = data_item_index;
		     pa_ptr = jp;
		     ip = jp->operand(data_item_index);
		     end;
		else do;
		     pa_type = statement_node;
		     pa_ptr = r->statement.next;
		     ip = jp;
		     end;

		if ip->operator.op_code = put_edit_trans
		then do;
		     vp = ip->operand(2);
		     loop_ptr = null;
		     end;
		else do;	/* we have a loop operator here,meaning an array */
		     num_eaten = expand_loop_set_ptr(ip,vp,loop_ptr);
		     do i = 1 to (num_eaten-1);
			call get_next_format;
			end;
		     end;

		if format_op = a_format
		|  format_op = b_format
		then 	do;

			if format_op=a_format
			then pp = vp;
			else pp= convert$from_builtin(vp,bit_type);	/* convert the string to bits */
			p = create_operator(put_field,2);

			if op_num > 2  	/* means there is a length given	*/
			then do;
				if format_ptr->operand(3)->node.type = reference_node
				then if format_ptr->operand(3)->reference.symbol->symbol.constant
				     then do;	/* declare the temporary with this constant length */
					c_length = format_ptr->operand(3)->reference.symbol->symbol.initial->bbin35;
					length_ptr = null;	/* no dcl_size if there is a c_dcl_size */
					goto lengths_set;
					end;

				/* needs a dcl_size & a c_dcl_size of zero */
				c_length = 0;
				length_ptr = copy_unique_expression((format_ptr->operand(3)));
		lengths_set:
				p->operand(2) = convert$to_target_fb(pp,declare_temporary(char_type,
					      c_length,0,length_ptr));
				end;	/* the target temp. assignment does the check for size cond. */
			else p->operand(2) = convert$from_builtin(pp,char_type); /* no length, no check */

			if p->operand(2)->node.type=operator_node
			then pp = p->operand(2)->operand(1);
			else pp = p->operand(2);

			if op_num > 2
			then if length_ptr = null
			     then wp = format_ptr->operand(3);	/* just use op(3) for width */
			     else wp = share_expression(length_ptr);
			else if pp->reference.varying_ref
			     then do;
				wp = create_operator(length_fun,2);
				wp->operand(1) = declare_temporary(integer_type,max_length_precision,
						0,null);
				wp->operand(2) = share_expression((p->operand(2)));
				end;
			     else if pp->reference.length = null /* use ref length */
				then wp = declare_constant$integer((pp->reference.c_length));
				else wp = share_expression((pp->reference.length));
			p->operand(1) = wp;	/* op(1) of put_field is length of output string */
			end;

		else	if ^pef_format(vp)		/* must be complex (c_format) format item */
			then do;
				if vp->node.type = operator_node
				then vs = vp->operand(1)->reference.symbol;
				else vs = vp->reference.symbol;
				c_format_ptr = format_ptr;
				wp = create_operator(join,2);
				if vs->symbol.complex 
				then do;
					uncomplex_temp = declare_temporary(substr(string(vs->symbol.attributes),1,36)
						       & ^unaligned_mask & ^complex_mask | aligned_mask | real_mask,
						       (vs->symbol.c_dcl_size), (vs->symbol.scale), null);
					do j = 1 to 2;
					     call get_next_part_of_cplx_format(j+2);
					     q = create_operator(decode_complex_fun(j),2);
					     q->operator.processed = "1"b;
					     q->operand(1) = uncomplex_temp;
					     if j = 1
					     then q->operand(2) = vp;
					     else q->operand(2) = share_expression(vp);
					     if ^pef_format(q)
					     then goto err170;
					     wp->operand(j) = p;
					     end;
					end;

				else if vs->symbol.char
				then do j = 1 to 2;
					/* The point of this code is to change the temp on the LHS */
					/* of the bottom assign_op to a complex version of itself, and */
					/* to insert a real or imag operator above that assign_op, */
					/* with the old version of the temp on it's LHS	*/
					call get_next_part_of_cplx_format(j+2);
					if j = 1
					then if ^pef_format(vp)
					     then goto err170;
					     else;
					else if ^pef_format(share_expression(vp))
					     then goto err170;
					q = p->operand(2)->operand(2)->operand(1);
					p->operand(2)->operand(2)->operand(1) = force_cplx_temp(q);
					q2 = create_operator(decode_complex_fun(j),2);
					q2->operator.processed = "1"b;
					q2->operand(1) = q;
					q2->operand(2) = p->operand(2)->operand(2);
					p->operand(2)->operand(2) = q2;
					wp->operand(j) = p;
					end;

				else do;
					call get_next_part_of_cplx_format(3);
					if ^pef_format(vp) then goto err170;
					wp->operand(1) = p;
					call get_next_part_of_cplx_format(4);
					if ^pef_format(create_token("0",dec_integer)) then goto err170;
					wp->operand(2) = p;
					end;



				p = wp;
				end;

			if ctl_cnt>0
			then do;
			     pp = create_operator(join,(ctl_cnt+1));
			     do j=1 to ctl_cnt;
				pp->operand(j)=ctl_pointer(j);
				end;
			     if loop_ptr = null
			     then pp -> operand(ctl_cnt+1) = p;
			     else do;
				loop_ptr -> operand(1) = p;
				pp -> operand(ctl_cnt+1) = ip;
				end;
			     p=pp;
			     ctl_cnt = 0;
			     end;
			else if loop_ptr ^= null
			     then do;
				loop_ptr -> operand(1) = p;
				p = ip;
				end;

			if pa_type = statement_node
			then pa_ptr->statement.root = p;
			else pa_ptr->operator.operand(pa_opnum) = p;
		end;
	end;

goto exit_2;

/**/
expand_loop_set_ptr:proc(op_param,vp_param,pa_param) returns(fixed bin (31));

dcl (op_ptr,op_param,vp_param,pa_param)  pointer;

op_ptr=op_param;
if op_ptr->operator.operand(4)->node.type ^= reference_node
then  goto punt;

if ^op_ptr->operator.operand(4)->reference.symbol->symbol.constant
then goto punt;
else if op_ptr->operator.operand(1)->operator.op_code = put_edit_trans
     then do;
	pa_param = op_ptr;
	vp_param = op_ptr->operator.operand(1)->operator.operand(2);
	return((op_ptr->operator.operand(4)->reference.symbol->symbol.initial->bbin35));
	end;

    else if op_ptr->operator.operand(1)->operator.op_code = loop
	then return((op_ptr->operator.operand(4)->reference.symbol->symbol.initial
			->bbin35 * expand_loop_set_ptr((op_ptr->operator.operand(1)),vp_param,pa_param)));
	else goto punt;

end expand_loop_set_ptr;



/* Sees if format list is entirely known at compile time and produces an expanded array of simple format items */


format_list_process:proc(p_param);

dcl (h,iteration_factor,i,j) fixed bin, (p,p_param,q) ptr;

do p = p_param repeat p->operand(1) while (p ^= null);

	if p->operator.op_code=e_format		/* e,f_formats need the creation of a picture so all */
	|  p->operator.op_code=f_format		/* fields must be known at compile time, for the others */
	then constant_operands=p->operator.number;	/* only the iteration factor must be known.	*/
	else if p->operator.op_code = r_format
	     then constant_operands = 3;
	     else constant_operands=2;

	do i = 2 to constant_operands;
		if p->operand(i) ^= null
		then if p->operand(i)->node.type ^= reference_node
		     then goto punt;
		     else if ^p->operand(i)->reference.symbol->symbol.constant
			then goto punt;	/* Throughout this proc as soon as we give up on quick i/o we */
		end;			/* just goto punt.	*/

	if p->operand(2) ^= null
	then iteration_factor = p->operand(2)->reference.symbol->symbol.initial->bbin35;
	else iteration_factor=1;
	if p->operator.op_code = r_format
	then	do;
		q2 = p->operand(3)->reference.symbol;
		q2->symbol.initial->statement.root,
		q = expression_semantics((q2->symbol.block_node),(q2->symbol.initial),
				(q2->symbol.initial->statement.root),(context_with_top_bit_on));
					/* the last arg MUST be passed by value cause it is an	*/
					/* in/out arg yet dcl'd options(constant) !!!		*/
		do j=1 to iteration_factor;
			call format_list_process(q);
			end;
		end;
	else	if p->operator.op_code = l_parn
		then	do;
			q = p->operand(3);	/* operand(3) is the true format item */
			do j=1 to iteration_factor;
				call format_list_process(q);
				end;
			end;

		else do;
			if p->operator.op_code = c_format
			then do;
					/* op(3) is real form. item, op(4) is imag form. item */
				if p->operator.number = 2 then goto punt;

				do h=3 to p->operator.number;
	
					if p->operand(h)->operand(2) ^= null then goto punt;
					do k=3 to p->operand(h)->operator.number;
						if p->operand(h)->operand(k)^=null
						then if p->operand(h)->operand(k)->node.type ^= reference_node
						     then goto punt;
						     else if ^p->operand(h)->operand(k)->reference.symbol->symbol.constant
							then goto punt;
						end;
	
					end;
				end;
			else if p->operator.op_code = bn_format
			     then goto punt;
	 		     else	if p->operator.op_code=e_format
			     	then	if p->operator.number > 4
			     		then	if p->operand(5)^=null
			     			then 	if p->operand(5)->reference.symbol->symbol.initial
			     				->bbin35 <= p->operand(4)->reference.symbol->symbol.initial
			     				->bbin35
			     				then goto punt;	/* sig digits < dec prec !! */


			if pti>hbound(format_list_ptr_table,1)-1 then goto punt;
			pti = pti+1;
			format_list_ptr_table(pti).it_factor = iteration_factor;
			format_list_ptr_table(pti).f_ptr = p;
			end;

		end;
end;


/*      */
/* Process p_format,e_format,f_format items, return "0"b if not one of those types.	*/


pef_format:proc(vp_param) returns(bit(1) aligned);

dcl	(vp,vp_param) ptr;

vp = vp_param;

if format_op=f_format
then	do;

	if  op_num > 3	/* op(4) is the decimal precision (de)	*/
	then de = format_ptr->operand(4)->reference.symbol->symbol.initial->bbin35;
	else de = 0;	/* 0 is the default decimal precision	*/
	if  op_num > 4	/* op(5) is the scale factor (ki)	*/
	then ki = format_ptr->operand(5)->reference.symbol->symbol.initial->bbin35;
	else ki = 0;	/* 0 is the default scale factor	*/
	wi = format_ptr->operand(3)->reference.symbol->symbol.initial->bbin35;  /* op(3) is the field width (wi)*/

	if de<0				/* These are language defined errors. */
	then goto err496;
	else if wi<0
	     then goto err496;
	     else if wi=0 
		then goto ef_null;
		else	if de>0
			then	if wi<de+2
				then goto err496;
	if de=0
	then p_str = copy("-",wi-1)||"-9";
	else p_str = copy("-",wi-de-2)||"-9.v"||copy("9",de);

	p = create_operator(put_field_chk,3);

	rr = declare_picture_temp((p_str),(-ki),"0"b,"0"b);
	p->operand(1) = declare_constant$integer((rr->reference.c_length-1));
	p->operand(2) = convert$to_target_fb(vp,rr);
	if p->operand(2)->operand(2)->node.type = operator_node
	then if p->operand(2)->operand(2)->operator.op_code = assign
	     then p->operand(2)->operand(2)->operator.op_code = assign_round;
	p->operand(3) = declare_constant$integer((wi-min(max_p_dec,wi)));
	return("1"b);
	end;

if	format_op = e_format
then	do;

	wi = format_ptr->operand(3)->reference.symbol->symbol.initial->bbin35;
	if wi = 0 then goto ef_null;
	if op_num > 3
	then de = format_ptr->operand(4)->reference.symbol->symbol.initial->bbin35;
	else do;
		p = convert$from_builtin(vp,(float_mask|decimal_mask|aligned_mask|real_mask));
		if p->node.type = operator_node
		then p = p->operand(1);
		de = p->reference.symbol->symbol.c_dcl_size-1;
	     end;
	if op_num > 4
	then si = format_ptr->operand(5)->reference.symbol->symbol.initial->bbin35;
	else si = de+1;

	if de=0
	then	if si<0
		then goto err496;
		else	if wi-si-5<0
			then goto err496;
			else;
	else	if si-de<0
		then goto err496;
		else	if wi-si-6<0
			then goto err496;

	if de ^= 0
	then p = create_pic_ass_pf(copy("b",wi-si-6)||copy("-",si-de)||"9.v"
			||copy("9",de)||"es999",vp,0,"0"b,"1"b);
	else	p = create_pic_ass_pf(copy("b",wi-si-5)||copy("-",si)||"9ves999",vp,0,"0"b,"1"b);
	return("1"b);
	end;
if format_op = picture_format
then do;
	p = format_ptr->operand(3)->reference.symbol;
	p_str = string(p->symbol.initial->picture_image.chars);
	p = create_pic_ass_pf(p_str,vp,(p->symbol.initial->picture_image.scalefactor),"0"b,"0"b);
		/* The complex bit, arg 3, can be "0"b because there is no such thing as a complex	*/
		/* picture in a format list -- there is no way to express it in a pl1 program		*/
	return("1"b);
	end;
return("0"b);

ef_null:
	p = create_operator(nop,0);
	return("1"b);

err496:
	k = 496;
	call semantic_translator$abort(k,null);
end;

/*    */
create_pic_ass_pf:proc(v_str,vq,scalefac,complex_bit,pfc) returns(ptr);

dcl (p,q,vq) pointer;
dcl scalefac fixed bin(31);
dcl v_str char(256) varying aligned;
dcl (pfc,complex_bit) bit(1) aligned;

q = declare_picture_temp((v_str),scalefac,complex_bit,"0"b);
if pfc
then do;
	p = create_operator(put_field_chk,3);
	p->operand(1) = declare_constant$integer((q->reference.c_length-1));
	p->operand(3) = declare_constant$integer(0);
     end;
else do;
	p = create_operator(put_field,2);
	p->operand(1) = declare_constant$integer((q->reference.c_length));
     end;

p->operand(2) = convert$to_target_fb(vq,q);
return(p);
end;
/*  */
format_list_semantics:entry(b,s_param,t);

	b -> block.why_nonquick.format_statement = "1"b;
	b -> block.no_stack = "0"b;

	fop=t->operator.op_code;

	do i=1 to t->operator.number;
	flt=t->operand(i);
	if flt=null then goto end_f_loop;

	if i=1 then
		do;
f_list:
		call io_data_list_semantics$format_list_semantics(b,s_param,flt);
		goto end_f_loop;
		end;

	if i=2 then
		do;
int:
		if flt->node.type=token_node
		then if flt->token.type^=is_identifier then goto convert_to_integer;
fl_process:
		string(context)="0000"b;
		flt = expression_semantics(b,s_param,flt,context);
		call make_non_quick (flt, "0001"b);	/* block.why_nonquick.invoked_by_format */

convert_to_integer:
		flt=convert$to_target(flt,declare_temporary(integer_type,default_fix_bin_p,0,null));
		goto end_f_loop;
		end;

	if i=3 then
		do;
		if fop=l_parn then goto f_list;
		if fop=r_format then
			do;
			string(context)="0000"b;
			flt = expression_semantics(b,s_param,flt,context);
			if def_context.aggregate then goto err171;
			call make_non_quick (flt, "0001"b);	/* block.why_nonquick.invoked_by_format */
			if flt->node.type=operator_node then fltt=flt->operand(1);
			else fltt=flt;
			if fltt->node.type^=reference_node then goto err171;
			if ^fltt->reference.symbol->symbol.format then goto err171;
			goto end_f_loop;
			end;

		if fop=c_format then
			do;
c_form:
			if flt->node.type^=operator_node then goto err170;
			if flt->operator.op_code^=e_format  then
			if flt->operator.op_code^=f_format  then
			if flt->operator.op_code^=picture_format then goto err170;
			goto f_list;
			end;
		if fop=picture_format then goto end_f_loop;	/* pc is e reference node already */
		goto int;
		end;

	if i=4 & fop=c_format then goto c_form;
	goto int;				/* all other cases require an integer */

err171:
	k=171;
	goto sig_format_err;

err170:
	k=170;
sig_format_err:
	call semantic_translator$error(k,null);

end_f_loop:
	t->operand(i)=flt;
	end;

	return;

/*  */
get_data_:
		/* the whole job is done here; we produce
		   directly for code generator.  */

	if jp=null then			/* (gdt(1))=null means oklist=const(0) */
		do;
		jp,t->operand(1)=create_operator(join,0);
		goto full_symtab;
		end;
	n=jp->operator.number;
	if n=0 then
		do;
full_symtab:
		bx=b;
		do while(bx^=null);
		bx->block.get_data="1"b;
		bx=bx->block.father;
		end;
		goto gdexit;
		end;

	do i=1 to n;
			/* in each case make sure that the operand is
				(a) reference to a variable, not to a constant or expression
				(b) that the ref is not subscripted or qualified
					i.e., no   p->x    or    x(j,4)
				(c) that ref is string/arith
				(d) or is array/structure of string/arith
			   and set "set" and "put_in_symtab" for ref and ref's containing structures
			*/
	ri=jp->operand(i);
	if ri->node.type=token_node then
		do;
		string(context)="0"b;
		ri = expression_semantics(b,s,ri,context);
		if ri->node.type ^= reference_node then goto err469;
		goto gdcommon;
		end;
	if ri->node.type ^= reference_node then goto err469;
	if ri->reference.qualifier ^= null then goto err469;
	if ri->reference.offset ^= null then goto err469;
	string(context)="0"b;
	ri = expression_semantics(b,s,ri,context);

	/* ********************************
	 *
	 *  There is an unexplained problem
	 *  with defined items.  BASIS says
	 *  that any defined item is OK here,
	 *  AG94 allows string-overlay and
	 *  non-asterisk simple defined.
	 *
	 ************************************ */


gdcommon:
	/* there were no subscripts or qualifiers */
	sy=ri->reference.symbol;

	if def_context.aggregate then if sy->symbol.defined
		then ri=defined_reference(b,s,ri,null,sy,"0"b);


	call walk(sy);
	if get_of_noncomputational
	then go to err470;

	go to ok;

err469:
	k=469;
	if ri->node.type^=reference_node then
		do;
		k=473;		/* err470 is called only with a reference */
		sy=null;
		end;
	else sy=ri->reference.symbol;
	goto gderr;

err470:
	k=470;
gderr:
	call semantic_translator$error(k,sy);
	ri=null;
ok:
	jp->operand(i)=ri;	/* it has been altered by expression semantics */
	end;
gdexit:
	bx=create_list(2);
	bx->list.element(1)=pl1_stat_$ok_list;
	pl1_stat_$ok_list=bx;
	bx->list.element(2)=jp;
			/* making a list of the oklists as
			   (next,join) pairs */
	goto exit;

/*  */


    walk:	proc(sp);
	dcl (sp,tp) ptr;

	get_of_noncomputational = "0"b;

	tp=sp->symbol.father;
		do while (tp^=null);
		tp->symbol.put_in_symtab,
		tp->symbol.set="1"b;
		if tp->symbol.cross_references ^= null
		then tp->symbol.cross_references->cross_reference.set_reference = "1"b;
		tp=tp->symbol.father;
		end;

    down:	entry(sp);

	sp->symbol.put_in_symtab,
	sp->symbol.set="1"b;
	tp = sp -> symbol.cross_references;
	if tp ^= null then tp -> cross_reference.set_reference = "1"b;

	tp=sp->symbol.son;
	if tp = null				/* at bottom? */
	then if (substr (string (sp -> symbol.attributes), 1, 36) & computational_mask) = ""b
	     then get_of_noncomputational = "1"b;

	do while (tp ^= null);
	     call down(tp);
	     tp=tp->symbol.brother;
	end;
	return;

end walk;







    label_of_statement:	proc(s) returns(ptr);
	/* returns ptr to label of statement which is created
	   and whose address is returned in "s"  */
	dcl (s,r) ptr;
	s=create_statement(assignment_statement,(nss->statement.back),null,prefix);
	s->statement.processed,s->statement.generated="1"b;

	r=create_label(b,null,by_compiler);
	r->label.statement=s;
	s->statement.labels=create_list(2);
	s->statement.labels->list.element(2)=r;
	return(r);
end;

/*   */
    io_join_semantics:	proc(t);

	dcl t ptr;

	dcl (randi,s,op,q,tt) ptr;
	dcl (i,j,k,l,m,n) fixed bin(15);

	j=1;
	if t=null then goto join_finish;
	n=t->operator.number;

join_loop:
	do i=j to n;
	randi=t->operand(i);
	if randi->node.type=operator_node then
		if randi->operator.op_code=do_fun
		then	do;
			k=i-1;
			no_quick_edit = "1"b;
			goto new_join;
			end;
	op=create_operator(trans_op,2);
	op->operand(2)=randi;





	t->operand(i)=op;		/* we insert transmission operator */
	end;
	k=n;

new_join:
		/* if no elements, nothing
		   if one element, no join: direct "assignment"
		   if >1 elements, make a new join, but
		   if n  elements, use original join  */

	l=k+1-j;
	if l=0 then goto process_do;

	s=create_statement(assignment_statement,(nss->statement.back),null,prefix);
	s->statement.generated="1"b;

	if l=1 then
		do;
		s->statement.root=t->operand(j);
		goto process_do;
		end;
	if l=n then	/* simple join */
		do;
		s->statement.root=t;
		goto join_finish;
		end;

	s->statement.root,
	q=create_operator(join,l);

		do m=1 to l;
		q->operand(m)=t->operand(m+j-1);
		end;

process_do:
	if k=n then goto join_finish;

	s=create_statement(do_statement,(nss->statement.back),null,prefix);
	s->statement.generated="1"b;
	s->statement.root=randi;
	tt=randi->operand(1);
	call io_join_semantics(tt);


	randi->operand(1)=label_of_statement(s);
	s->statement.processed="0"b;	/* ? */
	s->statement.statement_type=null_statement;

	j=k+2;
	if j>n then goto join_finish;	/* skipping over the "do" leaves nothing */
	goto join_loop;

join_finish:

	end io_join_semantics;
/**/
get_next_format:proc ;

	do while (cur_rep = 0);
		peti = peti + 1;
		if peti> pti
		then do;
			if ^data_format_found then goto err497;
			peti = 1;
			end;
		cur_rep = format_list_ptr_table(peti).it_factor;
		end;

	cur_rep = cur_rep-1;

	format_ptr = format_list_ptr_table(peti).f_ptr;
	format_op = format_ptr->operator.op_code;

	end;
/**/
compare_format: proc(pa,pb) returns(bit(1) aligned);

dcl	(pa,pb,a,b) ptr;
dcl	i fixed bin;

	/* since operand(1) is chain ptr and operand(2) is iteration factor,
	   only operands(3-n) are significant for us. */

	a = pa;
	b = pb;

	if a = b then return("1"b);

	if a ^= null
	then if b ^= null
	then if a -> operator.op_code = b -> operator.op_code
	then if a -> operator.number = b -> operator.number
	then do;
	     do i = 3 to b -> operator.number;
		if a -> operand(i) ^= b -> operand(i)
		then if ^ compare_expression((a -> operand(i)),(b -> operand(i)))
		     then go to fail;
		end;
	     return("1"b);
	     end;

fail:	return("0"b);

	end;
/**/


err495:
	k = 495;
	goto idl_err;
err497:
	k = 497;
	goto idl_err;
err427:
	k = 427;
idl_err:
	call semantic_translator$abort(k,null);



/*		*/
force_cplx_temp:proc(q_param) returns(ptr);

dcl	(q,q_param) ptr;

	q = q_param;
	return(declare_temporary(substr(string(q->reference.symbol->
		symbol.attributes),1,36) & ^unaligned_mask & ^real_mask
		| aligned_mask | complex_mask,(q->reference.symbol->
		symbol.c_dcl_size),(q->reference.symbol->symbol.scale),
		null));

end;

get_next_part_of_cplx_format:proc(num);
dcl	num fixed bin(31);

	if c_format_ptr->operator.number < num
	then return;

	format_ptr = c_format_ptr->operand(num);
	format_op = format_ptr->operator.op_code;
	do op_num = format_ptr->operator.number repeat op_num-1 while(format_ptr->operand(op_num) = null);
		end;

	return;

end;

/* include files */

%include semant;
%include picture_image;
%include nodes;
%include system;
%include mask;
%include reference;
%include block;
%include token;
%include token_types;
%include semantic_bits;
%include symbol;


%include boundary;
%include declare_type;
% include label;
%include list;
%include op_codes;
%include operator;
%include statement;
%include statement_types;
%include ps_map;
%include cross_reference;
     end /* io_data_list_semantics */;




		    io_semantics.pl1                10/17/90  1059.1rew 10/17/90  0942.0      289890



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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 bug2164
  2) change(90-08-24,Huen), approve(90-08-24,MCR8187),
     audit(90-09-07,Zimmerman), install(90-10-17,MR12.4-1046):
     pl1_2224: Fix the PL1 compiler use of variables that are targets of "read
     into" statements.
                                                   END HISTORY COMMENTS */


io_semantics:proc(bb,ss,tt) ;
	dcl    (bb,ss,tt) ptr;

	/* Written by P. A. Belmont on 9-29-71
	   called by expression_semantics "on the way down"
	   upon encountering any of the  "outer" io op_codes:
	   get_file,get_string,put_file,put_string,open_file,
	   xxx_file for various xxx's

	   or "inner op_codes:
	   get_list_trans,put_list_trans,get_edit_trans,
	   put_edit_trans,get_data_trans,put_data_trans.
	*/


	/* updated 12-17-74 to make not_bytebuffer in psr.job smarter and to add bit_string bit */

	/* updated 7-31-74 to add propagate_bit at line 913,
		abnormal_return for keyto (release-2,action(19),keyto_join:  */

	/* updated 12-22-77 by P. Krupp to  fix bugs 1657, 1658, 1680          */
	/* Modified 780616 by PG for unsigned */
	/* Modified 790110 by RAB to fix 1813 (referenced but not set not diag for file vars) */
          /* Modified 4-10-87 by RW to fix bug 2164 */

dcl type bit (36);
dcl opcode_temp bit(9) aligned;
dcl (a,b,cs,ns,vs,q,r,s,t,tp,tp1,dp) ptr;
dcl (locate_var,locate_set,locate_size) ptr;
dcl transop bit(9) aligned;
dcl convtype bit(36) aligned;
dcl (i,n,m,PS_offset,lal) fixed bin(15);
dcl no_byte bit(1) aligned;
dcl cbs fixed bin(24);
dcl strlen fixed bin(31);
dcl assign_list(21) ptr;
dcl end_of_join ptr;

/* builtins */

dcl (addr, binary, bit, length, mod, null, substr, string) builtin;

dcl job bit(36) aligned;
dcl job_additions bit(36) aligned;
dcl bb36 bit(36) aligned based;
dcl constsize fixed bin(35);
dcl stringdesc bit(36) aligned;

dcl fab2mod2(7) ptr aligned;
dcl fab2template_b bit(504) aligned based(addr(fab2mod2));
dcl 1 fab2template based(addr(fab2mod2)),
	2 bits bit(36) aligned,
	2 name char(32) aligned,
	2 ( ls,ps,bs ) fixed bin(15),
	2 title168p	ptr;

dcl pl1_stat_$generate_symtab ext bit(1);
dcl pl1_stat_$check_ansi ext bit(1) aligned;

dcl rand_index(35) fixed bin(15) static internal init(2,2,1,4,4, 4,1,1,1,1, 3,1,1,1,1,
					    1,1,1,1,4, 3,3,3,1,1, 1,1,1,2,0,
					    0,0,0,5,0);


/* program */

	t=tt;
	if t->operator.op_code >= terminate_trans then goto main_io_operator;

transmission_operators:

	transop=t->operator.op_code;
	tp=t->operator.operand(2);

	if tp->node.type=operator_node
	then if tp->op_code=join then
		do;
		/* builtin, processing a pseudovariable target
		   of get-list or get-edit, will replace the PV
		   with join(assign(temp,PV),temp,assign(PV,temp)) in the cases
		   onsource, onchar, pageno.  This is because
		   these PVs are implemented as calls instead of
		   as storage references.  io_semantics must
		   now rearange things.

		   builtin must have completely processed its things
		   and operator_semantics must copy the tree ("tt")
		   argument back into the tree-proper. */

		tt=tp;			/* replace GET with JOIN */
		t->operand(2)=tp->operand(2);	/* GET's target is now the "temp"  */
		tp->operand(2)=t;		/*  yielding JOIN(ASSIGN(temp,PV),GET(-,temp),ASSIGN(PV,temp)) */
		tp=t->operand(2);		/* tp points to the target of GET */
		end;

	if tp->node.type=token_node then
		do;
		if ^(transop=put_list_trans|transop=put_edit_trans) then goto err471;
		if (tp -> token.type & is_constant) ^= is_constant
		then go to err472;

		tp, t -> operator.operand (2) = convert (tp, decoded_type (binary (tp -> token.type, 9)));
		end;

	if tp->node.type=operator_node then
		do;
		if ^(transop=put_list_trans|transop=put_edit_trans) then
			goto err471;
		tp=tp->operator.operand(1);
		end;

	if tp->node.type=label_node
		then convtype=local_label_var_type;
	else if tp->reference.symbol->node.type=label_node
		then convtype=local_label_var_type;
	else if tp->reference.symbol->symbol.constant
	     & (tp->reference.symbol->symbol.entry | tp->reference.symbol->symbol.format)
		then convtype=substr(string(tp->reference.symbol->symbol.attributes),1,36);
	else convtype=(36)"0"b;

	if convtype^=(36)"0"b
		then if transop=put_list_trans
			then do;
			t->operator.operand(2)=create_operator(assign,2);
			t->operator.operand(2)->operator.operand(2)=tp;
			t->operator.operand(2)->operator.operand(1),tp=declare_temporary(convtype,0,0,null);
			t->operator.operand(2)->operator.processed="1"b;
			end;
			else call semantic_translator$abort(358,tp);

	if tp->reference.symbol->symbol.picture
	then do;
		tp->reference.symbol->symbol.general->reference.symbol->symbol.allocate = "1"b;

		if transop=put_list_trans
		then do;
			t->operator.op_code = put_field;
			t->operand(1) = declare_constant$integer((tp->reference.c_length));
		     end;
	     end;

	type = substr (string (tp -> reference.symbol -> symbol.attributes), 1, 36);

	if (type & computational_mask) = ""b		/* is the symbol computational? */
	then if (transop = put_data_trans) | (transop = put_list_trans)	/* Not computational, is this a put? */
	     then do;				/* yes. */
			t->operand(1) = declare_descriptor(bb,ss,(tp->reference.symbol),
					(tp->reference.qualifier),"0"b);
			if pl1_stat_$check_ansi
			then do;
				if t->operand(2)->node.type = operator_node
				then	n = 352;
				else	n = 351;
			 	call semantic_translator$error(n,tp);
			end;
		end;
	     else go to err472;

	if transop=put_data_trans then
		do;
		t->operator.operand(1)=tp->reference.subscript_list;
		tp=tp->reference.symbol;
			do while(tp^=null);
			tp->symbol.put_in_symtab="1"b;
			tp=tp->symbol.father;
			end;
		return;
		end;

	if (type & arithmetic_mask) ^= ""b		/* arithmetic? */
	then	if transop=put_list_trans
		then do;
			t->operator.op_code=put_field;
			t->operator.operand(2)=convert$from_builtin((t->operand(2)),char_type);
			t->operand(1)=declare_constant$integer((t->operand(2)->operand(1)->reference.c_length));
			end;
		else t->operand(1)=declare_descriptor(bb,ss,(tp->reference.symbol),(tp->reference.qualifier),"0"b);

	if (type & string_mask) ^= ""b		/* string? */
			/* NOTE: we do NOT make up a descriptor
				in the case of a pictured value.
				The lack of one tips off the code generator. */

	then do;		/* string case - must manufacture a descriptor */
			/* Note: we must here handle a substr as a
			   storage reference (i.e., the symbol of the
			   whole string but a reference with a possibly
			   shorter length).  declare_descriptor would
			   return a descriptor for the whole string;  the
			   situation is _n_o_t analogous to argument passing
			   since in that case a temporary is made.  */

		if tp -> reference.symbol -> symbol.bit
		then if tp -> reference.varying_ref
		     then stringdesc = "1010100"b;	/* descriptor type 20 */
		     else stringdesc = "1010011"b;	/* descriptor type 19 */
		else if tp -> reference.varying_ref
		     then stringdesc = "1010110"b;	/* descriptor type 22 */
		     else stringdesc = "1010101"b;	/* descriptor type 21 */

		substr(stringdesc,8,1)=tp->reference.symbol->symbol.packed;
		q=null;

		if tp->reference.varying_ref then
			do;
			s=tp->reference.symbol;
			if s->symbol.dcl_size=null then
			constsize=s->symbol.c_dcl_size;
			else	do;
				q=copy_expression(s->symbol.dcl_size);
				if s->symbol.refer_extents then
				call refer_extent(q,(tp->reference.qualifier));
				string(context)="0"b;
				q = expression_semantics(bb,ss,q,context);
				end;
			end;

		else	do;	/* non varying */
			if tp->reference.length=null then constsize=tp->reference.c_length;
			else	q=copy_expression(tp->reference.length);
			end;

		if q=null then
			do;
			substr(stringdesc,13,24)=substr(addr(constsize)->bb36,13,24);
			t->operator.operand(1)=declare_constant(stringdesc,arg_desc_type,length(stringdesc),0);
			end;
		else	do;
			dp,t->operator.operand(1)=create_operator(make_desc,3);
			dp->operator.operand(1)=declare_temporary(arg_desc_type,length(stringdesc),0,null);
			dp->operator.operand(2)=declare_constant(stringdesc,arg_desc_type,length(stringdesc),0);
			dp->operator.operand(3)=q;
			end;
		end;

	if transop<=get_edit_trans then
		do;
		tp=tp->reference.symbol;
		call propagate_bit(tp,set_bit);
		call propagate_bit(tp,passed_as_arg_bit);
		end;

	return;

err471:
	n=471;
	goto  abort_trans;

err472:
	n=472;

abort_trans:
	if t->operator.operand(2)->node.type=operator_node then n=n+3;
	call semantic_translator$error(n,tp);
	return;

main_io_operator:
	vs,cs=ss;
	if ss->statement.labels=null then goto keep_statement;
	cs=create_statement((ss->statement.statement_type),ss,null,(ss->statement.prefix));
	cs->statement.root=ss->statement.root;
	ss->statement.root=null;
	ss->statement.statement_type=null_statement;
	return;

keep_statement:
	lal=0;
	end_of_join=null;
	ns=cs->statement.next;
	b=bb;
	if b->block.plio_ps=null then
		do;
		call io_semantics_util$make_ps(b);
		b -> block.why_nonquick.io_statements = "1"b;
		b -> block.no_stack = "0"b;
		end;


		/* Map of PS for the curious:

		PS|00 Stack_Frame_p
		PS|02 Symbol_Table_Top_p
		PS|04 Symbol_Table_Block_p
		PS|06 Format_Area_p
		PS|08 Subscript_List_p
		PS|10 Abnormal_Return_Label
		PS|16 Source_p	(addr(file) or addr(FFSB) or addr(ref))
		PS|18 Special_List_p	/Set_P_p
		PS|20 Copy_File_p
		PS|21			/Variable_Bit_Length
		PS|22 Job
		PS|23 Number
		PS|24 Value_p		/Variable_p
		PS|26 Descriptor
		PS|27 ..........
		PS|28 Offset
		PS|29 Prep_sw		/Locking_sw
		PS|30 New_Format_sw
		.....
		PS|48 Key (char(256) varying  )
							*/
	m=t->operator.number;
		t->operator.operand(m)=convert((t->operator.operand(m)),bit_type);
		job=t->operator.operand(m)->reference.symbol->symbol.initial->bb36;
		job_additions="0"b;
		/* See: io_statement_parse;  the options etc are recorded as a bit 36. */
	m=m-1;

			/* Now handle the special cases and then call expression_semantics
			   for all the ordinary operands. Check that all items but
			   into and from are scalar. */

	if substr(job,4,3)^="0"b then				/* data,edit,list */
		do;
		call io_data_list_semantics(b,cs,(t->operator.operand(4)));
		if t->operator.operand(4)->operator.op_code=get_data_trans then
			do;
			if lal<20 then lal=lal+1;
			else goto err467;
			assign_list(lal)=t->operator.operand(4);
			end;
		t->operator.operand(4)=null;
		goto loop1;
		end;

	if substr(job,20,1) then goto locate_prelim;		/* locate */

loop1:
	do i=1 to m;
	if t->operator.operand(i)=null then goto end_loop1;
	string(context)="0"b;

	if i=1 then if (job & "000000000000000000000000101"b)^="0"b
		then def_context.evaluate_offset="1"b;
			/* force evaluation of offset for aggregate FROM,INTO */

	t->operand(i) = expression_semantics(b,cs,(t->operand(i)),context);
	if t -> operand (i) -> node.type = label_node
	     then call semantic_translator$abort(78,null); /* illegal label constant */
	if t -> operand(i) -> node.type = reference_node
	then if t -> operand (i) -> reference.symbol -> node.type = label_node
	     then call semantic_translator$abort(78,null); /* illegal label constant */
	if i=1 then	if (job & "00000000000000000000000010101"b) ^="0"b	/* into,from,(ref) */
			then goto end_loop1;
	if def_context.aggregate then goto err62;	/* scalar */
end_loop1:
	end;
/* 





		JOB BITS

	INPUT(PARSE)	AS ALTERED(HEREIN)		TO RUNTIME

	1  file
	2  string option
	3 		varying
	4  data
	5  edit
	6  list
	7  get
	8  put
	9  page
	10 line
	11 skip
	12 copy-file
	13 p1p2
	14 bit_string
	15 unlock
	16 read
	17 write
	18 rewrite
	19 delete
	20 locate
	21 key
	22 keyto
	23 keyfrom
	24 set		set
	25 into
	26 ignore
	27 from
	28					rel-6
	29					rel-5	NB: RELEASE-NUMBER 6-bits
	30					rel-4	    copied and reset to 0 by RECIO
	31					rel-3
	32					rel-2
	33					rel-1
	34 open		not-byte-buffer		not-byte-buffer
	35
	36		packedptr			packedptr

	*/

loop2:
	do i=1 to 29,
		34;	/* OPEN,TITLE,PSIZE,LSIZE */
	if substr(job,i,1) then
		do;
		tp=t->operator.operand(rand_index(i));
		goto action(i);
		end;
action(3):					/* varying */
action(6):					/* list */
action(9):					/* page */
action(13):					/* p1p2 */

end_loop2:
	end;
/*  */
exit:
	if end_of_join ^=null then
		do;
		if job_additions^="0"b then job=job|job_additions;
		substr(job,28,6)="000010"b;	/* release 2 */

				/* release-2 adds: abnormal-return after KEYTO.  See comment
					at keyto_join:  
				   release-1 adds: char(256) var KEYs
						not_byte_buffer switch  */
		end_of_join->operator.operand(1)=declare_constant$bit(job);	/* for record_io, stream_prep operators */
					/* the bit36 "job" may have been changed  */
		lal=lal+1;
		assign_list(lal)=end_of_join;
		end;
	vs=create_statement(assignment_statement,(cs->statement.back),null,(cs->statement.prefix));
	vs->statement.generated,vs->statement.processed="1"b;
	if lal=1 then vs->statement.root=assign_list(1);
	else	do;
		vs->statement.root,tp=create_operator(join,lal);
			do i=1 to lal;
			tp->operator.operand(i)=assign_list(i);
			end;
		end;


	/* original operator is nulled out */
	do lal=1 to m+1;
	t->operator.operand(lal)=null;
	end;


	return;
err62:
	n=62;
	goto abort_null;

err114:
	n=114;
	goto abort_tp;

err115:
	n=115;
	goto abort_tp;

err468:
	n=468;
	tp=q;
	goto abort_tp;

err461:
	n=461;
	goto abort_tp;

err462:
	n=462;
	goto abort_tp;

err463:
	n=463;
	goto abort_tp;

err464:
	n=464;
	goto abort_tp;

err465:
	n=465;
	goto abort_tp;

err466:
	n=466;
	goto abort_null;

err467:
	n=467;
	goto abort_null;


abort_null:
	tp=null;
abort_tp:
	call semantic_translator$error(n,tp);
	if n=467 then return;
	goto end_loop2;


/*  */

action(12):								/* copy_file */
	PS_offset=ps_copy;
	goto test_file;
action(1):								/* file */
	PS_offset=ps_source;
test_file:
	if ^tp->reference.symbol->symbol.file then goto err462;
	goto set_addr;

action(11):								/* skip */
	if tp=null then tp=declare_constant$integer(1);
action(10):								/* line */
action(26):								/* ignore */
	call assign_ps(tp,ps_number,"int",null);
	goto end_loop2;

action(21):								/* key */
action(23):								/* keyfrom */

	r=b->block.plio_ps->list.element(50);
	if r=null then r=io_semantics_util$keys(b);
	if tp->node.type=token_node then tp=convert(tp,char_type);
	call assign_ps(tp,49,"aok",r);
				/* c_offset must address the first data-word of the
				   char256varying KEY; not the length-word !!   */
	goto end_loop2;

action(24):								/* set */
	PS_offset=ps_special_list;
	if substr(job,20,1)	/* locate */
	then	tp=locate_set;
	if ^tp->reference.symbol->symbol.ptr then goto err463;
	call propagate_bit((tp->reference.symbol),set_bit);
	if tp->reference.symbol->symbol.unaligned then substr(job_additions,36,1)="1"b;
	goto set_addr;



action(29):								/* (ref) for lock,unlock */

	n=476;	/* (REF) not implemented now */
		/* when it is, then check for data type:LOCK */
	goto abort_tp;

action(25):								/* into */
	call propagate_bit((tp->reference.symbol),set_bit);
	/* TR13134: Padded ref. bug occurs at read into statement */
	call propagate_bit((tp->reference.symbol),passed_as_arg_bit);
	/* if i=29 then goto set_variable_p; */
action(27):								/* from */


	/* generate    BITSIZE   and   BYTE-ALIGNMENT   */


	no_byte="0"b;	/* we are prepared to find a byte-aligned, byte-length buffer */

	s=tp->reference.symbol;
	if s->symbol.dimensioned & ^tp->reference.array_ref then
		do;
				/* array-element case is special */
		a=s->symbol.array;
		q=a->array.element_size_bits;
		cbs=a->array.c_element_size_bits;
		if a->array.element_boundary=bit_ then no_byte="1"b;		/* BIT boundary */
		end;

	else	do;
                    if s -> node.type = symbol_node
                    then do;
			q=s->symbol.bit_size;
			cbs=s->symbol.c_bit_size;
                         end;
                    else do;            /* bug2164: s is sometimes a reference node */
      			q = s -> reference.symbol -> symbol.bit_size;
 			cbs = s -> reference.symbol -> symbol.c_bit_size;
		     end;
		if s->symbol.boundary=bit_ then no_byte="1"b;	/* aligned on BIT boundary */
		end;


	if s->symbol.bit then substr(job_additions,14,1)="1"b;	/*bit info needed for stringvalue */


	if q=null then
		do;
		if mod(cbs,9)^=0 then no_byte="1"b;
		 q=declare_constant$integer((cbs));
		end;
	else	do;
		q=copy_expression((q));
		if ^ byte_buffer(s)
		     then no_byte = "1"b;
		if s->symbol.refer_extents then
		call refer_extent(q,(tp->reference.qualifier));
		q = expression_semantics(b,cs,q,"0"b);
		end;



	if s->symbol.varying then
		do;
		 if tp->reference.array_ref then substr(job_additions,35,1)="1"b;	/* varying_array */
		 substr(job_additions,3,1)="1"b;				/* varying */
		 no_byte="0"b;		/* padding always exists in a varying string */
		end;

			/* NB: unless the file has env(stringvalue),
			   the runtime will do addrel(p,-1) on variable_p
			   if work.varying (3) is set; and will add 36 to
			   variable_bitlen if work.varying is set UNLESS
			   work.varying_array (35) is also set.  */

	if no_byte then substr(job_additions,34,1)="1"b;	/* probable non-byte-buffer */
	call assign_ps(q,ps_var_bitlen,"int",null);		/* variable_bitlen */

set_variable_p:
	PS_offset=ps_var_p;
	goto set_addr;			/* variable_p */

action(22):								/* keyto */
	s=tp->reference.symbol;
	if ^s->symbol.char then goto err464;
	call propagate_bit(s,set_bit);

	vs=create_statement(assignment_statement,cs,null,(cs->statement.prefix));
	vs->statement.generated,vs->statement.processed="1"b;
	q=create_operator(assign,2);
	q->operator.operand(1)=tp;


	r=b->block.plio_ps->list.element(50);
	if r=null then r=io_semantics_util$keys(b);
	r=copy_expression((r));

	r->reference.c_length=0;	/* rule for varying string on RHS */
	q->operator.operand(2)=r;
	vs->statement.root=operator_semantics(b,cs,q,"0"b);

		/* i.e., key=PS|48->defined,aligned,char(256) varying */
	goto end_loop2;



action(28):								/* else for lock */
	t->operator.operand(1)=declare_temporary(bit_type,36,0,null);
		/* code generator will call lock and then
		   assign PS|31 to this temp. */

	goto end_loop2;

action(20):								/* locate */
	call alloc_semantics$init_only(locate_set,cs,(locate_var->reference.symbol));


action(14):								/* lock */
action(15):								/* unlock */
action(16):								/* read */
action(17):								/* write */
action(18):								/* rewrite */
action(19):								/* delete */
	if ss->statement.root=tt then
		do;
		ss->statement.statement_type=null_statement;
		ss->statement.root=null;
		end;
			/* takes care of all RECIO except lock_file with ELSE */

	if  substr(job,22,1) /* KEYTO */ then
		do;
		opcode_temp=record_io;
		goto keyto_join;
		end;

	end_of_join=create_operator(record_io,1);

	goto end_loop2;

action(2):								/* string option */
	r=tp;
	if substr(job,7,1) then
		do;	/* get */
		r,tp=convert(tp,char_type);
		if tp->node.type=operator_node then r=tp->operator.operand(1);
		s=r->reference.symbol;
		end;
	else	do;	/* put */
		if r->node.type ^= reference_node then goto err466;
		s=r->reference.symbol;
		if ^s->symbol.char then if ^s->symbol.picture then goto err466;
		call propagate_bit(s,set_bit);
		end;

	if b->block.plio_ffsb=null then call io_semantics_util$make_ffsb(b);

	if r->reference.varying_ref then
		do;
		substr(job_additions,3,1)="1"b;	/* set the varying bit */
		q=s->symbol.dcl_size;
		if q=null then q=declare_constant$integer((s->symbol.c_dcl_size));
		else	do;
			q=copy_expression((q));
			if s->symbol.refer_extents then call refer_extent(q,(r->reference.qualifier));
			q = expression_semantics(b,cs,q,"0"b);
			end;
		end;
	else	do;
		q=r->reference.length;
		if q=null then q=declare_constant$integer((r->reference.c_length));
		else q=copy_expression((q));
		end;

	call assign_ps(q,ps_number,"aok",null);	/* ps|ps_number = (max)length */
	r=tp;
	tp=b->block.plio_ffsb->symbol.reference;
	call assign_ps(r,6,"adr",tp);	/* ffsb|6 = addr(string expression)  */
	PS_offset=ps_source;
	goto set_addr;		/* ps|16 = addr(ffsb)  */

action(4):								/* data */
	pl1_stat_$generate_symtab="1"b;	/* generate SOME of the s.t.  */
	if substr(job,7,1)
	     then go to end_loop2;	/* get */

	if b->block.plio_ssl=null then call io_semantics_util$make_ssl(b);

	goto end_loop2;



action(5):								/* edit */

	if b->block.plio_fa=null then call io_semantics_util$make_fa(b);
	goto end_loop2;

action(7):								/* get */
action(8):								/* put */

	vs=create_statement((cs->statement.statement_type),(ns->statement.back),null,(cs->statement.prefix));
	vs->statement.generated,vs->statement.processed="1"b;

	cs->statement.statement_type=null_statement;
	cs->statement.root=null;	/* place holder only */

	vs->statement.root=t;	/* will generate the terminate call */
	t->operator.op_code=terminate_trans;
	opcode_temp=stream_prep;

keyto_join:
	/* of all the recio statements, read with keyto needs a null-statement
	   for abnormal return since the assignment to the keyto variable
	   follows the recio operator.  Changes must also be made in the CG
	   and in pl1_operators, not to mention in PLIO.  version-2. (7-74)  */


	vs=create_statement(null_statement,(ns->statement.back),null,(cs->statement.prefix));
				/* creates a null-statement for abnormal returns;
				   principally for the get and put statements
				   but also (7-74) for recio with keyto  */
	vs->statement.generated,vs->statement.processed="1"b;
	r=create_label(b,null,by_compiler);
	r->label.statement=vs;
	vs->statement.labels=create_list(2);
	vs->statement.labels->list.element(2)=r;	/* return label */

	end_of_join=create_operator(opcode_temp,2);
	end_of_join->operator.operand(2)=r;	/* ab ret label */
	goto end_loop2;

action(34):								/* OPEN */
	if b->block.plio_fab2=null then call io_semantics_util$make_fab2(b);
	r=b->block.plio_fab2->symbol.reference;

	if tp->node.type=token_node then fab2template.bits=bit(substr(tp->token.string,1,36),36);
	else fab2template.bits=tp->reference.symbol->symbol.initial->bb36;
	fab2template.bits=fab2template.bits | "001"b;	/* signifying the title168 changes */
	fab2template.name=" ";
	fab2template.ls,
	fab2template.ps,
	fab2template.bs=0;
	fab2template.title168p = null;

	tp=t->operator.operand(4);	/* pagesize */
	if tp^=null then call assign_ps(tp,10,"int",r);

	tp=t->operator.operand(1);	/* linesize */
	if tp^=null then call assign_ps(tp,9,"int",r);

	tp=t->operator.operand(3);	/* title */
	if tp^=null then
		do;
		call assign_ps(tp,1,"c32",r);
		if b->block.plio_ffsb=null then call io_semantics_util$make_ffsb(b);
					/* we'll use fake-fsb to store title168 */
		tp1=b->block.plio_ffsb->symbol.reference;
		call assign_ps(tp1,12,"adr",r);	/* fab2.title168p=addr(ffsb) */
		call assign_ps(share_expression(tp), 0,"ttl",tp1);	/* ffsb=char(title_exp,168) */
		end;

			/* the mechanism "convert$to_target" might
			   have been used, and used to be used, to
			   handle constant page_size,line_size, and
			   title options:  but (at least for title,
			   i.e., for strings) this procedure was capable
			   of returning an assignment operator
			   rather than a reference to a constant: thus
			   I could not rely on its use as a mechanism
			   for producing constant components for FAB2.

			   [I had used: fab2template.X=convert$to_target(
			    tp,declare_temporary(XX,...)->reference.symbol->
			    symbol.initial->based.XX  ]
							*/
	q=declare_constant$bit((fab2template_b));
	call assign_ps(q,0,"aok",r);
	if lal>1 then
		do;
		q=assign_list(1);
		assign_list(1)=assign_list(lal);
		assign_list(lal)=q;		/* assign whole fab2 template
					   before filling in the individual
					   variable fields */
		end;
	call assign_ps(r,ps_special_list,"adr",null);	/* PS|special_list_p=addr(fab2) */
	goto exit;

		/* Code Generator generates calls to runtime routines as follows:
		a) record_io:	call plio2_recio_(psp)
		b) open_file:	call plio2_$open_explicit_(psp)
		c) close_file:	call plio2_$close1_(psp)
		d) stream_prep:	call plio2_$get_prep_(psp)
				call plio2_$put_prep_(psp)
		e)terminate_trans:	if GET statement then call plio2_$get_terminate_(psp)
				if PUT statement then call plio2_$put_terminate_(psp)
		f) put_data_trans:
		g) put_edit_trans:
		h) put_list_trans:
		i) get_edit_trans:
		j) get_list_trans:
		*/
/*  */
set_addr:
	call assign_ps(tp,PS_offset,"adr",null);
	goto end_loop2;

locate_prelim:
	tp=t->operator.operand(4);
	if tp->node.type ^= token_node then goto err461;
	if tp->token.type ^= identifier then goto err461;

	if substr(job,24,1) then
		do;
		tp=create_reference(tp);
		tp->reference.qualifier=t->operator.operand(1);
		t->operator.operand(1)=null;
		end;
	else	substr(job,24,1)="1"b;
		/* we place this directly in job rather than in job_additions, as it will be tested */

	string(context)="0"b;
	tp = expression_semantics(b,cs,tp,context);
	s=tp->reference.symbol;
	if s->symbol.controlled then goto err114;
	if ^s->symbol.based then goto err115;
	if s->symbol.level>=2 then goto err465;
	locate_set,q=tp->reference.qualifier;
	if q=null then goto err468;
	if q->node.type=operator_node then goto err468;
			/* assignment of pointer must be to a pointer variable
			   not to a pointer expression */
	if ^q->reference.symbol->symbol.ptr then goto err468;

	locate_var=tp;
	locate_size=s->symbol.bit_size;
	if locate_size=null then locate_size=declare_constant$integer((s->symbol.c_bit_size));
	else	do;
		locate_size=copy_expression((locate_size));
		/* "refer_extent" is not called: we wish to use the left-hand sides */
		string(context)="0"b;
		locate_size = expression_semantics(b,cs,locate_size,context);
		end;

	call assign_ps(locate_size,ps_var_bitlen,"aok",null);

	t->operator.operand(4)=null;
	goto loop1;
/*  */

assign_ps:proc(x,PS_offset,dtype,tref);
	dcl (x,tref) ptr;
	dcl PS_offset fixed bin(15);
	dcl dtype char(3) aligned;	/* "int","ptr","c32","ttl","adr","spf","aok","cvr" */
	dcl (tp,ap) ptr;
	dcl outtype bit(36) aligned;

	/* This subroutine has as its principal use
	   the assignment with coercive conversion
	   of some element to PS.  It has been extended
	   to do addressing and to assign to storage blocks
	   other than PS */

	if lal<20 then lal=lal+1;
	else goto err467;
	assign_list(lal),tp=create_operator(assign,2);

     /* SET TARGET */
	if tref ^= null then		/* not directed at PS */
		do;
		tp->operator.operand(1)=copy_expression((tref));
		tp->operator.operand(1)->reference.c_offset=PS_offset;	/* ? */
		end;
	else	do;
		tp->operator.operand(1),ap=b->block.plio_ps->list.element(PS_offset+2);
		if PS_offset=ps_key then if ap=null then tp->operator.operand(1)=
					io_semantics_util$keys(b);
		end;

     /* SET "RIGHT-HAND-SIDE"  */
	if dtype="aok" then tp->operator.operand(2)=x;

	else if dtype="adr" then		/* store addr(x)  */
		do;
		tp->operator.operand(2),ap=create_operator(addr_fun_bits,2);
		ap->operator.operand(2)=x;
		if x->node.type = reference_node
		then if ^ x->reference.symbol->symbol.file	/* 1-79 */
		     then call propagate_bit((x->reference.symbol), aliasable_bit);	/* 6-73, 7-74 */
		ap->operator.operand(1)=declare_temporary(pointer_type,0,0,null);
		end;

	else	do;		/* COERCIONS */
		if dtype="int" then
			outtype=integer_type;
		else if dtype="ptr" then
			outtype=pointer_type;
		else	outtype=char_type;

		if dtype="ttl" then strlen=168;
		else strlen=32;
		tp->operator.operand(2)=convert$to_target(x,
		declare_temporary(outtype,strlen,0,null));
		end;
end assign_ps;
/*  */

io_semantics_util:proc;

dcl	(b,s,t,tp,q,r) ptr;
dcl	(i,n) fixed bin(15);
dcl	bp ptr unaligned based;





io_semantics_util$make_ps:entry(b);
	n=48;		/* Builds the ordinary PS, 48 words long */
	q=addr(b->block.plio_ps);
	goto make;

end_make_ps:
	tp=create_list(50);
	tp->list.element(1)=s;
	q->bp=tp;	/* block.plio_ps -> list; list(1)->ps_symbol */

	do i=2 to 22 by 2     ,    23 to 31 ;	/* We leave element 32 null as a flag to io_data_l_sem,	*/
					/* if a new_format is needed they will make one,along	*/
					/* with a defined ref. to protect it from the optimizer	*/
					/* messing around with it.				*/
	tp->list.element(i),r=copy_expression(s->symbol.reference);
	r->reference.c_offset=i-2;
	r->reference.units=word_;
	end;
	return;

io_semantics_util$keys:entry(b) returns(ptr);
			/* Extends the size of PS to 48+65 words long
			   to accomodate the new key, which is char256varying.
			   Also sets list.element(50)=ref to defined char256varying
			   whose qualifier is PS|48  */

	t=b->block.plio_ps->list.element(1);
	t->symbol.c_word_size,
	t->symbol.c_dcl_size=113;
	t->symbol.c_bit_size=113*bits_per_word;	/* 113=48+65, 65=length of c-256-var, KEY as of 73-12-6 */

		s=create_symbol(null,null,by_compiler);
		s->symbol.char,
		s->symbol.varying,		/* key is c256var 73-12-6 */
		s->symbol.aligned,
		s->symbol.overlayed,
		s->symbol.aliasable,		/* 6-73 */
		s->symbol.defined="1"b;
		s->symbol.dcl_size=create_token("256",dec_integer);
		/* s->symbol.initial=create_token("1",dec_integer); */
		/* s->symbol.position="1"b; */

		call declare(s);

	r=s->symbol.reference;
	r->reference.units=word_;
	r->reference.c_offset=49;
			/* c_offset addresses first data-word, not length-word !! */
	r->reference.c_length=256;		/* must =0 if on R.H.S.  */
	r->reference.qualifier=copy_expression(t->symbol.reference);

	b->block.plio_ps->list.element(50)=r;
	return(r);


io_semantics_util$make_fa:entry(b);
	n=122;
	q=addr(b->block.plio_fa);
	goto make;

io_semantics_util$make_ffsb:entry(b);
	n=42;
				/* 32 are needed for the original use,
				   viz., the "fake fsb" used for string option.
				   But 42 are needed for the newer use (6-30-72)
				   for the title168.  */
	q=addr(b->block.plio_ffsb);
	goto make;

io_semantics_util$make_ssl:entry(b);
	n=1;	/* WILL BE RESET AT SEMANT TIME TO LENGTH OF LONGEST SSL */
	q=addr(b->block.plio_ssl);
	goto make;

io_semantics_util$make_fab2:entry(b);
	n=14;
	q=addr(b->block.plio_fab2);
	goto make;

make:
	if q->bp ^=null then return;			/* this is a mild error. */

	q->bp,s=create_symbol(b,(null),by_compiler);

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

	s->symbol.boundary=mod2_;
	s->symbol.c_word_size,
	s->symbol.c_dcl_size=n;
	s->symbol.c_bit_size=n*bits_per_word;

	if n=48 then goto end_make_ps;
	return;
end io_semantics_util;

/**/
byte_buffer:	proc(sym) reducible returns(bit(1) aligned);

/* determines if a symbol is eligible to be a buffer whose length is an integral number of bytes */

dcl	(adam,s,sym) ptr;

	s, adam = sym;

loop:	do while(s -> symbol.structure);
	     s = s -> symbol.son;
	     end;

	if ^ s -> symbol.char
	then if ^ s -> symbol.picture
	     then if ^ s -> symbol.decimal
		then if s -> symbol.bit | s -> symbol.packed
		     then return("0"b);

	if s = adam
	     then return("1"b);

	do while(s -> symbol.brother = null);
	     s = s -> symbol.father;
	     if s = adam
		then return("1"b);
	     end;

	s = s -> symbol.brother;
	go to loop;
end byte_buffer;

/* include files */

%include semant;
/*  */
%include nodes;
%include block;
%include list;
%include operator;
%include op_codes;
%include semantic_bits;
%include symbol;
%include array;
%include system;
%include reference;
%include token;
%include token_types;
%include statement;
%include statement_types;
%include declare_type;
%include label;
%include ps_map;
%include symbol_bits;
%include boundary;
%include mask;
%include decoded_token_types;
     end /* io_semantics */;




		    lookup.pl1                      07/31/89  1431.7r w 07/31/89  1338.8       35271



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


/* Modified Dec 1978 by David Spector to process suppress_cross_ref context bit
   to suppress redundant int entry/label cross-references */
/* Modified: 27 Dec 1980 by PCK to implement by name assignment */

lookup: proc(blk,stmnt,tree,s,context) returns(bit(1) aligned);

dcl	(blk,stmnt,tree,s,d,q,b,f,name) ptr;
dcl	fully_qualified bit(1);
dcl	(n,k) fixed bin(15);
dcl	pl1_stat_$LHS ptr ext static;

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

%include semant;


%include symbol;

%include label;

%include reference;
%include semantic_bits;

%include block;

%include statement;


%include token;

%include list;

%include cross_reference;

%include nodes;

			/*      */

	n = 0;
	d = null;
	if tree->node.type = reference_node
		then do;
			q = tree->reference.length;
			name = tree->reference.symbol;
		     end;
		else do;
			q = null;
			name = tree;
		     end;

/* search for an applicable declaration for which this is a fully qualified reference.  Remember any
applicable declaration for which this is a partialy qualified reference.  If two
or more applicable declarations can be found and this is not a fully qualified reference
to any of them, this is an ambiguous reference.  If only one applicable declaration
can be found, this is a valid partialy qualified reference to that declaration.  The search
for an applicable declaration begins in the current block and continues outward until
the first applicable declaration is found.  After the first applicable
declaration is found, all additional searching is confined to the block in which the
first applicable declaration was found.  */

	b = blk;
	do while(b^=null);
		s = name->token.declaration;
		do while(s^=null);
			fully_qualified = "1"b;
			if s->symbol.block_node^=b
			then	goto not_applicable;
			if s->node.type = label_node
				then if q = null
					then go to applicable;
					else go to not_applicable;
			if q = null then do;
					if s->symbol.member then fully_qualified = "0"b;
					go to applicable;
				      end;
			k = 1;
			f = s;
			do while(k <= q->list.number);
				do f=f->symbol.father repeat f->symbol.father while(f^=null);
					if f->symbol.token = q->list.element(k) then go to next_name;
					fully_qualified = "0"b;
				end;
				go to not_applicable;
next_name:
				k = k+1;
			end;

			fully_qualified = fully_qualified & f->symbol.father=null;
		
applicable:
		
			if fully_qualified then go to exit;
			n = n+1;
			d = s;
not_applicable:
			s = s->symbol.multi_use;
		end;

		if n>0 then b = null;else b = b->block.father;
	end;

	if n>1 then call semantic_translator$abort(221,name);
	if d = null then return("0"b);
	s = d;

exit:
	if tree->node.type = reference_node & ^def_context.by_name_lookup
		then do;
			tree->reference.length = null;
			tree->reference.symbol = s;
		     end;
	if s->node.type = symbol_node
		then	if ^def_context.ignore_based
			then do d=s repeat d->symbol.father while(d^=null);
				d->symbol.allocate = "1"b;
			end;

	if stmnt ^= null
	then if stmnt->node.type = statement_node & ^def_context.suppress_cross_ref
	then do;
		d = create_cross_reference();
		q = s;
		if s -> node.type ^= label_node
		then if s -> symbol.condition
		     then q = s -> symbol.equivalence;
		d->cross_reference.next = q->symbol.cross_references;
		q->symbol.cross_references = d;
		string(d->cross_reference.source_id) = string(stmnt->statement.source_id);
	end;

	return("1"b);

	end lookup;




		    make_non_quick.pl1              10/03/83  1727.1rew 10/03/83  1006.7       17505



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


/* This procedure walks thru an expression tree.  If it finds a call to an
   internal procedure, it makes the internal procedure non-quick */

make_non_quick: proc(pt, reason);

dcl	pt ptr;
dcl	reason bit (36) aligned;

dcl	(p,q) ptr,
	null builtin,
	i fixed bin;

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

	p = pt;
	if pt = null then return;

	if p -> node.type = reference_node
	then do;
	     call make_non_quick((p -> reference.offset), reason);
	     call make_non_quick((p -> reference.length), reason);
	     call make_non_quick((p -> reference.qualifier), reason);
	     return;
	     end;

	if p -> node.type = list_node
	then do;

	     do i = 1 to p -> list.number;
		call make_non_quick((p -> element(i)), reason);
		end;

	     return;
	     end;

	if p -> node.type ^= operator_node then return;

	if p -> operator.op_code = std_call
	then do;
	     q = p -> operand(2);
	     if q -> node.type = reference_node
	     then do;
		q = q -> reference.symbol;
		if q -> symbol.internal & q -> symbol.constant
		then do;
			string (q -> symbol.equivalence -> block.why_nonquick) =
			     string (q -> symbol.equivalence -> block.why_nonquick) | reason;
			q -> symbol.equivalence -> block.no_stack = "0"b;
		     end;
		end;
	     end;

	do i = 1 to p -> operator.number;
	     call make_non_quick((p -> operand(i)), reason);
	     end;

	end;




		    match_arguments.pl1             07/31/89  1431.7r w 07/31/89  1338.8       66528



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


/* Modified 780712 by PG for unsigned
   Modified 790812 by RAB to fix 1797 (erroneous WARNING 47 when array of
	character strings passed to function expecting star extents lengths.)
   Modified 4 October 1980 by M. N. Davidoff to eliminate internal static.  Fixes 2023.
*/
/* format: style3,tree */
match_arguments:
     procedure (pa, pb) returns (bit (1) aligned);

dcl	pa		ptr;
dcl	pb		ptr;

/* automatic */

dcl	a		ptr;
dcl	a_reference	bit (1) aligned;
dcl	a_root		ptr;
dcl	b		ptr;
dcl	found_brother	bit (1) aligned;
dcl	parent_is_scalar	bit (1) aligned;

/* builtin */

dcl	(null, string, unspec)
			builtin;

%include semant;
%include array;
%include nodes;
%include picture_image;
%include reference;
%include symbol;

/* If a is a reference, the length given in the reference is used as the size
   and the bounds and dimensionality of b are ignored.  A star extent of b is
   considered to match any corresponding extent of a.  If the arguments are
   structures, this procedure makes a prefix walk over the members to ensure
   that the members match. */

	b = pb;

	if pa = b
	then return ("1"b);

	if pa = null
	then return ("0"b);

	if pa -> node.type = reference_node
	then do;
		a_reference = "1"b;
		a = pa -> reference.symbol;
	     end;
	else do;
		a_reference = "0"b;
		a = pa;
	     end;

	parent_is_scalar = "0"b;
	a_root = a;
	do while (a ^= a_root -> symbol.father);
	     if b = null
	     then return ("0"b);

	     if a_reference
	     then if a = a_root
		then if ^match (pa, b)
		     then return ("0"b);
		     else ;
		else if ^match ((a -> symbol.reference), b)
		     then return ("0"b);
		     else ;
	     else if ^match (a, b)
		then return ("0"b);

	     if a -> symbol.son ^= null
	     then do;
		     a = a -> symbol.son;
		     b = b -> symbol.son;
		end;
	     else do;
		     found_brother = "0"b;
		     do while (a ^= a_root -> symbol.father & ^found_brother);
			if a -> symbol.brother = null | a = a_root
			then do;
				if b -> symbol.brother ^= null & a ^= a_root
				then return ("0"b);

				a = a -> symbol.father;
				b = b -> symbol.father;
			     end;
			else do;
				a = a -> symbol.brother;
				b = b -> symbol.brother;
				found_brother = "1"b;
			     end;
		     end;
		end;
	end;

	return ("1"b);

/* Check if two nodes match. */

match:
     procedure (pa, pb) returns (bit (1) aligned);

dcl	pa		ptr;
dcl	pb		ptr;

/* automatic */

dcl	a		ptr;
dcl	asize		ptr;
dcl	b		ptr;
dcl	ba		ptr;
dcl	bb		ptr;
dcl	bsize		ptr;
dcl	c_asize		fixed bin (24);
dcl	c_bsize		fixed bin (24);

	b = pb;
	asize, bsize = null;
	c_asize, c_bsize = 0;

	if pa = b
	then return ("1"b);

	if a_reference
	then a = pa -> reference.symbol;
	else a = pa;

	if string (a -> symbol.data_type) ^= string (b -> symbol.data_type) | a -> symbol.binary ^= b -> symbol.binary
	     | a -> symbol.real ^= b -> symbol.real | a -> symbol.scale ^= b -> symbol.scale
	     | a -> symbol.aligned ^= b -> symbol.aligned | a -> symbol.unsigned ^= b -> symbol.unsigned
	     | a -> symbol.varying ^= b -> symbol.varying
	then return ("0"b);

	if ^a_reference & a -> symbol.dimensioned ^= b -> symbol.dimensioned
	then return ("0"b);

	if a -> symbol.float | a -> symbol.fixed
	then do;
		c_asize = a -> symbol.c_dcl_size;
		c_bsize = b -> symbol.c_dcl_size;
	     end;

	else if a -> symbol.char | a -> symbol.bit
	     then do;
		     if a_reference & ^a -> symbol.varying
		     then do;
			     asize = pa -> reference.length;
			     c_asize = pa -> reference.c_length;
			end;
		     else do;
			     asize = a -> symbol.dcl_size;
			     c_asize = a -> symbol.c_dcl_size;
			end;

		     bsize = b -> symbol.dcl_size;
		     c_bsize = b -> symbol.c_dcl_size;
		end;

	if a -> symbol.picture
	then if unspec (a -> symbol.general -> reference.symbol -> symbol.initial -> picture_image)
		^= unspec (b -> symbol.general -> reference.symbol -> symbol.initial -> picture_image)
	     then return ("0"b);
	     else ;

	else if a -> symbol.area
	     then do;
		     asize = a -> symbol.dcl_size;
		     bsize = b -> symbol.dcl_size;
		     c_asize = a -> symbol.c_dcl_size;
		     c_bsize = b -> symbol.c_dcl_size;
		end;

	if b -> symbol.star_extents
	then if bsize = null & (c_asize ^= c_bsize | asize ^= null)
	     then return ("0"b);
	     else ;
	else if c_asize ^= c_bsize | ^compare_expression (asize, bsize)
	     then return ("0"b);

	if a_reference & a -> symbol.father = null
	then if pa -> reference.array_ref ^= b -> symbol.dimensioned
	     then return ("0"b);

	if b -> symbol.dimensioned
	then do;
		if a -> symbol.array -> array.own_number_of_dimensions > b -> symbol.array -> array.number_of_dimensions
		then call semantic_translator$abort (269, a);

		if a -> symbol.array -> array.number_of_dimensions ^= b -> symbol.array -> array.number_of_dimensions
		     & (a -> symbol.array -> array.own_number_of_dimensions
		     ^= b -> symbol.array -> array.own_number_of_dimensions | a -> symbol.father = null
		     | b -> symbol.father = null)
		then return ("0"b);

		ba = a -> symbol.array -> array.bounds;
		bb = b -> symbol.array -> array.bounds;

		if bb = null
		then return ("0"b);

		do while (ba ^= null & bb ^= null);
		     if b -> symbol.star_extents
		     then if constant_extent ((bb -> bound.lower)) & constant_extent ((bb -> bound.upper))
			     & (ba -> bound.c_lower ^= bb -> bound.c_lower
			     | ba -> bound.c_upper ^= bb -> bound.c_upper | ^constant_extent ((ba -> bound.lower))
			     | ^constant_extent ((ba -> bound.upper)))
			then return ("0"b);
			else ;

		     else if ba -> bound.c_lower ^= bb -> bound.c_lower | ba -> bound.c_upper ^= bb -> bound.c_upper
			     | ^same_extent_bounds ((ba -> bound.lower), (bb -> bound.lower))
			     | ^same_extent_bounds ((ba -> bound.upper), (bb -> bound.upper))
			then return ("0"b);

		     ba = ba -> bound.next;
		     bb = bb -> bound.next;
		end;
	     end;

	else if a_reference
	     then if pa -> reference.array_ref
		then if ^parent_is_scalar
		     then return ("0"b);
		     else ;
		else parent_is_scalar = "1"b;
	     else if a -> symbol.dimensioned
		then return ("0"b);

	return ("1"b);

same_extent_bounds:
     procedure (a, b) returns (bit (1) aligned) reducible;

dcl	a		ptr;
dcl	b		ptr;

	if constant_extent (a)
	then if constant_extent (b)
	     then return ("1"b);
	     else return ("0"b);
	else if constant_extent (b)
	     then return ("0"b);
	     else return (compare_expression (a, b));
     end same_extent_bounds;

/* An extent is considered constant if it is null or a reference to a constant
   symbol. */

constant_extent:
     procedure (p) returns (bit (1) aligned) reducible;

dcl	p		ptr;

	if p = null
	then return ("1"b);

	else if p -> node.type = reference_node
	     then if p -> reference.symbol -> symbol.constant
		then return ("1"b);

	return ("0"b);
     end constant_extent;

     end match;

     end match_arguments;




		    offset_adder.pl1                07/31/89  1431.7r w 07/31/89  1338.9       38385



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


offset_adder:	proc(a,ca,ua,mwa,arg_b,arg_cb,arg_ub,arg_mwb,no_improve);

/* Modified: 79/04/23 by PCK to implement 4-bit decimal */

dcl	(a,arg_b,b,p,q) ptr;
dcl	(ca,arg_cb,cb) fixed bin(31);
dcl	(ua,arg_ub,ub) fixed bin(3);
dcl	(mwa,arg_mwb,mwb) bit(1) aligned;	/* ON means units ^= word_, but variable offset in words */
dcl	n fixed bin(15);
dcl	bit_offset fixed bin(31);

dcl	no_improve bit(1);

dcl	(divide,min,mod,null,substr) builtin;

dcl	c_table(7,7) fixed bin(31,1) int static initial(
					1, 4.5, 9,18,36,36,36,
					0,   1, 2, 4, 8, 8, 8,
					0,   0, 1, 2, 4, 4, 4,
					0,   0, 0, 1, 2, 2, 2,
					0,   0, 0, 0, 1, 1, 1,
					0,   0, 0, 0, 0, 1, 1,
					0,   0, 0, 0, 0, 0, 1);

dcl	pl1_stat_$eis_mode bit(1) aligned ext static;


	b = arg_b; cb = arg_cb; ub = arg_ub; mwb = arg_mwb; /* value b,cb,ub,mwb; */

	call get_ptr(a,ua,mwa);

	call get_ptr(b,ub,mwb);

	if ua = 0
	then ua = ub;
	else if ub = 0
	     then ub = ua;
	     else if ua ^= ub & (ua < word_ | ub < word_)
		then if ua < ub
		     then do;
			     cb = cb * c_table (ua,ub);

			     if b ^= null
			     then b = convert_variable_offset (b,ua,ub);

			end;
		     else do;
			     ca = ca * c_table (ub,ua);

			     if a ^= null
			     then a = convert_variable_offset (a,ub,ua);

			end;

	ua = min(ua,ub);
	ca = ca+cb;

	if a = null
	then do;
		a = b;

		if b = null
		then if ^no_improve
		then if ua < word_
		then do;
			/* improve offset units */
			bit_offset = ca * c_table(bit_,ua);

			do n = word_ to bit_ by -1
			     while(mod(bit_offset,c_table(bit_,n)) ^= 0);
			end;

			if n = word_ | ^pl1_stat_$eis_mode
			then do;
				ca = divide(bit_offset,c_table(bit_,n),31,0);
				ua = n;
			     end;
		end;
	end;
	else	if b ^= null
		then do;
			q = create_operator(add,3);
			q->operand(2) = a;
			q->operand(3) = b;
			a = q;
		end;

	if a ^= null & ca ^= 0
	then do;
		q = create_operator(add,3);
		q->operand(2) = a;
		q->operand(3) = declare_constant$integer(ca);
		a = q;
		ca = 0;
	end;

	return;

get_ptr:	proc(pt,units,offset_is_modword);

dcl	(pt,t,new) ptr;
dcl	units fixed bin(3);
dcl	offset_is_modword bit(1) aligned;

	if pt = null then return;

	if ^ pl1_stat_$eis_mode
	then if pt -> node.type = operator_node
	then if substr(pt -> operator.op_code,1,5) = substr(mod_bit,1,5)
	then do;
	     pt = pt -> operand(3);
	     return;
	     end;

	if ^ offset_is_modword
	     then return;

	/* force pt to use "units" instead of word_ */

	t = create_operator(mult,3);

	t -> operator.processed = "0"b;
	t -> operand(1) = null;
	t -> operand(2) = pt;
	t -> operand(3) = declare_constant$integer((c_table(units,word_)));

	pt = t;

	offset_is_modword = "0"b;

	end /* get_ptr */;

/* Convert a variable offset from one set of units to another set of units */

convert_variable_offset:
	procedure (variable_offset,to_units,from_units) returns(pointer);

/* parameters */

dcl  variable_offset pointer;
dcl  (from_units,to_units) fixed binary(3);

/* automatic */

dcl  converted_variable_offset pointer;


	if from_units = digit_ & to_units = bit_
	then converted_variable_offset =  create_operator (digit_to_bit,2);	/* Special case digit offset to bit offset conversion to avoid scaled multiplicaion */
	else do;			/* All other offset conversions are simple integer multiplications */
		converted_variable_offset = create_operator (mult,3);
		converted_variable_offset -> operand(3) = declare_constant$integer ((c_table(to_units,from_units)));
	     end;

	converted_variable_offset -> operand(2) = variable_offset;

	return (converted_variable_offset);

	end /* convert_variable_offset */;

%include semant;
%include operator;
%include reference;
%include nodes;
%include op_codes;
%include boundary;
%include system;

	end /* offset_adder */;





		    operator_semantics.pl1          09/22/89  1408.7rew 09/22/89  1359.7      629577



/****^  ***********************************************************
        *                                                         *
        * 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,MCR8121), audit(89-08-09,Vu),
     install(89-09-22,MR12.3-1073):
     Changed references to error msg 134 to msg 135.
                                                   END HISTORY COMMENTS */


/* 	Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement
	Modified: 9 August 1978 by PCK to fix bug 1753
	Modified: 15 August 1978 by PCK to fix bug 1708
	Modified: 25 August 1978 by PCK to fix bugs 1779 and 1730
	Modified: 23 April 1979 by PCK to implement 4-bit decimal
	Modified 790606 by PG to add byte and rank builtins
	Modified 800103 by RAB to fix 1860 in which passing a label constant
		as arg somtimes fails.
	Modified: 1 July 1980 by PCK to fix 1975 (substr of an aligned string
		is passed by reference when it is the target of an assignment
		whose LHS is a function returning an aligned string
		of the same length
	Modified: 2 June 1981 by EBush to fix bug 1851 (faulting on multiply
		declared entries)
	Modified: 06 June 89 by RWaters changed references to error
                    message 134 to 135
*/

/* format: style2,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
operator_semantics:
     proc (blk, stmnt, input_tree, context) returns (ptr);

/* parameters */
	dcl      blk ptr parameter;
	dcl      stmnt ptr parameter;
	dcl      input_tree ptr parameter;

/* automatic */

	dcl      (a, after_ret) ptr;
	dcl      (b, bb, c) ptr;
	dcl      desc ptr;
	dcl      e ptr;
	dcl      es ptr;
	dcl      expr ptr;
	dcl      (first, last) ptr;
	dcl      jump_stmnt ptr;
	dcl      last_jump ptr;
	dcl      length (2:3) ptr;
	dcl      next ptr;
	dcl      old_rand (2:3) ptr;
	dcl      orig_stmnt_ptr ptr;
	dcl      qq ptr;
	dcl      ref ptr;
	dcl      rv ptr;
	dcl      size ptr;
	dcl      sym ptr;
	dcl      signal_stmnt_ptr ptr;
	dcl      tree ptr;
	dcl      target ptr;

	dcl      (n, k, q, s, math_libe_no) fixed bin (15);
	dcl      (i, m, p, r) fixed bin (31);
	dcl      (rprec, rscale) fixed bin (31);
	dcl      c_length (2:3) fixed bin (31);
	dcl      prec (3) fixed bin (31);
	dcl      value_of_y fixed bin (71);

	dcl      decimal_result bit (1) aligned;
	dcl      first_time bit (1) aligned;
	dcl      m_set bit (1) aligned;
	dcl      end_statement_flag bit (1) aligned;
	dcl      label_attached bit (1) aligned;
	dcl      make_operator bit (1) aligned;

	dcl      (opcode, s_opcode) bit (9) aligned;
	dcl      result_type bit (36) aligned;
	dcl      integer fixed bin (15) based;
	dcl      cond_name char (16);
	dcl      based_char char (16) based;
	dcl      float_dec_target ptr;
	dcl      hold_abort_label label variable;

/* external static */
	dcl      pl1_stat_$abort_label label ext static;
	dcl      pl1_stat_$cur_statement ptr ext static;
	dcl      pl1_stat_$error_flag bit (1) ext static;
	dcl      pl1_stat_$multi_type bit (1) ext static;
	dcl      pl1_stat_$root ptr ext static;
	dcl      pl1_stat_$stmnt_unreachable bit (1) ext static;

/* structures */

	dcl      1 atype like type;
	dcl      1 btype like type;
	dcl      1 ctype like type;
	dcl      1 rtype like type;

/* builtins */

	dcl      (abs, addr, bin, bool, divide, fixed, index, max, min, null, sign, string, substr, unspec) builtin;

/* internal static */

	dcl      TRUE bit (1) int static options (constant) init ("1"b);
	dcl      FALSE bit (1) int static options (constant) init ("0"b);

	dcl      action_index (20, 0:15) fixed bin (15) int static init (0, 1, 1, 1, 1, 2, 3, (9) - 1,
						/* class 1 */
		    0, (5) 4, (10) - 1, 0, 5, (2) - 1, 0, -1, 13, -1, 0, -1, (6) - 1, (4) - 1, (6) 6, (6) - 1, 0,
		    (9) 7, (6) - 1,			/* class 5 */
		    0, 0, -1, 9, -1, 10, -1, 0, 13, 15, 15, 11, -1, -1, 0, -1, (4) 19, (12) - 1, (7) 12, -1, -1, 14,
		    14, (4) - 1, 12, (16) - 1, (11) - 1, 8, (4) - 1,
						/* class 10 */
		    15, (4) 0, (11) - 1, (2) 0, (14) - 1, (4) - 1, (3) 21, (9) - 1, 12, 12, 20, 0, (11) - 1, 0, 0,
		    (14) 16, -1,			/* class 15 */
		    (7) 16, (5) - 1, (4) 0, (2) 0, 11, 18, 18, (9) 16, 17, 0, (4) 16, (2) - 1, 2, 0, (7) - 1, 0,
		    (16) - 1, (16) - 1);		/* class 20 */
%page;
/* begin */
	tree = input_tree;

	if tree = null then
	     goto ret;
	if tree -> node.type ^= operator_node then
	     goto ret;
	if tree -> operator.processed then
	     goto ret;

	this_context = "0"b;
	n, m = 0;
	a, b, c, e, next, qq, ref, size, sym, length (2), length (3) = null;
						/* safety first */

	k = tree -> operator.number;

	opcode = tree -> operator.op_code;

	if opcode < std_arg_list then
	     call extract;

	goto action (action_index (fixed (substr (opcode, 1, 5), 5), fixed (substr (opcode, 6, 4), 4)));

%page;
/*
 * This operator should not be seen by this procedure.
 */
action (-1):
	call semantic_translator$abort (52, null);
%page;
/*
 * This operator requires no action by this procedure.
 */
action (0):
	goto ret;
%page;
/*
 * This code is executed for the arithmetic operators + - / *
 */
action (1):
	if b -> node.type = label_node | c -> node.type = label_node then
	     call semantic_translator$abort (78, null);

	if btype.bit then
	     string (btype) = integer_type;
	if ctype.bit then
	     string (ctype) = integer_type;
	if btype.char then
	     string (btype) = dec_integer_type;
	if ctype.char then
	     string (ctype) = dec_integer_type;
	if btype.picture then
	     if b -> symbol.complex then
		if b -> symbol.pic_float then
		     string (btype) = float_decimal_complex_mask;
		else
		     string (btype) = fixed_decimal_complex_mask;
	     else if b -> symbol.pic_float then
		string (btype) = float_decimal_real_mask;
	     else
		string (btype) = fixed_decimal_real_mask;
	if ctype.picture then
	     if c -> symbol.complex then
		if c -> symbol.pic_float then
		     string (ctype) = float_decimal_complex_mask;
		else
		     string (ctype) = fixed_decimal_complex_mask;
	     else if c -> symbol.pic_float then
		string (ctype) = float_decimal_real_mask;
	     else
		string (ctype) = fixed_decimal_real_mask;

	if ^(btype.fixed | btype.float) then
	     call semantic_translator$abort (227, null);
	if ^(ctype.fixed | ctype.float) then
	     call semantic_translator$abort (227, null);

	if btype.binary & ctype.decimal then
	     string (ctype) = string (ctype) & ^decimal_mask | binary_mask;
	if btype.decimal & ctype.binary then
	     string (btype) = string (btype) & ^decimal_mask | binary_mask;
	if btype.complex | ctype.complex then
	     result_type = complex_mask;
	else
	     result_type = real_mask;

	if btype.binary then do;
	     if btype.fixed & ctype.float then
		string (btype) = string (btype) & ^fixed_mask | float_mask;
	     if btype.float & ctype.fixed then
		string (ctype) = string (ctype) & ^fixed_mask | float_mask;

	     call converter;

	     p = b -> symbol.c_dcl_size;
	     q = b -> symbol.scale;
	     r = c -> symbol.c_dcl_size;
	     s = c -> symbol.scale;
	     if b -> symbol.fixed then do;
		result_type = result_type | binary_mask | fixed_mask | aligned_mask;
		if opcode = add | opcode = sub then do;
		     m = min (max_p_fix_bin_2, max (p - q, r - s) + max (q, s) + 1);
		     n = max (q, s);
		     goto create_temp;
		end;
		if opcode = mult then do;
		     m = min (max_p_fix_bin_2, p + r + 1);
		     n = q + s;
		     goto create_temp;
		end;
		if opcode = div then do;
		     m = max_p_fix_bin_2;
		     n = m - p + q - s;
		     goto create_temp;
		end;
	     end;
	     else do;
		result_type = result_type | binary_mask | float_mask | aligned_mask;
		m = max (p, r);
		goto create_temp;
	     end;
	end;
	else do;
	     call converter;

	     p = b -> symbol.c_dcl_size;
	     q = b -> symbol.scale;
	     r = c -> symbol.c_dcl_size;
	     s = c -> symbol.scale;
	     if b -> symbol.fixed & c -> symbol.fixed then do;
		result_type = result_type | decimal_mask | fixed_mask | aligned_mask;
		if opcode = add | opcode = sub then do;
		     m = min (max_p_dec, max (p - q, r - s) + max (q, s) + 1);
		     n = max (q, s);
		     goto create_temp;
		end;
		if opcode = mult then do;
		     m = min (max_p_dec, p + r + 1);
		     n = q + s;
		     goto create_temp;
		end;
		if opcode = div then do;
		     m = max_p_dec;
		     n = m - p + q - s;
		     goto create_temp;
		end;
	     end;
	     else do;
		result_type = result_type | decimal_mask | float_mask | aligned_mask;
		m = max (p, r);
		goto create_temp;
	     end;
	end;
%page;
/*
 * This code is executed for the negate and the prefix_plus operator.
 */
action (2):
	if opcode = prefix_plus then
	     call extract;
	if b -> node.type = label_node then
	     call semantic_translator$abort (78, null);

	if btype.bit then
	     string (btype) = integer_type;
	if btype.char then
	     string (btype) = dec_integer_type;
	if btype.picture then
	     if b -> symbol.complex then
		if b -> symbol.pic_float then
		     string (btype) = float_decimal_complex_mask;
		else
		     string (btype) = fixed_decimal_complex_mask;
	     else if b -> symbol.pic_float then
		string (btype) = float_decimal_real_mask;
	     else
		string (btype) = fixed_decimal_real_mask;

	if ^(btype.fixed | btype.float) then
	     call semantic_translator$abort (227, null);

	call converter;

	if opcode = prefix_plus then do;
	     tree = tree -> operand (2);
	     goto ret;
	end;

	m = b -> symbol.c_dcl_size;
	n = b -> symbol.scale;
	result_type = string (btype) & ^unaligned_mask | aligned_mask;
	goto create_temp;
%page;
/*
 * This code is executed for the ** operator.
 */
action (3):
	if b -> node.type = label_node | c -> node.type = label_node then
	     call semantic_translator$abort (78, null);

	old_rand (2) = tree -> operand (2);
	old_rand (3) = tree -> operand (3);

	if btype.bit | btype.char then
	     string (btype) = integer_type;
	if ctype.bit | ctype.char then
	     string (ctype) = integer_type;

	if btype.picture then
	     if b -> symbol.complex then
		if b -> symbol.pic_float then
		     string (btype) = float_decimal_complex_mask;
		else
		     string (btype) = fixed_decimal_complex_mask;
	     else if b -> symbol.pic_float then
		string (btype) = float_decimal_real_mask;
	     else
		string (btype) = fixed_decimal_real_mask;

	if ctype.picture then
	     if c -> symbol.complex then
		if c -> symbol.pic_float then
		     string (ctype) = float_decimal_complex_mask;
		else
		     string (ctype) = fixed_decimal_complex_mask;
	     else if c -> symbol.pic_float then
		string (ctype) = float_decimal_real_mask;
	     else
		string (ctype) = fixed_decimal_real_mask;

	if ^(btype.fixed | btype.float) then
	     call semantic_translator$abort (227, null);
	if ^(ctype.fixed | ctype.float) then
	     call semantic_translator$abort (227, null);

	decimal_result = btype.decimal & ctype.decimal;
	m_set = FALSE;

	string (ctype) = string (ctype) & ^decimal_mask | binary_mask;

	if ctype.fixed & ctype.real & c -> node.type = token_node then do;
	     m_set = TRUE;
	     c, e = convert ((old_rand (3)), string (ctype));
	     c = c -> reference.symbol;

	     value_of_y = constant_value (c);

	     if value_of_y > 0 & c -> symbol.scale = 0 then do;
		tree -> operand (3) = e;

		if btype.complex then
		     string (btype) = string (btype) & ^fixed_mask & ^decimal_mask | float_mask | binary_mask;

		tree -> operand (2), b = convert ((old_rand (2)), string (btype));
		if b -> node.type = operator_node then
		     b = b -> operand (1);
		b = b -> reference.symbol;

		p = b -> symbol.c_dcl_size;
		q = b -> symbol.scale;
		r = c -> symbol.c_dcl_size;
		s = c -> symbol.scale;

		m = max (p, r);
		n = 0;

		if btype.fixed & btype.real then do;
		     m = (p + 1) * value_of_y - 1;
		     n = q * value_of_y;

		     if m > max_p_fix_bin_2 | m > max_p_dec & btype.decimal then do;
			b, tree -> operand (2) = convert ((old_rand (2)), real_type);
			if b -> node.type = operator_node then
			     b = b -> operand (1);
			b = b -> reference.symbol;
			string (btype) = string (b -> symbol.attributes) & ^dimensioned_mask;
			p = b -> symbol.c_dcl_size;
			m = max (p, r);
		     end;
		end;
	     end;

	     else do;
		if value_of_y = 0 then do;
		     tree -> operand (3) = declare_constant$integer (0);
		     c = tree -> operand (3) -> reference.symbol;
		end;
		else do;
		     string (btype) = string (btype) & ^fixed_mask | float_mask;
		     string (ctype) = string (ctype) & ^fixed_mask | float_mask;

		     if btype.complex then
			string (ctype) = string (ctype) & ^real_mask | complex_mask;

		     c, tree -> operand (3) = convert ((old_rand (3)), string (ctype));
		     if c -> node.type = operator_node then
			c = c -> operand (1);
		     c = c -> reference.symbol;
		end;

		b, tree -> operand (2) = convert ((old_rand (2)), string (btype));
		if b -> node.type = operator_node then
		     b = b -> operand (1);
		b = b -> reference.symbol;

		p = b -> symbol.c_dcl_size;
		q = c -> symbol.c_dcl_size;
		m = max (p, q);
		n = 0;
	     end;

	     if ^btype.decimal then
		goto create_exp_call;
	end;

	rtype = btype;
	string (btype) = string (btype) & ^fixed_mask | float_mask;

	if ctype.float | c -> symbol.scale ^= 0 then do;
	     string (btype) = string (btype) & ^decimal_mask | binary_mask;
	     string (ctype) = string (ctype) & ^fixed_mask | float_mask;
	end;

	if btype.complex then do;
	     string (btype) = string (btype) & ^decimal_mask | binary_mask;

	     if ctype.float | ctype.decimal | ctype.complex then
		string (ctype) = string (ctype) & ^real_mask & ^fixed_mask | complex_mask | float_mask;
	end;
	else if ctype.complex then do;
	     string (btype) = string (btype) & ^decimal_mask & ^real_mask | binary_mask | complex_mask;
	     string (ctype) = string (ctype) & ^fixed_mask | float_mask;
	end;

	if btype.decimal then do;
	     float_dec_target = create_symbol (blk, null, by_compiler);
	     float_dec_target -> symbol.float, float_dec_target -> symbol.decimal, float_dec_target -> symbol.real,
		float_dec_target -> symbol.temporary = TRUE;
	     float_dec_target -> symbol.c_dcl_size = max_p_dec;

	     call declare (float_dec_target);

	     float_dec_target = float_dec_target -> symbol.reference;

	     tree -> operand (3) = convert ((old_rand (3)), string (ctype));
						/*   c can only be integer_type by now   */

	     if tree -> operand (3) -> node.type = operator_node then
		c = tree -> operand (3) -> operand (1) -> reference.symbol;
	     else
		c = tree -> operand (3) -> reference.symbol;

	     if ^m_set then do;
		b = convert ((old_rand (2)), string (btype));
		if b -> node.type = operator_node then
		     b = b -> operand (1);
		b = b -> reference.symbol;
		m = max (b -> symbol.c_dcl_size, c -> symbol.c_dcl_size);
	     end;

	     tree -> operand (2) = convert$to_target ((old_rand (2)), float_dec_target);
	     if tree -> operand (2) -> node.type = reference_node then
		if tree -> operand (2) -> reference.symbol -> symbol.c_dcl_size ^= max_p_dec then do;
		     b = create_operator (assign, 2);
		     b -> operand (1) = float_dec_target;
		     b -> operand (2) = tree -> operand (2);
		     tree -> operand (2) = b;
		end;

	     if tree -> operand (2) -> node.type = operator_node then
		b = tree -> operand (2) -> operand (1) -> reference.symbol;
	     else
		b = tree -> operand (2) -> reference.symbol;

	end;
	else
	     call converter;

	p = b -> symbol.c_dcl_size;
	q = c -> symbol.c_dcl_size;
	rprec = m;
	rscale = n;
	m = max (p, q);
	n = 0;

	if btype.decimal then do;
	     math_libe_no = 195;			/* decimal_exp_ */

	     if q > max_p_fix_bin_1 then do;
		math_libe_no = math_libe_no + 1;	/* decimal_exp2_ */
		m = max_p_dec;
	     end;

	     goto make_call;
	end;

	if ctype.fixed then
	     m = p;
	else if m > max_p_flt_bin_1 then do;
	     if p <= max_p_flt_bin_1 then
		tree -> operand (2) = convert$to_target ((old_rand (2)), (c -> symbol.reference));

	     if q <= max_p_flt_bin_1 then
		tree -> operand (3) = convert$to_target ((old_rand (3)), (b -> symbol.reference));
	end;

create_exp_call:
	if ctype.fixed then
	     if q <= max_p_fix_bin_1 then
		math_libe_no = 17;			/* xp2_ */
	     else
		math_libe_no = 197;			/* xp22_ */
	else
	     math_libe_no = 21;			/* xp3_ */

	if btype.float then
	     if m > max_p_flt_bin_1 then
		math_libe_no = math_libe_no + 1;
	     else
		;
	else if m > max_p_fix_bin_1 then
	     math_libe_no = math_libe_no + 1;

	if btype.complex then
	     math_libe_no = math_libe_no + 2;

	if btype.fixed & btype.real then
	     if m > max_p_fix_bin_1 then
		math_libe_no = 171;			/* diexp_*/
	     else
		math_libe_no = 147;			/*  iexp_ */

	if math_libe_no = 17 | math_libe_no = 18 | math_libe_no = 21 | math_libe_no = 22 | math_libe_no = 147
	     | math_libe_no = 171 then do;
	     if c -> symbol.constant then
		if constant_value (c) = 0 then do;
		     string (btype) = string (btype) & ^fixed_mask | float_mask;
		     m = min (b -> symbol.c_dcl_size, max_p_flt_bin_2);
		     tree = declare_constant ("000000010100"b || (60)"0"b, string (btype), m, 0);
						/*   representation of 1.0e0   */

		     goto ret;
		end;

	     tree -> operand (1) = declare_temporary (string (btype), m, n, null);
	     goto check_decimal;
	end;

make_call:
	qq = create_operator ((std_call), 3);
	qq -> operand (1) = declare_temporary (string (btype), m, n, null);
	qq -> operand (2) = reserve$declare_lib (math_libe_no);
	qq -> operand (2) -> reference.symbol -> symbol.irreducible = FALSE;
	qq -> operand (2) -> reference.symbol -> symbol.reducible = TRUE;
	qq -> operand (3) = create_operator (std_arg_list, 3);

	qq -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 8, 0, null);
	qq -> operand (3) -> operand (2), e = create_list (3);

	e -> element (1) = tree -> operand (2);
	e -> element (2) = tree -> operand (3);

	tree = qq;

	qq -> operand (1), e -> element (3) = copy_expression (qq -> operand (1));
	e -> element (3) -> reference.shared = FALSE;
	e -> element (3) -> reference.ref_count = 2;

check_decimal:
	if decimal_result then do;
	     if math_libe_no = 195 | math_libe_no = 196 /* decimal_exp_ | decimal_exp2_ */ then do;
		m = rprec;
		n = rscale;
		btype = rtype;
	     end;
	     else if btype.fixed then do;
		m = divide (bin (m, 15, 0) * 100 + 331, 332, 15, 0) + 1;
		n = divide (abs (n) * 100 + 331, 332, 15, 0) * sign (n);
	     end;
	     else do;
		m = divide (bin (m, 15, 0) * 100 + 331, 332, 15, 0);
		n = 0;
	     end;

	     qq = create_operator (assign, 2);
	     qq -> operand (1) = declare_temporary (string (btype) & ^binary_mask | decimal_mask, m, n, null);
	     qq -> operand (2) = tree;

	     tree = qq;
	end;

	goto ret;
%page;
/*
 * This code is executed for the string operators ^ | & ||
 */
action (4):
	if b -> node.type = label_node then
	     call semantic_translator$abort (78, null);

	if k > 2 then
	     if c -> node.type = label_node then
		call semantic_translator$abort (78, null);

	if opcode = cat_string & ^(btype.bit & ctype.bit) then
	     result_type, string (btype), string (ctype) = char_type;
	else
	     result_type, string (btype), string (ctype) = bit_type;

	call converter;

	do i = 2 to k;
	     if tree -> operand (i) -> node.type = operator_node then
		ref = tree -> operand (i) -> operand (1);
	     else
		ref = tree -> operand (i);

	     if ref -> reference.varying_ref then do;
		c_length (i) = 0;
		length (i) = create_length_fun ((tree -> operand (i)));
		length (i) -> operand (1) = copy_expression (length (i) -> operand (1));
		length (i) -> operand (1) -> reference.shared = FALSE;
	     end;
	     else do;
		c_length (i) = ref -> reference.c_length;
		length (i) = ref -> reference.length;
	     end;

	     if length (i) = null then
		prec (i) = max_length_precision;
	     else if length (i) -> node.type = operator_node then
		prec (i) = length (i) -> operand (1) -> reference.symbol -> symbol.c_dcl_size;
	     else
		prec (i) = length (i) -> reference.symbol -> symbol.c_dcl_size;
	end;

	if opcode = not_bits then do;
	     m = c_length (2);
	     size = share_expression (length (2));
	     goto create_temp;
	end;

	if length (2) = null & length (3) ^= null then
	     length (2) = declare_constant$integer (c_length (2));

	if length (3) = null & length (2) ^= null then
	     length (3) = declare_constant$integer (c_length (3));

	if length (2) = null then
	     if opcode = cat_string then
		m = c_length (2) + c_length (3);
	     else
		m = max (c_length (2), c_length (3));
	else do;
	     make_operator = TRUE;

	     if opcode = cat_string then do;
		s_opcode = add;
		prec (1) = min (max_p_fix_bin_1, max (prec (2), prec (3)) + 1);
	     end;
	     else do;
		if length (2) = length (3) | compare_expression (length (2), length (3)) then
		     make_operator = FALSE;
		else do;
		     s_opcode = max_fun;
		     prec (1) = min (max_p_fix_bin_1, max (prec (2), prec (3)));
		end;
	     end;

	     if make_operator then do;
		size = create_operator (s_opcode, 3);
		size -> operand (1) = declare_temporary (integer_type, prec (1), 0, null);
		size -> operand (2) = share_expression (length (2));
		size -> operand (3) = share_expression (length (3));
		size -> operator.processed = TRUE;
	     end;
	     else
		size = share_expression (length (2));
	end;

	goto create_temp;
%page;
/*
 * This code is executed for the assignment operator.
 */
action (5):
	if a -> node.type = label_node then
	     call semantic_translator$abort (135, null);

/* check for assignments to file or entry constants, but allow assignments
 * of addr to a file constant.  These are produced by the declaration
 * processor to initialize the file constant.
 */

	if a -> symbol.constant then
	     if ^(a -> symbol.file & blk -> block.prologue_flag) | tree -> operand (2) -> node.type ^= operator_node
		then
		call semantic_translator$abort (135, null);
	     else if tree -> operand (2) -> op_code ^= addr_fun then
		call semantic_translator$abort (135, null);

/* If the right side is a token, convert it to the type of the left side,
 * unless the left side has no type
 */

	if b -> node.type = token_node then
	     if string (atype) ^= "0"b then do;
		if tree -> operand (1) -> reference.varying_ref | a -> symbol.dcl_size ^= null
		     | tree -> operand (1) -> reference.length ^= null then
		     tree -> operand (2) = convert (b, string (atype));
		else
		     tree -> operand (2) = convert$to_target (b, (tree -> operand (1)));

		if tree -> operand (2) -> node.type = operator_node then
		     b = tree -> operand (2) -> operand (1) -> reference.symbol;
		else
		     b = tree -> operand (2) -> reference.symbol;

		string (btype) = string (b -> symbol.attributes);
	     end;
	     else do;
		b, tree -> operand (2) = convert ((tree -> operand (2)), string (btype));
		if b -> node.type = operator_node then
		     b = b -> operand (1);
		b = b -> reference.symbol;
	     end;

/* If the left side is a temporary with no data type, it is to acquire
 * the data type of the right side.
 */

	if a -> symbol.temporary & string (a -> symbol.data_type) = "0"b then do;
	     if b -> node.type = label_node then do;
		string (atype), substr (string (a -> symbol.attributes), 1, 36) = label_mask;

		call declare (a);
	     end;
	     else do;
		string (atype), substr (string (a -> symbol.attributes), 1, 36) =
		     substr (string (b -> symbol.attributes), 1, 36);
		a -> symbol.scale = b -> symbol.scale;

		a -> symbol.initialed, a -> symbol.overlayed, a -> symbol.position = FALSE;

		if b -> symbol.array = null then do;
		     a -> symbol.c_word_size = b -> symbol.c_word_size;
		     a -> symbol.c_bit_size = b -> symbol.c_bit_size;
		     a -> symbol.word_size = b -> symbol.word_size;
		     a -> symbol.bit_size = b -> symbol.bit_size;
		end;
		else do;
		     a -> symbol.c_word_size = b -> symbol.array -> array.c_element_size;
		     a -> symbol.c_bit_size = b -> symbol.array -> array.c_element_size_bits;
		     a -> symbol.word_size = b -> symbol.array -> array.element_size;
		     a -> symbol.bit_size = b -> symbol.array -> array.element_size_bits;
		end;

		if atype.char | atype.bit then do;
		     ref = tree -> operand (2);
		     if ref -> node.type = operator_node then
			ref = ref -> operand (1);
		     a -> symbol.c_dcl_size = ref -> reference.c_length;
		     a -> symbol.dcl_size = ref -> reference.length;
		     a -> symbol.exp_extents = ref -> reference.length ^= null;

		     if ^ref -> reference.varying_ref then do;
			a -> symbol.reference -> reference.c_length = ref -> reference.c_length;
			a -> symbol.reference -> reference.length = share_expression ((ref -> reference.length));
			a -> symbol.varying = FALSE;

			call get_size (a);
		     end;
		     else
			a -> symbol.reference -> reference.length, a -> symbol.dcl_size =
			     create_length_fun ((tree -> operand (2)));

		     a -> symbol.exp_extents = a -> symbol.reference -> reference.length ^= null;
		end;
		else do;
		     a -> symbol.pix = b -> symbol.pix;
		     a -> symbol.c_dcl_size = b -> symbol.c_dcl_size;
		     a -> symbol.general = b -> symbol.general;
						/* for offsets and picture */

		     if tree -> operand (2) -> node.type = reference_node then
			a -> symbol.reference -> reference.c_length = tree -> operand (2) -> reference.c_length;
		     else
			a -> symbol.reference -> reference.c_length =
			     tree -> operand (2) -> operand (1) -> reference.c_length;
		end;
	     end;

	     a -> symbol.dimensioned = FALSE;
	     string (a -> symbol.storage_class) = "0"b;
	     a -> symbol.temporary = TRUE;
	end;

/* If this assignment is to a char(*) or bit(*) return parameter,
 * then generate code to fill in the descriptor and then replace the
 * assignment with the expression converted to conform to the type
 * etc of the return parameter.
 */

	if def_context.return & a -> symbol.star_extents & a -> symbol.dcl_size ^= null & (atype.bit | atype.char)
	then do;
	     ref, tree = convert ((tree -> operand (2)), string (atype));

	     if ref -> node.type = operator_node then
		ref = ref -> operand (1);

	     if ref -> reference.varying_ref then
		c = create_length_fun (tree);

	     else if ref -> reference.length = null then
		c = declare_constant$integer ((ref -> reference.c_length));
	     else
		c = share_expression ((ref -> reference.length));

	     e = copy_expression (input_tree -> operand (1) -> reference.symbol -> symbol.descriptor);
	     e -> reference.shared = FALSE;
	     e -> reference.ref_count = 1;
	     desc =
		declare_constant$desc (
		string (e -> reference.symbol -> symbol.descriptor -> symbol.initial -> descriptor (0).bit_type));
	     call make (3, make_desc, e, desc, c);
	     stmnt -> statement.processed = TRUE;

	     goto ret;
	end;

/* If this assignment is a by_value argument, the left side is to
 * be replaced by a temporary whose data type is derived from the argument
 * descriptor.  The extents are given by the descriptor unless the
 * descriptor has star_extents, in the latter case the extents are
 * derived from the right side.
 */

	if def_context.arg_list & a -> symbol.param_desc then do;
	     n = a -> symbol.scale;

	     if atype.area then
		size = a -> symbol.dcl_size;

	     result_type = string (atype);

	     if atype.fixed | atype.float | atype.area then
		m = a -> symbol.c_dcl_size;
	     else if atype.bit | atype.char | atype.picture then
		if a -> symbol.star_extents & a -> symbol.dcl_size ^= null then do;
		     expr, ref = tree -> operand (2);

		     if ref -> node.type = operator_node then
			ref = ref -> operand (1);

		     if ref -> node.type ^= reference_node then
			call semantic_translator$abort (78, null);

		     if ^(ref -> reference.symbol -> symbol.bit | ref -> reference.symbol -> symbol.char) then
			expr, ref = convert ((tree -> operand (2)), string (atype));

		     if ref -> node.type = operator_node then
			ref = ref -> operand (1);

		     if ref -> reference.varying_ref then
			size = create_length_fun (expr);

		     else if ref -> reference.length ^= null then
			size = share_expression ((ref -> reference.length));
		     else
			m = ref -> reference.c_length;
		end;
		else
		     m = a -> symbol.c_dcl_size;

	     tree -> operand (1) = declare_temporary (result_type, m, n, size);

	     if a -> symbol.picture then do;
		tree -> operand (1) -> reference.symbol -> symbol.general = a -> symbol.general;
		tree -> operand (1) -> reference.symbol -> symbol.pix = a -> symbol.pix;
	     end;

	     a = tree -> operand (1) -> reference.symbol;
	end;

/* transform x = 0 into assign_zero(x)  */

	if b -> symbol.constant & btype.fixed & btype.binary & btype.real & b -> symbol.c_dcl_size <= max_p_fix_bin_1
	     then
	     if b -> symbol.initial -> integer = 0 & atype.fixed & atype.binary & atype.real
		& a -> symbol.c_dcl_size <= max_p_fix_bin_1 & a -> symbol.scale = 0 & ^a -> symbol.packed
		& ^a -> symbol.unaligned then do;
		tree -> operator.op_code = assign_zero;
		tree -> operator.number = 1;
		goto force_store;
	     end;


/* If the size condition is enabled, assignments to arithmetic values must
 * be done using a size_ck operator.  If the stringsize condition is enabled,
 * assignments to bit or character data must be done with the size_ck
 * operator.  No additional optimizations can be performed.
 */

	if substr (stmnt -> statement.prefix, 6, 1) & (atype.fixed | atype.float)
	     | substr (stmnt -> statement.prefix, 9, 1) & (atype.bit | atype.char | atype.picture) then
	     tree -> operator.op_code = assign_size_ck;

/* If the left side is a varying_ref then fill in the length fields with
 * the max length.
 */

	if tree -> operand (1) -> reference.varying_ref then do;
	     if a -> symbol.reference = tree -> operand (1) then do;
		tree -> operand (1), e = copy_expression (a -> symbol.reference);
		e -> reference.shared = FALSE;
		e -> reference.ref_count = 1;
	     end;

	     tree -> operand (1) -> reference.c_length = a -> symbol.c_dcl_size;

	     if a -> symbol.dcl_size ^= null then do;
		e = copy_expression (a -> symbol.dcl_size);
		if a -> symbol.refer_extents then
		     call refer_extent (e, (tree -> operand (1) -> reference.qualifier));
		e = expression_semantics ((a -> symbol.block_node), stmnt, (e), this_context);
		tree -> operand (1) -> reference.length = convert$to_integer (e, integer_type);
	     end;
	end;

	if b -> node.type = symbol_node then
	     if a -> symbol.picture | b -> symbol.picture & ^a -> symbol.char then
		tree -> operand (2) = convert$to_target ((tree -> operand (2)), (tree -> operand (1)));

/* If the right side is an operator whose output temporary has the
 * same attributes as the left side then replace the temp with a
 * reference to the left side.
 */

	if tree -> operand (2) -> node.type = operator_node & tree -> op_code = assign & ^def_context.return then do;
	     e = tree -> operand (2);

	     if e -> op_code = add | e -> op_code = sub then do;
		sym = e -> operand (1) -> reference.symbol;

		if sym -> symbol.fixed & sym -> symbol.binary & sym -> symbol.real & sym -> symbol.scale = 0
		     & atype.fixed & atype.binary & atype.real & a -> symbol.scale = 0
		     &
		     bool (sym -> symbol.c_dcl_size <= max_p_fix_bin_1, a -> symbol.c_dcl_size <= max_p_fix_bin_1,
		     "1001"b) then
		     goto replace;
	     end;

/* If the operator is a call then
 * the return temp is replaced with the left side reference.
 */

	     if compare_declaration ((tree -> operand (1)), (e -> operand (1)), e -> op_code ^= std_call) then do;
		if e -> op_code = std_call then do;
		     if tree -> operand (1) -> reference.substr
			& tree -> operand (1) -> reference.symbol -> symbol.aligned then
			goto force_store;

		     e = e -> operand (3) -> operand (2);

		     rv = e -> list.element (e -> list.number) -> reference.symbol;
		     if rv -> symbol.return_value then
			goto force_store;
		     if rv -> symbol.dimensioned then
			goto force_store;
		     if rv -> symbol.structure then
			goto force_store;

		     if tree -> operand (1) -> reference.symbol -> symbol.temporary then
			if tree -> operand (1) -> reference.shared then do;
			     tree -> operand (1) = copy_expression (tree -> operand (1));
			     tree -> operand (1) -> reference.shared = FALSE;
			     tree -> operand (1) -> reference.ref_count = 1;
			end;

		     e -> list.element (e -> list.number) = share_expression ((tree -> operand (1)));
		     tree -> operand (1) -> reference.symbol -> symbol.passed_as_arg = TRUE;
		end;
replace:
		e = tree -> operand (2);
		if e -> operand (1) -> reference.length ^= null then
		     call adjust_count ((e -> operand (1) -> reference.length));
		e -> operand (1) = tree -> operand (1);
		tree = e;
	     end;
	end;

/* If this is an assignment done because of by_value argument passing
 * insure that the output temporary has a ref_count of at least one.
 * This insures that the code generator will store the result into it.
 */

force_store:
	if def_context.arg_list then
	     if tree -> operand (1) -> reference.symbol -> symbol.temporary then
		if tree -> operand (1) -> reference.shared then do;
		     e = create_reference ((tree -> operand (1)));
		     e -> reference = tree -> operand (1) -> reference;
		     e -> reference.shared = FALSE;
		     e -> reference.ref_count = 1;
		     tree -> operand (1) = e;
		end;

	if tree -> op_code ^= assign & tree -> op_code ^= assign_size_ck then
	     goto ret;

	if a -> symbol.constant then
	     goto ret;

/* Pointer <--> Offset two-way conversion */

	if a -> symbol.offset & b -> symbol.ptr | b -> symbol.offset & a -> symbol.ptr then do;
	     if a -> symbol.offset then do;
		if b -> symbol.constant then do;

/* operand(2) is "null", turn it into "nullo" */

		     n = -1;
		     tree -> operand (2) = declare_constant (unspec (n), offset_mask, 0, 0);
		     goto ret;
		end;

		opcode = off_fun;
		c = copy_expression (a -> symbol.general);
		if c = null then
		     call semantic_translator$abort (435, a);
	     end;
	     else do;
		opcode = ptr_fun;
		c = copy_expression (b -> symbol.general);
		if c = null then
		     if ^b -> symbol.constant then do;
			if pl1_stat_$cur_statement -> statement.root -> op_code ^= allot_var then
			     call semantic_translator$abort (435, b);
			else if pl1_stat_$cur_statement -> statement.root -> operand (1) -> reference.qualifier
			     ^= tree then
			     call semantic_translator$abort (435, b);
		     end;
		     else do;
			tree -> operand (2) = declare_constant (unspec (c), pointer_type, 0, 0);
			goto ret;
		     end;
	     end;

	     c = expression_semantics (blk, stmnt, c, "0"b);

	     e = create_operator ((opcode), 3);		/* by value for efficiency */
	     e -> operand (1) = tree -> operand (1);
	     e -> operand (2) = tree -> operand (2);
	     e -> operand (3) = c;

	     tree = e;

	     goto ret;
	end;

/* If this is an assignment of an entry constant to an entry variable the
 * procedure identified by the entry constant cannot share its containing
 * block's stack frame.
 */
	if b -> node.type = symbol_node then
	     if btype.entry & b -> symbol.constant & b -> symbol.equivalence ^= null then do;
		b -> symbol.equivalence -> block.why_nonquick.assigned_to_entry_var = TRUE;
		b -> symbol.equivalence -> block.no_stack = FALSE;
	     end;

/* check the validity of the conversion implied by this assignment.  */

	if ^tree -> operator.processed then
	     call convert$validate ((tree -> operand (2)), (tree -> operand (1)));

	if a -> symbol.entry then
	     if b -> symbol.constant then
		if b -> symbol.internal then
		     do e = b -> symbol.block_node repeat e -> block.father while (e ^= null);
			e -> block.flush_at_call = TRUE;
		     end;

/* Area assignment is converted into a call to area_$assign(addr(a1),addr(a2)) */

	if atype.area then do;
	     e = create_list (2);

	     do i = 1 to 2;
		e -> element (i) = create_operator (addr_fun, 2);
		e -> element (i) -> operand (1) = declare_temporary (pointer_type, 0, 0, null);
		e -> element (i) -> operand (2) = tree -> operand (i);
	     end;

	     tree, pl1_stat_$cur_statement -> statement.root = create_operator ((std_call), 3);
	     tree -> operand (2) = reserve$declare_lib (161);
						/* area_assign_ */
	     tree -> operand (3) = create_operator (std_arg_list, 3);
	     tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 8, 0, null);
	     tree -> operand (3) -> operand (2) = e;
	end;

	goto ret;
%page;
/*
 * This code is executed for the relational operators.
 */
action (6):
	call convert_relationals;
	result_type = bit_type;
	m = 1;
	goto create_temp;
%page;
/*
 * This code is executed for the transfer operators.
 */
action (7):
	if a -> node.type = label_node then do;
	     if a -> label.used_as_format then
		call semantic_translator$abort (196, null);
	     a -> label.used_in_goto = TRUE;
	end;
	else if ^atype.label then
	     call semantic_translator$abort (229, null);

	if opcode ^= jump then do;
	     if opcode > jump_false then do;
		call convert_relationals;
	     end;

	     else if opcode = jump_true | opcode = jump_false then do;
		string (btype) = bit_type;
		call converter;

/* warn about ^ <expr> where <expr> is not bit(1) */

		if tree -> operand (2) -> node.type = operator_node then
		     if tree -> operand (2) -> operator.op_code = not_bits then
			if ^constant_length ((tree -> operand (2) -> operand (1)), 1) then
			     call semantic_translator$error (156, null);
	     end;

	     target = tree -> operand (1);

/* following block of code added by R. Barnes to fix 1542 & 1546 11/05/76 */

	     if target -> node.type ^= label_node then do;
		if target -> node.type = reference_node then
		     if target -> reference.qualifier = null & target -> reference.offset = null then
			goto ret;

/* exprs in the label ref must not be evaluated unless jump taken */

		next = create_list (2);
		tree -> operand (1), next -> element (2) = create_label (blk, null, by_compiler);

		tree -> operator.op_code = jump_complement (fixed (substr (opcode, 6, 4), 4));

		call make (1, jump, target, null, null);
		call make (0, null_statement, next, null, null);

		pl1_stat_$cur_statement = stmnt;
	     end;
	end;
	goto ret;
%page;
/*
 * This code :-) is executed for the length_fun
 */
action (8):
	goto ret;
%page;
/*
 * This code is executed for the std_call_operator.
 */
action (9):
	k = 2;
	call extract;
	if ^btype.entry then
	     call semantic_translator$abort (223, null);
	tree = function (blk, stmnt, tree, b, context);
	goto ret;
%page;
/*
 * This code is executed for the std_entry_operator.
 */
action (10):
	orig_stmnt_ptr = stmnt;

	if stmnt -> statement.statement_type = entry_statement then do;
	     qq = create_statement (goto_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
	     qq -> statement.root = create_operator (jump, 1);

	     next = create_list (2);
	     next -> list.element (2), qq -> statement.root -> operand (1) = create_label (blk, null, by_compiler);

	     qq = create_statement (null_statement, stmnt, next, (stmnt -> statement.prefix));
	     next -> list.element (2) -> label.statement = qq;
	     qq -> statement.reference_count = 1;
	end;

/* create assignment statements to all automatic pointers used to
 * qualify parameters or return values which appear in more than one position.
 */

	do i = 1 to k;
	     if tree -> operand (i) -> node.type ^= reference_node then
		goto ret;
	     a = tree -> operand (i) -> reference.symbol;

	     if tree -> operand (i) -> reference.varying_ref then do;
		tree -> operand (i) -> reference.c_length = a -> symbol.c_dcl_size;
		if a -> symbol.dcl_size ^= null then do;
		     tree -> operand (i) -> reference.length = copy_expression (a -> symbol.dcl_size);
		     tree -> operand (i) -> reference.length =
			expression_semantics (blk, stmnt, (tree -> operand (i) -> reference.length), "0"b);
		end;
	     end;

	     if a -> symbol.allocated then do;		/* if parameters appear in different positions */
		call make (3, param_ptr, (tree -> operand (i) -> reference.qualifier), declare_constant$integer (i),
		     blk);
		if a -> symbol.star_extents then
		     call make (3, param_desc_ptr,
			(tree -> operand (i) -> reference.symbol -> symbol.descriptor -> reference.qualifier),
			declare_constant$integer (i), blk);
	     end;
	end;

/* If the block has multiple return types create an assignment to the
 * automatic integer to identify which type is required when returning
 * from an invocation of the this entry.  Entries which do not return
 * values set the variable to zero.
 */

	if blk -> block.return_count ^= null then do;
	     if orig_stmnt_ptr -> statement.labels -> list.element (2) -> reference.symbol -> symbol.dcl_size = null
		then
		a = null;				/* from here on we want a to be the return value; if none, a = null	*/

	     i = 0;
	     b = blk -> block.return_values;

	     do while (b ^= null);
		if b -> list.element (2) = a then
		     goto hit;
		b = b -> list.element (1);
		i = i + 1;
	     end;
hit:
	     call make (2, assign, (blk -> block.return_count), declare_constant$integer (i), null);

/* The following call is because operator_semantics is the only person in
 * the compiler who makes an assign of zero into a store zero, for better code
 */

	     if i = 0 then
		stmnt -> statement.root = operator_semantics (blk, stmnt, (stmnt -> statement.root), this_context);
	end;

/* create an execute prologue operator. */

	call make (0, ex_prologue, null, null, null);

	pl1_stat_$cur_statement = stmnt;

	goto ret;
%page;
/*
 * This code is executed for the return_value operator
 * and also the std_return operator.
 */
action (11):
	signal_stmnt_ptr = null;

	if stmnt -> statement.statement_type = end_statement then do;
	     if blk -> block.block_type = begin_block | blk -> block.block_type = on_unit then
		goto ret;
	     end_statement_flag = TRUE;
	end;
	else
	     end_statement_flag = FALSE;

/* The following test checks for the case of an unreachable end
 * statement. We do not want to produce any checks for return value
 * compatablility; indeed we want to do as little as possible because the
 * optimizer and code generator will make it produce NO code, anyway.
 */

	if pl1_stat_$stmnt_unreachable then
	     if stmnt -> statement.labels = null then
		if end_statement_flag then
		     goto ret;

	if tree -> operator.op_code = return_value then
	     e = tree -> operand (1);
	else
	     e = null;

	do bb = blk repeat bb -> block.father while (bb -> block.block_type = begin_block);
	end;

	a = bb -> block.return_values;
	if a ^= null then				/* will be null if block entry was multiply declared */
	     if bb -> block.return_count = null & a -> list.element (2) = null then
		if e = null then
		     goto ret;
		else
		     call semantic_translator$abort (53, null);

	stmnt -> statement.statement_type = null_statement;
	stmnt -> statement.generated = TRUE;

	tree = null;

	i = 0;
	jump_stmnt, next = null;

	if bb -> block.return_count ^= null then
	     if e ^= null then
		call prepare (e);

	first_time = TRUE;
	after_ret = stmnt -> statement.next;
	pl1_stat_$multi_type = bb -> block.return_count ^= null;
	if pl1_stat_$multi_type then do;
	     hold_abort_label = pl1_stat_$abort_label;	/* pl1_stat_$abort_label is used in other */
	     pl1_stat_$abort_label = continue;		/* programs and must be saved & restored. */
	end;

	do a = a repeat a -> element (1) while (a ^= null);
	     pl1_stat_$error_flag = FALSE;
	     if pl1_stat_$multi_type then
		if a -> element (1) ^= null then do;
		     next = create_list (2);
		     next -> list.element (2) = create_label (blk, null, by_compiler);
		     call make (3, jump_if_ne, (next -> list.element (2)), (bb -> block.return_count),
			declare_constant$integer (i));
		     last_jump = jump_stmnt;
		     jump_stmnt = stmnt;
		end;
		else
		     next = null;			/* if no next element, there is no need for a 	*/
						/* compare because the indeces MUST be equal, since	*/
						/* all the previous tests must have failed and	*/
						/* there are no more possibilities.	*/
	     first = stmnt;
	     last = stmnt -> statement.next;

/*
 * The following code handles the case of "return;", where there is no
 * return value.
 */

	     if e = null then
		if a -> list.element (2) = null then do;
		     call make (0, std_return, null, null, null);
		     goto end_of_ret_assignment_loop;
		end;
		else do;
		     if pl1_stat_$multi_type | end_statement_flag then
			goto make_signal_statement;
		     else
			call semantic_translator$abort (356, null);
		end;

/* the following handles the case of "return(value);" where the
 * entry entered through expected NO return_value, but just a
 * simple "return;"
 */

	     if a -> list.element (2) = null then
		goto make_signal_statement;

/* The rest of the loop handles the case of "return(value);" where
 * the entry did expect a return_value.
 */

	     ref = a -> list.element (2);
	     b = create_operator (assign, 2);
	     b -> operand (1) = copy_expression (ref -> symbol.reference);
	     b -> operand (1) = expression_semantics (blk, stmnt, (b -> operand (1)), this_context);

	     if first_time then
		b -> operand (2) = e;
	     else
		b -> operand (2) = copy_ref (e);

	     first_time = FALSE;

	     def_this_context.return = TRUE;
	     def_this_context.RHS_aggregate = ref -> symbol.structure | ref -> symbol.reference -> reference.array_ref;

	     if ref -> symbol.structure | ref -> symbol.dimensioned then do;
		stmnt = stmnt -> statement.next;
		b = expand_assign (blk, stmnt, b, this_context, null);
		stmnt = stmnt -> statement.back;

		if ref -> symbol.star_extents then do;
		     if b -> node.type = operator_node then do;
			es = b -> operand (1) -> reference.symbol;
			qq = b -> operand (1) -> reference.qualifier;
		     end;
		     else
			es = b -> reference.symbol;

		     if es -> symbol.packed then do;
			opcode = return_bits;
			if es -> symbol.bit_size = null then
			     size = declare_constant$integer ((es -> symbol.c_bit_size));
			else
			     size = es -> symbol.bit_size;
		     end;
		     else do;
			opcode = return_words;
			if es -> symbol.word_size = null then
			     size = declare_constant$integer ((es -> symbol.c_word_size));
			else
			     size = es -> symbol.word_size;
		     end;

		     size = copy_expression ((size));

		     if es -> symbol.refer_extents then
			call refer_extent (size, qq);

		     size = expression_semantics (blk, stmnt, size, this_context);

		     call make (2, (opcode), b, size, null);
						/* by value for efficiency */
		end;
		else
		     call make (0, std_return, null, null, null);

		goto continue;
	     end;

	     if def_context.aggregate then
		call semantic_translator$abort (50, null);

	     b = operator_semantics (blk, stmnt, b, this_context);

	     if ref -> symbol.star_extents then do;
		if b -> node.type = operator_node & b -> op_code = assign then do;
		     do qq = b -> operand (2) repeat qq -> operand (1) while (qq -> node.type = operator_node);
		     end;

		     if qq -> reference.symbol -> symbol.char then
			b = b -> operand (2);
		end;

		call make (2, return_string, b, null, null);
	     end;
	     else do;

/* Place the output of operator semantics directly into the statement.
 * Since the operator may be assign (2 operands) or
 * ptr_fun|off_fun (3 operands), we cannot use the internal procedure "make".
 */

		qq = create_statement (assignment_statement, stmnt, null, (stmnt -> statement.prefix));
		qq -> statement.generated = TRUE;
		qq -> statement.root = b;
		if pl1_stat_$multi_type then
		     qq -> statement.suppress_warnings = TRUE;
		stmnt = stmnt -> statement.next;
		call make (0, std_return, null, null, null);
	     end;

continue:
	     if pl1_stat_$error_flag then do;
make_signal_statement:
		qq = first -> statement.next;

		do while (qq ^= last);
		     qq = qq -> statement.next;
		     call free_node ((qq -> statement.back));
		end;

		first -> statement.next = last;
		if last ^= null then
		     last -> statement.back = first;

		if signal_stmnt_ptr = null then do;
		     qq = create_token ("return_conversion_error", identifier);

		     if qq -> token.declaration = null then do;
			ref = create_symbol (pl1_stat_$root, qq, by_compiler);
			ref -> symbol.condition = TRUE;
			call declare (ref);
		     end;
		     else
			ref = qq -> token.declaration;

		     stmnt = create_statement (signal_statement, first, null, (first -> statement.prefix));
		     stmnt -> statement.root = create_operator (signal_on, 2);
		     stmnt -> statement.root -> operand (1) = ref -> symbol.reference;
		     label_attached = FALSE;
		     signal_stmnt_ptr = stmnt;

/* now generate a garbage return, which can never be executed because this
 * signal never returns, but which is used to tell the cg that there is
 * no fall-through here, so you dont have to reload regs.
 */

		     call make (0, std_return, null, null, null);
		end;
		else do;
		     if ^label_attached then do;
			qq = create_list (2);
			qq -> element (2) = create_label (blk, null, by_compiler);
			qq -> element (2) -> label.statement = signal_stmnt_ptr;
			signal_stmnt_ptr -> statement.reference_count = 1;
			signal_stmnt_ptr -> statement.labels = qq;

/* from now on signal_stmnt_ptr points to the label of the stmnt to raise
 * the conv error, whereas previously it pointed to the statement itself.
 */

			signal_stmnt_ptr = qq -> list.element (2);
			label_attached = TRUE;
		     end;

/* We would like to do some optimizations which are
 * only valid if we previously generated a jump_if_ne and if
 * we are the last entry point conversion being processed.
 */

		     if jump_stmnt = null | a -> element (1) ^= null then do;
			stmnt = create_statement (goto_statement, first, null, (first -> statement.prefix));
			stmnt -> statement.root = create_operator (jump, 1);
			stmnt -> statement.root -> operator.operand (1) = signal_stmnt_ptr;
			signal_stmnt_ptr -> label.statement -> statement.reference_count =
			     signal_stmnt_ptr -> label.statement -> statement.reference_count + 1;
		     end;
		     else if jump_stmnt -> statement.root -> operand (1) -> label.statement = stmnt then do;
			if jump_stmnt -> statement.next -> statement.statement_type = goto_statement then
			     if jump_stmnt -> statement.next -> statement.root -> operand (1) -> label.statement
				-> statement.statement_type = signal_statement then do;

/* This block of code is for the sole purpose of optimizing
 * the case where the end of the statement looks like:
 *		jump to l1 if ^= 2
 *		do conversion
 *	l1:	jump to l2 if ^= 1
 *		goto <raise signal>
 *	l2:	goto <raise signal>
 *
 * and changing it to look like:
 * 		jump to <raise_signal> if ^= 2
 * 		do conversion
 *				
 * which is of course vastly preferable code.
 */

				last_jump -> statement.root -> operand (1) = signal_stmnt_ptr;
				if after_ret ^= null then
				     after_ret -> statement.back = jump_stmnt -> statement.back;
				jump_stmnt -> statement.back -> statement.next = after_ret;

/* we needn't reset ptrs cause we can never reenter loop */

				stmnt = jump_stmnt -> statement.back;
			     end;
			     else
				goto normal_sig;
			else
			     goto normal_sig;
		     end;
		     else do;
normal_sig:
			jump_stmnt -> statement.root -> operator.operand (1) = signal_stmnt_ptr;
			signal_stmnt_ptr -> label.statement -> statement.reference_count =
			     signal_stmnt_ptr -> label.statement -> statement.reference_count + 1;
			jump_stmnt, next = null;
		     end;
		end;
	     end;

end_of_ret_assignment_loop:
	     i = i + 1;

	     if next ^= null then do;
		call make (0, null_statement, next, null, null);
		stmnt -> statement.save_temps = TRUE;
	     end;
	end;

	if pl1_stat_$multi_type then
	     pl1_stat_$abort_label = hold_abort_label;

	pl1_stat_$multi_type = FALSE;
	pl1_stat_$cur_statement = stmnt;

	goto ret;
%page;
/*
 * This code is executed for operators whose operands must be binary integers
 * and whose output is a binary integer.
 */
action (12):
	do i = 2 to k;
	     tree -> operand (i) = convert$to_integer ((tree -> operand (i)), integer_type);
	end;

	result_type = integer_type;
	m = default_fix_bin_p;
	goto create_temp;
%page;
/*
 * This code is executed for operators whose operands must be integers
 * but whose output can be anything.
 */
action (13):
	do i = 2 to k;
	     tree -> operand (i) = convert$to_integer ((tree -> operand (i)), integer_type);
	end;
	goto ret;
%page;
/*
 * This code is executed for operators whose operands can be anything
 * but whose result is a binary integer.
 */
action (14):
	result_type = integer_type;
	m = max_offset_precision;
	goto create_temp;
%page;
/*
 * This code is executed for operators whose operands can be anything
 * but whose result is a pointer.
 */
action (15):
	result_type = pointer_type;
	goto create_temp;
%page;
/*
 * This code is executed for I/O operators.
 */
action (16):
	call io_semantics (blk, stmnt, tree);

	goto ret;
%page;
/*
 * This code is executed for DO operators.
 */
action (17):
	call do_semantics (blk, stmnt, tree);
	tree = null;

	goto ret;
%page;
/*
 * This code is executed for allocate and free operators.
 */
action (18):
	call alloc_semantics (blk, stmnt, tree);
	goto ret;
%page;
/*
 * This code is executed for mod_bit, mod_byte, mod_half, and
 * for mod_word operators.
 */
action (19):
	do i = 1 to 2;
	     tree -> operand (i) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
	end;
	goto ret;
%page;
/*
 * This code is executed for the loop operator
 */
action (20):
	if tree -> operand (1) -> node.type = token_node then do;
	     string (atype) = decoded_type (fixed (tree -> operand (1) -> token.type));
	     tree -> operand (1) = convert ((tree -> operand (1)), string (atype));
	end;

	do i = 3 to 4;
	     tree -> operand (i) = convert$to_integer ((tree -> operand (i)), integer_type);
	end;

	goto ret;
%page;
/*
 * This code is required for on-, revert-, and signal-statements
 */
action (21):
	if tree -> operand (1) -> node.type = label_node then
	     call semantic_translator$abort (78, null);

	if ^tree -> operand (1) -> reference.symbol -> symbol.condition then
	     call semantic_translator$abort (268, (tree -> operand (1)));

	if tree -> operand (2) ^= null then
	     if tree -> operand (2) -> node.type = label_node then
		call semantic_translator$abort (78, null);
	     else if ^tree -> operand (2) -> reference.symbol -> symbol.file then
		call semantic_translator$abort (477, (tree -> operand (2)));

	if opcode = enable_on then
	     do e = blk repeat e -> block.father while (e ^= null);
		e -> block.flush_at_call = TRUE;
	     end;

	if opcode = signal_on then do;
	     qq = tree -> operand (1) -> reference.symbol -> symbol.general -> reference.symbol;
	     cond_name = substr (qq -> symbol.initial -> based_char, 1, qq -> symbol.c_dcl_size);

	     do i = 1 to 19;
		if condition_name (i) = cond_name then do;
		     if i > 10 then
			i = i - 10;
		     if substr (stmnt -> statement.prefix, i, 1) = "0"b then do;
			tree = create_operator (nop, 0);
			stmnt -> statement.statement_type = null_statement;
			goto ret;
		     end;
		end;
	     end;
	end;

	else do;
	     blk -> block.why_nonquick.condition_statements = TRUE;
	     blk -> block.no_stack = FALSE;
	end;

	goto ret;
%page;
/*
 * This code is executed by almost everybody.
 */
create_temp:
	tree -> operand (1) = declare_temporary (result_type, m, n, size);
	goto ret;
%page;
/*
 * subroutine to make an operator and a statement.
 */
make:
     procedure (n, code, a, b, c);

	dcl      n fixed bin (15) parameter;
	dcl      code bit (9) aligned parameter;
	dcl      (a, b, c) ptr parameter;

	dcl      (labels, p, q) ptr;
	dcl      stype bit (9) aligned;

	p, labels = null;
	stype = assignment_statement;
	if code = jump_if_ne then
	     stype = if_statement;
	else if code = jump then
	     stype = goto_statement;
	else if code = return_string | code = return_bits | code = return_words | code = std_return then
	     stype = return_statement;

	if code = null_statement then do;
	     stype = code;
	     labels = a;
	end;
	else do;
	     p = create_operator (code, n);
	     if n > 0 then
		p -> operand (1) = a;
	     if n > 1 then
		p -> operand (2) = b;
	     if n > 2 then
		p -> operand (3) = c;
	end;

	q = create_statement (stype, stmnt, labels, (stmnt -> statement.prefix));

	q -> statement.generated = TRUE;

	if code = null_statement then
	     if labels ^= null then do;
		labels -> list.element (2) -> label.statement = q;
		q -> statement.reference_count = 2;
	     end;
	     else if pl1_stat_$multi_type then
		q -> statement.suppress_warnings = TRUE;

	q -> statement.root = p;
	stmnt = stmnt -> statement.next;

     end make;
%page;
/*
 * subroutine to force the proper conversions of relational operators.
 */
convert_relationals:
     procedure ();

	dcl      i fixed bin (15);

	if b -> node.type = label_node then
	     if c -> node.type = label_node then
		return;
	     else if ctype.label then
		return;
	     else
		call semantic_translator$abort (229, null);
	if c -> node.type = label_node then
	     if b -> node.type = label_node then
		return;
	     else if btype.label then
		return;
	     else
		call semantic_translator$abort (229, null);
	if btype.area | ctype.area then
	     call semantic_translator$abort (51, null);
	if btype.ptr & ctype.offset then do;
	     tree -> operand (3) = convert ((tree -> operand (3)), pointer_type);
	     tree -> operand (3) -> operator.processed = FALSE;
	     tree -> operand (3) = operator_semantics (blk, stmnt, (tree -> operand (3)), "0"b);
	     tree -> operand (3) -> operator.processed = TRUE;
	     return;
	end;
	if btype.offset & ctype.ptr then do;
	     if c -> symbol.constant then do;

/* convert "null" to "nullo" */

		i = -1;
		tree -> operand (3) = declare_constant (unspec (i), offset_mask, 0, 0);
	     end;
	     else do;
		tree -> operand (2) = convert ((tree -> operand (2)), pointer_type);
		tree -> operand (2) -> operator.processed = FALSE;
		tree -> operand (2) = operator_semantics (blk, stmnt, (tree -> operand (2)), "0"b);
		tree -> operand (2) -> operator.processed = TRUE;
	     end;
	     return;
	end;

picture_redo:
	if btype.bit & ctype.bit then
	     goto conv;
	if btype.char & ctype.char then
	     goto conv;
	if btype.bit & ctype.char then do;
	     string (btype) = string (btype) & ^bit_mask | char_mask;
	     goto conv;
	end;
	if btype.char & ctype.bit then do;
	     string (ctype) = string (ctype) & ^bit_mask | char_mask;
	     goto conv;
	end;
	if (btype.bit | btype.char) & (ctype.fixed | ctype.float) then do;
	     string (btype) = string (ctype);
	     goto conv;
	end;
	if (ctype.bit | ctype.char) & (btype.fixed | btype.float) then do;
	     string (ctype) = string (btype);
	     goto conv;
	end;

	if btype.picture then do;
	     if b -> symbol.pic_char then
		string (btype) = char_mask;
	     else if b -> symbol.complex then
		if b -> symbol.pic_float then
		     string (btype) = float_decimal_complex_mask;
		else
		     string (btype) = fixed_decimal_complex_mask;
	     else if b -> symbol.pic_float then
		string (btype) = float_decimal_real_mask;
	     else
		string (btype) = fixed_decimal_real_mask;

	     goto picture_redo;
	end;

	if ctype.picture then do;
	     if c -> symbol.pic_char then
		string (ctype) = char_mask;
	     else if c -> symbol.complex then
		if c -> symbol.pic_float then
		     string (ctype) = float_decimal_complex_mask;
		else
		     string (ctype) = fixed_decimal_complex_mask;
	     else if c -> symbol.pic_float then
		string (ctype) = float_decimal_real_mask;
	     else
		string (ctype) = fixed_decimal_real_mask;

	     goto picture_redo;
	end;

	if btype.binary & ctype.decimal then
	     string (ctype) = string (ctype) & ^decimal_mask | binary_mask | aligned_mask;
	if btype.decimal & ctype.binary then
	     string (btype) = string (btype) & ^decimal_mask | binary_mask | aligned_mask;
	if btype.binary then do;
	     if btype.fixed & ctype.float then
		string (btype) = string (btype) & ^fixed_mask | float_mask | aligned_mask;
	     if btype.float & ctype.fixed then
		string (ctype) = string (ctype) & ^fixed_mask | float_mask | aligned_mask;
	end;
	if btype.complex then
	     string (ctype) = string (ctype) & ^real_mask | complex_mask;
	if ctype.complex & ^btype.complex then
	     string (btype) = string (btype) & ^real_mask | complex_mask;

	if index (string (btype), "1"b) ^= index (string (ctype), "1"b) & ^(btype.decimal & ctype.decimal) then
	     call semantic_translator$abort (186, null);

conv:
	if index (string (btype), "1"b) > 5 | btype.complex then
	     if opcode ^= equal & opcode ^= not_equal & opcode ^= jump_if_eq & opcode ^= jump_if_ne then
		call semantic_translator$abort (198, null);

	call converter;

     end convert_relationals;
%page;
/*
 * subroutine to force a conversion.
 * and set the strings "btype" and "ctype" accordingly
 */
converter:
     procedure ();

	dcl      r ptr;

	if k > 1 then do;
	     if tree -> operand (2) -> node.type = token_node then
		tree -> operand (2) = convert ((tree -> operand (2)), string (btype));
	     else if btype.decimal & b -> symbol.decimal then
		;
	     else if btype.binary & b -> symbol.binary & btype.real = b -> symbol.real & btype.fixed = b -> symbol.fixed
		then
		;
	     else do;
		if (string (btype) & arithmetic_mask) ^= "0"b then
		     string (btype) = string (btype) & ^unaligned_mask | aligned_mask;
		tree -> operand (2) = convert ((tree -> operand (2)), string (btype));
	     end;

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

	     b = r -> reference.symbol;
	end;

	if k > 2 then do;
	     if tree -> operand (3) -> node.type = token_node then
		tree -> operand (3) = convert ((tree -> operand (3)), string (ctype));
	     else if ctype.decimal & c -> symbol.decimal then
		;
	     else if ctype.binary & c -> symbol.binary & ctype.real = c -> symbol.real & ctype.fixed = c -> symbol.fixed
		then
		;
	     else do;
		if (string (ctype) & arithmetic_mask) ^= "0"b then
		     string (ctype) = string (ctype) & ^unaligned_mask | aligned_mask;
		tree -> operand (3) = convert ((tree -> operand (3)), string (ctype));
	     end;

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

	     c = r -> reference.symbol;
	end;

     end converter;
%page;
/*
 * subroutine to extract pointers to the first 1 2 or 3 operand's symbol nodes
 */
extract:
     procedure ();

	if k > 0 then do;
	     a = tree -> operand (1);

	     if a ^= null then do;
		if a -> node.type = operator_node then
		     a = a -> operand (1);

		if a -> node.type = token_node then
		     string (atype) = decoded_type (fixed (a -> token.type));

		if a -> node.type = label_node then
		     string (atype) = "0"b;

		if a -> node.type = reference_node then do;
		     a = a -> reference.symbol;
		     if a -> node.type = symbol_node then
			string (atype) = string (a -> symbol.attributes) & ^dimensioned_mask;
		     else
			string (atype) = "0"b;
		end;

		if a -> node.type = symbol_node then
		     if atype.arg_descriptor & opcode ^= assign & opcode ^= make_desc then do;
			qq = create_operator (assign, 2);
			qq -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
			qq -> operand (2) = tree -> operand (1);
			qq -> operator.processed = TRUE;

			a = qq -> operand (1) -> reference.symbol;
			string (atype) = integer_type;
			tree -> operand (1) = qq;
		     end;
	     end;
	end;

	if k > 1 then do;
	     b = tree -> operand (2);

	     if b ^= null then do;
		if b -> node.type = operator_node then
		     b = b -> operand (1);

		if b -> node.type = token_node then
		     if b -> token.type = dec_integer & k > 2 then
			string (btype) = dec_integer_type;
		     else
			string (btype) = decoded_type (fixed (b -> token.type));

		if b -> node.type = label_node then
		     string (btype) = "0"b;

		if b -> node.type = reference_node then do;
		     b = b -> reference.symbol;
		     string (btype) = string (b -> symbol.attributes) & ^dimensioned_mask;
		end;

		if b -> node.type = symbol_node then
		     if btype.arg_descriptor & opcode ^= assign & opcode ^= make_desc then do;
			qq = create_operator (assign, 2);
			qq -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
			qq -> operand (2) = tree -> operand (2);
			qq -> operator.processed = TRUE;

			b = qq -> operand (1) -> reference.symbol;
			string (btype) = integer_type;
			tree -> operand (2) = qq;
		     end;
	     end;
	end;

	if k > 2 then do;
	     c = tree -> operand (3);

	     if c ^= null then do;
		if c -> node.type = operator_node then
		     c = c -> operand (1);

		if c -> node.type = token_node then
		     if c -> token.type = dec_integer then
			string (ctype) = dec_integer_type;
		     else
			string (ctype) = decoded_type (fixed (c -> token.type));

		if c -> node.type = label_node then
		     string (ctype) = "0"b;

		if c -> node.type = reference_node then do;
		     c = c -> reference.symbol;
		     string (ctype) = string (c -> symbol.attributes) & ^dimensioned_mask;
		end;

		if c -> node.type = symbol_node then
		     if ctype.arg_descriptor & opcode ^= assign & opcode ^= make_desc then do;
			qq = create_operator (assign, 2);
			qq -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
			qq -> operand (2) = tree -> operand (3);
			qq -> operator.processed = TRUE;

			c = qq -> operand (1) -> reference.symbol;
			string (ctype) = integer_type;
			tree -> operand (3) = qq;
		     end;
	     end;
	end;

     end extract;
%page;
/*
 * This procedure creates a separate assignment statement for an operator,
 * if it finds one, in the expression to be returned, because that is
 * the only way to force the order of evaluation so that the expression
 * will be eval'ed before the tests which determine which assignment,
 * in the case of multiple return statements and entry points are made.
 */
prepare:
     procedure (pt);

	dcl      pt ptr parameter;
	dcl      p ptr;

	p = pt;

	if p -> node.type = operator_node then do;
	     if p -> op_code = param_ptr | p -> op_code = param_desc_ptr then
		return;

	     stmnt = create_statement (assignment_statement, stmnt, null, (stmnt -> statement.prefix));
	     stmnt -> statement.root = share_expression (p);
	end;
	else do;
	     if p -> node.type ^= reference_node then
		return;

	     if p -> reference.qualifier ^= null then
		call prepare ((p -> reference.qualifier));

	     if p -> reference.offset ^= null then
		call prepare ((p -> reference.offset));

	     if p -> reference.length ^= null then
		call prepare ((p -> reference.length));
	end;

     end prepare;
%page;
copy_ref:
     procedure (pt) returns (ptr);

	dcl      pt ptr parameter;
	dcl      (p, q) ptr;


/* If the input is an unshared reference, get a unique value,
 * otherwise, use share_expression
 */

	p = pt;

	if p -> node.type = reference_node then do;
	     if p -> reference.shared then
		return (p);

	     q = create_reference (null);
	     q -> reference = p -> reference;
	     q -> reference.ref_count = 1;

	     if q -> reference.qualifier ^= null then
		q -> reference.qualifier = share_expression ((q -> reference.qualifier));
	     if q -> reference.offset ^= null then
		q -> reference.offset = share_expression ((q -> reference.offset));
	     if q -> reference.length ^= null then
		q -> reference.length = share_expression ((q -> reference.length));

	     return (q);
	end;

	else
	     return (share_expression (p));

     end copy_ref;
%page;
/*
 * subroutine to create a length_fun operator and return a ptr to it
 */
create_length_fun:
     procedure (op2) returns (ptr);

	dcl      op2 pointer parameter;
	dcl      p pointer;

	p = create_operator (length_fun, 2);
	p -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
	p -> operand (2) = share_expression (op2);
	return (p);
     end create_length_fun;
%page;

ret:
	if tree ^= null then
	     if tree -> node.type = operator_node then
		tree -> operator.processed = TRUE;

	return (tree);
%page;
/*
 * get the initial value of a fixed binary variable with a scale
 * factor of zero
 */
constant_value:
     procedure (sym_ptr) returns (fixed bin (71));

	dcl      sym_ptr ptr parameter;

	dcl      integer_1 based fixed bin (35);
	dcl      integer_2 based fixed bin (71);
	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;
%page;
%include condition_name;
%page;
%include semant;
%page;
%include array;
%page;
%include symbol;
%page;
%include pl1_symbol_type;
%page;
%include symbol_bits;
%page;
%include operator;
%page;
%include mask;
%page;
%include label;
%page;
%include list;
%page;
%include block;
%page;
%include block_types;
%page;
%include statement;
%page;
%include reference;
%page;
%include semantic_bits;
%page;
%include op_codes;
%page;
%include statement_types;
%page;
%include nodes;
%page;
%include system;
%page;
%include token;
%page;
%include token_types;
%page;
%include declare_type;
%page;
%include decoded_token_types;
%page;
%include jump_complement;
%page;
%include pl1_descriptor;

     end operator_semantics;




		    pl1_data.cds                    10/04/83  1029.6rew 10/04/83  1024.9      571356



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

/* format: style2 */
(stringrange, stringsize):
pl1_data:
     proc;

/*
	Converted to create_data_segment_  07/07/76 by Bernard Greenberg
	Modified:	27 Dec 1976 by Richard Barnes for after, before, ltrim, rtrim
	Modified:	30 Dec 1976 by RAB for collate9 and high9
	Modified:	17 Feb 1977 by RAB for -check_ansi
	Modified: April 1977 to add codeptr, currentsize, clock, environmentptr,
				maxlength, stackbaseptr, stackframeptr,
				stacq, vclock by RHS
	Modified:	10 May 1977 by RAB to fix 1573 (sum & prod)
	Modified 770519 by PG to add substraddr
	Modified:	12 July 1977 by RAB to fix maxlength & change stacq definition
	Modified: 29 Mar 1978 by PCK to add codeptr, environmentptr, stackbaseptr, and stackframeptr
	Modified 790202 by PG to add byte and rank
	Modified 830101 by BIM add addcharno addbitno addwordno setcharno
		setbitno setwordno, remove substraddr.
*/

	dcl     create_data_segment_	 ext entry (ptr, fixed bin (35) aligned);
	dcl     com_err_		 entry options (variable);
	dcl     1 cdsa		 like cds_args aligned;
	dcl     (get_temp_segments_, release_temp_segments_)
				 entry (char (*), (*) ptr, fixed bin (35));
	dcl     (cleanup, stringrange, stringsize, error)
				 condition;
	dcl     code		 fixed bin (35);
	dcl     myname		 char (10) init ("pl1_data") static internal options (constant);
	dcl     segptrs		 (1) ptr init (null ());


	dcl     (i, j)		 fixed bin (15);

	dcl     p			 ptr;


	dcl     (addr, collate, divide, substr, unspec, null)
				 builtin;

	dcl     ioa_		 entry options (variable);

	dcl     collating_overlay	 (0:511) bit (9) unal based (addr (p -> long_collating_sequence));

	dcl     1 pl1_data		 based (p),
		2 long_collating_sequence
				 char (512) aligned,
		2 builtin_name,
		  3 number_of_names	 fixed bin (15),
		  3 description	 (127 refer (pl1_data.number_of_names)),
		    4 name	 char (14),
		    4 aggregate_result
				 bit (1),
		    4 nonstandard	 bit (1),
		    4 unused	 bit (7),
		    4 opcode	 bit (9),
		    4 reserve_list_number
				 fixed bin (15),
		    4 jump_index	 fixed bin (15),
		    4 check_indicator
				 fixed bin (15),
		    4 number1	 fixed bin (15),
		    4 number2	 fixed bin (15),
		    4 number_of_descriptions
				 fixed bin (15),
		    4 descriptor	 (4),
		      5 check_code	 fixed bin (15),
		      5 type	 bit (36) aligned;

/*	check_indicator		resulting action:

	1			number1 is required number of arguments
	2			number1 is minimum number of arguments
	3			number1 is minimum number of arguments,
				number2 is maximum number of arguments.

	check_code		resulting action:

	1			argument must be of this type
	2			argument should be converted to this type
	3			argument should be converted to float binary
	4			argument should be converted to arithmetic type
	5			argument should be converted to integer type
	6			argument should be real decimal fixed constant
	7			argument should be converted to string type
	8			argument must either be a bit string or real fixed binary
	9			argument must be variable
	10			argument must be computational
	11			argument must be real and converted to float binary
	12			argument must be entry, label, or format value
						*/


%include cds_args;

%include mask;
%include op_codes;
%include system;

/*      */

	on stringsize
	     begin;
		call com_err_ (0, myname, "Stringsize condition raised.");
		signal error;
	     end;
	on cleanup call release_temp_segments_ (myname, segptrs, (0));
	call get_temp_segments_ (myname, segptrs, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, "Getting temp segments");
		return;
	     end;

	p = segptrs (1);

/*      */

	i = 1;
	p -> builtin_name.description (i).name = "abs";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = abs_fun;
	p -> builtin_name.description (i).jump_index = 13;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;

	i = i + 1;
	p -> builtin_name.description (i).name = "acos";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = acos_fun;
	p -> builtin_name.description (i).reserve_list_number = 85;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "add";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = add;
	p -> builtin_name.description (i).jump_index = 14;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number2 = 4;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;
	p -> builtin_name.description (i).descriptor (4).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "addr";
	p -> builtin_name.description (i).opcode = addr_fun;
	p -> builtin_name.description (i).jump_index = 33;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 9;

	i = i + 1;
	p -> builtin_name.description (i).name = "addrel";/* multics function */
	p -> builtin_name.description (i).opcode = addrel_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 41;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = pointer_type;
	p -> builtin_name.description (i).descriptor (2).check_code = 8;
	i = i + 1;
	p -> builtin_name.description (i).name = "addwordno";/* multics function */
	p -> builtin_name.description (i).opcode = addrel_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 41;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = pointer_type;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "allocation";
	p -> builtin_name.description (i).opcode = allocation_fun;
	p -> builtin_name.description (i).jump_index = 36;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "allocn";
	p -> builtin_name.description (i).opcode = allocation_fun;
	p -> builtin_name.description (i).jump_index = 36;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "after";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = index_after_fun;
	p -> builtin_name.description (i).jump_index = 55;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "asin";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = asin_fun;
	p -> builtin_name.description (i).reserve_list_number = 77;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "atan";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = atan_fun;
	p -> builtin_name.description (i).reserve_list_number = 93;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;
	p -> builtin_name.description (i).descriptor (2).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "atand";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = atand_fun;
	p -> builtin_name.description (i).reserve_list_number = 97;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;
	p -> builtin_name.description (i).descriptor (2).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "atanh";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 45;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "baseno";/* multics function */
	p -> builtin_name.description (i).opcode = baseno_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 39;
	p -> builtin_name.description (i).check_indicator = 1;
						/* Exact # of args */
	p -> builtin_name.description (i).number1 = 1;	/* One argument */
	p -> builtin_name.description (i).number_of_descriptions = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "segno"; /* multics function */
	p -> builtin_name.description (i).opcode = segno_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 70;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "baseptr";
						/* multics function */
	p -> builtin_name.description (i).opcode = baseptr_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 41;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 8;

	i = i + 1;
	p -> builtin_name.description (i).name = "before";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = index_before_fun;
	p -> builtin_name.description (i).jump_index = 56;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "bin";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 15;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = binary_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "binary";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 15;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = binary_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "bit";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 18;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = bit_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "bool";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = bool_fun;
	p -> builtin_name.description (i).jump_index = 23;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = bit_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = bit_mask;
	p -> builtin_name.description (i).descriptor (3).check_code = 2;
	p -> builtin_name.description (i).descriptor (3).type = bit_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "byte";	/* multics function */
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = byte_fun;
	p -> builtin_name.description (i).jump_index = 68;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = fixed_binary_real_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "ceil";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = ceil_fun;
	p -> builtin_name.description (i).jump_index = 16;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;

	i = i + 1;
	p -> builtin_name.description (i).name = "char";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 18;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "character";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 18;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "clock"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = clock_fun;
	p -> builtin_name.description (i).jump_index = 62;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "codeptr";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = codeptr_fun;
	p -> builtin_name.description (i).jump_index = 63;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 12;

	i = i + 1;
	p -> builtin_name.description (i).name = "collate";
	p -> builtin_name.description (i).jump_index = 1;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "collate9";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 59;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "complex";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = complex_fun;
	p -> builtin_name.description (i).jump_index = 17;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "conjg";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = conjg_fun;
	p -> builtin_name.description (i).jump_index = 50;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = complex_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "convert";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 46;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "copy";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = repeat_fun;
	p -> builtin_name.description (i).jump_index = 9;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 7;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "cos";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = cos_fun;
	p -> builtin_name.description (i).reserve_list_number = 61;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "cosd";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = cosd_fun;
	p -> builtin_name.description (i).reserve_list_number = 65;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "cosh";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 113;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "cplx";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = complex_fun;
	p -> builtin_name.description (i).jump_index = 17;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "currentsize";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 64;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "date";
	p -> builtin_name.description (i).reserve_list_number = 186;
	p -> builtin_name.description (i).jump_index = 31;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "dec";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 15;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = decimal_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "decat";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 190;
	p -> builtin_name.description (i).jump_index = 24;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "decimal";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 15;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (1).type = decimal_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "dim";
	p -> builtin_name.description (i).opcode = sub;
	p -> builtin_name.description (i).reserve_list_number = 3;
						/* third argument in call to bounds_ */
	p -> builtin_name.description (i).jump_index = 26;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "dimension";
	p -> builtin_name.description (i).opcode = sub;
	p -> builtin_name.description (i).reserve_list_number = 3;
						/* third argument in call to bounds_ */
	p -> builtin_name.description (i).jump_index = 26;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "divide";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = div;
	p -> builtin_name.description (i).jump_index = 14;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number2 = 4;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;
	p -> builtin_name.description (i).descriptor (4).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "dot";
	p -> builtin_name.description (i).opcode = add;
	p -> builtin_name.description (i).jump_index = 45;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number2 = 4;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;
	p -> builtin_name.description (i).descriptor (4).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "empty";
	p -> builtin_name.description (i).jump_index = 28;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "environmentptr";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = environmentptr_fun;
	p -> builtin_name.description (i).jump_index = 63;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 12;

	i = i + 1;
	p -> builtin_name.description (i).name = "erf";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 129;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "erfc";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 133;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "exp";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = exp_fun;
	p -> builtin_name.description (i).reserve_list_number = 29;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "fixed";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 3;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "float";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 2;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "floor";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = floor_fun;
	p -> builtin_name.description (i).jump_index = 16;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;

	i = i + 1;
	p -> builtin_name.description (i).name = "hbound";
	p -> builtin_name.description (i).reserve_list_number = 2;
						/* third argument in call to bounds_ */
	p -> builtin_name.description (i).jump_index = 26;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "high";
	p -> builtin_name.description (i).opcode = repeat_fun;
	p -> builtin_name.description (i).jump_index = 5;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "high9"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = repeat_fun;
	p -> builtin_name.description (i).jump_index = 60;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "imag";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = imag_fun;
	p -> builtin_name.description (i).jump_index = 19;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = complex_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "index";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = index_fun;
	p -> builtin_name.description (i).jump_index = 6;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "lbound";
	p -> builtin_name.description (i).reserve_list_number = 1;
						/* third argument in call to bounds_ */
	p -> builtin_name.description (i).jump_index = 26;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "length";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = length_fun;
	p -> builtin_name.description (i).jump_index = 7;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 7;

	i = i + 1;
	p -> builtin_name.description (i).name = "lineno";
	p -> builtin_name.description (i).reserve_list_number = 183;
	p -> builtin_name.description (i).jump_index = 30;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = file_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "log";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = log_fun;
	p -> builtin_name.description (i).reserve_list_number = 33;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "log10";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = log10_fun;
	p -> builtin_name.description (i).reserve_list_number = 41;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "log2";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = log2_fun;
	p -> builtin_name.description (i).reserve_list_number = 37;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "low";
	p -> builtin_name.description (i).opcode = repeat_fun;
	p -> builtin_name.description (i).jump_index = 8;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "ltrim"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = verify_ltrim_fun;
	p -> builtin_name.description (i).jump_index = 57;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = char_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "max";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = max_fun;
	p -> builtin_name.description (i).jump_index = 20;
	p -> builtin_name.description (i).check_indicator = 2;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "maxlength";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 65;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 7;

	i = i + 1;
	p -> builtin_name.description (i).name = "min";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = min_fun;
	p -> builtin_name.description (i).jump_index = 20;
	p -> builtin_name.description (i).check_indicator = 2;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "mod";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = pl1_mod_fun;
	p -> builtin_name.description (i).jump_index = 21;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "multiply";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = mult;
	p -> builtin_name.description (i).jump_index = 14;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number2 = 4;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;
	p -> builtin_name.description (i).descriptor (4).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "null";
	p -> builtin_name.description (i).jump_index = 29;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "nullo"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 44;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "offset";
	p -> builtin_name.description (i).opcode = off_fun;
	p -> builtin_name.description (i).jump_index = 35;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = pointer_type;
	p -> builtin_name.description (i).descriptor (2).check_code = 1;
	p -> builtin_name.description (i).descriptor (2).type = area_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "onchar";
	p -> builtin_name.description (i).reserve_list_number = 9;
	p -> builtin_name.description (i).jump_index = 51;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "oncode";
	p -> builtin_name.description (i).reserve_list_number = 10;
	p -> builtin_name.description (i).jump_index = 53;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "onfield";
	p -> builtin_name.description (i).reserve_list_number = 8;
	p -> builtin_name.description (i).jump_index = 42;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "onfile";
	p -> builtin_name.description (i).reserve_list_number = 12;
	p -> builtin_name.description (i).jump_index = 42;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "onkey";
	p -> builtin_name.description (i).reserve_list_number = 13;
	p -> builtin_name.description (i).jump_index = 42;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "onloc";
	p -> builtin_name.description (i).reserve_list_number = 7;
	p -> builtin_name.description (i).jump_index = 42;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "onsource";
	p -> builtin_name.description (i).reserve_list_number = 14;
	p -> builtin_name.description (i).jump_index = 52;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "pageno";
	p -> builtin_name.description (i).reserve_list_number = 184;
	p -> builtin_name.description (i).jump_index = 30;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = file_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "pointer";
	p -> builtin_name.description (i).opcode = ptr_fun;
	p -> builtin_name.description (i).jump_index = 34;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "setwordno"; /* multics function */
	p -> builtin_name.description (i).opcode = ptr_fun;
	p -> builtin_name.description (i).jump_index = 34;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = pointer_type;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "prec";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 4;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "precision";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 4;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "prod";
	p -> builtin_name.description (i).opcode = mult;
	p -> builtin_name.description (i).jump_index = 43;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;

	i = i + 1;
	p -> builtin_name.description (i).name = "ptr";
	p -> builtin_name.description (i).opcode = ptr_fun;
	p -> builtin_name.description (i).jump_index = 34;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;

	i = i + 1;
	p -> builtin_name.description (i).name = "rank";	/* multics function */
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = rank_fun;
	p -> builtin_name.description (i).jump_index = 69;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "real";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = real_fun;
	p -> builtin_name.description (i).jump_index = 19;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = complex_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "rel";	/* multics function */
	p -> builtin_name.description (i).opcode = rel_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 39;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "wordno";/* multics function */
	p -> builtin_name.description (i).opcode = wordno_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 71;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "charno";
	p -> builtin_name.description (i).opcode = charno_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 71;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "bitno";
	p -> builtin_name.description (i).opcode = bitno_fun;
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 71;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;

	begin;
	     declare NAMES		      (4) char (12) init ("setcharno", "addcharno", "setbitno", "addbitno")
				      int static options (constant);
	     declare OP		      (4) bit (9)
				      init (setcharno_fun, addcharno_fun, setbitno_fun, addbitno_fun);

	     declare nx		      fixed bin;

	     do nx = 1 to 4;
		i = i + 1;
		p -> builtin_name.description (i).name = NAMES (nx);
		p -> builtin_name.description (i).opcode = OP (nx);
		p -> builtin_name.description (i).jump_index = 74;
		p -> builtin_name.description (i).check_indicator = 1;
						/* fixed argument count */
		p -> builtin_name.description (i).number1 = 2;
		p -> builtin_name.description (i).number_of_descriptions = 2;
		p -> builtin_name.description (i).descriptor (1).check_code = 1;
		p -> builtin_name.description (i).descriptor (1).type = pointer_type;
		p -> builtin_name.description (i).descriptor (2).check_code = 5;
	     end;
	end;
	i = i + 1;
	p -> builtin_name.description (i).name = "reverse";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = reverse_fun;
	p -> builtin_name.description (i).jump_index = 27;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 7;

	i = i + 1;
	p -> builtin_name.description (i).name = "round";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = round_fun;
	p -> builtin_name.description (i).jump_index = 22;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;
	p -> builtin_name.description (i).descriptor (2).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "rtrim"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = verify_rtrim_fun;
	p -> builtin_name.description (i).jump_index = 58;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number2 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = char_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "search";/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = search_fun;
	p -> builtin_name.description (i).jump_index = 37;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = char_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "sign";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = sign_fun;
	p -> builtin_name.description (i).jump_index = 38;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;

	i = i + 1;
	p -> builtin_name.description (i).name = "sin";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = sin_fun;
	p -> builtin_name.description (i).reserve_list_number = 53;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "sind";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = sind_fun;
	p -> builtin_name.description (i).reserve_list_number = 57;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "sinh";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 109;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "size";	/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).jump_index = 47;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "sqrt";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = sqrt_fun;
	p -> builtin_name.description (i).reserve_list_number = 25;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "stac";	/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = lock_fun;
	p -> builtin_name.description (i).jump_index = 40;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = pointer_type;
	p -> builtin_name.description (i).descriptor (2).check_code = 1;
	p -> builtin_name.description (i).descriptor (2).type = bit_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "stackbaseptr";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = stackbaseptr_fun;
	p -> builtin_name.description (i).jump_index = 61;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "stackframeptr";
						/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = stackframeptr_fun;
	p -> builtin_name.description (i).jump_index = 61;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "stacq"; /* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = stacq_fun;
	p -> builtin_name.description (i).jump_index = 66;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 1;
	p -> builtin_name.description (i).descriptor (1).type = bit_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 1;
	p -> builtin_name.description (i).descriptor (2).type = bit_mask;
	p -> builtin_name.description (i).descriptor (3).check_code = 1;
	p -> builtin_name.description (i).descriptor (3).type = bit_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "string";
	p -> builtin_name.description (i).jump_index = 10;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "substr";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).jump_index = 11;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 7;
	p -> builtin_name.description (i).descriptor (2).check_code = 5;
	p -> builtin_name.description (i).descriptor (3).check_code = 5;

	i = i + 1;
	p -> builtin_name.description (i).name = "subtract";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = sub;
	p -> builtin_name.description (i).jump_index = 14;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 3;
	p -> builtin_name.description (i).number2 = 4;
	p -> builtin_name.description (i).number_of_descriptions = 4;
	p -> builtin_name.description (i).descriptor (3).check_code = 6;
	p -> builtin_name.description (i).descriptor (4).check_code = 6;

	i = i + 1;
	p -> builtin_name.description (i).name = "sum";
	p -> builtin_name.description (i).opcode = add;
	p -> builtin_name.description (i).jump_index = 43;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 10;

	i = i + 1;
	p -> builtin_name.description (i).name = "tan";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = tan_fun;
	p -> builtin_name.description (i).reserve_list_number = 69;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "tand";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = tand_fun;
	p -> builtin_name.description (i).reserve_list_number = 73;
	p -> builtin_name.description (i).jump_index = 54;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 11;

	i = i + 1;
	p -> builtin_name.description (i).name = "tanh";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).reserve_list_number = 117;
	p -> builtin_name.description (i).jump_index = 25;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 3;

	i = i + 1;
	p -> builtin_name.description (i).name = "time";
	p -> builtin_name.description (i).reserve_list_number = 187;
	p -> builtin_name.description (i).jump_index = 32;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "translate";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = translate_fun;
	p -> builtin_name.description (i).jump_index = 49;
	p -> builtin_name.description (i).check_indicator = 3;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number2 = 3;
	p -> builtin_name.description (i).number_of_descriptions = 3;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = char_mask;
	p -> builtin_name.description (i).descriptor (3).check_code = 2;
	p -> builtin_name.description (i).descriptor (3).type = char_mask;

	i = i + 1;
	p -> builtin_name.description (i).name = "trunc";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = trunc_fun;
	p -> builtin_name.description (i).jump_index = 16;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;
	p -> builtin_name.description (i).number_of_descriptions = 1;
	p -> builtin_name.description (i).descriptor (1).check_code = 4;

	i = i + 1;
	p -> builtin_name.description (i).name = "unspec";
	p -> builtin_name.description (i).jump_index = 12;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "valid";
	p -> builtin_name.description (i).reserve_list_number = 185;
	p -> builtin_name.description (i).jump_index = 48;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 1;

	i = i + 1;
	p -> builtin_name.description (i).name = "vclock";/* multics function */
	p -> builtin_name.description (i).nonstandard = "1"b;
	p -> builtin_name.description (i).opcode = vclock_fun;
	p -> builtin_name.description (i).jump_index = 62;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 0;

	i = i + 1;
	p -> builtin_name.description (i).name = "verify";
	p -> builtin_name.description (i).aggregate_result = "1"b;
	p -> builtin_name.description (i).opcode = verify_fun;
	p -> builtin_name.description (i).jump_index = 37;
	p -> builtin_name.description (i).check_indicator = 1;
	p -> builtin_name.description (i).number1 = 2;
	p -> builtin_name.description (i).number_of_descriptions = 2;
	p -> builtin_name.description (i).descriptor (1).check_code = 2;
	p -> builtin_name.description (i).descriptor (1).type = char_mask;
	p -> builtin_name.description (i).descriptor (2).check_code = 2;
	p -> builtin_name.description (i).descriptor (2).type = char_mask;

	p -> builtin_name.number_of_names = i;

	call ioa_ ("^a: ^d names processed.", myname, i);

/* prepare long_collating_sequence */

	substr (p -> long_collating_sequence, 1, 128) = collate ();
	do j = 128 to 511;
	     collating_overlay (j) = bit (fixed (j, 9), 9);
	end;

/* now call create_data_segment_ */

	unspec (cdsa) = "0"b;
	cdsa.have_text = "1"b;
	cdsa.sections (1).p = p;
	cdsa.sections (1).len = divide (length (unspec (pl1_data)), 36, 17, 0);
	cdsa.sections (1).struct_name = "pl1_data";
	cdsa.seg_name = myname;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0
	then call com_err_ (code, myname, "Creating ^a data segment", myname);

	call release_temp_segments_ (myname, segptrs, (0));
     end pl1_data;




		    prepare_symbol_table.pl1        07/31/89  1431.7r w 07/31/89  1338.9       97272



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


/* Program to prepare symbol table by semantically translating any expressions
   associated with a symbol node.

   Initial Version:  1 July 1972 by BLW
	Modified:	5 April 1978 by RAB to fix 1720
	Modified: 23 January by DS to fix bug 1817
	Modified: 7 October 1980 by M. N. Davidoff to fix bug 1971.
*/
/* format: style3 */
prepare_symbol_table:
     procedure (root);

dcl	root		ptr;

/* automatic */

dcl	ev_based_var	ptr;
dcl	ev_qual		ptr;
dcl	ev_ref		ptr;
dcl	ev_temp		ptr;
dcl	s1		ptr;
dcl	s2		ptr;
dcl	scan_again	bit (1) aligned;

/* builtin */

dcl	(null, string)	builtin;

/* external static */

dcl	pl1_stat_$cur_statement
			ptr external static;
dcl	pl1_stat_$dummy_block
			ptr external static;
dcl	pl1_stat_$index	fixed bin external static;
dcl	pl1_stat_$locator	(128) ptr 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);
dcl	pl1_stat_$table	bit (1) aligned external static;

%include block;
%include symbol;
%include array;
%include reference;
%include operator;
%include statement;
%include nodes;
%include block_types;
%include declare_type;
%include statement_types;
%include op_codes;
%include system;
%include semant;

/* program */

	ev_qual = create_operator (param_ptr, 3);
	ev_temp, ev_qual -> operator.operand (1) = declare_temporary (pointer_type, 0, 0, null);
	ev_qual -> operator.operand (2) = declare_constant$integer (1);
	ev_qual -> operator.operand (3), pl1_stat_$dummy_block = create_block (internal_procedure, null);

	ev_ref = declare_pointer (pl1_stat_$dummy_block);
	ev_ref -> reference.qualifier, pl1_stat_$dummy_block -> block.context = ev_qual;

	ev_ref -> reference.symbol -> symbol.auto = "0"b;
	ev_ref -> reference.symbol -> symbol.parameter = "1"b;
	ev_ref -> reference.symbol -> symbol.location = 1;

	ev_based_var = declare_integer (pl1_stat_$dummy_block);
	ev_based_var -> reference.qualifier = ev_ref;

	ev_based_var -> reference.symbol -> symbol.auto = "0"b;
	ev_based_var -> reference.symbol -> symbol.based = "1"b;

	s1 = create_statement (unknown_statement, pl1_stat_$dummy_block, null, ""b);
	s2 = null;

/* Sometimes the entire symbol table must be scanned more than once.
   Processing a symbol node may cause another symbol node's
   symbol.cross_references pointer to be set, symbol.allocate bit to be turned
   on, or symbol.put_in_symtab bit to be turned on.  If that symbol node has
   already been passed in the symbol chain, we have to pass over the symbol
   table again to ensure that the symbol node is processed.  If we didn't, the
   code generator will fault when generating a thunk for the symbol node.
   Another pass is made over the symbol table if any of these fields could
   have been set for the first time.  This fixes 1971. */

	scan_again = "1"b;
	do while (scan_again);
	     scan_again = "0"b;
	     call scan_symbol_table;
	end;

	return;

/* This procedure makes a prefix walk of the block node tree.  For each block
   node, all the declarations local to that block are examined for entry into
   the runtime symbol table.  If the declaration is eligible, process is
   called to prepare the symbol node for the runtime symbol table. */

scan_symbol_table:
     procedure;

dcl	cb		ptr;
dcl	found_brother	bit (1) aligned;
dcl	get_data		bit (1) aligned;
dcl	p		ptr;
dcl	q		ptr;

	cb = root;
	do while (cb ^= null);
	     get_data = cb -> block.get_data;
	     do p = cb -> block.declaration repeat p -> symbol.next while (p ^= null);
		if p -> node.type = symbol_node
		then if p -> symbol.dcl_type ^= by_compiler & ^p -> symbol.builtin & ^p -> symbol.condition
			& ^p -> symbol.constant & ^p -> symbol.symtab_processed
			& (p -> symbol.cross_references ^= null | p -> symbol.allocate | get_data)
		     then do;
			     do q = p repeat q -> symbol.father while (q -> symbol.father ^= null);
			     end;

			     if q -> symbol.put_in_symtab | get_data | pl1_stat_$table
			     then call process (q);
			end;
	     end;

	     if cb -> block.son ^= null
	     then cb = cb -> block.son;
	     else do;
		     found_brother = "0"b;
		     do while (cb ^= null & ^found_brother);
			if cb -> block.brother = null
			then cb = cb -> block.father;
			else do;
				cb = cb -> block.brother;
				found_brother = "1"b;
			     end;
		     end;
		end;
	end;

	return;

/* This procedure prepares a symbol node for entry into the runtime symbol
   table.  If the symbol node is a structure declaration, this procedure makes
   a prefix walk of the member symbol nodes to prepare them also.  Any
   expression or variable used as a size or bound on symbols are encoded.
   This procedure ensures that all variables referenced in size or bound
   expressions are marked for inclusion into the runtime symbol table. */

process:
     procedure (pt);

dcl	pt		ptr;

dcl	ap		ptr;
dcl	array_ref		bit (1) aligned;
dcl	bp		ptr;
dcl	qp		ptr;
dcl	rp		ptr;
dcl	sp		ptr;

	sp = pt;
	do while (sp ^= null);
	     pl1_stat_$cur_statement = sp;
	     string (pl1_stat_$statement_id) = string (sp -> symbol.source_id);

	     if sp -> symbol.picture
	     then do;
		     scan_again = scan_again | ^sp -> symbol.general -> reference.symbol -> symbol.allocate;
		     sp -> symbol.general -> reference.symbol -> symbol.allocate = "1"b;
		end;

	     if sp -> symbol.offset
	     then if sp -> symbol.general ^= null
		then do;
			sp -> symbol.general = encode_qual (sp -> symbol.general);

			if sp -> symbol.general ^= null
			then if sp -> symbol.general -> node.type = reference_node
			     then do;
				     scan_again =
					scan_again
					| ^sp -> symbol.general -> reference.symbol -> symbol.put_in_symtab;
				     sp -> symbol.general -> reference.symbol -> symbol.put_in_symtab = "1"b;
				end;
		     end;

	     if ^sp -> symbol.entry
	     then sp -> symbol.symtab_size = encode (sp -> symbol.dcl_size);

	     rp = sp -> symbol.reference;
	     rp -> reference.offset = encode (rp -> reference.offset);

	     if sp -> symbol.defined
	     then if sp -> symbol.structure
		then do;

/* try to locate base reference so we can determine addressing information
   for the defined element */

			if sp -> symbol.reference -> reference.qualifier = null
			then if lookup ((sp -> symbol.block_node), null, copy_expression (sp -> symbol.equivalence), bp,
				"0"b)
			     then sp -> symbol.reference -> reference.qualifier = bp -> symbol.reference;
		     end;

		else do;

/* expression_semantics won't call defined_reference for an array */

			array_ref = sp -> symbol.reference -> reference.array_ref;
			sp -> symbol.reference -> reference.array_ref = "0"b;

			qp = encode_qual (sp -> symbol.reference);
			if qp ^= null
			then if qp -> node.type = reference_node
			     then do;
				     qp -> reference.ref_count = 0;
				     qp -> reference.shared = "1"b;
						/* symbol.reference must be shared */
				     qp -> reference.processed = "0"b;
						/* prevent expr_semantics anomalies */
				     sp -> symbol.reference = qp;
				end;

			sp -> symbol.reference -> reference.array_ref = array_ref;
		     end;

	     if sp -> symbol.based
	     then if rp -> reference.qualifier ^= null
		then do;
			rp -> reference.qualifier = encode_qual (rp -> reference.qualifier);

			if rp -> reference.qualifier ^= null
			then if rp -> reference.qualifier -> node.type = reference_node
			     then do;
				     scan_again =
					scan_again
					| ^rp -> reference.qualifier -> reference.symbol -> symbol.put_in_symtab;
				     rp -> reference.qualifier -> reference.symbol -> symbol.put_in_symtab = "1"b;
				end;
		     end;

	     ap = sp -> symbol.array;
	     if ap ^= null
	     then do;
		     ap -> array.symtab_virtual_origin = encode (ap -> array.virtual_origin);

		     do bp = ap -> array.bounds repeat bp -> bound.next while (bp ^= null);
			bp -> bound.symtab_lower = encode (bp -> bound.lower);
			bp -> bound.symtab_upper = encode (bp -> bound.upper);

			if bp -> bound.c_multiplier = 0
			then bp -> bound.symtab_multiplier = encode (bp -> bound.multiplier);
		     end;
		end;

	     sp -> symbol.symtab_processed = "1"b;

	     if sp -> symbol.son ^= null
	     then sp = sp -> symbol.son;
	     else do;
		     found_brother = "0"b;
		     do while (sp ^= null & ^found_brother);
			if sp -> symbol.brother = null
			then sp = sp -> symbol.father;
			else do;
				sp = sp -> symbol.brother;
				found_brother = "1"b;
			     end;
		     end;
		end;
	end;

	return;

/* This procedure encodes for the runtime symbol table one expression used as
   a size or bound on a symbol node.  It runs the semantic translator over the
   expression in case it has not been previously referenced in the program.
*/
encode:
     procedure (t) returns (ptr);

dcl	t		ptr unaligned;

dcl	convert_to_integer	bit (1) aligned;
dcl	tp		ptr;

	convert_to_integer = "1"b;
	goto common;

encode_qual:
     entry (t) returns (ptr);

	convert_to_integer = "0"b;

common:
	if t = null
	then return (t);

	if s2 = null
	then s2 = create_statement (unknown_statement, s1, null, ""b);
	else do;
		s2 -> statement.root = null;
		string (s2 -> statement.source_id) = string (pl1_stat_$statement_id);
	     end;

	s2 -> statement.put_in_profile = "0"b;

	tp = copy_expression (t);

	if sp -> symbol.refer_extents
	then tp = fill_refer (tp, ev_ref, "0"b);

	pl1_stat_$locator (1) = ev_based_var;
	pl1_stat_$index = 1;

	tp = semantic_translator$call_es (cb, s2, tp, fail, convert_to_integer);
	scan_again = "1"b;

	if tp ^= null
	then if tp -> node.type = operator_node
	     then if tp -> operator.op_code = loop | tp -> operator.op_code = join
		then do;
			call error (73, null, sp);

fail:
			call error (318, null, sp);
			return (null);
		     end;

	if ev_qual -> operator.operand (1) ^= ev_temp
	then do;
		call free_node ((ev_qual -> operator.operand (1)));
		ev_qual -> operator.operand (1) = ev_temp;
	     end;

	if ev_ref -> reference.qualifier ^= ev_qual
	then do;
		call free_node ((ev_ref -> reference.qualifier));
		ev_ref -> reference.qualifier = ev_qual;
	     end;

	if s1 -> statement.next ^= s2
	then do;
		s2 -> statement.root = tp;
		s2 = null;
		return (s1 -> statement.next);
	     end;

	return (tp);
     end encode;

     end process;

     end scan_symbol_table;

     end prepare_symbol_table;




		    propagate_bit.pl1               10/03/83  1727.1rew 10/03/83  1006.9       16659



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


propagate_bit:	proc(sym,number);

/* Modified 780616 by PG for unsigned */
/* Modified Dec 1978 by DS for new cross-ref 'set' format */

/* parameters */

dcl (	sym ptr,
	number fixed bin (15)) parameter;

/* automatic */

dcl	(p, r) ptr;

/* builtins */

dcl	(null, string, substr) builtin;

/* include files */

%include symbol;
%include symbol_bits;
%include cross_reference;

/* program */

	if sym->symbol.temporary then return;

	p = sym;

	if number = set_bit				/* Set gets propagated to ancestors as well */
	then do;
		r = p -> symbol.cross_references;
		if r ^= null then r -> cross_reference.set_reference = "1"b;
						/* r = null means symbol is compiler-developed */
						/* Support new 'set' format in listing */
		r = p;
		do while(r->symbol.father^=null);
			r=r->symbol.father;
			substr(string(r->symbol.attributes),number,1) = "1"b;
		end;
	end;
	else if substr (string (p->symbol.attributes), number, 1)
	     then return;

	substr(string(p->symbol.attributes),number,1) = "1"b;
	if p->symbol.son^=null
	then call propagate((p->symbol.son));

propagate:	proc(p);

dcl	p ptr unal,
	q ptr;

	q = p;

	do while(q^=null);
		substr(string(q->symbol.attributes),number,1) = "1"b;

		if q->symbol.son^=null
		then call propagate(q->symbol.son);

		q = q->symbol.brother;
	end;

	end propagate;

     end /* propagate_bit */;




		    semantic_translator.pl1         07/31/89  1431.7rew 07/31/89  1329.5      122031



/****^  ***********************************************************
        *                                                         *
        * 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 */
semantic_translator:
     proc;

/* 	Modified: 770630 by PG to fix 1609 (incorrect use of auto & defined in prologue) 
	Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement
	Modified:	20 Mar 1978 by RAB to fix bug in setting goto_bit introduced in 78.02.15 change
	Modified: 30 Nov 1978 by DS to suppress redundant label and entry cross-references
	Modified: 30 Aug 1979 by PCK to fix 1804 and 1823
          Modified: 10 Jul 1989 by RW removed obsolete parameter in the call to error_()
*/

dcl      (b, d, sym, t, tk) ptr;

dcl      pl1_stat_$debug_semant bit (1) aligned ext static,
         pl1_stat_$stmnt_unreachable bit (1) aligned ext static,
         pl1_stat_$index fixed bin (15) ext static,
         pl1_stat_$last_severity fixed bin (15) ext static,
         pl1_stat_$error_flag bit (1) aligned ext static,
         pl1_stat_$multi_type bit (1) aligned ext static;

dcl      pl1_stat_$LHS ptr ext static;
dcl      pl1_stat_$cur_block ptr ext static;
dcl      pl1_stat_$cur_statement ptr ext static;
dcl      pl1_stat_$root ptr ext static;
dcl      pl1_stat_$abort_label label ext static;

dcl      (
         pl1_stat_$util_abort,
         pl1_stat_$util_error
         ) variable static ext entry;

dcl      1 pl1_stat_$statement_id ext static,
	 2 file_number bit (8),
	 2 line_number bit (14),
	 2 statement_number bit (5);

dcl      pl1_stat_$stop_id bit (27) ext static;

dcl      pl1_stat_$st_start fixed bin (23) ext static,
         pl1_stat_$st_length fixed bin (11) ext static,
         pl1_stat_$profile_length fixed bin (31) ext static;

dcl      (i, j, k, m, n) fixed bin (15);
dcl      changed bit (1);
dcl      goto_bit bit (1) aligned;
dcl      abort label int static;
dcl      had_error bit (1) int static;

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

dcl      real_quick_info (pl1_stat_$node_uses (1)) bit (pl1_stat_$node_uses (1)) aligned,
         block_array (pl1_stat_$node_uses (1)) ptr;

dcl      ioa_ entry options (variable);
dcl      debug entry ();

/* set up abort and error entries for utility section */

	pl1_stat_$util_abort = semantic_translator$abort;
	pl1_stat_$util_error = semantic_translator$error;

	pl1_stat_$quick_pt = addr (real_quick_info);

	do i = 1 to pl1_stat_$node_uses (1);
	     quick_info (i) = "0"b;
	end;

	context = "0"b;
	b = pl1_stat_$root;
	pl1_stat_$st_start, pl1_stat_$st_length = 0;
	string (pl1_stat_$statement_id) = "0"b;

	call context_processor (pl1_stat_$root, abort);

scan:
	pl1_stat_$cur_block = b;
	block_array (b -> block.number) = b;

/* if this is a begin block, we have to create a "call" of the begin block
	   from the parent block so our quick procedure algorithm will work */

	if b -> block_type = begin_block then
	     substr (quick_info (b -> block.number), b -> block.father -> block.number, 1) = "1"b;

	d = b -> block.declaration;
	abort = next_dcl;

	do while (d ^= null);
	     pl1_stat_$cur_statement = d;
	     string (pl1_stat_$statement_id) = string (d -> symbol.source_id);

	     call declare (d);
next_dcl:
	     d = pl1_stat_$cur_statement -> symbol.next;
	end;

/* process the prologue and main statement lists.  */

	goto_bit = "0"b;
	abort = next_stmnt;

	do d = b -> block.main, b -> block.prologue;
	     do while (d ^= null);
		pl1_stat_$cur_statement = d;

		d -> statement.free_temps =
		     string (pl1_stat_$statement_id) ^= string (d -> statement.source_id)
		     & string (d -> statement.source_id) ^= "0"b;

		if d -> statement.free_temps then do;
		     d -> statement.put_in_profile = "1"b;
		     pl1_stat_$profile_length = pl1_stat_$profile_length + 1;
		end;

		if d -> statement.processed then
		     goto next_stmnt;

		pl1_stat_$LHS = null;
		string (pl1_stat_$statement_id) = string (d -> statement.source_id);

		call process_label (d);

		if pl1_stat_$debug_semant then
		     if string (pl1_stat_$statement_id) = pl1_stat_$stop_id then do;
			call ioa_ ("DB for stop-at:");
			call debug;
		     end;

		def_context.top = "1"b;

/* We do not want to update the statement passed as the argument */
		d -> statement.root = expression_semantics (b, (d), (d -> statement.root), context);
next_stmnt:
		d = pl1_stat_$cur_statement -> statement.next;
	     end;

	     b -> block.prologue_flag = "1"b;		/* let world know we are semant'ing prologue */
	end;

	b -> block.prologue_flag = "0"b;		/* now we are done */
	context = "0"b;

next_block:
	if b -> block.son ^= null then do;
	     b = b -> block.son;
	     goto scan;
	end;

ck_brother:
	if b -> block.brother ^= null then do;
	     b = b -> block.brother;
	     goto scan;
	end;

	if b -> block.father ^= null then do;
	     b = b -> block.father;
	     goto ck_brother;
	end;

/* at this point we have processed all blocks in the program, now
	   determine which blocks can be quick.  substr(quick_info(i),j,1)
	    will be "1"b if block "i" is called from block "j"	*/

loop:
	changed = "0"b;

	do i = 1 to pl1_stat_$node_uses (1);
	     b = block_array (i);
	     if ^b -> block.no_stack then
		goto next;
	     if b -> block.owner ^= null then
		goto next;

/* determine if block is called */

	     j = index (quick_info (i), "1"b);
	     if j = 0 then
		goto next;

/* If block "i" calls itself recursively, it can never be quick. */

	     if substr (quick_info (i), i, 1) = "1"b then do;
		b -> block.why_nonquick.recursive_call = "1"b;
		b -> block.no_stack = "0"b;
		go to next;
	     end;

/* See if it is called from any other blocks;
	        a block can be quick if only called from one block */

	     if substr (quick_info (i), j + 1) then
		goto next;

/* block "i" will allocate its storage in block "j" */

	     b -> block.owner = block_array (j);

	     do k = 1 to pl1_stat_$node_uses (1);

/* if some other block is allocating its storage in block "i",
		   that block has to now take it from block "j" */

		if block_array (k) -> block.owner = b then
		     block_array (k) -> block.owner = block_array (j);

/* copy all transitions out of block "i" into block "j" and
		   then erase all transitions out of block "i" */

		substr (quick_info (k), j, 1) = substr (quick_info (k), j, 1) | substr (quick_info (k), i, 1);
		substr (quick_info (k), i, 1) = "0"b;
	     end;

/* remember that we changed the array */

	     changed = "1"b;

next:
	end;

/* we repeat the above algorithm until we make a pass thru the
	   array with no change */

	if changed then
	     goto loop;

/* if the owner field of a block is now null, the block can't be quick */

	do i = 1 to pl1_stat_$node_uses (1);
	     b = block_array (i);

/* issue warning if internal procedure was never called */

	     if b -> block_type = internal_procedure then
		if quick_info (i) = "0"b & ^b -> block.why_nonquick.assigned_to_entry_var then do;
		     call error (267, null, (b -> block.main -> statement.labels -> element (2)));
		     if b -> block.no_stack & b -> block.owner = null then do;
			b -> block.why_nonquick.never_referenced = "1"b;
			b -> block.no_stack = "0"b;
		     end;
		end;

/* If block has no owner at this point, and is still quick, make it nonquick, */
/* because we have been unable to find it a unique owner for its stack frame. */

	     if b -> block.owner = null & b -> block.no_stack then do;
		b -> block.why_nonquick.no_owner = "1"b;
		b -> block.no_stack = "0"b;
	     end;
	     else if b = b -> block.owner then do;
		b -> block.why_nonquick.recursive_call = "1"b;
		b -> block.no_stack = "0"b;
	     end;
	end;

	return;

process_label:
     proc (s);

/* The reason for the need for two "goto" bits is that goto_bit
   reflects the last stmnt thru the 1st half of the next invocation
   of process_label, which used to be the only person who used it, but by
   the time expression_semantics is called to process the statement, that bit
   has been updated to reflect the CURRENT statement, which is no longer interesting.
   Therefore pl1_stat_$stmnt_unreachable is used by everyone who is interested
   who is called as a result of the call to expression_semantics, to tell if
   at that point the PREVIOUS statement was a return or a goto.	*/

dcl      (lookup_block, lptr, s) ptr,
         st_type bit (9) aligned;

	st_type = s -> statement.statement_type;
	lptr = s -> statement.labels;

	if lptr = null then
	     if goto_bit
		& (st_type ^= end_statement & st_type ^= null_statement & st_type ^= entry_statement
		& st_type ^= format_statement) then
		if st_type = do_statement then
		     if s -> statement.root -> operand (3) = null then
			call semantic_translator$error (56, null);
		     else
			call semantic_translator$error (476, null);
		else
		     call semantic_translator$error (56, null);
	     else
		;
	else
	     do while (lptr ^= null);
		if st_type = procedure_statement | st_type = entry_statement then
		     lookup_block = b -> block.father;
		else
		     lookup_block = b;

		def_context.suppress_cross_ref = "1"b;	/* No redundant cross-ref for labels */

		lptr -> list.element (2) =
		     expression_semantics (lookup_block, d, (lptr -> list.element (2)), context);

		def_context.suppress_cross_ref = "0"b;	/* Continue allowing cross-referencing */

		lptr = lptr -> list.element (1);
	     end;

/* If the last statement, still refected by "goto_bit", was a goto
   return, or stop, then the statement about to be processed must be
   unreachable, so set this external bit. operator_semantics uses it to tell
    when the quality of the code produced doesn't matter.	*/

	pl1_stat_$stmnt_unreachable = goto_bit;

	if st_type = return_statement | st_type = goto_statement | st_type = stop_statement then
	     goto_bit = "1"b;
	else
	     goto_bit = "0"b;

     end process_label;

/* This entry is called when a fatal error occurs in declaration processing or semantic
   translation.  Recovery consists of deleting the offending statement from the program by
   transforming it into a null statement.  Illegal declarations remain in the program.	*/

abort:
     entry (m, t);

	d = pl1_stat_$cur_statement;

	if d -> node.type = statement_node then do;
	     if pl1_stat_$debug_semant then do;
		tk = d -> statement.root;
		call ioa_ ("^/SEMANTICS bug at ^p", tk);
	     end;
	     else do;
		d -> statement.root = null;
		d -> statement.statement_type = null_statement;
	     end;

	     if pl1_stat_$multi_type then do;
		pl1_stat_$error_flag = "1"b;
		goto pl1_stat_$abort_label;
	     end;

	     call error_ (m, d -> statement.source_id, t, (d -> statement.segment), (d -> statement.source.start),
		(d -> statement.source.length));
	end;
	else
	     call error_$no_text (m, d -> symbol.source_id, t);

	pl1_stat_$index = 0;
	goto abort;

/* This entry is called when a non-fatal error occurs during semantic translation
   or declaration processing. */

error:
     entry (m, t);

	d = pl1_stat_$cur_statement;

	if d -> node.type = statement_node then
	     if pl1_stat_$multi_type then
		;
	     else
		call error_ (m, d -> statement.source_id, t, (d -> statement.segment), (d -> statement.source.start),
		     (d -> statement.source.length));
	else
	     call error_$no_text (m, d -> symbol.source_id, t);

	if pl1_stat_$last_severity >= 2 then
	     had_error = "1"b;			/* for call_es */

	return;


/* This entry is called by prepare_symbol_table when it wants to process an
   expression found hanging off a symbol node.  expression_semantics cannot be
   called directly because of a possible abort return */

call_es:
     entry (blk, stm, exp, fail, convert_to_integer) returns (ptr);

dcl      (blk, stm, exp) ptr,
         fail label,
         convert_to_integer bit (1) aligned;

dcl      (tp, tp1) ptr;

	pl1_stat_$cur_statement = stm;
	abort = fail;
	had_error = "0"b;

	tp = expression_semantics (blk, stm, exp, "0"b);
	if had_error then
	     goto fail;

	if ^convert_to_integer then
	     return (tp);

	tp1 = tp;
	if tp1 -> node.type ^= token_node then do;
	     if tp1 -> node.type = operator_node then
		tp1 = tp1 -> operand (1);
	     if tp1 -> reference.symbol -> symbol.arg_descriptor then
		go to chk_err;
	end;
	tp = convert$to_integer (tp, (integer_type));
chk_err:
	if had_error then
	     goto fail;

	return (tp);

%include quick_info;

%include semant;

%include block;
%include block_types;
%include declare_type;
%include operator;
%include semantic_bits;
%include list;

%include symbol;
%include reference;

%include statement;

%include statement_types;

%include nodes;
%include token;
%include token_types;
%include system;

     end semantic_translator;




		    simplify_expression.pl1         07/31/89  1431.7r w 07/31/89  1338.9       18756



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


simplify_expression:	proc(input_tree,constant,input_tree_modified);

dcl	(input_tree,tree,s) ptr;

dcl	(i,constant,const(2:3)) fixed bin;
dcl	fix_bin fixed bin based;

dcl	(input_tree_modified,modified(2:3)) bit(1) aligned;

dcl	null builtin;

	tree = input_tree;

	constant = 0;

	input_tree_modified = "0"b;

	if tree->node.type = reference_node
	then do;
		s = tree->reference.symbol;

		if	s->node.type = symbol_node
		then if	s->symbol.constant
		then if	s->symbol.fixed
		then if	s->symbol.binary
		then if	s->symbol.c_word_size = words_per_fix_bin_1
		then if	s->symbol.scale = 0
		then do;
			constant = s->symbol.initial->fix_bin;
			input_tree_modified = "1"b;
		end;

		return;
	end;

	if tree->node.type ^= operator_node
	then	return;

	if tree->operator.op_code^=add
	&  tree->operator.op_code^=sub
	&  tree->operator.op_code^=mult
	then	return;

	do i = 2 to tree->operator.number;
		call simplify_expression((tree->operand(i)),const(i),modified(i));
	end;

	if modified(2)
	&  modified(3)
	then do;
		if tree->operator.op_code=add
		then	constant = const(2)+const(3);
		else

		if tree->operator.op_code=sub
		then	constant = const(2)-const(3);
		else	constant = const(2)*const(3);

		input_tree_modified = "1"b;

		return;
	end;

	do i=2 to 3;
		if modified(i)
		then	if tree->operand(i)->node.type = operator_node
			then	tree->operand(i) = declare_constant$integer((const(i)));
	end;

	return;

%include language_utility;
%include nodes;
%include op_codes;
%include operator;
%include reference;
%include symbol;
%include system;

	end simplify_expression;




		    simplify_offset.pl1             07/31/89  1431.7r w 07/31/89  1339.0      229428



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


/* This version of simplify_offset assumes that mod_bit, mod_byte,
   mod_half, and bit_pointer operators do not appear in the tree */

/*	Modified:	10 April 1977 by RAB to eliminate use of mod_word operator
	Modified:	26 November 1977 by RAB to fix 1690
	Modified:	10 February 1978 by RAB to fix 1691
	Modified:	25 August 1978 by RAB to help fix 1780
	Modified:	5 September 1978 by RAB to fix 1782
	Modified:	17 Jan 1979 by RAB to fix 1816 (fault with aligned unsigned subscript)
	Modified: 23 April 1979 by PCK to implement 4-bit decimal
	Modified:	23 May 1979 by RAB to fix 1820 (large lower bound in word
		array causes bad code)
*/

simplify_offset: proc(pt,context);

dcl	pt ptr;		/* points at a reference node */

dcl	(f,p1,p2,p3,p4,r,s,s1,s2,s3,s4,sym,q,symref) ptr,
	i fixed bin,
	sign fixed bin(1),
	(has_offset, ok_to_free) bit(1) aligned,
	multiple fixed bin(31),
	(bit_offset,c_bit_offset,factor) fixed bin(24),
	(orig_c_offset,start_gen_storage,start_generation) fixed bin(24),
	(n,fix_precision,lower_precision) fixed bin(24),
	op_code bit(9) aligned,
	(called_fix_exp, fractional_offset_to_be_added) bit(1) aligned,
	fix_bin fixed bin based;

dcl	convert_offset(0:5) init(36,1,4.5,9,18,36) fixed bin(7,1) int static options(constant);
dcl	units_per_word(0:5) init(1,36,8,4,2,1) fixed bin(6) int static;

dcl	(divide,max,min,mod,null,substr) builtin;

%include semant;

%include operator;
%include reference;
%include symbol;
%include array;
%include op_codes;
%include nodes;
%include system;
%include boundary;
%include semantic_bits;

			/*      */

	q = pt;

	s = q -> reference.symbol;

	has_offset, ok_to_free = "1"b;

	/* following code attempts to reduce precision of length
	   expression; it checks if index register can be used
	   to hold length */

	p1 = q -> reference.length;
	if p1 ^= null
	then if p1 -> node.type = operator_node
	then do;
	     if s -> symbol.dcl_size ^= null
	     then fix_precision = max_length_precision;
	     else if s -> symbol.c_dcl_size >= max_index_register_value
		then fix_precision = max_length_precision;
		else fix_precision = max_signed_xreg_precision;

	     /* ok to reduce precision of expression */

	     if fix_precision = max_signed_xreg_precision
	      | p1 -> operand(1) -> reference.symbol -> symbol.c_dcl_size > max_p_fix_bin_1
	     then if p1 -> operator.op_code = assign
	     then do;
		p2 = fix_exp((p1 -> operand(2)));

		if fb_value(p2)
		then if p2 -> symbol.c_dcl_size <= fix_precision
		     then if p2 -> symbol.scale = 0
			then do;
			     q -> reference.length = p1 -> operand(2);
			     call free_op(p1);
			     end;
		end;
	     else p2 = fix_exp(p1);
	     end;

	/* following code uses modword_in_offset to discover if no further processing
	   of offset expression is possible */

	if q -> reference.modword_in_offset
	     then return;
	/* following code attempts to simplify offset expressions of the form

		c
		exp + c
		exp - c
		c + exp

		c1 * c2
		c1 * (exp + c2)
		c1 * (exp - c2)
		c1 * (c2 + exp)
						*/

	p1 = q -> reference.offset;
	if p1 = null
	then do;
	     call check_addr;
	     goto ret;
	     end;

	/* The following block of code is necessary because the 6180 will not allow
	   variable fractional offsets to be negative */

	orig_c_offset = q -> reference.c_offset;

	fractional_offset_to_be_added = def_context.f_offset_to_be_added;

	if q -> reference.units < word_ | fractional_offset_to_be_added
	then do;
	     p2 = s -> symbol.reference;
	     if q -> reference.units = p2 -> reference.units
		then start_gen_storage = p2 -> reference.c_offset;
		else start_gen_storage = divide(convert_offset(p2 -> reference.units) * p2 -> reference.c_offset,
			convert_offset(q -> reference.units),31,0);
	     orig_c_offset = max(start_gen_storage,orig_c_offset);
	     end;

	/* *********************************************************************** */

	called_fix_exp = "0"b;

simplify:	if p1 -> node.type ^= operator_node
	then do;

	     s1 = p1 -> reference.symbol;

	     if fb1_const(s1)
	     then do;
		q -> reference.offset = null;
		q -> reference.c_offset = q -> reference.c_offset + s1 -> symbol.initial -> fix_bin;
		call check_addr;
		goto ret;
		end;

	     goto ret;
	     end;

	op_code = p1 -> operator.op_code;

	if op_code = add
	then do;
	     sign = 1;
	     goto l1;
	     end;

	if op_code = sub
	then do;
	     sign = -1;

l1:	     p2 = p1 -> operand(3);
	     if p2 -> node.type ^= reference_node then goto simp1;

	     s2 = p2 -> reference.symbol;

	     if fb1_const(s2)
	     then do;

		/* eliminate the add or sub operator and absorb the constant */

		q -> reference.offset = check_exp((p1 -> operand(2)));

absorb:		call free_op(p1);
		p1 = q -> reference.offset;

		q -> reference.c_offset = q -> reference.c_offset + sign *
		 s2 -> symbol.initial -> fix_bin;
		goto simplify;
		end;

simp1:	     if sign < 0 then goto check_sub;

	     p2 = p1 -> operand(2);
	     if p2 -> node.type ^= reference_node
	     then do;

		/* The following code tries to improve the precision of the
		   offset expression to 17, 18, or 24 depending on the offset
		   units and the size of the variable	*/

replace:
		if called_fix_exp then goto rep;

		lower_precision = max_signed_xreg_precision;

		if q -> reference.units < word_  & ^ q -> reference.modword_in_offset
		 | fractional_offset_to_be_added
		then do;
		     fix_precision = max_offset_precision;
		     if s -> symbol.dcl_size ^= null then goto set_bit;
		     if s -> symbol.c_dcl_size > max_index_register_value then goto set_bit;
		     if s -> symbol.c_dcl_size > max_signed_index_register_value
		      & fractional_offset_to_be_added
			then lower_precision = max_uns_xreg_precision;

		     r = q;
		     sym = s;
		     start_generation = start_gen_storage;

check_again:
		     f = sym;

		     if sym -> symbol.member
		     then do;

			/* can't reduce precision if member has offset
			   expression */

			if sym -> symbol.reference -> reference.offset ^= null
			then goto set_bit;

			if sym -> symbol.dimensioned
			then do f = sym repeat f -> symbol.father
				while(f -> symbol.array -> array.own_number_of_dimensions
				      ^= f -> symbol.array -> array.number_of_dimensions);
				end;
			end;

		     if f -> symbol.bit_size ^= null then go to set_bit;

		     /* the next block of code determines if the maximum
		        variable offset will fit in an index register.
		        The maximum offset is calculated in n.	*/

		     n = f -> symbol.c_bit_size;
		     n = divide(n, convert_offset(q -> reference.units), 24, 0);

		     n = n + start_generation - q -> reference.c_offset;

		     if n >= max_index_register_value then goto set_bit;
		     if n >= max_signed_index_register_value
		      & fractional_offset_to_be_added
			then lower_precision = max_uns_xreg_precision;

		     if sym -> symbol.defined
		     then do;

			/* have to do same check on all those we are
			   defined on */

			r = r -> reference.qualifier;
			if r -> node.type = operator_node
			     then r = r -> operand(1);
			sym = r -> reference.symbol;
			symref = sym -> symbol.reference;

			if symref -> reference.c_offset ^= 0
			then do;
			     if q -> reference.units = symref -> reference.units
				then start_generation = symref -> reference.c_offset;
				else start_generation =
				     divide(convert_offset(symref->reference.units) * symref->reference.c_offset,
					convert_offset(q->reference.units), 31, 0);
			     end;
			else start_generation = 0;
			go to check_again;
			end;
		     end;

		fix_precision = lower_precision;

set_bit:		called_fix_exp = "1"b;

		if fix_precision = max_length_precision
		then if p1 -> operand(1) -> reference.symbol -> symbol.c_dcl_size <= max_p_fix_bin_1
		     then go to rep;

		if p1 -> operator.op_code = assign
		then do;
		     p2 = fix_exp((p1 -> operand(2)));
		     if fb_value(p2)
		     then if p2 -> symbol.c_dcl_size <= fix_precision
			then if p2 -> symbol.scale = 0
			     then do;
				p2 = p1 -> operand(2);
				call free_op(p1);
				p1, q -> reference.offset = p2;
				goto simplify;
				end;
		     end;
		else do;
		     if substr(p1 -> operator.op_code,1,5) = substr(mod_bit,1,5)
		     then p2 = p1 -> operand(3); else p2 = p1;
		     p2 = fix_exp(p2);
		     end;

		goto rep;
		end;

	     s2 = p2 -> reference.symbol;

	     if fb1_const(s2)
	     then do;
		q -> reference.offset = check_exp((p1 -> operand(3)));
		goto absorb;
		end;

	     goto replace;

	     /* the following code tries to catch
			exp - exp
	        which gets eliminated,
			(exp1 + exp2) - exp1
	        which gets simplified, and
			exp1 * exp2 - exp1
	        which gets converted to
			(exp2 - 1) * exp1
	       with obvious simplifcation when exp2 is a constant */

check_sub:
	     if compare_expression((p1 -> operand(2)),(p1 -> operand(3)))
	     then do;
		call free_exp(p1);
		p1 = null;
		call check_addr;
		goto rep;
		end;

	     p2 = p1 -> operand(2);
	     if p2 -> node.type ^= operator_node then goto replace;

	     if p2 -> operator.op_code = add
	     then do;
		if compare_expression((p2 -> operand(2)),(p1 -> operand(3)))
		then do;
		     q -> reference.offset = check_exp((p2 -> operand(3)));
elim_sub:
		     call free_op(p1);
		     p2 = check_exp(p2);
		     call free_op(p2);
		     p1 = q -> reference.offset;
		     go to simplify;
		     end;

		if compare_expression((p2 -> operand(3)),(p1 -> operand(3)))
		then do;
		     q -> reference.offset = check_exp((p2 -> operand(2)));
		     go to elim_sub;
		     end;

		go to replace;
		end;

	     if p2 -> operator.op_code ^= mult then goto replace;

	     if ^ compare_expression((p2 -> operand(2)),(p1 -> operand(3))) then goto replace;

	     p3 = p2 -> operand(3);
	     if p3 -> node.type ^= reference_node
	     then do;
switch:		p1 -> operator.op_code = mult;
		p2 -> operator.op_code = sub;
		p2 -> operand(2) = p3;
		p2 -> operand(3) = declare_constant$integer(1);

		p3 = p1 -> operand(1);
		p1 -> operand(1) = p2 -> operand(1);
		p2 -> operand(1) = p3;
		goto replace;
		end;

	     s3 = p3 -> reference.symbol;
	     if ^ fb1_const(s3) then goto switch;

	     p1 -> operand(2) = declare_constant$integer(s3 -> symbol.initial -> fix_bin - 1);
	     p1 -> operand(1) = p2 -> operand(1);
	     p1 -> operator.op_code = mult;

	     goto replace;
	     end;

	if op_code ^= mult then goto replace;

	p2 = p1 -> operand(2);
	if p2 -> node.type ^= reference_node then goto check_mb;

	s2 = p2 -> reference.symbol;
	if ^ fb1_const(s2) then goto check_mb;

again:	p3 = p1 -> operand(3);
	if p3->node.type^=operator_node
	then do;
	     s3 = p3->reference.symbol;

	     if fb1_const(s3)
	     then do;
		q -> reference.offset = null;
		q -> reference.c_offset = q -> reference.c_offset + s2 -> symbol.initial -> fix_bin * s3 -> symbol.initial -> fix_bin;
		call free_op(p1);
		call check_addr;
		goto ret;
		end;
	     else goto check_mb;
	     end;

	if p3 -> operator.op_code = add then sign = 1;
	else if p3 -> operator.op_code = sub then sign = -1;
	     else goto check_mb;

	p4 = p3 -> operand(3);
	if p4 -> node.type ^= reference_node then goto check_mb;

	s4 = p4 -> reference.symbol;
	if fb1_const(s4)
	then do;
	     p1 -> operand(3) = p3 -> operand(2);
alter:	     call free_op(p3);
	     q -> reference.c_offset = q -> reference.c_offset + sign *
	      s2 -> symbol.initial -> fix_bin * s4 -> symbol.initial -> fix_bin;
	     goto again;
	     end;

	if sign < 0 then goto check_mb;

	p4 = p3 -> operand(2);
	if p4 -> node.type ^= reference_node then goto check_mb;

	s4 = p4 -> reference.symbol;

	if fb1_const(s4)
	then do;
	     p1 -> operand(3) = p3 -> operand(3);
	     goto alter;
	     end;

check_mb:	if q -> reference.fo_in_qual then goto replace;

	/* following code attempts to recognize references to items
	   which have a constant bit offset and a variable word offset;
	   the offset expression for this type of reference is
		mult(t4,exp,multiple_of_bits_per_word)	*/

	if q -> reference.units >= word_  then goto replace;

	if q -> reference.length ^= null then goto replace;
	if s -> symbol.decimal then goto replace;
	if s -> symbol.bit
	then if q -> reference.c_length > bits_per_double
	     then goto replace;
	     else;
	else if s -> symbol.char | s -> symbol.picture
	     then if q -> reference.c_length > characters_per_double
		then goto replace;

	if q -> reference.units = bit_ then factor = 1;
	else factor = bits_per_character;

	p3 = p1 -> operand(3);
	if p3 -> node.type ^= reference_node then goto replace;

	s3 = p3 -> reference.symbol;
	if ^ fb1_const(s3) then goto replace;

	bit_offset = s3 -> symbol.initial -> fix_bin * factor;
	if mod(bit_offset,bits_per_word) ^= 0 then goto replace;

	/* found it, mark the reference and eliminate
	   or change mult operator */

	multiple = divide(bit_offset,bits_per_word,31,0);
	c_bit_offset = q -> reference.c_offset * factor;

	if mod(c_bit_offset,bits_per_word) ^= 0
	then do;

	     if multiple = 1
	     then do;
		q -> reference.offset = check_exp((p1 -> operand(2)));
		call free_op(p1);
		p1 = q -> reference.offset;
		end;

	     else p1 -> operand(3) = declare_constant$integer(multiple);

	     q -> reference.modword_in_offset = "1"b;
	     has_offset = "0"b;
	     end;

	else do;

	     /* we probably shouldn't have gotten here,
	        but we'll improve units to word_ and
	        forget about marking the reference */

	     q -> reference.c_offset = divide(c_bit_offset,bits_per_word,24,0);
	     q -> reference.units = word_;

	     if multiple = 1
	     then do;
		q -> reference.offset = check_exp((p1 -> operand(2)));
		call free_op(p1);
		p1 = q -> reference.offset;
		go to simplify;
		end;
	     else p1 -> operand(3) = declare_constant$integer(multiple);
	     end;

	if p1 -> node.type = operator_node
	     then goto replace;

rep:
	q->reference.offset = p1;

ret:
	if q -> reference.units = 0
	then	return;

	if q -> reference.units = word_
	then do;
		if has_offset
		then	if abs(q -> reference.c_offset) > max_index_register_value
			then	call restore_orig_c_offset;
		return;
	     end;

	if q->reference.units = bit_
	then if ^ s -> symbol.bit
	then if s->symbol.char
	     |  s->symbol.decimal
	     |  s->symbol.picture
	then do;
		q->reference.units = character_;
		q->reference.c_offset = divide(q->reference.c_offset,bits_per_character,17,0);
		orig_c_offset = divide(orig_c_offset,bits_per_character,31,0);

		p1 = q->reference.offset;
		if p1=null
		then	go to check_neg;

		if q->reference.modword_in_offset
		then	goto check_neg;

		if p1->node.type=operator_node
		then do;
			if p1->operator.op_code=mult
			then do i = 2 to 3;
				p3 = p1->operand(i);

				if p3->node.type=reference_node
				then do;
					s3 = p3->reference.symbol;

					if fb1_const(s3)
					then do;
						bit_offset = s3->symbol.initial->fix_bin;
						if bit_offset=bits_per_character
						then do;
							q->reference.offset = check_exp((p1->operand(5-i)));
							call free_op(p1);
							p1 = q->reference.offset;

							goto simplify;
						end;
						else if mod(bit_offset,bits_per_character) = 0
						     then if p1->operand(1)->reference.ref_count <= 1
						     then do;
							multiple = divide(bit_offset,bits_per_character,31,0);
							p1->operand(i) = declare_constant$integer(multiple);
							go to check_neg;
							end;
					end;
				end;
			end;

			s1 = p1->operand(1)->reference.symbol;
		end;
		else	s1 = p1->reference.symbol;

		p2 = create_operator((div),3);
		p2->operand(1) = declare_temporary((integer_type),(s1->symbol.c_dcl_size),0,null);
		p2->operand(2) = p1;
		p2->operand(3) = declare_constant$integer((bits_per_character));
		p2->operator.processed = "1"b;

		q->reference.offset = p2;

	end;

	/* The following block of code is necessary because the 6180 will not allow
	   variable fractional offsets to be negative.  To be specific,
	   negative character offsets may only appear in the a or q, and
	   negative bit offsets may not appear at all.  We must protect
	   against negative variable offsets and against negative constant
	   offsets that are so large as to exceed the 15-bit constant address
	   portion of the instruction word.	*/

check_neg:
	if q -> reference.units = character_ & s -> symbol.decimal & s -> symbol.unaligned
	then do;
		call double_offset;
		orig_c_offset = 2 * orig_c_offset;
	     end;

	if has_offset
	then if q -> reference.c_offset > orig_c_offset
	      | divide(q -> reference.c_offset,units_per_word(q->reference.units),19,0) <= -16383
	then do;
	     if q -> reference.units = character_ | q -> reference.units = digit_
	     then do;
		q -> reference.big_offset = "1"b;
		return;
		end;

	     call restore_orig_c_offset;
	     end;

	/* ************************************************************* */


	return;

check_addr:    proc;
	     /* this code tries to improve addr(x) -> y_unaligned */
     
	     has_offset = "0"b;
	     p2 = q -> reference.qualifier;
	     if p2 = null then return;
     
	     if p2 -> node.type ^= operator_node then return;
     
	     if p2 -> operator.op_code = addr_fun
	     then do;
		q -> reference.fo_in_qual = "0"b;
		p1, q -> reference.offset = null;
		return;
		end;
     
	     if p2 -> operator.op_code ^= addr_fun_bits then return;

	     /* if qual is unshared, someone else is also using it,
	        so altering it is unsafe. */

	     if ^ p2 -> operand(1) -> reference.shared then return;

	     /* if the reference is an aggregate, simplify_offset may be
	        undone, so altering qualifier is unsafe. */

	     if q -> reference.array_ref then return;

	     if s -> node.type = symbol_node
	     then if s -> symbol.structure
		then return;
     
	     p3 = p2 -> operand(2);

	     if q -> reference.c_offset ^= 0
	     then if q -> reference.units ^= p3 -> reference.units
		then return;
     
	     p1, q -> reference.offset = p3 -> reference.offset;
	     q -> reference.c_offset = q -> reference.c_offset + p3 -> reference.c_offset;
	     q -> reference.units = p3 -> reference.units;
	     q -> reference.fo_in_qual = p3 -> reference.fo_in_qual;
	     q -> reference.modword_in_offset = p3 -> reference.modword_in_offset;
     
	     if p3->reference.symbol->symbol.reference = p3
	     then p3, p2->operand(2) = copy_expression((p3));
     
	     p3 -> reference.offset = null;
	     p3 -> reference.c_offset, p3 -> reference.units = 0;
	     p3 -> reference.modword_in_offset = "0"b;
     
	     p2 -> operator.op_code = addr_fun;

	     call check_char_units;
     
	     end;

check_exp:     proc(off) returns(ptr);

	     /* check_exp is called when off is to replace the current q->reference.offset.
	        off is assumed to be contained in q->reference.offset.  If q->reference.offset
	        is also contained in q->reference.length, then off's ref count must be
	        incremented. */

dcl	     off ptr;

dcl	     p ptr;

	     p = off;

	     if p ^= null
	     then do;
	     	if q -> reference.length ^= null
		then if in_expression((q -> reference.offset),(q -> reference.length))
		     then p = share_expression(p);

		if p -> node.type = reference_node
		then if p -> reference.symbol -> symbol.packed
		     then p = convert$to_integer(p,(integer_type));
		end;

	     return(p);

	     end;


in_expression: proc(p,pt) reducible returns(bit(1) aligned);

dcl	     (p,pt) ptr,
	     k fixed binary;

	     if p=pt then goto yes;

	     if pt -> node.type ^= operator_node then goto no;

	     do k = 1 to pt -> operator.number;
		if pt -> operand(k) ^= null
		then if in_expression(p,(pt -> operand(k)))
		     then go to yes;
		end;

no:	     return("0"b);

yes:	     return("1"b);
	     end;

fb1_const:     proc(pt) reducible returns(bit(1) aligned);

dcl	     (p,pt) ptr;

	     p = pt;
	     if ^ p -> symbol.constant then goto no;
	     if ^ p -> symbol.fixed then goto no;
	     if ^ p -> symbol.binary then goto no;

	     if p -> symbol.c_word_size = words_per_fix_bin_1 then return("1"b);

no:	     return("0"b);
	     end;

fb_value:	     proc(pt) reducible returns(bit(1) aligned);

dcl	     (p,pt) ptr;

	     p = pt;
	     if p = null then goto no;

	     if ^ p -> symbol.fixed then goto no;
	     if ^ p -> symbol.binary then goto no;
	     if ^ p -> symbol.real then goto no;

	     if p -> symbol.aligned | p -> symbol.constant then return("1"b);

no:	     return("0"b);
	     end;

fix_exp:	     proc(pt) returns(ptr);

dcl	     pt ptr;

dcl	     (p,s1,s2,s3,t) ptr;

	     p = pt;
	     if p -> node.type = reference_node then return(p -> reference.symbol);

	     t = p -> operand(1);
	     if t ^= null
	     then do;
		s1 = t -> reference.symbol;
		if ^ t -> reference.shared then goto back;
		if ^ fb_value(s1) then goto back;
		if s1 -> symbol.c_dcl_size <= fix_precision then goto back;
		end;

	     /* output is fixed bin, but precision is too large.  see if we can
	        reduce precision */

	     if p -> operator.op_code = assign then goto ck2;

	     if p -> operator.op_code > mult then goto back;

	     s3 = fix_exp((p -> operand(3)));

	     if ^ fb_value(s3) then goto back;
	     if s3 -> symbol.c_dcl_size > max_p_fix_bin_1 then goto back;

ck2:	     s2 = fix_exp((p -> operand(2)));

	     if ^ fb_value(s2) then goto back;
	     if s2 -> symbol.c_dcl_size > max_p_fix_bin_1 then goto back;

	     /* both operands are fix single, reduce precision */

	     p -> operator.processed = "1"b;
	     p -> operand(1) = declare_temporary((integer_type),(fix_precision),
	      0,null);
	     s1 = p -> operand(1) -> reference.symbol;

back:	     return(s1);
	     end;

free_op:	     proc(pt);

dcl	     (pt,r1) ptr;

	     r1 = pt -> operand(1);
	     if r1 -> reference.ref_count < 2
	     then if ok_to_free
		then call free_node(pt);
		else;
	     else do;
		r1 -> reference.ref_count = r1 -> reference.ref_count - 1;
		ok_to_free = "0"b;
		end;

	     end;

free_exp:      proc(exp);

dcl	     (exp,px,py) ptr,
	     j fixed bin;

	     px = exp;
	     do j = 1 to px -> operator.number;
		py = px -> operand(j);
		if py ^= null
		then do;
		     if j = 1
		     then if py -> reference.ref_count > 1
			then do;
			     py -> reference.ref_count = py -> reference.ref_count - 1;
			     return;
			     end;

		     if py -> node.type = operator_node
		     then call free_exp(py);
		     end;
		end;

	     call free_node(px);
	     end;

check_char_units:	proc;

dcl	     (new,o,s1) ptr;

	     if q -> reference.units = character_
	     then if ^ s -> symbol.char
	     then if ^ s -> symbol.decimal
	     then if ^ s -> symbol.picture
	     then do;
		q -> reference.units = bit_;
		q -> reference.c_offset = q -> reference.c_offset * bits_per_character;

		if q -> reference.offset ^= null
		then if ^ q -> reference.modword_in_offset
		then do;
		     o = q -> reference.offset;
		     if o -> node.type = operator_node
			then s1 = o -> operand(1) -> reference.symbol;
			else s1 = o -> reference.symbol;

		     new = create_operator((mult),3);
		     new -> operand(1) = declare_temporary((integer_type),s1 -> symbol.c_dcl_size + 4,0,null);
		     new -> operand(2) = declare_constant$integer((bits_per_character));
		     new -> operand(3) = o;
		     new -> operator.processed = "1"b;
		     p1, q -> reference.offset = new;
		     end;
		end;

	     end;

/* Convert off set from character_ to digit_ units for unaligned decimal variables */

double_offset:
	procedure;

declare	(new,o,s1) pointer;

	q -> reference.units = digit_;
	q -> reference.c_offset = q -> reference.c_offset * packed_digits_per_character;

	if q -> reference.offset ^= null
	then if ^ q -> reference.modword_in_offset
	     then do;
		     o = q -> reference.offset;

		     if o -> node.type = operator_node
		     then s1 = o -> operand(1) -> reference.symbol;
		     else s1 = o -> reference.symbol;

		     new = create_operator((mult),3);
		     new -> operand(1) = declare_temporary((integer_type),s1 -> symbol.c_dcl_size + 1,0,null);

		     new -> operand(2) = declare_constant$integer((packed_digits_per_character));
		     new -> operand(3) = o;
		     new -> operator.processed = "1"b;
		     p1, q -> reference.offset = new;
		end;

	end /* double_offset */;

/* makes orig_c_offset the new q -> reference.c_offset */

restore_orig_c_offset:	proc;

dcl	(p1,p2,p3,p4) ptr;
dcl	difference fixed bin(31);
dcl	(prec2,prec3) fixed bin(24);

	p2 = q -> reference.offset;

	if p2 -> node.type = operator_node
	     then p4 = p2 -> operand(1);
	     else p4 = p2;
	prec2 = p4 -> reference.symbol -> symbol.c_dcl_size;

	difference = q -> reference.c_offset - orig_c_offset;
	q -> reference.c_offset = orig_c_offset;

	p1 = create_operator(add,3);
	p1 -> operand(2) = p2;
	p3, p1 -> operand(3) = declare_constant$integer(difference);
	prec3 = p3 -> reference.symbol -> symbol.c_dcl_size;
	p1 -> operand(1) = declare_temporary((integer_type),
		min(max_p_fix_bin_1,max(prec2,prec3)  + 1),0,null);
	p1 -> operator.processed = "1"b;

	q -> reference.offset = p1;

	end /* restore_orig_c_offset */;


	end;




		    subscripter.pl1                 07/31/89  1431.7r w 07/31/89  1339.0       72216



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


/* Modified: 79/04/23 by PCK to implement 4-bit decimal */

subscripter: proc(blk,stmnt,tree,subs,s) returns(ptr);

dcl	(blk,stmnt,tree,s,subs,subscript,e,sum,a,b,q,off,pdssl) ptr;
dcl	(n,i,k,n_minus_k) fixed bin(15);
dcl	(units,cunits) fixed binary(3);
dcl	(c_sum,c_subscript,coff) fixed bin(31);

dcl	op_table(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);

dcl	pl1_stat_$eis_mode bit(1) aligned ext static;

dcl	(addr,null,substr,string,fixed,char,max) builtin;

	c_sum = 0;
	sum = null;
	n = subs->list.number;
	if s->node.type = label_node
	then do;
		b = create_bound();
		b->bound.c_lower = s->label.low_bound;
		b->bound.c_upper = s->label.high_bound;
		b->bound.c_multiplier = 1;
		k = 1;
	     end;
	else do;
		a = s->symbol.array;
		b = a->array.bounds;
		k = a->array.number_of_dimensions;
		if n < k then call print(81);
		if n > k & ^s->symbol.entry then call print(82);
	     end;

	if tree->reference.put_data_sw
	then pdssl = create_list(k);
	else pdssl = null;

/* The parse produces separate subscript and argument lists when possible
	ex 1:	a(i)(arg1,arg2);
   but when the syntax is ambiguous, it produces a single list:
	ex 2:	a(i).b(first_arg_or_subs,...last_arg_or_subs);

   Note that the elements are pushed, i.e., the list for example 2 is:
	(last_arg_or_subs,...first_arg_or_subs,i)
*/
	do i = n-k+1 to n;			/* take last _k of _n elements */

	     subscript = subs->list.element(i);
	     if subscript->node.type = token_node
		then if subscript->token.type = dec_integer
			then do;
				c_subscript = token_to_binary(subscript);

/* Check the subscript against the constant array bounds.
   The following code works for all cases except where someone has already put a reference
   to the constant in the bound.upper or bound.lower fields, _a_n_d that constant is zero.
*/


				if b->bound.lower = null | b->bound.c_lower ^= 0
				then if c_subscript < b->bound.c_lower
				     then call print(184);
				if b->bound.upper = null | b->bound.c_upper ^= 0
				then if c_subscript > b->bound.c_upper
				     then call print(184);
				subscript = null;
			     end;
			else;
		else if subscript->node.type=operator_node
		     then subscript = copy_expression((subscript));

	     if subscript ^= null
		then do;
			this_context = "0"b;
			subscript = expression_semantics(blk,stmnt,subscript,this_context);
			if def_this_context.aggregate then call print(84);
			subscript = convert$to_integer(subscript,integer_type);
		     end;


	     if substr(stmnt->statement.prefix,7,1) /* subscriptrange */
	          then if b->bound.lower^=null | b->bound.upper^=null | subscript^=null
		then do;
			if subscript = null then subscript = declare_constant$integer(c_subscript);
			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));
			q = create_operator(bound_ck,4);
			q->operand(2) = subscript;
			q->operand(3) = copy_expression(b->bound.lower);
			q->operand(4) = copy_expression(b->bound.upper);
			subscript = expression_semantics((s->symbol.block_node),stmnt,q,this_context);
		     end;

	     if b->bound.c_multiplier^=0
	     then	if subscript=null
		then	c_sum = c_sum+b->bound.c_multiplier*c_subscript;
		else	if b->bound.c_multiplier=1
			then	sum = addf(sum,subscript);
			else	sum = addf(sum,multf
					(declare_constant$integer((b->bound.c_multiplier)),subscript));

	     else	if subscript=null
		then	if c_subscript=1
			then	sum = addf(sum,copy_expression(b->bound.multiplier));		else
			if c_subscript^=0
			then	sum = addf(sum,multf
				(copy_expression(b->bound.multiplier),declare_constant$integer(c_subscript)));
			else;
		else	sum = addf(sum,multf(copy_expression(b->bound.multiplier),subscript));

	     if pdssl ^= null		/* save the subscripts for data i/o in the opposite order */
		then if subscript ^= null
			then pdssl->list.element(n-i+1) = share_expression(subscript);
			else pdssl->list.element(n-i+1) = declare_constant$integer(c_subscript);

	     b = b->bound.next;
	end;

/* strip off the subscripts we used, return the extra ones (possible arguments to a
   subscripted entry variable, for example. */

	if k ^= n
	then do;
		n_minus_k=n-k;
		b = create_list(n_minus_k);
		do i = 1 to n_minus_k;	/* take first n_minus_k elements of subs */
		     b->element(i) = subs->element(i);
		end;
		subs = b;
	end;
	else	subs = null;

/* Subtract the virtual origin from the sum of the multipliers times the subscripts. */

	e = tree;
	if s->node.type = symbol_node
	then if tree = s->symbol.reference
		then	e = copy_expression((tree));

	if pdssl ^= null
	then do;
		e->reference.subscript_list=pdssl;
		blk->block.plio_ssl->symbol.c_word_size = max(blk->block.plio_ssl->symbol.c_word_size,k+1);
	end;

	if s->node.type = label_node
	then do;
		units = word_;
		c_sum = c_sum-s->label.low_bound;
	end;
	else do;
		units = a->array.offset_units;
		c_sum = c_sum-a->array.c_virtual_origin;
		if a->virtual_origin^=null
		then	if sum=null
			then do;
				sum = create_operator(negate,2);
				sum->operator.operand(2) = copy_expression(a->virtual_origin);
			end;
			else	sum = subf(sum,copy_expression(a->array.virtual_origin));

		if	units=character_
		then if	pl1_stat_$eis_mode
		then if	s->symbol.bit
		     |	s->symbol.binary
		     |	s->symbol.ptr
		then do;
			units = bit_;
			c_sum = c_sum * bits_per_character;
			if sum^=null
			then	sum = multf(sum,declare_constant$integer(bits_per_character));
		end;
	end;

/* call the offset_adder to add the offset produced from the subscripts to the offset
   produced by the declaration processor.  All conversions of units are done by the
   offset adder.  */

	off = e->reference.offset;
	coff = e->reference.c_offset;
	cunits = e->reference.units;
	call offset_adder(off,coff,cunits,(e->reference.modword_in_offset),sum,c_sum,units,"0"b,e->reference.fo_in_qual);
	e->reference.offset = off;
	e->reference.c_offset = coff;
	e->reference.units = cunits;
	e->reference.modword_in_offset = "0"b;

/* If the units of the offset are less than words and the offset is variable the top operator
   in the offset expression must be a mod operator.  */

	if	^pl1_stat_$eis_mode
	then if	e->reference.units < word_
	then if	e->reference.offset ^= null
	then do;
		q = create_operator(op_table(e->reference.units),3);
		q->operand(3) = e->reference.offset;
		e->reference.offset = q;
	end;

	e->reference.shared = "0"b;
	e->reference.ref_count = 1;
	if s->symbol.packed then e->reference.padded_ref = "0"b;

	return(e);

/* subroutine to print an error message and abort. */

print: proc(m);

dcl	m fixed bin(15);
dcl	semantic_translator$abort entry(fixed bin(15),ptr);

	call semantic_translator$abort(m,s);

	end print;

/* subroutine to build expressions.  */

addf: proc(a,b) returns(ptr);

dcl	(a,b,c) ptr;
dcl	opcode bit(9) aligned;

	opcode = add;

	if a=null
	then return(b);

	go to common;

subf: entry(a,b) returns(ptr);

	opcode = sub;
	go to common;

multf: entry(a,b) returns(ptr);

	opcode = mult;
common:
	c = create_operator(opcode,3);
	c->operand(2) = a;
	c->operand(3) = b;

	return(c);

	end addf;

%include semant;
%include block;
%include label;
%include symbol;
%include array;
%include reference;
%include statement;
%include list;
%include token;
%include operator;
%include op_codes;
%include boundary;
%include nodes;
%include token_types;
%include declare_type;
%include semantic_bits;
%include system;


	end subscripter;




		    validate.pl1                    10/25/90  1001.3rew 10/25/90  0955.1      180666



/****^  ***********************************************************
        *                                                         *
        * 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,MCR7635), audit(87-04-28,Huen),
     install(87-05-21,MR12.1-1033):
     Fix bug #2144
  2) change(89-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
     install(89-09-19,MR12.3-1068):
     Fix bugs 1737 & 1873
  3) change(90-08-30,Huen), approve(90-08-30,MCR8160),
     audit(90-09-07,Zimmerman), install(90-10-17,MR12.4-1046):
     pl1_2221: Fix the PL1 compiler to not complain about constant symbols that
     are actually legal.
  4) change(90-10-17,Gray), approve(90-10-17,MCR8160), audit(90-10-19,Schroth),
     install(90-10-25,MR12.4-1049):
     Modified to only validate constants for symbols declared by dcl statement.
                                                   END HISTORY COMMENTS */

/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
validate:
     proc (sp);

/* Modified 780314 by PG to fix 1673 (don't default constants unless default statement explicitly touches constants)
	and to print error 206 only if none of the attribute sets are consistent.
   Modified 780629 by PG for unsigned
   Modified 780712 by PG to diagnose liking to a structure containing refer extents
   Modified 780725 by PG to move responsibility for setting the aliasable bit to declare and declare_structure.
   Modified 780731 by PG to use adam to determine storage class.
   Modified 780927 by PCK to flag the use of unaligned decimal for Release 24 of PL/I
   Modified 790521 by RAB to complete the implementation of multiple
	attribute sets for default statements started on 780314.
  Modified 830427 by BIM for options (packed) for pointers.
  Modified 860618 by RW to diagnose "dcl z varying" as incorrect
  Modified 890202 by RW "constant" attribute only on files and entries,
     	duplicate parameter dcls only diagnosed once

*/

/* parameters */

dcl      sp pointer parameter;

/* automatic */

dcl      (adam, s, b, d, ds) ptr;
dcl      m fixed bin (15);
dcl      (n, minimum, maximum) fixed bin (31);
dcl      1 invalid aligned like symbol.attributes;
dcl      (invalid_attribute_set, valid_attribute_set, return_parameter, created_descriptor) bit (1) aligned;

/* external static */

dcl      pl1_stat_$check_ansi bit (1) aligned ext static;
dcl      pl1_stat_$unaligned_dec bit (1) aligned ext static;

/* builtins */

dcl      (binary, hbound, index, lbound, length, null, string, substr, unspec) builtin;

/* program */

	s = sp;

/* Since the storage class has not been propagated down at this time for members of
   structures, get a pointer to the level-1 symbol node ("adam") which contains the
   storage class of the structure.  (Which itself may not have been set for parameters...) */

	do adam = s repeat (adam -> symbol.father) while (adam -> symbol.father ^= null);
	end;

/* Prevent the descriptor for parameters of internal procedures from being defaulted */

	created_descriptor = adam -> symbol.parameter & adam -> symbol.param_desc;

	if created_descriptor then
	     s -> symbol.param_desc = "0"b;

	if s -> symbol.level = 0 & s -> symbol.member then do;
	     call print (113);
	     s -> symbol.member = "0"b;
	end;

	if adam -> symbol.parameter & s -> symbol.location = 0
	     & ^(s -> symbol.member | s -> symbol.dcl_type = by_compiler) then do;

/* parameter attribute but not a parameter */
	     if s -> symbol.token -> token.declaration -> symbol.location = 0 then
		call print (97);			/* else it is just a duplicate declaration, diagnose it later */

	end;

	if (s -> symbol.level > 1 | s -> symbol.member) & s -> symbol.father = null then do;
	     call print (212);
	     s -> symbol.level = 0;
	     s -> symbol.member = "0"b;
	end;

/* Diagnose an invalid attribute set. */

	invalid = inconsistent (s -> symbol.attributes);

	if string (invalid) ^= ""b then do;
	     m = 200;
	     if s -> symbol.external & string (adam -> symbol.storage_class) ^= "0"b
		& ^(adam -> symbol.static | adam -> symbol.constant | adam -> symbol.controlled) then
		m = 218;

	     if s -> symbol.varying & string (s -> symbol.data_type) ^= "0"b & ^(s -> symbol.bit | s -> symbol.char)
		then
		m = 219;

	     if s -> symbol.initialed & (adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.defined)
		then
		m = 220;

	     if s -> symbol.member & string (s -> symbol.storage_class) ^= ""b then
		m = 210;
	end;
	else
	     m = 0;

	if m ^= 0 then do;
	     call print (m);
	     string (s -> symbol.attributes) = string (s -> symbol.attributes) & ^string (invalid);
	end;

	call check_extent_type;

/* Prevent the return value from being defaulted. */

	return_parameter =
	     s -> symbol.parameter & ^created_descriptor & s -> symbol.level < 2 & s -> symbol.dcl_type = by_compiler;
	if return_parameter then do;
	     s -> symbol.parameter = "0"b;
	     s -> symbol.return_value = "1"b;
	end;

/* Apply the defaults */

	if ^adam -> symbol.temporary then
	     do b = s -> symbol.block_node repeat b -> block.father while (b ^= null);
		do d = b -> block.default repeat d -> default.next while (d ^= null);
		     if d -> default.no_defaults then
			go to develop;

		     valid_attribute_set, invalid_attribute_set = "0"b;
		     if d -> default.system then
			call system;
		     else if evaluate (d, s, adam, (d -> default.predicate)) then
			if d -> default.error then
			     call print (211);
			else
			     do ds = d -> default.symbol repeat ds -> symbol.next while (ds ^= null);
				string (invalid) =
				     string (s -> symbol.attributes) | string (ds -> symbol.attributes);
				invalid = inconsistent (invalid);

				if string (invalid) ^= ""b then
				     invalid_attribute_set = "1"b;
				else if merge_attributes (s, ds) /* merge default symbol attributes into s */ then
				     invalid_attribute_set = "1"b;
				else do;
				     s -> symbol.defaulted = "1"b;
				     valid_attribute_set = "1"b;
				end;
			     end;

		     if invalid_attribute_set /* None of the attribute sets could be applied. */
			& ^valid_attribute_set then
			call print (206);
		end;
	     end;

	call system;

/* now check that the automagickly supplied attributes still match the 
 * declared attributes
 * diagnose this: dcl x fixed bin constant
 */

	if adam -> symbol.constant & adam -> symbol.dcl_type = by_declare & ^(s -> symbol.file | s -> symbol.entry) then do;
	     call print (200);
	     s -> symbol.constant = "0"b;		/* lets do it all again to get the defaults right this time. */
	     call validate (s);
	end;

/* These errors might result from supplying the system defaults.  */

	call check_extent_type;

/* Restore the attributes modified above. */

develop:
	if created_descriptor then do;
	     s -> symbol.parameter = "0"b;
	     s -> symbol.param_desc = "1"b;
	end;

	if return_parameter then do;
	     s -> symbol.parameter = "1"b;
	     s -> symbol.return_value = "0"b;
	end;

/* remove wart -- entry() caused a dummy list to be attached to symbol.general to prevent defaulting */

	if s -> symbol.entry then
	     if s -> symbol.general ^= null then
		if s -> symbol.general -> list.number = 0 then
		     s -> symbol.general = null;

/* Check for completed attributes and prevent faults if they are not complete */

	m = 0;
	if s -> symbol.returns then
	     if s -> symbol.dcl_size = null then do;
		call print (279);
		s -> symbol.returns = "0"b;
	     end;
	if s -> symbol.dimensioned then
	     if s -> symbol.array = null then do;
		call print (280);
		s -> symbol.dimensioned = "0"b;
	     end;
	if s -> symbol.picture then
	     if s -> symbol.general = null then do;
		call print (281);
		s -> symbol.picture = "0"b;
	     end;
	if s -> symbol.position then
	     if s -> symbol.initial = null then do;
		call print (282);
		s -> symbol.position = "0"b;
	     end;
	if s -> symbol.initialed then
	     if s -> symbol.initial = null then do;
		call print (283);
		s -> symbol.alloc_in_text, s -> symbol.initialed = "0"b;
	     end;
	if s -> symbol.generic then
	     if s -> symbol.general = null then do;
		m = 284;
		s -> symbol.generic = "0"b;
	     end;
	if s -> symbol.environment then
	     if ^s -> symbol.interactive & ^s -> symbol.stringvalue then
		m = 285;
	if s -> symbol.options then
	     if ^s -> symbol.variable_arg_list & ^s -> symbol.alloc_in_text & ^s -> symbol.explicit_packed then do;
		m = 498;
		s -> symbol.options = "0"b;
	     end;
	if s -> symbol.alloc_in_text then do;
	     if pl1_stat_$check_ansi then
		call print (349);

	     if ^(s -> symbol.internal & adam -> symbol.static & (s -> symbol.structure | s -> symbol.initialed))
	     then do;
		m = 482;
		s -> symbol.alloc_in_text = "0"b;
	     end;
	end;
	if m ^= 0 then
	     call print (m);

/* check for nonstandard constructs */

	if pl1_stat_$check_ansi then do;
	     if s -> symbol.external then
		if index (s -> symbol.token -> token.string, "$") ^= 0 then
		     call print (8);
	     if adam -> symbol.param_desc & s -> symbol.local then
		call print (353);
	end;

/* check for the unaligned and decimal attributes so that the user can be warned of an implementation change for Release 25 */

	if s -> symbol.unaligned & s -> symbol.decimal & ^s -> symbol.temporary then
	     pl1_stat_$unaligned_dec = "1"b;

/* develop the packed bit.	*/

	if (s -> symbol.fixed | s -> symbol.float | s -> symbol.char | s -> symbol.bit | s -> symbol.picture
	     | s -> symbol.ptr) & s -> symbol.unaligned then
	     s -> symbol.packed = "1"b;

/* check the declared precision	*/

	if s -> symbol.fixed | s -> symbol.float then do;
	     if s -> symbol.decimal then
		n = max_p_dec;
	     else if s -> symbol.fixed then
		n = max_p_fix_bin_2;
	     else
		n = max_p_flt_bin_2;

	     if s -> symbol.c_dcl_size > n then do;
		call print (201);
		s -> symbol.c_dcl_size = n;
	     end;					/*
 NOTE: neither of the following 2 tests will ever be true, as a too 
large or too small of scale NEVER occures. Scale is fixed bin (7) and can
never have a too big of number to fit in it.  These tests have
therefore been moved to get_scale(), which is found in
attribute_parse.pl1
RW 89
*/
						/*
*	     if s -> symbol.scale < min_scale then do;
*		call print (222);
*		s -> symbol.scale = min_scale;
*	     end;
*	     if s -> symbol.scale > max_scale then do;
*		call print (222);
*		s -> symbol.scale = max_scale;
*	     end;
*/
	     s -> symbol.precision = "1"b;
	     return;
	end;

/* check the size of areas and strings.	*/

	minimum = 0;
	if s -> symbol.char then
	     maximum = max_char_string;
	else if s -> symbol.bit then
	     maximum = max_bit_string;
	else if s -> symbol.area then do;
	     maximum = max_area_size;
	     minimum = min_area_size;
	end;
	else
	     return;

	d = s -> symbol.dcl_size;
	if d = null then
	     return;				/* should emit error message about incomplete attribute set */
	if d -> node.type ^= token_node then
	     return;
	if d -> token.type ^= dec_integer then
	     return;
	n = token_to_binary (d);

	if n > maximum then do;
	     call print (205);
	     n = maximum;
	end;

	if n < minimum then do;
	     call print (204);
	     n = minimum;
	end;

	s -> symbol.dcl_size = null;
	s -> symbol.c_dcl_size = n;
	return;

check_extent_type:
     procedure ();

	m = 0;
	if s -> symbol.star_extents
	     & ^(adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.return_value) then
	     m = 215;

	if s -> symbol.refer_extents & ^adam -> symbol.based & string (adam -> symbol.storage_class) ^= "0"b then
	     m = 217;

	if s -> symbol.exp_extents & (adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.static) then
	     m = 216;

/* Check to avoid parsing ` dcl x varying; ' without a diagnostic.
	   Since this is called twice, check data type to avoid printing 
	   out error two times */
	if s -> symbol.varying & string (s -> symbol.data_type) ^= "0"b & ^(s -> symbol.bit | s -> symbol.char) then
	     m = 219;

	if m ^= 0 then
	     call print (m);

     end /* check_extent_type */;

/* subroutine to print an error message.	*/

print:
     proc (m);

dcl      m fixed bin (15) parameter;

	call semantic_translator$error (m, s);

     end;

/* subroutine to check string(symbol.attributes) for inconsistency */

inconsistent:
     procedure (bv_attributes) returns (1 aligned like symbol.attributes);

/* parameters */

dcl      1 bv_attributes aligned like symbol.attributes;

/* automatic */

dcl      1 a aligned like symbol.attributes,
         1 b aligned like symbol.attributes;
dcl      i fixed bin;

/* program */

	string (a) = string (bv_attributes);
	string (b) = ""b;

	do i = lbound (incompatable, 1) to hbound (incompatable, 1);
	     if substr (string (a), i, 1) then
		string (b) = string (b) | (string (a) & incompatable (i));
	end;

	return (b);

     end inconsistent;

/* subroutine to evaluate the predicate of a default statement */

evaluate:
     procedure (d, bv_s, bv_adam, e) returns (bit (1) aligned);

/* parameters */

dcl      (d, bv_s, bv_adam, e) ptr parameter;

/* automatic */

dcl      (adam, r, s, t) ptr;
dcl      (i, letterx, n) fixed bin;
dcl      m fixed bin (15);
dcl      c char (1);
dcl      v (2:3) bit (1) aligned;
dcl      ident (2) char (256) varying;
dcl      word char (11);

/* program */

	s = bv_s;
	adam = bv_adam;
	if e = null then
	     go to fail;
	if e -> node.type = token_node then do;
	     word = e -> token.string;
	     letterx = binary (unspec (substr (word, 1, 1)), 9);
	     do i = index_given_letter (letterx) by 1 while (keyword (i) < word);
	     end;
	     if keyword (i) ^= word then
		go to err2;

	     return (substr (string (s -> symbol.attributes), bit_index (i), 1));
	end;

	if e -> node.type = operator_node then do;
	     n = e -> operator.number;
	     if n > 3 | n < 2 then
		go to err1;
	     do i = 2 to n;
		v (i) = evaluate (d, s, adam, (e -> operand (i)));
	     end;
	     if e -> operator.op_code = or_bits then
		return (v (2) | v (3));
	     if e -> operator.op_code = and_bits then
		return (v (2) & v (3));
	     if e -> operator.op_code = not_bits then
		return (^v (2));
	     go to err1;
	end;
	if e -> node.type ^= reference_node then
	     go to err2;
	if e -> reference.symbol -> token.string ^= "range" then
	     go to err2;
	r = e -> reference.offset;
	if r = null then
	     go to err2;
	if r -> node.type ^= list_node then
	     go to err2;
	n = r -> list.number;
	if n > 2 then
	     go to err0;
	if adam -> symbol.param_desc | adam -> symbol.return_value then
	     go to fail;
	if adam -> symbol.constant & ^(s -> symbol.file | s -> symbol.entry) then
	     go to fail;

	do i = 1 to n;
	     if r -> element (i) -> node.type ^= token_node then
		go to err2;
	     ident (i) = r -> element (i) -> token.string;
	end;

	t = s -> symbol.token;

	if n = 1 then do;
	     if t -> token.size < length (ident (1)) then
		go to fail;
	     if ident (1) = "*" then
		go to exit;
	     if substr (t -> token.string, 1, length (ident (1))) ^= ident (1) then
		go to fail;
	     go to exit;
	end;
	else do;
	     if length (ident (1)) ^= 1 then
		go to err0;
	     if length (ident (2)) ^= 1 then
		go to err0;
	     c = t -> token.string;
	     if c < ident (2) | c > ident (1) then
		go to fail;
	     go to exit;
	end;

/* error conditions detected during predicate evaluation. */


err0:
	m = 207;					/* range operand syntax error	*/
	go to print;
err1:
	m = 208;					/* operator is not boolean		*/
	go to print;
err2:
	m = 209;					/* illegal operand in predicate	*/


/* error print and recovery routine */

print:
	call error_$no_text (m, d -> default.source_id, null);
	d -> default.predicate = null;
fail:
	return ("0"b);
exit:
	return ("1"b);

     end evaluate;

system:
     proc;

/* check for nonstandard defaults */

	if pl1_stat_$check_ansi then
	     if (s -> symbol.variable_arg_list & ^s -> symbol.entry) | (s -> symbol.environment & ^s -> symbol.file)
		then
		call print (126);

/* entry defaults	*/

	if s -> symbol.returns | s -> symbol.reducible | s -> symbol.irreducible | s -> symbol.variable_arg_list then
	     s -> symbol.entry = "1"b;

	if s -> symbol.entry then
	     s -> symbol.irreducible = ^s -> symbol.reducible;

/* file defaults	*/

	if string (s -> symbol.file_attributes) then
	     s -> symbol.file = "1"b;

/* arithmetic defaults */

	if ^s -> symbol.constant then do;
	     if string (s -> symbol.data_type) = "0"b then
		s -> symbol.fixed = "1"b;
	     if s -> symbol.fixed | s -> symbol.float then do;

/* arithmetic defaults for variables */

		s -> symbol.binary = ^s -> symbol.decimal;
		s -> symbol.real = ^s -> symbol.complex;
		if s -> symbol.c_dcl_size = 0 then
		     if s -> symbol.fixed then
			if s -> symbol.binary then
			     s -> symbol.c_dcl_size = default_fix_bin_p;
			else
			     s -> symbol.c_dcl_size = default_fix_dec_p;
		     else if s -> symbol.binary then
			s -> symbol.c_dcl_size = default_flt_bin_p;
		     else
			s -> symbol.c_dcl_size = default_flt_dec_p;
	     end;
	     else if (s -> symbol.bit | s -> symbol.char) then do;

/* string defaults for variables */

		s -> symbol.non_varying = ^s -> symbol.varying;
		if s -> symbol.dcl_size = null then
		     if s -> symbol.c_dcl_size = 0 then
			s -> symbol.c_dcl_size = 1;
	     end;
	end;

/* area defaults  */

	if s -> symbol.area then
	     if s -> symbol.dcl_size = null then
		if s -> symbol.c_dcl_size = 0 then
		     s -> symbol.c_dcl_size = default_area_size;

/* scope class defaults	*/

	if s -> symbol.file | s -> symbol.entry then
	     if substr (string (s -> symbol.storage_class), 1, 7) | s -> symbol.member | s -> symbol.aligned
		| s -> symbol.unaligned | s -> symbol.initialed | s -> symbol.return_value then
		s -> symbol.variable = "1"b;

	if ^s -> symbol.variable then
	     if (s -> symbol.entry | s -> symbol.file) then
		s -> symbol.constant = "1"b;

	if s -> symbol.condition then
	     s -> symbol.external, s -> symbol.auto = "1"b;

	s -> symbol.variable =
	     ^s -> symbol.constant & ^(s -> symbol.builtin | s -> symbol.condition | s -> symbol.generic);

	if ((s -> symbol.file | s -> symbol.entry) & s -> symbol.constant & ^s -> symbol.internal) then
	     s -> symbol.external = "1"b;

	s -> symbol.internal = ^s -> symbol.external;

	if s -> symbol.variable & s -> symbol.external & ^s -> symbol.controlled then
	     s -> symbol.static = "1"b;

	if ^(s -> symbol.builtin | s -> symbol.condition | s -> symbol.generic | s -> symbol.member) then
	     if string (s -> symbol.storage_class) = "0"b then
		s -> symbol.auto = "1"b;

/* storage alignment and packing defaults */

	if (s -> symbol.char | s -> symbol.bit | s -> symbol.picture | s -> symbol.structure)
	     & ^(s -> symbol.aligned | s -> symbol.varying) then
	     s -> symbol.unaligned = "1"b;

	s -> symbol.aligned = ^s -> symbol.unaligned;

	if (s -> symbol.fixed | s -> symbol.float) & ^(s -> symbol.signed | s -> symbol.unsigned | s -> symbol.constant)
	     then
	     s -> symbol.signed = "1"b;

     end system;

/* include files */

%include semant;
%include default;
%include symbol;
%include symbol_bits;
%include reference;
%include operator;
%include token;
%include token_types;
%include list;
%include block;
%include op_codes;
%include nodes;
%include system;
%include pl1_attribute_table;
%include declare_type;
     end;




		    constant_token.pl1              04/24/92  1201.8r w 04/24/92  1041.3       59607



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-01-26,RWaters), approve(88-01-26,MCR7724), audit(88-02-05,Huen),
     install(88-02-16,MR12.2-1024):
     Expand the uses of options (constant) variables.
  2) change(91-01-18,Blackmore), approve(91-01-18,MCR8234),
     audit(91-12-05,Huen), install(92-04-24,MR12.5-1011):
     Add 'token_lookup' procedure to allow scoping rules to be followed during
     resolution of references to constant values.
                                                   END HISTORY COMMENTS */

constant_token:
	proc (blk_ptr, token_ptr, type_mask, desired_type) returns (bit (9));

dcl (blk_ptr, token_ptr) pointer parameter;
dcl desired_type bit (9) aligned parameter;
dcl type_mask bit (9) aligned parameter;

/* This routine is passed a pointer to a token, a mask to check token types
   against a desired token type, and a desired token type.

   It will check the current token, to see if it is a symbol which is
   static options (constant) initial (...), of a type which is acceptable
   through the mask.  If so, it will change the token pointer to point to
   the token for the constant which initializes this variable, and will
   return the token type of the constant.  This essentially replaces
   constants for use in areas where a variable of any type will be seen
   as a syntax error, even though use of a constant would be wonderful for
   producing understandable and taylorable code. */

/* Modified: Jan 28,88 by RW to fix 1994 and 2186. */

%page;
%include block;
%page;
%include cross_reference;
%include list;
%include nodes;
%page;
%include symbol;
%page;
%include token;
%include token_list;
%page;
%include token_types;
%page;
dcl 1 t like token based (token_ptr);

dcl d ptr;
dcl symp ptr;
dcl 1 sym like symbol based (symp);

declare   pl1_stat_$table bit (1) aligned external static;

dcl (null, string) builtin;

/* If it is a symbol which is
   static options (constant) initialized (), then we will return, not the
   pointer to its token, but the pointer to the initializing token which
   defines its value.  We will also cross-reference this reference, since
   we will no longer see the real token, only its value. */

	     symp = token_lookup (blk_ptr, token_ptr);
	     if symp = null () then return (t.type);
	     if  sym.node_type ^= symbol_node then
		return (t.type);

/* It is a symbol, determine if it is allocated in text, initialed, fixed and
   static. */

	     if sym.initial ^= null () & ^sym.dimensioned then
		if sym.initialed & sym.alloc_in_text & sym.static &
		sym.initial -> list.number = 3
		then do;	/* no expression */
		     if sym.initial -> list.element (3) ^= null () then return (t.type);
		     if (type_mask & sym.initial -> list.element (2) -> t.type) ^= 
			(type_mask & desired_type) then return (t.type);

/* decimal integer token, update the token pointer. */

		     token_ptr = sym.initial -> list.element (2);

/* re-use constant token.  We will now cross-reference this variable, since
   it now disappears from the view of the parser. */

		     d = create_cross_reference ();
		     d -> cross_reference.next = sym.cross_references;
		     sym.cross_references = d;
		     string (d -> cross_reference.source_id)
			= string (pl1_stat_$statement_id);
		     if pl1_stat_$table then
			sym.allocate, sym.put_in_symtab = "1"b; /* to find it later */
		end;
		return (t.type);
%page;
token_lookup: proc (blk, t_ptr) returns (ptr);
/* Return a pointer to the symbol (or label) represented by the token referred
   to by t_ptr, in the scope of the block pointed to by 'blk'. */

dcl  (blk, t_ptr, sym_ptr, partial_ptr, b) ptr;
dcl  num_partials	        fixed bin (15);

/* search for an applicable declaration symbol for which this is a fully
   qualified reference.  Remember any applicable declaration for which this is
   a partially qualified reference.  If two or more applicable declarations can
   be found and this is not a fully qualified reference to any of them, this is
   an ambiguous reference.  If only one applicable declaration can be found,
   this is a valid partially qualified reference to that declaration.
   The search for an applicable declaration begins in the current block and
   continues outward until the first applicable declaration is found.
   After the first applicable declaration is found, all additional searching is
   confined to the block in which the first applicable declaration was found. */

    num_partials = 0;
    partial_ptr = null;

    b = blk;
    do while (b ^= null);				/* While more blocks to search. */

      sym_ptr = t_ptr -> token.declaration;
      do while (sym_ptr ^= null);			/* While more symbols to look at. */

        if sym_ptr -> symbol.block_node = b then
	do;					/* In proper scope. */
	if (sym_ptr -> node.type = label_node)            /* If we have a label or fully qualified */
	     | ^(sym_ptr -> symbol.member) then return(sym_ptr);/* symbol, then we're successful. */
	num_partials = num_partials + 1;		/* Otherwise reference is partially qualified. */
	partial_ptr = sym_ptr;
        end;					/* End: In proper scope. */

        sym_ptr = sym_ptr -> symbol.multi_use;
      end;					/* End: While more symbols to look at. */

      if num_partials > 0 then b = null; else b = b -> block.father;
    end;						/* End: While more blocks to search. */

/* Here we either have a partially qualified reference, or no reference. */
    if num_partials > 1 then partial_ptr = null;            /* Ambiguous reference */
    return (partial_ptr);

  end token_lookup;
%page;
defer_constant_token_list:
	entry (blk_ptr, index, stop_type);

/* accept a list of tokens and defer all indentifiers which represent a
   static options (constant) to refer to the actual constant token, rather
   than the variable. */

dcl index fixed bin parameter;
dcl stop_type bit (9) aligned parameter;

dcl k fixed bin;
dcl dummy_type bit (9) aligned;

	k = index;
	do while (t_table.type ^= semi_colon & t_table.type^=stop_type);
	     if (t_table.type & is_identifier) = identifier then
		dummy_type = constant_token (blk_ptr, token_list (k), is_constant, dec_integer);
	     if (t_table.type & is_delimiter) ^= is_delimiter &
		(token_list (k+1) -> t_table.type & is_identifier) =
		identifier then return;
	     k = k + 1;
	end;
	return;
%page;
%include language_utility;
	end constant_token;


*/
                                          -----------------------------------------------------------


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

*/
