



		    adjust_ref_count.pl1            10/03/83  1730.5rew 10/03/83  1007.8       26298



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


/* This procedure is called to adjust the reference count of a node up or down.
   It also adjusts the reference counts of any length, qualifier, or offset expressions.

   Initial Version: 29 January 1972 by BLW
	Modified:	12 February 1973 by RAB to conform to reference_count design
	Modified:	9 March 1977 by RAB to change mod_word handling
	Modified:	9 April 1977 by RAB to remove mod_word operator	*/

adjust_ref_count: proc(pt,delta);

dcl	pt ptr,		/* points at a reference node */
	delta fixed bin;	/* amount of change */

dcl	(p,q) ptr,
	n fixed bin,
	stack_temp$free_temp entry(ptr),
	(null,substr) builtin;

dcl	cg_stat$cur_statement ptr ext;
dcl	error entry(fixed bin,ptr,ptr);

%include reference;
%include operator;
%include nodes;
%include temporary;

	p = pt;
	n = delta;

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

	if ^ p -> reference.shared 
	then do;
		p -> reference.ref_count = p -> reference.ref_count + n;

		if p -> reference.hit_zero
		     then do;
			call error(313,cg_stat$cur_statement,p);
			return;
			end;

		if p -> reference.ref_count = 0
		     then do;
			if p -> reference.symbol ^= null
			     then p -> reference.hit_zero = "1"b;
			end;
		     else if p -> reference.ref_count < 0
			then if p -> reference.symbol ^= null
			     then do;
				call error(316,cg_stat$cur_statement,p);
				return;
			          end;
			     else;
			else return;
	     end;
	else return;

	q = p -> reference.length;
	if q ^= null
	then do;
	     if q -> node.type = operator_node then q = q -> operand(1);

	     if ^ q -> reference.shared then call adjust_ref_count(q,-1);
	     end;

	q = p -> reference.qualifier;
	if q ^= null
	then do;
	     if q -> node.type = temporary_node
	     then call check_temp;
	     else do;
		if q -> node.type = operator_node
		     then q = q -> operand(1);
		if ^q -> reference.shared
		     then call adjust_ref_count(q,-1);
		end;
	     end;

	q = p -> reference.offset;
	if q = null then return;

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

	if ^ q -> reference.shared then call adjust_ref_count(q,-1);
	return;


check_temp:	proc;

	     p -> reference.qualifier -> temporary.ref_count
	       = p -> reference.qualifier -> temporary.ref_count - 1;
	     if p -> reference.qualifier -> temporary.ref_count > 0
		then p -> reference.qualifier = null;
		else call stack_temp$free_temp(p);

	     end;

	end;




		    aq_man.pl1                      10/03/83  1730.5rew 10/03/83  1007.8      122508



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


/* procedure to manage aq register for pl/1

   Initial Version:  4 September 1971 by BLW for Version II
	Modified:  2 October 1972 by BLW	
	Modified:	11 June 1973 by RAB for aq_man$load_any ... 
	Modified:	19 March 1977 by RAB for aq_man$left_shift
		and aq_man$right_shift
	Modified:	4 September 1977 by RAB to fix 1666
	Modified:	10 November 1977 by RAB to prevent trimming when amt is bits_per_two_words	*/

/*	These are the meanings of some important fields in the a_reg:

	a_reg.size	the size of the datum in the register without
			pad bits

	a_reg.offset	the offset of the leftmost bit of the datum
			from the left of the register

	a_reg.length	the sum of a_reg.offset + a_reg.size + any known
			zero_bits of padding immediately to the right of
			the datum.  (Anything beyond a_reg.length in the
			register is unknown.)		*/

aq_man$pad_aq: proc(type,size);

dcl	type fixed bin,	/* bit_string or char_string */
	size fixed bin;	/* size to pad to, in bits */

dcl	(cg_stat$double_temp,cg_stat$text_base) ptr ext,
	cg_stat$text_pos fixed bin ext;

dcl	(i,j,k,n) fixed bin,
	arith bit(1),
	macro fixed bin(15),
	p ptr;

dcl	word bit(36) aligned based;

dcl	expmac entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15)),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	xr_man$load_const entry(fixed bin,fixed bin),
	aq_man$check_strings entry(fixed bin),
	aq_man$clear_q entry,
	c_a entry(fixed bin,fixed bin) returns(ptr),
	copy_temp entry(ptr) returns(ptr);

dcl	(abs,addrel,bit,fixed,lbound,min,null,string,substr) builtin;

dcl (	anaq		init(42),
	oraq		init(48),
	rfb1_to_rfb2	init(88),
	truncate(2)	init(520,521),
	q_left_shift(2)	init(515,63),	/* qls, lls */
	left_shift(2)	init(134,63),	/* als, lls */
	right_shift(2)	init(245,62),	/* arl, lrl */
	stfx1		init(15),
	sta		init(4)) fixed bin(15) int static options(constant);

%include cgsystem;
%include cg_reference;
%include symbol;
%include data_types;
%include machine_state;
%include bases;
%include boundary;

	if size <= a_reg.size then return;

	if a_reg.length < size
	then do;
	     call expmac((anaq),c_a((a_reg.size),5));
	     a_reg.length = bits_per_two_words;
	     end;

	if type = bit_string then a_reg.size = a_reg.length;
	else do;
	     call expmac((oraq),c_a((a_reg.size),6));
	     if size < bits_per_two_words then call expmac((anaq),c_a(size,5));
	     a_reg.size = size;
	     end;

	return;

aq_man$save_aq: entry(pt,pad);

dcl	pt ptr,		/* points at reference node of value in aq */
	pad fixed bin;	/* ^= 0 means clear_q when storing */

	p = pt;

	k = p -> reference.data_type;
	if k <= real_flt_bin_2
	then do;
	     arith = "1"b;
	     macro = stfx1 - 1 + k;
	     goto store;
	     end;

	arith = "0"b;

	if a_reg.size <= bits_per_word
	then if pad = 0 then k = 0;
	     else do;
		k = 1;
		call aq_man$clear_q;
		end;
	else do;
	     if a_reg.length < bits_per_two_words then call expmac((anaq),c_a((a_reg.size),5));
	     k = 2;
	     end;

store:	if p -> reference.temp_ref
	then do;
	     if p -> reference.shared
	     then do;
		p, pt = copy_temp(p);
		p -> reference.ref_count = 2;
		end;
	     else p -> reference.ref_count = p -> reference.ref_count + 1;

	     if arith then call expmac(macro,p); else call expmac$one((sta),p,k);
	     end;

	else do;
	     if arith
		then call expmac(macro,cg_stat$double_temp);
		else call expmac$one((sta),cg_stat$double_temp,k);

	     string(p -> reference.address) = string(cg_stat$double_temp -> reference.address);
	     p -> reference.relocation = cg_stat$double_temp -> reference.relocation;
	     p -> reference.perm_address = "1"b;
	     p -> reference.even = "1"b;
	     end;

	p -> reference.value_in.storage = "1"b;
	return;

aq_man$clear_q: entry;

	k = bits_per_word;
	goto trim;

aq_man$trim_aq: entry(n_bits);

dcl	n_bits fixed bin;

	k = n_bits;
	call aq_man$check_strings(k);

	/* check to see if last instruction was also a trimming instruction */

trim:	p = addrel(cg_stat$text_base,cg_stat$text_pos - 1);

	if (p -> word & "111000000000000000111111111111111111"b)
		   ^= "000000000000000000011111111001000000"b		/* anaq ap|0 */
	then goto gen;

	if fixed(substr(p -> word,4,15),15) <= bits_per_four_words
	then do;
	     substr(p -> word,4,15) = bit(fixed(2*k,15),15);
	     goto len;
	     end;

gen:	if k < bits_per_two_words
	     then call expmac((anaq),c_a(k,5));
	a_reg.length = bits_per_two_words;

len:	a_reg.size = k - a_reg.offset;
	return;

aq_man$check_strings: entry(n_bits);

	/* check to make sure that no bits will get lost from any string
	   currently held in a register.  If bits will be lost, value must
	   be saved if not already in storage */

	n = a_reg.number;
	do i = 1 by 1 while(i <= n);
check:	     p = a_reg.variable(i);

	     if p -> reference.data_type >= lbound(convert_size,1)
		then j = p -> reference.c_length * convert_size(p -> reference.data_type);
		else j = p -> reference.c_length;

	     if n_bits - a_reg.offset < j
	     then do;
		if ^ p -> reference.temp_ref then goto drop;
		if p -> reference.value_in.storage then goto drop;
		if p -> reference.ref_count < 1 then goto drop;

		/* have to save value */

		p -> reference.store_ins = bit(cg_stat$text_pos,18);
		p -> reference.ref_count = p -> reference.ref_count + 1;

		call expmac$one((sta),p,fixed(j > bits_per_word,1));

		p -> reference.value_in.storage = "1"b;

drop:		p -> reference.value_in.a = "0"b;

		n = n - 1;
		a_reg.number = n;
		if n < i then return;

		do j = i to n;
		     a_reg.variable(j) = a_reg.variable(j+1);
		     end;

		goto check;
		end;
	     end;

	return;


aq_man$left_shift: entry(amt,long);

dcl	amt fixed bin(8),		/* amount to shift */
	long bit(1) aligned;	/* forces long shift */

dcl	nregs fixed bin;		/* number of registers involved */
dcl	amount fixed bin;		/* amount to shift */

	amount = amt;

	if long | a_reg.size + a_reg.offset > bits_per_word
	     then nregs = 2;
	     else nregs = 1;

	call expmac(left_shift(nregs), c_a(amount,1));

	a_reg.offset = a_reg.offset - amount;
	if a_reg.length < bits_per_words(nregs)
	     then a_reg.length = a_reg.length - amount;
	     else a_reg.length = bits_per_words(nregs);

	return;


aq_man$right_shift: entry(amt,long);

	amount = amt;

	if long | a_reg.size + a_reg.offset + amount > bits_per_word
	     then nregs = 2;
	     else nregs = 1;

	call expmac(right_shift(nregs), c_a(amount,1));

	a_reg.offset = a_reg.offset + amount;
	a_reg.length = min(a_reg.length + amount, bits_per_words(nregs));
	return;


aq_man$fix_scale: entry(pt,scale1,type1);

dcl	(scale1,type1) fixed bin;
dcl	ptype fixed bin;

	ptype = pt -> reference.data_type;
	n = scale1 - pt -> reference.symbol -> symbol.scale;
	if n = 0
	then do;
	     if type1 > ptype
		then call expmac$zero((rfb1_to_rfb2));
	     return;
	     end;

	if type1 > ptype
	then do;
	     if n > bits_per_word
	     then do;
		macro = q_left_shift(2);
		goto shift;
		end;

	     call expmac((q_left_shift(2)),c_a((bits_per_word),1));
	     n = n - bits_per_word;

	     if n = 0 then return;

	     k = 2;
	     end;

	else k = ptype;

	if n < 0
	then do;
	     call xr_man$load_const(abs(n),2);
	     call expmac$zero((truncate(k)));
	     end;

	else do;
	     macro = q_left_shift(k);
shift:	     call expmac(macro,c_a(n,1));
	     end;

	return;

/* The following section is called to load string offsets and string lengths into the a or q
   for use by EIS instructions. */

/* Load variable offset or length into a or q */

aq_man$load_any_var:	entry(pt,ar,base_offset);

dcl	ar fixed bin(2),		/* specifies reg to be loaded */
	base_offset fixed bin(24);	/* base offset to add to pt */

dcl	1 machine_overlay based(m_s_p),
	2 node_type bit(9),
	2 indicators fixed bin,
	2 next,
	2 aq_regs(2) like machine_state.a_reg;

dcl	c fixed bin(24);
dcl	l fixed bin;
dcl	lock bit(1) aligned;
dcl	cg_stat$cur_statement ptr ext static;

dcl (	load_aq(2)	init(1,7),	/* lda, ldq */
	add_aq(2)		init(645,19),	/* ada, adq */
	right_shift_aq(2)	init(725,514))	/* ars, qrs */
		fixed bin(15) int static options(constant);

dcl	adjust_ref_count entry(ptr,fixed bin);
dcl	generate_constant$real_fix_bin_1 entry(fixed bin(24)) returns(ptr);
dcl	get_single_ref entry(ptr) returns(ptr);
dcl	base_man$load_any_var_and_lock entry(fixed bin,ptr,bit(3) aligned);
dcl	base_man$unlock entry (fixed bin);
dcl	xr_man$load_any_var_and_lock entry(ptr,fixed bin(3),fixed bin(18));
dcl	error entry(fixed bin,ptr,ptr);

	lock = "0"b;
	p = pt;
	c = base_offset;

search:	j = -1;
	do i = 1 to 2;
		do l = 1 to aq_regs(i).number;
		     if aq_regs(i).variable(l) = p
		     then do;
			j = i;
			if aq_regs(i).constant = c
			then do;
			     if ^ p -> reference.shared
				then call adjust_ref_count(p,-1);
			     go to return_i;
			     end;
			end;
		end;
	end;

	i = get_free_aq();
	if i ^= 0
	     then call load_aq_var;

return_i:	ar = i;
	if lock
	then do;
	     aq_regs(i).locked = "1"b;
	     aq_regs(i).number_h_o = 0;
	     end;
	return;

/* Load constant offset or length into a or q */

aq_man$load_any_const:	entry(base_offset,ar);

	lock = "0"b;
	p = generate_constant$real_fix_bin_1(base_offset);
	c = 0;
	go to search;

aq_man$lock:	entry(pt,ar);

	i = ar;

	if pt ^= null & (^ aq_regs(i).locked | aq_regs(i).number_h_o ^= 0)
	then do;
	     j, aq_regs(i).number_h_o = aq_regs(i).number_h_o + 1;
	     aq_regs(i).has_offset(j) = pt;
	     end;
	else aq_regs(i).number_h_o = 0;

	aq_regs(i).locked = "1"b;

	return;

/* Load variable offset or length into a or q and lock */

aq_man$load_any_var_and_lock:	entry(pt,ar);

	lock = "1"b;
	p = pt;
	c = 0;
	go to search;

/* Load item into specified register */

aq_man$load_var:	entry(pt,ar);

	p = pt;
	i = ar;

	if substr(string(p -> reference.value_in),i,1)
	then do;
	     if ^ p -> reference.shared
		then call adjust_ref_count(p,-1);
	     return;
	     end;

	j = -1;
	c = 0;
	call load_aq_var;
	return;

/* Find a register in which to load the reference */

get_free_aq:	proc() returns(fixed bin);

dcl	(i,k,count(2)) fixed bin;
dcl	q ptr;
dcl	base bit(3) aligned;
dcl	xr fixed bin(3);
dcl	tag bit(6) aligned;

	if aq_regs(1).locked
	then if aq_regs(2).locked
	     then do;

		do i = 1 to 2;
		if aq_regs(i).number_h_o ^= 0
		then do;
		     if aq_regs(i).constant = 0 & aq_regs(i).number ^= 0 & ^ aq_regs(i).has_offset(1) -> reference.big_offset
		     then do;
			q = aq_regs(i).variable(1);

			if ^ q -> reference.shared
			then q -> reference.ref_count = q -> reference.ref_count + 1;

			call xr_man$load_any_var_and_lock(q,xr,0);

			tag = "001"b || bit(xr,3);

			do k = 1 to aq_regs(i).number_h_o;
			aq_regs(i).has_offset(k) -> address.tag = tag;
			end;

		     end;

		     else do k = 1 to aq_regs(i).number_h_o;
			q = aq_regs(i).has_offset(k);

			if k < aq_regs(i).number_h_o | q -> reference.c_f_offset = 0
			then q -> reference.perm_address = "1"b;
			else do;
			     aq_regs(i).locked = "0"b;
			     aq_regs(i).number_h_o = 0;
			     end;


			if q -> reference.ext_base
			then if q -> address.base ^= sp
			     then call base_man$unlock(which_base(fixed(q -> address.base,3)));

			if ^q -> reference.shared
			then q -> reference.ref_count = q -> reference.ref_count + 1;

			call base_man$load_any_var_and_lock(2,q,base);

			end;

		     aq_regs(i).locked = "0"b;
		     aq_regs(i).number_h_o = 0;
		     return(i);
		     end;
		end;

		call error(329,cg_stat$cur_statement,p);
		lock = "0"b;
		return(0);
		end;
	     else return(2);
	else if aq_regs(2).locked
	     then return(1);

	if j > 0 then return(j);

	do i = 1 to 2;
	     if aq_regs(i).number = 0
		then return(i);
	end;

	do i = 1 to 2;
	     count(i) = 0;
	     do k = 1 to aq_regs(i).number;
		count(i) = count(i) + aq_regs(i).variable(k) -> reference.ref_count;
	     end;
	end;

	if count(1) < count(2)
	then return(1);
	else if count(2) < count(1)
	     then return(2);

	if aq_regs(1).changed < aq_regs(2).changed
	     then return(1);
	     else return(2);
end;


/* Load the specified register */

load_aq_var:	proc();

dcl	(cp,q) ptr;
dcl	c1 fixed bin(24);

	q = p;
	c1 = c;

	if p -> reference.data_type = real_fix_bin_2
	     then q = get_single_ref(p);

	if j = i
	then do;
	     c1 = c - aq_regs(i).constant;
	     if ^ q -> reference.shared
		then call adjust_ref_count(q,-1);
	     end;

	else do;
	     if q -> reference.temp_ref
	     then if ^ q -> reference.value_in.storage
		then if q -> reference.value_in.q
		     then call aq_man$save_aq(q,0);

	     call expmac((load_aq(i)),q);

	     if ^ q -> reference.aligned_ref
	     then if q -> reference.units = word_ & q -> reference.c_length = bits_per_half
		then call expmac(right_shift_aq(i),c_a((bits_per_half),1));
		else call error(367,cg_stat$cur_statement,q);
	     end;

	if c1 ^= 0
	then do;
	     if c1 > 0 & c1 < 262144
	     then cp = c_a((c1),2);
	     else cp = generate_constant$real_fix_bin_1(c1);
	     call expmac((add_aq(i)),cp);
	     end;

	if i = 1
	     then aq_regs(1).offset, aq_regs(1).size = 0;
	aq_regs(i).constant = c;
	aq_regs(i).number = 1;
	aq_regs(i).variable(1) = p;
	if c = 0
	     then substr(string(p -> reference.value_in),i,1) = "1"b;
end;

end;




		    arith_data.alm                  10/03/83  1730.5rew 10/03/83  1007.8        9945



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

" data segment for arithmetic code generator, BLW, 18 November 1968
" Modified: 1 July 1971 by BLW for Version II
"
	name	arith_data
	segdef	fixed
"
fixed:	dec	19,0,0	add  s s	adfx1
	dec	21,1,0	add  s d	adfx3
	dec	21,0,0	add  d s	adfx3
	dec	20,0,0	add  d d	adfx2
"
	dec	22,0,0	sub  s s	sbfx1
	dec	21,1,1	sub  s d	adfx3
	dec	24,0,1	sub  d s	sbfx3
	dec	23,0,0	sub  d d	sbfx2
"
	dec	25,0,0	mult s s 	mpfx1
	dec	258,0,0	mult s d	mpfx2
	dec	258,1,0	mult d s	mpfx2
	dec	259,0,0	mult d d	mpfx3
"
	dec	260,0,0	div  s s	dvfx1
	dec	262,0,0	div  s d	dvfx3
	dec	261,0,0	div  d s	dvfx2
	dec	262,0,0	div  d d	dvfx3
"
	end




		    arith_op.pl1                    10/03/83  1730.5rew 10/03/83  1007.8      105885



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


/* this procedure compiles arithmetic expressions

   Initial Version:  5 October, 1968 by BLW
	Modified: 24 May, 1971 by BLW for Version II 
	Modified: 21 January, 1973 by BLW
	Modified:	8 November 1973 by RAB for fixed divide
	Modified:	16 September 1974 by RAB for bug 1230 (float divide)
	Modified:	24 September 1975 by RAB for bug 1424
	Modified:	29 October 1975 by RAB to check p3 in q	
	Modified: 2 April 1976 by RHS to improve code for constant*2
	Modified:	9 March 1978 by RAB to check p3 in q for floating divide	*/

arith_op:	proc(node_pts,refs,atom);

dcl	node_pts	ptr,		/* points at operator node */
	refs(3)	ptr,		/* ptrs to ref nodes of operands */
	atom(3)	bit(1) aligned;	/* ON is operand is atomic */

dcl	node_pt	ptr defined(node_pts),
	ref(3)	ptr defined(refs);

dcl	(p,p1,p2,p3,q2,q3) ptr,
	complex_stuff$complex_stuff fixed bin ext,
	based_int fixed bin(18) based,
	(type1,type2,type3,scale1,scale2,scale3,op,k,rev,comp,max_type,op_code,n) fixed bin(15),
	shift fixed bin,
	(check_scale,check_type,mult_scaled,reversed) bit(1) aligned,
	negate_op(4) fixed bin(15) int static initial(255,38,39,39),
	load entry(ptr,fixed bin(15)),
	power_of_two entry(fixed bin(18)) returns(fixed bin(18)),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	expmac$interpret entry(fixed bin,ptr,(3) ptr,(3) bit(1) aligned),
	expmac entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15)),
	expmac$abs entry(ptr,fixed bin),
	compile_exp entry(ptr),
	(compile_exp$save,compile_exp$save_exp,compile_exp$save_float_2,copy_temp) entry(ptr) returns(ptr);

dcl	(fixed_to_float,float_to_fixed) entry(ptr),
	compile_exp$save_fix_scaled entry(ptr,fixed bin(15),fixed bin(15)) returns(ptr),
	aq_man$fix_scale entry(ptr,fixed bin(15),fixed bin(15));

dcl	divide_fx1 init(535) fixed bin(15) int static;

dcl	(addr,fixed,max,mod) builtin;

dcl	1 arith_data$fixed(3) ext static,
	2 left_type(2),
	3 right_type(2),
	4 body		fixed bin(15),
	4 rev		fixed bin(15),
	4 comp		fixed bin(15),

	1 fix_info	based(p),
	2 body		fixed bin(15),
	2 rev		fixed bin(15),
	2 comp		fixed bin(15);

dcl (	add_op		init(1),
	sub_op		init(2),
	mult_op		init(3),
	div_op		init(4)) fixed bin int static;


%include reference;
%include operator;
%include symbol;
%include data_types;
%include op_codes;
%include "645op2";
%include "645op3";

dcl (	fx1_to_fl2	init(122),
	fl2_to_fx2	init(125)) fixed bin(15) int static;


begin:	p1 = ref(1);

	reversed,
	mult_scaled,
	check_type,
	check_scale = "0"b;

	p2 = ref(2);

	p = node_pt;
	q2 = p -> operand(2);

	if p1 -> reference.symbol -> symbol.complex
	then do;
	     call expmac$interpret(complex_stuff$complex_stuff,node_pt,refs,atom);
	     return;
	     end;

	type1 = p1 -> reference.data_type;
	type2 = p2 -> reference.data_type;

	/* check for special attention */

	if p -> operator.op_code = negate then goto neg_op;

	p3 = ref(3);
	q3 = p -> operand(3);

	op_code = fixed(p -> operator.op_code,9) - 16;

	type3 = p3 -> reference.data_type;

	/* if p3 is in q, try to flip_rands */

	if p3 -> reference.value_in.q
	then if atom(2)
	then if op_code ^= sub_op
	then if op_code ^= div_op
	then if atom(3)
	then do;
	     call flip_rands;
	     reversed = "0"b;
	     end;

	/* get information for this combination of operator
	   and data types */

	if type1 >= real_flt_bin_1
	then do;

	     /* have floating point operation, we use the
	        manner in which macro values are coded to
	        calculate the appropriate macro to use */

	     max_type = type1;
	     rev, comp = 0;
	     op = adfl1 + 2 * op_code - real_flt_bin_1 - 2;

	     if op_code = 4
	     then do;

		/* have floating divide, must avoid FDV & FDI
		   instructions for double precision result
		   (fixes bug 1230) */

		if type1 > type2
		then do;
		     atom(2) = "0"b;
		     check_type = "1"b;
		     end;

		if type1 > type3
		then do;
		     atom(3) = "0"b;
		     check_type = "1"b;
		     end;

		/* if p3 is in q, try to flip rands and use inverted divide */

		if p3 -> reference.value_in.q & atom(2) & atom(3)
		then do;
		     call flip_rands;
		     op = op + 2;
		     end;
		end;
	     end;
	else do;

	     /* have fixed point operation; all division (except
	        for fx1/fx1) is handled by external
	        operator */

	     scale1 = p1 -> reference.symbol -> symbol.scale;
	     scale2 = p2 -> reference.symbol -> symbol.scale;
	     scale3 = p3 -> reference.symbol -> symbol.scale;

	     if op_code ^= div_op then goto normal;

	     if scale1 ^= 0 then goto punt;
	     if scale2 ^= 0 then goto punt;
	     if scale3 ^= 0 then goto punt;


	     if max(type1,type2,type3) = real_fix_bin_1
	     then do;
		k = type2;
		goto gi;
		end;

punt:	     if ^ atom(3) then p3 = compile_exp$save(q3);
	     if atom(2) then call load(p2,0); else call compile_exp(q2);
	     op = divide_fx1 + 2*type2 + type3 - 3;
	     shift = scale1 - (scale2 - scale3);
	     call expmac(op,p3);
	     call expmac$abs(addr(shift),1);
	     return;

normal:	     if op_code = mult_op 
	     then do;
		k = type2;
		if scale1 ^= scale2 + scale3
		     then mult_scaled = "1"b;
		end;

	     else do;
		max_type = max(type2,type3);
		if max_type = real_fix_bin_1 & type1 = real_fix_bin_2
		then k = real_fix_bin_2; else k = type2;

		if scale1 ^= scale2
		then do;
		     atom(2) = "0"b;
		     check_scale = "1"b;
		     end;

		if scale1 ^= scale3
		then do;
		     atom(3) = "0"b;
		     check_scale = "1"b;
		     end;

		end;

gi:	     call get_information;
	     end;

	/* dispatch on form of operands */

	goto arith_switch(fixed(atom(2) || atom(3),2));

	/* both operands are atomic.  check to see if body of
	   operation takes left operand instead of right */

arith_switch(3):
atm_atm:	if rev > 0
	then do;
faa:	     call flip_rands;
	     goto aa_2;
	     end;

	if op_code = mult_op
	then if type1 = real_fix_bin_1
	     then if p2 -> reference.symbol -> symbol.constant
		then if ^p3->reference.symbol->symbol.constant
		     then goto faa;
		     else if power_of_two(p2->reference.symbol->symbol.initial->based_int) ^= 0
			then goto faa;

	/* expand load(p2) and body(p3) */

aa_2:	call load(p2,comp);

aa_3:	if op_code <= sub_op
	then do;
	     if check_scale
		then max_type = max(type2,type3);

	     if max_type < type1
		then call expmac$zero(rfb1_to_rfb2);
	     end;

	if type1 >= real_flt_bin_1 then op = op + type3;
aa_4:	call expmac(op,p3);

	if mult_scaled
	then do;
	     p1 -> reference.symbol -> symbol.scale = scale2 + scale3;
	     call aq_man$fix_scale(p1,scale1,type1);
	     p1 -> reference.symbol -> symbol.scale = scale1;
	     end;

	return;

	/* expressions on both sides, the case real_fix_bin_1 - real_fix_bin_2
	   is given special treatment */

arith_switch(0):
exp_exp:	if op_code ^= sub_op then goto ee_0;

	if type1 >= real_flt_bin_1 then goto ee_0;

	if type2 < type3 & ^ check_scale
	then do;
	     p2 = compile_exp$save(q2);
	     call compile_exp(q3);
	     call expmac$zero(negl);
	     call expmac(adfx3,p2);
	     return;
	     end;

	/* both operands are expressions, evaluate right expression
	   and store in a temporary, then treat like exp_atm case */

ee_0:	if rev > 0 then call flip_rands;

	if check_scale & scale1 ^= scale3
	then do;
	     p3 = compile_exp$save_fix_scaled(q3,scale1,type1);
	     type3 = type1;
	     call get_info;
	     if reversed
	     then if rev = 0
		then do;
		     call flip_rands;
		     go to atm_exp;
		     end;
	     end;
	else if check_type & type1 > type3
	     then do;
		p3 = compile_exp$save_float_2(q3);
		type3 = type1;
		end;
	     else p3 = compile_exp$save(q3);

	goto ea_0;

	/* left operand is atomic, right is an expression. */

arith_switch(2):
atm_exp:	goto ae_switch(op_code);

	/* operation is addtion */

ae_switch(1):
ae_add:	call flip_rands;
	goto ea_0;

	/* operation is multiplication */

ae_switch(3):
ae_mpy:	if type2 = real_fix_bin_1
	then if type3 = real_fix_bin_2
	     then rev = 1; else;
	else if type2 = real_fix_bin_2
	     then if type3 = real_fix_bin_1
		then rev = 0;

	goto ae_gen;

	/* operation is subtraction, evaluate expression and
	   save if fixed single */

ae_switch(2):
ae_sub:	if type3 = real_fix_bin_1
	then do;
ae_sub_1:	     if check_scale & scale1 ^= scale3
	     then do;
		p3 = compile_exp$save_fix_scaled(q3,scale1,type1);
		type3 = type1;
		call get_info;
		end;
	     else p3 = compile_exp$save(q3);

	     goto aa_2;
	     end;

	call compile_exp(q3);

	if check_scale & scale1 ^= scale3
	then do;
	     call aq_man$fix_scale(p3,scale1,type1);
	     type3 = type1;
	     call get_info;
	     end;

	k = 1 - mod(type2,2);
	if type3 >= real_flt_bin_1
	then op = adfl1 + k;
	else op = adfx3 - k;

	/* we use the fact that:
	     real_fix_bin_2 = real_fix_bin_1+1
	     real_flt_bin_2 = real_flt_bin_1+1
	   and the fact that:
	     mod(real_fix_bin_1,2) = mod(real_fix_bin_2,2) = 1;

	   Thus we generate op for single precision atom,
	   and op+|-1 for double precision atom      */

	call expmac$zero(negate_op(type3));
	call expmac(op,p2);
	return;

	/* operation is division.  evaluate expression and
	   save if fixed point or use inverse divide if floating */

ae_switch(4):
ae_div:	if type1 <= real_fix_bin_2
	then do;
	     p3 = compile_exp$save(q3);
	     goto aa_2;
	     end;

	op = op+2;

	/* for general operation, reverse operands */

ae_gen:	call flip_rands;

	/* left operand is an expression, right is atomic. */

arith_switch(1):
exp_atm:	if check_scale & scale1 ^= scale2
	then do;
	     type2 = type1;
	     call get_info;
	     end;

	if rev > 0
	then do;
	     if check_scale & scale1 ^= scale2
	     then p2 = compile_exp$save_fix_scaled(q2,scale1,type1);
	     else p2 = compile_exp$save(q2);

	     call flip_rands;
	     goto aa_2;
	     end;

ea_0:	call compile_exp(q2);

	if check_scale & scale1 ^= scale2
	then do;
	     call aq_man$fix_scale(p2,scale1,type1);
	     type2 = type1;
	     call get_info;
	     end;

	if op_code = add_op
	then do;
	     if type2 ^= real_fix_bin_1 then goto aa_3;
	     if type3 ^= real_fix_bin_2 then goto aa_3;
	     call expmac$zero(rfb1_to_rfb2);
	     op = adfx2;
	     goto aa_4;
	     end;

	if comp > 0 then call expmac$zero(negate_op(type2));
	goto aa_3;

	/* negation operator */

neg_op:	if atom(2)
	then do;

	     /* set k = 3 if double length atom and 1 otherwise */

	     if mod(type2,2) = 0 then k = 3; else k = 1;
	     call load(p2,k);
	     end;
	else do;

	     /* have expression */

	     call compile_exp(q2);
	     call expmac$zero(negate_op(type1));
	     end;
	return;

flip_rands:    proc;
	
	     /* this procedure is called to reverse the operands of a node */
	
	     dcl p ptr,t fixed bin,b bit(1) aligned;
	
	     p = p2; p2 = p3; p3 = p;
	     p = q2; q2 = q3; q3 = p;
	     t = type2; type2 = type3; type3 = t;
	     t = scale2; scale2 = scale3; scale3 = t;
	     b = atom(2); atom(2) = atom(3); atom(3) = b;
	     reversed = ^ reversed;
	
	     end;

get_info:	     proc;

dcl	     j fixed bin,
	     info_pt ptr;

	     j = type2;
	     goto common;

get_information: entry;

	     j = k;

common:	     info_pt = addr(arith_data$fixed(op_code).left_type(j).
	      right_type(type3));
	     op = info_pt -> fix_info.body;
	     rev = info_pt -> fix_info.rev;
	     comp = info_pt -> fix_info.comp;
	     end;

	end;




		    assign_info.alm                 10/03/83  1730.5rew 10/03/83  1007.8       66015



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

" information table for assignment operator
"
	name	assign_info
	segdef	assign_info
"
" Format of each entry in table is
"
"	vfd	6/action_a,6/action_b,12/macro_1,12/macro_2
"
assign_info:
	null
"
"
"	real_fix_bin_1 = ...
"
	vfd	6/1,6/5		= real_fix_bin_1
	vfd	6/1,6/5		= real_fix_bin_2
	vfd	6/1,6/7,12/124	= real_flt_bin_1
	vfd	6/1,6/7,12/124	= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/1,12/124	= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/6		= bit_string
"
"	real_fix_bin_2 = ...
"
	vfd	6/1,6/5,12/88	= real_fix_bin_1
	vfd	6/1,6/5		= real_fix_bin_2
	vfd	6/1,6/7,12/125	= real_flt_bin_1
	vfd	6/1,6/7,12/125	= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/1,12/125	= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/6		= bit_string
"
"	real_flt_bin_1 = ...
"
	vfd	6/1,6/6,12/122	= real_fix_bin_1
	vfd	6/1,6/6,12/123	= real_fix_bin_2
	vfd	6/1,6/1		= real_flt_bin_1
	vfd	6/1,6/1		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/1		= complex_flt_bin_1
	vfd	6/4,6/1		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/6		= bit_string
"
"	real_flt_bin_2 = ...
"
	vfd	6/1,6/6,12/122	= real_fix_bin_1
	vfd	6/1,6/6,12/123	= real_fix_bin_2
	vfd	6/1,6/1		= real_flt_bin_1
	vfd	6/1,6/1		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/1		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/6		= bit_string
"
"	complex_fix_bin_1 = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	complex_fix_bin_2 = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	complex_flt_bin_1 = ...
"
	vfd	6/1,6/6,12/395	= real_fix_bin_1
	vfd	6/1,6/6,12/398	= real_fix_bin_2
	vfd	6/3,6/1,12/390,12/394 = real_flt_bin_1
	vfd	6/3,6/1,12/390,12/394 = real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/1		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/6		= bit_string
"
"	complex_flt_bin_2 = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	real_fix_dec = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	real_flt_dec = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	complex_fix_dec = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	complex_flt_dec = ...
"
	vfd	6/2,6/4		= real_fix_bin_1
	vfd	6/2,6/4		= real_fix_bin_2
	vfd	6/2,6/4		= real_flt_bin_1
	vfd	6/2,6/4		= real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/2,6/4		= complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/2,6/4		= bit_string
"
"	char_string = ...
"
	vfd	6/2,6/2		= real_fix_bin_1
	vfd	6/2,6/2		= real_fix_bin_2
	vfd	6/2,6/2		= real_flt_bin_1
	vfd	6/2,6/2		= real_flt_bin_2
	vfd	6/2,6/2		= complex_fix_bin_1
	vfd	6/2,6/2		= complex_fix_bin_2
	vfd	6/2,6/2		= complex_flt_bin_1
	vfd	6/2,6/2		= complex_flt_bin_2
	vfd	6/2,6/2		= real_fix_dec
	vfd	6/2,6/2		= real_flt_dec
	vfd	6/2,6/2		= complex_fix_dec
	vfd	6/2,6/2		= complex_flt_dec
	vfd	6/5		= char_string
	vfd	6/2,6/2		= bit_string
"
"	bit_string = ...
"
	vfd	6/7,6/3,12/0,12/126 = real_fix_bin_1
	vfd	6/7,6/3,12/0,12/127 = real_fix_bin_2
	vfd	6/7,6/3,12/125,12/127 = real_flt_bin_1
	vfd	6/7,6/3,12/125,12/127 = real_flt_bin_2
	vfd	6/2,6/4		= complex_fix_bin_1
	vfd	6/2,6/4		= complex_fix_bin_2
	vfd	6/4,6/3,12/125,12/127 = complex_flt_bin_1
	vfd	6/2,6/4		= complex_flt_bin_2
	vfd	6/2,6/4		= real_fix_dec
	vfd	6/2,6/4		= real_flt_dec
	vfd	6/2,6/4		= complex_fix_dec
	vfd	6/2,6/4		= complex_flt_dec
	vfd	6/2,6/2		= char_string
	vfd	6/5		= bit_string
"
	end




		    assign_op.pl1                   09/22/89  1403.5rew 09/22/89  1359.0      530451



/****^  ***********************************************************
        *                                                         *
        * 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-04-21,RWaters), approve(89-04-21,MCR8101), audit(89-04-27,Huen),
     install(89-06-16,MR12.3-1059):
     Reset the indicators after a call to size_check_fx1/size_check_uns_fx1.
  2) change(89-07-10,RWaters), approve(89-07-10,MCR8121), audit(89-08-09,Vu),
     install(89-09-22,MR12.3-1073):
     Print warning when constants occure on LHS of assignment stmt.
                                                   END HISTORY COMMENTS */


/* format: style2,^indattr,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
/* This procedure is called to process the assign operator
%page;
   Initial Version: 15 September 1971 by BLW
          Modified: 12 February 1973 by BLW
          Modified: 16 February 1973 by RAB
          Modified: 18 June 1973 by RAB for EIS
          Modified: 26 November 1974 by RAB for opt of const bit assmt
          Modified: 26 May 1975 by RAB for assign_round
          Modified: 21 August 1975 by RAB to fix 1399
          Modified: 16 October 1976 by RAB to improve vs = vs || char1;
          Modified: 10 November 1976 by RAB to fix 1549
          Modified: 25 February 1977 by RAB to fix 1585
          Modified: 9 March 1977 by RAB to fix 1593
          Modified: 19 March 1977 by RAB for aq_man$left_shift
                    and aq_man$right_shift
          Modified: 6 May 1977 by RAB to fix 1617 and use load for A(5)'s all_zeros case
          Modified: 15 May 1977 by RAB to fix 1621
          Modified: 1 September 1977 by RAB to fix 1664 by calling state_man$flush_sym
          Modified: 14 September 1977 by RAB to fix 1653
          Modified: 10 November 1977 by RAB to make minor string assignment improvement
          Modified: 2 December 1977 by RAB to fix 1692
          Modified: 16 July 1978 by PCK for unsigned binary
          Modified: 11 August 1978 by RAB to fix 1729 & 1754
          Modified: 30 November 1978 by RAB to fix 1799 (vs = substr(a,length(vs),b))
          Modified: 18 Dec 1978 by RAB to fix 1805 (vs = vs ||vsfun(); for stack frames > 16k)
          Modified: 79/04/23 by PCK to implement fixed decimal
          Modified: 28 May 1979 by RAB to fix 1827 (vs = substr(a,length(vs)+1))
          Modified: 30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
                    See prepare_operand for details.
          Modified 830118 BIM to copy_temp ptr temps on the LHS. See
                   pointer_builtins for more explanation. 
	Modified 890304 by RWaters to reset the indicators after a call
		to size_check_fx1, and size_check_uns_fx1.
          Modified 890715 by RWaters reformatted; print a warning message when
                    an options(constant) occures on the LHS of an assignment.
*/
%page;
assign_op:
     proc (pt);

/* parameters */
	dcl      pt ptr parameter;			/* points at operator node */

/* automatic */
	dcl      (p, p1, p2, s1, s2, b2, q, q1, q2) ptr;
	dcl      exp_pt ptr;
	dcl      arg (3) ptr;
	dcl      top ptr;
	dcl      (a, b, i, type1, type2, k, size1, size2) fixed bin;
	dcl      (length1, length2, aq_used, scale1, scale2) fixed bin;
	dcl      (prec1, prec2, ds, d, dt, cfo, orig_count, units_per_wrd) fixed bin;
	dcl      (atomic, all_blanks, all_ones, all_zeros, all_same) bit (1) aligned;
	dcl      (loaded, last_macro, hard1, hard2, here_before) bit (1) aligned;
	dcl      (load_it, right_constant, check_size, no_store) bit (1) aligned;
	dcl      (pack_char_pic, always_round, refs_are_same) bit (1) aligned;
	dcl      base bit (3) aligned;
	dcl      tag bit (4) aligned;
	dcl      op_code bit (9) aligned;
	dcl      full_word bit (36) aligned;
	dcl      c_length fixed bin (24);
	dcl      word bit (36) aligned based;
	dcl      double_string bit (72) aligned;
	dcl      (m1, m2, macro, bump_mac, size_ck_macro) fixed bin (15);

/* external */
	dcl      cg_stat$cur_level fixed bin external;
	dcl      cg_stat$cur_statement ptr external;
	dcl      cg_stat$cur_tree ptr ext;
	dcl      cg_stat$null_value bit (72) aligned external;
	dcl      cg_stat$packed_null_value fixed bin external;
	dcl      cg_stat$save_exp_called bit (1) external;
	dcl      cg_stat$temp_ref ptr external;
	dcl      cg_stat$text_base ptr external;
	dcl      cg_stat$text_pos fixed bin external;

/* entries */
	dcl      adjust_ref_count entry (ptr, fixed bin);

	dcl      aq_man$check_strings entry (fixed bin);
	dcl      aq_man$left_shift entry (fixed bin (8), bit (1) aligned);
	dcl      aq_man$lock entry (ptr, fixed bin);
	dcl      aq_man$right_shift entry (fixed bin (8), bit (1) aligned);
	dcl      aq_man$trim_aq entry (fixed bin);

	dcl      base_to_core entry (fixed bin, ptr);
	dcl      base_man$load_any_var entry (fixed bin, ptr) returns (bit (3) aligned);
	dcl      base_man$load_packed entry (ptr, fixed bin);
	dcl      base_man$load_var entry (fixed bin, ptr, fixed bin);
	dcl      base_man$store_ptr_to entry (ptr, ptr);
	dcl      base_man$update_base entry (fixed bin, ptr, fixed bin);

	dcl      compile_exp entry (ptr);
	dcl      compile_exp$save entry (ptr) returns (ptr);
	dcl      compile_exp$save_exp entry (ptr) returns (ptr);
	dcl      copy_temp entry (ptr) returns (ptr);
	dcl      compare_expression entry (ptr, ptr) reducible returns (bit (1) aligned);
	dcl      convert_chars entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
	dcl      convert_arithmetic entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
	dcl      c_a entry (fixed bin, fixed bin) returns (ptr);
	dcl      decimal_op$get_float_temp entry (fixed bin (24), bit (1) aligned) returns (ptr);
	dcl      error entry (fixed bin, ptr, ptr);
	dcl      expmac entry (fixed bin (15), ptr);
	dcl      expmac$one entry (fixed bin (15), ptr, fixed bin);
	dcl      expmac$zero entry (fixed bin (15));
	dcl      expmac$many entry (fixed bin (15), ptr, fixed bin);
	dcl      expmac$many_eis entry (fixed bin (15), ptr, fixed bin);
	dcl      expmac$one_eis entry (fixed bin (15), ptr);
	dcl      expmac$two_eis entry (fixed bin (15), ptr, ptr);

	dcl      fixed_to_float entry (ptr);
	dcl      float_to_fixed entry (ptr);
	dcl      generate_constant entry (bit (*) aligned, fixed bin) returns (ptr);
	dcl      generate_constant$real_fix_bin_1 entry (fixed bin) returns (ptr);
	dcl      generate_constant$bit_string entry (bit (*) aligned, fixed bin) returns (ptr);
	dcl      generate_constant$char_string entry (char (*) aligned, fixed bin) returns (ptr);
	dcl      get_imaginary entry (ptr) returns (ptr);
	dcl      get_single_ref entry (ptr) returns (ptr);
	dcl      load entry (ptr, fixed bin);
	dcl      load$for_store entry (ptr, fixed bin);
	dcl      load$long_string entry (ptr);
	dcl      load$short_string entry (ptr, fixed bin);
	dcl      load_prog entry (ptr, fixed bin) variable;
	dcl      load_size entry (ptr);
	dcl      load_size$xr_or_aq entry (ptr, bit (4) aligned);
	dcl      long_op$one_eis entry (ptr, fixed bin, fixed bin (15));
	dcl      long_op$extend_stack entry (ptr, fixed bin (15));
	dcl      make_n_addressable entry (ptr, fixed bin);
	dcl      m_a entry (ptr, bit (2) aligned);
	dcl      make_both_addressable entry (ptr, ptr, bit (1) aligned);
	dcl      need_temp entry (ptr, bit (2) aligned);
	dcl      move_data$move_block entry (ptr, ptr, fixed bin);
	dcl      picture_op entry (ptr);
	dcl      prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr);
	dcl      stack_temp$assign_temp entry (ptr);
	dcl      state_man$erase_reg entry (bit (19) aligned);
	dcl      state_man$flush_ref entry (ptr);
	dcl      state_man$flush_sym entry (ptr);
	dcl      store entry (ptr);
	dcl      store$all_ones entry (ptr);
	dcl      store$force entry (ptr);
	dcl      store$save_string_temp entry (ptr);
	dcl      xr_man$load_const entry (fixed bin, fixed bin);

/* builtins */
	dcl      (abs, addr, addrel, bit, divide, fixed, max, min, mod, null, string, substr, verify) builtin;

/* other stuff */
	dcl      assign_info$assign_info (14, 14) fixed bin ext,
	         1 assign_info aligned based,		/* image of ext structure */
		 2 act_a unal bit (6),
		 2 act_b unal bit (6),
		 2 macro_1 unal bit (12),
		 2 macro_2 unal bit (12);

	dcl      (
	         assign_label_to_int init (379),
	         rflb1_to_cflb1 init (390),
	         set_label_const (2) init (315, 285),
	         ldfl1 init (9),
	         alloc_char_temp init (89),
	         chars_move init (420),
	         chars_move_vt init (444),
	         cat_move_chars init (218),
	         sbfx1 init (22),
	         aos_mac init (309),
	         incr_mac init (310),
	         lda init (1),
	         ansa init (43),
	         longbs_to_fx2 init (132),
	         cpfx1 init (136),
	         lrl init (62),
	         lrs init (492),
	         lls init (63),
	         move_chars init (98),
	         oraq init (48),
	         stfx1 init (15),
	         sta init (4),
	         fx1_to_bs init (293),
	         blank_cs init (472),
	         zero_bs init (468),
	         one_bs init (469),
	         zero_cs init (419),
	         one_cs init (484),
	         zero_cs_q init (479),
	         b2c_mac init (108),
	         size_check_fx1 init (553),
	         chars_move_ck init (555),
	         signal_stringsize init (563),
	         size_ck_varying init (566),
	         size_ck_suffix init (567),
	         size_ck_decimal init (582),
	         cmp_suffix_1 init (220),
	         size_ck_suffix_1 init (698),
	         left_shift (2) init (515, 63),
	         truncate (2) init (520, 521),
	         min_fx1 init (247),
	         zero_mac init (308),
	         zero_mac_p_1 init (307),
	         move_decimal init (438),
	         multiply_decimal init (450),
	         make_lv init (173),
	         store_lv init (174),
	         size_check_uns_fx1 init (731),
	         uns_fx1_to_bs init (733)
	         ) fixed bin (15) int static options (constant);

	dcl      ptr_convert (23:24, 23:24) fixed bin (15) int static init (0, 407, 408, 0);

	dcl      based_bs bit (size2) aligned based,
	         based_cs char (length2) aligned based;

	dcl      1 instruction based aligned,		/* layout of first word of EIS instruction */
		 2 fill char (1) unal,		/* fill character -- can be set by assign_op */
		 2 enablefault bit (1) unal,
		 2 pad1 bit (1) unal,
		 2 mf2 bit (7) unal,
		 2 opcode bit (10) unal,
		 2 inhibit bit (1) unal,
		 2 mf1 bit (7) unal;

	dcl      1 exponent aligned,			/* layout of floating decimal exponent character */
		 2 pad bit (1) unal,
		 2 value fixed bin (7) unal;

	dcl      exponent_char char (1) based (addr (exponent)) aligned;

/* CONSTANTS */

	dcl      TRUE bit (1) aligned int static options (constant) init ("1"b);
	dcl      FALSE bit (1) aligned int static options (constant) init ("0"b);

%page;
%include cgsystem;
%page;
%include statement;
%page;
%include operator;
%page;
%include reference;
%page;
%include symbol;
%page;
%include block;
%page;
%include nodes;
%page;
%include bases;
%page;
%include data_types;
%page;
%include machine_state;
%page;
%include op_codes;
%page;
%include boundary;
%page;
/* program */

	load_prog = load$for_store;

	all_blanks, all_ones, all_zeros, all_same, loaded, here_before, full_word, no_store, pack_char_pic, last_macro =
	     FALSE;

	p = pt;
	op_code = p -> operator.op_code;
	check_size = (op_code = assign_size_ck);
	always_round = (op_code = assign_round);

	p1 = prepare_operand ((p -> operand (1)), 1, atomic);
	orig_count = p1 -> reference.ref_count;

	exp_pt, p2 = p -> operand (2);
	if p2 -> node.type = operator_node | p2 -> node.type = label_node | ^p2 -> reference.temp_ref then
	     p2 = prepare_operand (p2, 1, atomic);
	else
	     atomic = TRUE;

gt:
	s1 = p1 -> reference.symbol;
	s2 = p2 -> reference.symbol;

	scale1 = s1 -> symbol.scale;
	prec1 = s1 -> symbol.c_dcl_size;

	right_constant = FALSE;

	type2 = p2 -> reference.data_type;

	if s2 -> node.type = label_node then do;
	     type1 = p1 -> reference.data_type;
	     goto lab_or_ent;
	end;

	scale2 = s2 -> symbol.scale;
	prec2 = s2 -> symbol.c_dcl_size;

	if s1 -> symbol.storage_block & ^here_before then do;
	     type1, p1 -> reference.data_type = type2;
	     p1 -> reference.c_length = p2 -> reference.c_length;
	     if type1 = char_string | type2 = bit_string then
		p1 -> reference.long_ref = p1 -> reference.c_length * convert_size (type1) > bits_per_two_words;
	end;
	else
	     type1 = p1 -> reference.data_type;

	here_before = TRUE;

	dt = type1 - char_string;

	if type2 ^= bit_string then
	     if type2 ^= char_string then
		goto chk_temp;

	length2 = p2 -> reference.c_length;
	size2 = length2 * convert_size (type2);

	if op_code = pack then
	     if type2 = char_string then
		if substr (cg_stat$cur_statement -> statement.prefix, 5, 1) then
		     pack_char_pic = TRUE;

	if atomic then do;
	     if ^s2 -> symbol.constant then
		goto chk_temp;
	     if s2 -> symbol.varying then
		goto chk_temp;
	     if s2 -> symbol.dimensioned then
		goto chk_temp;
	     if p2 -> reference.offset ^= null then
		goto chk_temp;
	     if p2 -> reference.length ^= null then
		goto chk_temp;
	     if p2 -> reference.c_offset ^= 0 then
		goto chk_temp;
	     if p2 -> reference.temp_ref then
		goto chk_temp;

	     right_constant = TRUE;

	     q = s2 -> symbol.initial;

	     if type2 = char_string then do;
		if length2 > 0 then do;
		     all_same = verify (q -> based_cs, substr (q -> based_cs, 1, 1)) = 0;
		     if all_same then
			all_blanks = substr (q -> based_cs, 1, 1) = " ";
		end;
		else
		     all_same, all_blanks = TRUE;
	     end;
	     else do;
		all_ones = (^q -> based_bs = FALSE);
		all_zeros = (q -> based_bs = FALSE);
	     end;
	end;

chk_temp:
	if ^p1 -> reference.temp_ref then
	     goto get_info;
	if p1 -> reference.defined_ref then
	     goto get_info;
	if p1 -> reference.aggregate then
	     goto get_info;

/* have temporary on left of assignment */

	if p1 -> reference.length = null then do;

	     load_prog = load;

	     if p1 -> reference.allocate then do;
		if ^p1 -> reference.allocated then
		     call stack_temp$assign_temp (p1);
		if p1 -> reference.ref_count = 1 then
		     p1 -> reference.ref_count = 2;
		goto get_info;
	     end;

	     if ^p1 -> reference.long_ref then do;
		no_store = TRUE;
		goto get_info;
	     end;

	end;

/* have long (string) temp = something */

	if type1 ^= type2 then do;
	     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     call long_op$extend_stack (p1, alloc_char_temp + dt);
	     call store$save_string_temp (p1);
	     goto get_info;
	end;

	if ^atomic then
	     p2 = compile_exp$save (exp_pt);

	call long_op$extend_stack (p1, alloc_char_temp + dt);
	if cg_stat$save_exp_called then
	     call store$save_string_temp (p1);
	call expmac$two_eis (move_chars + dt, p1, p2);

	goto done;

get_info:
	if atomic then
	     goto gi;

	if type2 <= real_flt_bin_2 then
	     k = 1;
	else do;
	     if type2 ^= type1 then
		goto gi;
	     if type2 < char_string then
		goto gi;
	     if type2 > bit_string then
		goto gi;

	     if pack_char_pic then
		goto gi;
	     if p1 -> reference.varying_ref then
		goto gi;
	     if p1 -> reference.length ^= null then
		goto gi;

	     k = 0;
	end;

/* if the right hand side is another assign operator which only changes the
 * precision of its operand(2) (case k = 1) or another assignment to a
 * string temporary (case k = 0) we'll try to eliminate the extra assign
 */

	if exp_pt -> node.type ^= operator_node then
	     goto gi;
	if exp_pt -> operator.op_code ^= assign then
	     goto gi;
	if exp_pt -> operator.operand (1) -> reference.ref_count > 1 then
	     goto gi;

	if k = 0 then do;
	     if p2 -> reference.varying_ref then
		goto gi;
	     if p2 -> reference.length ^= null then
		goto gi;

/* we can eliminate assignment if length of right side temporary
 * is equal to length of left side temp
 */
	     if p1 -> reference.c_length = p2 -> reference.c_length then
		goto elim;
	end;

/* we have to restore the original value of the data type field
 * of operand(2) if it is a reference because if we dont, prepare_operand
 * will get confused and not evaluate the offset expression (if any)
 */

	q2 = exp_pt -> operand (2);
	if q2 -> node.type = operator_node then
	     q2 = q2 -> operand (1);

	m1 = q2 -> reference.data_type;

	q2 = prepare_operand (q2, 0, atomic);

	m2 = q2 -> reference.data_type;
	q2 -> reference.data_type = m1;

	if k = 0 then do;
	     if p1 -> reference.c_length < p2 -> reference.c_length then
		if type2 ^= m2 then
		     goto repair;
		else
		     goto elim;

/* must have p1 -> c_length > p2 -> c_length */

/* q2 -> reference.c_length won't be in the same units as for p2,
 * but it still gives a reasonable indication of safety unless q2
 * is decimal.  This fixes 1653
 */
	     if type2 ^= m2 then
		if m2 >= real_fix_dec & m2 <= complex_flt_dec then
		     goto repair;

	     if q2 -> reference.varying_ref then
		goto repair;
	     if q2 -> reference.length ^= null then
		goto repair;

	     if p2 -> reference.c_length < q2 -> reference.c_length then
		goto repair;

/* eliminate the assignment */

elim:
	     p2, exp_pt = exp_pt -> operand (2);
	     if k = 0 then do;
		p2 = prepare_operand (p2, 1, atomic);
		goto gt;
	     end;
	     p2 = prepare_operand (p2, 1, atomic);
	     goto gi;
	end;

/* k = 1 at this point */

	if type2 = m2 then
	     goto elim;

repair:
	atomic = FALSE;

gi:
	if type2 > bit_string then
	     goto LABEL_ENTRY_OR_PTR;

	q = addr (assign_info$assign_info (type1, type2));
	a = fixed (q -> assign_info.act_a, 6);
	b = fixed (q -> assign_info.act_b, 6);
	m1 = fixed (q -> assign_info.macro_1, 12);
	m2 = fixed (q -> assign_info.macro_2, 12);

	if pack_char_pic then do;
	     a = 2;
	     b = 2;
	end;

/* MR12.3: print a sev 2 warning about assignments to an
 * options(constant) variable
 */
	if p1 -> reference.symbol -> symbol.alloc_in_text then
	     call error (134, cg_stat$cur_statement, null);

	goto A (a);
%page;
/* unimplemented conversion */

A (0):
	call error (331, cg_stat$cur_statement, null);
	goto done;
%page;
/* ordinary arithmetic assignment */

A (1):
	if p1 -> reference.aligned_for_store_ref then do;
A1a:
	     if atomic then
		call load_prog (p2, 0);
	     else
		call compile_exp (exp_pt);
	     goto B (b);
	end;

/* have assignment to packed arithmetic value */

	if type1 ^= type2 then
	     goto A1a;

	if ^atomic then
	     if exp_pt -> node.type = operator_node then
		goto A1a;

	if p2 -> reference.ref_count > 1 then
	     goto A1a;

	if check_size then
	     if type1 = real_fix_bin_1 then
		if prec1 < prec2 then
		     goto A1a;

/* have atom on right */

	size1 = p1 -> reference.c_length;

	if type1 = real_fix_bin_1 then do;

	     if s2 -> symbol.constant then do;

		if s2 -> symbol.packed & ^p2 -> reference.aligned_ref then
		     goto fake_bit;

		if p2 -> reference.offset ^= null then
		     goto A1b;
		if p2 -> reference.c_offset ^= 0 then
		     goto A1b;

		p2 = generate_constant$bit_string (
		     substr (s2 -> symbol.initial -> word, bits_per_word - size1 + 1, size1), size1);

/* now treat assignment as if we were assigning bit strings */

fake_bit:
		check_size = FALSE;

		if prec1 = prec2 then
		     if s1 -> symbol.unsigned = s2 -> symbol.unsigned then
			if p1 -> reference.hard_to_load | p2 -> reference.hard_to_load then do;
			     dt = 1;
			     goto short_eis;
			end;

		call load$for_store (p2, 0);

		aq_used = a_reg.offset + a_reg.size;

		k = size1 - a_reg.size;
		if k < 0 then do;			/* right side is larger than we need */
		     call aq_man$check_strings (aq_used + k);
		     a_reg.offset = a_reg.offset - k;
		end;
		else if k > 0 then do;		/* right side has less precision than we need */
		     if a_reg.offset > 0 then
			call aq_man$left_shift (a_reg.offset, "0"b);

		     if s2 -> symbol.unsigned then
			macro = lrl;
		     else
			macro = lrs;

		     call expmac (macro, c_a (k, 1));

		end;

		a_reg.size = size1;
		p1 -> reference.data_type = bit_string;
		goto l1;
	     end;

A1b:
	     if p2 -> reference.aligned_ref then
		goto A1a;
	     if p2 -> reference.value_in.q then
		goto A1a;

	     if scale1 ^= scale2 then
		goto A1a;

/* have packed fixed single on right, too */

	     p2 -> reference.data_type = bit_string;
	     goto fake_bit;
	end;

	if p2 -> reference.value_in.q then
	     goto A1a;

	if type1 = real_flt_bin_1 | type1 = real_flt_bin_2 then do;
	     type1, p1 -> reference.data_type, p2 -> reference.data_type = bit_string;

	     call load_prog (p2, type2 - real_flt_bin_1);

	     size2 = p2 -> reference.c_length;
	     goto string_store_check;
	end;

	goto A1a;
%page;
/* char string and decimal conversion */

A (2):
	if ^atomic then
	     p2 = compile_exp$save_exp (exp_pt);
	goto B (b);
%page;
/* left side is complex */

A (3):
	if atomic then do;
	     call expmac (m2, p2);
	     goto l1;
	end;

	call compile_exp (exp_pt);
	m2 = 0;
	goto B (b);
%page;
/* right side is complex float single binary */

A (4):
	if ^atomic then do;
	     p2 = compile_exp$save_exp (exp_pt);
	     if exp_pt -> node.type ^= operator_node then
		goto B (4);
	end;

	if type1 = complex_flt_bin_1 then do;
	     call load_prog (p2, 0);
	     goto l1;
	end;

	call expmac ((ldfl1), p2);
	loaded = TRUE;
	if scale1 ^= 0 then
	     b = 7;
	goto B (b);
%page;
/* have string = string */

A (5):
	length1 = p1 -> reference.c_length;
	size1 = length1 * convert_size (type1);
	d = fixed (size1 > bits_per_word, 1);

	all_same = all_same & ((length1 = length2 & p1 -> reference.length = null) | all_blanks);
	all_ones = all_ones & (length1 = length2 & p1 -> reference.length = null);

	hard1 = p1 -> reference.hard_to_load;
	hard2 = p2 -> reference.hard_to_load;
	if ^hard2 then
	     if p2 -> reference.long_ref then
		if p2 -> reference.units < word_ then
		     hard2 = size1 > bits_per_word;

	if ^check_size then
	     goto A5a;
	if p1 -> reference.length ^= null then
	     goto A5a;
	if p2 -> reference.length ^= null then
	     goto A5a;

	call check_stringsize;

/* the following code tries to improve string assignments by using
 * an MLR or ldaq-staq seq
 */

A5a:
	if p1 -> reference.varying_ref then
	     goto A5c;
	if p1 -> reference.length ^= null then
	     goto A5c;
	if ^p1 -> reference.aligned_for_store_ref then
	     goto A5c;

	if no_store then
	     goto A5c;

	if ^p2 -> reference.aligned_ref then
	     goto A5c;
	if p2 -> reference.varying_ref then
	     goto A5c;
	if p2 -> reference.length ^= null then
	     goto A5c;
	if ^p2 -> reference.long_ref then
	     goto A5c;

	if all_same | all_ones | all_zeros then
	     if size1 > break_even_bits then
		goto A5c;

	if length1 > length2 then
	     goto A5c;

	if ^(mod (size1, bits_per_word) = 0 | p1 -> reference.long_ref) then
	     goto A5c;

	if mod (size1, bits_per_word) = 0 | p1 -> reference.padded_for_store_ref then do;

	     if ^atomic then
		call compile_exp (exp_pt);

	     call move_data$move_block (p1, p2, divide (size1 + bits_per_word - 1, bits_per_word, 17, 0));
	     goto done;
	end;

A5c:
	if atomic then do;

A5ca:
	     if ^p1 -> reference.varying_ref then
		goto chk;

/* have varying string on left */

	     if p2 -> reference.length ^= null then
		goto l9;
	     if p2 -> reference.varying_ref then
		goto l9;

	     if length2 = 0 then do;
		p1 -> reference.c_offset = p1 -> reference.c_offset - 1;
		call expmac ((zero_mac), p1);
		p1 -> reference.c_offset = p1 -> reference.c_offset + 1;
		call state_man$flush_ref (p1);	/* p1 might have been in indicators */
		goto done;
	     end;

	     if p1 -> reference.length ^= null then
		goto l9;

	     load_prog = load;

	     if ^hard2 then do;
		if ^p2 -> reference.long_ref then do;
		     call load_prog (p2, d);
		     goto string_store_work;
		end;

		if ^p1 -> reference.long_ref then do;
		     call load$short_string (p2, d);
		     goto string_store_work;
		end;
	     end;

	     goto l9;

chk:
	     if p1 -> reference.long_ref then do;

l9:
lg:
		if ^p1 -> reference.varying_ref then do;
		     call state_man$flush_sym ((p1 -> reference.symbol));
		     call eis_move;
		     goto done;
		end;

/* have varying string on left, must set cur length */

		if p1 -> reference.length ^= p2 -> reference.length then
		     arg (1) = get_length_in_storage (p1);
		else
		     arg (1) = get_length (p1);

		if p2 -> reference.varying_ref then do;

		     call load_size (p2);

		     if arg (1) = null then
			if s2 -> symbol.c_dcl_size <= length1 & s2 -> symbol.dcl_size = null then
			     goto l11;
			else
			     arg (1) = generate_constant$real_fix_bin_1 (length1);

		     goto l10;
		end;

		arg (2) = get_length (p2);

		if arg (1) = null then
		     if arg (2) = null then do;
			call load (generate_constant$real_fix_bin_1 (min (length1, length2)), 0);
			goto l11;
		     end;
		     else
			arg (1) = generate_constant$real_fix_bin_1 (length1);
		else if arg (2) = null then
		     arg (2) = generate_constant$real_fix_bin_1 (length2);

		call load (arg (2), 0);

		if arg (1) = arg (2) then do;
		     if ^arg (1) -> reference.shared then
			arg (1) -> reference.ref_count = arg (1) -> reference.ref_count - 1;
		     goto l11;
		end;

l10:
		if p2 -> reference.ref_count = 1 then
		     call need_temp (p2, "01"b);
		if check_size then
		     macro = size_ck_varying;
		else
		     macro = min_fx1;
		if arg (1) -> reference.data_type = real_fix_bin_2 then
		     arg (1) = get_single_ref (arg (1));
		call expmac (macro, arg (1));

l11:
		refs_are_same = compare_refs (p1, p2);

		if ^refs_are_same & p2 -> reference.offset ^= null then do;

/* the offset of p2 may be length(p1) (either as a
 * reference node or as an operator node), so we
 * should be careful to see that it is loaded before
 * the length(p1) is changed.  We use aq_man$lock
 * and make_n_addressable to ensure that registers
 * stay locked.  Fixes 1799 and 1827.
 */

		     call aq_man$lock (null, 2);
		     arg (1) = p2;
		     call make_n_addressable (addr (arg), 1);
		end;

		call expmac_length_of_varying (stfx1, p1);

		if ^refs_are_same then
		     call expmac$two_eis (chars_move_vt + dt, p1, p2);
		else do;
		     if ^p2 -> reference.shared then
			call adjust_ref_count (p2, -1);
		     if ^p1 -> reference.shared then
			call adjust_ref_count (p1, -1);
		end;

		goto done;
	     end;

/* string on left is short */

	     if p2 -> reference.varying_ref then
		goto short_eis;

	     if hard1 | hard2 then
		goto short_eis;

	     if p2 -> reference.long_ref then
		if p2 -> reference.length = null then
		     call load$short_string (p2, d);
		else do;
short_eis:
		     if no_store then
			p1 = copy_temp (p1);

		     if p1 -> reference.aligned_for_store_ref then
			if mod (size1, bits_per_word) ^= 0 then do;
			     if size1 < bits_per_word then
				macro = zero_mac;
			     else
				macro = zero_mac_p_1;
			     if ^p1 -> reference.shared then
				p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
			     call expmac (macro, p1);
			end;

		     call state_man$flush_sym ((p1 -> reference.symbol));

		     call eis_move;

		     if p1 -> reference.temp_ref then
			if cg_stat$save_exp_called then
			     call adjust_ref_count (p1, -1);
			else if cg_stat$cur_tree ^= p then do;
			     if ^no_store then
				p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
			     call load (p1, d);
			end;

		     goto done;
		end;
	     else if all_zeros then do;

		if p1 -> reference.temp_ref then do;
		     call load_prog (p2, d);
		     goto string_store_work;
		end;

		if p1 -> reference.aligned_for_store_ref then
		     if size1 <= bits_per_word then
			goto zm;
		     else do;
			call load_prog (p2, d);
			goto string_store_work;
		     end;

/* we'll zero the string by generating an and to storage
 * macro using a mask with 0's in the field occupied
 * by the string
 */

		call state_man$flush_ref (p1);
		double_string = (72)"1"b;
		cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
		substr (double_string, cfo + 1, size1) = "0"b;

		d = fixed (cfo + size1 > bits_per_word, 1);
		p2 = generate_constant (double_string, d + 1);
		call load (p2, d);
		call expmac$one ((ansa), p1, d);
		goto done;
	     end;
	     else if right_constant then do;
		if p1 -> reference.aligned_for_store_ref then do;
		     call load_prog (p2, d);
		     goto string_store_work;
		end;

/* we have a string constant being assigned to a variable
 * with a non-zero offset, we'll generate another constant
 * which is already shifted
 */

		cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
		if cfo + size1 > bits_per_two_words then do;
		     call load_prog (p2, d);
		     goto string_store_work;
		end;

		double_string = (72)"0"b;
		substr (double_string, cfo + 1, size1) = s2 -> symbol.initial -> based_bs;
		d = fixed (cfo + size1 > bits_per_word, 1);
		p2 = generate_constant (double_string, d + 1);

		call expmac$one ((lda), p2, d);
		a_reg.offset = cfo;
		a_reg.size = size2;
		a_reg.length = bits_per_word * (d + 1);
		goto string_store_work;
	     end;
	     else do;
		call load_prog (p2, d);
		goto string_store_work;
	     end;

	     goto string_store_work;
	end;

	if exp_pt -> node.type ^= operator_node then
	     goto A5ca;

/* string on right is not atomic */

	if ^p1 -> reference.varying_ref then
	     goto l4;

/* following code looks for the case
 *	 vs = vs || something
 * where vs is a varying string.  note that we can't use
 * compare_expression directly because ref node for
 * vs on LHS has a length field and ref node on RHS has
 * 0 length field
 */

	if exp_pt -> operator.op_code ^= cat_string then
	     goto l4;

	q = exp_pt -> operand (2);
	if q -> reference.c_length ^= 0 then
	     goto l4;
	if q -> reference.length ^= null then
	     goto l4;

	if ^compare_refs (p1, q) then
	     goto l4;

/* We have the case
 *	     vs = vs || something;
 * so we can move something to the end of vs
 */

	q = prepare_operand (q, -1, atomic);

	q1 = prepare_operand ((exp_pt -> operand (3)), 1, atomic);
	if ^atomic then
	     if q1 -> reference.long_ref then
		call compile_exp ((exp_pt -> operand (3)));
	     else
		q1 = compile_exp$save_exp ((exp_pt -> operand (3)));

/* We should bump down some reference counts for unneeded temps
 * associated with result of cat_string operator
 */

	call adjust_suff_temp ((exp_pt -> operand (1)));

/* get a ptr to the operand to be used in the subsequent compare.
 * We make the call now because this operand may need to be unpacked
 * which would emit code.  This fixes 1754
 */

	if q1 -> reference.c_length ^= 1 then
	     q2 = get_suffix_length (q1);
	else
	     q2 = get_suffix_length (p1);

/* make the varying string addressable without a tag */

	call m_a (p1, "10"b);

	if p1 -> address.tag then do;
	     if ^p1 -> reference.shared then
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     base = base_man$load_any_var (2, p1);
	     if p1 -> reference.ref_count = 1 then
		call need_temp (p1, "10"b);
	end;

/* erase and lock the q register and force both operands to be addressable,
 * erase and locking the involved registers
 */

	call state_man$erase_reg ("01"b);
	call aq_man$lock (null, 2);
	arg (1) = p1;
	arg (2) = q1;
	p1 -> reference.perm_address = TRUE;
	call make_n_addressable (addr (arg), 2);
	p1 -> reference.perm_address = FALSE;

	if q1 -> reference.c_length ^= 1 then do;	/* get the room left in the varying string for the move */
	     call load_size (p1);
	     call expmac_length_of_varying ((sbfx1), p1);

/* compare the 2 lengths to decide how much we will move in ( result in q reg ) */

	     if check_size then
		macro = size_ck_suffix;
	     else
		macro = min_fx1;
	     if q1 -> reference.varying_ref then
		call expmac_length_of_varying (macro, q1);
	     else
		call expmac (macro, q2);

/* load present size of varying string into a register other than q */

	     call load_size$xr_or_aq (q, tag);

	     bump_mac = incr_mac;
	     macro = chars_move_vt + dt;
	end;
	else do;					/* compare present size with max length of target */

	     call load_size (q);

	     if check_size then
		macro = size_ck_suffix_1;
	     else
		macro = cmp_suffix_1;

	     call expmac (macro, q2);

	     tag = "0110"b;				/* ql */

	     bump_mac = aos_mac;
	     macro = cat_move_chars + dt;
	end;

	if ^q -> reference.shared then
	     call adjust_ref_count (q, -1);

/* update length field of varying string */

	call expmac_length_of_varying (bump_mac, p1);

/* Use old size of varying string as the offset in the string for the target of the move */

	p1 -> address.tag = "00"b || tag;
	p1 -> reference.perm_address = TRUE;
	q1 -> reference.perm_address = TRUE;
	call expmac$two_eis (macro, p1, q1);

	if dt > 0 then
	     machine_state.indicators = ind_invalid;
	goto done;
%page;
/* Have expression, will compile */

l4:
	if ^p2 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null)
	     & (p1 -> reference.long_ref | hard1) then
	     p2 = compile_exp$save (exp_pt);
	else
	     call compile_exp (exp_pt);

	if p1 -> reference.varying_ref then do;
	     if p1 -> reference.length ^= null then
		goto lg;

	     if p2 -> reference.length = null then do;
		if ^p2 -> reference.long_ref then
		     goto string_store_work;
	     end;
	     else
		goto lg;
	end;

	if p1 -> reference.long_ref then
	     goto lg;

/* string on left is short */

	if hard1 then
	     goto short_eis;

	if p2 -> reference.long_ref then do;

	     if check_size then
		goto short_eis;

	     if p2 -> reference.length ^= null | size2 < bits_per_two_words then
		goto short_eis;

	     p2 -> reference.value_in.storage = TRUE;

	     call load$short_string (p2, d);
	     size2 = bits_per_word * (d + 1);
	end;

/* we have size2 <= a_reg.size */

string_store_work:
	if p1 -> reference.varying_ref then do;

	     if ^p1 -> reference.shared then
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;

	     call expmac$one ((sta), p1, fixed (min (size1, size2) > bits_per_word, 1));
	     p2 = generate_constant$real_fix_bin_1 (min (length1, length2));

	     if p1 -> address.tag = "000110"b then do;	/* ql */
		call expmac ((lda), p2);
		m2 = sta;
	     end;
	     else do;
		call load (p2, 0);
		m2 = stfx1;
	     end;

	     last_macro = TRUE;
	     call expmac_length_of_varying (m2, p1);

	     goto done;
	end;

string_store_check:
	if size1 = a_reg.size then
	     goto st;

	if size1 < a_reg.size then do;
	     if no_store then
		call aq_man$trim_aq (size1);
	     goto st;
	end;

/* have size2 <= a_reg.size < size1 */

	aq_used = a_reg.size + a_reg.offset;

	if type1 = bit_string then
	     if a_reg.length = bits_per_two_words | a_reg.length - a_reg.offset >= size1 then
		goto st;
	     else
		goto pad;

/* we must pad the char string, check to see if new length
 * will fit with current offset
 */

	if size1 > bits_per_two_words - a_reg.offset then do;

/* we can't extend far enough without shifting string
 * back to left end of aq
 */
	     call aq_man$left_shift (a_reg.offset, "1"b);
	     aq_used = a_reg.size;
	end;

	if size1 <= bits_per_word then
	     k = size1 + a_reg.offset;
	else
	     k = bits_per_two_words;

	if a_reg.length < k then do;
pad:
	     call aq_man$trim_aq (aq_used);
	     a_reg.length = 72;
	end;

	if type1 = bit_string then
	     goto st;

	call expmac ((oraq), c_a (aq_used, 6));

	if mod (k, bits_per_word) ^= 0 then do;
	     call aq_man$trim_aq (k);
	     a_reg.length = bits_per_two_words;
	end;

	a_reg.size = k - a_reg.offset;

st:
	if (size1 = size2) & all_ones then
	     call store$all_ones (p1);
	else
	     call store (p1);

	if a_reg.size + a_reg.offset > bits_per_two_words then
	     a_reg.size = bits_per_two_words - a_reg.offset;

	goto done;
%page;
/* something (not char string) = bit string */

A (6):
	if p2 -> reference.long_ref | p2 -> reference.varying_ref then do;

	     if ^atomic then
		call compile_exp (exp_pt);
	     call load$long_string (p2);

	     call expmac$zero ((longbs_to_fx2));

/* now have real_fix_bin_2 in aq register */

now_fx2:
	     type2 = real_fix_bin_2;

	     q = addr (assign_info$assign_info (type1, type2));
	     m1 = fixed (q -> assign_info.macro_1, 12);
	     m2 = fixed (q -> assign_info.macro_2, 12);
	     goto B (fixed (q -> assign_info.act_b, 6));
	end;

	if all_zeros then
	     if type1 = real_fix_bin_1 & ^p1 -> reference.temp_ref & p1 -> reference.aligned_for_store_ref then do;
zm:
		call state_man$flush_ref (p1);
		call expmac ((zero_mac), p1);
		goto done;
	     end;

	if atomic then
	     call load (p2, 1);
	else
	     call compile_exp (exp_pt);

	dt = a_reg.offset;
	if a_reg.number ^= 0 then do;
	     q = a_reg.variable (1);
	     if q -> reference.temp_ref & q -> reference.ref_count > 0 then
		call state_man$erase_reg ("1"b);
	end;

	if size2 < bits_per_two_words then do;
	     k = bits_per_two_words - size2;
	     if k > dt then
		call aq_man$right_shift (k - dt, "1"b);
	end;

	if scale1 ^= 0 then
	     call state_man$erase_reg ("1"b);

	goto now_fx2;
%page;
/* bit_string = arithmetic */

A (7):
	if ^atomic then do;
	     call compile_exp (exp_pt);

	     loaded = TRUE;
	end;

	goto B (b);
%page;
/* ordinary arithmetic assignment */

B (1):
	if m1 ^= 0 then
	     call expmac$zero (m1);

l0:
	if m2 ^= 0 then
	     call expmac$zero (m2);

l1:
	if check_size & s1 -> symbol.fixed then do;
	     if type1 > real_fix_bin_1 then
		dt = 1;
	     else if type2 > real_fix_bin_1 then
		dt = 1;
	     else
		dt = 0;
	     call xr_man$load_const (-s1 -> symbol.c_dcl_size * (dt + 1), 7);

	     if s1 -> symbol.unsigned then
		size_ck_macro = size_check_uns_fx1 + dt;
	     else
		size_ck_macro = size_check_fx1 + dt;

	     call expmac$zero (size_ck_macro);

/* RW 89
 * The above load_const destroyed the indicators we needed.
 */
	     machine_state.indicators = ind_invalid;

	end;

	call store (p1);

done:
	cg_stat$temp_ref = p1;

	if p1 -> reference.temp_ref then
	     p1 -> reference.ref_count = min (p1 -> reference.ref_count, orig_count);

	if ^p1 -> reference.shared then
	     p1 -> reference.evaluated = TRUE;

	return;
%page;
/* have conversion to or from char string */

B (2):
	if p1 -> reference.temp_ref & p1 -> reference.shared & p1 -> reference.length = null then do;
	     p1, p -> operand (1) = copy_temp (p1);
	     orig_count = 1;
	end;

	load_it =
	     p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p & ^p1 -> reference.long_ref
	     & ^s1 -> symbol.decimal;

	if op_code = pack | op_code = unpack then
	     call picture_op (p);
	else do;
	     call convert_chars (p1, p2, check_size, always_round);

	     if p2 ^= null then do;			/* conversion was done into temp which we must still assign */
		atomic = TRUE;
		length2 = p2 -> reference.c_length;
		size2 = bits_per_char * length2;
		type2 = char_string;
		goto A (5);
	     end;
	end;

B2b:
	if type1 = bit_string then
	     machine_state.indicators = ind_invalid;

	if load_it then do;
	     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     call load (p1, fixed (type1 >= char_string, 1));
	end;
	goto done;
%page;
/* have bit string = arithmetic */

B (3):
	size1, length1 = p1 -> reference.c_length;

	if type2 <= real_fix_bin_2 & scale2 ^= 0 then do;
	     if ^loaded then
		call load (p2, 0);

	     call scaler (-scale2, type2);

	     prec2 = max (prec2 - scale2, 0);
	     goto B3b;
	end;

	if ^loaded then
	     if type2 > real_fix_bin_2 | ^p2 -> reference.aligned_ref then
		call load (p2, 0);
	     else do;
		d = type2 - real_fix_bin_1;
		k = bits_per_word * (d + 1);

		arg (1) = p2;
		arg (2) = c_a (k - prec2, 1);

		if s2 -> symbol.unsigned then
		     macro = uns_fx1_to_bs;
		else
		     macro = fx1_to_bs;

		call expmac$many (macro + d, addr (arg), 2);

		a_reg.length = k;
		goto B3a;
	     end;

B3b:
	if ^s2 -> symbol.unsigned then do;
	     if machine_state.indicators ^= ind_arithmetic then do;
		call expmac (cpfx1 - real_fix_bin_1 + type2, c_a (0, 5));
		machine_state.indicators = ind_arithmetic;
	     end;

	     if m1 ^= 0 then
		call expmac$zero (m1);
	     if m2 ^= 0 then
		call expmac$zero (m2);
	end;

	call expmac ((lls), c_a (bits_per_two_words - prec2, 1));

	a_reg.length = bits_per_two_words;

B3a:
	a_reg.size, size2, length2 = prec2;
	a_reg.offset = 0;

	if p1 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null) then do;
	     p2 = c_a (46, 4);			/* store in double_temp */
	     p2 -> reference.c_length = length2;
	     p2 -> reference.temp_ref = TRUE;
	     p2 -> reference.data_type = bit_string;
	     p2 -> reference.ref_count = 2;
	     p2 -> reference.value_in.storage = TRUE;
	     call expmac$one ((sta), p2, fixed (length2 > bits_per_word, 1));
	     goto lg;
	end;
	else do;
	     if check_size then
		call check_stringsize;
	     goto string_store_work;
	end;

LABEL_ENTRY_OR_PTR:
	orig_count = p1 -> reference.ref_count;
	if type2 < unpacked_ptr then
	     goto lab_or_ent;

/* following check allows for initialization of file constants */

	if type1 = local_label_variable then
	     type1, p1 -> reference.data_type = unpacked_ptr;

	if type2 = unpacked_ptr then do;

/* NOTE:  All assignments of unpacked ptrs must be done through the pointer
 *        registers in order to validate the pointers' ring numbers
 */

	     if ^atomic then do;
		if type1 = unpacked_ptr then
		     if ^p2 -> reference.allocate then do;
						/* slide the LHS in as the target of the operator */
			exp_pt -> operand (1) = p1;
			call compile_exp (exp_pt);	/* and compile */
			goto done;
		     end;


		call compile_exp (exp_pt);		/* leave the temp in the machine state */
		p2 = exp_pt -> operator.operand (1);	/* and use it */
		goto CONVERT_UNPACKED_PTR_TO_SOMETHING;
	     end;

	     if s2 -> symbol.constant then do;

/* right side of assignment is a constant, it must be null ptr.
 * if left side is packed ptr, use packed representation of null
 */
		if type1 = packed_ptr then do;
		     p2, p -> operand (2) = generate_constant$real_fix_bin_1 (cg_stat$packed_null_value);
		     type2, p2 -> reference.data_type = packed_ptr;
		end;
	     end;
	end;

	if p2 -> reference.temp_ref then
	     if ^p1 -> reference.temp_ref then
		do i = 1 to 6;
		     if p2 -> reference.value_in.b (i) then do;
			if p1 -> reference.aligned_for_store_ref then
			     if ^p2 -> reference.shared then
				call adjust_ref_count (p2, -1);

			call base_to_core (i, p1);

/* have to decrement count after base_to_core rather
 * than before for unaligned refs so that temp can
 * be used for intermediate saving by base_to_core
 */

			if ^p1 -> reference.aligned_for_store_ref then
			     if ^p2 -> reference.shared then
				call adjust_ref_count (p2, -1);
			goto done;
		     end;
		end;

CONVERT_UNPACKED_PTR_TO_SOMETHING:
	if type1 < type2 | (type2 = packed_ptr & p1 -> reference.temp_ref) then do;
	     call base_man$load_packed (p, i);
	     if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
		call base_to_core (i, p1);
	     goto done;
	end;
	else if type2 = unpacked_ptr then
	     if p1 -> reference.temp_ref | ^s2 -> symbol.constant then
		if p1 -> reference.aligned_for_store_ref | p1 -> reference.hard_to_load then do;
		     if ^p2 -> reference.shared & p2 -> reference.temp_ref then
			call adjust_ref_count (p2, +1);
						/* base man will hit ref count even though the reference is evaluated already, potentially */
		     base = base_man$load_any_var (1, p2);
		     i = which_base (fixed (base, 3));
		     if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
			call base_to_core (i, p1);
		     else
			call base_man$update_base (1, p1, i);
		     goto done;
		end;

	call load (p2, 0);

	m2 = ptr_convert (type2, type1);
	goto l0;
%page;
/* have conversion to or from decimal or complex */

B (4):
	if s1 -> symbol.complex ^= s2 -> symbol.complex then
	     goto B4b;
	if type1 ^= type2 then
	     goto B4a;
	if scale1 ^= scale2 then
	     goto B4a;
	if p1 -> reference.c_length ^= p2 -> reference.c_length then
	     goto B4a;

	if p1 -> reference.aligned_for_store_ref & p2 -> reference.aligned_ref
	     & s1 -> symbol.unaligned = s2 -> symbol.unaligned then do;
	     if s2 -> symbol.decimal then
		if s2 -> symbol.unaligned then do;
		     units_per_wrd = packed_digits_per_word;
		     if s2 -> symbol.complex then
			c_length =
			     p2 -> reference.c_length + 2 * mod (divide (p2 -> reference.c_length, 2, 24, 0), 2);
		     else
			c_length = p2 -> reference.c_length;
		end;
		else do;
		     units_per_wrd = chars_per_word;
		     c_length = p2 -> reference.c_length;
		end;
	     else do;
		units_per_wrd = bits_per_word;
		c_length = p2 -> reference.c_length;
	     end;

	     call move_data$move_block (p1, p2, divide (c_length + units_per_wrd - 1, units_per_wrd, 17, 0));
	     goto done;
	end;

B4a:
	if s1 -> symbol.decimal then
	     if s2 -> symbol.decimal then do;
		macro = move_decimal;

		if max (scale1, scale2) <= max_dec_scale & min (scale1, scale2) >= min_dec_scale then
		     call assign_decimal;

		else if type1 = type2 then do;
		     if abs (scale1 - scale2) <= max_dec_scale - min_dec_scale then do;
			if scale1 > scale2 then
			     i = min_dec_scale;
			else
			     i = max_dec_scale;
			s1 -> symbol.scale = i + (scale1 - scale2);
			s2 -> symbol.scale = i;
		     end;
		     else do;
			macro = multiply_decimal;
			exponent.pad = "0"b;
			exponent.value = scale1 - scale2;
			s1 -> symbol.scale = 0;
			s2 -> symbol.scale = 0;
		     end;

		     call assign_decimal;

		     s1 -> symbol.scale = scale1;
		     s2 -> symbol.scale = scale2;
		end;
		else do;
		     macro = multiply_decimal;
		     exponent.pad = "0"b;

		     if scale1 > max_dec_scale | scale1 < min_dec_scale then
			exponent.value = scale1;
		     else
			exponent.value = -scale2;

		     call assign_decimal;
		end;

		goto done;
	     end;

B4b:
	if p1 -> reference.temp_ref & p1 -> reference.shared then do;
	     p1, p -> operand (1) = copy_temp (p1);
	     orig_count = 1;
	end;

	load_it =
	     p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p
	     & ^(s1 -> symbol.decimal | s1 -> symbol.complex);

	call convert_arithmetic (p1, p2, check_size, always_round);

	goto B2b;
%page;
/* have fixed binary = fixed binary */

B (5):
	if m1 ^= 0 then
	     call expmac$zero (m1);

	ds = scale1 - scale2;

	if ds ^= 0 then do;
	     k = max (type1, type2);
	     call scaler (ds, k);
	end;

	goto l1;
%page;
/* have float binary = fixed binary */

B (6):
	if scale2 = 0 then
	     goto B (1);

	call fixed_to_float (p2);
	if type1 = complex_flt_bin_1 then
	     call expmac$zero (rflb1_to_cflb1);
	goto l1;
%page;
/* have fixed binary = float binary */

B (7):
	if scale1 = 0 then
	     goto B (1);

	call float_to_fixed (p1);
	goto l1;
%page;
lab_or_ent:
	if p1 -> reference.temp_ref & ^cg_stat$save_exp_called then
	     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;

	if type1 = real_fix_bin_1 then do;
	     arg (1) = p1;
	     arg (2) = p2;
	     call expmac$many ((assign_label_to_int), addr (arg), 2);
	     goto done;
	end;

	if type1 = unpacked_ptr then do;
	     call base_man$store_ptr_to (p2, p1);
	     goto done;
	end;

	if type2 = ext_entry_in | type2 = ext_entry_out then do;
	     call base_man$load_var (2, p2, 1);

	     if ^p1 -> reference.shared then
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;

	     p1 -> reference.data_type = unpacked_ptr;
	     call base_to_core (1, p1);

	     p2 = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
	     p2 -> reference.data_type = unpacked_ptr;
	     call load (p2, 0);
	     call m_a (p1, "1"b);			/* can't have indirection in address */
	     p1 -> reference.perm_address = TRUE;

	     p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
	     call store$force (p1);
	     p1 -> reference.perm_address = FALSE;
	     p1 -> reference.data_type = type1;
	     goto done;
	end;

	b2 = s2 -> symbol.block_node;

	if type2 ^= label_constant then
	     if type2 ^= int_entry then
		goto le_1;

	if b2 -> block.level ^= cg_stat$cur_level then
	     goto le_2;

	call m_a (p1, "1"b);
	p1 -> reference.perm_address = TRUE;
	k = 1 + fixed (p1 -> address.base = bp, 1);
	call base_man$load_var (2, p2, k);
	call expmac ((set_label_const (k)), p1);
	goto done;

le_1:
	if type2 > entry_variable then do;
le_2:
	     arg (1) = p2;
	     arg (2) = c_a (cg_stat$cur_level - b2 -> block.level, 2);
	     call expmac$many ((make_lv), addr (arg), 2);

	     call m_a (p1, "0"b);
	     p1 -> reference.perm_address = TRUE;
	     call expmac ((store_lv), p1);
	end;

	else do;
	     if ^p1 -> reference.shared then
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     if ^p2 -> reference.shared then
		p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
	     call base_man$update_base (0, null, 1);
	     call make_both_addressable (p1, p2, "1"b);

	     do i = 1 to 2;
		p1 -> reference.perm_address = TRUE;
		p2 -> reference.perm_address = TRUE;
		call base_man$load_var (1, p2, 1);
		call base_to_core (1, p1);
		call state_man$flush_ref (p2);
		if i = 1 then do;
		     p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
		     substr (p2 -> address.tag, 1, 2) = "00"b;
		     p2 -> address.offset = bit (fixed (fixed (p2 -> address.offset, 15) + 2, 15), 15);
		end;
	     end;

	     p1 -> reference.perm_address = FALSE;
	     p2 -> reference.perm_address = FALSE;
	end;

	goto done;
%page;
/*
 *
 */
assign_op$length_of_varying:
     entry (pt, source);

	dcl      source ptr parameter;

	last_macro = FALSE;
	call load (source, 0);
	call expmac_length_of_varying ((stfx1), pt);
	return;
%page;
/*
 * entry to convert fixed decimal scaled input whose scale is out
 * of range to float decimal output
 */
assign_op$fix_dec_scaled:
     entry (pt);

	always_round, check_size = FALSE;
	p2 = pt;
	s2 = p2 -> reference.symbol;
	p1 = decimal_op$get_float_temp (s2 -> symbol.c_dcl_size, (s2 -> symbol.complex));
	s1 = p1 -> reference.symbol;
	macro = multiply_decimal;
	exponent.pad = "0"b;
	exponent.value = -s2 -> symbol.scale;
	call assign_decimal;
	pt = p1;
	return;
%page;
/*
 * entry to convert float decimal input to fixed decimal scaled output
 * whose scale is out of hardware range
 */
assign_op$to_dec_scaled:
     entry (pt, source);

	always_round, check_size = FALSE;
	p2 = source;
	p1 = pt;
	s1 = p1 -> reference.symbol;
	s2 = p2 -> reference.symbol;
	macro = multiply_decimal;
	exponent.pad = "0"b;
	exponent.value = s1 -> symbol.scale;
	call assign_decimal;
	if ^p1 -> reference.shared then
	     p1 -> reference.evaluated = TRUE;
	return;
%page;
/*
 * procedure to generate assignment macro for strings
 */
eis_move:
     proc;

	if p1 -> reference.temp_ref then
	     p1 -> reference.value_in.storage = TRUE;

	if ^(check_size & p1 -> reference.length ^= null) then do;
	     if all_same then do;
		call expmac$one_eis ((blank_cs), p1);
		if length2 > 0 then
		     addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> instruction.fill =
			substr (s2 -> symbol.initial -> based_cs, 1, 1);
		return;
	     end;

	     if all_ones then do;
		if p1 -> reference.aligned_for_store_ref then
		     if mod (size1, bits_per_char) = 0 then do;
			m1 = one_cs;
			call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1);
			return;
		     end;

		m1 = one_bs;
		call expmac$one_eis (m1, p1);
		return;
	     end;

	     if all_zeros then do;
		if p1 -> reference.aligned_for_store_ref then
		     if p1 -> reference.length = null then do;
			if p1 -> reference.padded_for_store_ref | mod (size1, bits_per_char) = 0 then do;
			     m1 = zero_cs;
			     call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1)
				;
			     return;
			end;
		     end;
		     else if p1 -> reference.padded_for_store_ref then do;
			call load_size (p1);
			if p1 -> reference.ref_count = 1 then
			     call need_temp (p1, "01"b);
			call expmac$zero ((b2c_mac));
			call expmac$one_eis ((zero_cs_q), p1);
			return;
		     end;

		m1 = zero_bs;
		call expmac$one_eis (m1, p1);
		return;
	     end;
	end;

	if check_size then
	     macro = chars_move_ck;
	else
	     macro = chars_move;

	call expmac$two_eis (macro + dt, p1, p2);
     end eis_move;
%page;
/*
 * this procedure gets the length expression of a string and increments
 * reference count preparatory to its use in a macro
 */
get_length:
     proc (pt) returns (ptr);

	dcl      pt ptr parameter;
	dcl      (q, q1) ptr;

	q = pt -> reference.length;

	if q ^= null then do;
	     if q -> node.type = operator_node then do;
		q1 = q -> operand (1);
		if q1 -> reference.shared then
		     q -> operand (1) = copy_temp (q1);
		q = q -> operand (1);
	     end;

	     if ^q -> reference.shared then
		q -> reference.ref_count = q -> reference.ref_count + 1;
	end;

	return (q);
     end get_length;
%page;
/*
 * this procedure  gets the length of a reference such that it can be
 * used in storage by a fullword instruction. This routine may emit code.
 * This routine was written to fix 1754.
 */
get_length_in_storage:
     proc (pt) returns (ptr);

	dcl      pt ptr parameter;
	dcl      p ptr;

	p = get_length ((pt));

	if p ^= null then
	     if ^p -> reference.aligned_ref then
		p = compile_exp$save (p);

	return (p);

     end get_length_in_storage;
%page;
/*
 * this procedure gets the length needed by the section that handles
 *   	vs = vs || expr;
 * this MAY emit code.
 */
get_suffix_length:
     proc (pt) returns (ptr);

	dcl      pt ptr parameter;
	dcl      (p, q) ptr;

	p = pt;

	q = get_length_in_storage (p);

	if q = null then do;
	     if p -> reference.c_length ^= 0 | ^p -> reference.varying_ref then
		q = generate_constant$real_fix_bin_1 ((p -> reference.c_length));
	end;
	else if q -> reference.data_type = real_fix_bin_2 then
	     q = get_single_ref (q);

	return (q);

     end get_suffix_length;
%page;
/*
 *  this procedure executes a macro on the length word of a varying string
 */
expmac_length_of_varying:
     proc (macro, pt);

	dcl      macro fixed bin (15) parameter;
	dcl      pt ptr parameter;

	dcl      p ptr;
	dcl      addr_hold bit (36) aligned;
	dcl      reloc_hold bit (12) aligned;

	p = pt;

	if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then do;
						/* same restriction on temp_ref as in m_a */
	     if p -> address.offset ^= (15)"0"b | p -> reference.no_address then
		call m_a (p, "00"b);
	     p -> address.offset = (15)"1"b;
	end;
	else do;
	     addr_hold = string (p -> reference.address);
	     reloc_hold = p -> reference.relocation;
	     p -> reference.c_offset = p -> reference.c_offset - 1;
	     call m_a (p, "00"b);
	     p -> reference.c_offset = p -> reference.c_offset + 1;
	end;

	p -> reference.perm_address = TRUE;

	if ^last_macro then
	     if ^p -> reference.shared then
		p -> reference.ref_count = p -> reference.ref_count + 1;

	call expmac (macro, p);

	p -> reference.perm_address = FALSE;

	if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then
	     p -> address.offset = (15)"0"b;
	else do;
	     string (p -> reference.address) = addr_hold;
	     p -> reference.relocation = reloc_hold;
	end;

     end expmac_length_of_varying;
%page;
/*
 *
 */
scaler:
     proc (amt, type);

	dcl      (amt, type) fixed bin parameter;

	if amt < 0 then do;
	     call xr_man$load_const (abs (amt), 2);
	     call expmac$zero ((truncate (type)));
	end;
	else
	     call expmac ((left_shift (type)), c_a (amt, 1));

     end scaler;
%page;
/*
 * this procedure compares two references ignoring the two length fields
 */
compare_refs:
     proc (p1, p2) reducible returns (bit (1) aligned);

	dcl      (p1, p2) ptr parameter;

	if p1 -> reference.symbol ^= p2 -> reference.symbol then
	     return (FALSE);
	else if p1 -> reference.c_offset ^= p2 -> reference.c_offset then
	     return (FALSE);
	else if ^compare_expression ((p1 -> reference.offset), (p2 -> reference.offset)) then
	     return (FALSE);
	else if ^compare_expression ((p1 -> reference.qualifier), (p2 -> reference.qualifier)) then
	     return (FALSE);
	else
	     return (TRUE);

     end compare_refs;
%page;
/*
 *
 */
adjust_suff_temp:
     proc (pt);

	dcl      pt ptr parameter;
	dcl      p ptr;

	p = pt;
	top = p -> reference.length;
	call adjust_suff_op (top);
	call adjust_ref_count (p, -1);

     end adjust_suff_temp;
%page;
/*
 *
 */
adjust_suff_op:
     proc (pt);

	dcl      pt ptr parameter;
	dcl      (p, q) ptr;
	dcl      i fixed bin;

	p = pt;

	if p -> node.type = operator_node then do;
	     q = p -> operand (1);
	     if ^q -> reference.evaluated then
		if q -> reference.ref_count <= 1 then
		     do i = 2 to p -> operator.number;
			if p -> operand (i) ^= null then
			     call adjust_suff_op ((p -> operand (i)));
		     end;
	end;
	else
	     q = p;

	if p ^= top then
	     if q -> node.type = reference_node then
		if ^q -> reference.shared then
		     call adjust_ref_count (q, -1);

	return;

     end adjust_suff_op;
%page;
/*
 * this issues macro(s) to effect the assignment of a decimal variable
 */
assign_decimal:
     proc;

	dcl      (mac, ninst) fixed bin (15);
	dcl      arg (2, 3) ptr;

	mac = macro + fixed (s1 -> symbol.float | always_round, 1);

	if macro = multiply_decimal then do;
	     arg (1, 3), arg (2, 3) = generate_constant$char_string ("+1" || exponent_char, 3);
	     k = 3;
	end;
	else
	     k = 2;

	ninst = fixed (s1 -> symbol.complex, 1) + 1;

	arg (1, 1) = p1;
	arg (1, 2) = p2;

	if ninst > 1 then do;
	     arg (2, 1) = get_imaginary (p1);
	     arg (2, 2) = get_imaginary (p2);
	end;

	do i = 1 to ninst;
	     call expmac$many_eis (mac, addr (arg (i, 1)), k);

	     if check_size then
		if s1 -> symbol.fixed then
		     call expmac$zero ((size_ck_decimal));
	end;

     end assign_decimal;
%page;
/*
 * this issues warning about stringsize occuring at runtime
 * and generates unconditional signal of stringsize
 */
check_stringsize:
     proc;

	if length1 < length2 then do;
	     if ^cg_stat$cur_statement -> statement.suppress_warnings then
		call error (319, cg_stat$cur_statement, null);
	     call expmac$zero ((signal_stringsize));
	end;

     end check_stringsize;
     end assign_op;




		    assign_storage.pl1              12/01/87  1601.3rew 12/01/87  1555.1      143559



/****^  ***********************************************************
        *                                                         *
        * 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 bug2174
                                                   END HISTORY COMMENTS */


/* This procedure is called to assign storage to all blocks

   Revised Version: 15 April 1971 by BLW
	Modified: 22 January 1973 by BLW for controlled storage
	Modified:	18 April 1975 by RHS for options(constant)
	Modified:	5 June 1975 by EEW for separate_static
	Modified:	19 June 1975 by RAB for listing label arrays
	Modified:	24 November 1975 by RAB to fix 1439
	Modified:	31 March 1976 by RAB to fix 1481,
		introduced by fix of 1439
	Modified:	21 October 1976 by RAB to improve conversion of static
		to constant
	Modified:	5 April 1978 by RAB to detect infinite loop while finding level of quick block
	Modified: 23 April 1979 by PCK to implement 4-bit decimal.
          Modified: 18 June 1987 by RW to fix 2174 by checking segment size when
		static storage is allocated.
*/

assign_storage: proc(pt) ;

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

dcl	(cg_static_$cur_block,cg_static_$format_list,cg_static_$temporary_list,
	cg_static_$stat_base,cg_static_$text_base,cg_static_$link_base,cg_static_$constant_list,
	cg_static_$label_list,cg_static_$last_label) ptr ext,
	(cg_static_$separate_static,cg_static_$generate_symtab,cg_static_$table_option) bit(1) ext,
	(cg_static_$text_pos,cg_static_$stat_pos,cg_static_$link_pos,
	 cg_static_$cur_level,cg_static_$max_stack_size, cg_static_$max_program_size) fixed bin(17) ext;

dcl	(block_pt,blk_pt,sym_pt,ref_pt,bp,p,q,q1,static_base,pos_pt) ptr,
	(auto_ctr,loc,cfo,c,r,t,n,units,a_units,datum_size,bit_length,increment) fixed bin(17),
	err_no fixed bin,
	(not_set,no_runtime_symbol) bit(1) aligned,
	cptr(3) ptr based,
	static_pos fixed bin(17) based,
	error entry(fixed bin,ptr,ptr),
	cg_error entry(fixed bin,fixed bin),
	assign_storage entry(ptr),
	initialize_int_static entry(ptr,ptr),
	create_list entry(fixed bin) returns(ptr);

dcl	(addrel,divide,fixed,max,mod,null) builtin;

dcl	fo_mult(0:5) fixed bin(17,1) int static init(0,1,4.5,9,18,0),
	bits_per_char fixed bin int static init(9),
	param_array fixed bin int static init(64);

dcl	fix_bin fixed bin based,
	buffer(datum_size) fixed bin based;

%include pl1_tree_areas;
%include nodes;
%include block;
%include statement;
%include symbol;
%include label;
%include array;
%include reference;
%include list;
%include block_types;
%include boundary;
%include system;
%include declare_type;

	block_pt, blk_pt = pt;

	if cg_static_$separate_static
	then do;
	     static_base = cg_static_$stat_base;
	     pos_pt = addr(cg_static_$stat_pos);
	     end;
	else do;
	     static_base = cg_static_$link_base;
	     pos_pt = addr(cg_static_$link_pos);
	     end;

again:	if block_pt = null then return;
	cg_static_$cur_block = block_pt;

	no_runtime_symbol = ^ (cg_static_$table_option | cg_static_$generate_symtab);

	if block_pt -> block.no_stack
	then do;

	     /* get ptr to block owning this quick block */

	     do while(blk_pt -> block.no_stack);
		if blk_pt -> block.owner = null then blk_pt = blk_pt -> block.father;
		else blk_pt = blk_pt -> block.owner;
		end;

	     /* the level of a quick block is that of the block in which
	        its storage is being allocated;  the level of that block,
	        if not previously set, is that of its parent + 1.
	        (Iterate, if necessary.) */

	     increment = 0;
	     bp = blk_pt;
	     do while(bp -> block.level = 0);
		bp -> block.last_auto_loc = max(param_array,bp -> block.last_auto_loc);
		increment = increment + 1;
		bp = bp -> block.father;

		do while(bp -> block.no_stack);
		     if bp = block_pt	/* without this test, the compiler could loop if this were true */
		     then do;

			/* we have a loop in owner-father chain, so block_pt is unreachable */

			call error(267,null,(bp -> block.main -> statement.labels -> element(2)));
			bp -> block.why_nonquick.never_referenced = "1"b;
			bp -> block.no_stack = "0"b;
			blk_pt = block_pt;
			go to again;
			end;

		     if bp -> block.owner = null
			then bp = bp -> block.father;
			else bp = bp -> block.owner;
		     end;

		end;

	     cg_static_$cur_level = bp -> block.level + increment;

	     /* assign space for no_stack block in the ancestor block,
	        reserving space for entry & return info if needed */

	     auto_ctr = blk_pt -> block.last_auto_loc;
	     if block_pt -> block.block_type ^= begin_block
	     then do;
		auto_ctr = auto_ctr + mod(auto_ctr,2);	/* make even */
		block_pt -> block.entry_info = auto_ctr;
		auto_ctr = auto_ctr + 6;

		if auto_ctr > cg_static_$max_stack_size
		then call cg_error(308,cg_static_$max_stack_size);
		end;

	     end;
	else do;
	     cg_static_$cur_level = blk_pt -> block.father -> block.level + 1;
	     auto_ctr = max(param_array,blk_pt -> block.last_auto_loc);
	     end;

	block_pt -> block.level = cg_static_$cur_level;

	sym_pt = block_pt -> block.declaration;

	do while(sym_pt ^= null);

	     if sym_pt -> node.type = label_node
	     then do;

		if sym_pt -> label.array
		then do;
		     sym_pt -> label.location = cg_static_$text_pos;
		     cg_static_$text_pos = cg_static_$text_pos + (sym_pt -> label.high_bound -
		      sym_pt -> label.low_bound + 1);
		     sym_pt -> label.allocated = "1"b;

		     p = create_list(2);
		     p -> list.element(2) = sym_pt;
		     if cg_static_$last_label ^= null
			then cg_static_$last_label -> list.element(1) = p;
			else cg_static_$label_list = p;
		     cg_static_$last_label = p;
		     end;

		goto loop;
		end;

	     /* if we have a format, put it on a list for later processing */

	     if sym_pt -> symbol.format & sym_pt -> symbol.constant
	     then do;
		p = create_list(2);
		p -> list.element(2) = sym_pt;
		p -> list.element(1) = cg_static_$format_list;
		cg_static_$format_list = p;
		goto loop;
		end;

	     if sym_pt -> symbol.varying then goto no;

	     if sym_pt -> symbol.packed then goto contig;

	     if ^ sym_pt -> symbol.bit
	     then if ^ sym_pt -> symbol.char
		then goto no;

	     /* The following section sets the contiguous bit ON if a reference
	        to the datum never overlaps a word boundary;  the algorithm is
	        due to Jim Gimpel and is described in MSPM BN.9.01 */

contig:	     if sym_pt -> symbol.dcl_size ^= null then goto no;

	     q = sym_pt -> symbol.array;
	     if q = null then bit_length = sym_pt -> symbol.c_bit_size;
	     else bit_length = q -> array.c_element_size_bits;

	     if bit_length = 0 then goto no;

	     if bit_length = 1 then goto yes;

	     if sym_pt -> symbol.char
	     then if bit_length = bits_per_char
		then goto yes;

	     ref_pt = sym_pt -> symbol.reference;
	     units = ref_pt -> reference.units;

	     if ref_pt -> reference.offset ^= null
	     then if units < word_ then goto no;

	     cfo = mod(ref_pt -> reference.c_offset * fo_mult(units),bits_per_word);

	     if q = null
	     then if cfo + bit_length <= bits_per_word
		then goto yes; else goto no;

	     if q -> virtual_origin ^= null then goto no;

	     a_units = q -> array.offset_units;
	     n = mod(q -> c_virtual_origin * fo_mult(a_units),bits_per_word);

	     c = cfo - n;
	     r = 36;
	     q = q -> array.bounds;

	     do while(q ^= null);
		n = q -> c_multiplier;
		if n = 0 then goto no;

		n = mod(n * fo_mult(a_units),bits_per_word);
gcd:		t = mod(n,r);

		if t ^= 0
		then do;
		     n = r;
		     r = t;
		     goto gcd;
		     end;

		q = q -> bound.next;
		end;

	     if bit_length + mod(c,r) <= r then  
yes:	     sym_pt -> symbol.contiguous = "1"b;

no:	     if ^ sym_pt -> symbol.allocate & no_runtime_symbol then goto loop;
	     if sym_pt -> symbol.father ^= null then goto loop;

	     cg_static_$generate_symtab = cg_static_$generate_symtab | sym_pt -> symbol.put_in_symtab;

	     /* have a symbol that has to be allocated, check for referenced
	        but not set */

	     not_set = "0"b;
	     if ^ sym_pt -> symbol.allocate then goto disp;
	     if block_pt -> block.get_data then goto disp;
	     if sym_pt -> symbol.dcl_type = by_compiler then goto disp;
	     if sym_pt -> symbol.aliasable then goto disp;
	     if sym_pt -> symbol.area then goto disp;

	     /* following eliminates error 307 for
		dcl a based(p);
	        where "p" is never references in program */

	     if (sym_pt -> symbol.ptr | sym_pt -> symbol.offset)
	     then if sym_pt -> symbol.put_in_symtab
		then goto disp;

	     not_set = ^ (sym_pt -> symbol.set | sym_pt -> symbol.passed_as_arg);

	     /* the only storage classes we handle are auto and int static */

disp:	     if sym_pt -> symbol.auto
	     then do;
		if ^ sym_pt -> symbol.structure & not_set
		then call error(307,null,sym_pt);

		call assign_datum(sym_pt,auto_ctr);

		if auto_ctr > cg_static_$max_stack_size
		then call cg_error(308,cg_static_$max_stack_size);

                    if cg_static_$text_pos > cg_static_$max_program_size
                    then call cg_error(311,cg_static_$max_stack_size);

		goto fl;
		end;

	     if sym_pt->symbol.controlled & ^sym_pt->symbol.arg_descriptor
	     then do;
		if sym_pt->symbol.internal
		then do;
		     sym_pt->symbol.allocated = "1"b;
		     if not_set & ^sym_pt->symbol.structure & sym_pt->symbol.initial = null
			then call error(307,null,sym_pt);
		     loc = pos_pt -> static_pos;
		     loc = loc + mod(loc,2);
		     pos_pt -> static_pos = loc + 6;
		     sym_pt->symbol.location = loc;
		     q = addrel(static_base,loc);
		     q->cptr(1) = null;
		     q->cptr(2) = null;
		     q->cptr(3) = null;
		     end;

flc:		q = sym_pt->symbol.descriptor->reference.symbol;
		if q->symbol.controlled
		then do;
			if sym_pt->symbol.external
			then do;
				q->symbol.external = "1"b;
				q->symbol.internal = "0"b;
			     end;
			else do;
				q->symbol.location = loc + 2;
				q->symbol.allocated = "1"b;
			     end;
		     end;
		go to fl;
		end;

	     if sym_pt -> symbol.file
	     then if sym_pt -> symbol.constant
		then if sym_pt -> symbol.internal
		     then goto int_stat;

	     if sym_pt -> symbol.static
	     then do;

		if ^ sym_pt -> symbol.internal then goto fl;

int_stat:		datum_size = sym_pt -> symbol.c_word_size;

		if not_set | sym_pt -> symbol.alloc_in_text
		then do;

		     if ^ sym_pt -> symbol.structure & sym_pt -> symbol.initial = null
		     then do;
			if sym_pt -> symbol.alloc_in_text
			then do;
			     call error(482,null,sym_pt);
			     sym_pt->alloc_in_text = "0"b;
			     goto int_stat;
			     end;

		          else call error(307,null,sym_pt);

		          sym_pt -> symbol.allocated = "1"b;
		          goto fl;
		          end;

		     if sym_pt -> symbol.son ^= null then goto tx;

		     /* turn into a constant */

		     sym_pt -> symbol.multi_use = cg_static_$constant_list;
		     cg_static_$constant_list = sym_pt;

		     if datum_size > 1
		     then do;
			allocate buffer in(tree_area) set(q);
			goto ci;
			end;

		     n = 0;
		     call initialize_int_static(sym_pt,addr(n));

		     p = sym_pt -> symbol.multi_use;
		     do while(p ^= null);
			q = p -> symbol.initial;

			if datum_size <= p -> symbol.c_word_size
			then if q -> fix_bin = n
			     then do;
				if p -> symbol.equivalence = null
				     then sym_pt -> symbol.equivalence = p;
				     else sym_pt -> symbol.equivalence = p -> symbol.equivalence;

				if p -> symbol.allocated
				then do;
				     sym_pt -> symbol.location = p -> symbol.location;
				     sym_pt -> symbol.allocated = "1"b;
				     end;
				else if no_runtime_symbol
				     then sym_pt -> symbol.allocate = "0"b;
				     else sym_pt->symbol.equivalence -> symbol.allocate = "1"b;

				goto si;
				end;

			p = p -> symbol.multi_use;
			end;

		     /* there was no existing constant with this value as a prefix */

		     allocate fix_bin in(tree_area) set(q);
		     q -> fix_bin = n;

		     goto si;

		     /* assign to text section */

tx:		     loc = cg_static_$text_pos;
		     if sym_pt -> symbol.boundary = mod2_ | datum_size = 2
		     then loc = loc + mod(loc,2);

		     cg_static_$text_pos = loc + datum_size;

		     sym_pt -> symbol.location = loc;
		     sym_pt -> symbol.allocated = "1"b;

		     q = addrel(cg_static_$text_base,loc);

ci:		     call initialize_int_static(sym_pt,q);

si:		     sym_pt -> symbol.initial = q;
		     sym_pt -> symbol.constant = "1"b;
		     sym_pt -> symbol.static = "0"b;

		     goto fl;
		     end;

		call assign_datum(sym_pt,pos_pt->static_pos);

		if sym_pt -> symbol.initial ^= null | sym_pt -> symbol.area
		then call initialize_int_static(sym_pt,addrel(static_base,loc));

fl:		q = sym_pt -> symbol.son;
		if q ^= null then call fill_loc(q);

		end;

loop:	     sym_pt = sym_pt -> symbol.next;
	     end;

	/* finished with user storage, now do temps */

	if block_pt -> block.block_type ^= root_block then goto done;

	sym_pt = cg_static_$temporary_list;
	do while(sym_pt ^= null);

	     if sym_pt -> symbol.allocate
	     then call assign_datum(sym_pt,auto_ctr);

	     sym_pt = sym_pt -> symbol.next;
	     end;

done:	blk_pt -> block.last_auto_loc = auto_ctr;

	p = block_pt -> block.son;
	if p ^= null then call assign_storage(p);

	blk_pt, block_pt = block_pt -> block.brother;
	goto again;

assign_datum:  proc(s,ctr);

dcl	     s ptr,
	     ctr fixed bin(17);

dcl	     (amt,k) fixed bin(17),
	     my_s ptr;

	     my_s = s;

	     amt = my_s -> symbol.c_word_size;
	     if my_s -> symbol.boundary = mod2_ | amt = 2
	     then ctr = ctr + mod(ctr,2);

	     loc = ctr;
	     ctr = ctr + amt;

	     my_s -> symbol.location = loc;
	     my_s -> symbol.allocated = "1"b;

	     end;

fill_loc:	     proc(s);

dcl	     s ptr;

dcl	     (p,q,p1) ptr;

	     p = s;
repeat:	     if p = null then return;

	     p -> symbol.location = loc;
	     p -> symbol.allocated = "1"b;

	     /* if father is external, set son external also */

	     if p -> symbol.father -> symbol.external
	     then do;
		p -> symbol.internal = "0"b;
		p -> symbol.external = "1"b;
		goto do_son;
		end;

	     if p -> symbol.cross_references = null then goto l1;
	     if cg_static_$generate_symtab then goto l1;
	     if p -> symbol.aliasable then goto l1;
	     if p -> symbol.dcl_type = by_compiler then goto l1;
	     if p -> symbol.set then goto l1;
	     if p -> symbol.passed_as_arg then goto l1;
	     if p -> symbol.structure then goto l1;

	     if p -> symbol.auto
	     then do;
		call error(307,null,p);
		goto l1;
		end;

	     if (p->symbol.static|p->symbol.controlled) & p->symbol.internal
	     then if p -> symbol.initial = null
		then call error(307,null,p);

	     /* check for switch into text segment */

l1:	     if p -> symbol.father -> symbol.constant
	     then do;
		p -> symbol.constant = "1"b;
		p -> symbol.static, p -> symbol.auto = "0"b;
		p1 = cg_static_$text_base;
		end;
	     else p1 = static_base;

	     p1 = addrel(p1,loc);

	     if p -> symbol.static | p -> symbol.constant
	     then if p -> symbol.initial ^= null | p -> symbol.area
		then call initialize_int_static(p,p1);

	     if p -> symbol.constant then p -> symbol.initial = p1;

do_son:	     q = p -> symbol.son;
	     if q ^= null then call fill_loc(q);

	     p = p -> symbol.brother;
	     goto repeat;
	     end;

	end;




		    base_man.pl1                    10/03/83  1730.5rew 10/03/83  1007.9      309015



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */


/* format: style3 */
/* Procedure to manage base registers

   The contents of the base registers are determined by the value
   of the type field as follows (P = variable field, N = constant field)

          0         EMPTY
          1         value of reference specified by P
          2         address of reference specified by P
          3         value of ptr contained at N in current stack
          4         ptr to display for block N levels back
          5         ptr to linkage section
          6         arg ptr for block P
          7         desc ptr for block P
          8         ptr thru link with offset N
          9         ptr to arg N in block P
         10         ptr to desc N in block P
         11         ptr to data of ext ctl variable with link N
         12         ptr to desc of ext ctl variable with link N
         13         ptr to static section
         14         ptr through ptr in static with offset N

   Initial Version: 16 April 1971 by BLW
          Modified:  11 May 1973 by RAB  for multiple base regs
          Modified: 19 June 1973 by RAB for EIS
          Modified: 19 July 1974 by RAB to load arg ptr in any reg
          Modified: 4 June 1975 by RAB for separate_static
          Modified: 20 August 1976 by RAB to fix 1512
          Modified: 22 January 1979 by RAB to fix 1814 (ERROR 313 for multiple
                    occurrences of based packed qualifier in if stmt)
                    prepare_operand now sets reference.evaluated after call to
                    base_man$load_packed
          Modified: 23 April 1979 by PCK to implement 4-bit decimal
          Modified: 2 September 1982 by BIM for load_aq_var
	Modified: June 1983 BIM for ref count fixes.
*/

base_man$load_any_var:
     proc (code, var, base3);

dcl       code                fixed bin,                    /* how to load */
          var                 ptr,                          /* ptr to ref */
          base3               bit (3) aligned;              /* set to base loaded */

dcl       (i, j, k, n, text_pos, type, ca_code)
                              fixed bin,
          (vp, p, q)          ptr,
          (
          cg_stat$cur_level,
          cg_stat$text_pos,
          cg_stat$last_base_used
          )                   fixed bin ext,
          cg_stat$separate_static
                              bit (1) aligned ext static,
          (
          cg_stat$text_base,
          cg_stat$cur_statement
          )                   ptr ext static,
          (addressable, atomic)
                              bit (1) aligned,
          eis                 bit (1) aligned,
          lock                bit (1) aligned init ("0"b),
          tag_hold            bit (6) aligned,
          fract_offset        fixed bin,
          xr                  fixed bin (3),
          base                bit (3) aligned,
          full_word           bit (36) aligned based,
          macro               fixed bin (15),
          load                entry (ptr, fixed bin),
          prepare_operand     entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
          copy_temp           entry (ptr) returns (ptr),
          base_to_core        entry (fixed bin, ptr),
          base_man$load_var   entry (fixed bin, ptr, fixed bin),
          base_man$load_display
                              entry (fixed bin, bit (3) aligned),
          base_man$load_linkage
                              entry (bit (3) aligned),
          base_man$load_arg   entry (fixed bin, ptr, bit (3) aligned),
          base_man$load_any_var
                              entry (fixed bin, ptr, bit (3) aligned),
          base_man$load_link_indirect
                              entry (fixed bin, bit (12) aligned, bit (3) aligned),
          xr_man$load_any_const
                              entry (fixed bin, fixed bin (3)),
          xr_man$add_any_const
                              entry (fixed bin, fixed bin (3), fixed bin (3)),
          m_a                 entry (ptr, bit (2) aligned),
          c_a                 entry (fixed bin, fixed bin) returns (ptr),
          compile_exp$save    entry (ptr) returns (ptr),
          get_reference       entry () returns (ptr),
          adjust_ref_count    entry (ptr, fixed bin),
          expmac              entry (fixed bin (15), ptr),
          expmac$zero         entry (fixed bin (15)),
          error               entry (fixed bin, ptr, ptr);

declare   new_base            bit (3) aligned;
declare   a_q_aq              fixed bin;                    /* Zero, one, two */
declare   want_a_PR           bit (1) aligned init ("1"b);

dcl       (abs, addrel, bit, fixed, mod, null, string, substr)
                              builtin;

dcl       (
          first_base          init (3),
          last_base           init (6)
          )                   fixed bin (3) int static options (constant);

dcl       (
          load_base           (0:1, 6) init (60, 361, 618, 619, 620, 621,
                                                            /* unpacked */
                              636, 637, 638, 639, 640, 641),/* packed */
          store_base          (23:24, 6) init (61, 409, 622, 623, 624, 625,
                                                            /* unpacked */
                              630, 631, 632, 633, 634, 635) /* packed */
          )                   fixed bin (15) int static options (constant);


declare   e_a_q_aq_mac        (0:2) init (370, 371, 376) fixed bin (15) int static options (constant);

dcl       add_base            (3) init (643, 736, 644) fixed bin (15) int static options (constant);

dcl       (
          load_bp             init (60),
          store_bp            init (61),
          load_lp             init (361),
          packed_into_bp      init (584),
          stfx1               init (15),
          load_link_ptr       init (283)
          )                   fixed bin (15) int static options (constant);

dcl       stack_info          (0:1) fixed bin int static options (constant) init (26,
                                                            /* stack offset of arg list */
                              34);                          /* stack offset of desc list */

dcl       link_info           (0:1) fixed bin int static options (constant) init (36,
                                                            /* stack offset of linkage ptr */
                              28);                          /* stack offset of static ptr */

dcl       display_offset      fixed bin int static init (32) options (constant);

%include op_codes;
%include operator;
%include block;
%include machine_state;
%include symbol;
%include cg_reference;
%include bases;
%include relocation_bits;
%include nodes;
%include boundary;
%include cgsystem;

/* This entry handles types 1 -3 and only loads bp */

begin:
          n = code;                                         /* see list of values above */
          j, k = -1;
          want_a_PR = "1"b;
          go to load_any_var_load_aq_common;

load_aq_var:
     entry (var);

/* ASSUMPTIONS: this will only be called with pointer values */

          n = 1;
          j, k = -1;
          want_a_PR = "0"b;
          a_q_aq = 2;                                       /* AQ */
          go to load_any_var_load_aq_common;

load_a_var:
     entry (var);

          n = 1;
          j, k = -1;
          want_a_PR = "0"b;
          a_q_aq = 0;
          go to load_any_var_load_aq_common;

load_q_var:
     entry (var);

          n = 1;
          j, k = -1;
          want_a_PR = "0"b;
          a_q_aq = 1;

load_any_var_load_aq_common:
          vp = var;

/* Search the registers to see if we already have the registers */

          do i = 1 to last_base;
               type = base_regs (i).type;
               if type = 0
               then k = i;
               else if type = n                             /* contains the address type */
               then if base_regs (i).variable = vp
                    then do;
                              if ^want_a_PR
                              then go to PR_to_AQ;
                              if ^vp -> reference.shared
                              then call adjust_ref_count (vp, -1);
                              base3 = bases (i);
                              go to reset_perm;
                         end;
          end;

/* We must load a register */

          call when_to_m_a;
          if ^want_a_PR
          then go to load_AQ;
          i = get_free_base ();
          base3 = bases (i);
          go to l1a;

PR_to_AQ:                                                   /* come here with the PR number in i */
          string (vp -> address) = ""b;
          vp -> address.base = bases (i);                   /* fix the reference */
          vp -> address.ext_base = "1"b;
          vp -> reference.perm_address = "1"b;
          vp -> reference.relocation = ""b;                 /* Has to be absolute, its XXXX prn|0 */
          call expmac (e_a_q_aq_mac (a_q_aq), vp);
          go to AQ_finish;

load_AQ:
          if ^addressable
          then do;
                    call m_a (vp, "00"b);
                    vp -> reference.perm_address = "1"b;
               end;

          if substr (vp -> address.tag, 1, 2)               /* Is there a star ? */
          then do;
                    if ^vp -> reference.shared
                    then vp -> reference.ref_count = vp -> reference.ref_count + 1;
                    call base_man$load_any_var (n, var, new_base);
                    i = which_base (bin (new_base, 3));
                    go to PR_to_AQ;
               end;

          substr (vp -> address.tag, 1, 2) = "01"b;         /* convert to RI mod */
          call expmac (e_a_q_aq_mac (a_q_aq), vp);

AQ_finish:
          vp -> reference.perm_address = "0"b;              /* force m_a to recalculate, since we may have patched the tag */
          return;

base_man$load_any_var_and_lock:
     entry (code, var, base3);

          lock = "1"b;
          go to begin;


base_man$load_var_and_lock:
     entry (code, var, which);

          lock = "1"b;


base_man$load_var:
     entry (code, var, which);

dcl       which               fixed bin;                    /* which base to load */

          i = which;
          j, k = -1;

          vp = var;
          n = code;
          call when_to_m_a;

/* See if item is already in a pointer register */

          do k = 1 to last_base;
               if base_regs (k).type = n
               then if base_regs (k).variable = vp
                    then if k = i
                         then do;
                                   if ^vp -> reference.shared
                                   then call adjust_ref_count (vp, -1);
                                   go to reset_perm;
                              end;
                         else j = k;
          end;

/* Section to load the pointer register */


          do;
               cg_stat$last_base_used = i;
l1a:
               macro = load_base (0, i);

/* If we have the item in another pointer register, move it over */

               if j >= 0
               then do;
                         call change_base (i);
                         p = c_a (0, 4);
                         p -> address.base = bases (j);
                         call expmac (macro, p);
                         if ^vp -> reference.shared
                         then call adjust_ref_count (vp, -1);
                         if n = 2
                         then do;
                                   vp -> reference.address_in.b (i) = "1"b;
                                   go to l2;
                              end;
                         else go to l1b;
                    end;

/*  To get the item, we must make it addressable */

               if ^addressable
               then do;
                         call m_a (vp, "0"b || eis);
                         vp -> reference.perm_address = "1"b;
                    end;

               call change_base (i);


               if n = 2
               then do;

                         if eis
                         then do;                           /* mask out the tag */
                                   tag_hold = vp -> address.tag & "001111"b;
                                   vp -> address.tag = vp -> address.tag & "010000"b;
                              end;

                         call expmac (macro, vp);

                         if vp -> reference.units ^= word_
                         then do;
                                   macro = add_base (vp -> reference.units);
                                   p = get_reference ();
                                   string (p -> reference.address) = bases (i);
                                   p -> address.ext_base = "1"b;
                                   p -> reference.relocation = "0"b;
                                   p -> reference.perm_address = "1"b;

                                   if eis
                                   then do;
                                             if vp -> reference.c_f_offset ^= 0
                                             then call add_cfo;
                                             p -> address.tag = tag_hold;
                                        end;
                                   else do;
                                             fract_offset =
                                                  mod (vp -> reference.c_offset, units_per_word (vp -> reference.units));
                                             if fract_offset < 0
                                             then fract_offset = fract_offset + units_per_word (vp -> reference.units);
                                             call xr_man$load_any_const (fract_offset, xr);
                                             p -> address.tag = "001"b || bit (xr, 3);
                                        end;

                                   if p -> address.tag
                                   then call exp_addmac;
                              end;

                         if vp -> reference.symbol ^= null
                         then do;
                                   string (vp -> reference.address) = bases (i);
                                   vp -> address.ext_base = "1"b;
                                   vp -> reference.relocation = "0"b;
                                   vp -> reference.c_f_offset = 0;
                                   vp -> reference.ic_ref = "0"b;
                              end;

                         vp -> reference.address_in.b (i) = "1"b;

                         goto l2;
                    end;

               if substr (vp -> address.tag, 1, 2)
               then do;
                         if ^vp -> reference.shared
                         then vp -> reference.ref_count = vp -> reference.ref_count + 1;
                         call expmac (macro, vp);
                         string (vp -> reference.address) = bases (i);
                         vp -> address.ext_base = "1"b;
                         vp -> address.tag = "010000"b;     /* * */
                         vp -> reference.relocation = "0"b;
                    end;
               else substr (vp -> address.tag, 1, 2) = "01"b;
                                                            /* convert to RI mod */

               call expmac (macro, vp);

l1b:
               vp -> reference.value_in.b (i) = "1"b;
l2:
               base_regs (i).variable = vp;

               base_regs (i).type = n;
               if lock
               then base_regs (i).locked = base_regs (i).locked + 1;
               else base_regs (i).locked = 0;

          end;

reset_perm:
          if vp -> reference.symbol ^= null
          then vp -> reference.perm_address = "0"b;

used_i:
          base_regs (i).used = cg_stat$text_pos;
          return;

base_man$load_stack_indirect:
     entry (code, base2);

          n = code;

          k = -1;
          do i = 1 to last_base;
               type = base_regs (i).type;
               if type = 0
               then k = i;
               else if type = 3
               then if base_regs (i).constant = n
                    then go to l8;
          end;

          i = get_free_base ();


          call change_base (i);

          vp = c_a (n, 14);                                 /* sp|n,* */
          call expmac ((load_base (0, i)), vp);

          base_regs (i).type = 3;
          base_regs (i).constant = n;

l8:
          base2 = bases (i);
          goto used_i;

base_man$load_display:
     entry (frames, base2);

dcl       frames              fixed bin,                    /* number of frames */
          base2               bit (3) aligned;              /* set to base loaded */

dcl       (fmin, nframes)     fixed bin;

          j, k = -1;
          n, fmin = frames;

/* Search for a register with a display pointer already loaded */

          do i = 1 to last_base;
               type = base_regs (i).type;
               if type = 0
               then k = i;
               else if type = 4
               then do;
                         if base_regs (i).constant = n
                         then go to l6;
                         if base_regs (i).constant < n
                         then do;
                                   nframes = n - base_regs (i).constant;
                                   if nframes < fmin
                                   then do;
                                             fmin = nframes;
                                             j = i;
                                        end;
                              end;
                    end;
          end;

          i = get_free_base ();

/* Get first pointer in the chain */

          call change_base (i);

          vp = c_a (display_offset, 14);                    /* sp|32,* */
          if j > 0
          then vp -> address.base = bases (j);
          macro = load_base (0, i);

          call expmac (macro, vp);

/* If necessary, follow the chain */

          if fmin > 1
          then do;
                    vp -> address.base = bases (i);
                    do j = 2 to fmin;
                         call expmac (macro, vp);
                    end;
               end;


          base_regs (i).type = 4;
          base_regs (i).constant = frames;

l6:
          base2 = bases (i);
          go to used_i;


base_man$load_static:
     entry (base1);

          if cg_stat$separate_static
          then do;
                    n = 13;
                    j = 1;
                    ca_code = 4;
                    go to link_join;
               end;


base_man$load_linkage:
     entry (base1);

dcl       base1               bit (3) aligned;              /* set to base loaded */

          n = 5;
          j = 0;
          ca_code = 14;
link_join:
          k = -1;

/* search for a register with ptr already loaded */

          do i = 2 to last_base;
               type = base_regs (i).type;
               if type = 0
               then k = i;
               else if type = n
               then go to set_base1;
          end;

/* we prefer to use the lp */

          if base_regs (2).type < 5
          then i = 2;
          else i = get_free_base ();

/* flush register i */

          call change_base (i);

/* load the register from the correct offset */

          vp = c_a ((link_info (j)), ca_code);
          call expmac ((load_base (j, i)), vp);
          base_regs (i).type = n;

set_base1:
          base1 = bases (i);
          base_regs (i).used = cg_stat$text_pos;
          return;


base_man$load_arg:
     entry (code, blk_pt, base3);

dcl       blk_pt              ptr;                          /* points at a blk node */

          vp = blk_pt;

          j = code + 6;

          do i = 1 to last_base;
               if base_regs (i).type = j
               then if base_regs (i).variable = vp
                    then go to l7;
          end;

          n = cg_stat$cur_level - vp -> block.level;
          if n = 0
          then base = sp;
          else call base_man$load_display (n, base);

          call setk;

          i = get_free_base ();

          if vp -> block.no_stack
          then n = vp -> block.entry_info + 2 + 2 * code;
          else n = stack_info (code);

          call change_base (i);

          p = c_a (n, 14);
          p -> address.base = base;
          call expmac ((load_base (0, i)), p);

          base_regs (i).type = j;
          base_regs (i).variable = vp;

l7:
          base3 = bases (i);
          goto used_i;

base_man$load_link_indirect:
     entry (poff, reloc, base3);

dcl       (poff, off)         fixed bin,                    /* offset in linkage or static section */
          reloc               bit (12) aligned;             /* relocation to use */

dcl       multiple            fixed bin;

          off = poff;

          if reloc = rc_lp15
          then do;                                          /* link indirect */
                    n = 8;
                    j = 9;
               end;
          else do;                                          /* static indirect */
                    n = 14;
                    j = 15;
               end;

          do i = 1 to last_base;
               if base_regs (i).type = n
               then if base_regs (i).constant = off
                    then go to l10;
          end;

          vp = c_a (off, j);

          call setk;

          i = get_free_base ();

          call change_base (i);


          call expmac ((load_base (0, i)), vp);

          base_regs (i).type = n;
          base_regs (i).constant = off;

l10:
          base3 = bases (i);
          go to used_i;

base_man$load_controlled:
     entry (poff, desc, base3);

dcl       desc                fixed bin;                    /* zero if data, otherwise desc */

          n = 11 + fixed (desc ^= 0, 1);
          off = poff;

          do i = 1 to last_base;
               if base_regs (i).type = n
               then if base_regs (i).constant = off
                    then go to l10;
          end;

          call base_man$load_link_indirect (off, (rc_lp15), base);

          call setk;

          i = get_free_base ();

          call change_base (i);

          p = c_a (desc, 14);
          p -> address.base = base;
          call expmac ((load_base (0, i)), p);

          base_regs (i).type = n;
          base_regs (i).constant = off;

          goto l10;

base_man$load_arg_ptr:
     entry (code, blk_pt, argno, base4);

dcl       argno               fixed bin,                    /* which arg */
          base4               bit (3) aligned;              /* set to base loaded */

          vp = blk_pt;

          n = code + 9;

          do i = 1 to last_base;
               type = base_regs (i).type;
               if type = n
               then if base_regs (i).variable = vp
                    then if base_regs (i).constant = argno
                         then go to l9;
          end;

          call base_man$load_arg (code, blk_pt, base);

          call setk;

          i = get_free_base ();

          call change_base (i);

          p = c_a (2 * (argno - code), 14);
          p -> address.base = base;

          call expmac ((load_base (0, i)), p);

          base_regs (i).type = n;
          base_regs (i).variable = vp;
          base_regs (i).constant = argno;

l9:
          base4 = bases (i);
          goto used_i;

base_man$store_ptr_to:
     entry (pa, pb);

/* this entry is called to store a ptr to reference pa in
             reference pb */

dcl       (pa, pb)            ptr;

          do i = 1 to last_base;
               if base_regs (i).type = 2
               then if base_regs (i).variable = pa
                    then do;
                              if ^pa -> reference.shared
                              then call adjust_ref_count (pa, -1);
                              go to store;
                         end;
          end;

          i = 1;

          call base_man$load_var (2, pa, i);

store:
          if pb -> reference.symbol ^= null
          then call base_to_core (i, pb);
          else do;
                    call expmac ((store_base (23, i)), pb);
                    if pb -> reference.temp_ref
                    then pb -> reference.value_in.storage = "1"b;
               end;

          return;

base_man$update_base:
     entry (code, var, which);

/* This entry is called to update the contents of the base register state */

          i = which;
          call change_base (i);

          vp = var;
          n = code;

          if n = 2
          then do;
                    vp -> reference.address_in.b (i) = "1"b;
                    goto l2;
               end;

          if n = 1
          then goto l1b;

          if n >= 5 & n <= 7
          then do;
                    base_regs (i).type = n;
                    base_regs (i).variable = vp;
                    go to used_i;
               end;
          else base_regs (i).type = 0;
          return;

base_man$load_packed:
     entry (pa, where);

/* This entry is called when an assigment from packed ptr to unpacked ptr is
             found as the qualifier of a reference node, or when such an assignment is
             found elsewhere.  The packed ptr is loaded into any register. */

dcl       where               fixed bin;

          n = 1;

          p = pa;
          vp = p -> operand (1);

          if vp -> reference.shared & vp -> reference.symbol -> symbol.temporary
          then vp, p -> operand (1) = copy_temp (vp);

          vp = prepare_operand (vp, 1, atomic);


          q = prepare_operand ((p -> operand (2)), 1, atomic);

          if ^atomic
          then q = compile_exp$save ((p -> operand (2)));

          k = -1;
          do i = first_base to last_base;
               if base_regs (i).type = 0
               then k = i;
               else if q -> reference.temp_ref
               then if base_regs (i).type = 1
                    then if base_regs (i).variable = q
                         then do;
                                   where = i;
                                   call adjust_ref_count (q, -1);
                                   go to used_i;
                              end;
          end;

          if q -> reference.temp_ref
          then if ^q -> reference.value_in.storage
               then if q -> reference.value_in.q
                    then do;
                              q -> reference.ref_count = q -> reference.ref_count + 1;
                              q -> reference.store_ins = bit (cg_stat$text_pos, 18);
                              call expmac ((stfx1), q);
                              q -> reference.value_in.storage = "1"b;
                         end;
                    else call error (315, cg_stat$cur_statement, q);

          p = vp;
          vp = q;

          call when_to_m_a;
          i = get_free_base ();

          where = i;

          call change_base (i);

          call expmac ((load_base (1, i)), vp);

          vp = p;
          go to l1b;


base_man$lock:
     entry (lbase);
dcl       lbase               fixed bin;
          base_regs (lbase).locked = base_regs (lbase).locked + 1;
          return;

base_man$unlock:
     entry (lbase);
          base_regs (lbase).locked = base_regs (lbase).locked - 1;
          return;



/* */
when_to_m_a:
     proc;
dcl       p                   ptr;

/* Decide whether we must make vp addressable before looking for a free base
   register and loading it */

          eis = "0"b;
          addressable = ^vp -> reference.no_address & vp -> reference.perm_address;
          if string (vp -> reference.value_in.b)
          then return;
          if string (vp -> reference.address_in.b)
          then return;

          if n = 2
          then if vp -> reference.units ^= word_
               then if ^vp -> reference.modword_in_offset
                    then eis = "1"b;

          if addressable
          then return;

          do p = vp -> reference.qualifier repeat p -> reference.qualifier while (p ^= null);
               if p -> node.type = temporary_node
               then return;
               if p -> node.type = operator_node
               then do;
                         if p -> operator.op_code = param_ptr
                         then go to call_ma;
                         p = p -> operand (1);
                    end;
               if string (p -> reference.value_in.b)
               then go to call_ma;
               if string (p -> reference.address_in.b)
               then go to call_ma;
               if p -> reference.ref_count > 1
               then do;
call_ma:
                         call m_a (vp, "0"b || eis);
                         vp -> reference.perm_address = "1"b;
                         addressable = "1"b;
                         if k >= first_base
                         then if base_regs (k).type ^= 0
                              then call setk;
                         return;
                    end;
          end;
     end;



/* */
get_free_base:
     proc () returns (fixed bin);

/* If an empty register was found in the scan, use that; otherwise pick a
   register containing a variable with the lowest reference count, priority, and
   least recently used */

dcl       (i, j, cmin, n, pr, pmin, type)
                              fixed bin;
dcl       p                   ptr;
dcl       priority            (14) fixed bin int static init (3, 3, 2, 4, 5, 4, 3, 2, 3, 1, 3, 1, 5, 2);

/* Variable k lives in the outer block */

          if k >= first_base
          then if base_regs (k).locked = 0
               then do;
                         cg_stat$last_base_used = k;
                         return (k);
                    end;

          j = -1;
          cmin = 123456;
          do i = max (cg_stat$last_base_used + 1, first_base) to last_base, first_base to cg_stat$last_base_used;
               if base_regs (i).locked > 0
               then go to try_another;

               type = base_regs (i).type;
               if type = 0
               then do;
hit:
                         cg_stat$last_base_used = i;
                         return (i);
                    end;

               p = base_regs (i).variable;

               if type < 3
               then do;
                         if p = null
                         then go to hit;
                         n = p -> reference.ref_count;

                         if ^p -> reference.shared
                         then if n <= 0
                              then go to hit;
                              else ;
                         else if p -> reference.temp_ref
                         then go to hit;

                         pr = 3;
                    end;
               else do;
                         n = 0;
                         pr = priority (type);
                    end;

               if n < cmin
               then do;
                         cmin = n;
sj:
                         pmin = pr;
                         j = i;
                    end;
               else if n = cmin
               then if pr < pmin
                    then go to sj;
                    else if pr = pmin
                    then if base_regs (i).used < base_regs (j).used
                         then go to sj;
try_another:
          end;

          cg_stat$last_base_used = j;
          return (j);
     end;




/* */

change_base:
     proc (m);

dcl       (m, n, t)           fixed bin,
          p                   ptr;

          n = m;
          p = base_regs (n).variable;
          if p = null
          then return;

          t = base_regs (n).type;

          if t = 2
          then do;
                    p -> reference.address_in.b (n) = "0"b;
                    return;
               end;

          if t ^= 1
          then return;

          p -> reference.value_in.b (n) = "0"b;

          if ^p -> reference.temp_ref
          then return;
          if p -> reference.value_in.storage
          then return;
          if p -> reference.dont_save
          then return;

          if p -> reference.ref_count > 0
          then do;
                    p -> reference.ref_count = p -> reference.ref_count + 1;
                    p -> reference.store_ins = bit (cg_stat$text_pos, 18);
                    call expmac ((store_base (p -> reference.data_type, n)), p);
                    p -> reference.value_in.storage = "1"b;
               end;

     end;                                                   /* */
setk:
     proc;

          k = -1;
          do i = last_base to first_base by -1;
               if base_regs (i).type = 0
               then do;
                         k = i;
                         return;
                    end;
          end;

     end;                                                   /**/
exp_addmac:
     proc;

/* Issues add bits or bytes to pointer macro */

          text_pos = cg_stat$text_pos;

          call expmac (macro, p);

          base_regs (i).changed = text_pos;
          base_regs (i).instruction = addrel (cg_stat$text_base, text_pos) -> full_word;
     end;



add_cfo:
     proc;

/* routine to add in constant_fractional_offset if not already done */

          if substr (tag_hold, 3, 1)
          then do;
                    call xr_man$add_any_const ((vp -> reference.c_f_offset), xr, fixed (substr (tag_hold, 4, 3), 3));
                    tag_hold = "001"b || bit (xr, 3);
               end;
          else do;
                    call xr_man$load_any_const ((vp -> reference.c_f_offset), xr);
                    p -> address.tag = "001"b || bit (xr, 3);
                    call exp_addmac;
               end;
     end;

     end base_man$load_any_var;




		    base_to_core.pl1                10/03/83  1730.5rew 10/03/83  1007.9       30672



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


/* procedure to store ptr value held in base register

   Initial Version: 24 July 1971 by BLW
	Modified: 13 February 1973 by RAB
	Modified: 11 June 1976 by RAB
	Modified: 29 March 1978 by PCK to allow sp to be stored
	Modified:	30 March 1980 by RAB for reference.(aligned padded)_for_store_ref.
		See prepare_operand for details.	*/

base_to_core: proc(p_base,var);

dcl	p_base fixed bin,
	var ptr;

dcl	(p,p1,q,q1) ptr,
	base fixed bin,
	update bit(1) aligned,
	dt fixed bin,
	state_man$flush_ref entry(ptr),
	base_man$update_base entry(fixed bin,ptr,fixed bin),
	store entry(ptr),
	expmac$zero entry(fixed bin(15)),
	load entry(ptr,fixed bin),
	(base_man$lock,base_man$unlock) entry(fixed bin),
	expmac entry(fixed bin(15),ptr),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	expmac$two_eis entry(fixed bin(15),ptr,ptr);

dcl	(max,null) builtin;

dcl (	store_base(23:24,7)	init(61,409,622,623,624,625,533,		/* unpacked */
			     630,631,632,633,634,635,730),		/* packed */
	unpk_to_pk	init(407),
	move_bits		init(99),
	base_to_aq(6)	init(410,411,626,627,628,629)) fixed bin(15) int static;

%include reference;
%include symbol;
%include machine_state;
%include nodes;
%include data_types;
%include cgsystem;

	p = var;
	base = p_base;

	dt = p -> reference.data_type;

	update = "0"b;

	if base_regs(base).type > 0
	then if base_regs(base).type <= 2
	     then do;
		p1 = base_regs(base).variable;

		if p1 ^= null
		then if p1 -> node.type ^= reference_node
		     then p1 = null;

		if p = p1
		then if base_regs(base).type = 1
		     then if ^ p -> reference.shared
			then go to gs;
			else update = "1"b;
		     else;
		else if dt >= unpacked_ptr
		     then if p1 ^= null
			then if p1 -> reference.hit_zero
			     then update = "1"b;
		end;

	     else p1 = null;

	else do;
	     update = "1"b;
	     p1 = null;
	     end;
	call state_man$flush_ref(p);

	if update
	     then call base_man$update_base(1,p,base);

gs:
	q = p -> reference.symbol;

	/* following line is needed to allow initialization of file constants */

	if q -> symbol.temporary
	     then p -> reference.value_in.storage = "1"b;



	dt = max(dt,unpacked_ptr);

	if p -> reference.aligned_for_store_ref
	then do;
	     call base_man$lock(base);

	     call expmac((store_base(dt,base)),p);

	     call base_man$unlock(base);
	     return;
	     end;


	if p1 ^= null
	then if p1 -> reference.data_type = packed_ptr
	     then do;
		q1 = p1;
		if ^ p1 -> reference.temp_ref | p1 -> reference.value_in.storage
		     then go to l2;
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
		p1 -> reference.value_in.storage = "1"b;
		go to l1;
		end;

	q1 = c_a(46,4);
	q1 -> reference.c_length = bits_per_word;

l1:	call expmac((store_base(packed_ptr,base)),q1);

l2:	if ^ q1 -> reference.shared
	     then q1 -> reference.ref_count = q1 -> reference.ref_count + 1;

	call expmac$two_eis((move_bits),p,q1);

	end;




		    c_a.pl1                         10/03/83  1730.5rew 10/03/83  1007.9       47781



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


/* This procedure is called with a constant and a code.  It is used
   to generate various types of referencees using the constant.

   Initial Version: 30 September 1968 by BLW 
	Modified: 19 March 1971 by BLW for Version II
	Modified: 24 August 1972 by BLW
	Modified:	4 June 1975 by RAB for separate_static
	Modified 791026 by PG for TCT tables in pl1_operators_
*/

c_a:	proc(pc,code) returns(ptr);

dcl	(c,pc) fixed bin(15),		/* constant value */
	code fixed bin,		/* what type of reference */
	table_subscript fixed bin,
	word_delta fixed bin;

dcl	(ref_pt,p) ptr,
	xr fixed bin(3),
	n fixed bin(15),
	mask_array fixed static init(0),	/* loc of mask array */
	blank_array fixed static init(288),	/* loc of blank array */
	array_mask fixed static init(144),	/* loc of mask2 array */
	xr_man$load_any_const entry(fixed bin,fixed bin(3)),
	get_reference ext entry returns(ptr);
dcl	base_man$load_linkage entry returns(bit(3) aligned);
dcl	base_man$load_static entry returns(bit(3) aligned);
dcl	stack_temp$assign_temp entry(ptr);

dcl	(addr,bit,divide,fixed,substr,mod) builtin;

dcl	1 word		aligned based(p),
	2 offset		unaligned bit(18),
	2 rhs		unaligned bit(18);

/* internal static */

dcl	tct_byte_offset (0:3) fixed bin int static init (-627, -499, -371, -243);	/* from assembly of pl1_operators_ */

/* include files */

%include reference;
%include temporary;
%include bases;
%include relocation_bits;

/* program */

	ref_pt = get_reference();
	p = addr(ref_pt -> reference.address);
	c,n = pc;
	goto sw(code);

	/* reference is c itself */

sw(1):	if n >= 0 then p -> word.offset = bit(fixed(n,18),18);
	else p -> word.offset = bit(fixed(262144 + n,18),18);

done:	ref_pt -> reference.no_address = "0"b;
	ref_pt -> reference.perm_address = "1"b;
	return(ref_pt);

	/* reference is c,dl */

sw(2):	ref_pt -> address.tag = "000111"b; /* dl */
	goto sw(1);

	/* reference is c,du */

sw(3):	ref_pt -> address.tag = "000011"b; /* du */
	goto sw(1);

	/* reference is sp|c */

sw(4):	ref_pt -> address.base = sp;

	if mod(n,2) = 0 then ref_pt -> reference.even = "1"b;

l2:	if n >= 16384
	then do;
	     n = mod(n,16384);
	     call xr_man$load_any_const(c-n,xr);
	     substr(ref_pt -> address.tag,3,4) = "1"b || bit(xr,3);
	     end;

	ref_pt -> address.ext_base = "1"b;
	ref_pt -> address.offset = bit(fixed(n,15),15);;
	goto done;

	/* reference is ap|mask_array+2*c, where referenceed location
	   contains a string with c 1's followed by 72-c 0's */

sw(5):	ref_pt -> address.offset = bit(fixed(mask_array+2*n,15),15);
l1:	ref_pt -> address.base = ap;
	ref_pt -> address.ext_base = "1"b;
	ref_pt -> reference.even = "1"b;
	goto done;

	/* reference is ap|blank_array+2*c, where referenceed location
	   contains a string with c 0 char's followed by 8-c blanks */

sw(6):	ref_pt -> address.offset = bit(fixed(blank_array+2*divide(n,9,17,0),15),15);
	goto l1;

	/* reference is ap|array_mask+2*c, where referenceed location
	   contains a string with c 0's followed by 72-c 1's */

sw(7):	ref_pt -> address.offset = bit(fixed(array_mask+2*n,15),15);
	goto l1;

	/* reference is 0,c */

sw(8):	ref_pt -> address.tag = "001"b || bit(fixed(n,3),3);
	goto done;

	/* reference is lp|c,* (linkage section) */

sw(9):	ref_pt -> address.tag = "010000"b;	/* * */
	ref_pt -> address.base = base_man$load_linkage();
	ref_pt -> reference.relocation = rc_lp15;
	goto l2;

	/* reference is c,ic */

sw(10):	ref_pt -> reference.ic_ref = "1"b;
	ref_pt -> address.tag = "000100"b;	/* ic */
	if mod(n,2) = 0 then ref_pt -> reference.even = "1"b;
	goto sw(1);

	/* reference is bp|c */

sw(11):	ref_pt -> address.base = bp;
	goto l2;

	/* reference is to block of c words in stack */

sw(12):	ref_pt -> reference.c_length = n;
	ref_pt -> reference.temp_ref = "1"b;
	call stack_temp$assign_temp(ref_pt);
	c,n = ref_pt -> reference.qualifier -> temporary.location;
	goto sw(4);

	/* reference is to location c in static section */

sw(13):	ref_pt -> address.base = base_man$load_static();
	ref_pt -> reference.relocation = rc_is15;
	goto l2;

	/* reference is sp|c,* */

sw(14):	ref_pt -> address.tag = ref_pt -> address.tag | "010000"b;	/* * */
	go to sw(4);

	/* reference is lp|c,* (static section) */

sw(15):	ref_pt -> address.tag = ref_pt -> address.tag | "010000"b;	/* * */
	ref_pt -> reference.relocation = rc_is15;
	ref_pt -> address.base = base_man$load_static();
	go to l2;

	/* reference is ap|-n, where -n is the offset of the TCT table for c */

sw (16):
	word_delta = divide (c, 4, 9, 0);
	table_subscript = c - word_delta * 4;
	n = tct_byte_offset (table_subscript) - word_delta + 32768;
	ref_pt -> reference.address.base = ap;
	ref_pt -> reference.address.offset = bit (n, 15);
	ref_pt -> reference.address.ext_base = "1"b;
	/* dont care about even bit */
	go to done;

     end /* c_a */;




		    call_op.pl1                     10/03/83  1730.5rew 10/03/83  1007.9      161181



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


/* procedure to compile calls

   Initial Version: 16 April 1971 by BLW for Version II
	Modified:  5 November 1972 by BLW	
	Modified:	15 February 1973 by RAB
	Modified:	25 June 1973 by RAB	
	Modified: 2 August 1974 by RAB for constant arg list calls
	Modified:	16 November 1974 by RAB to fix bug 1232
	Modified:	17 November 1974 by RAB to fix bug 1255
	Modified:	12 December 1975 by RAB to remove call to state_man$erase_reg
	Modified:	23 June 1976 by RAB to centralize use of cg_stat$last_call
	Modified:	10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address
	Modified: 23 April 1979 by PCK to implement 4-bit decimal 
	Modified: 23 June 1981 by EBush to increase max size of arg lists 
	Modified: 11 September 81 by EBush to add prepare_call_long and 
		prepare_quick_call_long macros.  */

call_op:	proc(pt) returns(ptr);

dcl	pt ptr;		/* points at call operator node */

dcl	(cg_stat$cur_tree,cg_stat$double_temp,cg_stat$temp_ref,cg_stat$cur_node) ptr ext,
	cg_stat$cur_block ptr ext,
	cg_stat$text_pos fixed bin(18) ext,
	cg_stat$cur_level fixed bin ext;

dcl	(p,q,node_pt,ret_pt,ent_pt,sal_pt,arglist,ap,p2,p2s,p3,
	arg(3),args,descs,ent_blk,save_cur_node) ptr,
	(i,j,n,skip,ent_type,n_args,arg_pos,dt) fixed bin,
	(macro1,macro2) fixed bin(15),
	last_freed fixed bin(18),
	arg_list_extent fixed bin(35),
	xr fixed bin(3),
	(atom,useless,quick,reset,use_itp) bit(1) aligned;

dcl	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	expmac entry(fixed bin(15),ptr),
	copy_temp entry(ptr) returns(ptr),
	(stack_temp$assign_temp,stack_temp$free_temp) entry(ptr),
	compile_exp$save entry(ptr) returns(ptr),
	compile_exp$save_exp entry(ptr) returns(ptr),
	(compile_exp,load_size) entry(ptr);
dcl	compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
dcl	share_expression entry(ptr) returns(ptr),
	base_man$store_ptr_to entry(ptr,ptr),
	store_bit_address entry(ptr,ptr,fixed bin(18)),
	base_man$load_var entry(fixed bin,ptr,fixed bin),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	(long_op$extend_stack,adjust_ref_count) entry(ptr,fixed bin(15)),
	store$save_string_temp entry(ptr),
	long_op$c_or_b entry(ptr,fixed bin,fixed bin(15)),
	need_temp entry(ptr,bit(2) aligned),
	xr_man$load_any_const entry(fixed bin,fixed bin(3)),
	xr_man$load_const entry(fixed bin,fixed bin),
	xr_man$super_lock entry(fixed bin),
	m_a entry(ptr,bit(2) aligned),
	expmac$zero entry(fixed bin(15)),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	state_man$flush entry,
	state_man$flush_address entry(ptr),
	cg_error entry(fixed bin,fixed bin),
	generate_constant$relocatable entry(ptr,fixed bin,bit(1) aligned) returns(ptr);

dcl	(addr,bit,fixed,hbound,null,substr) builtin;

dcl (	call_ent_var	init(230),
	zero_mac		init(308),
	lda		init(1),
	alloc_char_temp	init(89),
	realloc_char_temp	init(92),
	prepare_call	init(362),
	prepare_quick_call	init(363),
	prepare_call_long   init(741),
	prepare_quick_call_long  init(742),
	quick_call	init(367)) fixed bin(15) int static;

%include cg_reference;
%include operator;
%include list;
%include symbol;
%include block;
%include temporary;
%include data_types;
%include op_codes;
%include nodes;
%include boundary;
%include cgsystem;
%include its;

	save_cur_node = cg_stat$cur_node;
	node_pt, cg_stat$cur_node = pt;
	ret_pt = node_pt -> operand(1);

	/* get info about entry */

	q = node_pt -> operand(2);
	ent_pt = prepare_operand(q,1,atom);
	if ^ atom then ent_pt = compile_exp$save(q);

	ent_type = ent_pt -> reference.data_type;
	if ent_type ^= int_entry then quick = "0"b;
	else do;
	     ent_blk = ent_pt -> reference.symbol -> symbol.equivalence;
	     quick = ent_blk -> block.no_stack;
	     end;

	/* get ptr to std_arg_list operator */

	sal_pt = node_pt -> operand(3);

	/* The rest of the main procedure is put in a begin block so that
	   the extents of arrays (and bit vectors) that hold values for
	   each arg in the arg_list will conform to the number of args, via
	   auto adjustable storage, thus avoiding an artificial limit on
	   the number of args in a call. */

	if sal_pt = null
	     then arg_list_extent = 1;
	     else arg_list_extent = sal_pt->operand(2)->list.number;

     begin;
	dcl rand_pt(arg_list_extent) ptr;
	dcl (adjust,already)  bit(arg_list_extent);
     

	if sal_pt = null
	then do;

	     /* no arguments, no sweat if this is quick call */

	     if quick
	     then do;
		call state_man$flush;
		call expmac((quick_call),ent_pt);
		goto done;
		end;

	     /* use temp location for arglist */

	     arglist = cg_stat$double_temp;
	     descs = null;
	     n_args = 0;
	     goto l3;
	     end;

	/* get ptr to arglist and skip if we already evaluated it */

	arglist = sal_pt -> operand(1);
	arglist -> reference.units = word_;
	arglist -> reference.perm_address = "0"b;
	if arglist -> reference.evaluated 
	then do;
	     arglist->reference.no_address = "1"b;
	     goto l2;
	     end;

	args = sal_pt -> operand(2);
	n_args = args -> list.number;

	if n_args > max_list_elements
	then do;
	     call cg_error(340,max_list_elements);
	     n_args = max_list_elements;
	     end;

	/* get info about all the arguments of the call */

	do i = 1 to n_args;
	     q = args -> element(i);
	     p = prepare_operand(q,-1,atom);

	     if atom then goto step;
	     if q -> node.type ^= operator_node then goto step;

	     if q -> operator.op_code = assign | q -> operator.op_code = assign_size_ck
	     then do;

		if p -> reference.length = null then goto l1;

		/* we have adjustable string temp = something,
		   check to see if we have the same size on both
		   sides of the assignment */

		/* We have to be prepared to restore the
		   original value of the data_type field
		   of operand(2) if it is a reference,
		   because if we don't, prepare_operand
		   will get confused and not evaluate
		   the length expression, if any. */

		p2 = q -> operand(2);
		if p2 -> node.type = operator_node 
		     then p2 = p2 -> operand(1);
		dt = p2 -> reference.data_type;

		p2 = prepare_operand((q -> operand(2)),-1,atom);
		p2s = p2 -> reference.length;

		reset = "0"b;

		if p2s = p -> reference.length
		then;
		else if compare_expression(p2s,(p -> reference.length))
		     then do;

			/* Have same size on both sides of assign, so optimize */

			p2s = share_expression(p2s);
			if p2s -> node.type = reference_node
			     then p2s = prepare_operand(p2s,1,useless);
			p -> reference.length = p2s;
			end;
		     else reset = "1"b;

		if (p -> reference.data_type ^= p2 -> reference.data_type) | atom
		then do;

		     /* We restore the data_type field before
		        calling compile_exp$save if the
		        2 length exprs were not the
		        same, as previously mentioned */

		     if reset
			then p2 -> reference.data_type = dt;
		     p = compile_exp$save(q);
		     end;
		else do;
		     p -> reference.ref_count = p -> reference.ref_count + 1;
		     dt = p -> reference.data_type - char_string;
		     call compile_exp((q -> operand(2)));
		     call long_op$extend_stack(p,realloc_char_temp+dt);
		     call store$save_string_temp(p);
		     call adjust_ref_count((q -> operand(2)),-1);
		     end;

		goto step;
		end;

	     if p -> reference.long_ref
	     then p = compile_exp$save_exp(q);
	     else do;
l1:		if p -> reference.c_length > 0
		 | p -> reference.data_type < char_string
		 | p -> reference.data_type > bit_string
		then p = compile_exp$save_exp(q);
		else do;

		     /* have zero length string being passed out */

		     p = q -> operand(1);

		     call stack_temp$assign_temp(p);

		     if p -> reference.varying_ref
		     then do;
			p -> reference.c_offset = p -> reference.c_offset - 1;
			p -> reference.ref_count = p -> reference.ref_count + 1;
			call expmac((zero_mac),p);
			p -> reference.c_offset = p -> reference.c_offset + 1;
			end;
		     end;
		end;

step:	     rand_pt(i) = p;
	     if p -> reference.length ^= null
	     then if p -> reference.ref_count = 1
		then call need_temp(p,"01"b);
	     end;

	/* allocate space for temp result of function, if necessary */

	if p -> reference.temp_ref
	then if ^ p -> reference.allocated
	     then do;

		if ^ p -> reference.allocate
		then do;
		     p, ret_pt, rand_pt(n_args) = copy_temp(p);
		     p -> reference.ref_count = 2;
		     end;

		call stack_temp$assign_temp(p);
		p -> reference.value_in.storage = "1"b;
		end;

	/* check to see if we can generate a constant arg list */

	if quick
	then do;
	     use_itp = check_arg_addrs();
	     if use_itp
	     then do;
		call gen_itp_list;
		go to l2;
		end;
	     end;

	/* allocate space for arg list if necessary */

	if ^ arglist -> reference.allocated
	then do;
	     if ^ arglist -> reference.allocate then arglist = copy_temp(arglist);
	     call stack_temp$assign_temp(arglist);
	     end;

	last_freed = arglist -> reference.qualifier -> temporary.last_freed;

	arg_pos = arglist -> reference.qualifier -> temporary.location;

	if arg_pos + 2*n_args + 1 < 16384
	     then ap = c_a(arg_pos,4);
	     else do;
		ap = c_a(0,4);
		call xr_man$load_const(arg_pos,1);	/* xr1 is safe because it is out of the pool */
		ap -> address.tag = "001001"b;
		arg_pos = 0;
		string(arglist -> reference.address) = string(ap -> reference.address);
		arglist->reference.perm_address = "1"b;
		end;

	/* put ptrs to arguments into arg list.  If an arg is a temporary, we will
	   adjust the reference count up by 1 so that the temporary remains allocated
	   until we return from call_op.  If we did not do this and some of the
	   registers had to be saved in storage, one of the temporaries used for
	   an arg passed by value might get used. */

	adjust = "0"b;
	do i = 1 to n_args;
	     ap -> address.offset = bit(fixed(arg_pos + 2*i,15),15);
	     p = rand_pt(i);

	     if p -> reference.temp_ref
	     then do;
		p -> reference.ref_count = p -> reference.ref_count + 1;
		substr(adjust,i,1) = "1"b;
		end;

	     call store_bit_address(ap,p,last_freed);
	     end;

	/* decide if we have to skip a position in the arg list for stack ptr */

	skip = fixed(((ent_type = int_entry) & ^ quick) | (ent_type = entry_variable),1) + n_args;

	descs = sal_pt -> operand(3);
	if descs = null then goto l2;

	/* put ptrs to descriptors into arg list */

	already = "0"b;
	do i = 1 to n_args;

	     if substr(already,i,1) then goto next;

	     ap -> address.offset = bit(fixed(arg_pos + 2*(i+skip),15),15);
	     p = prepare_operand((descs -> element(i)),1,atom);
	     call base_man$store_ptr_to(p,ap);

	    /* if same descriptor used later, store ptr to it now */

	     do j = i + 1 to n_args;
		if p = descs -> element(j)
		then do;
		     ap -> address.offset = bit(fixed(arg_pos + 2*(j+skip),15),15);
		     call base_man$store_ptr_to(p,ap);
		     substr(already,j,1) = "1"b;
		     end;
		end;

next:	     end;

l2:

	/* generate call */

l3:	arg(1) = arglist;
	if n_args > 127
	     then arg(2) = c_a((n_args*2),3);   /* for prepare_call_long macros */
	     else arg(2) = c_a((n_args*2048),2);  /* for prepare_call macros */

	if ent_type = int_entry & ^ quick
	then do;
	     j = cg_stat$cur_level - ent_pt -> reference.symbol -> symbol.block_node -> block.level;

	     if j ^= 0
	     then do;
		call xr_man$load_const(j,7);
		call xr_man$super_lock(7);
		ent_type = int_entry_other;
		end;

	     end;

	if ret_pt ^= null
	then if ^ ret_pt -> reference.shared
	     then if cg_stat$cur_tree = node_pt
		then call adjust_ref_count(ret_pt,-1);

	if quick
	then do;
	     if use_itp
	     then do;
		call base_man$load_var(2,arglist,1);
		if descs ^= null
		     then call expmac((lda),arglist);
		end;
	     else if n_args > 127
		    then call expmac$many((prepare_quick_call_long),addr(arg),2);
	              else call expmac$many((prepare_quick_call),addr(arg),2);

	     call state_man$flush;
	     call expmac((quick_call),ent_pt);
	     end;
	else do;
	     if n_args > 127
		then call expmac$many((prepare_call_long),addr(arg),2);
		else call expmac$many((prepare_call),addr(arg),2);
	     call base_man$load_var(2,ent_pt,1);
	     call state_man$flush;
	     call expmac$zero(call_ent_var + 2*(ent_type - entry_variable) + fixed(descs ^= null,1));
	     end;

	if adjust = "0"b then goto done;

	do i = 1 to n_args;
	     if substr(adjust,i,1)
	     then do;
		p = rand_pt(i);
		call adjust_ref_count(p,-1);
		end;
	     end;

done:
	ent_pt -> reference.perm_address = "0"b;
	cg_stat$cur_node = save_cur_node;

	if ret_pt ^= null
	then if ^ ret_pt -> reference.shared
	     then ret_pt -> reference.evaluated = "1"b;

	return(ret_pt);
/**/
check_arg_addrs:	proc reducible returns(bit(1) aligned);

dcl	     (f,p,s) ptr;

	     /* checks args to see if all addresses are suitable for use
	        in a constant arg list */

	     if cg_stat$cur_block -> block.last_auto_loc >= 16384
		then go to fail;

	     /* make sure quick block contains no non-quick blocks */

	     if ent_blk -> block.son ^= null
	     then if ^ check_block((ent_blk -> block.son))
		then go to fail;

	     /* now check args for constant addresses */

	     do i = 1 to n_args;
		p = rand_pt(i);

		if p -> reference.offset ^= null
		     then go to fail;

		s = p -> reference.symbol;

		if p -> reference.temp_ref
		then do;
		     if p -> reference.address_in.storage
			then go to fail;

		     if p -> reference.aggregate
		     then do;
			do f = s repeat f -> symbol.father while(f -> symbol.father ^= null);
			     end;
			if f -> symbol.word_size ^= null
			     then go to fail;
			end;
		     end;

		else if p -> reference.qualifier ^= null
		     then go to fail;
		     else if s -> symbol.auto
			then if cg_stat$cur_level ^= s -> symbol.block_node -> block.level
			     then go to fail;
			     else;
			else if s -> symbol.constant
			     then do;
				if s -> symbol.equivalence ^= null
				     then s = s -> symbol.equivalence;

				if ^ s -> symbol.allocated
				then go to fail;
				else if p -> reference.units ^= 0
				     then if p -> reference.units ^= word_
					then go to fail;
					else;
				     else;
				end;

			     else go to fail;
		end;

	     return("1"b);

fail:	     return("0"b);

	     end;


/**/
check_block:   proc(pt) reducible returns(bit(1) aligned);

dcl	     (p,pt) ptr;

	     /* make sure all contained blocks are quick */

	      do p = pt repeat p -> block.brother while(p ^= null);
		if ^ p -> block.no_stack
		     then go to fail;
		if p -> block.son ^= null
		then if ^ check_block((p -> block.son))
		     then go to fail;
		end;

	     return("1"b);

fail:	     return("0"b);

	     end;
/**/
gen_itp_list:	proc;

dcl	     iscan fixed bin;
dcl	     doing_descriptors bit(1) aligned;

dcl	     1 arg_list auto aligned,
	     2 header aligned,
	       3 arg_count fixed bin(17) unal,
	       3 code bit(18) unal,
	       3 desc_count fixed bin(17) unal,
	       3 pad bit(18) unal,
	     2 itp_list(128) like itp aligned;

	     /* generates an argument list of constant addresses using
	        ITP pairs and ordinary indirect words */

	     doing_descriptors = "0"b;
	     arg_list.code, arg_list.pad = "0"b;
	     adjust = "0"b;
	     iscan = 0;
	     arg_list.arg_count = 2 * n_args;

	     /* fill in addresses of arguments */

	     call fill_list;

	     /* process descriptors, if any */

	     descs = sal_pt -> operand(3);
	     if descs ^= null
	     then do;
		arg_list.desc_count = 2 * n_args;
		doing_descriptors = "1"b;
		call fill_list;
		end;
	     else arg_list.desc_count = 0;

	     /* generate the constant argument list */

	     arglist = generate_constant$relocatable(addr(arg_list),2 * iscan + 2,"1"b);

fill_list:	proc;

dcl		ind_word bit(36) aligned based;
dcl		eis bit(2) aligned;
dcl		p ptr;

		/* fills in the arg_list */

		do i = 1 to n_args;
		     iscan = iscan + 1;

		     if ^ doing_descriptors
			then p = rand_pt(i);
			else p = prepare_operand((descs -> element(i)),1,atom);

		     if string(p -> reference.address_in.b)
			then call state_man$flush_address(p);

		     /* make the arg addressable */

		     if p -> reference.units = word_
			then eis = "00"b;
			else eis = "11"b;

		     call m_a(p,eis);

		     if p -> reference.ic_ref
		     then do;
			p -> reference.ic_ref = "0"b;
			p -> address.tag = "000000"b;
			end;

		     /* depending on ext_base, make an ITP pair or an indirect word */

		     string(itp_list(iscan)) = (72)"0"b;

		     if p -> address.ext_base
		     then do;
			itp_list(iscan).pr_no = p -> address.base;
			itp_list(iscan).itp_mod = "100001"b;	/* 41(8) - ITP */
			itp_list(iscan).offset = bit(fixed(p -> address.offset,18),18);
			if p -> reference.c_f_offset ^= 0
			then if p -> reference.units = bit_
			     then itp_list(iscan).bit_offset = bit(p -> reference.c_f_offset,6);
			     else if p -> reference.units = character_
				then itp_list(iscan).bit_offset = bit(fixed(bits_per_char * p -> reference.c_f_offset,6),6);
				else itp_list(iscan).bit_offset = bit(fixed(bits_per_char
					* divide(p -> reference.c_f_offset,packed_digits_per_char,6),6),6);
			end;

		     else addr(itp_list(iscan)) -> ind_word = string(p -> reference.address);

		     /* adjust the reference count for this use of the argument */

		     if ^ p -> reference.shared
		     then if p -> reference.temp_ref & ^ doing_descriptors
			then substr(adjust,i,1) = "1"b;
			else call adjust_ref_count(p,-1);
		     end;

		end;

	     end;


             end; /* begin block */


	end;




		    cat_op.pl1                      05/30/90  1619.7rew 05/30/90  1600.8       63486



/****^  ***********************************************************
        *                                                         *
        * 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-09-27,RWaters), approve(89-09-27,MCR8068), audit(89-09-27,Vu),
     install(89-10-02,MR12.3-1080):
     Fixed to remove duplicate declaration attributes.
  2) change(90-05-03,Huen), approve(90-05-03,MCR8169), audit(90-05-18,Gray),
     install(90-05-30,MR12.4-1012):
     pl1_1885: Fix pl1 optimizer to handle the concatenation of a common string
     expression correctly.
                                                   END HISTORY COMMENTS */


/* program to compile concatenation operator

   Initial Version: 28 December, 1968 by BLW
	Modified:  9 September 1971 by BLW for Version II
	Modified: 27 July 1972 by BLW
	Modified:	8 June 1973 by RAB for EIS
	Modified: 14 Sept 1979 by PCK to fix bug 1855
*/

cat_op:	proc(node_pts,refs,code);

dcl	node_pts ptr,		/* points at operator node */
	refs(3) ptr,		/* reference nodes for operands */
	code fixed bin;		/* local context */

dcl	node_pt ptr defined (node_pts),
	ref(3) ptr defined (refs);

dcl	(p1,p2,p3,p,q2,q3) ptr,
	(dt,type,n,s2,size1,size2,size3) fixed bin,
	macro fixed bin(15),
	tag bit(4) aligned,
	base bit(3) aligned,
	(lunits,word_offset) fixed bin(15),
	string_temp entry(ptr,ptr,ptr) returns(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	compile_exp entry(ptr),
	(compile_exp$save,compile_exp$save_exp) entry(ptr) returns(ptr),
	m_a entry(ptr,bit(2) aligned),
	base_man$load_any_var entry(fixed bin,ptr,bit(3) aligned),
	load_size$xr_or_aq entry(ptr,bit(4) aligned),
	state_man$erase_reg entry(bit(19) aligned),
	expmac$eis entry(fixed bin(15),ptr),
	aq_man$clear_q entry,
	c_a entry(fixed bin,fixed bin) returns(ptr),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac entry(fixed bin(15),ptr);

dcl	(addr,divide,fixed,mod,null) builtin;

dcl	1 p1_address aligned based(addr(p1 -> reference.address)),
	2 base bit(3) unal,
	2 offset fixed bin(14) unal,
	2 op bit(9) unal,
	2 no_address bit(1) unal,
	2 inhibit bit(1) unal,
	2 ext_base bit(1) unal,
	2 tag bit(6) unal;


dcl (	cat_move_chars	init(218),
	lda		init(1),
	ldq		init(7),
	sta		init(4),
	ora		init(46),
	arl		init(245),
	lrl		init(62)) fixed bin(15) int static;

%include boundary;
%include cgsystem;
%include cg_reference;
%include operator;
%include data_types;
%include machine_state;

begin:	p = node_pt;

	p1 = ref(1);
	p2 = ref(2);
	p3 = ref(3);

	q2 = p -> operand(2);
	q3 = p -> operand(3);

	type = p1 -> reference.data_type;
	n = convert_size(type);
	size1 = p1 -> reference.c_length * n;
	size2 = p2 -> reference.c_length * n;
	size3 = p3 -> reference.c_length * n;
	s2 = fixed(size2 > bits_per_word,1);
	dt = type - char_string;

	goto switch(code);

	/* have atm || exp */

switch(2):
ae:	if p1 -> reference.long_ref then p3 = compile_exp$save_exp(q3);

	/* have atm || atm */

switch(3):
aa:	if p1 -> reference.long_ref
	then do;

	     /* resultant string is long */

/* Want to protect possible length expr of p2 */

aa_l1:	     if ^ p2 -> reference.shared
		then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;

/* Call string_temp to allocate a temporary and move in p2 */

	     p1 = string_temp(p,p2,p3);

/* THE FOLLOWING SECTION SETS UP A MOVE TO EFFECT THE CONCATENATION */

aa_l3:

/* If p2's length was able to be inserted directly into a descriptor, try to optimize
  by changing the constant offset of the target */

	     if p2 -> reference.length = null
	     then if p2 -> reference.c_length < 4096
		then if ^ p2 -> reference.varying_ref
		     then do;
			call m_a(p1,"11"b);

			if dt = 0
			then lunits = character_;
			else lunits = bit_;

			word_offset = divide(p2 -> reference.c_length,units_per_word(lunits),15,0)
				  + p1_address.offset;
			if word_offset < 16383
			then do;
			     p1 -> reference.c_f_offset = mod(p2 -> reference.c_length,units_per_word(lunits))
						  + p1 -> reference.c_f_offset;
			     if p1 -> reference.c_f_offset >= units_per_word(lunits)
			     then do;
				p1 -> reference.c_f_offset = p1 -> reference.c_f_offset - units_per_word(lunits);
				word_offset = word_offset + 1;
				end;
			     p1_address.offset = word_offset;
			     go to set_perm;
			     end;
			end;

/* This sequence is used when p2's length was in a register .  We use p2's length as the 
   offset in p1 in which to move p3 for the concatenation */

	     call load_size$xr_or_aq(p2,tag);

	     call m_a(p1,"11"b);

	     if p1 -> address.tag
	     then do;
		p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
		p1 -> reference.perm_address = "1"b;
		call base_man$load_any_var(2,p1,base);
		end;

	     p1 -> address.tag = "00"b || tag;

/* Issue the move macro for the concatenation */

set_perm:	     p1 -> reference.perm_address = "1"b;

	     call expmac$eis(cat_move_chars+dt,p3);

	     if dt > 0
		then machine_state.indicators = -1;

	     p1 -> reference.perm_address = "0"b;

	     if ^ p2 -> reference.shared
		then call adjust_ref_count(p2,-1);

	     return;
	     end;

	/* resultant string is short */

	if p2 -> reference.c_length = 0
	then do;
	     call compile_exp(q3);
	     return;
	     end;

aa_2:	if size2 = bits_per_word & mod(code,2) ^= 0
	then do;
	     call expmac((lda),p2);
aa_2a:	     call expmac((ldq),p3);
	     end;
	else do;
aa_3:	     call compile_exp(q3);


	     call state_man$erase_reg("1"b);	/* shift won't flush the register first */

	     if size1 > bits_per_word
	     then do;
		macro = lrl;

		/* clear q if necessary, so we
		   won't have garbage left over */

		if size3 <= bits_per_word
		then if size2 ^= bits_per_word
		     then if a_reg.length < bits_per_two_words
			then call aq_man$clear_q;
		end;

	     else macro = arl;

	     call expmac(macro,c_a(size2,1));

	     call expmac$one((ora),p2,s2);
	     end;

	a_reg.size = size1;
	return;

	/* have exp || exp */

switch(0):
ee:	if ^ p1 -> reference.long_ref
	then do;
ee1:	     p2 = compile_exp$save(q2);
	     goto aa_3;
	     end;

	p3 = compile_exp$save_exp(q3);

	/* have exp || atm */

switch(1):
ea:	if ^ p1 -> reference.long_ref
	then do;
	     if size2 ^= bits_per_word then goto ee1;
	     if p2 -> reference.ref_count < 1 then call compile_exp(q2);
	     else p2 = compile_exp$save(q2);	/* needed later */
	     goto aa_2a;
	     end;

ea1:	if p2 -> reference.long_ref | p2 -> reference.varying_ref
	     then call compile_exp(q2);
	     else p2 = compile_exp$save_exp(q2);

	goto aa_l1;

	end;




		    cg_error.pl1                    10/03/83  1730.5rew 10/03/83  1007.9       11376



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

cg_error:	proc(code,value) ;

dcl	(code,value) fixed bin;

dcl	p ptr,
	n fixed bin,
	cg_stat$cur_statement ptr ext static,
	v12 char(12) varying,
	bindec$vs entry(fixed bin,char(12) varying),
	error entry(fixed bin,ptr,ptr);

%include pl1_tree_areas;
%include token;
%include nodes;

	call bindec$vs(value,v12);
	n = length(v12);

	allocate token in(tree_area) set(p);
	p -> node.type = token_node;
	p -> token.string = v12;
	call error(code,cg_stat$cur_statement,p);

	end;




		    cg_stat.alm                     10/03/83  1730.5rew 10/03/83  1007.9       90504



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

" Static data segment for code generator
"
" Modified: 16 Nov by PCK to fix bug 1858 by adding cg_stat$in_thunk.
"
	name	cg_stat
"
"	CONSTANT INFORMATION
"
	segdef	max_program_size	size of largest program
max_program_size:
	dec	65536
"
	segdef	max_stack_size	size of largest stack frame
max_stack_size:
	dec	60000
"
	segdef	packed_null_value	inernal value of packed null pointer
packed_null_value:
	oct	007777000001
"
	segdef	null_value	internal value of null ptr
	even
null_value:
	its	-1,1,n
"
	segdef	offset_null_value	internal value of offset null value
offset_null_value:
	oct	777777777777
"
	segdef	def_pool_size
def_pool_size:
	dec	10		size of definition pool
"
	segdef	version_number
version_number:
	dec	2
"
"	VARIABLES
"
	use	linkc
	join	/link/linkc
"
"	FIXED SCALARS
"
	segdef	aos_array		loc in linkage section of current position
	bss	aos_array,1	in array of aos counters for entries into prog.
"
	segdef	bit_count		bit count of object segment
	bss	bit_count,1
"
	even
	segdef	clock_time	clock reading at start of compilation
	bss	clock_time,2
"
	segdef	cur_level		nexting level of block being compiled
	bss	cur_level,1
"
	segdef	def_origin	rel(cg_stat$def_base) stored as fixed bin(18)
	bss	def_origin,1
"
	segdef	def_pool		dim(0:10)
	bss	def_pool,11	vector of pooled definition ptrs for ext static
"
	segdef	def_pos		next position to be filled in definitions section
	bss	def_pos,1
"
	segdef	last_base_used	last base register used
	bss	last_base_used,1
"
	segdef	last_call		position in text of last call operator
	bss	last_call,1
"
	segdef	last_index_used	last index used in index chain
	bss	last_index_used,1
"
	segdef	last_macro	last macro expanded
	bss	last_macro,1
"
	segdef	link_begin	offset where links start in linkage segment
	bss	link_begin,1
"
	segdef	link_origin	rel(cg_stat$link_base) stored as fixed bin(18)
	bss	link_origin,1
"
	segdef	link_pos		next position to be filled in linkage section
	bss	link_pos,1
"
	segdef	link_rel		start of linkage in object segment
	bss	link_rel,1
"
	segdef	list_break	vector of section breaks in listing
	bss	list_break,4
"
	segdef	map_start		loc of start of source map in symbol
	bss	map_start,1
"
	segdef	profile_pos	next position to be filled in profile
	bss	profile_pos,1
"
	segdef	profile_start	position of start of long_profile
	bss	profile_start,1
"
	segdef    stat_pos            next position to be filled in static section
	bss       stat_pos,1
"
	segdef    stat_rel            start of static in object segment
	bss       stat_rel,1
"
	segdef	sym_origin	rel(cg_stat$sym_base) stored as fixed bin(18)
	bss	sym_origin,1
"
	segdef	sym_pos		next position to be filled in symbol section
	bss	sym_pos,1
"
	segdef	sym_rel		start of symbol in object segment
	bss	sym_rel,1
"
	segdef	text_origin	rel(cg_stat$text_base) stored as fixed bin(18)
	bss	text_origin,1
"
	segdef	text_pos		next position to be filled in text section
	bss	text_pos,1
"
"	BIT SCALARS
"
	segdef	debug		bit(1), ON if debug option used
	bss	debug,1
"
	segdef	extended_stack	bit(1), ON if stack extended at run-time
	bss	extended_stack,1
"
	segdef	for_test_called	bit(1), ON if compile_exp$for_test called
	bss	for_test_called,1
"
	segdef	full_symtab	bit(1), ON means generate full symbol table
	bss	full_symtab,1
"
	segdef	generate_map	bit(1), ON if statement map being generated
	bss	generate_map,1
"
	segdef	generate_symtab	bit(1), ON if "put_in_symtab" bit found on any symbol
	bss	generate_symtab,1
"
	segdef	in_thunk		bit(1), ON if compiling thunk
	bss	in_thunk,1
"
	segdef	in_prologue	bit(1), ON if compiling prologue
	bss	in_prologue,1
"
	segdef	io_used		bit(1), ON if io statements used
	bss	io_used,1
"
	segdef	last_def		bit(18), loc of last definition
	bss	last_def,1
"
	segdef	long_profile	bit(1), ON if -long_profile specified
	bss	long_profile,1
"
	segdef	old_id		bit(27), id of last entry in object map
	bss	old_id,1
"
	segdef	optimize		bit(1), ON if optimize specified
	bss	optimize,1
"
	segdef	profile_option	bit(1), ON if profile should be generated
	bss	profile_option,1
"
	segdef	save_exp_called	bit(1), ON if compile_exp$save called
	bss	save_exp_called,1
"
	segdef	seg_def		bit(18), loc of class 3 segname definition
	bss	seg_def,1
"
	segdef	skip_to_label	bit(1), ON if ignoring lines after uncond tra
	bss	skip_to_label,1
"
	segdef	star_symbol_up_zero bit(18), location of link to <*symbol>|0
	bss	star_symbol_up_zero,1
"
	segdef    separate_static     bit(1), ON if separate static section
	bss       separate_static,1
"
	segdef	stop_id		bit(27), id of statement to stop on, debugging only
stop_id:	oct	777777777777
"
	segdef	support	bit(1), ON if support option specified
	bss	support,1
"
	segdef	table_option	bit(1), ON if table option specified
	bss	table_option,1
"
	segdef	use_type_6	bit(1), ON if type 6 links must be generated
	bss	use_type_6,1	for external data references
"
	segdef	used_operator	(900) bit(1), ON if ith operator used
	bss	used_operator,25
"
	segdef	zero_def		bit(18), loc of zero word in definitions
	bss	zero_def,1
"
"
"	CHARACTER SCALARS
"
	segdef	compiler_name	char(12) var, name of compiler
	bss	compiler_name,4
"
	segdef	seg_name		char(32) var, name of program being compiled
	bss	seg_name,9
"
	segdef	version_name	char(64) var, version of compiler message
	bss	version_name,34
"
"	POINTER SCALARS
"
	even
"
	segdef	agg_temps		ptr to list of aggreate temps allocated
	bss	agg_temps,2
"
	segdef	complex_ac	ptr to ref node for complex accumulator
	bss	complex_ac,2
"
	segdef	constant_list	ptr to list of constants
	bss	constant_list,2
"
	segdef	cur_block		ptr to block being compiled
	bss	cur_block,2
"
	segdef	cur_entry		ptr to current entry statement
	bss	cur_entry,2
"
	segdef	cur_node		ptr to current node in tree
	bss	cur_node,2
"
	segdef	cur_statement	ptr to statement being compiled
	bss	cur_statement,2
"
	segdef	cur_tree		ptr to tree being compiled
	bss	cur_tree,2
"
	segdef	def_base		ptr to base of definitions section buffer
	bss	def_base,2
"
	segdef	def_reloc_base	ptr to base of definitions section relocation buffer
	bss	def_reloc_base,2
"
	segdef    desc_list_ptr
desc_list_ptr:
	its       -1,1,n
"
	segdef	double_temp	ptr to ref node for double temp cell
	bss	double_temp,2
"
	segdef	dummy_block	ptr to block node for use by e_v
	bss	dummy_block,2
"
	segdef	dummy_statement	ptr to statement node for use by e_v
	bss	dummy_statement,2
"
	segdef	eis_temp	ptr to temporary set up by string_temp
	bss	eis_temp,2
"
	segdef	encoded_values	ptr to list of values encoded by e_v
	bss	encoded_values,2
"
	segdef	entry_arg		ptr to arg for entry macro
	bss	entry_arg,2
"
	segdef	entry_vector_pointer	ptr to entry_vector in fortran|pl1
	bss	entry_vector_pointer,2
"
	segdef	ev_qual		ptr to param ptr qual exp used by e_v
	bss	ev_qual,2
"
	segdef	ext_proc_list	ptr to list of external procedures used
	bss	ext_proc_list,2
"
	segdef	ext_var_list	ptr to list of external variables used
	bss	ext_var_list,2
"
	segdef	first_op		ptr to first operator node used by eval_exp
	bss	first_op,2
"
	segdef	first_ref		ptr to first reference node on get_reference list
	bss	first_ref,2
"
	segdef	format_list	ptr to list of format nodes
	bss	format_list,2
"
	segdef	jump_label	ptr to scratch label used by jump_op
	bss	jump_label,2
"
	segdef	label_list	ptr to list of label_arrays
	bss	label_list,2
"
	segdef	last_encoded	ptr to last value encoded by e_v
	bss	last_encoded,2
"
	segdef	last_label	ptr to last label array in label_list
	bss	last_label,2
"
	segdef	link_base		ptr to base of linkage section buffer
	bss	link_base,2
"
	segdef	link_reloc_base	ptr to base of linkage section relocation buffer
	bss	link_reloc_base,2
"
	segdef	long_string_temp	ptr to ref node for long string temp cell
	bss	long_string_temp,2
"
	segdef	m_s_p		ptr to machine state node
	bss	m_s_p,2
"
	segdef	ms_list		ptr to list of machine state nodes
	bss	ms_list,2
"
	segdef	name_list		ptr to list of names kept by "name_assign"
	bss	name_list,2
"
	segdef	next_op		ptr to next operator node to be used by eval_exp
	bss	next_op,2
"
	segdef	next_ref		ptr to next reference node on get_reference list
	bss	next_ref,2
"
	segdef	objmap_pt		ptr to object map in object segment
	bss	objmap_pt,2
"
	segdef	profile_base	ptr to base of seg where profile is placed
	bss	profile_base,2
"
	segdef	prol_ent		ptr to label defining prologue entry point
	bss	prol_ent,2
"
	segdef	return_operator	ptr to node for return op in pl1_ops_
	bss	return_operator,2
"
	segdef	root		ptr to root of program being compiled
	bss	root,2
"
	segdef	stop_operator	ptr to node for return op in pl1_ops_
	bss	stop_operator,2
"
	segdef	return_main_operator	ptr to node for return_main op in pl1_ops_
	bss	return_main_operator,2
"
	segdef    stat_base           ptr to base of static section buffer
stat_base:
	its       -1,1,n
"
	segdef	sym_base		ptr to base of symbol section buffer
	bss	sym_base,2
"
	segdef	sym_reloc_base	ptr to base of symbol section relocation buffer
	bss	sym_reloc_base,2
"
	segdef	sym_use_base	ptr to array giving use of symbols in text section
	bss	sym_use_base,2
"
	segdef	temp_ref		ptr to reference for temp result of operator
	bss	temp_ref,2
"
	segdef	temporary_list	ptr to list of temporaries
	bss	temporary_list,2
"
	segdef	text_base		ptr to base of text section buffer
	bss	text_base,2
"
	segdef	text_reloc_base	ptr to base of text section relocation buffer
	bss	text_reloc_base,2
"
	segdef	validate_proc	ptr to dcl of validation procedure
validate_proc:
	its	-1,1,n
"
	segdef	word_ref		ptr to ref node for word offset part of offset
	bss	word_ref,2
"
"	AGGREGATES
"
	segdef	statement_map
	bss	statement_map,1
	end




		    check_o_and_s.pl1               10/03/83  1730.5rew 10/03/83  1007.9       20070



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

check_o_and_s: proc(pt) returns(ptr);

dcl	pt ptr;		/* points at operator node */

dcl	(d,p,q,p1) ptr,
	(i,m,n) fixed bin,
	(mod,null) builtin;

dcl	get_variable entry(ptr) returns(ptr),
	create_list entry(fixed bin) returns(ptr);

dcl	fix_bin	fixed bin based;

dcl	1 descriptor based aligned like desc_;

%include operator;
%include list;
%include block;
%include reference;
%include symbol;
%include nodes;
%include op_codes;
%include descriptor;
%include desc_types;

	p = pt;
	if p -> node.type ^= operator_node
	then do;
no:	     return(null);
	     end;

	if p -> op_code ^= desc_size then goto no;

	q = p -> operand(2);
	if q -> node.type ^= reference_node then goto no;

	d = q;

	q = q -> reference.qualifier;
	if q = null then goto no;

	if q -> node.type ^= operator_node then goto no;
	if q -> op_code ^= param_desc_ptr then goto no;

	if d -> reference.symbol -> symbol.descriptor -> symbol.initial -> descriptor.type_ = structure_desc
	     then go to no;

	n = 2 * q -> operand(2) -> reference.symbol -> symbol.initial -> fix_bin;

	p = q -> operand(3);
	p1 = p -> block.o_and_s;
	if p1 = null then goto no;

	if p1 -> list.number < n
	then do;
	     m = n + mod(n,2);
	     q = create_list(m);

	     do i = 1 to p1 -> list.number;
		q -> element(i) = p1 -> element(i);
		end;

	     p -> block.o_and_s, p1 = q;
	     end;

	q = p1 -> element(n);
	if q = null then p1 -> element(n), q = get_variable(p);
	return(q);


	end;




		    code_generator.pl1              10/03/83  1730.5rew 10/03/83  1008.0      229779



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


/* This is the "main program" of the code generator.  It performs various
   initialization tasks, assigns storage and constants, compiles the
   program, and then finishes up the object segment.

   Initial Version:  1 February 1971 by BLW
	Modified: 22 January 1973 by BLW
	Modified:	9 July 1973 by RAB for EIS
	Modified:	5 June 1975 by EEW for separate_static
	Modified:	19 June 1975 by RAB for listing label arrays
	Modified:	10 January 1976 by RAB for cg_stat$return_operator to fix 1453
	Modified:	1 June 1976 by RAB for *system links
	Modified:	27 Sept 1976 by RAB to fix 1523
	Modified:	21 Oct 1976 by RAB to fix 1540
	Modified:	1 Dec 1976 by RAB for -long_profile	
	Modified: April 1977 by RHS to use get_temp_segments_ and release_temp_segments_
	Modified:	25 August 1977 by RAB to insert debugging code for
		call to release_temp_segments_	
	Modified: 22 Feb 1978 by PCK to implement the stop statement and options(main)
	Modified: 4 October 1980 by M. N. Davidoff to fix cleanup handler bugs.  Fixes 2023.
	Modified: 19 November 1981 by C. Hornig to fix long_profile with separate_static.
*/
/* format: style3 */
code_gen_:
     proc (seg_name, compiler_name, version_name, root, validate_proc, temporary_list, constant_list, ok_ptr, object_pt,
	clock_time, profile_size, produce_listing, symbols_on, print_cp_dcl, map, assembly_list, table_option,
	generate_symtab, print, error_finish, bit_cnt, npages, ncpu, link, dummy_block, generate_map, nnpages, nncpu,
	long_profile);

dcl	seg_name		char (32) var,		/* name of program being compiled */
	compiler_name	char (3) var,		/* name of compiler, i.e. "pl1" */
	version_name	char (132) var,		/* version of compiler */
	root		ptr,			/* ptr to root block */
	validate_proc	ptr,			/* ptr to dcl of validation proc */
	temporary_list	ptr,			/* ptr to list of temporaries */
	constant_list	ptr,			/* ptr to list of constants */
	ok_ptr		ptr,			/* ptr to OK list for get data */
	object_pt		ptr,			/* ptr to object segment to fill-in */
	clock_time	fixed bin (71),		/* clock reading at start of compilation */
	profile_size	fixed bin,		/* size of profile table */
	produce_listing	bit (1) aligned,		/* ON if listing being produced */
	symbols_on	bit (1) aligned,		/* ON if symbol map should be written */
	print_cp_dcl	bit (1) aligned,		/* ON to see compiler produced dcls */
	map		bit (1) aligned,		/* ON to get map of object program */
	assembly_list	bit (1) aligned,		/* ON to get listing of instructions */
	table_option	bit (1) aligned,		/* ON if "table" option used */
	generate_symtab	bit (1) aligned,		/* ON if run-time symbol table needed */
	print		entry (ptr, bit (1) aligned, bit (1) aligned),
						/* program to call to print symbols */
	error_finish	entry,			/* program to call to finish up errors */
	bit_cnt		fixed bin (22),		/* set to bit count of object seg */
	(npages, nnpages)	fixed bin,		/* set to number of page faults */
	(ncpu, nncpu)	fixed bin (71),		/* set to CPU time used */
	link		bit (1) aligned,		/* ON if link to pl1_operators_ desired */
	dummy_block	ptr,			/* ptr to block used in encoding expressions
					   for runtime symbol table */
	generate_map	bit (1) aligned,		/* ON if statement map wanted */
	long_profile	bit (1) aligned;		/* ON if long_profile desired */

dcl	(
	cg_stat$double_temp,
	cg_stat$long_string_temp,
	cg_stat$dummy_block,
	cg_stat$ms_list,
	cg_stat$jump_label,
	cg_stat$m_s_p,
	cg_stat$name_list,
	cg_stat$format_list,
	cg_stat$complex_ac,
	cg_stat$dummy_statement,
	cg_stat$stat_base,
	cg_stat$link_base,
	cg_stat$link_reloc_base,
	cg_stat$sym_base,
	cg_stat$next_ref,
	cg_stat$sym_reloc_base,
	cg_stat$root,
	cg_stat$validate_proc,
	cg_stat$first_ref,
	cg_stat$cur_statement,
	cg_stat$temporary_list,
	cg_stat$constant_list,
	cg_stat$text_base,
	cg_stat$entry_arg,
	cg_stat$sym_use_base,
	cg_stat$text_reloc_base,
	cg_stat$encoded_values,
	cg_stat$def_base,
	cg_stat$def_reloc_base,
	cg_stat$desc_list_ptr,
	cg_stat$first_op,
	cg_stat$next_op,
	cg_stat$agg_temps,
	cg_stat$objmap_pt,
	cg_stat$cur_node,
	cg_stat$label_list,
	cg_stat$last_label,
	cg_stat$return_operator,
	cg_stat$stop_operator,
	cg_stat$profile_base,
	cg_stat$return_main_operator
	)		ptr ext;

dcl	(
	cg_stat$link_origin,
	cg_stat$def_origin,
	cg_stat$sym_origin,
	cg_stat$last_call,
	cg_stat$stat_pos,
	cg_stat$stat_rel,
	cg_stat$def_pos,
	cg_stat$text_pos,
	cg_stat$link_pos,
	cg_stat$sym_pos,
	cg_stat$list_break	(4),
	cg_stat$cur_level,
	cg_stat$link_begin,
	cg_stat$profile_pos,
	cg_stat$max_program_size,
	cg_stat$bit_count,
	cg_stat$link_rel,
	cg_stat$sym_rel,
	cg_stat$def_pool	(0:10),
	cg_stat$def_pool_size,
	cg_stat$profile_start
	)		fixed bin ext;

dcl	cg_stat$map_start	fixed bin (18) ext;

dcl	(
	cg_stat$save_exp_called,
	cg_stat$generate_symtab,
	cg_stat$extended_stack,
	cg_stat$profile_option,
	cg_stat$separate_static,
	cg_stat$skip_to_label,
	cg_stat$table_option,
	cg_stat$generate_map,
	cg_stat$io_used,
	cg_stat$use_type_6,
	cg_stat$long_profile,
	cg_stat$debug
	)		bit (1) aligned ext static;

dcl	ctl_char$ff	char (1) aligned ext;

dcl	cg_stat$seg_name	char (32) var ext,
	cg_stat$compiler_name
			char (12) var ext,
	cg_stat$version_name
			char (132) var ext,
	cg_stat$clock_time	fixed bin (71) ext,
	cg_stat$used_operator
			bit (900) ext;

dcl	1 cg_stat$statement_map
			unaligned ext,
	  2 (first, last)	bit (18);

dcl	pl1_stat_$version	fixed bin ext static;

dcl	(p, q, qr, ok, text_base, text_reloc_base)
			ptr,
	clength		fixed bin (24),
	(text_pos, stat_pos, link_pos, sym_pos, amt, def_pos, defrel, statrel, linkrel, symbolrel, n)
			fixed bin (18),
	(i, code)		fixed bin,
	(pages, ppages)	fixed bin int static,
	(cpu, ccpu)	fixed bin (71) int static;

dcl	(
	gen_pl1_symbol$beg_symbol,
	compile_formats,
	gen_pl1_symbol$end_symbol,
	gen_pl1_linkage$init_linkage
	)		entry,
	error		entry (fixed bin, ptr, ptr);
dcl	com_err_		entry options (variable);
dcl	(assign_storage, gen_pl1_linkage, compile_block)
			entry (ptr),
	mst$block_nodes	entry (ptr, fixed bin) returns (fixed bin);
dcl	(
	pl1_print$non_varying,
	pl1_print$non_varying_nl
	)		entry (char (*) aligned, fixed bin),
	hcs_$get_usage_values
			entry (fixed bin, fixed bin (71), fixed bin),
	hcs_$set_bc_seg	entry (ptr, fixed bin, fixed bin),
	(display_pl1_map, display_pl1_text)
			entry (ptr),
	create_block	entry (bit (9) aligned, ptr) returns (ptr),
	create_statement	entry (bit (9) aligned, ptr, ptr, bit (12) aligned) returns (ptr),
	create_reference	entry (ptr) returns (ptr),
	create_label	entry (ptr, ptr, bit (3) aligned) returns (ptr),
	state_man$create_ms entry returns (ptr);
dcl	compile_link	entry (char (*) aligned, bit (18) aligned, fixed bin) returns (fixed bin);
dcl	c_a		entry (fixed bin, fixed bin) returns (ptr),
	cg_error		entry (fixed bin, fixed bin);
dcl	debug		entry options (variable);
dcl	ioa_		entry options (variable),
	expmac		entry (fixed bin (15), ptr),
	expmac$fill_usage	entry (fixed bin (18), fixed bin (17));

dcl	(get_temp_segments_, release_temp_segments_)
			entry (char (*), (*) ptr, fixed bin);

dcl	profile_width	init (2) fixed bin int static;

dcl	(addrel, bit, divide, fixed, mod, null, ptr, size, substr, verify)
			builtin;

dcl	(out_of_bounds, cleanup)
			condition;

dcl	1 ok_list		aligned based,
	  2 number	fixed bin,
	  2 offset	(1) unaligned bit (18);

dcl	1 ok_list_reloc	aligned based,
	  2 number	fixed bin,
	  2 offset	(1) unaligned bit (18);

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

dcl	image		(amt) fixed bin based,
	def_image		(def_pos) fixed bin based,
	link_image	(link_pos) fixed bin based,
	stat_image	(stat_pos) fixed bin based,
	symbol_image	(sym_pos) fixed bin based;

dcl	based_cs		char (clength) based aligned;
dcl	based_bs		bit (clength) based aligned;

dcl	get_ops_mac	init (195) fixed bin (15) int static;

dcl	return_operator_loc init (409) fixed bin (15) int static options (constant);
dcl	stop_operator_loc	init (801) fixed bin (15) int static options (constant);
dcl	return_main_operator_loc
			init (802) fixed bin (15) int static options (constant);

dcl	temp_segs		(8) ptr;
dcl	ss_temp_seg	(1) ptr;
dcl	my_name		char (32);

%include symbol;
%include block;
%include reference;
%include runtime_symbol;
%include operator;
%include list;
%include boundary;
%include block_types;
%include stack_head;
%include bases;
%include declare_type;
%include object_map;
%include cgsystem;
%include relbts;
%include its;
%include long_profile;
%include pl1_version;

/* program */

	cg_stat$bit_count = 0;
	pages = 0;
	ppages = 0;
	cpu = 0;
	ccpu = 0;

	if pl1_stat_$version ^= pl1_version | compiler_name ^= "pl1"
	then call error (342, null, null);

	my_name = compiler_name;

/* create scratch segments and set pointers to various buffers */

	temp_segs (*) = null;
	ss_temp_seg (*) = null;

	on cleanup
	     begin;
		call release_temp_segments_ (my_name, temp_segs (*), code);
		call release_temp_segments_ (my_name, ss_temp_seg (*), code);
	     end;

	call get_temp_segments_ (my_name, temp_segs, code);
	if code ^= 0
	then do;
get_temp_segs_failed:
		call com_err_ (code, my_name, "get_temp_segments_");
		goto done;
	     end;

	cg_stat$link_base = temp_segs (1);
	cg_stat$link_reloc_base = temp_segs (2);
	cg_stat$def_base = temp_segs (3);
	cg_stat$def_reloc_base = temp_segs (4);
	cg_stat$sym_base = temp_segs (5);
	cg_stat$sym_reloc_base = temp_segs (6);
	cg_stat$text_reloc_base = temp_segs (7);
	cg_stat$sym_use_base = temp_segs (8);

	cg_stat$link_origin, cg_stat$def_origin, cg_stat$sym_origin = 0;

	if cg_stat$separate_static
	then do;
		call get_temp_segments_ (my_name, ss_temp_seg, code);
		cg_stat$stat_base = ss_temp_seg (1);
		if code ^= 0
		then goto get_temp_segs_failed;
	     end;

/* initialize position in various buffers */

	cg_stat$def_pos, cg_stat$stat_pos, cg_stat$text_pos, cg_stat$sym_pos = 0;
	cg_stat$link_pos = 8;

/* set up static versions of input arguments */

	cg_stat$seg_name = seg_name;
	cg_stat$compiler_name = "PL/I";
	cg_stat$use_type_6 = "0"b;
	cg_stat$version_name = version_name;
	cg_stat$root = root;
	cg_stat$validate_proc = validate_proc;
	cg_stat$temporary_list = temporary_list;
	cg_stat$constant_list = constant_list;
	text_base, cg_stat$text_base = ptr (object_pt, 0);
	text_reloc_base = cg_stat$text_reloc_base;
	cg_stat$clock_time = clock_time;
	cg_stat$table_option = table_option;
	cg_stat$long_profile = long_profile;
	cg_stat$generate_symtab = generate_symtab;

/* the generate_symtab bit will only be on at entry to code generator
	   if put data or get data statements were used in program */

	cg_stat$io_used = generate_symtab;

/* initialize various other parts of the compiler */

	cg_stat$last_call = 0;

	cg_stat$cur_node, cg_stat$desc_list_ptr, cg_stat$label_list, cg_stat$last_label, cg_stat$first_ref,
	     cg_stat$next_ref, cg_stat$ms_list, cg_stat$first_op, cg_stat$next_op, cg_stat$name_list,
	     cg_stat$format_list, cg_stat$cur_statement, cg_stat$agg_temps = null;

	cg_stat$skip_to_label, cg_stat$used_operator = "0"b;

	cg_stat$m_s_p = state_man$create_ms ();

/* create pointers to ref nodes for string operations */

	cg_stat$complex_ac = stk_add (complex_ac_loc);
	cg_stat$double_temp = stk_add (double_temp_loc);
	cg_stat$long_string_temp = stk_add (long_string_loc);
	cg_stat$long_string_temp -> reference.tag = "010000"b;
						/* * */
	cg_stat$return_operator = stk_add (return_operator_loc);
	cg_stat$return_operator -> address.base = ap;
	cg_stat$stop_operator = stk_add (stop_operator_loc);
	cg_stat$stop_operator -> address.base = ap;
	cg_stat$return_main_operator = stk_add (return_main_operator_loc);
	cg_stat$return_main_operator -> address.base = ap;

/* Initialize definition pool for external static without init clauses */

	do i = 0 to cg_stat$def_pool_size;
	     cg_stat$def_pool (i) = 0;
	end;

/* assign storage */

	cg_stat$root -> block.level = 0;
	call assign_storage ((cg_stat$root -> block.son));

	if cg_stat$long_profile
	then do;
		cg_stat$profile_option = "0"b;
		cg_stat$profile_pos = size (long_profile_header);
		amt = size (long_profile_header) + profile_size * size (long_profile_entry);

		if cg_stat$separate_static
		then do;
			cg_stat$profile_start = cg_stat$stat_pos + mod (cg_stat$stat_pos, 2);
			cg_stat$profile_base = addrel (cg_stat$stat_base, cg_stat$profile_start);
			cg_stat$stat_pos = cg_stat$profile_start + amt;
		     end;
		else do;
			cg_stat$profile_start = cg_stat$link_pos + mod (cg_stat$link_pos, 2);
			cg_stat$profile_base = addrel (cg_stat$link_base, cg_stat$profile_start);
			cg_stat$link_pos = cg_stat$profile_start + amt;
		     end;

		cg_stat$profile_base -> long_profile_header.last_offset = dummy_entry_offset;
	     end;

	else do;
		cg_stat$profile_option = profile_size ^= 0;
		if cg_stat$profile_option
		then do;
			amt = profile_width * (profile_size + 1);

			if cg_stat$separate_static
			then do;
				cg_stat$profile_base = cg_stat$stat_base;
				cg_stat$profile_pos = cg_stat$stat_pos;
				cg_stat$stat_pos = cg_stat$stat_pos + amt;
			     end;
			else do;
				cg_stat$profile_base = cg_stat$link_base;
				cg_stat$profile_pos = cg_stat$link_pos;
				cg_stat$link_pos = cg_stat$link_pos + amt;
			     end;
		     end;
	     end;

	cg_stat$generate_map = generate_map | cg_stat$table_option | cg_stat$profile_option | cg_stat$long_profile;

	cg_stat$link_begin = cg_stat$link_pos;
	cg_stat$list_break (1) = cg_stat$text_pos;

/* generate linkage section */

	call gen_pl1_linkage$init_linkage;
	call gen_pl1_linkage (root);

/* assign multi-word constants */

	cg_stat$list_break (2), text_pos = cg_stat$text_pos;

	p = cg_stat$constant_list;
	do while (p ^= null);

	     q = p -> symbol.equivalence;
	     if q ^= null
	     then do;
		     q -> symbol.passed_as_arg =
			q -> symbol.passed_as_arg
			| (p -> symbol.passed_as_arg | p -> symbol.arg_descriptor | p -> symbol.aliasable);
		     goto loop;
		end;

	     if p -> symbol.allocate
	     then do;

		     q = p -> symbol.initial;
		     amt = p -> symbol.c_word_size;

		     if amt = 0
		     then go to clear;

		     if amt > 2
		     then do;
			     clength = p -> symbol.c_bit_size;
			     if p -> symbol.char
			     then do;
				     clength = divide (clength, bits_per_char, 24, 0);
				     if verify (q -> based_cs, substr (q -> based_cs, 1, 1)) = 0
				     then go to clear;
				end;
			     else if p -> symbol.bit
			     then if (q -> based_bs = "0"b) | (^q -> based_bs = "0"b)
				then go to clear;
			end;
		     else if amt = 1
		     then do;
			     if p -> symbol.passed_as_arg
			     then goto put;
			     if p -> symbol.arg_descriptor
			     then goto put;
			     if p -> symbol.dcl_type = by_declare & table_option
			     then goto put;
			     if p -> symbol.dimensioned
			     then goto put;
			     if p -> symbol.aliasable
			     then goto put;

			     if q -> half.left = "0"b
			     then goto clear;
			     if q -> half.right = "0"b
			     then goto clear;
			     if q -> half.left ^= (18)"1"b
			     then goto put;

clear:
			     p -> symbol.allocate = "0"b;
			     goto loop;
			end;

		     if amt = 2 | p -> symbol.boundary = mod2_
		     then text_pos = text_pos + mod (text_pos, 2);

put:
		     p -> symbol.location = text_pos;
		     p -> symbol.allocated = "1"b;

		     addrel (text_base, text_pos) -> image = q -> image;

		     text_pos = text_pos + amt;
		end;

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

	cg_stat$list_break (3), cg_stat$text_pos = text_pos;

	if ^link
	then cg_stat$entry_arg = null;
	else do;

/* generate sequence to get ptr to operator segment */

		call expmac ((get_ops_mac), c_a (compile_link ("pl2_operators_$entry_operators", "0"b, 0), 9));

/* get reference node to record where we put sequence just generated
	        (we can't use c_a since there may be a number of prologue statements
	         compiled before we ever use the reference node in an entry) 	     */

		p = create_reference (null);
		p -> reference.ic_ref = "1"b;
		p -> reference.tag = "000100"b;	/* IC */
		p -> reference.address.offset = bit (fixed (text_pos, 15), 15);
		p -> reference.no_address = "0"b;
		p -> reference.perm_address = "1"b;
		cg_stat$entry_arg = p;
	     end;

	cg_stat$list_break (4) = cg_stat$text_pos;

/* create symbol table header and generate run-time
	   symbol table if it is needed */

	call gen_pl1_symbol$beg_symbol;

	if dummy_block ^= null
	then cg_stat$dummy_block = dummy_block;
	else cg_stat$dummy_block = create_block (internal_procedure, null);

	cg_stat$jump_label = create_label (cg_stat$dummy_block, null, (by_compiler));
	cg_stat$dummy_statement = create_statement ((9)"0"b, cg_stat$dummy_block, null, (12)"0"b);
	cg_stat$cur_level = 0;

	cg_stat$encoded_values = null;
	if cg_stat$generate_symtab | table_option
	then do;

/* generate run-time symbol table */

		code = mst$block_nodes (cg_stat$root, 0);

/* process the OK lists for get data */

		text_pos = cg_stat$text_pos;

		ok = ok_ptr;
		do while (ok ^= null);
		     q = addrel (text_base, text_pos);
		     qr = addrel (text_reloc_base, text_pos);
		     p = ok -> element (2);

		     q -> ok_list.number = p -> operator.number;
		     p -> operator.number = text_pos;

		     do i = 1 to q -> ok_list.number;
			q -> ok_list.offset (i) = bit (p -> operand (i) -> reference.symbol -> symbol.runtime, 18);
			qr -> ok_list_reloc.offset (i) = rc_s;
		     end;

		     text_pos = text_pos + divide (q -> ok_list.number + 3, 2, 18, 0);
		     ok = ok -> element (1);
		end;

		cg_stat$text_pos = text_pos;
	     end;

/* compile formats */

	if cg_stat$format_list ^= null
	then call compile_formats;

/* compile the program !! */

	cg_stat$map_start = cg_stat$sym_pos;
	cg_stat$statement_map.first = bit (cg_stat$map_start, 18);

	cg_stat$save_exp_called, cg_stat$extended_stack = "0"b;
	call compile_block (cg_stat$root);

/* now assign any constants that were generated during compilation
	   and any single word constants not usable via direct modifier */

	text_pos = cg_stat$text_pos;

	p = cg_stat$constant_list;
	do while (p ^= null);

	     if p -> symbol.allocated
	     then goto step;

	     if p -> symbol.allocate
	     then do;

		     q = p -> symbol.equivalence;
		     if q = null
		     then q = p;
		     else if q -> symbol.allocated
		     then do;
			     n = q -> symbol.location;
			     call fill_use (p, n);
			     goto step;
			end;

		     amt = q -> symbol.c_word_size;
		     if amt = 2 | q -> symbol.boundary = mod2_
		     then text_pos = text_pos + mod (text_pos, 2);

		     call fill_use (p, text_pos);

		     if q ^= p
		     then call fill_use (q, text_pos);

		     if p -> symbol.storage_block
		     then call gen_relocation;

		     q = addrel (text_base, text_pos);
		     q -> image = p -> symbol.initial -> image;

		     text_pos = text_pos + amt;
		end;

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

	cg_stat$text_pos = text_pos;

/* finish the long_profile */

	if cg_stat$long_profile
	then cg_stat$profile_base -> long_profile_header.nentries =
		divide (cg_stat$profile_pos - size (long_profile_header), size (long_profile_entry), 17, 0);

/* finish the symbol table */

	call gen_pl1_symbol$end_symbol;

/* finish up the object segment */

	on out_of_bounds call cg_error (311, cg_stat$max_program_size);

	text_pos = cg_stat$text_pos;
	def_pos = cg_stat$def_pos;
	stat_pos = cg_stat$stat_pos;
	link_pos = cg_stat$link_pos;
	sym_pos = cg_stat$sym_pos;

	defrel = text_pos;
	cg_stat$link_rel, linkrel = divide (defrel + def_pos + 1, 2, 17, 0) * 2;
	cg_stat$stat_rel, statrel = divide (linkrel + link_pos + 1, 2, 17, 0) * 2;
	cg_stat$sym_rel, symbolrel = divide (statrel + stat_pos + 1, 2, 17, 0) * 2;

	addrel (text_base, defrel) -> def_image = cg_stat$def_base -> def_image;
	addrel (text_base, linkrel) -> link_image = cg_stat$link_base -> link_image;
	if stat_pos > 0
	then addrel (text_base, statrel) -> stat_image = cg_stat$stat_base -> stat_image;
	addrel (text_base, symbolrel) -> symbol_image = cg_stat$sym_base -> symbol_image;

/* fill in standard object map */

	n = divide (symbolrel + sym_pos + 1, 2, 17, 0) * 2;
	p = addrel (text_base, n);
	cg_stat$objmap_pt = p;

	p -> object_map.decl_vers = 2;
	p -> object_map.identifier = "obj_map";
	p -> object_map.text_length = bit (text_pos, 18);
	p -> object_map.definition_offset = bit (defrel, 18);
	p -> object_map.definition_length = bit (def_pos, 18);
	p -> object_map.linkage_offset = bit (linkrel, 18);
	p -> object_map.linkage_length = bit (link_pos, 18);
	if cg_stat$separate_static
	then do;
		p -> object_map.static_offset = bit (statrel, 18);
		p -> object_map.static_length = bit (stat_pos, 18);
	     end;
	else do;
		p -> object_map.static_offset = bit (fixed (linkrel + 8, 18), 18);
		p -> object_map.static_length = bit (fixed (cg_stat$link_begin - 8, 18), 18);
	     end;
	p -> object_map.symbol_offset = bit (symbolrel, 18);
	p -> object_map.symbol_length = bit (sym_pos, 18);

	p -> object_map.format.relocatable, p -> object_map.format.procedure, p -> object_map.format.standard = "1"b;
	p -> object_map.format.separate_static = cg_stat$separate_static;

	addrel (p, size (p -> object_map)) -> map_ptr = bit (n, 18);

/* compute bit count of object segment */

	n = n + size (p -> object_map) + 1;
	cg_stat$bit_count = n * 36;

	call hcs_$set_bc_seg (text_base, cg_stat$bit_count, code);

	call hcs_$get_usage_values (pages, cpu, i);

	revert out_of_bounds;

	cg_stat$cur_statement = null;

	if produce_listing
	then do;
		if symbols_on
		then call print (cg_stat$root, print_cp_dcl, "0"b);

		call pl1_print$non_varying_nl ("", 0);

		call error_finish;

		if map
		then do;
			call pl1_print$non_varying_nl ("", 0);
			call display_pl1_map (cg_stat$root);
		     end;

		if assembly_list
		then do;
			call pl1_print$non_varying (ctl_char$ff, 1);
			call display_pl1_text (cg_stat$root);
		     end;
	     end;

done:
	call hcs_$get_usage_values (ppages, ccpu, i);

/* all done */

	if code ^= 0
	then call com_err_ (code, compiler_name, seg_name);

	bit_cnt = cg_stat$bit_count;
	npages = pages;
	ncpu = cpu;
	nnpages = ppages;
	nncpu = ccpu;

	pl1_stat_$version = 0;

	call release_temp_segments_ (my_name, temp_segs, code);
	if code ^= 0
	then goto release_failed;

	if cg_stat$separate_static
	then do;
		call release_temp_segments_ (my_name, ss_temp_seg, code);
release_failed:
		if code ^= 0
		then do;
			call com_err_ (code, my_name, "release_temp_segments_");
			if cg_stat$debug
			then do;
				call ioa_ ("debug: ");
				call debug;
			     end;
		     end;
	     end;

	return;

/* This entry is called by the command program to get the bit count
   when the listing segment has overflowed and a non-local return
   has been done past the code_generator */

return_bit_count:
     entry (bit_count, np, nc, nnp, nnc);

dcl	(bit_count, np, nnp)
			fixed bin,
	(nc, nnc)		fixed bin (71);

	pl1_stat_$version = 0;
	bit_count = cg_stat$bit_count;
	np = pages;
	nc = cpu;
	nnp = ppages;
	nnc = ccpu;

	return;

fill_use:
     proc (pt, loc);

dcl	pt		ptr,
	loc		fixed bin (18);

dcl	p		ptr;

	p = pt;
	call expmac$fill_usage (loc, (p -> symbol.location));
	p -> symbol.location = loc;
	if p -> symbol.varying
	then p -> symbol.location = p -> symbol.location + 1;
	p -> symbol.allocated = "1"b;

	if p -> symbol.runtime
	then addrel (cg_stat$sym_base, p -> symbol.runtime) -> runtime_symbol.address.location = bit (loc, 18);
     end fill_use;

stk_add:
     proc (k) returns (ptr);

dcl	k		fixed bin (15),
	q		ptr;

	q = create_reference (null);
	q -> reference.even, q -> reference.ext_base = "1"b;
	q -> reference.no_address = "0"b;
	q -> reference.perm_address = "1"b;
	q -> reference.base = sp;
	q -> reference.address.offset = bit (k, 15);
	q -> reference.units = word_;

	return (q);
     end stk_add;

/* generates relocation bits for relocatable constants
   (relocatable constants are those constants remaining to
   be allocated after return from compile_block that are
   declared with symbol.storage_block on) */

gen_relocation:
     proc;

dcl	c		ptr;
dcl	(i, rscan)	fixed bin;

dcl	1 descriptor	(amt) aligned based,
	  2 base		bit (3) unal,
	  2 offset	bit (15) unal,
	  2 fract		bit (2) unal,
	  2 type		bit (4) unal,
	  2 dscale	fixed bin (5) unal,
	  2 dlength	bit (6) unal;

	c = p -> symbol.initial;

	if p -> symbol.boundary < mod2_
	then do;

/* EIS descriptors */

		rscan = text_pos;
		do i = 1 to amt;
		     if c -> descriptor (i).base = lp
		     then addrel (text_reloc_base, rscan) -> half.left = rc_is15;
		     rscan = rscan + 1;
		end;
	     end;

	else do rscan = text_pos + 2 to text_pos + amt - 1 by 2;

/* arg list fileed with ITP modifiers
		        (skip over first doubleword) */

		c = addrel (c, 2);

		if c -> itp.itp_mod = "100001"b	/* 41(8) - ITP */
		then if c -> itp.pr_no = lp
		     then addrel (text_reloc_base, rscan + 1) -> half.left = rc_is18;
		     else ;
		else if c -> itp.itp_mod = "000000"b	/* 0 - ordinary indirect word */
		then addrel (text_reloc_base, rscan) -> half.left = rc_t;
	     end;
     end gen_relocation;

     end code_gen_;




		    combine_tests.pl1               10/03/83  1730.5rew 10/03/83  1008.0       83223



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


/* combine_tests runs on the statements produced by optimize_if's processing of
   an if statement.  It looks for consecutive tests on the same word and tries
   to combine them.  If 2 tests to the same word are found, the following
   equations are used:

   jump_true(target,r1), jump_true(target,r2) -> jump_true(target,and_bits(r,mask))

   jump_true(next,r1), jump_false(target,r2) -> jump_false(target,and_bits(r,mask))

   jump_false(next,r1), jump_true(target,r2) -> jump_if_eq(target,and_bits(r,mask),mask)

   jump_false(target,r1), jump_false(target,r2) -> jump_if_ne(target,and_bits(r,mask),mask)


   jump_true(target,r1), jump_true(target,and_bits(r2,mask1)) -> jump_true(target,and_bits(r,mask2))

   jump_true(next,r1), jump_false(target,and_bits(r2,mask1)) -> jump_false(target,and_bits(r,mask2))

   jump_false(next_r1), jump_if_eq(target,and_bits(r2,mask1),mask1) -> jump_if_eq(target,and_bits(r,mask2),mask2)

   jump_false(target,r1), jump_if_ne(target,and_bits(r2,mask1),mask1) -> jump_if_ne(target,and_bits(r,mask2),mask2)

   Initial Version:	17 January 1977 by Richard A. Barnes
	Modified:	9 March 1977 by RAB to change mod_word handling
	Modified:	9 March 1977 by RAB to remove some dead code
	Modified:	9 April 1977 to remove mod_word operator	*/


combine_tests: proc(first,last);

dcl	first ptr,	/* first component of the if stmt */
	last ptr;		/* last component of the if stmt */

dcl	(s1,s2,stop_ptr,r1,r2,o1,o2) ptr;
dcl	(just_combined,is_next,is_target) bit(1) aligned;
dcl	(opcode1,opcode2) bit(9) aligned;
dcl	cfo(2) fixed bin(6);
dcl	wo(2) fixed bin(18);
dcl	based_bs bit(36) aligned based;
dcl	mask bit(36) aligned auto;

dcl	declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),ptr) returns(ptr);
dcl	generate_constant entry(bit(*) aligned,fixed bin) returns(ptr);
dcl	create_operator entry(bit(9) aligned,fixed bin(15)) returns(ptr);
dcl	create_reference entry(ptr) returns(ptr);
dcl	share_expression entry(ptr) returns(ptr);
dcl	adjust_ref_count entry(ptr,fixed bin);
dcl	free_node entry(ptr);

dcl	(divide,mod,null,substr) builtin;

%include cgsystem;
%include boundary;
%include op_codes;
%include nodes;
%include label;
%include list;
%include symbol;
%include reference;
%include operator;
%include statement;
%include mask;

	just_combined = "0"b;
	stop_ptr = first;

	do s2 = last repeat s1 while (s2 ^= stop_ptr);
	     s1 = s2 -> statement.back;

	     if s2 -> statement.labels = null
	     then do;
		o2 = s2 -> statement.root;
		opcode2 = o2 -> operator.op_code;

		if just_combined
		then r2 = o2 -> operand(2) -> operand(2);
		else do;
		     if opcode2 ^= jump_true & opcode2 ^= jump_false
			then goto next;
		     r2 = o2 -> operand(2);
		     if ^ candidate(r2)
			then goto next;
		     end;

		o1 = s1 -> statement.root;
		r1 = o1 -> operand(2);
		opcode1 = o1 -> operator.op_code;

		if opcode1 = jump_true | opcode1 = jump_false
		then if candidate(r1)
		then if same_word(r1,r2)
		then do;
		     is_target = o1 -> operand(1) = o2 -> operand(1);
		     is_next = "0"b;
		     if o1 -> operand(1) -> node.type = label_node
		     then if o1 -> operand(1) -> label.statement = s2 -> statement.next
			then is_next = "1"b;

		     if just_combined
		     then do;
			if opcode1 = jump_true
				& ((opcode2 = jump_true & is_target) | (opcode2 = jump_false & is_next))
			 | opcode1 = jump_false
				& ((opcode2 = jump_if_eq & is_next) | (opcode2 = jump_if_ne & is_target))
			then do;
			     call continue_combining;
			     go to step;
			     end;
			end;

		     else do;
			if opcode1 = jump_true
			then if opcode2 = jump_true
			     then if is_target
				then do;
				     call combine(jump_true,2);
				     go to step;
				     end;
				else;
			     else if is_next
				then do;
				     call combine(jump_false,2);
				     go to step;
				     end;
				else;
			else if opcode2 = jump_true
			     then if is_next
				then do;
				     call combine(jump_if_eq,3);
				     go to step;
				     end;
				else;
			     else if is_target
				then do;
				     call combine(jump_if_ne,3);
				     go to step;
				     end;
			end;
		     end;
		end;

next:	     just_combined = "0"b;
step:
	     end;

	return;


candidate:     proc(p) returns(bit(1) aligned);

dcl	     p ptr;	/* ptr to node that might be a candidate */

	     if p -> node.type = reference_node
	     then if p -> reference.c_length = 1
	     then if p -> reference.symbol -> symbol.packed
	     then if ^ p -> reference.fo_in_qual & ^ p -> reference.padded_ref & ^ p -> reference.aligned_ref
	     then if p -> reference.units = 0 | p -> reference.units = word_
		 | p -> reference.offset = null | p -> reference.modword_in_offset
	     then return("1"b);

	     return("0"b);

	     end;


same_word:     proc(p1,p2) returns(bit(1) aligned);

dcl	     (p1,p2) ptr;

dcl	     (r(2),adam(2),a) ptr;
dcl	     i fixed bin;

	     r(1) = p1;
	     r(2) = p2;

	     if r(1) -> reference.offset = r(2) -> reference.offset
	      & r(1) -> reference.qualifier = r(2) -> reference.qualifier
	     then do;
		do i = 1 to 2;
		     wo(i) = divide(r(i) -> reference.c_offset,units_per_word(r(i) -> reference.units),18,0);
		     cfo(i) = mod(r(i) -> reference.c_offset * convert_offset(r(i) -> reference.units), bits_per_word);
		     if cfo(i) ^= 0
		     then if r(i) -> reference.c_offset < 0
			then wo(i) = wo(i) - 1;

		     do a = r(i) -> reference.symbol repeat a -> symbol.father
			while (a -> symbol.father ^= null);
			end;
		     adam(i) = a;
		     end;

		if wo(1) = wo(2) & adam(1) = adam(2)
		     then return("1"b);
		end;

	     return("0"b);

	     end;


continue_combining:	proc;

dcl	     p ptr;

	     mask = o2 -> operand(2) -> operand(3) -> reference.symbol -> symbol.initial -> based_bs;
	     substr(mask,cfo(1)+1,1) = "1"b;
	     p = generate_constant(mask,1);
	     o2 -> operand(2) -> operand(3) = p;
	     if o2 -> operator.number = 3
		then o2 -> operand(3) = p;

	     call merge_and_unthread;

	     just_combined = "1"b;

	     end;


combine:	     proc(op_code,num);

dcl	     op_code bit(9) aligned,
	     num fixed bin(15);

dcl	     (a,p,r,m) ptr;

	     if num ^= 2
	     then do;
		p = create_operator(op_code,num);
		p -> operand(1) = o2 -> operand(1);
		call free_node(o2);
		o2 = p;
		end;
	     else /* o2 -> operator.op_code = op_code */ ;

	     r = create_reference(null);
	     r -> reference = r2 -> reference;
	     if ^ r -> reference.shared
	     then do;
		r -> reference.ref_count = 1;
		if r -> reference.qualifier ^= null
		     then r -> reference.qualifier = share_expression((r -> reference.qualifier));
		if r -> reference.offset ^= null
		     then r -> reference.offset = share_expression((r -> reference.offset));
		call adjust_ref_count(r2,-1);
		end;

	     r -> reference.c_length = bits_per_word;

	     if r -> reference.units ^= 0 & r -> reference.units < word_
	     then do;
		r -> reference.units = word_;
		r -> reference.c_offset = wo(2);
		r -> reference.modword_in_offset = "0"b;
		end;

	     a = create_operator(and_bits,3);
	     a -> operand(2) = r;
	     a -> operand(1) = declare_temporary(bit_mask|aligned_mask,(bits_per_word),0,null);

	     mask = (36)"0"b;
	     substr(mask,cfo(1)+1,1) = "1"b;
	     substr(mask,cfo(2)+1,1) = "1"b;
	     p = generate_constant(mask,1);
	     a -> operand(3) = p;

	     o2 -> operand(2) = a;
	     if num > 2
		then o2 -> operand(3) = p;

	     call merge_and_unthread;

	     just_combined = "1"b;

	     end;


merge_and_unthread:	proc;

	     /* moves operator from s2 to s1, unthreads s2, and frees tree
	        originally hanging from s1 */

	     s1 -> statement.root = o2;
	     call free_node(s2);

	     call decrement_target_expression((o1 -> operand(1)));
	     if ^ o1 -> operand(2) -> reference.shared
		then call adjust_ref_count((o1 -> operand(2)), -1);
	     call free_node(o1);

	     end;


decrement_target_expression:	proc(pt);

dcl	     (p,pt,s,vector,l) ptr;
dcl	     i fixed bin;

	     /* operator_semantics has ensured that the target of a conditional
	        jump will not be an operator nor a reference with expressions
	        hanging off it */

	     p = pt;

	     if p -> node.type = label_node
	     then do;
		s = p -> label.statement;
		s -> statement.reference_count = s -> statement.reference_count - 1;
		return;
		end;

	     if p -> node.type = reference_node
	     then if p -> reference.symbol ^= null
	     then if p -> reference.symbol -> node.type = label_node
	     then do;
		l = p -> reference.symbol;
		vector = l -> label.statement;

		s = vector -> element(p -> reference.c_offset + 1);
		s -> statement.reference_count = s -> statement.reference_count - 1;
		end;

	     call adjust_ref_count(p,-1);

	     end;

	end;




		    compare_ptrs.table              10/04/83  1048.1rew 10/04/83  1040.0       10917



" definition of pointer comparisons
"
	name	compare_ptrs
	segdef	compare_ptrs
"
	bool	ptr_mask_,460
	bool	unpk_to_pk_,560
	bool	aq,600000
	equ	arg1,1*4096
	equ	arg2,2*4096
	equ	arg3,3*4096
"
compare_ptrs:
	switch	0,code
	jump	HH
	jump	HE
	flipto	HE	really EH
EE:
	switch	23,type2
	jump	EE_unpk
EE_pk:
	switch	23,type3
	jump	EE_pk_unpk
EE_pk_pk:
	if	q3
	cmpq	arg2
**
	load	arg2
	cmpq	arg3
**
EE_pk_unpk:
	load	arg3
	erase	aq
	tsx0	ap|unpk_to_pk_
	cmpq	arg2
**
EE_unpk:
	switch	23,type3
	jump	EE_unpk_unpk
	flipto	EE_pk_unpk
EE_unpk_unpk:
	if	q3
	flipto	cp_ptr
**
l1:	load	arg2
cp_ptr:
	erase	aq
	eraq	arg3
	anaq	ap|ptr_mask_
**
HE:
	switch	23,type2
	jump	HE_unpk
HE_pk:
	switch	23,type3
	jump	HE_pk_unpk
HE_pk_pk:
	compile	arg2
	cmpq	arg3
**
HE_pk_unpk:
	cplsave	arg2
	jump	EE_pk_unpk
HE_unpk:
	switch	23,type3
	jump	HE_unpk_unpk
HE_unpk_pk:
	cplsave	arg2
	flipto	EE_pk_unpk
HE_unpk_unpk:
	cplsave	arg2
	jump	l1
HH:
	switch	23,type2
	jump	HH_unpk
HH_pk:
	switch	23,type3
	jump	HH_pk_unpk
HH_pk_pk:
	cplsave	arg3
	jump	HE_pk_pk
HH_pk_unpk:
	cplsave	arg3
	jump	HE_pk_unpk
HH_unpk:
	switch	23,type3
	jump	HH_unpk_unpk
HH_unpk_pk:
	cplsave	arg2
	flipto	HE_pk_unpk
HH_unpk_unpk:
	cplsave	arg3
	jump	HE_unpk_unpk
"
	end




		    compile_block.pl1               10/03/83  1730.5rew 10/03/83  1008.0       87966



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


/* program to compile a block

   Initial Version: 16 April 1971 by BLW for Version II
	Modified: 15 December 1972 by BLW
	Modified:	5 October 1975 by RAB to fix 1427
	Modified:	27 September 1976 by RAB to fix 1523
	Modified:	15 August 1977 by RAB to fix 1654
	Modified:	30 November 1978 by RAB to fix 1789
		(bad storage allocation in quick begin blocks
		 contained within quick procedures)	*/

compile_block: proc(pt);

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

dcl	(cg_stat$cur_block,cg_stat$text_base,cg_stat$sym_base,
	 cg_stat$prol_ent,cg_stat$root,cg_stat$cur_entry,
	 cg_stat$sym_reloc_base,cg_stat$m_s_p,cg_stat$cur_statement,
	 cg_stat$link_base,cg_stat$link_reloc_base,cg_stat$agg_temps,
	 cg_stat$profile_base) ptr ext static,
	(cg_stat$text_pos,cg_stat$sym_pos,cg_stat$cur_level,cg_stat$profile_pos,cg_stat$map_start) fixed bin(18) ext,
	(cg_stat$table_option,cg_stat$in_prologue,cg_stat$skip_to_label,
	 cg_stat$generate_map,cg_stat$old_id,cg_stat$profile_option,cg_stat$extended_stack) bit(1) ext;

dcl	1 cg_stat$statement_map	unaligned ext,
	2 first		bit(18),
	2 last		bit(18);

dcl	(bp,fp,sp,p,q,prol_save,entry_save,pl) ptr,
	n fixed bin,
	sym_pos fixed bin(18),
	bt bit(9),
	unused bit(1) aligned;

dcl	(addrel,fixed,max,null,size,string) builtin;

dcl	create_list entry(fixed bin) returns(ptr),
	create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
	(compile_block,compile_statement) entry(ptr),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	(state_man$flush,io_op$init_ps) entry,
	state_man$create_ms entry returns(ptr),
	make_mod entry(fixed bin(17),fixed bin) returns(fixed bin(18)),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
	expmac$zero entry(fixed bin(15)),
	expmac entry(fixed bin(15),ptr),
	stack_temp$free_aggregates entry;

dcl (	enter_prologue	init(202),
	leave_prologue	init(203),
	tra		init(169)) fixed bin(15) int static;

dcl	1 eax_ins		aligned based,
	2 offset		unal bit(18);

dcl	relocation bit(36) aligned based;

%include block;
%include reference;
%include statement;
%include list;
%include label;
%include runtime_symbol;
%include statement_map;
%include profile_entry;
%include declare_type;
%include block_types;
%include relbts;

	bp = pt;
	if bp = null then return;

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

	if bt = on_unit then goto db;

	goto l1;

compile_block$begin_block: entry(pt);

	bp = pt;
	bt = bp -> block.block_type;

	/* since we are doing a transition from one block to another,
	   block.last_auto_loc must be up to date (fixes 1789)	*/

	if bp -> block.no_stack & cg_stat$cur_block -> block.no_stack
	then do;
	     fp = cg_stat$cur_block;

	     do while(fp -> block.no_stack);
		if fp -> block.owner = null
		     then fp = fp -> block.father;
		     else fp = fp -> block.owner;
		end;

	     fp -> block.last_auto_loc = max(fp -> block.last_auto_loc, cg_stat$cur_block -> block.last_auto_loc);
	     end;

l1:	cg_stat$cur_block, fp = bp;

	if bp -> block.no_stack
	then do;

	     /* get ptr to block in which storage should be allocated */

	     do while(fp -> block.no_stack);
		if fp -> block.owner = null then fp = fp -> block.father;
		else fp = fp -> block.owner;
		end;

	     bp -> block.last_auto_loc = fp -> block.last_auto_loc;
	     end;

	cg_stat$cur_level = bp -> block.level;

	if cg_stat$m_s_p = null then cg_stat$m_s_p = state_man$create_ms(); else call state_man$flush;

	bp -> block.free_temps(1),
	bp -> block.free_temps(2),
	bp -> block.free_temps(3) = null;

	entry_save = cg_stat$cur_entry;
	cg_stat$cur_entry = null;

	prol_save = cg_stat$prol_ent;

	/* if there is only one entry to this block, we don't compile the prologue
	   sequence;  the entire prologue sequence will be inserted into the
	   main sequence by compile_tree when it sees the ex_prologue operator.
	   if there is more than one entry, we must compile prologue as a closed
	   subroutine, in this case cg_stat$prol_ent will point to a dummy
	   label used to identify start of prologue.  There is a different
	   label for each procedure | begin block */

	cg_stat$prol_ent = null;

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

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

	cg_stat$in_prologue = "1"b;
	cg_stat$skip_to_label = "0"b;

	if bt ^= begin_block
	then do;
	     cg_stat$prol_ent = create_label((bp),null,by_compiler);
	     cg_stat$prol_ent -> label.location = cg_stat$text_pos;
	     cg_stat$prol_ent -> label.allocated = "1"b;

	     bp -> block.enter.start = cg_stat$text_pos;

	     n = bp -> block.last_auto_loc;
	     bp -> block.last_auto_loc = n + 1;

	     call expmac((enter_prologue),c_a(n,4));
	     bp -> block.enter.end = cg_stat$text_pos;
	     end;

	if bp -> block.plio_ps ^= null
	then do;
	     if bt = begin_block then bp -> block.enter.start = cg_stat$text_pos;
	     call io_op$init_ps;
	     bp -> block.enter.end = cg_stat$text_pos;
	     end;

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

	if bt ^= begin_block
	then do;
	     bp -> block.leave.start = cg_stat$text_pos;
	     call expmac((leave_prologue),c_a(n,4));
	     bp -> block.leave.end = cg_stat$text_pos;
	     call state_man$flush;
	     end;

	/* initialize object map if we're generating a symbol table */

do_main:	if cg_stat$generate_map
	then do;
	     sp = addrel(cg_stat$sym_base,bp -> block.symbol_block);
	     sp -> runtime_block.map.first = bit(fixed(cg_stat$sym_pos -
	      bp -> block.symbol_block,18),18);
	     cg_stat$old_id = "0"b;
	     end;

	cg_stat$in_prologue = "0"b;

	/* compile main sequence */

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

	cg_stat$extended_stack = "0"b;	/* fixes 1654 */

	if bp -> block.no_stack then fp -> block.last_auto_loc =
	 max(fp -> block.last_auto_loc,bp -> block.last_auto_loc);

	/* free any aggregate temps that have not already been freed */

	if cg_stat$agg_temps ^= null
	     then call stack_temp$free_aggregates;

	/* do son block */

	p = bp -> block.son;
	if p ^= null
	then do;

	     /* if this is a begin block, we must generate a transfer around
	        the code for internal procedures */

	     if bt = begin_block
	     then do;

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

		     if q -> block.block_type = internal_procedure
		     then do;

			q = create_label((bp),null,by_compiler);
			call expmac((tra),prepare_operand(q,1,unused));
			cg_stat$cur_statement -> statement.object.finish =
			 cg_stat$cur_statement -> statement.object.finish + 1;
			goto l2;
			end;

		     q = q -> block.brother;
		     end;
		end;

l2:	     call compile_block(p);

	     if bt = begin_block
	     then if q ^= null
		then call expmac$fill_usage(cg_stat$text_pos,(q -> label.location));

	     end;

	if bp -> block.no_stack
	then do;

	     /* update total automatic storage used in block holding allocations
	        for this quick block.  if that block is a brother, it may have
	        already been completely compiled, so we may have to fill in the
	        stack size again */

	     fp -> block.last_auto_loc = max(fp -> block.last_auto_loc,bp -> block.last_auto_loc);
	     if fp -> block.processed then call fill_stack(fp);
	     end;
	else call fill_stack(bp);

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

chk_st:	if ^ cg_stat$generate_map then goto chk_pf;

	if bp = cg_stat$root
	then do;

	     /* just finished root block, put dummy at end of map */

	     sym_pos = cg_stat$sym_pos;
	     q = addrel(cg_stat$sym_base,sym_pos);
	     q -> statement_map.location = bit(cg_stat$text_pos,18);
	     string(q -> statement_map.source_id) = (27)"1"b;
	     addrel(cg_stat$sym_reloc_base,sym_pos) -> relocation = rc_t;
	     cg_stat$sym_pos = cg_stat$sym_pos + size(q -> statement_map);
	     cg_stat$statement_map.last = bit(cg_stat$sym_pos,18);
	     end;

	sp -> runtime_block.map.last = bit(fixed(cg_stat$sym_pos - bp -> block.symbol_block,18),18);

chk_pf:	if ^ cg_stat$profile_option then goto do_bro;

	if bp ^= cg_stat$root then goto do_bro;

	/* put dummy entry at end of profile */

	addrel(cg_stat$profile_base,cg_stat$profile_pos) -> profile_entry.map = bit(fixed(sym_pos - cg_stat$map_start,18),18);

do_bro:	if bt ^= begin_block
	then if bt ^= on_unit
	     then if bp -> block.brother ^= null
		then call compile_block((bp -> block.brother));

	cg_stat$prol_ent = prol_save;
	cg_stat$cur_entry = entry_save;

fill_stack:    proc(blk);

dcl	     blk ptr;

dcl	     stack_size bit(18),
	     (p,q) ptr;

	     /* fill stack size into first instruction (eaxy) of each entry
	        in this block */
     
	     stack_size = bit(make_mod(blk -> block.last_auto_loc,16),18);
	     p = blk -> block.entry_list;

	     if blk -> block_type = begin_block
	     then do;
		p -> eax_ins.offset = stack_size;
		return;
		end;
     
	     do while(p ^= null);
		q = p -> element(2) -> statement.labels -> element(2) -> reference.symbol;
		addrel(cg_stat$text_base,q -> label.location) -> eax_ins.offset = stack_size;
		p = p -> element(1);
		end;
     
	     end;

	end;




		    compile_entry.pl1               11/20/86  1408.9r w 11/20/86  1145.0      107163



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


/* Procedure to compile entry statements

   Initial Version: 31 March 1971 by BLW for Version II
	Modified:  29 December 1972 by BLW	  
	Modified:  23 June 1975 by EEW for new entry format
	Modified:	25 September 1975 by RAB to remove labels in prev implementation
	Modified:	17 May 1977 by RAB to check for reserved external name	
	Modified: 15 Feb 1978 by PCK to implement options(main) */

compile_entry: proc(pt,pos);

dcl	pt ptr,		/* point at statement node */
	pos fixed bin(18);		/* set to position of symbol_link info */

dcl	(cg_stat$text_base,cg_stat$def_base,cg_stat$validate_proc,cg_stat$cur_entry,cg_stat$desc_list_ptr,
	 cg_stat$entry_arg,cg_stat$cur_block,cg_stat$text_reloc_base,
	 cg_stat$cur_statement) ptr ext,
	cg_stat$last_def bit(18) aligned ext,
	cg_stat$support bit(1) aligned ext,
	cg_stat$separate_static bit(1) ext,
	cg_stat$text_pos fixed bin(18) ext;

dcl	(p,ep,lp,cb,ent_pt,tree,q,pa,p1,q1,q2,q3,arg(2),desc_pt,desc_list_ptr,def_ptr) ptr,
	bi_size fixed bin,
	(gen_dummy, not_found) bit(1) aligned,
	bit_image bit(bi_size) aligned based,
	entry_type fixed bin(15),
	(i,n,m,om,text_pos,ed) fixed bin(18);

dcl	expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
	store entry(ptr),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	base_man$update_base entry(fixed bin,ptr,fixed bin);
dcl	base_man$load_arg entry(fixed bin,ptr) returns(bit(3) aligned);
dcl	create_list entry(fixed bin(18)) returns(ptr),
	get_variable entry(ptr) returns(ptr),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	generate_definition entry(char(*) aligned,fixed bin(3),bit(18) aligned),
	expmac entry(fixed bin(15),ptr),
	error entry(fixed bin,ptr,ptr);

dcl	(addr,addrel,bit,fixed,index,null,rel,size,substr) builtin;

dcl	1 reloc(0:3)	aligned based,
	2 skip1		unal bit(12),
	2 left		unal bit(6),
	2 skip2		unal bit(12),
	2 right		unal bit(6);

dcl	based_fixed fixed bin based;

dcl	1 text_desc_reloc	aligned based,
	2 number		fixed bin (18) unsigned unaligned,
	2 array (num_descs refer (text_desc_reloc.number)) unaligned,
	  3 skip		bit(12),
	  3 reloc		bit(6);

dcl	1 entry_info	aligned based,
	2 num_args	unal bit(17),
	2 skip		unal bit(1),
	2 filler	          unal bit(18),
	2 symbol_link	unal bit(18),
	2 symbol_block	unal bit(18);

dcl (	entry_macro	init(196),
	quick_entry_mac	init(364),
	ext_entry		init(594),
	ss_ext_entry        init(646),
	ss_op_offset        init(198),
/*	ldfx2		init(8), */
/*	pf_mac		init(113), */
/*	quick_desc_mac	init(279), */
	get_desc_size	init(284),
	support_mac	init(305),
	set_main_mac	init(728),
	nop_mac		init(312)) fixed bin(15) int static options(constant);

%include definition;
%include block;
%include statement;
%include list;
%include operator;
%include symbol;
%include token;
%include reference;
%include nodes;
%include relocation_bits;
%include op_codes;
%include statement_types;
%include entry_sequence_info;

	cg_stat$cur_entry, p = pt;
	ent_pt = p -> statement.labels -> list.element(2) -> reference.symbol;
	tree = p -> statement.root;
	text_pos = cg_stat$text_pos;

	cb = cg_stat$cur_block;

	ed = 0;
	num_descs = tree -> operator.number;
	do i = 1 to num_descs;
	     if tree -> operand(i) -> reference.symbol -> symbol.star_extents
	      | tree -> operand(i) -> reference.symbol -> symbol.exp_extents		/* fortran */
	     then do;
		ed = 1;
		goto l1;
		end;
	     end;

l1:	if cb -> block.no_stack
	then do;
	     call expmac(quick_entry_mac + fixed(num_descs > 0,1) + ed,
	      c_a((cb -> block.entry_info),4));
	     if num_descs > 0
		then call base_man$update_base(6 + ed,cb,1);
	     goto define;
	     end;

	/* generate definition(s) for entry point */

	q = ent_pt -> symbol.token;
	p = addrel(cg_stat$text_base,text_pos);

	/* In the following block of code, we have these pointers:

		p ->	entry_sequence
		ep ->	relocation for entry_sequence
		q1 ->	parm_desc_ptrs
		q2 ->	relocation for parm_desc_ptrs	*/

	if ent_pt -> symbol.external
	then do;
	     if cg_stat$validate_proc = null then n = 0; else n = 4;

	     if num_descs = 0 
	     then do;

		/* no descriptors, we need not have prefix word or descriptor array */

		p = addrel(p,-1);
		ep = addrel(cg_stat$text_reloc_base,text_pos - 1);
		text_pos = text_pos + 1;
		end;

	     else do;

		/* we have descriptors, we will need to build array of pointers or use old one */

		q1 = p;
		q2 = addrel(cg_stat$text_reloc_base,text_pos);

		q1 -> parm_desc_ptrs.n_args = fixed(num_descs,18);

		/* construct array of entry-descriptor pointers */

		do i = 1 to num_descs;
		     desc_pt = tree -> operand(i) -> reference.symbol -> symbol.descriptor
		      -> reference.symbol;
		     if ^ desc_pt -> symbol.constant then desc_pt = desc_pt -> symbol.descriptor;
		     q1 -> parm_desc_ptrs.descriptor_relp(i) = bit(fixed(desc_pt -> symbol.location,18),18);
		     q2 -> text_desc_reloc.reloc(i) = rc_t;
		     end;

		bi_size = (num_descs + 1) * 18;

		/* determine if the array  already exists in the text section */

		not_found = "1"b;
		lp = cg_stat$desc_list_ptr;

		do while(lp ^= null & not_found);
		     if q1 -> bit_image = lp -> list.element(2) -> bit_image
			then not_found = "0"b;
			else lp = lp -> list.element(1);
		     end;

		if not_found
		then do;

		     /* No; put the array on the list of such arrays */

		     desc_list_ptr = create_list(2);
		     desc_list_ptr -> list.element(1) = cg_stat$desc_list_ptr;
		     cg_stat$desc_list_ptr = desc_list_ptr;
		     desc_list_ptr -> list.element(2) = q1;

		     text_pos = text_pos + size(q1 -> parm_desc_ptrs);
		     p = addrel(cg_stat$text_base,text_pos);
		     p -> entry_sequence.descr_relp_offset = rel(q1);
		     end;

		else do;

		     /* Yes; use the old array */

		     q1 -> bit_image = "0"b;
		     q2 -> bit_image = "0"b;
		     q1 -> entry_sequence.descr_relp_offset = rel(lp -> list.element(2));
		     end;

		ep = addrel(cg_stat$text_reloc_base,text_pos);

		ep -> reloc(0).left = rc_t;
		p -> entry_sequence.has_descriptors = "1"b;

		text_pos = text_pos + 2;
		end;

   	     m = index(q -> token.string,"$");
	     call generate_definition(substr(q->token.string,m+1),0,bit(text_pos,18));
	     def_ptr = addrel(cg_stat$def_base,cg_stat$last_def);

	     if substr(q -> token.string,m+1) = "symbol_table"
		then call error(364,cg_stat$cur_statement,null);

	     gen_dummy = m ^= 0;

	     end;

	else do;

	     /* internal entry, we need no descriptor information */

	     n = 2;
	     p = addrel(p,-1);
	     ep = addrel(cg_stat$text_reloc_base,text_pos-1);
	     text_pos = text_pos + 1;
	     gen_dummy = "1"b;
	     end;

	if gen_dummy
	then do;

	     /* entry name is of form a$b or we have internal entry,
	        generate dummy def for use in labelling entry */

	     call generate_definition(q -> token.string,0,bit(text_pos,18));

	     def_ptr = addrel(cg_stat$def_base,cg_stat$last_def);
	     def_ptr -> definition.ignore = "1"b;
	     end;

	def_ptr -> definition.retain = "1"b;
	p -> entry_sequence.revision_1 = "1"b;
	p -> entry_sequence.variable = ent_pt -> symbol.variable_arg_list;
	p -> entry_sequence.function = ent_pt -> symbol.returns;
	p -> entry_sequence.def_relp = cg_stat$last_def;
	ep -> reloc(1).left = rc_dp;

	/* generate entry macro */

	cg_stat$text_pos = text_pos;

	if cg_stat$separate_static
	   then entry_type = ss_ext_entry;
	   else entry_type = ext_entry;

	if cg_stat$entry_arg = null then call expmac$zero(entry_type + n + ed);
	else do;
	     if cg_stat$separate_static
	        then om = ss_op_offset;
	        else om = 0;
	     arg(1) = c_a(om + n + ed,11);	     /* bp|... */
	     arg(2) = cg_stat$entry_arg;
	     call expmac$many(entry_macro,addr(arg),2);
	     end;

	/* fill in entry trailer info */

	p = addrel(cg_stat$text_base,cg_stat$text_pos);
	p -> entry_info.num_args = bit(fixed(num_descs,17),17);
	pos = cg_stat$text_pos + 1;
	cg_stat$text_pos = cg_stat$text_pos + 2;

	/* generate validate trailer if needed */

	if n = 4
	then do;
	     p = c_a((cg_stat$validate_proc -> symbol.location),2);	/* k),dl */
	     p -> reference.relocation = rc_lp18;
	     call expmac(nop_mac,p);
	     end;

	/* entry operator loads the lp */

	call base_man$update_base(5,null,2);

	/* generate code to set support bit, if specified */

	if cg_stat$support
	     then call expmac$zero((support_mac));

	/* set main_proc bit if procedure is options(main) */

	if cb->block.options_main & pt->statement.statement_type = procedure_statement
	     then call expmac$zero((set_main_mac));

	/* assign entry to current position */

define:	call expmac$fill_usage(text_pos,(ent_pt -> symbol.location));
	ent_pt -> symbol.location = text_pos;
	ent_pt -> symbol.allocated = "1"b;

	/* The following code attempts to optimize reference to incoming arguments
	   by extracting and saving the offsets and sizes of the arguments.  When
	   a later reference is made to the expression
			bit_pointer(param_ptr(k,block))
	   the value stored in the 2*k-1 ptr in the list attached to the block
	   will be accessed.  Similarly for the expression
			desc_size(param_desc_ptr(k,block))
	   and the value in element 2*k.	*/

	n = 2 * tree -> operator.number;
	p = cb -> block.o_and_s;

	if p = null then cb -> block.o_and_s, p = create_list(n);
	else if n > p -> list.number
	     then do;
		q = create_list(n);
		do i = 1 to p -> list.number;
		     q -> element(i) = p -> element(i);
		     end;
		cb -> block.o_and_s, p = q;
		end;

	/* If this is an entry which returns something with * extent,
	   don't look at return parameter */

	m = tree -> operator.number;
	pa = ent_pt -> symbol.dcl_size;
	if pa ^= null
	then if pa -> symbol.star_extents
	     then m = m - 1;

	pa = c_a(0,4);

	/* Now do all of the sizes */

	do i = 1 to m;
	     q = tree -> operand(i);
	     q1 = q -> reference.length;
	     if q1 = null
	     then do;
		q2 = q -> reference.symbol;
		if ^ q2 -> symbol.area then goto step;
		if ^ q2 -> symbol.star_extents then goto step;

		/* have area(*) parameter, have to extract size even though
		   no explicit desc_size operator appears */

		q2 = q -> reference.qualifier;
		if q2 = null then goto step;

		if q2 -> node.type ^= operator_node then goto step;
		if q2 -> op_code ^= param_ptr then goto step;

		if q2 -> operand(3) ^= cb then goto step;

		if q2 -> operand(2) -> reference.symbol -> symbol.initial -> based_fixed ^= i then goto step;

		q3 = c_a(2*(i-1),4);
		q3 -> address.base = base_man$load_arg(1,cb);
		q3 -> address.tag = "010000"b;	/* * */

		goto gds;
		end;

	     if q1 -> node.type ^= operator_node then goto step;
	     if q1 -> op_code ^= desc_size then goto step;

	     q2 = q1 -> operand(2);
	     if q2 -> node.type ^= reference_node then goto step;

	     q2 = q2 -> reference.qualifier;
	     if q2 = null then goto step;

	     if q2 -> node.type ^= operator_node then goto step;
	     if q2 -> op_code ^= param_desc_ptr then goto step;

	     if q2 -> operand(3) ^= cb then goto step;
	     if q2 -> operand(2) -> reference.symbol -> symbol.initial -> based_fixed ^= i then goto step;

	     q3 = q1 -> operand(2);

	     /* we found a length expression to evaluate, make sure we have
	        an automatic integer variable in which to save it */

gds:	     p1 = p -> element(2*i);
	     if p1 = null then p -> element(2*i), p1 = get_variable(cb);

	     call expmac((get_desc_size),q3);
	     call store(p1);

step:	     end;

	end;




		    compile_exp.pl1                 10/03/83  1730.5rew 10/03/83  1008.0      443241



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

/* format: style3 */

/* program to compile expressions

   Initial Version:  9 April 1971 by BLW for Version II
	Modified: 25 January 1973 by BLW
	Modified:	16 February 1973 by RAB
	Modified:	27 June 1973 by RAB for EIS
	Modified:	10 Sept 1975 by RAB to fix 1417
	Modified:	25 Sept 1975 by RAB to fix 1423
	Modified:	5 Oct 1975 for repeat_fun optimization
	Modified:	1 Feb 1976 by RAB for reverse_fun optimization
	Modified:	1 Feb 1976 by RAB to fix 1458
	Modified:	10 Feb 1976 by RAB to fix 1464
	Modified:	15 June 1976 by RAB to fix 1501
	Modified:	23 June 1976 by RAB to centralize use of cg_stat$last_call
	Modified:	7 Dec 1976 by RAB to fix 1559
	Modified:	23 Dec 1976 by RAB for after,before,ltrim,rtrim
	Modified:	30 Dec 1976 by RAB for 9-bit translate, search, verify	
	Modified 770619 by PG for clock, vclock, and stacq
	Modified:	12 July 1977 by RAB to change stacq definition
	Modified:	7 August 1978 by RAB to partially fix 1731
	Modified 780828 by PG to fix 1744 and remove pos_diff_fun
	Modified:	16 July 1979 by RAB to fix 1852 (abs(unal_auto) fails)
		and to remove use of absfx1_atm for faster code.
	Modified: 25 July 1979 by PCK to implement rank and byte builtins
	Modified: 29 August 1979 by PCK to fix bug 1853
	Modified 791023 by PG to recognize substr(string_const,const,1) in several contexts by inventing
		is_string_constant.
	Modified 791023 by PG to fix 1857 in which rank and byte didn't accept expressions.
	Modified 791026 by PG to use TCT tables in pl1_operators_ when possible.
	Modified December 1979 by BSG for reverse index, verify, search, 2 char reverse, and reverse bugs.
	Modified 800218 by PG to have math builtins update machine_state.indicators.
	Modified: 29 Feb 1980 to fix 1921
	Modified:	30 March 1980 by RAB for reference.(aligned padded)_for_store_ref.
		See prepare_operand for details.
	Modified: 15 August 1980 by M. N. Davidoff to fix 2005.
	Modified: 16 September 1980 by M. N. Davidoff to fix 1985.
*/
/* format: style3 */
compile_exp:
     proc (pt);

/* parameters */

dcl	pt		ptr;			/* points at operator node */

/* external static */

dcl	(
	cg_stat$cur_node,
	cg_stat$temp_ref,
	cg_stat$eis_temp,
	cg_stat$complex_ac,
	cg_stat$text_base
	)		ptr ext,
	(
	cg_stat$text_pos,
	cg_stat$offset_null_value
	)		fixed bin ext,
	(
	cg_stat$save_exp_called,
	cg_stat$for_test_called,
	cg_stat$extended_stack
	)		bit (1) ext;

dcl	(
	opcode_info$opcode_info
			(0:118),
	opcode_info$last_opcode,
	opcode_info$table	(0:18)
	)		fixed bin ext;

/* automatic */

dcl	(
	p,
	q,
	pa,
	ref1,
	save_cur_node,
	ref		(5),
	sym		(5),
	rand		(5)
	)		ptr,
	(
	sec,
	ftc,
	in_storage,				/* Conjecture: means result is in ref1 */
	inline,
	load_it,
	atom		(5),
	update_long,
	constant_rands,
	save_it,
	scaled,
	update_ref,
	atomic,
	is_string,
	check_type,
	check_aligned
	)		bit (1) aligned,
	c_offset		fixed bin (24),
	drop		bit (1) aligned init ("0"b),
	op_code		bit (9),
	b3		bit (3) aligned;
dcl	double		bit (72) aligned;
dcl	(mvt_table, result_string)
			char (512) aligned,
	op_class		bit (5) defined (op_code) pos (1),
	op_relative	bit (4) defined (op_code) pos (6),
	(
	i,
	j,
	k,
	n,
	action,
	op_rel,
	delta,
	call_code,
	code,
	type		(5),
	bump,
	orig_count,
	rlength,
	scale,
	array		(2)
	)		fixed bin,
	(save_l1, save_l2)	fixed bin (24),
	save_mwif		bit (1),
	save_coff		fixed bin (24),
	save_units	fixed bin (3),
	(macro, m)	fixed bin (15);

/* entries */

dcl	(
	load,
	load$for_test,
	load$for_save
	)		entry (ptr, fixed bin),
	load$long_string	entry (ptr),
	(assign_op, load_size)
			entry (ptr),
	aq_man$fix_scale	entry (ptr, fixed bin, fixed bin),
	aq_man$check_strings
			entry (fixed bin (8)),
	aq_man$left_shift	entry (fixed bin (8), bit (1) aligned),
	aq_man$right_shift	entry (fixed bin (8), bit (1) aligned),
	min_max		entry (ptr),
	compile_exp	entry (ptr),
	gen_arithmetic_builtin
			entry (ptr, (5) ptr, (5) bit (1) aligned, fixed bin),
	gen_arithmetic_call entry (ptr, (5) ptr, (5) aligned bit (1)),
	xr_man$load_const	entry (fixed bin, fixed bin),
	(
	compile_exp$save,
	compile_exp$save_exp
	)		entry (ptr) returns (ptr),
	c_a		entry (fixed bin (18), fixed bin) returns (ptr),
	base_man$load_var	entry (fixed bin, ptr, fixed bin),
	(
	base_man$load_a_var,
	base_man$load_q_var,
	base_man$load_aq_var
	)		entry (ptr),
	base_to_core	entry (fixed bin, ptr),
	expmac		entry (fixed bin (15), ptr),
	expmac$many_eis	entry (fixed bin (15), ptr, fixed bin),
	expmac$conditional	entry (fixed bin (15), ptr, (5) ptr, (5) bit (1) aligned),
	(
	expmac$eis,
	expmac$one_eis
	)		entry (fixed bin (15), ptr),
	expmac$two_eis	entry (fixed bin (15), ptr, ptr),
	expmac$abs	entry (ptr, fixed bin),
	long_op$eis_operator
			entry (ptr, ptr, fixed bin (15)),
	cg_error		entry (fixed bin, fixed bin),
	prepare_operand	entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
	eval_exp		entry (ptr, bit (1) aligned) returns (ptr),
	(arith_op, decimal_op, exp_op)
			entry (ptr, (5) ptr, (5) bit (1) aligned),
	(string_op, cat_op) entry (ptr, (5) ptr, fixed bin),
	pointer_builtins	entry (ptr, bit (1) aligned),
	get_reference	entry returns (ptr),
	inline_operation	entry (ptr, (5) ptr, (5) bit (1) aligned) returns (bit (1) aligned),
	set_indicators	entry (ptr, ptr, ptr, fixed bin) returns (fixed bin),
	expmac$zero	entry (fixed bin (15)),
	(
	store$save_string_temp,
	store$force,
	state_man$update_ref
	)		entry (ptr),
	state_man$set_aliasables
			entry (ptr),
	stack_temp$assign_block
			entry (ptr, fixed bin),
	state_man$erase_temps
			entry,
	(
	long_op,
	long_op$c_or_b
	)		entry (ptr, fixed bin, fixed bin (15));
dcl	generate_constant$bit_string
			entry (bit (*) aligned, fixed bin) returns (ptr);
dcl	generate_constant$real_fix_bin_1
			entry (fixed bin) returns (ptr),
	generate_constant$char_string
			entry (char (*) aligned, fixed bin (24)) returns (ptr),
	state_man$erase_reg entry (bit (19) aligned),
	state_man$flush	entry,
	string_temp	entry (ptr, ptr, ptr) returns (ptr),
	aq_man$lock	entry (ptr, fixed bin),
	adjust_ref_count	entry (ptr, fixed bin),
	copy_temp		entry (ptr) returns (ptr),
	share_expression	entry (ptr) returns (ptr);

/* builtins */

dcl	(addr, addrel, collate9, copy, fixed, hbound, index, length, min, mod, null, rank, string, substr)
			builtin;

/* based */

dcl	1 bit_table_structure
			based (addr (mvt_table)) aligned,
	  2 bit_table	(0:511) bit (9) unaligned;

dcl	fixed_bin_single	fixed bin based,
	fixed_bin_double	fixed bin (71) based,
	word		bit (36) aligned based;

dcl	based_cs		char (1) aligned based;
dcl	based_bs		bit (1) aligned based;

dcl	1 mlr_instruction	based aligned,
	  2 fill		char (1) unal,		/* fill character -- can be set by compile_exp */
	  2 enablefault	bit (1) unal,
	  2 pad1		bit (1) unal,
	  2 mf2		bit (7) unal,
	  2 opcode	bit (10) unal,
	  2 inhibit	bit (1) unal,
	  2 mf1		bit (7) unal;

dcl	1 csl_instruction	based aligned,
	  2 fill		bit (1) unal,
	  2 pad1		bit (4) unal,
	  2 bool		bit (4) unal,
	  2 enablefault	bit (1) unal,
	  2 pad2		bit (1) unal,
	  2 mf2		bit (7) unal,
	  2 opcode	bit (10) unal,
	  2 inhibit	bit (1) unal,
	  2 mf1		bit (7) unal;

dcl	bit4		bit (4) based aligned;

dcl	1 op_info		aligned based,
	  2 act1		unal bit (6),
	  2 act2		unal bit (6),
	  2 macro		unal bit (18),
	  2 delta		unal bit (2),
	  2 call_code	unal bit (4);

/* internal static */


dcl	(
	zero_bs		init (468),
	one_bs		init (469),
	blank_cs		init (472),
	inline_verify	init (207),
	inline_search	init (199),
	inline_translate	init (111),
	test_translate	init (157),
	test_translate_rev	init (158),
	verify_ltrim_inline init (712),
	verify_rtrim_inline init (713),
	absfx1		init (126),
	testfx1		init (508),
	ldfx1		init (7),
	ldfx2		init (8),
	als		init (134),
	arl		init (245),
	qrs		init (514),
	anq		init (688),
	ana		init (40),
	llr		init (372),
	scaled_mdfx1	init (549),
	mdfl1		init (269),
	mdfl2		init (270),
	stfl2		init (18),
	stfx1		init (15),
	offset_mac_easy	init (242),
	offset_mac_hard	init (600),
	chars_move	init (420),
	move_bits		init (99),
	test_bits		init (96),
	fetch_chars_eis	init (588),
	index_chars	(4) init (452, 700, 702, 256),
	index_chars_1	(4) init (460, 704, 706, 256),
	index_mac		(3, 2) init (460, 462, 704, 708, 706, 709),
	index_rev_mac	(2) init (463, 464),
	round_fl		init (531),
	atan2_mac		init (504),
	atan2d_mac	init (557),
	a_to_x0		init (306),
	rank_eis_mac	init (740),
	qrl		init (418),
	trunc_mac		(0:1) init (124, 384)
	)		fixed bin (15) int static options (constant);

dcl	rel_table		(4:9 /* op */, 0:1 /* string? */, 0:1 /* reversed? */) fixed bin (15) int static
			init (159, 161, 160, 162,	/* < */
			161, 159, 162, 160,		/* > */
			163, 163, 163, 163,		/* = */
			164, 164, 164, 164,		/* ^= */
			165, 167, 166, 168,		/* <= */
			167, 165, 168, 166);	/* >= */

dcl	exp_table		(4, 4) fixed bin (15) int static init (592, 0, 559, 560,
						/* fb1 */
			0, 0, 0, 0,		/* fb2 */
			591, 0, 565, 562,		/* flb1 */
			564, 0, 561, 562);		/* flb2 */


/* include files */

%include cgsystem;
%include reference;
%include symbol;
%include operator;
%include machine_state;
%include nodes;
%include data_types;
%include boundary;
%include op_codes;
%include mask;
%include bases;

/* program */

	ftc = cg_stat$for_test_called;
	cg_stat$for_test_called = "0"b;

start:
	sec = cg_stat$save_exp_called;
	cg_stat$save_exp_called = "0"b;

	p = pt;

	if p -> node.type ^= operator_node
	then do;
is_atom:
		i = p -> reference.data_type;
		call load (p, fixed (i = char_string | i = bit_string, 1));
		save_cur_node = cg_stat$cur_node;
		goto return_1;
	     end;

	ref (1) = p -> operand (1);
	if ^ref (1) -> reference.shared
	then do;

		if ref (1) -> reference.evaluated
		then do;
			p = ref (1);
			goto is_atom;
		     end;

		if ref (1) -> reference.temp_ref & ^ref (1) -> reference.long_ref & ^ref (1) -> reference.aggregate
		     & ref (1) -> reference.data_type ^= complex_flt_bin_1
		then drop = "1"b;
		else drop = "0"b;

	     end;

work:
	save_cur_node = cg_stat$cur_node;
	cg_stat$cur_node = p;

	save_it = cg_stat$save_exp_called;
	update_ref = "1"b;

	update_long, in_storage = "0"b;
	op_code = p -> operator.op_code;

	do i = 1 to min (p -> operator.number, hbound (rand, 1));
	     rand (i) = p -> operand (i);
	end;

	op_rel = fixed (op_relative, 4);
	k = opcode_info$table (fixed (op_class, 5)) + op_rel;
	if k > opcode_info$last_opcode
	then goto not_yet;

	q = addr (opcode_info$opcode_info (k));
	action = fixed (q -> op_info.act1, 6);

	goto switch_a (action);

/* assignment and picture operators */

switch_a (1):
	call assign_op (pt);
	ref1 = cg_stat$temp_ref;
	goto return;

/* min and max builtins */

switch_a (2):
	call min_max (pt);
	ref1 = cg_stat$temp_ref;

	if ref1 -> reference.symbol -> symbol.decimal
	then goto return;

	inline = "1"b;
	goto done_1;

/* error conditions */

switch_a (4):
	call cg_error (300, fixed (op_code, 9));	/* operator in wrong context */
	goto return;

switch_a (5):
not_yet:
	call cg_error (301, fixed (op_code, 9));	/* operator not yet implemented */
	goto return;

/* pointer valued builtin functions */

switch_a (6):
	call pointer_builtins (p, ^drop);

/* This used to avoid references that were shared. Now that shared */
/* temps are no longer permitted on the output side of pointer expressions, */
/* we set evaluated. This sets evaluated for non-tems in particular */
/* So any non-temp, or any non-shared temp is set evaluated */

	ref1 = p -> operator.operand (1);
	if ^ref1 -> reference.temp_ref | ^ref1 -> reference.shared
	then ref1 -> reference.evaluated = "1"b;
					         
	goto return;

/* most op codes come here */

switch_a (3):
	action = fixed (q -> op_info.act2, 6);
	macro = fixed (q -> op_info.macro, 18);
	delta = fixed (q -> op_info.delta, 2);
	call_code = fixed (q -> op_info.call_code, 4);

	n = p -> operator.number;
	do i = n by -1 to 2;
	     q = prepare_operand (rand (i), 1, atom (i));
	     ref (i) = q;
	     sym (i) = q -> reference.symbol;
	     type (i) = q -> reference.data_type;
	end;

/* There appears to be a convention that the size expression must be evaluated
   before m_a is called.  So, we evaluate the size expression here for those
   optimizations that would otherwise call m_a before evaluating the size
   expression. This fixes 1985. */

/* This fix referenced ref (2) for operators with only one operand. oops */

	if op_code = repeat_fun
	then if ref (2) -> reference.c_length = 1 & is_string_constant (2)
	     then ref1 = prepare_operand (rand (1), 1, atom (1));
	     else go to prepare_minus_1;
	else
prepare_minus_1:
	     ref1 = prepare_operand (rand (1), -1, atom (1));

	ref (1) = ref1;
	sym (1) = ref (1) -> reference.symbol;
	type (1) = ref (1) -> reference.data_type;

/* we can't use the "for_test" code sequences if result is needed elsewhere */

	cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;

	if sym (1) -> symbol.decimal
	then inline = "0"b;

	else if sym (1) -> symbol.complex | action = 7 | action = 30
	then inline = inline_operation (p, ref, atom);

	else /* operations with real results are done inline */
	     inline = "1"b;

/* compute context code */

	if n = 2
	then code = fixed (atom (2), 1);
	else if n = 3
	then code = fixed (atom (2) || atom (3), 2);

	if sym (1) -> symbol.complex & inline
	then do;

		if ^ref (1) -> reference.allocate
		then do;

use_cpx:
			q = get_reference ();
			q -> reference = ref (1) -> reference;
			ref (1) = q;

			ref (1) -> reference.offset, ref (1) -> reference.qualifier = null;
			string (ref (1) -> reference.address) = string (cg_stat$complex_ac -> reference.address);
			ref (1) -> reference.relocation = cg_stat$complex_ac -> reference.relocation;
			ref (1) -> reference.perm_address = "1"b;
			goto branch;
		     end;

		else if ref (1) -> reference.temp_ref
		then do;
			ref (1) -> reference.value_in.storage = "1"b;
			if ^cg_stat$save_exp_called
			then do;
				save_it = "1"b;
				ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
			     end;
		     end;

		if op_code = mult
		then if min (type (2), type (3)) = complex_flt_bin_1
		     then goto use_cpx;
		     else ;
		else if op_code = div
		then if type (3) = complex_flt_bin_1
		     then goto use_cpx;

		if ref (1) -> reference.offset ^= null
		then goto use_cpx;

		q = ref (1) -> reference.symbol;
		if q -> symbol.static & q -> symbol.external
		then goto use_cpx;
		if q -> symbol.parameter
		then goto use_cpx;

		in_storage = "1"b;
		update_ref = "0"b;
	     end;

branch:
	goto switch_b (action);

/* arithmetic operators */

switch_b (1):
	if ^inline
	then if sym (1) -> symbol.decimal
	     then call decimal_op (pt, ref, atom);

/* cannot do arithmetic operation inline, generate procedure call */

	     else call gen_arithmetic_call (p, ref, atom);

	else call arith_op (pt, ref, atom);

/* check to see if result should be stored */

done:
	cg_stat$temp_ref = ref1;

done_1:
	if ^ref1 -> reference.shared
	then ref1 -> reference.evaluated = "1"b;

	if ^inline
	then goto return;

	if cg_stat$for_test_called
	then goto return;

	if update_ref & (^ref1 -> reference.long_ref | update_long)
	then do;
		k = ref1 -> reference.c_offset;
		ref1 -> reference.c_offset = 0;

		call state_man$update_ref (ref1);

		ref1 -> reference.c_offset = k;
	     end;

	if ref1 -> reference.allocate
	then do;

		if ref1 -> reference.temp_ref
		then if ^save_it
		     then if ^ref1 -> reference.aggregate
			then go to return;

		if ref1 -> reference.long_ref
		then do;
			if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
			then if ref1 -> reference.address_in.storage
			     then call store$save_string_temp (ref1);
			     else ;
			else if ref1 ^= cg_stat$eis_temp
			then call expmac$two_eis (chars_move + type (1) - char_string, ref1, cg_stat$eis_temp);
			goto return;
		     end;

		if in_storage
		then goto return;

		if ref1 -> reference.data_type = complex_flt_bin_1
		then call expmac ((ldfx2), cg_stat$complex_ac);

		call store$force (ref1);
	     end;

return:
	if cg_stat$save_exp_called
	then do;
		ref_pt = cg_stat$temp_ref;
		ref_pt -> reference.ref_count = orig_count;
	     end;
	else if drop
	then call adjust_ref_count (ref1, -1);

return_1:
	cg_stat$save_exp_called = sec;
	cg_stat$for_test_called = ftc;
	cg_stat$cur_node = save_cur_node;
	return;

/* exponentiation operator */

switch_b (2):
	if type (3) = real_fix_bin_1
	then if is_constant (3)
	     then if sym (3) -> symbol.initial -> fixed_bin_single > 1
		then do;
			call exp_op (pt, ref, atom);
			go to done;
		     end;
		else if sym (3) -> symbol.initial -> fixed_bin_single = 1
		then go to switch_a (1);

	check_type = "0"b;
	macro = exp_table (type (2), type (3));
	call math_op;
	goto done;

/* string operators */

switch_b (3):
	cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;

	call string_op (pt, ref, code);

	goto done;

/* relational operators */

switch_b (4):
	call state_man$erase_temps;
	k = set_indicators (pt, ref (2), ref (3), code);

	if type (2) <= real_flt_bin_2
	then j = 0;
	else do;
		q = ref (2) -> reference.symbol;
		j = fixed (q -> symbol.bit | q -> symbol.char, 1);
	     end;

	call expmac$zero ((rel_table (op_rel, j, k)));
	a_reg.size = 1;
	goto bnf1;

/* rel, baseno, wordno, charno, bitno, (set, add)x(word bit char)no */


declare	charno_mac	fixed bin (15) init (691) int static options (constant);
declare	bitno_mac		fixed bin (15) init (692) int static options (constant);
declare	baseno_mac	fixed bin (15) init (241) int static options (constant);
declare	segno_mac		fixed bin (15) init (240) int static options (constant);
declare	packed_pointer	bit (1) aligned;

switch_b (5):
	if ref (2) -> reference.data_type = packed_ptr
	then do;
		packed_pointer = "1"b;
		if ^ref (2) -> reference.value_in.storage
						/* if it happens to be in a PR from use, use it there! */
		then if ^ref (2) -> reference.value_in.q/* in a PR */
		     then if string (ref (2) -> reference.value_in.b) ^= ""b
			then packed_pointer = "0"b;	/* treat as unpacked */
	     end;
	else do;
		packed_pointer = "0"b;

		if ^atom (2)			/* first operand (other than output) */
		then if rand (2) -> node.type = operator_node
						/* certain packed pointers can be ^atom */
		     then do;			/* must be turned into a pointer */
			     call pointer_builtins (rand (2), "0"b);
			     ref (2) = rand (2) -> operand (1);
			     if ^ref (2) -> reference.shared
			     then ref (2) -> reference.evaluated = "1"b;
			end;
	     end;

	if packed_pointer
	then go to PACKED_POINTER_BIFS (macro);
	else go to POINTER_BIFS (macro);		/* macro contains 1...highest of these */


PACKED_POINTER_BIFS (1):				/* rel */
PACKED_POINTER_BIFS (10):				/* baseno */
	ref (2) -> reference.data_type = bit_string;
	go to LOAD_PP_COMMON;
PACKED_POINTER_BIFS (2):				/* wordno */
PACKED_POINTER_BIFS (3):
PACKED_POINTER_BIFS (4):
PACKED_POINTER_BIFS (9):				/* segno */
	ref (2) -> reference.data_type = real_fix_bin_1;

LOAD_PP_COMMON:
	call load (ref (2), 0);
	ref (2) -> reference.data_type = packed_ptr;

	go to PACKED_POINTER_BIFS_2 (macro);		/* do the work */

PACKED_POINTER_BIFS_2 (1):				/* rel */
	q = c_a ((bits_per_half), 1);			/* no MOD */
	call expmac (als, q);
	go to RETURN_18_BITS;

PACKED_POINTER_BIFS_2 (2):				/* wordno */
	q = c_a (-1, 2);				/* DL */
	call expmac (anq, q);
	go to done;

declare	charno_packed_mac	init (377) fixed bin (15) int static options (constant);
PACKED_POINTER_BIFS_2 (3):				/* charno */
	call expmac$zero (charno_packed_mac);		/* uses table */
	go to done;

PACKED_POINTER_BIFS_2 (4):				/* bitno */
	q = c_a (12 + 18, 1);			/* top 6 bits */
	call expmac (qrl, q);			/* are the bit number */
	go to done;

declare	baseno_mask	init (4095) fixed bin (18) static options (constant);

PACKED_POINTER_BIFS_2 (9):				/* segno */
	q = c_a ((bits_per_half), 1);
	call expmac (qrl, q);
	q = c_a (baseno_mask, 2);			/* DL */
	call expmac (anq, q);
	go to done;

PACKED_POINTER_BIFS_2 (10):				/* baseno */
	q = c_a (baseno_mask, 3);			/* DU */
	call expmac (ana, q);
	go to RETURN_18_BITS;


POINTER_BIFS (1):					/* rel */
	call base_man$load_a_var (ref (2));
	go to RETURN_18_BITS;


POINTER_BIFS (2):					/* wordno */
	call base_man$load_q_var (ref (2));
	macro = qrl;				/* to QL */
	q = c_a ((bits_per_half), 1);			/* NO MOD */
	call expmac (macro, q);
	go to done;


POINTER_BIFS (3):					/* charno */
	call base_man$load_aq_var (ref (2));
	call expmac$zero (charno_mac);
	go to done;

POINTER_BIFS (4):					/* bitno */
	call base_man$load_aq_var (ref (2));
	call expmac$zero (bitno_mac);
	go to done;


POINTER_BIFS (9):					/* segno */
POINTER_BIFS (10):					/* baseno */
	call base_man$load_aq_var (ref (2));
	if op_code = segno_fun
	then do;
		call expmac$zero (segno_mac);
		go to done;
	     end;
	call expmac$zero (baseno_mac);		/* fall through */

RETURN_18_BITS:
l9a:
	a_reg.size = bits_per_half;

bnf1:
	a_reg.length = bits_per_word;
	a_reg.offset = 0;
	goto done;


/* bit_to_char, bit_to_word, char_to_word, half_to_word, word_to_mod2, word_to_mod4, word_to_mod8 operators */

switch_b (6):
	if ^inline
	then goto ext_call;

l2:
	if atom (2)
	then call load (ref (2), 0);
	else call compile_exp (rand (2));

	if delta = 1
	then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);

switch_b (23):					/* not used by opcode_info */
l2a:
	if macro ^= 0
	then call expmac$zero (macro);
	goto done;

/* abs function */

switch_b (7):
	if ^inline
	then do;

ext_call:
		load_it = "0"b;
		if ref (1) -> reference.temp_ref & ^cg_stat$save_exp_called
		then do;
			if sym (1) -> symbol.binary & sym (1) -> symbol.real
			then if sym (2) -> symbol.decimal
			     then do;
				     load_it = "0"b;
				     bump = 0;
				     inline = "1"b;
				end;
			     else do;
				     load_it = "1"b;
				     bump = 2;
				end;
			else bump = 1;

			if ^ref (1) -> reference.shared
			then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + bump;
		     end;

		if sym (2) -> symbol.decimal
		then call decimal_op (p, ref, atom);
		else call gen_arithmetic_builtin (p, ref, atom, call_code);

		if load_it
		then call load (ref (1), 0);

		goto done;
	     end;

	if atom (2)
	then call load$for_test (ref (2), 0);
	else call compile_exp_and_set_indicators (rand (2), type (2));

	macro = absfx1 - real_fix_bin_1 + type (2);
	goto l2a;

/* trunc function */

switch_b (8):
	if ^inline
	then goto ext_call;

	if sym (2) -> symbol.float
	then do;
		macro = trunc_mac (fixed (type (1) ^= real_fix_bin_1, 1));
		goto l2;
	     end;

/* the operation has no meaning for non-positive scales */

l7:
	if sym (2) -> symbol.scale <= 0
	then do;
		macro = 0;
		goto l2;
	     end;

	scale = sym (2) -> symbol.scale;
	if atom (2)
	then call load (ref (2), 0);
	else call compile_exp (rand (2));

	k = type (2) - real_fix_bin_1;
	macro = macro + k;

	call xr_man$load_const (scale, 2);

	if k > 0
	then if action ^= 8
	     then call xr_man$load_const (-2 * scale, 3);
	goto l2a;

/* trans_sign and mod functions */

switch_b (9):
	if ^atom (3)
	then ref (3) = compile_exp$save (rand (3));
	if atom (2)
	then call load (ref (2), 0);
	else call compile_exp (rand (2));

	if delta = 1
	then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);

	call expmac (macro, ref (3));

	if action = 21
	then if scaled
	     then do;
		     array (1) = sym (2) -> symbol.scale;
		     array (2) = sym (3) -> symbol.scale;
		     call expmac$abs (addr (array), 2);
		end;
	goto done;

/* bound_ck and range_ck operators */

switch_b (10):
	call expmac$conditional (macro, pt, ref, atom);
	goto done;

/* concatenation operator */

switch_b (14):
	cg_stat$for_test_called = "0"b;
	call cat_op (pt, ref, code);
	goto done;

/* index operator */

switch_b (15):
	if op_code = index_fun
	then m = 1;
	else if op_code = index_before_fun
	then m = 2;
	else m = 3;

	if type (2) = char_string
	then do;
		rlength = ref (3) -> reference.c_length;
		if rlength = 1 | rlength = 2
		then do;
			if op_code = index_rev_fun
			then macro = index_rev_mac (rlength);
			else macro = index_mac (m, rlength);
			if ^atom (2)
			then ref (2) = compile_exp$save_exp (rand (2));
			if ^atom (3)
			then ref (3) = compile_exp$save_exp (rand (3));
			call expmac$two_eis (macro, ref (2), ref (3));
			go to done;
		     end;
		else if op_code = index_rev_fun
		then m = 4;
	     end;

	else if ref (3) -> reference.c_length = 1	/* Must be bit string */
	then do;
		if ^atom (2)
		then if rand (2) -> node.type = operator_node
		     then if rand (2) -> operator.op_code = reverse_fun
			then goto ind0;
			else ref (2) = compile_exp$save (rand (2));

		call compile_exp (rand (3));

/* protect rand(3) in a, if necessary by getting ref(2)'s address early */

		if ref (2) -> reference.big_offset
		then do;
			call aq_man$lock (null, 1);
			if ^ref (2) -> reference.shared
			then ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
			call base_man$load_var (2, ref (2), 1);
		     end;

		call long_op$c_or_b (ref (2), 0, (index_chars_1 (m)));
		goto done;
	     end;

/* not single char|bit case */

ind0:
	if ^atom (3)
	then ref (3) = compile_exp$save_exp (rand (3));

	if ^atom (2)
	then call compile_string;

	call load$long_string (ref (2));
	call long_op$c_or_b (ref (3), 0, (index_chars (m)));
	goto done;

/* length function as top operand of tree */

switch_b (16):
	call load_size (ref (2));
	if ^ref (2) -> reference.shared
	then call adjust_ref_count (ref (2), -1);
	goto done;

/* offset function */

switch_b (17):
	if ^atom (2)
	then ref (2) = compile_exp$save (rand (2));

	pa = ref (2) -> reference.symbol;
	if pa -> symbol.constant
	then do;

/* must be null pointer on right */

		call load (generate_constant$real_fix_bin_1 (cg_stat$offset_null_value), 0);
		goto done;
	     end;

	call check_ptr;

	call load (ref (2), 0);
	k = ref (2) -> reference.data_type - unpacked_ptr;

	pa = ref (3) -> reference.symbol;
	if pa -> symbol.internal & (pa -> symbol.auto | pa -> symbol.static)
	then macro = offset_mac_easy;
	else macro = offset_mac_hard;

	call expmac (macro + k, ref (3));
	goto done;

/* assign_zero and stack_ptr operators */

switch_b (18):
	call expmac (macro, ref (1));
	cg_stat$temp_ref = ref (1);
	goto return;

/* desc_size operator */

switch_b (19):
	call expmac (macro, ref (2));
	goto done;

/* floor and ceiling functions */

switch_b (20):
	if ^inline
	then goto ext_call;

	if sym (2) -> symbol.float
	then do;
		macro = macro + 2;
		goto l2;
	     end;

	goto l7;

/* pl1 mod function */

switch_b (21):
	if ^inline
	then goto ext_call;

	scaled = "0"b;

	if sym (1) -> symbol.float
	then do;
		if type (1) = real_flt_bin_1
		then macro = mdfl1;
		else do;
			macro = mdfl2;

			if type (3) = real_flt_bin_1
			then do;

				if atom (3) & is_constant (3)
				then do;
					double = sym (3) -> symbol.initial -> word;
					ref (3) = generate_constant$bit_string (double, (bits_per_two_words));
					ref (3) -> reference.symbol -> symbol.boundary = mod2_;
				     end;
				else do;
					call compile_exp (rand (3));
					call save_ref_3;
				     end;

				atom (3) = "1"b;
			     end;
		     end;

		goto switch_b (9);
	     end;

	k = 2 * type (2) + type (3) - 3;

	if sym (2) -> symbol.scale = 0 & sym (3) -> symbol.scale = 0
	then macro = macro + k;
	else do;
		macro = scaled_mdfx1 + k;
		scaled = "1"b;
	     end;

	go to switch_b (9);

/* round function */

switch_b (22):
	if ^inline
	then goto ext_call;
	if sym (1) -> symbol.complex
	then goto ext_call;

	if atom (2)
	then call load (ref (2), 0);
	else call compile_exp (rand (2));

	if type (3) = real_fix_bin_1
	then k = sym (3) -> symbol.initial -> fixed_bin_single;
	else k = sym (3) -> symbol.initial -> fixed_bin_double;

	if sym (2) -> symbol.float
	then do;
		call expmac ((round_fl), c_a ((k), 1));
		goto done;
	     end;

	macro = macro + type (2) - real_fix_bin_1;

	j = sym (2) -> symbol.scale - k;

	if j > 0
	then do;
		call xr_man$load_const (j, 7);
		goto l2a;
	     end;
	else do;
		call aq_man$fix_scale (ref (2), k, type (1));
		go to done;
	     end;

/* repeat and reverse operator */

switch_b (24):
	if (op_code = repeat_fun) & (ref (2) -> reference.c_length = 1) & is_string_constant (2)
	then do;

/* we can just emit an mlr or csl with fill to compile this operator

   NOTE: For this optimization, prepare_operand was called on rand (1) to
   evaluate the size expression as well as the offset expression.  This
   ensures that the size expression is evaluated before m_a gets called.  It
   gets called during the call to expmac$one_eis.  This fixes 1985. */

		cg_stat$for_test_called = "0"b;

		call adjust_ref_count (rand (3), -1);

		ref (1) = string_temp (p, ref (2), null);

		if type (1) = char_string
		then macro = blank_cs;
		else do;
			if ref (2) -> reference.units = word_
			then c_offset = ref (2) -> reference.c_offset * bits_per_word;
			else c_offset = ref (2) -> reference.c_offset;
						/* must be in bits already */

			if substr (sym (2) -> symbol.initial -> based_bs, c_offset + 1, 1)
			then macro = one_bs;
			else macro = zero_bs;
		     end;

		call expmac$one_eis (macro, ref (1));

		if type (1) = char_string
		then do;
			if ref (2) -> reference.units = word_
			then c_offset = ref (2) -> reference.c_offset * chars_per_word;
			else c_offset = ref (2) -> reference.c_offset;
						/* units must already be chars */

			addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> mlr_instruction.fill =
			     substr (sym (2) -> symbol.initial -> based_cs, c_offset + 1, 1);
		     end;

		go to eis_done;
	     end;

	if op_code = reverse_fun
	then if ref (2) -> reference.c_length = 2
	     then if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
		then do;

/* reverse 2 chars- to make better code for reverse index */

			if type (1) = char_string
			then macro = chars_move;
			else macro = move_bits;
			call adjust_ref_count (ref (2), 1);
						/* Gonna use twice */
			if ^atom (2)
			then ref (2) = compile_exp$save_exp (rand (2));
			ref (1) = string_temp (p, ref (2), null);
			if ^(^ref (1) -> reference.aggregate & ref (1) -> reference.temp_ref)
			then call adjust_ref_count (ref (1), 1);
			save_l1 = ref (1) -> reference.c_length;
			save_l2 = ref (2) -> reference.c_length;
			ref (1) -> reference.c_length, ref (2) -> reference.c_length = 1;
			call adjust_c_offset (ref (1), +1);
			call expmac$two_eis (macro, ref (1), ref (2));
			call restore_c_offset (ref (1));
			call adjust_c_offset (ref (2), +1);
			call expmac$two_eis (macro, ref (1), ref (2));
			call restore_c_offset (ref (2));
			ref (1) -> reference.c_length = save_l1;
			ref (2) -> reference.c_length = save_l2;

			goto eis_done;
		     end;

	if atom (2)
	then do;
l10:
		call load$long_string (ref (2));

		if op_code = repeat_fun
		then if atom (3)
		     then call load (ref (3), 0);
		     else call compile_exp (rand (3));
		else macro = macro + type (1) - char_string;

		call expmac$zero (macro);

		if type (1) = bit_string
		then do;
			machine_state.indicators = ind_invalid;
			cg_stat$for_test_called = "0"b;
		     end;

l10a:
		if ref (1) -> reference.length ^= null
		then do;

/* for reverse or repeat the length may be considered
		   evaluated and in the q reg; for translate the length
		   is either already evaluated or is the length_fun op
		   which needs processing */

			if action = 24
			then do;
				pa = prepare_operand ((ref (1) -> reference.length), 0, atomic);

				if atomic
				then if ^pa -> reference.temp_ref
				     then ref (1) -> reference.length = pa;
				     else ;
				else do;
					if pa -> reference.shared
					then pa, ref (1) -> reference.length -> operand (1) = copy_temp (pa);
					pa -> reference.evaluated = "1"b;
				     end;

				call state_man$update_ref (pa);
			     end;
			else ref (1) -> reference.length = eval_exp ((ref (1) -> reference.length), "1"b);
		     end;
		else if ref (1) -> reference.c_length <= max_short_size (type (1))
		then call expmac$zero (fetch_chars_eis - char_string + type (1));

		if ref (1) -> reference.long_ref
		then do;
			update_long = ref (1) -> reference.temp_ref & ^ref (1) -> reference.aggregate;
			if update_long
			then if ref (1) -> reference.length = null
			     then if ref (1) -> reference.ref_count - fixed (cg_stat$save_exp_called, 1) > 1
				then do;
					update_long = "0"b;
					q = copy_temp (ref (1));
					call state_man$update_ref (q);
					call expmac$two_eis (chars_move + type (1) - char_string, ref (1), q);
				     end;
				else ;
			     else ;
			else do;
				q, cg_stat$eis_temp = COPY (ref (1));
				if ref (1) -> reference.length ^= null
				then q -> reference.length = share_expression ((ref (1) -> reference.length));
				q -> reference.ref_count = 1;
				call state_man$update_ref (q);
			     end;
		     end;

		cg_stat$extended_stack = "1"b;

		goto done;
	     end;

	call compile_string;
	goto l10;

/* verify and search functions */

switch_b (25):
	if ^atom (3)
	then ref (3) = compile_exp$save_exp (rand (3));

	if ref (2) -> reference.c_length = 1
	then do;
		if ^atom (2)
		then call compile_string;
		if op_code = verify_fun | op_code = verify_rev_fun
		then macro = inline_verify;
		else macro = inline_search;
		call expmac$two_eis (macro, ref (2), ref (3));
	     end;

	else if is_constant (3)
	then do;
		if op_code = verify_ltrim_fun
		then macro = verify_ltrim_inline;
		else if op_code = verify_rtrim_fun
		then macro = verify_rtrim_inline;
		else if op_code = verify_rev_fun | op_code = search_rev_fun
		then macro = test_translate_rev;
		else macro = test_translate;
		if ^atom (2)
		then ref (2) = compile_exp$save_exp (rand (2));
		if op_code = search_rev_fun
		then op_code = search_fun;		/* Make tests below easier */
		q = sym (3) -> symbol.initial;

		if (ref (3) -> reference.c_length = 1) & (op_code ^= search_fun)
		then q = c_a (rank (substr (q -> based_cs, 1, 1)), 16);
						/* use the table in pl1_operators_ */
		else do;
			string (bit_table) = "0"b;
			do i = 1 to ref (3) -> reference.c_length;
			     j = rank (substr (q -> based_cs, i, 1));
			     bit_table (j) = "777"b3;
			end;

			if op_code ^= search_fun
			then string (bit_table) = ^string (bit_table);

			q = generate_constant$char_string (mvt_table, length (mvt_table));
		     end;

		call expmac$two_eis (macro, ref (2), q);
	     end;

	else do;
		if ^atom (2)
		then call compile_string;
		call long_op$eis_operator (ref (2), ref (3), macro);
	     end;

	go to done;

/* translate function */

switch_b (26):
	if n = 4
	then macro = macro + 1;

	constant_rands = "1"b;

	do i = 3 to n;
	     if ^atom (i)
	     then do;
		     ref (i) = compile_exp$save_exp (rand (i));
		     constant_rands = "0"b;
		end;
	     else constant_rands = constant_rands & is_constant (i);
	end;

	if constant_rands
	then do;

/* The second and third args to the translate bif are constant, so we
	        can generate an inline translate sequence */

		if ^atom (2)
		then ref (2) = compile_exp$save_exp (rand (2));
		if ref (2) -> reference.value_in.string_aq
						/* We must make sure string_temp */
		then call state_man$erase_reg ("001"b); /* doesn't attempt to reuse space used foor ref(2) */

		ref (1) = string_temp (p, ref (2), null);

/* We must generate a translate table for use with an mvt instruction */

		mvt_table = collate9 ();

		q = sym (3) -> symbol.initial;

		if n = 3
		then mvt_table = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
		else do;
			result_string = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
			q = sym (4) -> symbol.initial;
			do i = ref (4) -> reference.c_length to 1 by -1;
			     j = rank (substr (q -> based_cs, i, 1));
			     substr (mvt_table, j + 1, 1) = substr (result_string, i, 1);
			end;
		     end;

		ref (3) = generate_constant$char_string (mvt_table, length (mvt_table));

		call expmac$many_eis ((inline_translate), addr (ref), 3);
eis_done:
		if ^ref (1) -> reference.long_ref
		then if ^cg_stat$for_test_called
		     then do;
			     update_ref = "0"b;
			     in_storage = ref1 = ref (1);
			     if ^(cg_stat$save_exp_called & in_storage) & ref (1) -> reference.temp_ref
				& ^ref (1) -> reference.aggregate
			     then do;
				     if in_storage
				     then if ^ref (1) -> reference.shared
					then ref (1) -> reference.ref_count =
						ref (1) -> reference.ref_count + 1;
				     call load (ref (1), 1);
				end;
			end;
		go to done;
	     end;

	else do;

/* generate operator call */

		if ^atom (2)
		then call compile_string;

		call load$long_string (ref (2));

		if n = 3
		then call long_op (ref (3), 0, macro);
		else call long_op$eis_operator (ref (3), ref (4), macro);

/* Since operator allocates own temp, we must branch for special handling */

		go to l10a;
	     end;

/* lock_fun (stac) function */

switch_b (27):
	if ^atom (2)
	then ref (2) = compile_exp$save (rand (2));

	call compile_exp (rand (3));

	call base_man$load_var (1, ref (2), 1);
	call state_man$set_aliasables (null);
	call expmac$zero (macro);

	a_reg.size = 1;
	goto bnf1;

switch_b (29):					/* complex and conjg functions */
switch_b (30):					/* real and imag functions */
	if inline
	then goto switch_b (10);
	else goto ext_call;

/* sign function */

switch_b (31):
	if sym (2) -> symbol.decimal
	then go to ext_call;

	if atom (2)
	then call load$for_test (ref (2), 0);
	else call compile_exp_and_set_indicators (rand (2), type (2));

	goto l2a;

/* allocation function */

switch_b (32):
	if sym (2) -> symbol.internal
	then n = 13;
	else n = 9;

	ref (2) = c_a ((sym (2) -> symbol.location), n);
	goto switch_b (19);

/* bool function */

switch_b (33):
	if ^atom (2)
	then ref (2) = compile_exp$save_exp (rand (2));

	if ^atom (3)
	then if rand (3) -> node.type = operator_node
	     then if ref (3) -> reference.long_ref & atom (4)
		then call compile_exp (rand (3));
		else ref (3) = compile_exp$save (rand (3));

	cg_stat$for_test_called =
	     cg_stat$for_test_called & is_constant (4) & ref (2) -> reference.length = ref (3) -> reference.length
	     & ref (2) -> reference.c_length <= ref (3) -> reference.c_length;

	ref (1) = string_temp (p, ref (3), ref (2));

	if is_constant (4)
	then do;
		if cg_stat$for_test_called
		then m = test_bits;
		else m = move_bits;
		call expmac$eis (m, ref (2));
		addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> csl_instruction.bool =
		     sym (4) -> symbol.initial -> bit4;
	     end;

	else do;
		call compile_exp (rand (4));
		call state_man$erase_reg ("1"b);
		call expmac ((arl), c_a (32, 1));

		if need_areg ()
		then do;
			call expmac$zero ((a_to_x0));
			macro = macro + 1;
		     end;
		else call aq_man$lock (null, 1);

		call expmac$eis (macro, ref (2));
	     end;

	go to eis_done;

/* math builtins */

switch_b (34):
	if n = 3
	then do;
		check_type = "1"b;
		if op_code = atan_fun
		then macro = atan2_mac;
		else macro = atan2d_mac;
	     end;

	if type (1) = real_flt_bin_2
	then macro = macro + 1;

	call math_op;
	go to done;

/* stacq function.  we will generate the following code:
		lda	ref3
		epp2	ref2
		ldq	ref4
		tsx0	ap|stacq_op	*/

switch_b (35):
	if ^atom (2)
	then ref (2) = compile_exp$save (rand (2));

	if ^atom (4)
	then ref (4) = compile_exp$save (rand (4));

	call compile_exp (rand (3));
	call base_man$load_var (2, ref (2), 1 /* pr2 */);
	if ref (2) -> reference.aliasable
	then call state_man$set_aliasables (ref (2));
	call expmac (macro, ref (4));
	a_reg.size = 1;
	go to bnf1;

/* clock and vclock functions.  we will generate the following code:
		tsx0	ap|clock_op
	or	tsx0	ap|vclock_op	*/

switch_b (36):
	call state_man$erase_reg ((18)"0"b || "1"b);	/* erase pr7 */
	call expmac$zero (macro);
	go to done;

/* byte builtin function. we generate the following code:
		ldq	ref2
		lls	63	*/

switch_b (37):
	if ^atom (2)
	then call compile_exp (rand (2));
	else call load (ref (2), 0);

	call aq_man$check_strings (0);
	a_reg.offset = 63;
	a_reg.length = 9;
	a_reg.size = 72;
	call aq_man$left_shift (63, "1"b);
	go to done;

/* rank builtin function. we generate the following code:
	   hard_to_load case:
		mrl	(...),(pr),fill(000)
		desc9a	ref2,1
		desc9a	sp|46,4
		ldq	sp|46

	   everything else:
		lda	ref2
		lrl	63	*/

switch_b (38):
	if ref (2) -> reference.hard_to_load
	then do;

/* hard_to_load implies operand is a reference, not an expression */

		if ^ref (1) -> reference.temp_ref | ref (1) -> reference.ref_count > 1
		then q = ref (1);
		else q = c_a (46, 4);		/* sp|46 (double temp) */

		if q -> reference.temp_ref
		then q -> reference.value_in.storage = "1"b;

		call expmac$two_eis (rank_eis_mac, q, ref (2));
		in_storage = "1"b;

		if ^save_it & ref (1) -> reference.temp_ref
		then do;
			if ^ref (1) -> reference.shared
			then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;

			call expmac (ldfx1, q);
		     end;
		else update_ref = "0"b;
	     end;
	else do;
		if atom (2)
		then call load (ref (2), 1);
		else call compile_exp (rand (2));

		call aq_man$right_shift (63, "1"b);
		a_reg.offset, a_reg.size, a_reg.length = 0;
	     end;
	go to done;

compile_exp$for_test:
     entry (pt);

	ftc = cg_stat$for_test_called;
	cg_stat$for_test_called = "1"b;
	goto start;

compile_exp$save:
     entry (pt, ref_pt);

dcl	ref_pt		ptr;			/* will be set to reference node for result */

	p = pt;
	if p -> node.type ^= operator_node
	then do;

		if ^p -> reference.aligned_ref
		then do;

l4:
			i = p -> reference.data_type;
			is_string = i = char_string | i = bit_string;

			if p -> reference.hard_to_load
			then if substr (string (p -> reference.value_in), 1, 2) = "00"b
						/* not in a or q */
			     then if p -> reference.ref_count > 0
				then do;
					if is_string | mod (p -> reference.c_length, bits_per_word) = 0
					then do;
						call load$for_save (p, 0);
						go to l5;
					     end;
				     end;

			call load (p, fixed (is_string, 1));

/* if the reference is now aligned, it was converted to a temporary
		   because its ref_count was greater than one */

			if p -> reference.aligned_ref
			then p -> reference.ref_count = p -> reference.ref_count + 2;
			else p = COPY (p);

			call store$force (p);
		     end;

l5:
		ref_pt = p;
		return;
	     end;

	check_aligned = "1"b;

l6:
	ref (1) = p -> operand (1);
	if ref (1) -> reference.evaluated
	then do;
		if check_aligned
		then if ^ref (1) -> reference.aligned_ref
		     then if ^ref (1) -> reference.long_ref
			then if ^ref (1) -> reference.varying_ref
			     then if ^ref (1) -> reference.symbol -> symbol.decimal
				then do;
					p = ref (1);
					go to l4;
				     end;
		ref_pt = ref (1);
		return;
	     end;

	if ^ref (1) -> reference.allocate
	then do;

		p -> operand (1) = copy_temp (ref (1));
		orig_count = 1;
		p -> operand (1) -> reference.ref_count = 2;
	     end;
	else if ^ref (1) -> reference.shared
	then do;
		orig_count = ref (1) -> reference.ref_count;
		ref (1) -> reference.ref_count = orig_count + 1;
	     end;

	ftc = cg_stat$for_test_called;
	cg_stat$for_test_called = "0"b;

	sec = cg_stat$save_exp_called;
	cg_stat$save_exp_called = "1"b;

	goto work;

compile_exp$save_exp:
     entry (pt, ref_pt);

	p = pt;
	if p -> node.type ^= operator_node
	then goto l5;

	check_aligned = "0"b;
	goto l6;

compile_exp$save_fix_scaled:
     entry (pt, target_scale, targ_type) returns (ptr);

dcl	target_scale	fixed bin,
	target_type	fixed bin,
	targ_type		fixed bin;

	target_type = targ_type;
save_join:
	p = pt;
	if p -> node.type ^= operator_node
	then call load (p, 0);
	else do;
		call compile_exp (p);
		p = p -> operand (1);
	     end;

	if target_type <= real_fix_bin_2
	then call aq_man$fix_scale (p, target_scale, target_type);

	q = COPY (p);
	q -> reference.data_type = target_type;

	call stack_temp$assign_block (q, min (target_type, 2));
						/* NOTE: size = type for real_fix_bin_1 or 2 */

	call expmac (stfx1 - real_fix_bin_1 + target_type, q);

	q -> reference.value_in.storage = "1"b;

	return (q);

compile_exp$save_float_2:
     entry (pt) returns (ptr);

	target_type = real_flt_bin_2;
	goto save_join;

/* INTERNAL PROCEDURES */

COPY:
     proc (pt) returns (ptr);

dcl	(pt, p)		ptr;

	p = copy_temp (pt);
	p -> reference.units = word_;
	p -> reference.aligned_ref, p -> reference.padded_ref, p -> reference.aligned_for_store_ref,
	     p -> reference.padded_for_store_ref = "1"b;
	p -> reference.aggregate = "0"b;
	p -> reference.c_offset = 0;
	p -> reference.ref_count = 2;
	p -> reference.length, p -> reference.offset, p -> reference.qualifier = null;
	return (p);

     end;

check_ptr:
     proc;

	if ref (2) -> reference.temp_ref
	then if ^ref (2) -> reference.value_in.storage
	     then if ^ref (2) -> reference.value_in.q
		then do;
			i = index (string (ref (2) -> reference.value_in.b), "1"b) - 1;
			if i >= 0
			then do;
				ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
				call base_to_core (i, ref (2));
			     end;
		     end;

     end;

compile_exp_and_set_indicators:
     procedure (bv_ref, bv_type);

/* compiles an ARITHMETIC expression and sets the indicators for testing */

/* parameters */

dcl	(
	bv_ref		ptr,
	bv_type		fixed bin
	)		parameter;

/* program */

	call compile_exp (bv_ref);
	if (machine_state.indicators ^= ind_arithmetic)
	then do;
		call expmac$zero (testfx1 - real_fix_bin_1 + bv_type);
		machine_state.indicators = ind_arithmetic;
	     end;

     end /* compile_exp_and_set_indicators */;

compile_string:
     proc;

	if rand (2) -> node.type = operator_node
	then if ref (2) -> reference.long_ref
	     then call compile_exp (rand (2));
	     else ref (2) = compile_exp$save (rand (2));

     end;

need_areg:
     proc returns (bit (1) aligned);

	if ref (1) -> reference.big_length
	then if ref (3) -> reference.big_length
	     then if ref (1) -> reference.length ^= ref (3) -> reference.length
		     | ref (1) -> reference.c_length ^= ref (3) -> reference.c_length
		then return ("1"b);

	return ("0"b);
     end;

is_constant:
     proc (i) reducible returns (bit (1) aligned);

dcl	i		fixed bin;

	if sym (i) -> symbol.constant
	then if ^ref (i) -> reference.varying_ref
	     then if ref (i) -> reference.offset = null
		then if ref (i) -> reference.c_offset = 0
		     then if ref (i) -> reference.length = null
			then return ("1"b);

	return ("0"b);
     end;

is_string_constant:
     proc (i) reducible returns (bit (1) aligned);

dcl	i		fixed bin;

	if sym (i) -> symbol.constant
	then if ^ref (i) -> reference.varying_ref
	     then if ref (i) -> reference.offset = null
		then if ref (i) -> reference.length = null
		     then return ("1"b);

	return ("0"b);
     end /* is_string_constant */;

save_ref_3:
     proc;

	ref (3) = c_a (2, 12);
	ref (3) -> reference.ref_count = 2;
	call expmac ((stfl2), ref (3));

     end;


math_op:
     proc;

/*	     procedure to issue calls to math operators	*/

dcl	adjust		bit (1) aligned;

	adjust = "0"b;

	if n = 3
	then if type (1) > type (3) & check_type
	     then ref (3) = compile_exp$save_float_2 (rand (3));
	     else if ^atom (3)
	     then ref (3) = compile_exp$save (rand (3));

/* load operand 2 into the q */

	if atom (2)
	then call load (ref (2), 0);
	else call compile_exp (rand (2));

	if n = 3
	then do;
		if ref (3) -> reference.temp_ref
		then do;

/* protect operand(3) from being clobbered when temps are saved */

			adjust = "1"b;
			ref (3) -> reference.ref_count = ref (3) -> reference.ref_count + 1;
		     end;

/* get a ptr to operand(3) into the ab */

		call base_man$load_var (2, ref (3), 3);
	     end;

/*  get a ptr to the workspace into the bp */

	q = c_a (32, 12);
	q -> reference.ref_count = 2;
	call base_man$load_var (2, q, 1);

/* we must flush all the registers because the math operators can make external calls */

	call state_man$flush;

	call expmac$zero (macro);
	machine_state.indicators = ind_arithmetic;

	if adjust
	then call adjust_ref_count (ref (3), -1);
	call adjust_ref_count (q, -1);

     end;

adjust_c_offset:
     proc (p, delta);

dcl	p		ptr,
	delta		fixed bin;

	save_mwif = p -> reference.modword_in_offset;
	save_coff = p -> reference.c_offset;
	save_units = p -> reference.units;
	if save_mwif
	then p -> reference.c_offset = save_coff + delta;
	else if save_units < word_
	then p -> reference.c_offset = save_coff + delta;
	else do;
		p -> reference.modword_in_offset = "1"b;
		if p -> reference.data_type = bit_string
		then do;
			p -> reference.units = bit_;
			p -> reference.c_offset = save_coff * bits_per_word + delta;
		     end;
		else do;
			p -> reference.units = character_;
			p -> reference.c_offset = save_coff * chars_per_word + delta;
		     end;
	     end;
     end;

restore_c_offset:
     proc (p);

dcl	p		ptr;

	p -> reference.c_offset = save_coff;
	p -> reference.modword_in_offset = save_mwif;
	p -> reference.units = save_units;
     end;


     end compile_exp;




		    compile_formats.pl1             10/03/83  1730.5rew 10/03/83  1008.0       77157



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

/* procedure to compile formats into internal form

   Initial Version: 10 December 1971 by BLW
	Modified:  3 January 1972 by BLW
	Modified: 22 October 1973 by BLW for picture formats */

compile_formats: proc ;

dcl	(cg_static_$text_base,cg_static_$text_reloc_base,cg_static_$format_list) ptr ext,
	(cg_static_$text_pos,cg_static_$cur_level) fixed bin(18) ext;

dcl	(p,q,p1,q1,fp) ptr,
	dont_pool bit(1),
	(first,size,n_bits,use,prev_use,delta,loc,n) fixed bin(18);

dcl	(e_v,e_v$l_v) entry(ptr,fixed bin(35),ptr,fixed bin,fixed bin,bit(36) aligned);

dcl	1 half	based aligned,
	2 left	bit(18) unal,
	2 right	bit(18) unal;
dcl	fix_bin fixed bin based,
	string bit(n_bits) aligned based;

dcl	format_class bit(5) init("01111"b) int static;

dcl	(addrel,bit,fixed,null,substr) builtin;

%include pl1_tree_areas;
%include cgsystem;
%include operator;
%include list;
%include statement;
%include reference;
%include symbol;
%include block;
%include format_value;
%include format_item;
%include nodes;
%include op_codes;

	/* preprocess all formats to encode any variables | expressions */

	p = cg_static_$format_list;
	do while(p ^= null);

	     q = p -> element(2);
	     cg_static_$cur_level = q -> symbol.block_node -> block.level;
	     q = q -> symbol.initial -> statement.root;
	     call preprocess(q);
	     p = p -> element(1);
	     end;

	/* now generate internal form for all formats */

	p = cg_static_$format_list;
	do while(p ^= null);

	     fp = addrel(cg_static_$text_base,cg_static_$text_pos);
	     fp -> fix_bin = 0;

	     cg_static_$text_pos = cg_static_$text_pos + 1;

	     dont_pool = "0"b;
	     q = p -> element(2);
	     first = generate(q -> symbol.initial -> statement.root) - 1;
	     size, q -> symbol.c_word_size = cg_static_$text_pos - first;

	     if dont_pool then goto unique;

	     /* try to pool this format with one already generated */

	     n_bits = size * bits_per_word;

	     p1 = cg_static_$format_list;
	     do while(p1 ^= p);

		q1 = p1 -> element(2);
		if size > q1 -> symbol.c_word_size then goto nf;
		if addrel(cg_static_$text_base,q1 -> symbol.location) -> string = fp -> string
		then do;

		     /* found a match */

		     loc = q1 -> symbol.location;
		     cg_static_$text_pos = first;
		     addrel(cg_static_$text_reloc_base,cg_static_$text_pos) -> string = "0"b;
		     goto fill;
		     end;

nf:		p1 = p1 -> element(1);
		end;

	     /* the format is unique */

unique:	     loc = first;

	     /* now assign the format and fill in its usage string (if any) */

fill:	     use = q -> symbol.location;
	     q -> symbol.location = loc;
	     q -> symbol.allocated = "1"b;

	     do while(use ^= 0);
		p1 = addrel(cg_static_$text_base,use);
		prev_use = fixed(p1 -> right,18);

		delta = loc - use;
		if delta >= 0 then p1 -> right = bit(delta,18);
		else p1 -> right = bit(fixed(262144+delta,18),18);

		use = prev_use;
		end;

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

	/* all done */

	return;

preprocess:    proc(opt);

dcl	     opt ptr;		/* points at format operator */

dcl	     (qi,fv,op,s) ptr,
	     i fixed bin;

	     /* This procedure is called to preprocess a format tree.  If the format is
	        a remote format, it encodes the format label specified in r(l).  It
	        then looks at all of the operands of the format operator;  if any of them
	        are not constants, it encodes their value and replaces them in the tree
	        with a pointer to the format value node.  It calls itself to process
	        another format operator found in the tree */

	     op = opt;
	     if op -> op_code ^= r_format then goto loop;

	     qi = op -> operand(3);
	     s = qi -> reference.symbol;
	     if s -> symbol.format & ^ s -> symbol.constant
	     then do;
		allocate format_value in(tree_area) set(fv);
		op -> operand(3) = fv;

		call e_v$l_v(null,fv -> format_value.val,qi,0,0,fv -> format_value.reloc);
		end;

loop:	     do i = 1 to op -> operator.number;
		qi = op -> operand(i);
		if qi = null then goto step;

		if qi -> node.type = format_value_node then goto step;

		if qi -> node.type = reference_node
		then if qi -> reference.symbol -> symbol.constant
		     then goto step; else goto all;

		if substr(qi -> op_code,1,5) = format_class
		then do;
		     call preprocess(qi);
		     goto step;
		     end;

all:		allocate format_value in(tree_area) set(fv);
		call e_v(null,fv -> format_value.val,qi,0,0,fv -> format_value.reloc);
		op -> operand(i) = fv;

step:		end;

	     end;

generate:	     proc(format_pt) returns(fixed bin(18));

dcl	     format_pt ptr unaligned;			/* points at first operator node in format */

dcl	     (pt,p,q,rp,s,prev) ptr,
	     (start,pos,prev_pos,i) fixed bin(18),
	     code fixed bin(9);

dcl	     1 fir	aligned based,
	     2 skip	bit(36),
	     2 count_reloc	bit(36),
	     2 value_reloc(3) bit(36);

	     pt = format_pt;
	     start = cg_static_$text_pos;
	     prev = null;

loop:	     pos = cg_static_$text_pos;
	     p = addrel(cg_static_$text_base,pos);
	     rp = addrel(cg_static_$text_reloc_base,pos);

	     p -> fix_bin = 0;
	     p -> format_item.num = bit(fixed(pt -> operator.number - 2,9),9);

	     cg_static_$text_pos = cg_static_$text_pos + pt -> operator.number;

	     q = pt -> operand(2);		/* repitition count */
	     if q = null then p -> count = 1;
	     else if q -> node.type = format_value_node
		then do;
		     p -> count = q -> format_value.val;
		     rp -> count_reloc = q -> format_value.reloc;
		     end;
		else p -> count = q -> reference.symbol -> symbol.initial -> fix_bin;

	     code = fixed(substr(pt -> op_code,6,4),4) - 1;
	     p -> format_item.code = bit(fixed(code,9),9);

	     if pt -> op_code = l_parn
	     then do;
		p -> format_item.value(1) = generate(pt -> operand(3)) - pos;
		goto step;
		end;

	     if pt -> op_code ^= r_format then goto cf;

	     q = pt -> operand(3);
	     if q -> node.type = format_value_node
	     then do;
		p -> format_item.value(1) = q -> format_value.val;
		rp -> value_reloc(1) = q -> format_value.reloc;
		goto step;
		end;

	     dont_pool = "1"b;

	     s = q -> reference.symbol;
	     if s -> symbol.allocated
	     then do;
		i = s -> symbol.location - pos - 2;
		if i >= 0 then p -> remote_format.offset = bit(fixed(i,18),18);
		else p -> remote_format.offset = bit(fixed(262144+i,18),18);
		end;
	     else do;
		p -> remote_format.offset = bit(fixed(s -> symbol.location,18),18);
		s -> symbol.location = pos + 2;
		end;

	     p -> remote_format.class = "0"b;
	     goto step;

cf:	     if pt -> op_code = c_format
	     then do;
		p -> format_item.value(1) = generate(pt -> operand(3)) - pos;
		if pt -> operator.number = 4 then p -> format_item.value(2) =
		 generate(pt -> operand(4)) - pos;
		goto step;
		end;

	     if pt -> op_code = picture_format
	     then do;

		/* operand(3) of a picture format item points to a reference
		   node for the picture constant.  We assume that the allocate
		   bit is ON in the symbol node for the picture constant, and
		   therefore that the constant will have already been allocated */

		p -> format_item.value(1) =  pt -> operand(3) -> reference.symbol
		 -> symbol.location - pos;
		dont_pool = "1"b;
		goto step;
		end;

	     do i = 3 to pt -> operator.number;
		q = pt -> operand(i);
		if  q -> node.type = format_value_node
		then do;
		     p -> format_item.value(i-2) = q -> format_value.val;
		     rp -> value_reloc(i-2) = q -> format_value.reloc;
		     end;
		else p -> format_item.value(i-2) = q -> reference.symbol -> symbol.initial -> fix_bin;
		end;

step:	     if prev ^= null then prev -> format_item.next = bit(fixed(pos - prev_pos,18),18);

	     prev = p;
	     prev_pos = pos;

	     pt = pt -> operand(1);
	     if pt ^= null then goto loop;

	     return(start);
	     end;

	end;




		    compile_link.pl1                10/03/83  1730.5rew 10/03/83  1008.0       32499



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


/* Procedure to generate a link

   Modified: 16 October 1972 by BLW for standard object segment
	Modified:	1 June 1976 by RAB for *system links	*/

compile_link: proc(string,grow,type) returns(fixed bin(18));

dcl	string char(*) aligned,
	grow bit(18) aligned,
	type fixed bin(15);

dcl	(def_pos,link_pos,n) fixed bin(18),
	(p,def_ptr,def_reloc_ptr,link_ptr,link_reloc_ptr) ptr,
	(block_type,seg_name,ent_name) bit(18) aligned;

dcl	(cg_static_$def_base,cg_static_$link_base,
	 cg_static_$def_reloc_base,cg_static_$link_reloc_base) ptr ext,
	cg_static_$zero_def bit(18) ext,
	cg_static_$use_type_6 bit(1) ext,
	(cg_static_$def_pos,cg_static_$link_pos) fixed bin(18) ext;

dcl	name_assign entry(char(*) aligned) returns(bit(18) aligned),
	reserve$read_lib entry(fixed bin(15)) returns(ptr);

dcl	(addrel,fixed,index,length,substr) builtin;

dcl	word(0:2) bit(36) aligned based;

dcl	reloc(0:2) bit(36) aligned based;

dcl	address	fixed bin(35) based;

dcl	1 fault_pair	aligned based,
	2 unused		unal bit(30),
	2 tag		unal bit(6);

%include token;
%include relbts;

	n = index(string,"$");

	if n = length(string)
	then do;

	     /* have seg_name$ */

	     ent_name = cg_static_$zero_def;
	     seg_name = name_assign(substr(string,1,length(string)-1));

	     if grow then block_type = "000000000000000110"b;
	     else block_type = "000000000000000011"b;

	     end;
	else do;

	     if grow
	     then if cg_static_$use_type_6
		then block_type = "000000000000000110"b;
		else block_type = "000000000000000101"b;
	     else block_type = "000000000000000100"b;

	     if n = 0
	     then do;

		/* no $ in external name */

		if type = 0 then seg_name, ent_name = name_assign(string);
		else do;

		     if block_type = "000000000000000110"b
		     then do;

			/* name is stat_$alpha format */

			p = reserve$read_lib(2);
			seg_name = name_assign(p -> token.string);
			end;

		     else do;

			/* have *system link */

			seg_name = "000000000000000101"b;
			end;

		     ent_name = name_assign(string);

		     end;
		end;
	     else do;

		/* have a$b form of name */

		seg_name = name_assign(substr(string,1,n-1));
		ent_name = name_assign(substr(string,n+1));

		end;
	     end;

	def_pos = cg_static_$def_pos;
	def_ptr = addrel(cg_static_$def_base,def_pos);
	def_reloc_ptr = addrel(cg_static_$def_reloc_base,def_pos);

	link_pos = cg_static_$link_pos;
	link_ptr = addrel(cg_static_$link_base,link_pos);
	link_reloc_ptr = addrel(cg_static_$link_reloc_base,link_pos);

	def_ptr -> word(0) = block_type || grow;
	if grow then def_reloc_ptr -> reloc(0) = rc_a_dp;

	def_ptr -> word(1) = seg_name || ent_name;
	def_reloc_ptr -> reloc(1) = rc_dp_dp;

	def_ptr -> word(2) = bit(def_pos,18);
	def_reloc_ptr -> reloc(2) = rc_dp;

	link_ptr -> address = -link_pos * 262144;	/* put in left half of word */
	link_ptr -> fault_pair.tag = "100110"b;		/* fi mod = 46 octal */
	link_reloc_ptr -> reloc(0) = rc_nlb;

	link_ptr -> word(1) = bit(fixed(def_pos+2,18),18);
	link_reloc_ptr -> reloc(1) = rc_dp;

	cg_static_$def_pos = def_pos + 3;
	cg_static_$link_pos = link_pos + 2;

	return(link_pos);
	end;




		    compile_statement.pl1           10/03/83  1730.5rew 10/03/83  1008.0      209412



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


/* procedure to compile a statement

   Initial Version: 31 March 1971 by BLW for Version
   Modified:  6 February 1973 by BLW
   Modified: 28 February 1973 by RAB
   Modified: 12 June 1973 by RAB for EIS
   Modified: 1 November 1973 by RAB for snap & system
   Modified: 23 June 1975 by EEW for separate static
   Modified: 20 August 1975 by RAB to fix bug 1396
   Modified: 1 November 1975 by RAB to optimize if stmts
   Modified: 10 January 1976 by RAB for cg_stat$return_operator to fix 1453
   Modified: 1 July 1976 by RAB for label array improvements
   Modified: 27 Sept 1976 by RAB to fix 1523
   Modified: 1 Dec 1976 by RAB for -long_profile
   Modified: 23 Jan 1977 by RAB for combine_tests
   Modified: 10 Feb 1977 by RAB for multiple cond names in on stmt
   Modified: 9 Feb 1978 by RAB to check $agg_temps on end stmt
   Modified: 11 Feb 1978 by RAB to fix 1687
   Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement
   Modified 790807 by PG to remove jump_three_way.
   Modified: 16 Nov 1979 by PCK to fix 1858
   Modified: 9 November 1981 by M. N. Davidoff to fix bug 1931 in which return and stop statements
	have garbage long profile information.
   Modified: 4 January 1983 BIM to note statements that begin do loops.
*/
/* format: style3 */
compile_statement:
     proc (pt);

dcl	pt		ptr;			/* points at statement node */

/* external static */

dcl	(
	cg_stat$cur_block,
	cg_stat$cur_statement,
	cg_stat$text_base,
	cg_stat$first_ref,
	cg_stat$m_s_p,
	cg_stat$agg_temps,
	cg_stat$text_reloc_base,
	cg_stat$sym_base,
	cg_stat$sym_reloc_base,
	cg_stat$next_ref,
	cg_stat$cur_tree,
	cg_stat$return_operator,
	cg_stat$profile_base,
	cg_stat$stop_operator,
	cg_stat$return_main_operator
	)		ptr ext,
	cg_stat$star_symbol_up_zero
			bit (18) ext,
	cg_stat$old_id	bit (27) ext,
	(
	cg_stat$text_pos,
	cg_stat$sym_pos,
	cg_stat$map_start,
	cg_stat$cur_level,
	cg_stat$profile_pos,
	cg_stat$profile_start
	)		fixed bin (18) ext,
	(
	cg_stat$generate_symtab,
	cg_stat$table_option,
	cg_stat$skip_to_label,
	cg_stat$generate_map,
	cg_stat$separate_static,
	cg_stat$extended_stack,
	cg_stat$in_prologue,
	cg_stat$profile_option,
	cg_stat$support,
	cg_stat$long_profile,
	cg_stat$optimize,
	cg_stat$in_thunk
	)		bit (1) ext;

dcl	cg_stat$stop_id	aligned bit (27) ext;

/* automatic */

dcl	(
	cb,
	p,
	q,
	q1,
	q2,
	q3,
	q4,
	tree,
	save_cb,
	arg		(4),
	p1
	)		ptr,
	(nargs, profile_pos)
			fixed bin,
	macro		fixed bin (15),
	save_label	label,
	recovery_label	label int static,
	(a1, a2, atomic, replace)
			bit (1) aligned,
	on_options	bit (2) aligned,
	(st_type, op)	bit (9) aligned,
	(i, text_pos, n)	fixed bin (18);

/* based */

dcl	fix_bin		fixed bin based;

dcl	1 eax_ins		aligned based,
	  2 offset	unal bit (18);

dcl	(word, relocation)	bit (36) aligned based;

/* internal static */

dcl	(
	reset_stack	init (194),
	ret_chars		init (586),
	ret_bits		init (590),
	ret_words		init (480),
	nop_mac		init (528),
	aos_mac		init (309),
	lxl0		init (64),
	leave_begin_block	init (97),
	tra		init (169),
	enable_mac	init (291),
	enable_file	init (606),
	enable_file_2	init (593),
	ss_enter_begin_block
			init (512),
	enter_begin_block	init (197),
	return_mac	init (198),
	support_mac	init (305),
	long_profile_mac	init (699),
	quick_return_mac	init (299),
	set_stack		init (175),
	begin_return_mac	init (288),
	begin_return_main_mac
			init (729),
	stop_mac		init (726),
	return_main_mac	init (727)
	)		fixed bin (15) int static options (constant);

/* builtins */

dcl	(addr, addrel, bit, fixed, null, size, string, substr)
			builtin;

/* entries */

dcl	create_list	entry (fixed bin) returns (ptr);
dcl	create_label	entry (ptr, ptr, bit (3) aligned) returns (ptr);
dcl	decode_node_id	entry (ptr, bit (1) aligned) returns (char (120) varying),
	error		entry (fixed bin, ptr, ptr),
	xr_man$load_const	entry (fixed bin (31), fixed bin),
	(
	xr_man$super_lock,
	xr_man$super_unlock
	)		entry (fixed bin),
	expmac$many	entry (fixed bin (15), ptr, fixed bin),
	(
	stack_temp$free_aggregates,
	state_man$flush,
	state_man$discard_ms
	)		entry,
	(adjust_ref_count, compile_entry)
			entry (ptr, fixed bin (18)),
	state_man$merge_ms	entry (ptr),
	state_man$create_ms entry returns (ptr),
	state_man$erase_reg entry (bit (19) aligned),
	(ioa_$nnl, debug)	entry options (variable),
	expmac		entry (fixed bin (15), ptr),
	c_a		entry (fixed bin (18), fixed bin) returns (ptr),
	copy_temp		entry (ptr) returns (ptr),
	prepare_operand	entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
	compile_exp	entry (ptr),
	compile_exp$save_exp
			entry (ptr) returns (ptr),
	base_man$load_var	entry (fixed bin, ptr, fixed bin),
	long_op$no_size	entry (ptr, fixed bin (15)),
	load_size		entry (ptr),
	make_mod		entry (fixed bin (17), fixed bin) returns (fixed bin (18)),
	expmac$fill_usage	entry (fixed bin (18), fixed bin (17)),
	expmac$zero	entry (fixed bin (15)),
	expmac$abs	entry (ptr, fixed bin),
	optimize_if	entry (ptr),
	combine_tests	entry (ptr, ptr),
	compile_block$begin_block
			entry (ptr),
	compile_tree	entry (ptr);

%include block;
%include reference;
%include symbol;
%include label;
%include statement;
%include operator;
%include list;
%include runtime_symbol;
%include nodes;
%include statement_types;
%include statement_map;
%include profile_entry;
%include long_profile;
%include op_codes;
%include block_types;
%include declare_type;
%include relbts;
%include data_types;
%include jump_complement;

/* program */

	p, cg_stat$cur_statement = pt;
	cb = cg_stat$cur_block;

	profile_pos = 0;

	recovery_label = done;

	if cg_stat$stop_id = string (p -> statement.source_id)
	then do;
		call ioa_$nnl ("Compiling ^p (^a).^/debug: ", pt, decode_node_id (p, "0"b));
		call debug;
	     end;

	st_type = p -> statement.statement_type;

	if st_type = format_statement
	then return;

	text_pos, p -> statement.object.start, p -> statement.object.finish = cg_stat$text_pos;

	if st_type = entry_statement | st_type = procedure_statement
	then do;
		q = create_list (2);
		q -> element (2) = p;
		q -> element (1) = cb -> block.entry_list;
		cb -> block.entry_list = q;

		cg_stat$skip_to_label = "0"b;
		if cg_stat$m_s_p = null
		then cg_stat$m_s_p = state_man$create_ms ();

		call compile_entry (pt, n);

		if (cg_stat$table_option | cg_stat$generate_symtab) & ^cb -> block.no_stack
		then do;
			addrel (cg_stat$text_base, n) -> word =
			     cg_stat$star_symbol_up_zero || bit (fixed (cb -> block.symbol_block, 18), 18);
			addrel (cg_stat$text_reloc_base, n) -> relocation = rc_lp18 || rc_s;
		     end;

		if cg_stat$table_option
		then do;
			p1 = p -> statement.labels -> element (2) -> reference.symbol;
			addrel (cg_stat$sym_base, p1 -> symbol.runtime) -> runtime_symbol.location =
			     bit (fixed (p1 -> symbol.location, 18), 18);
		     end;

		if cg_stat$long_profile
		then if p -> statement.labels -> element (2) -> reference.symbol -> symbol.external
		     then do;
			     call gen_long_profile (dummy_entry_offset);
			     call gen_long_profile (dummy_entry_offset);
			     call gen_long_profile (control_entry_offset);
			     call gen_long_profile (control_entry_offset);
			     call gen_long_profile (dummy_entry_offset);
			end;

		goto done;
	     end;

	q = p -> statement.labels;
	if q = null & cg_stat$skip_to_label
	then return;

	if p -> statement.begins_loop
	& mod (text_pos, 2) ^= 0
	     then do;
	     call expmac$zero (nop_mac);
	     text_pos = text_pos + 1; /* start on even boundary */
	end;

	a1 = "0"b;
	do while (q ^= null);
	     p -> statement.reference_count = p -> statement.reference_count - 1;
	     p1 = q -> element (2);

	     if p1 -> node.type = reference_node
	     then do;
		     n = p1 -> reference.symbol -> label.location + p1 -> reference.c_offset;
		     if addrel (cg_stat$text_base, n) -> fix_bin ^= 0
		     then call error (326, p, p1);
		     else do;
			     cg_stat$text_pos = n;
			     call expmac ((tra), c_a (text_pos, 10));
			     cg_stat$text_pos = text_pos;
			end;
		end;
	     else do;
		     call expmac$fill_usage (text_pos, (p1 -> label.location));
		     p1 -> label.location = text_pos;
		     p1 -> label.allocated = "1"b;

		     if cg_stat$table_option
		     then addrel (cg_stat$sym_base, p1 -> label.symbol_table) -> runtime_symbol.location =
			     bit (text_pos, 18);
		end;

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

	if p -> statement.labels ^= null
	then do;

/* if there are no states attached to this statement and the reference
   count is zero, there were no references to the statement.  If this is
   an end statement and the root is null, this is the superfluous end
   statement generated by if_parse or do_parse.  We will ignore the
   statement in this case and avoid altering the machine state */

		if p -> state_list = null
		then if p -> reference_count = 0
		     then if p -> statement.root = null
			then if st_type = end_statement
			     then do;
				     if ^cg_stat$skip_to_label
				     then if cg_stat$extended_stack | cg_stat$agg_temps ^= null
					     | cg_stat$profile_option | cg_stat$long_profile
					then goto free_temps;
				     goto done;
				end;

		cg_stat$skip_to_label = "0"b;

/* merge together all of the possible machine states */

		call state_man$merge_ms (pt);
	     end;

free_temps:
	if p -> statement.free_temps
	then do;
		if cg_stat$extended_stack
		then call shorten_stack;

		if cg_stat$agg_temps ^= null
		then call stack_temp$free_aggregates;
	     end;

	tree, cg_stat$cur_tree = p -> statement.root;

	if cg_stat$profile_option
	then if p -> statement.put_in_profile & string (p -> statement.source_id) ^= "0"b
	     then do;
		     profile_pos = cg_stat$profile_pos;
		     call expmac ((aos_mac), c_a (profile_pos + 1, 13));
		     cg_stat$profile_pos = cg_stat$profile_pos + size (p -> profile_entry);
		end;

	if cg_stat$long_profile
	then if p -> statement.put_in_profile & string (p -> statement.source_id) ^= "0"b
	     then do;
		     profile_pos = cg_stat$profile_pos;
		     call gen_long_profile (profile_pos);
		     cg_stat$profile_pos = cg_stat$profile_pos + size (long_profile_entry);
		end;

/* ignore null statements except if they have nop operator */

	if st_type = null_statement
	then do;
		if tree = null
		then goto done;
		if tree -> operator.op_code = nop
		then call expmac$zero ((nop_mac));
		goto done;
	     end;

	if st_type = if_statement
	then do;

/* following code looks for constructs:

   if <condition> then return; _o_r
   if <condition> then stop;

   and compiles it as a conditional transfer to
   the _r_e_t_u_r_n, _r_e_t_u_r_n__m_a_i_n, or _s_t_o_p label in the operator segment */

		if tree -> op_code <= jump | tree -> op_code >= jump_if_ge
		then goto normal;

		p1 = tree -> operand (1);
		if p1 -> node.type ^= label_node
		then goto check_if;

		q1 = p -> statement.next;
		if q1 -> statement_type ^= return_statement & q1 -> statement_type ^= stop_statement
		then goto check_if;
		if q1 -> statement.labels ^= null
		then goto check_if;

		q = q1 -> statement.root;
		if q ^= null
		then do;
			if q -> operator.number ^= 0
			then goto check_if;
			if q -> op_code ^= std_return & q -> op_code ^= stop
			then goto check_if;
		     end;

		if cb -> block.no_stack
		then goto check_if;
		if cb -> block.block_type = begin_block
		then goto check_if;

		q2 = q1 -> statement.next;
		if p1 -> label.statement ^= q2
		then goto check_if;

/* all our tests succeeded, complement the sense of the jump and replace its
   operand(1) with a reference node having address ap|409, ap|801, or ap|802
   (return_operator_loc, stop_operator_loc, return_main_operator_loc defined
   in code_generator.pl1).  We don't use c_a because if stmt might be split. */

		tree -> op_code = jump_complement (fixed (substr (tree -> op_code, 6, 4), 4));
		if q1 -> statement_type = return_statement
		then if cb -> block.options_main
		     then tree -> operand (1) = cg_stat$return_main_operator;
		     else tree -> operand (1) = cg_stat$return_operator;
		else tree -> operand (1) = cg_stat$stop_operator;

		q1 -> statement_type = null_statement;
		q1 -> statement.root = null;

		q2 -> statement.reference_count = q2 -> statement.reference_count - 1;

/* following code checks for possibility of optimizing an
   if statement with a logical operator at the top */

check_if:
		if cg_stat$optimize
		then if ^p -> statement.irreducible & ^p -> statement.checked
		     then if tree -> op_code = jump_true | tree -> op_code = jump_false
			then if tree -> operand (2) -> node.type = operator_node
			     then if ^tree -> operand (2) -> operand (1) -> reference.evaluated
				then if tree -> operand (2) -> operand (1) -> reference.c_length = 1
				     then do;
					     q1 = p -> statement.next;
					     call optimize_if (pt);
					     if q1 ^= p -> statement.next
					     then call combine_tests (pt, (q1 -> statement.back));
					     tree, cg_stat$cur_tree = p -> statement.root;
					end;

		goto normal;
	     end;

	if st_type = begin_statement
	then do;
		save_label = recovery_label;
		if ^tree -> block.no_stack
		then do;
			q = addrel (cg_stat$text_base, cg_stat$text_pos);
			tree -> block.entry_list = q;

			if cg_stat$separate_static
			then macro = ss_enter_begin_block;
			else macro = enter_begin_block;
			call expmac$zero ((macro));

			if (cg_stat$table_option | cg_stat$generate_symtab)
			then do;
				addrel (cg_stat$text_base, cg_stat$text_pos) -> word =
				     cg_stat$star_symbol_up_zero
				     || bit (fixed (tree -> block.symbol_block, 18), 18);
				addrel (cg_stat$text_reloc_base, cg_stat$text_pos) -> relocation =
				     rc_lp18 || rc_s;
			     end;

			cg_stat$text_pos = cg_stat$text_pos + 1;

			if cg_stat$support
			then call expmac$zero ((support_mac));
		     end;

		call make_map_entry;

		call compile_block$begin_block ((tree));

		if cg_stat$m_s_p = null
		then cg_stat$m_s_p = state_man$create_ms ();

		cg_stat$cur_block = cb;
		cg_stat$skip_to_label = "0"b;
		cg_stat$cur_level = cb -> block.level;
		recovery_label = save_label;

		if ^tree -> block.no_stack
		then q -> eax_ins.offset = bit (make_mod (tree -> block.last_auto_loc, 16), 18);
		return;
	     end;

	if st_type = on_statement
	then do;
		nargs = 3;
		q1 = tree -> operand (1);
		arg (1) = prepare_operand ((q1 -> reference.symbol -> symbol.general), 1, atomic);
		on_options = p -> statement.snap || p -> statement.system;

		q2 = tree -> operand (2);
		if q2 ^= null
		then do;
			arg (2) = prepare_operand (q2, 1, atomic);
			if on_options ^= ""b
			then do;
				macro = enable_file_2;
				nargs = 4;
				arg (4) = c_a (fixed (bit (on_options, 18), 18), 2);
			     end;
			else macro = enable_file;
		     end;
		else do;
			n = q1 -> reference.symbol -> symbol.location;
			arg (2) = c_a (n, 1);
			arg (2) -> reference.address.op = on_options;
			macro = enable_mac;
		     end;

		arg (3) =
		     prepare_operand ((tree -> operand (3) -> block.main -> statement.labels -> element (2)), 1,
		     atomic);

		call xr_man$load_const ((arg (1) -> reference.c_length), 6);
		call xr_man$super_lock (6);

		call expmac$many (macro, addr (arg), nargs);

		call xr_man$super_unlock (6);

		if ^arg (3) -> reference.symbol -> symbol.allocated
		then do;
			p1 = create_label (cg_stat$cur_block, null, by_compiler);
			call expmac ((tra), prepare_operand (p1, 1, atomic));

			call make_map_entry;

			save_cb = cb;
			call compile_block$begin_block ((tree -> operand (3)));
			cb, cg_stat$cur_block = save_cb;
			cg_stat$cur_level = cb -> block.level;

			call expmac$fill_usage (cg_stat$text_pos, (p1 -> label.location));

			if cg_stat$m_s_p = null
			then cg_stat$m_s_p = state_man$create_ms ();
			cg_stat$skip_to_label = "0"b;
		     end;

		else call make_map_entry;

		call state_man$flush;
		return;
	     end;

	if st_type = end_statement
	then do;
		if tree = null
		then goto done;

		cg_stat$skip_to_label = cb -> block.block_type ^= begin_block;

		if cb -> block.no_stack
		then if cb -> block.block_type ^= begin_block
		     then call expmac ((quick_return_mac), c_a (cb -> block.entry_info, 4));
		     else ;

		else if cb -> block.block_type = begin_block
		then do;
			call state_man$flush;
			call expmac$zero (leave_begin_block);
		     end;

		else call return_from_nonquick_procedure (cb);

		goto done;
	     end;

	if st_type = return_statement
	then do;
		cg_stat$skip_to_label = "1"b;

		if tree = null
		then goto nr;

		op = tree -> operator.op_code;
		if op = std_return
		then goto nr;

/* have return of something with * bound or length */

		i = 0;
		if cb -> block.block_type = begin_block
		then do;

			q = cb;
			do while (q -> block.block_type = begin_block);
			     if ^q -> block.no_stack
			     then i = i + 1;
			     q = q -> block.father;
			end;

		     end;

/* we assume that we can't have a no stack procedure with returns(*) */

		q3 = c_a (i, 2);

		if op = return_string
		then do;
			replace = "0"b;
			q1 = prepare_operand ((tree -> operand (1)), 1, a1);

			if ^a1
			then if q1 -> reference.long_ref
			     then do;
				     q2 = q1 -> reference.length;
				     if q2 ^= null
				     then do;
					     if q2 -> node.type = operator_node
					     then do;
						     q4 = q2 -> operand (1);
						     if q4 -> reference.shared
						     then do;
							     q2 -> operand (1) = copy_temp (q4);
							     replace = "1"b;
							end;
						end;

					     call adjust_ref_count (q2, 1);
					end;

				     call compile_exp ((tree -> operand (1)));
				end;
			     else q1 = compile_exp$save_exp ((tree -> operand (1)));

			call load_size (q1);

			if replace
			then q2 -> operand (1) = q4;

			if q1 -> reference.data_type = char_string
			then macro = ret_chars;
			else macro = ret_bits;

l1:
			call gen_long_profile_for_last_statement;
			call expmac (lxl0, q3);
			call long_op$no_size (q1, macro);
			goto ret_done;
		     end;

/* must be return_words | return_bits operator */

		q2 = prepare_operand ((tree -> operand (2)), 1, a2);
		q1 = prepare_operand ((tree -> operand (1)), -1, a1);

		call compile_exp ((tree -> operand (2)));

		if op = return_bits
		then do;
			macro = ret_bits;
			goto l1;
		     end;

		if q1 -> reference.varying_ref
		then q1 -> reference.c_offset = q1 -> reference.c_offset - 1;

		call base_man$load_var (2, q1, 1);
		call gen_long_profile_for_last_statement;
		call expmac (ret_words, q3);

		if q1 -> reference.varying_ref
		then q1 -> reference.c_offset = q1 -> reference.c_offset + 1;

		goto ret_done;

/* have normal return operator */

nr:
		q = cb;
		if cb -> block.block_type ^= begin_block
		then if cb -> block.no_stack
		     then do;
qr:
			     if cg_stat$extended_stack
			     then call shorten_stack;
			     call expmac (quick_return_mac, c_a (q -> block.entry_info, 4));
			end;
		     else call return_from_nonquick_procedure (cb);

		else do;
			i = 0;

			do while (q -> block.block_type = begin_block);
			     if ^q -> block.no_stack
			     then i = i + 1;
			     q = q -> block.father;
			end;

			if q -> block.no_stack
			then do;
				if i ^= 0
				then do;
					call expmac ((set_stack), c_a (i, 2));
					cg_stat$extended_stack = "0"b;
				     end;
				goto qr;
			     end;

			if q -> block.options_main
			then macro = begin_return_main_mac;
			else macro = begin_return_mac;

			call gen_long_profile_for_last_statement;
			call expmac (macro, c_a (i, 2));
		     end;

ret_done:
		call state_man$discard_ms;
		cg_stat$extended_stack = "0"b;

		goto done;
	     end;

/* process stop statements */

	if st_type = stop_statement
	then do;
		cg_stat$skip_to_label = "1"b;
		call gen_long_profile_for_last_statement;
		call expmac$zero (stop_mac);
		call state_man$discard_ms;
		goto done;
	     end;

normal:
	if tree ^= null
	then call compile_tree (tree);

done:
	call make_map_entry;
	return;

recover:
     entry;

/* This entry causes compile_statement to return to the program
   that call it, thus effecting an error recovery after a fault */

	goto recovery_label;

shorten_stack:
     procedure;

	if st_type ^= procedure_statement
	then do;
		call state_man$erase_reg ("0000000000000001000"b);
						/* ab */
		call expmac$zero ((reset_stack));
	     end;

	cg_stat$extended_stack = "0"b;
     end shorten_stack;

make_map_entry:
     procedure;

/* This procedure makes a statement_map entry for the statement if
   one is needed and updates any necessary profile information */

dcl	q		ptr;

	p -> statement.object.finish = cg_stat$text_pos;

	if profile_pos ^= 0
	then addrel (cg_stat$profile_base, profile_pos) -> profile_entry.map =
		bit (fixed (cg_stat$sym_pos - cg_stat$map_start, 18), 18);

	if ^cg_stat$generate_map
	then goto reset;

	if cg_stat$in_thunk
	then goto reset;				/* Protects runtime symbol table.  (1858) */

/* make entry in map if we generated any code for this
   statement and its statement id is different from that
   of previous statement */

	if profile_pos = 0
	then do;
		if cg_stat$in_prologue
		then goto reset;

		if p -> statement.object.finish = text_pos
		then goto reset;

		if cg_stat$old_id = string (p -> statement.source_id)
		then goto reset;

		if p -> statement.source.length <= 0
		then goto reset;
	     end;

	cg_stat$old_id = string (p -> statement.source_id);

	q = addrel (cg_stat$sym_base, cg_stat$sym_pos);
	q -> statement_map.location = bit (text_pos, 18);
	string (q -> statement_map.source_id) = string (p -> statement.source_id);
	q -> statement_map.source_info.start = bit (fixed (p -> statement.source.start, 18), 18);
	q -> statement_map.source_info.length = bit (fixed (p -> statement.source.length, 9), 9);
	addrel (cg_stat$sym_reloc_base, cg_stat$sym_pos) -> relocation = rc_t;
	cg_stat$sym_pos = cg_stat$sym_pos + size (q -> statement_map);

reset:
	cg_stat$next_ref = cg_stat$first_ref;
     end make_map_entry;

return_from_nonquick_procedure:
     procedure (cb);

dcl	cb		ptr;			/* (Input) */

	call gen_long_profile_for_last_statement;

	if cb -> block.options_main
	then call expmac$zero (return_main_mac);
	else call expmac$zero (return_mac);
     end return_from_nonquick_procedure;

gen_long_profile_for_last_statement:
     procedure;

	if cg_stat$long_profile
	then call gen_long_profile (dummy_entry_offset);
     end gen_long_profile_for_last_statement;

gen_long_profile:
     procedure (offset);

dcl	offset		fixed bin;		/* offset of profile entry */

dcl	1 trailer		aligned,
	  2 header_relp	fixed bin (17) unal,
	  2 entry_offset	fixed bin (17) unal;

	call expmac$zero (long_profile_mac);

	addrel (cg_stat$text_reloc_base, cg_stat$text_pos) -> relocation = rc_is18;
	trailer.header_relp = cg_stat$profile_start;
	trailer.entry_offset = offset;
	call expmac$abs (addr (trailer), size (trailer));
     end gen_long_profile;

     end compile_statement;




		    compile_tree.pl1                10/03/83  1730.5rew 10/03/83  1008.1      257076



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


/* Procedure to compile root operator of a statement

   Initial Version: 16 April 1971 by BLW
	Modified: 29 December 1972 by BLW
	Modified:	28 February 1973 by RAB
	Modified:	18 June 1973 by RAB	
	Modified:	6 October 1973 by RAB for EIS
	Modified:	23 June 1976 by R. Schoeman for new area package
	Modified:	24 June 1976 by RAB to centralize use of cg_stat$last_call
	Modified:	30 January 1977 by RAB to dec ref_count in allot_ctl & free_ctl
	Modified:	15 April 1979 by RAB to improve code for a = a & b; for
		based long strings by checking for allowable cases of overlap
	Modified:	17 August 1979 by RAB to improve code for a = a & ^ b; for long strings.
		One instruction is generated instead of two or more.
	Modified 791016 by PG to fix 1856 (multiple assignment code bumped ref count on
		a shared reference node owned by a top-level bound_ck operator!)
	Modified 830106 by BIM to align aggregate loops on doubleword
		boundaries.
*/

compile_tree: proc(pt);

/* parameters */

dcl	pt ptr parameter;		/* point at an operator node */

/* external static */

dcl	(cg_stat$prol_ent,cg_stat$cur_block,cg_stat$cur_statement,cg_stat$cur_node,cg_stat$cur_tree) ptr ext,
	cg_stat$text_pos fixed bin(18) ext;

/* automatic */

dcl	(p,arg(3),llp,ulp,p1,q1,p2,q2,q3,s1,s2,rand(10),save_cur_node) ptr,
	macro fixed bin(15),
	op_code bit(9),
	(atomic,abset) bit(1) aligned,
	(i,j,k,loc,n,cfo,d) fixed bin;

/* based */

dcl	fix_bin		fixed bin based;

/* defined */

dcl	op_class bit(5) defined(op_code) pos(1);

/* entries */

dcl	(assign_op,compile_tree,compile_exp,move_data,
	 state_man$flush_ref,jump_op,io_op) entry(ptr);
dcl	m_a entry(ptr,bit(2) aligned);
dcl	base_man$load_var entry(fixed bin,ptr,fixed bin),
	base_to_core entry(fixed bin,ptr),
	base_man$store_ptr_to entry(ptr,ptr),
	base_man$update_base entry(fixed bin,ptr,fixed bin);
dcl	compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
dcl	adjust_ref_count entry(ptr,fixed bin),
	call_op entry(ptr) returns(ptr),
	compile_exp$save entry(ptr) returns(ptr),
	compile_exp$save_exp entry(ptr) returns(ptr),
	load entry(ptr,fixed bin),
	create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
	store$force entry(ptr),
	xr_man$load_const entry(fixed bin(31),fixed bin),
	(state_man$flush,io_op$init_ps) entry,
	state_man$erase_reg entry(bit(19) aligned),
	state_man$set_aliasables entry(ptr),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	aq_man$clear_q entry,
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	expmac entry(fixed bin(15),ptr),
	decimal_op$change_target entry(ptr) returns(bit(1) aligned),
	decimal_op$get_float_temp entry(fixed bin(24),bit(1) aligned) returns(ptr),
	assign_op$to_dec_scaled entry(ptr,ptr),
	stack_temp$assign_aggregate entry(ptr);

/* builtins */

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

/* internal static */

dcl	odd_bases bit(19) aligned int static init("0000000000000001111"b);

dcl (	call_prologue	init(204),
	aos_mac		init(309),
	nop_mac		init(528),
	incr_mac		init(310),
	diff_mac		init(311),
	allot_auto_mac	init(114),
	zero_mac		init(308),
	open_mac		init(493),
	close_mac		init(494),
	make_desc_mac	init(275),
	arl		init(245),
	lrl		init(62),
	signal_mac	init(289),
	io_signal_mac	init(321),
	revert_mac	init(290),
	revert_file	init(607),
	string_mac(33:35)	init(43,49,55),
	long_mac(33:35)	init(264,304,341),
	move_andnot_1	init(392),
	set_desc_size	init(276),
	alloc_block	init(608),
	free_block	init(609),
	alloc_based_area	init(502),
	alloc_based_mac	init(695),
	free_based_mac	init(696),
	empty_area_mac	init(697),
	push_ctl_data	init(610),
	push_ctl_desc	init(611),
	pop_ctl_data	init(612),
	pop_ctl_desc	init(613),
	loop_end		init(397)) fixed bin(15) int static options (constant);

dcl (	jump_class	init("00101"b),
	ptr_class		init("01011"b),
	io_class		init("10000"b)) bit(5) int static options (constant);

/* include files */

%include cgsystem;
%include block;
%include statement;
%include operator;
%include reference;
%include symbol;
%include label;
%include nodes;
%include declare_type;
%include op_codes;
%include data_types;
%include boundary;
%include list;

/* program */

	p, cg_stat$cur_tree = pt;
	op_code = p -> operator.op_code;

	if op_code = join
	then do;

	     do i = 1 to p -> operator.number;
		call compile_tree((p -> operand(i)));
		end;

	     return;
	     end;

	if op_class = jump_class
	then do;
	     call jump_op(pt);
	     return;
	     end;

	do i = 1 to p -> operator.number;
	     rand(i) = p -> operand(i);
	     end;

	if p -> operator.number > 1
	then if rand(1) ^= null
	then if rand(1) -> node.type = reference_node
	then if rand(1) -> reference.evaluated
	then if ^ rand(1) -> reference.shared
	then do;
	     call adjust_ref_count(rand(1),-1);
	     return;
	     end;

	if op_code = std_call
	then do;
	     p = call_op(p);
	     return;
	     end;

	if op_code = assign_zero
	then do;
	     p = prepare_operand(rand(1),1,atomic);
	     call state_man$flush_ref(p);
	     call expmac((zero_mac),p);
	     if p -> reference.aliasable
		then call state_man$set_aliasables(p);
	     return;
	     end;

	if op_code = ex_prologue
	then do;

	     p = cg_stat$cur_block;
	     if p -> block.number_of_entries = 1
	     then do;

		/* instead of compiling the prologue as a subroutine, we'll
		   hook all of the prologue statements into the main list
		   after the current statement */

	          if p -> block.plio_ps ^= null then call io_op$init_ps;

		arg(1) = cg_stat$cur_statement;
		arg(2) = p -> block.end_prologue;
		if arg(2) = null then return;
		arg(2) -> statement.next = arg(1) -> statement.next;
		arg(2) -> statement.next -> statement.back = arg(2);
		arg(2) = p -> block.prologue;
		arg(1) -> statement.next = arg(2);
		arg(2) -> statement.back = arg(1);
		p -> block.prologue, p -> block.end_prologue = null;
		end;

	     else if cg_stat$prol_ent ^= null
		then do;
		     call state_man$erase_reg((odd_bases));
		     call expmac((call_prologue),prepare_operand(cg_stat$prol_ent,1,atomic));
		     end;

	     return;
	     end;

	if op_code = loop
	then do;

	     call check_aggregate(rand(1));

	     arg(2) = prepare_operand(rand(2),1,atomic);

	     ulp = prepare_operand(rand(4),1,atomic);
	     if ^ atomic then ulp = compile_exp$save(rand(4));

	     if ulp -> reference.data_type = real_fix_bin_2 then ulp -> reference.c_offset = ulp -> reference.c_offset + 1;

	     llp = prepare_operand(rand(3),1,atomic);
	     if atomic then call load(llp,0); else call compile_exp(rand(3));

	     call store$force(arg(2));

	     call state_man$flush;

	     if mod (cg_stat$text_pos, 2) ^= 0
	     then call expmac$zero (nop_mac);
	     arg(1) = create_label(cg_stat$cur_block,null,(by_compiler));
	     arg(1) -> label.location = cg_stat$text_pos;
	     arg(1) -> label.allocated = "1"b;
	     arg(1) = prepare_operand(arg(1),1,atomic);

	     call compile_tree(rand(1));

	     arg(3) = ulp;
	     call expmac$many((loop_end),addr(arg),3);

	     if ulp -> reference.data_type = real_fix_bin_2 then ulp -> reference.c_offset = ulp -> reference.c_offset - 1;

	     /* release scalar expressions pulled outside of loop as optimization */

	     do p1 = rand(5) repeat p1 -> element(1) while(p1 ^= null);
		call adjust_ref_count((p1 -> element(2)),-1);
		end;

	     return;
	     end;

	if op_code = allot_auto
	then do;
	     q2 = prepare_operand(rand(2),1,atomic);
	     if atomic then call load(q2,0); else call compile_exp(rand(2));
	     call expmac((allot_auto_mac),rand(1));
	     call base_man$update_base(1,rand(1),1);
	     return;
	     end;

	if op_code = make_desc
	then do;

	     do i = 1 to 3;
		arg(i) = prepare_operand(rand(i),1,atomic);
		end;

	     if atomic then call load(arg(3),0); else call compile_exp(rand(3));

	     if arg(1) ^= arg(2) then call expmac$many((make_desc_mac),addr(arg),2);
	     else do;
		call m_a(arg(1),"0"b);
		arg(1) -> reference.perm_address = "1"b;

		if arg(1) -> address.tag
		then do;
		     call base_man$load_var(2,arg(1),1);
		     arg(1) -> reference.perm_address = "1"b;
		     end;

		arg(1) -> address.tag = "001111"b;
		call expmac((set_desc_size),arg(1));
		end;

	     return;
	     end;

	if op_code = copy_words
	then do;
l4:	     call move_data(p);
	     abset = "0"b;
	     call set_structure(rand(1));
	     return;
	     end;

	if op_code = copy_string then goto l4;

	if op_class = io_class
	then do;
	     save_cur_node = cg_stat$cur_node;
	     cg_stat$cur_node = pt;
	     call io_op(pt);
	     cg_stat$cur_node = save_cur_node;
	     call state_man$set_aliasables(null);
	     return;
	     end;

	if op_code = open_file
	then do;
	     macro = open_mac;
	     goto l6;
	     end;

	if op_code = close_file
	then do;
	     macro = close_mac;

l6:	     call state_man$erase_reg((odd_bases));
	     call expmac$zero(macro);
	     call state_man$set_aliasables(null);
	     return;
	     end;

	if op_code = signal_on
	then do;

	     if rand(2) = null then macro = signal_mac;
	     else do;
		p2 = prepare_operand(rand(2),1,atomic);
		call base_man$store_ptr_to(p2,c_a(40,4));
		macro = io_signal_mac;
		end;

	     p1 = prepare_operand((rand(1) -> reference.symbol -> symbol.general),1,atomic);
	     call xr_man$load_const((p1 -> reference.c_length),6);
	     call expmac(macro,p1);
	     call state_man$flush;
	     return;
	     end;

	if op_code = revert_on
	then do;
	     if rand(2) = null
	     then call expmac((revert_mac),c_a((rand(1) -> reference.symbol -> symbol.location),4));
	     else do;
		arg(1) = prepare_operand((rand(1) -> reference.symbol -> symbol.general),1,atomic);
		arg(2) = prepare_operand(rand(2),1,atomic);
		call expmac$many((revert_file),addr(arg),2);
		end;

	     return;
	     end;

	if op_code = nop
	then do;
	     call expmac$zero((nop_mac));
	     return;
	     end;

	s1 = rand(1) -> reference.symbol;

	if op_code = allot_ctl
	then do;
		q2 = prepare_operand(rand(2),1,atomic);
		if atomic
		     then call load(q2,0);
		     else call compile_exp(rand(2));
		if s1->symbol.arg_descriptor
		     then macro = push_ctl_desc;
		     else if s1->symbol.exp_extents
			     then macro = alloc_block;
			     else macro = push_ctl_data;
		go to ca;
	     end;

	if op_code = free_ctl
	then do;
		if s1->symbol.arg_descriptor
		     then macro = pop_ctl_desc;
		     else if s1->symbol.exp_extents
			     then macro = free_block;
			     else macro = pop_ctl_data;
ca:		loc = s1->symbol.location;
		if s1->symbol.internal
		     then do;
			n = 13;
			if s1->symbol.arg_descriptor
			     then loc = loc - 2;
			end;
		     else n = 9;
		q1 = c_a(loc,n);
		call state_man$erase_reg((odd_bases));
		call expmac(macro,q1);
		if ^ rand(1) -> reference.shared
		     then call adjust_ref_count(rand(1),-1);
		call state_man$set_aliasables(null);
		abset = "1"b;
		call set_structure(rand(1));
		return;
	     end;

		/* The schematic code sequence for allot_based	*/
		/* is as follows:	*/
		/*  <prepare ptr>		*/
		/*  <flush all registers>	*/
		/*RE-TRY:		*/
		/*  <prepare area> (if it exists)	*/
		/*  <compile size(based_var)>	*/
		/*  epp2 area (if it exists)	*/
		/*  <flush all regs>	*/
		/*  tsx0	pr0|alloc_based if area given,	*/
		/*  or tsx0 pr0|alloc_based_storage if area not given	*/
		/*  tra RE-TRY		*/
		/*  spri2	_p_t_r (to area)	*/

	if op_code = allot_based
	then do;				
	     q1 = prepare_operand(rand(1),1,atomic);	

	     call state_man$flush;		
	     loc = cg_stat$text_pos;		

	     if rand(3)^= null		
	     then q3 = prepare_operand(rand(3),1,atomic);

	     q2 = prepare_operand(rand(2),1,atomic);
	     if atomic			
	     then call load(q2,0);		
	     else call  compile_exp(rand(2));	

	     p1 = c_a(loc,10);		
	     if rand(3) ^=  null		
	     then do;			
	     	call base_man$load_var(2,q3,1);
		macro = alloc_based_area;
		end;
	     else macro = alloc_based_mac;

	     call state_man$flush;

	     call expmac(macro,p1);
	     call base_to_core(1,q1);

	     return;
	     end;

		/* The schematic code sequence for free_based is:	*/
		/* <evaluate size (based_var)>	*/
		/* <evaluate area>	*/
		/* epp5 qualifier_of_based_var	*/
		/* <flush all regs>	*/
		/* tsx0 pr0|free_based	*/

	if op_code = free_based
	then do;				
	     q2 = prepare_operand(rand(2),1,atomic);
	     if ^atomic			
	     then call compile_exp(rand(2));	
	     else call adjust_ref_count(q2,-1);	
					
	     if rand(3) ^= null		
	     then do;
		q3 = prepare_operand(rand(3),1,atomic);
		if ^atomic
		then call compile_exp(rand(3));
		else call adjust_ref_count(q3,-1);

		end;

	     q1 = prepare_operand(rand(1),-1,atomic);

	     p2 = q1->reference.qualifier;

	     if p2->node.type = operator_node
	     then do;

		/* check for evaluated because addr_fun handled specially */

		if ^ p2 -> operand(1) -> reference.evaluated
		     then p2 = compile_exp$save(p2);
		     else p2 = p2 -> operand(1);
		end;

	     if ^ p2 -> reference.shared
		then p2->reference.ref_count = p2->reference.ref_count + 1;
	     call base_man$load_var(2,p2,5);

	     call state_man$flush;

	     call expmac$zero((free_based_mac));

	     call adjust_ref_count(q1,-1);

	     return;

	     end;

		/* The schematic code sequence for free_based is :	*/
		/* <compile size>	*/
		/* epp2 area	*/
		/* <flush all regs>	*/
		/* tsx0 pr0|empty	*/

	if op_code = empty_area
	then do;				
	     q1 = prepare_operand(rand(1),1,atomic);

	     q2 = prepare_operand(rand(2),1,atomic);
	     if ^atomic			
	     then call compile_exp(rand(2));	
	     else call load(q2,0);		

	     call base_man$load_var(2,q1,1);	

	     call state_man$flush;

	     call expmac$zero((empty_area_mac));

	     return;

	     end;

	if op_class = ptr_class then goto ce;

/* All of the code from here to the call to compile_exp is here to handle
   the special-cases that arise from operator_semantics eliminating assign
   operators at the top of the tree. However, the following code is general
   in that is it safe to perform these optimizations no matter what the
   origin of the tree. */

	/* The following code adjusts the reference count on T in the case
			T = right_hand_side
			a = T
			b = T
	   which arises from the multiple assignment
			a,b = right_hand_side
	  or from the assignment
			bit_string = unspec(right_hand_side)	*/

	if s1 -> symbol.temporary & ^rand(1) -> reference.shared
	then if rand (1) -> reference.ref_count > 1
	     then rand (1) -> reference.ref_count = rand (1) -> reference.ref_count - 1;

	if (op_code = assign) | (op_code = assign_size_ck)
	then do;
	     if op_code = assign_size_ck
	     then go to l0;

	     /* The following uses the fact the all decimal operations are done by special hardware and
	        most complex binary operations are done via calls to procedures both of which are
	        able to accept an output operand whose attributes are different than
	        those required by the PL/I precision rules.  The fact that the
	        semantic translator generated an assigment operator means that
	        the attributes of the LHS do not match those of the RHS.  If RHS
	        is an expression which has not been optimized or previously
	        evaluated, we will attempt to eliminate the assign operator ourselves
	        if the runtime routines can handle the attribute mismatch that will
	        result.  This eliminates the need for an extra procedure call at
	        runtime to move the result of the computation into LHS */

	     if rand(2) -> node.type ^= operator_node then goto l0;

	     p1 = rand(2) -> operand(1);
	     if p1 -> reference.evaluated then goto l0;
	     if p1 -> reference.ref_count > 0 then goto l0;

	     s2 = p1 -> reference.symbol;

	     /* Both sides have to have same value for complex and decimal attributes */

	     if s1 -> symbol.complex ^= s2 -> symbol.complex then goto l0;
	     if s2 -> symbol.decimal ^= s1 -> symbol.decimal then goto l0;

	     if s1 -> symbol.decimal
	     then do;

		/* Make sure scales are within hardware limits */

		if s1 -> symbol.scale > max_dec_scale then go to l0;
		if s1 -> symbol.scale < min_dec_scale then go to l0;
		if s2 -> symbol.scale > max_dec_scale then go to l0;
		if s2 -> symbol.scale < min_dec_scale then go to l0;

		/* some operators require results with special characteristics */

		if rand(2) -> operator.op_code = trunc_fun
		then if s1 -> symbol.scale ^= 0 | (s1 -> symbol.float & s2 -> symbol.fixed)
		     then go to l0;
		if rand(2) -> operator.op_code = assign
		then do;
		     if s1 -> symbol.float & s2 -> symbol.fixed
			then go to l0;
		     if s1 -> symbol.fixed & s2 -> symbol.fixed
		     then if s1 -> symbol.scale ^= s2 -> symbol.scale
			then go to l0;
		     if s1 -> symbol.c_dcl_size > s2 -> symbol.c_dcl_size
			then go to l0;
		     end;
		if rand(2) -> operator.op_code = round_fun then go to l0;
		if rand(2) -> operator.op_code = min_fun then go to l0;
		if rand(2) -> operator.op_code = max_fun then go to l0;
		if rand(2) -> operator.op_code = unpack then go to l0;

		/* any real decimal can be replaced by any other real decimal
		   and similarly for complex decimals */

switch:		rand(2) -> operand(1) = rand(1);
		p = rand(2);
		goto ce;
		end;

	     if ^ s1 -> symbol.complex then goto l0;

	     /* If output of RHS is float binary single, we only want to
	        replace it if LHS is float binary single aligned.  Otherwise,
	        we can replace a complex float binary with any other
	        complex float binary and similarly for complex fixed binary */

	     if s2 -> symbol.float
	     then if s2 -> symbol.c_word_size = 1
		then do;
		     if ^ s1 -> symbol.float then goto l0;
		     if s1 -> symbol.c_word_size ^= 1 then goto l0;
		     if s1 -> symbol.packed then goto l0;

		     if rand(1) -> reference.units ^= 0
		     then if rand(1) -> reference.units ^= word_
			then goto l0;

		     goto switch;
		     end;

	     if s2 -> symbol.float = s1 -> symbol.float then goto switch;

	     /* could not eliminate the assignment */

l0:	     call assign_op(p);
	     go to set;
	     end;

	/* the following code checks for decimal expressions whose scale
	   is outside of machine limits */

	if s1 -> symbol.decimal
	then if s1 -> symbol.fixed
	then if p -> operator.number >= 3
	then if op_code ^= round_fun
	then if op_code ^= complex_fun
	then do;
	     if s1 -> symbol.scale < min_dec_scale | s1 -> symbol.scale > max_dec_scale
	     then do;
		if decimal_op$change_target(p)
		then do;
		     p -> operand(1) = decimal_op$get_float_temp(s1 -> symbol.c_dcl_size,(s1 -> symbol.complex));
		     p1 = compile_exp$save(p);
		     rand(1) = prepare_operand(rand(1),1,atomic);
		     call assign_op$to_dec_scaled(rand(1),p1);
		     p -> operand(1) = rand(1);
		     go to set;
		     end;
		end;
	     go to ce;
	     end;

	/* machine-dependent optimizations follow */

	if op_code = add | op_code = sub
	then do;

	     /* if operand(1) is single fixed binary, we may be able to generate
	        a shorter code sequence if two of the operands are the same */


	     if s1 -> symbol.complex then goto ce;
	     if s1 -> symbol.float then goto ce;
	     if s1 -> symbol.unaligned then goto ce;

	     if s1 -> symbol.c_dcl_size > max_p_fix_bin_1 then goto ce;

	     if ^ search_arithmetic() then go to ce;

	     q1 = prepare_operand(rand(1),1,atomic);

	     call drop_count;

	     if i = 2 then j = 3; else j = 2;

	     p2 = p -> operand(j);
	     q2 = prepare_operand(p2,1,atomic);

	     if op_code = sub then goto l2;

	     if atomic
	     then do;
		s2 = q2 -> reference.symbol;
		if s2 -> symbol.constant
		then if q2 -> reference.offset = null
		     then if q2 -> reference.c_offset = 0
			then if s2 -> symbol.initial -> fix_bin = 1
		     	     then do;
				macro = aos_mac;
				goto l3;
				end;

		call load(q2,0);
		end;
	     else call compile_exp(p2);

l1a:	     macro = incr_mac;
	     goto l3;

l2:	     if i = 2
	     then do;
		if ^ atomic then q2 = compile_exp$save(p2);
		call load(q2,1);
		goto l1a;
		end;

	     if atomic then call load(q2,0); else call compile_exp(p2);

	     macro = diff_mac;

l3:	     call state_man$flush_ref(q1);
	     call expmac(macro,q1);
	     go to set;
	     end;

	if op_class = "00010"b			/* and, or, not, etc */
	then do;
	     if op_code > xor_bits then goto ce;

	     /* have &, |, or xor operator */

	     if rand(1) -> reference.length ^= null | rand(1) -> reference.c_length > bits_per_two_words
	     then do;
		if ^ search() then go to ce;

		macro = long_mac(fixed(op_code,9));

		if i = 2 then j = 3; else j = 2;

		q1 = prepare_operand(rand(1),1,atomic);
		p2 = prepare_operand(rand(j),1,atomic);

		if rand(j) -> node.type = reference_node
		then if overlaps(q1,p2)
		     then go to ce;
		     else;

		else if can_do_andnot(rand(j))
		     then do;

			/* op_code is and_bits, rand(j) is not_bits */

			p2 = prepare_operand((rand(j) -> operand(2)),1,atomic);

			if ^ atomic
			     then p2 = compile_exp$save_exp((rand(j) -> operand(2)));

			call adjust_ref_count((rand(j) -> operand(1)), -1);

			macro = move_andnot_1;
			end;

		     else p2 = compile_exp$save(rand(j));

		call drop_count;

		call expmac$two_eis(macro,q1,p2);
		go to set;
		end;

	     if rand(1) -> reference.offset ^= null then goto ce;
	     if rand(1) -> reference.fo_in_qual then goto ce;

	     cfo = mod(rand(1) -> reference.c_offset * convert_offset(rand(1) -> reference.units),bits_per_word);
	     k = cfo + rand(1) -> reference.c_length;
	     if k > bits_per_two_words then goto ce;

	     if ^ search() then go to ce;

	     q1 = prepare_operand(rand(1),1,atomic);

	     if ^ (q1 -> reference.aligned_ref | op_code = or_bits) then goto ce;

	     call drop_count;

	     if i = 2 then j = 3; else j = 2;
	     p2 = rand(j);
	     q2 = prepare_operand(p2,1,atomic);

	     d = fixed(k > bits_per_word,1);

	     if atomic then call load(q2,d); else call compile_exp(p2);

	     i = q2 -> reference.c_length;
	     if op_code = and_bits
	     then if fixed(i > bits_per_word,1) < d
		then do;
		     call aq_man$clear_q;
		     i = bits_per_two_words;
		     end;

	     i = cfo + i;
	     d = fixed(i > bits_per_word,1);

	     if cfo ^= 0
	     then do;
		if d = 0 then macro = arl; else macro = lrl;
		call expmac(macro,c_a(cfo,1));
		end;

	     call state_man$flush_ref(q1);
	     call expmac$one((string_mac(fixed(op_code,9))),q1,d);
	     go to set;
	     end;

ce:	call compile_exp(p);

set:	if rand(1) -> reference.aliasable
	then call state_man$set_aliasables(rand(1));
	else if rand(1) -> reference.defined_ref
	     then do;
		abset = "0"b;
		call set_structure((rand(1) -> reference.qualifier));
		end;

	return;

search:	proc returns(bit(1) aligned) irreducible;

	if rand(1) -> reference.units = 0
	     then rand(1) -> reference.units = word_;

	do i = 2 to 3;
	     q1 = rand(i);
	     if rand(1) = q1 then return("1"b);
	     if q1 -> node.type = reference_node
	     then do;
		if q1 -> reference.units = 0
		     then q1 -> reference.units = word_;
		if rand(1) -> reference.symbol = q1 -> reference.symbol
		then if compare_expression(rand(1),q1)
		     then return("1"b);
		end;
	     end;

	return("0"b);

	end;

search_arithmetic:	proc returns(bit(1) aligned) irreducible;

	/* we cannot use compare_expression directly because some operands
	   may be prepared while others may not, thus c_length may be invalid.
	   compare_expression is used at all because if one operand is a call,
	   the optimizer might be prevented from commoning the offsets and
	   qualifiers of the other operands. */

	do i = 2 to 3;
	     q1 = rand(i);
	     if rand(1) = q1 then return("1"b);
	     if q1 -> node.type = reference_node
	     then if rand(1) -> reference.symbol = q1 -> reference.symbol
	     then if rand(1) -> reference.c_offset = q1 -> reference.c_offset
	     then do;
		if rand(1) -> reference.qualifier ^= q1 -> reference.qualifier
		then if ^ compare_expression((rand(1) -> reference.qualifier),(q1 -> reference.qualifier))
		     then go to step;
		if rand(1) -> reference.offset ^= q1 -> reference.offset
		then if ^ compare_expression((rand(1) -> reference.offset),(q1 -> reference.offset))
		     then go to step;
		return("1"b);
		end;
step:
	     end;

	return("0"b);

	end;

drop_count:	proc;

	if ^ rand(i) -> reference.shared
	     then call adjust_ref_count(rand(i),-1);

	end;

overlaps:	proc(q1,p2) returns(bit(1) aligned);

/* checks to see if two reference nodes reference overlapping but not matching storage.
   At least one of the reference nodes MUST be a non-temporary. */

dcl	     (q1,p2) ptr;

	if q1 -> reference.symbol = p2 -> reference.symbol
	 | (q1 -> reference.aliasable & p2 -> reference.aliasable)
	   & q1 -> reference.symbol -> symbol.aligned = p2 -> reference.symbol -> symbol.aligned
	   & q1 -> reference.symbol -> symbol.varying = p2 -> reference.symbol -> symbol.varying
	then if q1 -> reference.substr
	      | p2 -> reference.substr
	      | ^ (q1 -> reference.symbol -> symbol.aligned | q1 -> reference.symbol -> symbol.varying)
	     then return("1"b);

	return("0"b);

	end /* overlaps */;

set_structure:	proc(pt);

/* We must flush the non-aggregate shared members of the structure from the machine state */

dcl	(adam,pt,r,s) ptr;

	adam = pt -> reference.symbol;

	s = adam;

loop:	do while(s -> symbol.structure);
	s = s -> symbol.son;
	end;

	r = s -> symbol.reference;
	if ^ r -> reference.array_ref
	then do;
	     if r -> reference.qualifier = null
	     then if r -> reference.offset = null
		then if r -> reference.length = null
		     then call state_man$flush_ref(r);

	     if ^ abset
	     then if s -> symbol.aliasable | r -> reference.aliasable
		then call state_man$set_aliasables(r);
	     end;

	if s = adam then return;

	do while(s -> symbol.brother = null);
	s = s -> symbol.father;
	if s = adam then return;
	end;

	s = s -> symbol.brother;
	go to loop;
	end;

check_aggregate:	proc(pt);

/* check_aggregate makes sure that aggregate temporaries get allocated
   outside of the loop in which they might appear */

dcl	     (p,pt,s) ptr;
dcl	     i fixed bin;
dcl	     op_code bit(9) aligned;

	     p = pt;
	     if p = null then return;
	     if p -> node.type ^= operator_node then return;

	     op_code = p -> operator.op_code;

	     if op_code = loop
	     then do;
		call check_aggregate((p -> operand(1)));
		return;
		end;

	     if op_code = join
	     then do;
		do i = 1 to p -> operator.number;
		     call check_aggregate((p -> operand(i)));
		     end;
		return;
		end;

	     if p -> operator.number = 0 then return;
	     if p -> operand(1) = null then return;
	     p = p -> operand(1);
	     if p -> node.type ^= reference_node then return;
	     s = p -> reference.symbol;
	     if s -> node.type ^= symbol_node then return;

	     if s -> symbol.temporary
	     then if s -> symbol.member | s -> symbol.dimensioned | s -> symbol.structure | s -> symbol.arg_descriptor
		then do;
		     do  while(s -> symbol.father ^= null);
			s = s -> symbol.father;
			end;

		     if s -> symbol.initial = null
			then call stack_temp$assign_aggregate(s);
		     end;

	     end /* check_aggregate */;

can_do_andnot: proc(p_o) returns(bit(1) aligned);

/* Sees whether a = a & ^ b; can be done in one instruction. */

dcl	     (o,p_o) ptr;	/* operator which might be not_bits */

dcl	     p2 ptr;
dcl	     useless bit(1) aligned;

	     o = p_o;

	     if op_code = and_bits
	      & o -> operator.op_code = not_bits
	      & o -> operand(1) -> reference.ref_count <= 1
	      & ^ o -> operand(1) -> reference.evaluated
	     then do;
		p2 = o -> operand(2);

		if p2 -> node.type = reference_node
		then do;
		     p2 = prepare_operand(p2,0,useless);	/* set reference.aliasable */
		     p2 -> reference.data_type = 0;		/* for future prepare_operand call */

		     if overlaps(rand(1),p2)
			then return("0"b);
		     end;

		return("1"b);
		end;

	     return("0"b);

	     end /* can_do_andnot */;
end;




		    complex_stuff.table             10/04/83  1048.1rew 10/04/83  1039.6       61308



" code definition segment for Fortran complex
"
"	Modified:	8 August 1978 by Richard A. Barnes to fix 1731
"
" we assume that the only type of complex data is cfl1 and that at least
" one operand has this type
"
	name	complex_stuff
	segdef	complex_stuff
	segdef	complex_compare
"
	equ	arg1,1*4096
	equ	arg2,2*4096
	equ	arg3,3*4096
"
	bool	fx1_to_fl2_,465
	bool	op_vec,551	from assembly of pl2_operators
"
	bool	aq,600000
"
complex_stuff:
	erase	aq
	switch	17,op
	jump	plus
	jump	minus
	jump	times
	jump	divide
	jump	negate
plus:
	switch	0,code
	jump	plus_HH
	jump	plus_HE
	flipto	plus_HE	actually plus_EH
plus_EE:
plus_EE_cfl1:
	switch	3,type2
	jump	plus_EE_cfl1_fl1_cfl1
	jump	plus_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
plus_EE_cfl1_cfl1:
	switch	3,type3
	flipto	plus_EE_cfl1_fl1_cfl1
	flipto	plus_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
plus_EE_cfl1_cfl1_cfl1:
	bump	arg2
	bump	arg3
	fld	arg2
	fad	arg3
	fst	arg1
	fld	arg2+1
	fad	arg3+1
	fst	arg1+1
	drop	arg2
	drop	arg3
**
plus_EE_cfl1_fl1_cfl1:
plus_EE_cfl1_fl2_cfl1:
	load	arg2
l1:	bump	arg3
	erase	aq
	fad	arg3
	fst	arg1
	fld	arg3+1
	fst	arg1+1
	drop	arg3
**
plus_HE:
plus_HE_cfl1:
	switch	3,type2
	jump	plus_HE_cfl1_fl1_cfl1
	jump	plus_HE_cfl1_fl2_cfl1
	jump	0
	jump	0
plus_HE_cfl1_cfl1:
	switch	3,type3
	jump	plus_HE_cfl1_cfl1_fl1
	jump	plus_HE_cfl1_cfl1_fl2
	jump	0
	jump	0
plus_HE_cfl1_cfl1_cfl1:
	cplalt	arg2
	jump	plus_EE_cfl1_cfl1_cfl1
plus_HE_cfl1_fl1_cfl1:
plus_HE_cfl1_fl2_cfl1:
	compile	arg2
	jump	l1
plus_HE_cfl1_cfl1_fl1:
plus_HE_cfl1_cfl1_fl2:
	cplalt	arg2
	bump	arg2
	fld	arg2
	fad	arg3
	jump	l5
plus_HH:
plus_HH_cfl1:
	switch	3,type2
	jump	plus_HH_cfl1_fl1_cfl1
	jump	plus_HH_cfl1_fl2_cfl1
	jump	0
	jump	0
plus_HH_cfl1_cfl1:
	switch	3,type3
	flipto	plus_HH_cfl1_fl1_cfl1
	flipto	plus_HH_cfl1_fl2_cfl1
	jump	0
	jump	0
plus_HH_cfl1_cfl1_cfl1:
	cplsave	arg3
	jump	plus_HE_cfl1_cfl1_cfl1
plus_HH_cfl1_fl1_cfl1:
plus_HH_cfl1_fl2_cfl1:
	cplalt	arg3
	compile	arg2
	jump	l1
"
minus:
	switch	0,code
	jump	minus_HH
	jump	minus_HE
	jump	minus_EH
minus_EE:
minus_EE_cfl1:
	switch	3,type2
	jump	minus_EE_cfl1_fl1_cfl1
	jump	minus_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
minus_EE_cfl1_cfl1:
	switch	3,type3
	jump	minus_EE_cfl1_cfl1_fl1
	jump	minus_EE_cfl1_cfl1_fl2
	jump	0
	jump	0
minus_EE_cfl1_cfl1_cfl1:
	bump	arg2
	bump	arg3
	fld	arg2
	fsb	arg3
	fst	arg1
	fld	arg2+1
l3:	fsb	arg3+1
	fst	arg1+1
	drop	arg2
	drop	arg3
**
minus_EE_cfl1_fl1_cfl1:
minus_EE_cfl1_fl2_cfl1:
minus_HE_cfl1_fl1_cfl1:
minus_HE_cfl1_fl2_cfl1:
	bump	arg2
	bump	arg3
	fetch	arg2
	erase	aq
	fsb	arg3
	fst	arg1
	fld	=0.0,du
	jump	l3
minus_EE_cfl1_cfl1_fl1:
minus_EE_cfl1_cfl1_fl2:
	bump	arg2
	fld	arg2
	fsb	arg3
l5:	fst	arg1
	fld	arg2+1
	fst	arg1+1
	drop	arg2
**
minus_EH:
minus_EH_cfl1:
	switch	3,type2
	jump	minus_EH_cfl1_fl1_cfl1
	jump	minus_EH_cfl1_fl2_cfl1
	jump	0
	jump	0
minus_EH_cfl1_cfl1:
	switch	3,type3
	jump	minus_EH_cfl1_cfl1_fl1
	jump	minus_EH_cfl1_cfl1_fl2
	jump	0
	jump	0
minus_EH_cfl1_cfl1_cfl1:
	cplalt	arg3
	jump	minus_EE_cfl1_cfl1_cfl1
minus_EH_cfl1_fl1_cfl1:
minus_EH_cfl1_fl2_cfl1:
	cplalt	arg3
	jump	minus_EE_cfl1_fl1_cfl1
minus_EH_cfl1_cfl1_fl1:
minus_EH_cfl1_cfl1_fl2:
	bump	arg2
	compile	arg3
	erase	aq
	fneg	0
	fad	arg2
	jump	l5
minus_HE:
minus_HE_cfl1:
	switch	3,type2
	jump	minus_HE_cfl1_fl1_cfl1
	jump	minus_HE_cfl1_fl2_cfl1
	jump	0
	jump	0
minus_HE_cfl1_cfl1:
	switch	3,type3
	jump	minus_HE_cfl1_cfl1_fl1
	jump	minus_HE_cfl1_cfl1_fl2
	jump	0
	jump	0
minus_HE_cfl1_cfl1_cfl1:
	cplalt	arg2
	jump	minus_EE_cfl1_cfl1_cfl1
minus_HE_cfl1_cfl1_fl1:
minus_HE_cfl1_cfl1_fl2:
	cplalt	arg2
	jump	minus_EE_cfl1_cfl1_fl1
minus_HH:
	cplsave	arg3
	jump	minus_HE
times:
	switch	0,code
	jump	times_HH
	jump	times_HE
	flipto	times_HE		actual times_EH
times_EE:
times_EE_cfl1:
	switch	3,type2
	jump	times_EE_cfl1_fl1_cfl1
	jump	times_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
times_EE_cfl1_cfl1:
	switch	3,type3
	flipto	times_EE_cfl1_fl1_cfl1
	flipto	times_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
times_EE_cfl1_cfl1_cfl1:
	bump	arg2
	bump	arg3
	ldaq	arg2
l9:	eppbp	arg3
	tsx0	ap|op_vec+146
	drop	arg2
	drop	arg3
**
times_EE_cfl1_fl1_cfl1:
times_EE_cfl1_fl2_cfl1:
	bump	arg2
	bump	arg3
	load	arg2
l6:	fmp	arg3
	fst	arg1
	erase	aq
	load	arg2
	fmp	arg3+1
	fst	arg1+1
	drop	arg3
	erase	aq
**
times_HE:
times_HE_cfl1:
	switch	3,type2
	jump	times_HE_cfl1_fl1_cfl1
	jump	times_HE_cfl1_fl2_cfl1
	jump	0
	jump	0
times_HE_cfl1_cfl1:
	switch	3,type3
	jump	times_HE_cfl1_cfl1_fl1
	jump	times_HE_cfl1_cfl1_fl2
	jump	0
	jump	0
times_HE_cfl1_cfl1_cfl1:
	bump	arg3
	cplalt	arg2
	bump	arg2
	if 	c2
	eppbp	arg3
	tsx0	ap|op_vec+145
	drop	arg2
	drop	arg3
**
	ldaq	arg2
	jump	l9
times_HE_cfl1_fl1_cfl1:
times_HE_cfl1_fl2_cfl1:
	bump	arg3
	cplsave	arg2
	jump	l6
times_HE_cfl1_cfl1_fl1:
times_HE_cfl1_cfl1_fl2:
	cplalt	arg2
	flipto	times_EE_cfl1_fl1_cfl1
times_HH:
times_HH_cfl1:
	switch	3,type2
	jump	times_HH_cfl1_fl1_cfl1
	jump	times_HH_cfl1_fl2_cfl1
	jump	0
	jump	0
times_HH_cfl1_cfl1:
	switch	3,type3
	flipto	times_HH_cfl1_fl1_cfl1
	flipto	times_HH_cfl1_fl2_cfl1
	jump	0
	jump	0
times_HH_cfl1_cfl1_cfl1:
	cplsave	arg3
	jump	times_HE_cfl1_cfl1_cfl1
times_HH_cfl1_fl1_cfl1:
times_HH_cfl1_fl2_cfl1:
	cplalt	arg3
	bump	arg3
	cplsave	arg2
	jump	l6
divide:
	switch	0,code
	jump	divide_HH
	jump	divide_HE
	jump	divide_EH
divide_EE:
divide_EE_cfl1:
	switch	3,type2
	jump	divide_EE_cfl1_fl1_cfl1
	jump	divide_EE_cfl1_fl2_cfl1
	jump	0
	jump	0
divide_EE_cfl1_cfl1:
	switch	3,type3
	jump	divide_EE_cfl1_cfl1_fl1
	jump	divide_EE_cfl1_cfl1_fl2
	jump	0
	jump	0
divide_EE_cfl1_cfl1_cfl1:
	bump	arg2
	bump	arg3
	ldaq	arg2
l7:	eppbp	arg3
	tsx0	ap|op_vec+148
	drop	arg2
	drop	arg3
**
divide_EE_cfl1_fl1_cfl1:
divide_EE_cfl1_fl2_cfl1:
	bump	arg2
	bump	arg3
	lda	arg2
	ldq	=0.0,du
	jump	l7
divide_EE_cfl1_cfl1_fl1:
divide_EE_cfl1_cfl1_fl2:
	bump	arg2
	bump	arg3
	load	arg3
	fdi	arg2
	fst	arg1
	erase	aq
	load	arg3
	fdi	arg2+1
	fst	arg1+1
	drop	arg2
**
divide_EH:
	cplsave	arg3
	jump	divide_EE
divide_HE:
divide_HE_cfl1:
	switch	3,type2
	jump	divide_HE_cfl1_fl1_cfl1
	jump	divide_HE_cfl1_fl2_cfl1
	jump	0
	jump	0
divide_HE_cfl1_cfl1:
	switch	3,type3
	jump	divide_HE_cfl1_cfl1_fl1
	jump	divide_HE_cfl1_cfl1_fl2
	jump	0
	jump	0
divide_HE_cfl1_cfl1_cfl1:
	bump	arg3
	cplalt	arg2
	bump	arg2
	if	c2
	eppbp	arg3
	tsx0	ap|op_vec+147
	drop	arg2
	drop	arg3
**
	ldaq	arg2
	jump	l7
divide_HE_cfl1_fl1_cfl1:
divide_HE_cfl1_fl2_cfl1:
	cplsave	arg2
	jump	divide_EE_cfl1_fl1_cfl1
divide_HE_cfl1_cfl1_fl1:
divide_HE_cfl1_cfl1_fl2:
	cplalt	arg2
	jump	divide_EE_cfl1_cfl1_fl1
divide_HH:
	cplsave	arg3
	jump	divide_HE
negate:
	ifnot	atm2
	cplalt	arg2
*
	bump	arg2
	fld	arg2
	fneg	0
	fst	arg1
	fld	arg2+1
	fneg	0
	fst	arg1+1
	drop	arg2
**
"
" table defining complex comparison for Fortran
"
complex_compare:
	switch	0,code
	jump	HH
	jump	HE
	flipto	HE	really EH
EE:
	if	q3
	cmpaq	arg2
**
c1:	load	arg2
	cmpaq	arg3
**
HH:
	cplsave	arg3
HE:
	cplalt	arg2
	jump	c1
	end




		    constant_zero.pl1               10/03/83  1730.5rew 10/03/83  1008.1        5481



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


	/* interim version */

constant_zero: proc(pt) returns(bit(1));

dcl	pt ptr;

	return("0"b);
	end;




		    convert_chars.pl1               10/24/88  1634.0r w 10/24/88  1358.7      302229



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


/* procedure to generate call to convert a character string

   Initial Version: 21 September 1971 by BLW
	Modified: 18 October 1972 by BLW
	Modified:	15 February 1973 by RAB
	Modified:	30 July 1973 by RAB for EIS
	Modified:	26 May 1975 by RAB for assign_round
	Modified:	23 June 1976 by RAB to centralize use of cg_stat$last_call
	Modified:	7 Dec 1976 by RAB to fix 1558
	Modified:	13 Dec 1976 by RAB to fix 1561
	Modified:	14 Dec 1976 by RAB to change blank_on_zero mechanism in inline_picture
	Modified:	27 Jan 1977 by RAB to fix 1572
	Modified:	16 June 1977 by RAB to fix 1631
	Modified:	10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address
	Modified:	4 October 1977 by RAB to fix 1676
	Modified: 31 July 1978 by PCK for unsigned binary	
	Modified: 8 August 1978 by PCK to fix bug 1767
	Modified: 6 September 1978 by PCK to fix bug 1763
	Modified: 24 April 1978 by PCK to implement 4-bit decimal
	Modified:	30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
		See prepare_operand for details.  Also fixes bug 1843 in which
		padded unaligned strings are not padded if they are targets
		of any_to_any_ calls.	*/

convert_chars: proc(left,right,check_size,always_round);

dcl	left ptr,			/* ptr to target */
	right ptr,		/* ptr to source */
	check_size bit(1) aligned,	/* "1"b if size checking */
	always_round bit(1) aligned;	/* "1"b if we should always round */

dcl	cg_stat$save_exp_called bit(1) ext,
	(cg_stat$double_temp,cg_stat$ext_proc_list,cg_stat$cur_block) ptr ext,
	cg_stat$text_pos fixed bin ext;

dcl	(lp,arg(65),arg_pt,p,p1,p2,ap,q,buff(3),s,sym(2)) ptr;
dcl	atomic		bit (1) aligned;
dcl	(comparison,c,check,scaled,varying_target) bit(1),
	adjust bit(36),
	increment bit(1) aligned init("0"b),
	macro fixed bin(15),
	last_freed fixed bin(18),
	(iop,i,j,k,k1,k2,arg_pos,n_args,n,type(2),dtype(2),prec(2),scale(2),length_hold,iscan,tprec,word,nchars) fixed bin;

dcl	c_a entry(fixed bin,fixed bin) returns(ptr),
	(aq_man$lock, aq_man$load_var, load_size$a_or_q) entry(ptr,fixed bin),
	base_man$load_var_and_lock entry(fixed bin,ptr,fixed bin),
	get_reference entry() returns(ptr),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	expmac$one_eis entry(fixed bin(15),ptr),
	generate_constant$char_string entry(char(*) aligned, fixed bin) returns (ptr),
	expmac$many_eis entry(fixed bin(15),ptr,fixed bin),
	create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
	expmac$fill_usage entry(fixed bin,fixed bin),
	need_temp entry(ptr,bit(2) aligned),
	assign_op$length_of_varying entry(ptr,ptr),
	stack_temp$assign_block entry(ptr,fixed bin),
	state_man$unlock entry,
	xr_man$load_const entry(fixed bin,fixed bin),
	xr_man$super_lock entry(fixed bin);
dcl	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
dcl	base_man$load_var entry(fixed bin,ptr,fixed bin),
	adjust_ref_count entry(ptr,fixed bin),
	long_op$extend_stack entry(ptr,fixed bin(15)),
	store$save_string_temp entry(ptr),
	copy_temp entry(ptr) returns(ptr),
	compile_exp entry(ptr),
	compile_exp$save entry(ptr) returns(ptr),
	compile_exp$save_exp entry(ptr) returns(ptr),
	create_list entry(fixed bin) returns(ptr),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	generate_constant entry(bit(*) aligned,fixed bin) returns(ptr);
dcl	compile_link entry(char(*) aligned,bit(18) aligned,fixed bin) returns(fixed bin);
dcl	store_bit_address entry(ptr,ptr,fixed bin(18)),
	expmac entry(fixed bin(15),ptr),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	reserve$declare_lib entry(fixed bin) returns(ptr),
	state_man$flush entry,
	state_man$flush_ref entry(ptr),
	stack_temp$free_temp entry(ptr),
	load entry(ptr,fixed bin);

dcl	(abs,addr,bit,ceil,divide,fixed,float,index,length,max,mod,null,search,string,substr,unspec) builtin;

dcl (	make_desc_mac	init(275),
	ldfx1		init(7),
	prepare_call	init(362),
	alloc_char_temp	init(89),
	move_chars	init(98),
	move_numeric	init(438),
	move_numeric_edit	init(221),
	dtb(2)		init(222,223),
	btd(2)		init(224,225),
	pic_mac(2)	init(417,416),
	conv_mac		init(412),
	zero_cs		init(419),
	zero_4bcs		init(739),
	blank_cs		init(472),
	pic_test		init(278),
	zero_mac(0:1)	init(308,307),
	call_ext_out	init(234)) fixed bin(15) int static;

dcl (	short_work_space	init(28),
	medium_work_space	init(44),
	long_work_space	init(158)) fixed bin int static options(constant);

dcl (	decimal_op	init(175),
	multi_decimal_op	init(176),
	complex_decimal_op	init(182),
	complex_binary_op	init(193)) fixed bin int static;

dcl (	lte		init("10000"b),	/* load table entry */
	insm		init("00001"b),	/* insert table entry 1 multiple */
	mfls		init("00110"b),	/* move with floating sign insertion */
	enf		init("00010"b),	/* end floating suppression */
	mvc		init("01101"b),	/* move source character */
	insb		init("01000"b),	/* insert blank on suppress */
	mvzb		init("00100"b),	/* move with zero suppression and blank replacement */
	mvza		init("00101"b),	/* move with zero suppression and asterisk replacement */
	mflc		init("00111"b)	/* move with floating currency symbol insertion */
			) bit(5) aligned int static;

dcl (	integer_header	init("100000011000100000000010010"b),	/* (lte 3),(blank),(insm 2) */
	scaled_header	init("100000011000100000000010001"b)	/* (lte 3),(blank),(insm 1) */
			) bit(27) int static;

dcl (	mvc_1		init("011010001"b),
	blank_on_zero	init("000110100"b),
	ses_off		init("000110000"b),
	ses_on		init("000111000"b),
	ses_on_bz		init("000111100"b),
	insb_5		init("011000101"b),
	enf_sign		init("000100000"b),
	enf_curr		init("000101000"b),
	enf_sign_bz	init("000100100"b),
	enf_curr_bz	init("000101100"b),
	insp_3		init("010110011"b),
	insn_4		init("010100100"b),
	insa_0		init("010010000"b),
	insb_0		init("010000000"b),
	insb_7		init("010000111"b),
	insb_8		init("010001000"b)) bit(9) int static aligned options(constant);

dcl	blk_on_zero	char(1) aligned based(addr(blank_on_zero));

dcl (	lte_3_blank	init("100000011000100000"b),
	lte_4_blank	init("100000100000100000"b)) bit(18) aligned int static;

dcl (	insn_cr		init("010100000001100011010100000001110010"b),
	insn_db		init("010100000001100100010100000001100010"b)
			) bit(36) aligned int static;

dcl	1 edit_sequence aligned,
	2 micro_op(68) structure unal,
	  3 op_code bit(5) unal,
	  3 data bit(4) unal;

dcl	1 edit_seq based(addr(edit_sequence)) aligned,
	2 header bit(27) unal,
	2 pad bit(9) unal;

dcl	char_image char(nchars) based(addr(edit_sequence)) aligned;

%include pl1_descriptor_type_fcn;
%include cg_reference;
%include symbol;
%include token;
%include operator;
%include list;
%include temporary;
%include data_types;
%include nodes;
%include op_codes;
%include cgsystem;
%include boundary;
%include declare_type;
%include label;
%include mask;

convert_arithmetic:	entry(left,right,check_size,always_round);

	p1, arg(1) = left;
	p2, arg(2) = right;
	right = null;

	call state_man$flush_ref(p1);

/* Initialize by filling in arrays */

	do i = 1 to 2;
	sym(i) = arg(i) -> reference.symbol;
	type(i) = arg(i) -> reference.data_type;
	prec(i) = sym(i) -> symbol.c_dcl_size;
	scale(i) = sym(i) -> symbol.scale;
	end;

	if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;

/* See if we can generate inline sequence */

	if ^ check_size
	then do;
	     if type(1) <= real_fix_bin_2
	     then if scale(1) = 0
	     then if p1 -> reference.aligned_for_store_ref
	     then if abs(scale(2)) <= 31
	     then if type(2) = real_fix_dec | type(2) = real_flt_dec
	     then do;
		if type(2) = real_flt_dec | scale(2) ^= 0
		then do;
		     q = get_temp(11*type(1));
		     call expmac$two_eis((move_numeric),q,p2);
		     end;
		else q = p2;
		call expmac$two_eis((dtb(type(1))),p1,q);
		return;
		end;

	     if type(2) <= real_fix_bin_2
	     then if scale(2) = 0
	     then if abs(scale(1)) <= 31
	     then do;

		if type(1) = real_fix_dec
		then if scale(1) = 0
		     then do;
			q = p1;
			call issue_btd;
			return;
			end;
		     else do;
			q = get_temp(11*type(2));
			call issue_btd;
			macro = move_numeric;
			if always_round
			     then macro = macro + 1;
			call expmac$two_eis(macro,p1,q);
			return;
			end;

		if type(1) = real_flt_dec
		then do;

		     /* float decimal -- we pretend that it is fixed decimal, and then
				     we append an exponent */

		     q = p1;
		     length_hold = p1 -> reference.c_length;

		     if sym(1) -> symbol.unaligned
		     then p1 -> reference.c_length = length_hold - 2;
		     else p1 -> reference.c_length = length_hold - 1;

		     p1 -> reference.data_type = real_fix_dec;
		     if ^ p1 -> reference.shared
			then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
		     call issue_btd;
		     p1 -> reference.c_length = length_hold;
		     p1 -> reference.data_type = real_flt_dec;

		     q = get_reference();
		     q -> reference.symbol = sym(1);
		     q -> reference.qualifier = p1;
		     q -> reference.c_offset = prec(1) + 1;
		     q -> reference.data_type = char_string;
		     q -> reference.defined_ref = "1"b;

		     if sym(1) -> symbol.unaligned
		     then do;
			     q -> reference.units = digit_;
			     q -> reference.c_length = 2;
			     macro = zero_4bcs;
			end;
		     else do;
			     q -> reference.units = character_;
			     q -> reference.c_length = 1;
			     macro = zero_cs;
			end;

		     call expmac$one_eis(macro,q);

		     return;
		     end;

		if type(1) = char_string
		then do;

		     /* We must first convert to fixed decimal and then to character string */

		     prec(2) = fixed(ceil(float(prec(2),23)/3.32) + 1,17);
		     q = get_temp(prec(2));
		     call issue_btd;
		     type(2) = real_fix_dec;
		     arg(2), p2 = q;
		     sym(2) = q -> reference.symbol;
		     end;
		end;

	     if type(1) = char_string
	     then if type(2) = real_fix_dec
	     then if prec(2) >= scale(2)
	     then if scale(2) >= 0
	     then do;
		iscan = 4;

		if scale(2) = 0
		then do;

		     /* decimal integer -- (lte 3),(blank),(insm 2),(mfls p-1),(enf),(mvc 1) */

		     edit_seq.header = integer_header;
		     if prec(2) > 1
			then call fill_seq((mfls),prec(2) - 1);
		     string(micro_op(iscan)) = enf;
		     string(micro_op(iscan+1)) = mvc_1;
		     nchars = iscan + 1;
		     end;

		else do;

		     /* scaled decimal -- (lte 3),(blank),(insm 1),(mfls p-q-1),(enf),
				      (mvc 1),(insb 7),(mvc q) */

		     edit_seq.header = scaled_header;
		     i = prec(2) - scale(2) - 1;
		     if i > 0
			then call fill_seq((mfls),i);
		     string(micro_op(iscan)) = enf;
		     if i < 0
			then string(micro_op(iscan+1)) = insb_8;
			else string(micro_op(iscan+1)) = mvc_1;
		     string(micro_op(iscan+2)) = insb_7;
		     iscan = iscan + 3;
		     call fill_seq((mvc),scale(2));
		     nchars = iscan - 1;
		     end;

		tprec = prec(2) + 3;

		varying_target = p1 -> reference.varying_ref & prec(1) >= tprec;
		if varying_target
		then do;
		     call assign_op$length_of_varying(p1,generate_constant$real_fix_bin_1(tprec));
		     p1 -> reference.c_length = tprec;
		     end;
		else if prec(1) ^= tprec
		     then right, arg(1) = get_str_temp(tprec);
		     else call pad_ref(p1);

		call issue_mvne;

		if varying_target then p1 -> reference.c_length = prec(1);

		return;
		end;
	     end;

/* We cannot generate an inline sequence, so we generate an operator call */

	if arg(1) -> reference.temp_ref
	     then arg(1) -> reference.ref_count = arg(1) -> reference.ref_count + 1;

	if sym(1) -> symbol.packed
	 & (sym(1) -> symbol.bit | sym(1) -> symbol.char)
	     then call pad_ref(p1);


	do i = 2 to 1 by -1;

	/* Protect length exprs + string temps from being prematurely released */

	if ^ arg(i) -> reference.shared
	then do;
	     n = arg(i) -> reference.ref_count;
	     check = n = 1;
	     arg(i) -> reference.ref_count = n + 1;
	     end;
	else check = "0"b;

	/* load and lock pointer register with address of the operand */

	call base_man$load_var_and_lock(2,arg(i),i + 2);

	/* free unnecessary temps */

	if check then call need_temp(arg(i),"11"b);

	/* load a or q with length or scale and precision of operand */

	if type(i) < char_string
	then do;
	     word = prec(i);
	     if scale(i) ^= 0
		then word = word + 262144*scale(i);
	     q = generate_constant$real_fix_bin_1(word);
	     call aq_man$load_var(q,i);
	     end;
	else call load_size$a_or_q(arg(i),i);

	if i = 2
	     then call aq_man$lock(null,2);

	/* load type into an index register */

	dtype (i) = pl1_descriptor_type (gen_attr (sym (i), arg (i)), sym (i) -> symbol.c_dcl_size);

	word = 2 * dtype(i) + fixed(sym(i) -> symbol.packed,1);

	call xr_man$load_const(word,i+5);
	if i = 2
	     then call xr_man$super_lock(7);

	end;


	/* get a pointer to a work_space
		28 words for 9-bit decimal operands
		44 words for 4-bit decimal operands
		156 words for strings		*/

	if max(type(1),type(2)) < char_string
	     then if sym(1) -> symbol.unaligned & sym(1) -> symbol.decimal
		 | sym(2) -> symbol.unaligned & sym(2) -> symbol.decimal
		     then n = medium_work_space;
		     else n = short_work_space;
	     else n = long_work_space;
	q = c_a(n,12);
	q -> reference.ref_count = 2;
	call base_man$load_var(2,q,5);

	/* Unlock the registers */

	call state_man$unlock;

	/* Decide which macro to use */

	i = 2;
	if n = short_work_space
	then if sym(1) -> symbol.real
	     then if sym(2) -> symbol.real
		then i = 0;

	macro = conv_mac + i;

	if always_round
	then macro = macro + 1;
	else if sym(1) -> symbol.float
	     then macro = macro + 1;
	     else if sym(1) -> symbol.char
		then if sym(2) -> symbol.float
		     then macro = macro + 1;

	/* Flush machine state and issue the macro */

	call state_man$flush;

	call expmac$zero(macro);


	/* Lower reference counts originally raised and return */

	do i = 1 to 2;
	if ^ arg(i) -> reference.shared then call adjust_ref_count(arg(i),-1);
	end;

	call adjust_ref_count(q,-1);
	return;


/* Compiles pack or unpack operator */

picture_op:	entry(node_pt);

	p = node_pt;

	p1 = p -> operand(1);

	call state_man$flush_ref(p1);

	if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;

	p2 = p -> operand(2);

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

	/* get picture constant */

	iop = fixed(p -> operator.op_code = unpack,1) + 1;
	arg(1) = p1;
	arg(2) = p2;
	q = arg(iop) -> reference.symbol -> symbol.general;
	if q -> reference.data_type = 0
	     then q = prepare_operand(q,1,atomic);

	/* Try to process inline.  If we cannot, then generate operator call */

	if ^ inline_picture()
	then do;
	     if p1 -> reference.temp_ref
		then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     arg(2) = q;
	     arg(3) = p2;

	     adjust = "0"b;
	     do i = 1 to 3;
		if arg(i) -> reference.temp_ref & ^ arg(i) -> reference.aggregate
		then do;
		     arg(i) -> reference.ref_count = arg(i) -> reference.ref_count + 1;
		     substr(adjust,i,1) = "1"b;
		     end;
		call base_man$load_var_and_lock(2,arg(i),i + 2);
		end;

	     call state_man$unlock;
	     call state_man$flush;

	     call expmac$zero((pic_mac(iop)));


	     if adjust
	     then do i = 1 to 3;
		if substr(adjust,i,1)
		     then call adjust_ref_count(arg(i),-1);
		end;
	     end;

	return;


/*	*************************************************

gen_procedure_call: entry(node_pt,ref,code);

	k = code;

	lp = node_pt;
	n_args = 2 * lp -> operator.number;

	if ref(1) -> reference.temp_ref
	then do;
	     q = ref(1) -> reference.length;
	     if q ^= null
	     then do;
		call long_op$extend_stack(ref(1),alloc_char_temp - char_string + ref(1) -> reference.data_type);
		ref(1) -> reference.ref_count = ref(1) -> reference.ref_count + 1;
		call store$save_string_temp(ref(1));
		increment = "1"b;
		end;
	     else if ref(1) -> reference.shared
		then ref(1) = copy_temp(ref(1));

	     end;

	do i = 1 to lp -> operator.number;
	     j = 2 * i - 1;
	     arg(j) = ref(i);
	     arg(j+1) = get_desc(arg(j));
	     end;

	comparison = "0"b;
	lp = ref(1);
	goto l2;

	************************************************* */

gen_arithmetic_call: entry(node_pt,ref,atom);

dcl	node_pt ptr,		/* points at operator node */
	ref(3) ptr,		/* ref nodes for operands */
	atom(3) bit(1) aligned;	/* "1"b if operand(i) atomic */

	s = ref(2) -> reference.symbol;
	if s -> symbol.decimal
	then do;
	     k1 = complex_decimal_op;
	     k2 = decimal_op;
	     end;
	else k1, k2 = complex_binary_op;

	c, comparison = "0"b;
	lp = node_pt;

	call prepare_operands;

	arg(2) = ref(1);
	if arg(2) ^= null
	then do;
	     c = ref(1) -> reference.symbol -> symbol.complex;
	     arg(3) = get_desc(arg(2));
	     end;
	else do;
	     comparison = "1"b;
	     arg(2), arg(3) = cg_stat$double_temp;
	     end;

	if comparison then j = 0; else j = fixed(substr(lp -> operator.op_code,6,4),4);
	arg(1) = generate_constant$real_fix_bin_1(j);

	arg(4) = ref(2);
	arg(5) = get_desc(arg(4));

	if lp -> operator.op_code = negate then n_args = 5;
	else do;
	     n_args = 7;
	     arg(6) = ref(3);
	     arg(7) = get_desc(arg(6));
	     c = c | arg(6) -> reference.symbol -> symbol.complex;
	     end;

	if c | s -> symbol.complex then k = k1; else k = k2;

	lp = ref(1);
	goto l2;

gen_arithmetic_builtin: entry(node_pt,ref,atom,code);

dcl	code fixed bin;

	lp = node_pt;
	s = ref(1) -> reference.symbol;
	if s -> symbol.decimal | ref(2) -> reference.symbol -> symbol.decimal
	then do;
	     if lp -> operator.number > 3 then k = multi_decimal_op;
	     else if ref(2) -> reference.symbol -> symbol.complex
		 | ref(1) -> reference.symbol -> symbol.complex
		then k = complex_decimal_op;
		else k = decimal_op;
	     end;
	else k = complex_binary_op;

	call prepare_operands;

	arg(1) = generate_constant$real_fix_bin_1(code);

	n_args = 2 * lp -> operator.number + 1;

	do i = 1 to lp -> operator.number-1;
	     j = 2 * i;
	     arg(j) = ref(i);
	     arg(j+1) = get_desc(arg(j));
	     end;

	j = 2 * i;
	if lp -> operator.op_code = round_fun then arg(j), arg(j+1) = ref(i);
	else do;
	     arg(j) = ref(i);
	     arg(j+1) = get_desc(arg(j));
	     end;

	lp = ref(1);
	comparison = "0"b;

l2:	if lp ^= null
	then if lp -> reference.temp_ref
	     then lp -> reference.value_in.storage = "1"b;

	arg_pt = c_a(2*(n_args+1),12);	/* get space for arglist in stack */

	if increment then arg_pt -> reference.ref_count = arg_pt -> reference.ref_count + 1;

	last_freed = arg_pt -> reference.qualifier -> temporary.last_freed;

	arg_pos = arg_pt -> reference.qualifier -> temporary.location;
	ap = c_a(0,4);		/* address sp|0 */

	if arg_pos + 2*n_args + 1 >= 16384
	then do;
	     call xr_man$load_const(arg_pos,1);		/* xr1 is safe because it's not in pool */
	     ap -> reference.address.tag = "001001"b;
	     arg_pos = 0;
	     string(arg_pt -> reference.address) = string(ap -> reference.address);
	     arg_pt -> reference.perm_address = "1"b;
	     end;

	/* put ptrs to arguments into arg list.  If arg is a temporary, we will
	   adjust the reference count up by 1 so that the temporary remains allocated
	   until we return from the call.  If we did not do this and some of the
	   registers had to be saved in storage, one of the arguments might get altered */

	adjust = "0"b;
	do i = 1 to n_args;
	     p = arg(i);
	     if p = null then goto l3;

	     if p -> reference.temp_ref
	     then do;
		p -> reference.ref_count = p -> reference.ref_count + 1;
		substr(adjust,i,1) = "1"b;
		end;

	     ap -> address.offset = bit(fixed(arg_pos + 2*i,15),15);
	     call store_bit_address(ap,p,last_freed);

	     do j = i + 1 to n_args;
		if p = arg(j)
		then do;
		     ap -> address.offset = bit(fixed(arg_pos + 2*j,15),15);
		     call store_bit_address(ap,p,last_freed);
		     arg(j) = null;
		     end;
		end;

l3:	     end;

	buff(1) = arg_pt;
	buff(2) = c_a(n_args*2048,2);
	buff(3) = reserve$declare_lib(k);

	ap = buff(3) -> reference.symbol;
	if ^ ap -> symbol.allocated
	then do;
	     ap -> symbol.location = compile_link(ap -> symbol.token -> token.string,"0"b,0);
	     ap -> symbol.allocated = "1"b;

	     q = create_list(2);
	     q -> element(2) = ap;
	     q -> element(1) = cg_stat$ext_proc_list;
	     cg_stat$ext_proc_list = q;
	     end;

	call expmac$many((prepare_call),addr(buff),2);
	call base_man$load_var(2,buff(3),1);
	call state_man$flush;
	call expmac$zero((call_ext_out));


	if comparison then call expmac((ldfx1),cg_stat$double_temp);

	if adjust = "0"b then return;

	do i = 1 to n_args;
	     if substr(adjust,i,1)
	     then do;
		p = arg(i);
		call adjust_ref_count(p,-1);
		end;
	     end;

	return;



inline_picture:	proc() returns(bit(1) aligned);


/* Attempts to generate inline sequence for picture operations */

dcl	(lab,pp) ptr;
dcl	(picture_pos,type,prec,scale,scalefactor,picture_length,nrands,source_length) fixed bin;
dcl	(pc,sc,drift,zero_sup_char) char(1) aligned;
dcl	table_entries char(8) init(" *+-$,.0") int static;
dcl	(current_micro_op,micro_op_code) bit(5) aligned;
dcl	micro_inst bit(9) aligned;

dcl	zero_suppression	bit(1) aligned;	/* "1"b -- machine is doing zero suppression (ES is OFF) */
dcl	have_drift	bit(1) aligned;	/* "1"b -- a drifting field has been encountered */
dcl	have_suppression	bit(1) aligned;	/* "1"b -- suppression characters or a drifting field have been encountered */
dcl	insertion_on_zero	bit(1) aligned;	/* "1"b -- characters have been inserted which should be blanked
						 if the number is 0 */
dcl	test_zero		bit(1) aligned;	/* zero_suppression & insertion_on_zero */

%include picture_image;
%include picture_types;

	if iop = 2
	then return("0"b);		/* unpack or encode */
	else do;

	     /* pack or edit */

	     call open_picture;

	     if type = char_picture
	     then if verify(substr(pp -> picture_image.chars,1,picture_length),"x") = 0
		then do;
		     call pad_ref(p1);
		     call expmac$two_eis((move_chars),p1,p2);
		     return("1"b);
		     end;
		else return("0"b);

	     if type > real_fixed_picture then return("0"b);

	     if abs(scale) > 31 then return("0"b);

	     /* We have a picture worth trying , so we go through a loop looking at
	        each picture character */

	     have_drift, have_suppression, insertion_on_zero, current_micro_op = "0"b;
	     zero_suppression = "1"b;
	     drift, zero_sup_char = " ";
	     iscan = 1;


	     do picture_pos = 1 to picture_length;
		pc = substr(pp -> picture_image.chars,picture_pos,1);
		go to case(index("9y*z$s+-cd/.,bv",pc));

		/* 9 */

case(1):		call force_significance;
		call put((mvc));
		go to step;

		/* y */

case(2):		if have_drift
		then if zero_suppression
		     then return("0"b);

		if picture_pos > 1
		     then call issue((ses_off));
		call put((mvzb));
		if substr(pp -> picture_image.chars,picture_pos + 1,1) ^= "y"
		     then call issue((ses_on));
		zero_suppression = "0"b;
		go to step;

		/* * */

case(3):		zero_sup_char = "*";
		insertion_on_zero = "1"b;
		call start_suppression;
		call put((mvza));
		go to step;

		/* z */

case(4):		zero_sup_char = " ";
		call start_suppression;
		call put((mvzb));
		go to step;

		/* $ */

case(5):		if pp -> picture_image.drift_character ^= "$"
		then call non_drifting;

		else do;
		     if ^ have_drift
		     then do;
			drift = "$";
			insertion_on_zero,
			have_drift = "1"b;
			call start_suppression;
			end;
		     else call put((mflc));
		     end;

		go to step;

		/* s */

case(6):		if pp -> picture_image.drift_character ^= "s"
		     then call non_drifting;
		     else call drifting_sign;

		/* + */

case(7):		if pp -> picture_image.drift_character ^= "+"
		then do;
		     call issue((insp_3));
		     insertion_on_zero = "1"b;
		     go to step;
		     end;

		call drifting_sign;

		/* - */

case(8):		if pp -> picture_image.drift_character ^= "-"
		then do;
		     call issue((insn_4));
		     go to step;
		     end;

		call drifting_sign;

		/* c */

case(9):		call issue_4((insn_cr));
		picture_pos = picture_pos + 1;
		go to step;

		/* d */

case(10):		call issue_4((insn_db));
		picture_pos = picture_pos + 1;
		go to step;

		/* / . , */

case(11):
case(12):
case(13):
		insertion_on_zero = "1"b;
		call insert_pun;

		/* b */

case(14):		pc = " ";
		call insert_pun;

		/* v */

case(15):		if index(substr(pp -> picture_image.chars,picture_pos+1),"9") = 0
		then call force_significance_bz;
		else if have_drift & index(substr(pp -> picture_image.chars,picture_pos+1),"y") ^= 0
		     then return("0"b);
		     else call force_significance;

step:		if iscan > 64 then return("0"b);
		end;

	     test_zero = zero_suppression & insertion_on_zero;
	     if test_zero & have_drift
		then call force_significance_bz;

	     call pad_ref(p1);

	     call force;
	     nchars = iscan - 1;

	     if test_zero & ^ have_drift
	     then do;
		nchars = nchars + 1;
		char_image = blk_on_zero || substr(char_image,1,nchars-1);
		end;

	     call issue_mvne;

	     end;

	return("1"b);


start_suppression:	proc;

	if ^ have_suppression
	then do;
	     if ^ zero_suppression
	     then do;
		call issue((ses_off));
		zero_suppression = "1"b;
		end;

	     have_suppression = "1"b;
	     end;

	end;


force_significance:	proc;

	if zero_suppression
	then do;
	     if have_drift
	     then do;
		if drift = "$"
		     then micro_inst = enf_curr;
		     else micro_inst = enf_sign;
		call issue(micro_inst);
		have_drift = "0"b;
		end;
	     else call issue(ses_on);

	     zero_suppression = "0"b;
	     end;

	end;


force_significance_bz: proc;

	/* same as force_significance except we blank on zero and leave have_drift on */

	if zero_suppression
	then do;
	     if have_drift
	     then do;
		if drift = "$"
		     then micro_inst = enf_curr_bz;
		     else micro_inst = enf_sign_bz;
		call issue(micro_inst);
		end;
	     else call issue(ses_on_bz);

	     zero_suppression = "0"b;
	     end;

	end;


non_drifting:	proc;

	if have_drift & zero_suppression
	then do;
	     call force_significance;
	     zero_suppression = "1"b;	/* remember that zero_suppression was on */
	     end;

	if picture_pos > 1
	     then call issue((ses_off));	/* for safety, we must have ES OFF */

	if have_suppression & zero_suppression
	then if pc = "$"
	     then micro_inst = enf_curr_bz;
	     else micro_inst = enf_sign_bz;
	else if pc = "$"
	     then micro_inst = enf_curr;
	     else micro_inst = enf_sign;

	call issue(micro_inst);

	zero_suppression = "0"b;

	insertion_on_zero = "1"b;
	go to step;

	end;


drifting_sign:	proc;

dcl	table_change bit(18) aligned;

	if ^ have_drift
	then do;
	     call start_suppression;
	     insertion_on_zero,
	     have_drift = "1"b;
	     drift = pc;
	     if drift ^= "s"
	     then do;
		if drift = "-"
		     then table_change = lte_3_blank;
		     else table_change = lte_4_blank;
		call issue_2(table_change);
		end;
	     end;

	else call put((mfls));
	go to step;

	end;



insert_pun:	proc;

	if zero_suppression
	then if ^ have_suppression
	     then do;
		call issue((ses_on));
		zero_suppression = "0"b;
		end;

	if zero_sup_char = "*"
	     then micro_inst = insa_0;
	     else micro_inst = insb_0;

	if pc = "/"
	then do;
	     call issue(micro_inst);
	     call issue(unspec(pc));
	     end;

	else do;
	     substr(micro_inst,6,4) = bit(fixed(index(table_entries,pc),4),4);
	     call issue(micro_inst);
	     end;

	go to step;

	end;



put:	proc(micro_op_code);

dcl	micro_op_code bit(5) aligned;

	if micro_op_code ^= current_micro_op
	     then call force;

	current_micro_op = micro_op_code;
	nrands = nrands + 1;

	end;



force:	proc;

	if current_micro_op
	     then call fill_seq((current_micro_op),nrands);

	current_micro_op = "0"b;
	nrands = 0;

	end;



issue:	proc(micro_inst);

dcl	micro_inst bit(9) aligned;

	call force;

	string(micro_op(iscan)) = micro_inst;
	iscan = iscan + 1;

	end;



issue_4:	proc(bit36);

dcl	bit36 bit(36) aligned;
dcl	(i,n) fixed bin;
dcl	p ptr;

	n = 4;
	p = addr(bit36);
	go to join;

issue_2:	entry(bit18);

dcl	bit18 bit(18) aligned;

dcl	1 array_st based aligned,
	2 micro_array(4) bit(9) unal;

	n = 2;
	p = addr(bit18);

join:	call force;

	do i = 1 to n;
	     string(micro_op(iscan)) = p -> micro_array(i);
	     iscan = iscan + 1;
	     end;

	end;



open_picture:	proc;

	pp = q -> reference.symbol -> symbol.initial;

	type = pp -> picture_image.type;
	prec = pp -> picture_image.prec;
	scale = pp -> picture_image.scale;
	picture_length = pp -> picture_image.piclength;
	source_length = pp -> picture_image.varlength;
	scalefactor = pp -> picture_image.scalefactor;

	end;


end;



prepare_operands: proc;

dcl	     i fixed bin;

	     do i = 2 to lp -> operator.number;
		if ^ atom(i) then ref(i) = compile_exp$save_exp((lp -> operand(i)));
		end;

	     if ref(1) = null then return;

	     if ^ ref(1) -> reference.allocate
	     then do;
		lp -> operand(1), ref(1) = copy_temp(ref(1));
		ref(1) -> reference.ref_count = 2;
		end;
	     else if ^ cg_stat$save_exp_called
		then if ref(1) -> reference.temp_ref
		     then ref(1) -> reference.ref_count = ref(1) -> reference.ref_count + 1;

	     end;

get_temp:	proc(prec) returns(ptr);

dcl	(length,type,prec) fixed bin;
dcl	p ptr;
dcl	long bit(1) aligned;

	/* Entry point to get a fixed decimal temporary */

	length = prec + 1;
	type = real_fix_dec;
	long = "0"b;
	go to join;

	/* Entry point to get a character string temporary */

get_str_temp:	entry(prec) returns(ptr);

	length = prec;
	long = length > max_short_size(char_string);
	type = char_string;

join:	p = get_reference();
	p -> reference.data_type = type;
	p -> reference.c_length = length;
	p -> reference.long_ref = long;
	p -> reference.temp_ref, p -> reference.allocate, p -> reference.value_in.storage = "1"b;
	call stack_temp$assign_block(p,divide(length + chars_per_word - 1,chars_per_word,17,0));

	return(p);
	end;


issue_btd:	proc;

	if ^ p2 -> reference.aligned_ref
	     then p2 = compile_exp$save(p2);

	call expmac$two_eis((btd(type(2))),q,p2);

	end;


issue_mvne:	proc;

	arg(3) = generate_constant$char_string(char_image,nchars);

	call expmac$many_eis((move_numeric_edit),addr(arg),3);

	end;


pad_ref:	proc(pt);

	/* pad_ref is called with a bit string, character string, or a
	   picture.  If the string is a short aligned string but does not
	   fill an integral number of words, the last word is zeroed. */

dcl	(p1,pt) ptr;

dcl	size fixed bin(24);

	p1 = pt;

	if p1 -> reference.data_type = bit_string
	     then size = p1 -> reference.c_length;
	     else size = p1 -> reference.c_length * bits_per_char;

	if ^ p1 -> reference.long_ref
	then if ^ p1 -> reference.varying_ref
	then if p1 -> reference.aligned_for_store_ref
	then if mod(size,bits_per_word) ^= 0
	then do;
	     if ^ p1 -> reference.shared
		then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     call expmac((zero_mac(fixed(size > bits_per_word,1))),p1);
	     end;
	end /* pad_ref */;



fill_seq:	proc(pop,pn);

dcl	(mop,pop) bit(5) aligned;	/* micro-op */
dcl	(n,pn) fixed bin;		/* number of chars being moved */

dcl	(i,ninst) fixed bin;
dcl	j fixed bin(4);

	n = pn;
	mop = pop;

	ninst = divide(n + 15,16,17,0);

	do i = 1 to ninst;
	string(micro_op(iscan)) = mop;
	if i = ninst
	then do;
	     j = mod(n,16);
	     if j ^= 0
		then micro_op(iscan).data = bit(j,4);
	     end;
	iscan = iscan + 1;
	end;

	end;


get_desc:	     proc(ref) returns(ptr);

dcl	     ref ptr;

dcl	     (p,q,r,s,arg(2)) ptr,
	     (type,scale,desc_type) fixed bin,
	     desc bit(36) int static aligned init("1"b);

	     p = ref;
	     s = p -> reference.symbol;

	     substr(desc,8,1) = s -> symbol.packed;

	     type = p -> reference.data_type;

	     desc_type = pl1_descriptor_type (gen_attr (s, p), s -> symbol.c_dcl_size);

	     substr(desc,2,6) = bit(fixed(desc_type,6),6);

	     if type < char_string
	     then do;
		     substr(desc,25,12) = bit(fixed(s -> symbol.c_dcl_size,12),12);

		     scale = s -> symbol.scale;

		     if scale < 0
		     then scale = scale + 1000000000000b;	/* 2's comp */

		     substr(desc,13,12) = bit(fixed(scale,12),12);

l1:		     return(generate_constant(desc,1));
		end;

	     q = p -> reference.length;
	     if q = null
	     then do;
		substr(desc,13,24) = bit(fixed(p -> reference.c_length,24),24);
		goto l1;
		end;

	     substr(desc,13,24) = "0"b;

	     if q -> node.type = operator_node
		then r = q -> operand(1);
		else r = q;
	     if ^ r -> reference.shared
		then r -> reference.ref_count = r -> reference.ref_count + 1;

	     call compile_exp(q);

	     arg(1) = c_a(1,12);
	     arg(1) -> reference.ref_count = 2;

	     arg(2) = generate_constant(desc,1);
	     call expmac$many((make_desc_mac),addr(arg),2);

	     return(arg(1));
	     end;

/* Generate the correct attribute string from both the symbol node and reference node */

gen_attr:
	procedure (symptr, refptr) returns (bit (36) aligned);

/* parameters */

dcl	symptr ptr;
dcl	refptr ptr;

/* program */

	if ^ refptr -> reference.varying_ref & symptr -> symbol.varying
	then return (substr (string (symptr -> symbol.attributes), 1, 36) & ^(varying_mask));

	return (substr (string (symptr -> symbol.attributes), 1, 36));

	end /* gen_attr */;

	end;




		    copy_temp.pl1                   10/03/83  1730.5rew 10/03/83  1008.1       11790



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

copy_temp: proc(pt) returns(ptr) ;

dcl	(pt,p) ptr;

%include pl1_tree_areas;
%include reference;

	allocate reference in (xeq_tree_area) set(p);
	p -> reference = pt -> reference;

	p -> reference.shared,
	p -> reference.aliasable,
	p -> reference.defined_ref,
	p -> reference.allocated,
	p -> reference.hit_zero,
	p -> reference.fo_in_qual,
	p -> reference.hard_to_load,
	string(p -> reference.info) = "0"b;

	p -> reference.temp_ref,
	p -> reference.allocate = "1"b;

	p -> reference.ref_count = 1;

	return(p);
	end;




		    ctl_char.alm                    10/03/83  1730.5rew 10/03/83  1008.1        5940



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

" segment to define special characters for pl1
"
	name	ctl_char
	segdef	ht
	segdef	nl
	segdef	ff
"
ht:	vfd	o9/11,27/0
nl:	vfd	o9/12,27/0
ff:	vfd	o9/14,27/0
"
	end




		    decimal_op.pl1                  10/03/83  1730.5rew 10/03/83  1008.1      142020



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


/* This procedure compiles decimal arithmetic expressions.

   Initial Version:	28 September 1973 by RAB
	Modified:	9 March 1978 by RAB to fix 1714 (use compile_exp$save_exp instead of $save)
	Modified: 25 April 1979 by PCK to implement 4-bit decimal			*/

decimal_op:	proc(node_pt,refs,atom);

dcl	node_pt ptr,		/* points at operator node */
	refs(3) ptr,		/* ptrs to ref nodes of operands */
	atom(3) bit(1) aligned;	/* ON if operand is atomic */

dcl	(op,p(128),s(128),q,r,imag(2)) ptr;
dcl	op_code bit(9) aligned;
dcl	(i,iop,j,max_scale,min_scale,ninst,scale(128),number,ltemp) fixed bin;
dcl	(macro,mac) fixed bin(15);
dcl	const char(2) aligned;
dcl	(adjust,atomic,all_fixed) bit(1) aligned;
dcl	mask bit(36) aligned;

dcl (	move_rounded	init(439),
	d3mac(0:5)	init(438,440,446,450,456,451),
	d2mac(4)		init(442,448,454,458),
	cplx_ops(3:4)	init(465,466),
	abs_decimal	init(473),
	abs_decimal_4bit	init(737),
	move_numeric	init(438),
	min_dec		init(474),
	max_dec		init(475),
	mod_dec		init(546),
	dvrcdec		init(467)) fixed bin(15) int static;

/* Meaning of iop:
	0	move
	1	add
	2	sub
	3	mult
	4	div
	5 	mult_rounded  */

dcl	1 exponent aligned,		/* exponent of a float dec constant */
	2 pad bit(1) unal,
	2 value fixed bin(7) unal;

dcl	exponent_char char(1) based(addr(exponent)) aligned;

dcl	1 op_table(0:5) aligned int static,
	2 macro fixed bin(15) init(541,542,0,543,544,545),
	2 ltemp fixed bin init(1,1,0,0,80,1);

dcl	(addr,bit,divide,fixed,length,max,min,mod,null,string) builtin;

dcl	adjust_ref_count entry(ptr,fixed bin);
dcl	assign_op$fix_dec_scaled entry(ptr);
dcl	(base_man$update_base,base_man$load_var_and_lock) entry(fixed bin,ptr,fixed bin);
dcl	c_a entry(fixed bin,fixed bin) returns(ptr);
dcl	compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
dcl	compile_exp$save_exp entry(ptr) returns(ptr);
dcl	copy_temp entry(ptr) returns(ptr);
dcl	declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),ptr) returns(ptr);
dcl	expmac entry(fixed bin(15),ptr);
dcl	expmac$many_eis entry(fixed bin(15),ptr,fixed bin);
dcl	expmac$two_eis entry(fixed bin(15),ptr,ptr);
dcl	expmac$one_eis entry(fixed bin(15),ptr);
dcl	generate_constant$relocatable entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
dcl	generate_constant$char_string entry(char(*) aligned,fixed bin) returns(ptr);
dcl	get_imaginary entry(ptr) returns(ptr);
dcl	make_n_addressable entry(ptr,fixed bin);
dcl	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
dcl	state_man$unlock entry;

%include op_codes;
%include operator;
%include symbol;
%include cg_reference;
%include data_types;
%include cgsystem;
%include mask;
%include nodes;
%include machine_state;

	/* Initialize and compile any non-atomic operands */

	ninst = 1;
	op = node_pt;
	op_code = op -> operator.op_code;
	all_fixed = "1"b;
	number = op -> operator.number;

	do i = 1 to number;
	     if ^ atom(i)
		then p(i) = compile_exp$save_exp((op -> operand(i)));
		else p(i) = refs(i);
	     s(i) = p(i) -> reference.symbol;
	     scale(i) = s(i) -> symbol.scale;
	     all_fixed = all_fixed & s(i) -> symbol.fixed;
	     end;

	adjust = ^ (p(1) -> reference.temp_ref | p(1) -> reference.shared);

	/* Handle negate case */

	if op_code = negate
	then do;
	     if s(1) -> symbol.complex
	     then do;
		ninst = 2;

		/* We will multiply by -1 */

use_mult:		iop = 3;
		const = "-1";
		end;
	     else do;
		if ^ p(1) -> reference.temp_ref
		then if compare_expression(p(1),p(2))
		     then go to use_mult;

		/* we will subtract from zero */

		iop = 2;
		const = "+0";
		end;

	     p(3) = p(2);
	     s(3) = s(2);
	     p(2) = generate_constant$char_string(const,2);
	     p(2) -> reference.data_type = real_fix_dec;
	     s(2) = p(2) -> reference.symbol;

	     call issue;
	     return;
	     end;


	/* Split off the builtins */

	if op_code > div then go to builtin;

	/* Now, we handle the other arithmetic cases.  Most code in the external procedure
	   past here deals with ensuring that the scales of the operands fall within the
 	   limits of the 6180's EIS descriptors. */

	if s(1) -> symbol.complex then ninst = 2;

	iop = fixed(op_code,9) - 16;		/* encode operation */

	if iop <= 2
	then do;

	     max_scale = max(scale(1),scale(2),scale(3));
	     min_scale = min(scale(1),scale(2),scale(3));

	     if max_scale <= max_dec_scale & min_scale >= min_dec_scale
	     then call issue;

	     else if max_scale - min_scale <= max_dec_scale - min_dec_scale & all_fixed
		then do;
		     do i = 1 to 3 while(scale(i) ^= max_scale);
		     end;

		     do j = 1 to 3;
			s(j) -> symbol.scale = max_dec_scale - scale(i) + scale(j);
			end;

		     call issue;

		     do j = 1 to 3;
			s(j) -> symbol.scale = scale(j);
			end;
		     end;

		else do;
		     call fix_scales;
		     call issue;
		     end;

	     return;
	     end;

	call fix_scales;

	if s(1) -> symbol.complex
	then if s(2) -> symbol.complex | iop = 4
	     then if s(3) -> symbol.complex
		then do;
		     ltemp = 48;
		     macro = cplx_ops(iop);
		     if ^ s(2) -> symbol.complex
			then macro = dvrcdec;
		     call gen_call;
		     return;
		     end;

	if iop = 4
	then if s(1) -> symbol.float
	     then do;

		/* Due to a hardware deficiency, floating point division must be done into
		   a temporary whose precision is 2 greater than that of the target's, and
		   the result is then moved into the target */

		q = p(1);
		p(1) = decimal_op$get_float_temp(s(1) -> symbol.c_dcl_size + 2,(s(1) -> symbol.complex));

		call issue;

		p(2) = p(1);
		p(1) = q;
		s(2) = p(2) -> reference.symbol;
		iop = 0;

		call issue;
		return;
		end;

	call issue;
	return;



/* Section to do decimal builtins */

builtin:
	if op_code = abs_fun
	then if s(2) -> symbol.real
	     then do;
		iop = 0;
		if adjust
		     then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 1;

		call issue;

		if s(1) -> symbol.unaligned
		then mac = abs_decimal_4bit;
		else mac = abs_decimal;

		call expmac$one_eis(mac,p(1));

		machine_state.indicators = min(machine_state.indicators,-1);
		return;
		end;


	if op_code = round_fun
	then do;

	     /* NOTE:  the following code assumes that the target has the proper pre-
		     cision and scale */

	     scale(3) = 0;
	     call fix_scales;

	     if s(1) -> symbol.complex then ninst = 2;

	     if s(1) -> symbol.float
	     then iop = 0;
	     else do;

		/* generate a multiply rounded by 10**K */

		iop = 5;
		s(1) -> symbol.scale = 0;
		s(2) -> symbol.scale = 0;
		p(3) = p(2);
		s(3) = s(2);
		exponent.pad = "0"b;
		exponent.value = scale(1) - scale(2);
		p(2) = generate_constant$char_string("+1" || exponent_char,3);
		s(2) = p(2) -> reference.symbol;
		end;

	     call issue;

	     if s(1) -> symbol.fixed
	     then do;
		s(1) -> symbol.scale = scale(1);
		s(3) -> symbol.scale = scale(2);
		end;
	     return;
	     end;

	if op_code = min_fun | op_code = max_fun
	then do;
	     call fix_scales;
	     if op_code = min_fun
		then macro = min_dec;
		else macro = max_dec;
	     mac = move_numeric + fixed(s(1) -> symbol.float,1);

	     if adjust
		then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 1;

	     call expmac$two_eis(mac,p(1),p(2));

	     do i = 3 to number;
		if ^ p(i) -> reference.shared
		     then p(i) -> reference.ref_count = p(i) -> reference.ref_count + 1;
		if adjust
		     then p(1) -> reference.ref_count = p(1) -> reference.ref_count + 2;
		call expmac$two_eis(macro,p(1),p(i));
		call expmac$two_eis(mac,p(1),p(i));
		end;

	     if adjust
		then call adjust_ref_count(p(1),-1);
	     refs(2) = p(2);
	     return;
	     end;

	if op_code = trunc_fun
	then do;
	     call fix_scales;
	     if s(1) -> symbol.fixed
	     then do;
		call expmac$two_eis((move_numeric),p(1),p(2));
		return;
		end;
	     end;

	if op_code = complex_fun
	then do;
	     imag(1) = get_imaginary(p(1));
	     macro = move_numeric + fixed(s(1) -> symbol.float,1);
	     call expmac$two_eis(macro,p(1),p(2));
	     call expmac$two_eis(macro,imag(1),p(3));
	     return;
	     end;

	if op_code = real_fun | op_code = imag_fun
	then do;
	     if op_code = real_fun
	     then q = p(2);
	     else do;
		q = get_imaginary(p(2));
		if ^ p(2) -> reference.shared
		     then call adjust_ref_count(p(2),-1);
		end;

	     call expmac$two_eis(move_numeric + fixed(s(1) -> symbol.float,1),p(1),q);

	     return;
	     end;

	if op_code = conjg_fun
	then do;
	     imag(1) = get_imaginary(p(1));
	     imag(2) = get_imaginary(p(2));

	     iop = 0;
	     call issue;

	     p(1) = imag(1);
	     p(2) = imag(2);
	     go to use_mult;
	     end;

/* Anything that reaches here results in calls to pl1_operators_ */

	if op_code ^= sign_fun
	then if op_code ^= abs_fun
	     then call fix_scales;
	     else;
	else do;
	     number = 1;
	     p(1) = p(2);
	     s(1) = s(2);
	     scale(1) = scale(2);
	     end;

	if op_code = pl1_mod_fun
	then do;

	     /* dec_ops_ will get stack extension */

	     ltemp = 0;
	     macro = mod_dec;
	     end;
	else do;
	     iop = fixed(op_code,9) - 144;
	     macro = op_table(iop).macro;
	     ltemp = op_table(iop).ltemp;
	     if ltemp = 1
		then ltemp = divide(p(2) -> reference.c_length + 3,chars_per_word,17,0);
	     end;

	call gen_call;
	return;





/* decimal_op$get_float_temp returns a floating decimal temporary of precision prec which is
   complex is complex is ON */

decimal_op$get_float_temp:	entry(prec,complex) returns(ptr);

dcl	prec fixed bin(24);
dcl	complex bit(1) aligned;

	if complex
	     then mask = complex_mask;
	     else mask = real_mask;

	r = declare_temporary(mask | float_mask | decimal_mask | aligned_mask,(prec),
				0,null);
	r = copy_temp(r);
	r = prepare_operand(r,1,atomic);
	return(r);



/* decimal_op$change_target is called when the target of a decimal arithmetic
   operation has a scale outside of hardware limits to determine if the target
   should be converted to floating point */

decimal_op$change_target:	entry(node_pt) returns(bit(1) aligned);

	op = node_pt;
	op_code = op -> operator.op_code;

	if op_code = add | op_code = sub
	then do;
	     scale(1) = op -> operand(1) -> reference.symbol -> symbol.scale;
	     do i = 2 to 3;
		if op -> operand(i) -> node.type = reference_node
		     then p(i) = op -> operand(i);
		     else p(i) = prepare_operand((op -> operand(i)),1,atomic);
		if p(i) -> reference.symbol -> symbol.float
		     then return("1"b);
		scale(i) = p(i) -> reference.symbol -> symbol.scale;
		end;

	     if max(scale(1),scale(2),scale(3)) - min(scale(1),scale(2),scale(3))
	           <= max_dec_scale - min_dec_scale
		then return("0"b);
	     end;

	return("1"b);



issue:	proc;

dcl	arg(2,3) ptr;
dcl	(i,nrands) fixed bin;
dcl	macro fixed bin(15);
dcl	(use_move,switch_rands) bit(1) aligned;

/* This routine does most of the work of issuing a decimal macro.  It must handle the cases
   concerning complex operands and cases in which the target variable is the same as one
   of the sources */

	use_move = "0"b;

	if iop ^= 0
	     then nrands = 3;
	     else nrands = 2;
	macro = d3mac(iop);

	if ^ p(1) -> reference.temp_ref
	then do i = 2 to mod(iop,2) + 2;

	     /* If the target is not a temporary, it may be one of the sources as well */

	     if compare_expression(p(1),p(i))
	     then do;
		if ^ p(i) -> reference.shared
		     then call adjust_ref_count(p(i),-1);
		if nrands = 2
		then do;
		     if adjust
			then call adjust_ref_count(p(1),-1);
		     return;
		     end;
		nrands = 2;
		macro = d2mac(iop);
		if i = 2
		then do;
		     p(2) = p(3);
		     s(2) = s(3);
		     scale(2) = scale(3);
		     end;
		if iop <= 2
		then if ^ s(2) -> symbol.complex
		     then ninst = 1;
		go to adjust_mac;
		end;
	     end;

adjust_mac:
	macro = macro + fixed(s(1) -> symbol.float,1);

	/* fill in the argument lists */

	do i = 1 to nrands;
	     arg(1,i) = p(i);
	     if ninst > 1
	     then if s(i) -> symbol.complex
		then arg(2,i) = get_imaginary(p(i));
		else if iop = 1
		     then do;
			use_move = "1"b;
			switch_rands = i = 2;
			end;
		     else if iop = 2
			then if i = 3
			     then do;
				use_move = "1"b;
				switch_rands = "0"b;
				end;
			     else do;
				arg(2,i) = generate_constant$char_string("+0",2);
				arg(2,i) -> reference.data_type = real_fix_dec;
				end;
			else do;
			     if ^ p(i) -> reference.shared
				then p(i) -> reference.ref_count = p(i) -> reference.ref_count + 1;
			     arg(2,i) = p(i);
			     end;
	     end;

	/* Now, issue the macro . */

	do i = 1 to ninst;
	     if use_move
	     then if i = ninst
		then do;
		     macro = d3mac(0);
		     nrands = 2;
		     if switch_rands
			then arg(2,2) = arg(2,3);
		     end;
	     call expmac$many_eis(macro,addr(arg(i,1)),nrands);
	     end;

	end;


fix_scales:	proc;

	/* replaces fixed scaled inputs whose scales are outside hardware limits with their
	   floating point equivalents */

	do i = 2 to number;
	     if scale(i) > max_dec_scale | scale(i) < min_dec_scale
	     then do;
		call assign_op$fix_dec_scaled(p(i));
		s(i) = p(i) -> reference.symbol;
		scale(i) = 0;
		end;
	     end;
	end;

gen_call:	proc;

	/* generates a call to pl1_operators_ to do decimal operation */

dcl	(desc,work) ptr;
dcl	clength fixed bin(6);
dcl	one_rand bit(1) aligned;

dcl	1 descriptor(3) aligned,
	2 address	bit(18) unal,
	2 fract	bit(2) unal,
	2 type	bit(4) unal,
	2 dscale	fixed bin(5) unal,
	2 dlength bit(6) unal;

dcl	1 four_bit_descriptor(3) aligned based(addr(descriptor)),	/* EIS 4-bit operand descriptor */
	2 address bit(18) unal,
	2 fract	bit(3) unal,
	2 type	bit(3) unal,
	2 dscale	fixed bin(5) unal,
	2 dlength bit(6) unal;

	/* get a pointer to a work area into the ab */

	if ltemp > 0
	then do;
	     work = c_a(ltemp,12);
	     work -> reference.ref_count = 2;
	     call base_man$load_var_and_lock(2,work,3);
	     end;

	/* make sure bp is uninvolved in addressing code for the decimal operands */

	call base_man$update_base(0,null,1);

	/* make all decimal operands addressable without any tags */

	call make_n_addressable(addr(p),- number);

	/* now build a string of descriptors for use by the operator */

	do i = 1 to number;
	     descriptor(i).address = string(p(i) -> reference.address);
	     if s(i) -> symbol.unaligned
	     then do;
		     four_bit_descriptor(i).fract = bit(fixed(p(i) -> reference.c_f_offset,3),3);
		     four_bit_descriptor(i).type = "10"b || s(i) -> symbol.fixed;
		end;
	     else do;
		     descriptor(i).fract = bit(fixed(p(i) -> reference.c_f_offset,2),2);
		     descriptor(i).type = "000"b || s(i) -> symbol.fixed;
		end;
	     descriptor(i).dscale = - scale(i);
	     clength = p(i) -> reference.c_length;
	     if s(i) -> symbol.complex
		then clength = divide(clength,2,6,0);
	     descriptor(i).dlength = bit(clength,6);
	     end;

	desc = generate_constant$relocatable(addr(descriptor),number,"0"b);

	/* generate the operator call */

	call expmac(macro,desc);

	/* unlock the registers and decrement the operands' reference counts */

	call state_man$unlock;

	if ltemp > 0
	     then call adjust_ref_count(work,-1);

	one_rand = number = 1;

	do i = 1 to number;
	     if ^ p(i) -> reference.shared
	     then if ^ p(i) -> reference.temp_ref | i > 1 | one_rand
		then call adjust_ref_count(p(i),-1);
	     end;

	end;

end;




		    e_v.pl1                         10/03/83  1730.5rew 10/03/83  1008.1      123489



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


/* Procedure to encode a variable or expression for use in symbol table 

   Initial Version:  7 May 1970 by BLW
	Modified:  4 September 1970 by BLW
	Modified: 16 February 1972 by BLW for Version II
	Modified:  2 July 1972 by BLW for new encoding scheme
	Modified: 26 September 1972 by BLW for std object segments
	Modified: 21 January 1973 by BLW for controlled storage
	Modified: 16 Nov 1979 by PCK to fix 1858 */

e_v:	proc(symb,coded_value,var,const,code,reloc);

dcl	symb	ptr,		/* points at symbol node */
	coded_value fixed bin,	/* where to store coded value */
	var	ptr,		/* variable part of value */
	const	fixed bin,	/* constant part of value */
	code	fixed bin,	/* type of value */
	reloc	bit(36) aligned;	/* relocation (output) */

dcl	(cg_stat$cur_block,cg_stat$encoded_values,cg_stat$cur_statement,
	 cg_stat$ev_qual,cg_stat$last_encoded,cg_stat$text_base,
	 cg_stat$dummy_block,cg_stat$dummy_statement,cg_stat$first_ref,
	 cg_stat$next_ref) ptr ext,
	 cg_stat$in_thunk bit(1) ext,
	(cg_stat$text_pos,cg_stat$cur_level) fixed bin(18) ext;

dcl	(vp,cvp,ap,bp,rp,sp,qp,xp,s1,s2,p,arg(2)) ptr,
	dl fixed bin(6),
	(lab,atomic) aligned bit(1),
	macro fixed bin(15),
	delta fixed bin(18),
	n fixed bin(18),
	fb_18 fixed bin(18) based;

dcl	compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
dcl	(compile_exp,compile_statement) entry(ptr),
	expmac entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15)),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	load entry(ptr,fixed bin),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	base_man$load_arg entry(fixed bin,ptr) returns(bit(3) aligned),
	state_man$flush entry,
	make_mod entry(fixed bin(17),fixed bin) returns(fixed bin(18)),
	token_to_binary entry(ptr) reducible returns(fixed bin),
	c_a entry(fixed bin,fixed bin) returns(ptr);

dcl	fix_bin fixed bin based;

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

dcl	1 value		aligned based(cvp),
	2 code		unal bit(6),
	2 n1		unal bit(6),
	2 n2		unal bit(6),
	2 offset		unal bit(18);

dcl	1 lxl_ins		aligned based,
	2 stack_size	unal bit(18),
	2 rhs		unal bit(18);

dcl (	adfx1		init(19),
	load_pt_reg	init(172),
	end_ev_label	init(322),
	beg_ev_proc	init(318),
	end_ev_proc	init(319)) fixed bin(15) int static;

%include pl1_tree_areas;
%include reference;
%include operator;
%include symbol;
%include block;
%include statement;
%include ev_node;
%include nodes;
%include op_codes;
%include boundary;
%include token;
%include token_types;
%include reloc_lower;

/*		Execution begins ... */

	lab = "0"b;

start:	cvp = addr(coded_value);
	delta, coded_value = 0;
	reloc = (36)"0"b;

	s1 = var;
	if s1 -> node.type = statement_node
	then do;

	     /* have a difficult expression which required additional statements to
	        be generated.  The original expression we encoded is the root of the
	        last statement node in the chain */

	     s2 = s1;
	     do while(s2 -> statement.next ^= null);
		s2 = s2 -> statement.next;
		end;

	     vp = s2 -> statement.root;
	     s2 -> statement.root = null;
	     goto diff;
	     end;

	/* have a (relatively) easy expression */

	s1 = null;
	vp = var;

	if vp -> node.type ^= operator_node then goto chk;

	if vp -> op_code = bit_pointer
	then do;
pf:	     value.code = "100011"b;
	     value.offset = bit(fixed(const + delta,18),18);
	     return;
	     end;

	if vp -> op_code = add
	then do;

	     /* check for constant plus bit pointer operator */

	     xp = vp -> operand(3);
	     if xp -> node.type ^= reference_node then goto chk;

	     sp = xp -> reference.symbol;
	     if ^ sp -> symbol.constant then goto chk;

	     ap = vp -> operand(2);
	     if ap -> node.type ^= operator_node then goto chk;
	     if ap -> op_code ^= bit_pointer then goto chk;

	     delta = sp -> symbol.initial -> fb_18;
	     goto pf;
	     end;

	if vp -> op_code = desc_size
	then do;

	     /* check for size = reference to incoming descriptor */

	     xp = vp -> operand(2);
	     if xp -> node.type ^= reference_node then goto chk;

	     qp = xp -> reference.qualifier;
	     if qp = null
	     then do;

		/* check for controlled descriptor */

		ap = xp -> reference.symbol;
		if ^ ap -> symbol.arg_descriptor then goto chk;
		if ^ ap -> symbol.controlled then goto chk;

		value.code = "101101"b;

		if ap -> symbol.internal then reloc = rc_a_is18;
		else do;
		     value.n1 = "000001"b;
		     reloc = rc_a_lp18;
		     end;

		vp = xp;
		ap = ap -> symbol.descriptor;
		goto l5;
		end;

	     if qp -> node.type ^= operator_node then goto chk;
	     if qp -> op_code ^= param_desc_ptr then goto chk;

	     value.code = "101011"b;
	     value.n1 = bit(fixed(cg_stat$cur_level - qp -> operand(3) -> block.level,6),6);
	     value.n2 = bit(fixed(qp -> operand(2) -> reference.symbol -> symbol.initial -> fix_bin,6),6);
	     value.offset = bit(fixed(xp -> reference.c_offset,18),18);
	     return;
	     end;

	goto hard;

chk:	if const ^= 0 then goto hard;

	if vp -> node.type = token_node
	then if vp -> token.type = dec_integer
	     then do;
		coded_value = token_to_binary(vp);
		reloc = "0"b;
		return;
		end;

	/* have a reference node, we can encode its value if its
	   word offset is constant */

easy:	if vp -> reference.units ^= 0
	then if vp -> reference.units ^= word_
	     then goto hard;

	if vp -> reference.offset ^= null then goto hard;

	rp = vp -> reference.qualifier;
	if rp ^= null then goto based;

	ap = vp -> reference.symbol;

	if vp -> reference.defined_ref then ap = ap -> symbol.initial;

	if ap -> symbol.constant & ap -> symbol.internal
	then do;
	     if ^ ap -> symbol.fixed then goto hard;
	     if ^ ap -> symbol.binary then goto hard;
	     if ^ ap -> symbol.real then goto hard;
	     if ap -> symbol.c_word_size ^= 1 then goto hard;

	     coded_value = ap -> symbol.initial -> fix_bin;
	     reloc = "0"b;
	     return;
	     end;

	bp = ap -> symbol.block_node;
	dl = cg_stat$cur_level - bp -> block.level;

	if ap -> symbol.auto
	then do;
	     if dl > 63 then goto hard;
	     value.n1 = bit(dl,6);
	     value.code = "100000"b;
l1:	     value.offset = bit(fixed(ap -> symbol.location + vp -> reference.c_offset,18),18);
	     value.n2 = "000000"b;
	     return;
	     end;

	if ap -> symbol.parameter
	then do;
	     if dl > 63 then goto hard;
	     if ap -> symbol.location > 63 then goto hard;

	     value.n1 = bit(dl,6);
	     value.n2 = bit(fixed(ap -> symbol.location,6),6);
	     value.offset = bit(fixed(vp -> reference.c_offset,18),18);
	     value.code = "101001"b;
	     return;
	     end;

	if ap -> symbol.controlled
	then do;
	     if ap -> symbol.arg_descriptor then value.code = "101110"b;
	     else value.code = "101111"b;

	     if ap -> symbol.internal then reloc = rc_a_is18;
	     else do;
		value.n1 = "000001"b;
		reloc = rc_a_lp18;
		end;

	     goto l5;
	     end;

	if ^ ap -> symbol.static then goto hard;

	if ap -> symbol.internal
	then do;
	     value.code = "100001"b;
	     reloc = rc_a_is18;
	     goto l1;
	     end;

	value.code = "100010"b;
	reloc = rc_a_lp18;

	/* cannot encode if word offset is not positive and less than 64 */

l5:	if vp -> reference.c_offset < 0 then goto hard;
	if vp -> reference.c_offset > 63 then goto hard;

	value.n2 = bit(fixed(vp -> reference.c_offset,6),6);
	value.offset = bit(fixed(ap -> symbol.location,18),18);

	return;

	/* have a based variable, we can encode it if offset is positive
	   and less than 64 */

based:	if vp -> reference.c_offset < 0 then goto hard;
	if vp -> reference.c_offset > 63 then goto hard;

	/* use special code if qualifier is the param ptr node created by
	   prepare_symbol_table (a pointer to it was stored in block.context).
	   In this case, we had a refer option */

	if rp -> reference.qualifier = cg_stat$dummy_block -> block.context
	then do;
	     value.code = "100111"b;
	     goto l3;
	     end;

	/* check for param_ptr operator as qualifier */

	if rp -> node.type = operator_node
	then do;
	     if rp -> op_code = param_ptr then value.code = "101001"b;
	     else if rp -> op_code = param_desc_ptr then value.code = "101100"b;
		else goto hard;

	     dl = cg_stat$cur_level - rp -> operand(3) -> block.level;
	     if dl > 63 then goto hard;

l4:	     value.n1 = bit(dl,6);
	     value.n2 = bit(fixed(rp -> operand(2) -> reference.symbol -> symbol.initial -> fix_bin,6),6);
	     value.offset = bit(fixed(vp -> reference.c_offset,18),18);
	     return;
	     end;

	/* the ptr must have a constant offset and must not be itself based */

	if rp -> reference.offset ^= null then goto hard;

	ap = rp -> reference.qualifier;
	if ap ^= null
	then do;
	     if ap -> node.type ^= operator_node then goto hard;
	     if ap -> op_code ^= param_ptr then goto hard;
	     if rp -> reference.c_offset ^= 0 then goto hard;

	     dl = cg_stat$cur_level - ap -> operand(3) -> block.level;
	     if dl > 63 then goto hard;

	     /* we can handle the case of a variable based on a ptr parameter */

	     value.code = "101010"b;
	     rp = ap;
	     goto l4;
	     end;

	ap = rp -> reference.symbol;
	bp = ap -> symbol.block_node;
	dl = cg_stat$cur_level - bp -> block.level;

	if ap -> symbol.auto
	then do;
	     if dl > 63 then goto hard;
	     value.code = "100100"b;
	     value.n1 = bit(dl,6);

l2:	     value.offset = bit(fixed(ap -> symbol.location + rp -> reference.c_offset,18),18);
l3:	     value.n2 = bit(fixed(vp -> reference.c_offset,6),6);
	     return;
	     end;

	if ^ ap -> symbol.static then goto hard;

	if ap -> symbol.internal
	then do;
	     value.code = "100101"b;
	     reloc = rc_a_is18;
	     goto l2;
	     end;

	/* the word offset must be positve and less than 64 for ext static ptr */

	if rp -> reference.c_offset < 0 then goto hard;
	if rp -> reference.c_offset > 63 then goto hard;

	value.code = "100110"b;
	reloc = rc_a_lp18;
	value.n1 = bit(fixed(rp -> reference.c_offset,6),6);
	value.offset = bit(fixed(ap -> symbol.location,18),18);
	goto l3;

	/* have an expression or a variable that cannot be encoded, we
	   must generate an internal procedure to evaluate the expression,
	   so first search to see if we have already generated a procedure
	   to evaluate an equivalent expression */

hard:	p = cg_stat$encoded_values;
	do while(p ^= null);

	     if p -> ev_node.block ^= cg_stat$cur_block then goto next;

	     if p -> ev_node.const ^= const then goto next;

	     if ^ compare_expression(p -> ev_node.exp,vp) then goto next;

	     /* we found an equivalent expression evalutated earlier */

	     allocate ev_equiv in(tree_area) set(xp);
	     xp -> ev_equiv.next = p -> ev_node.equiv;
	     p -> ev_node.equiv = xp;

	     if symb = null then xp -> ev_equiv.name = null;
	     else xp -> ev_equiv.name = symb -> symbol.token;
	     xp -> ev_equiv.code = code;

	     value.offset = bit(p -> ev_node.first,18);
	     goto hd;

next:	     p = p -> ev_node.next;
	     end;

	/* have no equivalent expression, we must evaluate this one */

diff:	cg_stat$dummy_block -> block.father = cg_stat$cur_block;
	bp, cg_stat$cur_block = cg_stat$dummy_block;
	bp -> block.level, cg_stat$cur_level = cg_stat$cur_level + 1;
	bp -> block.no_stack = "0"b;

	call state_man$flush;

	bp -> block.last_auto_loc = 64;

	bp -> block.free_temps(1),
	bp -> block.free_temps(2),
	bp -> block.free_temps(3) = null;

	value.offset = bit(cg_stat$text_pos,18);
	ap = addrel(cg_stat$text_base,cg_stat$text_pos);

	call expmac$zero((beg_ev_proc));

	cg_stat$in_thunk = "1"b;
	do while(s1 ^= null);
	     call compile_statement(s1);
	     s1 = s1 -> statement.next;
	     end;
	cg_stat$in_thunk = "0"b;

	cg_stat$cur_statement = cg_stat$dummy_statement;
	if symb ^= null
	     then string(cg_stat$cur_statement -> statement.source_id) = string(symb -> symbol.source_id);

	xp = prepare_operand(vp,1,atomic);

	if lab
	then do;
	     macro = end_ev_label;
	     call expmac((load_pt_reg),xp);
	     end;
	else do;
	     macro = end_ev_proc;
	     if atomic then call load(xp,0);
	     else do;
		cg_stat$cur_statement -> statement.root = vp;
		call compile_exp(vp);
		end;
	     end;

	if const ^= 0 then call expmac((adfx1),c_a(const,2));

	xp = c_a(4,4);			/* sp|4 */
	xp -> address.base = base_man$load_arg(0,bp);
	xp -> address.tag = "010000"b;	/* lp|4,* */
	call expmac(macro,xp);

	ap -> lxl_ins.stack_size = bit(make_mod(bp -> block.last_auto_loc,16),18);

	allocate ev_node in(tree_area) set(xp);
	if cg_stat$encoded_values = null
	then cg_stat$encoded_values = xp;
	else cg_stat$last_encoded -> ev_node.next = xp;
	cg_stat$last_encoded = xp;
	xp -> ev_node.next = null;

	if symb = null then xp -> ev_node.name = null;
	else xp -> ev_node.name = symb -> symbol.token;

	xp -> ev_node.exp = vp;
	xp -> ev_node.equiv = null;
	xp -> ev_node.const = const;
	xp -> ev_node.code = code;
	xp -> ev_node.first = fixed(value.offset,18);
	xp -> ev_node.last = cg_stat$text_pos;

	cg_stat$next_ref = cg_stat$first_ref;

	cg_stat$cur_level = cg_stat$cur_level - 1;
	xp -> ev_node.block, cg_stat$cur_block = bp -> block.father;

hd:	value.code = "101000"b;
	reloc = rc_a_t;

	return;

e_v$l_v:	entry(symb,coded_value,var,const,code,reloc);

	/* this entry is called to encode a label or format value */

	lab = "1"b;
	goto start;

	end;




		    eval_exp.pl1                    10/03/83  1730.5rew 10/03/83  1008.2       44136



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


/* This procedure evaluates an expression used as a size or offset.
   If the operator node does not have a reference count on its temporary,
  a copy is made of the temporary with a reference count of 2 to
  replace the original temporary.

   Initial Version:  5 September 1971 by BLW
	Modified: 15 July 1972 by BLW
	Modified:	2 August 1973 by RAB to eliminate operator copying 
	Modified:	15 October 1975 by RAB to use xrs for some assignments
	Modified:	26 July 1976 by RAB to fix 1505
	Modified:	9 March 1977 by RAB to eliminate mod_bit, etc. dead code
	Modified:	9 April 1977 by RAB to eliminate mod_word
	Modified:	14 February 1978 by RAB to extend power of use_xr
	Modified:	4 August 1978 by RAB to account for unsigned binary in use_xr	*/

eval_exp: proc(pt,no_xr) returns(ptr) ;

dcl	pt ptr,			/* points at the expression */
	no_xr bit(1) aligned;	/* "1"b  - don't use xrs for assignments */

dcl	(cg_stat$first_op,cg_stat$next_op,cg_stat$cur_block,cg_stat$cur_statement) ptr ext;

dcl	cg_stat$optimize bit(1) aligned ext static;

dcl	(sp,tp,xp) ptr,
	(atomic,copy) bit(1) aligned,
	op_code bit(9) aligned,
	xr fixed bin;

dcl	(copy_temp,check_o_and_s) entry(ptr) returns(ptr),
	create_list entry(fixed bin) returns(ptr),
	error entry(fixed bin,ptr,ptr),
	compile_exp entry(ptr),
	call_op entry(ptr) returns(ptr),
	length_op entry(ptr) returns(ptr),
	assign_desc_op entry(ptr) returns(ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	xr_man$load_any_var entry(ptr,fixed bin,fixed bin),
	xr_man$update_xr entry(ptr,fixed bin);

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

%include reference;
%include symbol;
%include operator;
%include nodes;
%include op_codes;
%include cgsystem;
%include boundary;
%include data_types;

	xp = pt;

	if xp = null then goto done;

	if xp -> node.type = operator_node
	then do;
	     op_code = xp -> operator.op_code;

	     if op_code = std_call
	     then do;
		if ^ xp -> operand(1) -> reference.evaluated
		then do;
		     tp = call_op(xp);
		     tp -> reference.value_in.storage = "1"b;
		     end;
done:		return(xp);
		end;

	     if op_code = desc_size
	     then do;
		tp = check_o_and_s(xp);
		if tp ^= null
		then do;
		     return(tp);
		     end;
		end;

	     tp = xp -> operand(1);
	     if tp = null
	     then do;
		call error(317,cg_stat$cur_statement,null);
		goto done;
		end;

	     if tp -> reference.evaluated
		then go to done;

	     if op_code = assign
	     then do;
		sp = xp -> operand(2);
		if sp -> node.type = reference_node
		then if sp -> reference.symbol -> symbol.arg_descriptor
		     then if tp -> reference.symbol -> symbol.temporary
			then do;

			     /* eliminate assignment of descriptor to temporary */

			     xp = assign_desc_op(xp);
			     go to done;
			     end;
			else;
		     else if cg_stat$optimize
			then if sp -> reference.symbol -> symbol.packed
			then if ^ no_xr
			then if sp -> reference.ref_count <= 1 | sp -> reference.aligned_ref
			then if use_xr()
			     then go to done;
		end;

	     if op_code = length_fun
	     then do;
		xp = length_op(xp);
		go to done;
		end;

	     if tp -> reference.shared
	     then do;
		xp -> operand(1), tp = copy_temp(tp);
		tp -> reference.ref_count = 2;
		end;
	     else if tp -> reference.temp_ref
		then tp -> reference.ref_count = tp -> reference.ref_count + 1;

	     call compile_exp(xp);

	     end;

	else xp = prepare_operand(xp,1,atomic);


	goto done;


use_xr:	     proc returns(bit(1) aligned);

	     sp = prepare_operand(sp,1,atomic);

	     if sp -> reference.c_length = bits_per_half | sp -> reference.aligned_ref
	     then if ^ sp -> reference.hard_to_load
	     then if sp -> reference.data_type = real_fix_bin_1
		   & (tp->reference.symbol->symbol.c_dcl_size = default_fix_bin_p + fixed(sp->reference.symbol->symbol.unsigned,1)
		     | sp -> reference.aligned_ref)
		 | sp -> reference.data_type = bit_string
		   & ^ sp -> reference.aligned_ref
		   & tp -> reference.symbol -> symbol.c_dcl_size = bits_per_half
	     then if sp -> reference.units = word_ | mod(sp -> reference.c_offset,bits_per_half) = 0
	     then do;
		tp = prepare_operand(tp,1,atomic);
		if tp -> reference.shared
		     then xp -> operand(1), tp = copy_temp(tp);
		call xr_man$load_any_var(sp,xr,0);
		call xr_man$update_xr(tp,xr);
		tp -> reference.evaluated = "1"b;
		return("1"b);
		end;

	     return("0"b);
	     end;


	end;




		    exp_op.pl1                      10/03/83  1730.5rew 10/03/83  1008.3       21825



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


/* program to generate code for x ** n where n is a constant integer > 1

   Method used is left-to-right binary scan of n,
	See Knuth, Volume 2, page 399

   Initial Version: 3 June 1971 by BLW
	Modified: 5 July 1972 by BLW	*/

exp_op:	proc(npx,refs,atom);

dcl	npx ptr,		/* points at operator node */
	refs(3) ptr,		/* refs for operands */
	atom(3) bit(1) aligned;	/* "1"b if operand(i) is atom */

dcl	node_pt ptr defined (npx),
	ref(3) ptr defined (refs);

dcl	(p,q) ptr,
	(type,square_macro,mpy_macro,n) fixed bin(15),
	fw bit(36) aligned;

dcl	load entry(ptr,fixed bin);
dcl	m_a entry(ptr,bit(2) aligned);
dcl	compile_exp$save entry(ptr) returns(ptr),
	get_reference entry returns(ptr);
dcl	state_man$erase_reg entry(bit(19) aligned);
dcl	expmac entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15));

dcl	(index,substr) builtin;

dcl	full_word bit(36) aligned based;

dcl (	square_fx1	init(403),
	mpy_mac(4)	init(25,0,31,32)) fixed bin(15) int static;

%include cgsystem;
%include reference;
%include symbol;
%include operator;

	/* following prevents use of A and Q as instruction modifiers by forcing
	   into storage any result held in these registers */

	call state_man$erase_reg("11"b);

	if atom(2) then call load(ref(2),0); else ref(2) = compile_exp$save((node_pt -> operand(2)));

	p = get_reference();
	p -> reference = ref(2) -> reference;
	if p -> reference.no_address then call m_a(p,"0"b);
	p -> reference.shared, p -> reference.perm_address = "1"b;

	if atom(2) then q = p; else q = ref(2);

	type = p -> reference.data_type;
	square_macro = square_fx1 - 1 + type;
	mpy_macro = mpy_mac(type);

	fw = ref(3) -> reference.symbol -> symbol.initial -> full_word;

	call expmac(mpy_macro,q);

	n = index(fw,"1"b) + 1;

loop:	if substr(fw,n,1) then call expmac(mpy_macro,p);

	n = n + 1;
	if n <= bits_per_word
	then do;
	     call expmac$zero(square_macro);
	     goto loop;
	     end;

	end;




		    expmac.pl1                      10/03/83  1730.5rew 10/03/83  1008.3      500148



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


/* macro expander for pl/1.

  expmac$many expands a macro with many arguments.

   expmac$one expands a macro with a single argument.  m_a is called
   if the argument is not addressable already.  the parameter 'double'
   being non-zero means that the macro argument represents a double
   length operand.  expmac$one will expand macro+1 if the operand is
   not on an even boundary and macro+2 if it is on an even boundary.

   expmac$abs is used to append a block of words to the output buffer.

   expmac$eis is used to expand a macro consisting of an EIS instruction where
   the result operand is in cg_stat$eis_temp and the other operand is passed as an
   argument to expmac$eis.

   expmac$two_eis is used to expand a macro consisting of an EIS instruction that has
   two operands, both of which are supplied in the argument list.

   expmac$many_eis expands a macro consisting of an EIS instruction and takes all its
   operands from its argument list.

   Initial Version: 10 October, 1968 by BLW
	Modified:  6 April, 1971 by BLW for Version II
	Modified: 26 October 1972 by BLW	
	Modified: 14 February 1973 by RAB
	Modified:	29 May 1973 by RAB for EIS
	Modified:	23 Feb 1976 by RAB to fix 1469
	Modified:	1 Dec 1976 by RAB for -long_profile
	Modified:	6 Mar 1977 by RAB to opt multiply of constants
	Modified:	25 Mar 1977 by RAB to fix 1599
	Modified: 5 May 1977 by SHW for new pl1_operator_names_
	Modified:	15 July 1977 by RAB to fix 1646
	Modified:	6 December 1977 by RAB to fix 1693
	Modified:	15 January 1978 by RAB to fix 1698
	Modified:	8 March 1978 by RAB to fix 1713
	Modified:	11 August 1978 by RAB to change handling of aggregate temp ref counts by expmac$eis and friends
	Modified:	21 August 1978 by RAB to increase obj seg limit from 32K to 128K
	Modified:	25 August 1978 by RAB to help fix 1780
	Modified: 25 April 1979 by PCK to implement 4-bit decimal
	Modified:	18 July 1979 by RAB to fix 1842 (ERR 313 when comparing
		entry vars).  Method of counting down ref counts in put_word
		changed to fix the bug.
	Modified 791029 by PG to make changes so that fix for 1744 does not degrade
		code for abs(floating_expr). Fixes long-outstanding problem with way
		machine_state.indicators is set for instructions that modify both the A and Q.
	Modified 800109 by PG to fix bug 1861 in above change involving pl1_operators_ & handling of indicators.
          Modified 8/19/81 by EBush to keep peepholer from removing what it thinks
                    are no-ops (eppn pn|0) but are really sites for binder relocation. (Bug 2084)
*/

/* format: style3 */
expmac:
     proc (macro, arg_pt);

/* parameters */

dcl	PR		fixed bin (3);
dcl	macro		fixed bin,		/* id of macro to be expanded */
	arg_pt		ptr;			/* ptr to single arg of macro */

/* builtins */

dcl	(abs, addr, addrel, binary, bit, divide, fixed, hbound, lbound, mod, null, ptr, string, substr)
			builtin;

/* automatic */

dcl	(arg_blk, p, q, q2, mac_pt, ref_pt, output_pt, sym_use_pt, reloc_pt, text_pt)
			ptr,
	b72		bit (72) aligned,
	(addressable, found, hold_perm_address)
			bit (1) aligned,
	made_perm_addressable
			bit (1) aligned init ("0"b),
	mop		fixed bin (10),
	(s1, s2, n)	fixed bin,
	inst		bit (10) aligned,
	rhs		bit (18) aligned,
	erase		bit (19) aligned,
	not_constant	bit (1),
	eis		bit (1) aligned init ("0"b),
	count_arg		bit (7) aligned,
	constant_value	fixed bin (18),
	(fw, const_string)	bit (36) aligned,
	(i, j, k, num_args, text_pos, first_pos, size, shift_amount, inc, offset)
			fixed bin (18),
	k71		fixed bin (71),
	mac		fixed bin;

dcl	1 info		aligned like instruction_info_$instruction_info;

/* entries */

dcl	cg_error		entry (fixed bin, fixed bin),
	constant_zero	entry (ptr) returns (bit (1)),
	expmac		entry (fixed bin (15), ptr),
	c_a		entry (fixed bin (18), fixed bin (18)) returns (ptr),
	error		entry (fixed bin, ptr, ptr),
	expmac_test	entry (fixed bin, ptr, (4) ptr, (4) bit (1) aligned) returns (bit (1)),
	m_a		entry (ptr, bit (2) aligned),
	expmac$zero	entry (fixed bin (15)),
	(load, adjust_ref_count)
			entry (ptr, fixed bin),
	need_temp		entry (ptr, bit (2) aligned),
	compile_exp	entry (ptr),
	compile_exp$save	entry (ptr) returns (ptr),
	state_man$erase_reg entry (bit (19) aligned),
	base_man$load_var	entry (fixed bin, ptr, fixed bin),
	aq_man$save_aq	entry (ptr, fixed bin),
	power_of_two	entry (fixed bin (18)) returns (fixed bin (18)) reducible;

/* internal static */

dcl	max_obj_seg_size	fixed bin (17) int static init (131071) options (constant);

dcl	(
	ldfx1		init (7),
	stfx1		init (15),
	sta		init (4),
	load_pt		init (60),
	load_ab		init (618),
	load_sb		init (621),
	fx1_to_fx2	init (88),
	quick_desc_mac	init (279),
	get_desc_size	init (284),
	zero_mac		init (308),
	sxl0		init (345),
	sxl7		init (352),
	stx0		init (714),
	stx7		init (721),
	xr18_to_q		init (735),
	xr_to_q		init (583)
	)		fixed bin (15) int static options (constant);

dcl	add_op		(2) bit (10) int static init ("0001111100"b,
						/* adq */
			"0001111110"b /* adaq */);

dcl	(
	eapbp		init ("0111010100"b),
	lcq		init ("0110111100"b),
	fld		init ("1000110010"b),
	fst		init ("1001011010"b),
	lda		init ("0100111010"b),
	ldq		init ("0100111100"b),
	adq		init ("0001111100"b),
	sbq		init ("0011111100"b),
	mpy		init ("1000000100"b),
	qls		init ("1110111100"b),
	lrs		init ("1110110110"b),
	lrl		init ("1111110110"b),
	arl		init ("1111110010"b),
	tsp4		init ("1101110000"b),
	tsp2		init ("0101110100"b),
	tsp3		init ("0101110110"b),
	tra		init ("1110010000"b),
	eax0		init ("1100100000"b),
	tsx0		init ("1110000000"b)
	)		bit (10) int static options (constant);

dcl	(
	lda_dl		init ("010011101000000111"b),
	lda_du		init ("010011101000000011"b),
	mpy_dl		init ("100000010000000111"b)
	)		bit (18) int static options (constant);

dcl	dl_inst		(0:3) bit (18) aligned int static options (constant) init ("001111110000000111"b,
						/* sbq ,dl */
			"000111110000000111"b,	/* adq ,dl */
			"011011110000000111"b,	/* lcq ,dl */
			"010011110000000111"b);	/* ldq ,dl */

dcl	(
	sbq_dl		defined (dl_inst (0)),
	adq_dl		defined (dl_inst (1)),
	lcq_dl		defined (dl_inst (2)),
	ldq_dl		defined (dl_inst (3))
	)		bit (18) aligned;

dcl	(
	eppbp_bp_up_zero	init ("010000000000000000011101010001000000"b),
	epplp_lp_up_zero	init ("100000000000000000011111000001000000"b),
	eppab_ab_up_zero	init ("001000000000000000011101001101000000"b),
	eppbb_bb_up_zero	init ("011000000000000000011101011101000000"b),
	epplb_lb_up_zero	init ("101000000000000000011111001101000000"b),
	eppsb_sb_up_zero	init ("111000000000000000011111011101000000"b),
	eax0_0_al		init ("000000000000000000110010000000000101"b),
	fld_0_dl		init ("000000000000000000100011001000000111"b),
	llr_36		init ("000000000000100100111111111000000000"b),
	ldq_0_dl		init ("000000000000000000010011110000000111"b),
	tpl_3_ic		init ("000000000000000011110000101000000100"b),
	ora_0_dl		init ("000000000000000000010111101000000111"b),
	adq_0_dl		init ("000000000000000000000111110000000111"b),
	sbq_0_dl		init ("000000000000000000001111110000000111"b),
	mpy_1_dl		init ("000000000000000001100000010000000111"b),
	div_1_dl		init ("000000000000000001101000110000000111"b)
	)		bit (36) int static options (constant);

dcl	(
	als_ins		init ("000000000000000000111011101000000000"b),
	lls_ins		init ("000000000000000000111011111000000000"b),
	anaq_ap		init ("000000000000000000011111111001000000"b)
	)		bit (36) int static;	/* these get set */

/* external static */

dcl	(
	cg_stat$text_base,
	cg_stat$text_reloc_base,
	cg_stat$cur_node,
	cg_stat$complex_ac,
	cg_stat$sym_use_base,
	cg_stat$cur_statement
	)		ptr ext,
	(
	pl1_operator_names_$last,
	cg_stat$max_program_size
	)		fixed bin ext,
	cg_stat$used_operator
			bit (900) ext,
	cg_stat$last_macro	fixed bin (15) ext,
	cg_stat$text_pos	fixed bin (18) ext;

dcl	1 instruction_info_$instruction_info
			(0:1023) aligned ext static,
	  2 changes	unaligned,
	    3 a		unal bit (1),
	    3 q		unal bit (1),
	    3 indicators	unal bit (1),
	    3 b		(1:6) unal bit (1),
	    3 x		(0:7) unal bit (1),
	    3 dr		unal bit (1),
	  2 directable	unal bit (1),
	  2 fixed_pt	unal bit (1),
	  2 float_pt	unal bit (1),
	  2 some_base	unal bit (1),
	  2 pad		unal bit (5),
	  2 num_words	unal fixed bin (7),
	  2 double_ins	unal bit (1);

dcl	instruction_info_$operators
			aligned ext static;

dcl	macro_table_$macro_count
			fixed bin ext,
	macro_table_$macro_table
			(1000) bit (72) ext static;

/* based */

dcl	1 operator_info	aligned based (addr (instruction_info_$operators)),
	  2 n_entries	fixed bin,
	  2 entry		(1 refer (operator_info.n_entries)),
	    3 first	fixed bin (18) uns unal,
	    3 last	fixed bin (18) uns unal,
	    3 info	aligned like instruction_info_$instruction_info;

dcl	arg		(num_args) ptr based (p);

dcl	1 macro_def	aligned based (p),
	  2 rel_ptr	unaligned bit (18),		/* rel ptr to body if size > 0 */
	  2 op_code	unaligned bit (10),		/* op_code if size = 0 */
	  2 size		unaligned bit (8),		/* size of body if multi instructions */
	  2 erase		unaligned bit (15),		/* which registers unaltered */
	  2 no_al		unaligned bit (1),		/* "1"b if no AL modification allowed */
	  2 no_ql		unaligned bit (1),		/* "1"b if no QL modification allowed */
	  2 perm		unaligned bit (1),		/* "1"b if arg1 should be made perm addressable */
	  2 cat		unaligned bit (1),		/* "1"b if target length should be taken from source length */
	  2 length_in_q	unaligned bit (1),		/* "1"b if length for move is in q register */
	  2 compare	unaligned bit (1),		/* "1"b if macro is an EIS comparison */
	  2 xec_eis	unaligned bit (1);		/* "1"b if macro xec's EIS instruction */

dcl	1 arg_word	aligned based (p),
	  2 dummy		unaligned bit (3),
	  2 number	unaligned bit (3),		/* arg number */
	  2 increment	unaligned bit (12),		/* add this to arg offset */
	  2 ignored	unaligned bit (12),
	  2 modifier	unaligned bit (6);

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

dcl	1 ic_instruction	based aligned,
	  2 offset	unaligned bit (18),
	  2 op_code	unaligned bit (10),
	  2 flag		unaligned bit (1),
	  2 ext_base	unaligned bit (1),
	  2 tag		unaligned bit (6);

dcl	1 forward_ref	based aligned,
	  2 eis_flag	unaligned bit (1),
	  2 offset	unaligned bit (17),
	  2 pad		unaligned bit (18);

dcl	full_word		bit (36) aligned based;

dcl	1 reloc		aligned based,
	  2 skip1		unal bit (12),
	  2 left_rel	unal bit (6),
	  2 skip2		unal bit (12),
	  2 right_rel	unal bit (6);

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

dcl	fix_bin		fixed bin based;

dcl	1 packed_ptr_st	based aligned,
	  2 packedptr	ptr unal;

/* include files */

%include operator_names;
%include machine_state;
%include nodes;
%include cg_reference;
%include symbol;
%include operator;
%include data_types;
%include boundary;
%include cgsystem;
%include relocation_bits;
%include bases;

/* program */

	k = 0;

	p = arg_pt;
	if p -> reference.temp_ref
	then do;
		if p -> reference.data_type ^= real_fix_bin_1
		then goto set_one;

		if p -> reference.value_in.storage
		then goto set_one;
		if p -> reference.array_ref
		then goto set_one;
		if p -> reference.aggregate
		then goto set_one;

		if macro = stfx1
		then goto set_one;
		if macro = zero_mac
		then goto set_one;
		if macro = load_pt
		then goto set_one;
		if macro >= load_ab & macro <= load_sb
		then go to set_one;
		if macro >= sxl0 & macro <= sxl7
		then goto set_one;
		if macro >= stx0 & macro <= stx7
		then goto set_one;
		if macro = quick_desc_mac
		then goto set_one;
		if macro = get_desc_size
		then goto set_one;

/* have reference to single precision fixed binary temp without
	        value in storage.  if value is in an index register, we'll
	        transfer it to storage or the q register */

		call save_temp;
		if macro = ldfx1
		then return;
	     end;

	goto set_one;

expmac$many:
     entry (macro, arg_pt, arg_cnt);

dcl	arg_cnt		fixed bin;		/* number of arguments */

	if arg_cnt <= 0
	then return;
	arg_blk = arg_pt;
	num_args = arg_cnt;

	do i = 1 to num_args;
	     p = arg_blk -> arg (i);
	     if ^p -> reference.perm_address
	     then call m_a (p, "0"b);
	end;

normal:
	mac = macro;
	goto join;

expmac$one:
     entry (macro, arg_pt, double);

dcl	double		fixed bin;		/* non-zero if double length operand */

	k = double;

set_one:
	num_args = 1;

	ref_pt = arg_pt;
	if ^ref_pt -> reference.perm_address
	then call m_a (ref_pt, k ^= 0);

	arg_blk = addr (ref_pt);

	if k = 0
	then goto normal;
	if ref_pt -> reference.even
	then mac = macro + 2;
	else mac = macro + 1;

join:
	if mac < 1
	then goto unknown;

	if mac > macro_table_$macro_count
	then do;
unknown:
		call cg_error (302, mac);
		return;
	     end;

	cg_stat$last_macro = mac;

	mac_pt = addr (macro_table_$macro_table (mac));
	if mac_pt -> full_word = "0"b
	then return;

	do i = 1 to num_args;
	     p = arg_blk -> arg (i);
	     if ^p -> reference.shared
	     then if p -> reference.ref_count = 1
		then call need_temp (p, "11"b);
	end;

	erase = mac_pt -> macro_def.erase;

	if erase
	then call state_man$erase_reg (erase);

	not_constant = "1"b;
	count_arg = (7)"0"b;

	first_pos, text_pos = cg_stat$text_pos;

/* check for no AL modification allowed */

	if mac_pt -> macro_def.no_al
	then do;
		p = arg_blk -> arg (1);
		if substr (p -> address.tag, 3, 4) = "0101"b
						/* al */
		then do;
			substr (p -> address.tag, 3, 4) = "1000"b;
						/* x0 */
			addrel (cg_stat$text_base, text_pos) -> full_word = eax0_0_al;
			text_pos = text_pos + 1;
		     end;
	     end;

	if mac_pt -> macro_def.perm
	then do;
		made_perm_addressable = "1"b;
		hold_perm_address = arg_blk -> arg (1) -> reference.perm_address;
		arg_blk -> arg (1) -> reference.perm_address = "1"b;
	     end;

	text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);

	size = fixed (mac_pt -> macro_def.size, 8);
	if size = 0
	then do;

/* macro is just an op_code, use of arg_1 is implied */

		p = arg_blk -> arg (1);
		output_pt -> full_word = string (p -> reference.address);
		output_pt -> instruction.op_code = mac_pt -> macro_def.op_code;

		q2 = p -> reference.symbol;
		if q2 ^= null
		then sym_use_pt -> packedptr = q2;

		inst = output_pt -> instruction.op_code;
		mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);

		if p -> reference.ic_ref
		then do;
			inc = 0;
			call text_ref;
		     end;

		reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
		reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);

		if ^p -> reference.shared & ^substr (count_arg, 1, 1)
		then substr (count_arg, 1, 1) = "1"b;

/* eliminate instructions which are effectively nop's -- if they really are ! */

		fw = output_pt -> full_word;

		if reloc_pt -> left_rel = rc_a
		then do;
			if fw = eppbp_bp_up_zero
			then goto done;
			if fw = epplp_lp_up_zero
			then goto done;
			if fw = eppab_ab_up_zero
			then go to done;
			if fw = eppbb_bb_up_zero
			then go to done;
			if fw = epplb_lb_up_zero
			then go to done;
			if fw = eppsb_sb_up_zero
			then go to done;
		     end;
		if fw = ora_0_dl
		then goto done;
		if fw = adq_0_dl
		then goto done;
		if fw = sbq_0_dl
		then goto done;
		if fw = mpy_1_dl
		then if cg_stat$cur_node -> operand (1) -> reference.data_type = real_fix_bin_1
		     then go to done;
		if fw = div_1_dl
		then goto done;

		rhs = output_pt -> right;
		q = addrel (output_pt, -1);

/* the following section attempts to remove code from the
	        sequences generated for string assignments and conversion
	        from bit to fixed.  Let N be the shift amount of the LRL,
	        if the preceding instruction is an lda which referecnes
	        a direct constant, the code attempts to shift the constant
	        reference and delete the lrl instruction.
	        if the preceding instruction is
			anaq	ap|2*(72-N)	(72-n)"1"b
	        the anaq instruction is removed.  if the preceding word is
			als	N
	        the two shift instructions are replaced by the instruction
			anaq	ap|144+2*N	(N)"0"b || (72-N)"1"b
	        if the preceding word is
			als	N-36
	        and the instruction before that is an lda, the
	        lda is changed to an ldq, the als and the lrl are
	        replaced by the instruction
			anaq	ap|144+2*N	(N)"0"b || (72-N)"1"b
	        Finally, if the preceding instruction is
			lls	N
	        it and the lrl are replaced by the same anaq as above */

		if rhs = lrl | rhs = arl
		then do;
			shift_amount = fixed (output_pt -> left, 18);

			if q -> right = lda_du
			then do;
				const_string = q -> left;
				goto l7;
			     end;

			if q -> right = lda_dl
			then do;
				const_string = (18)"0"b || q -> left;

l7:
				b72 = "0"b;
				substr (b72, shift_amount + 1) = const_string;
				if substr (b72, 37, 36)
				then goto l1;

				if b72 = "0"b & rhs = lrl
				then do;
					q -> full_word = fld_0_dl;
					goto done;
				     end;

				if substr (b72, 19, 18) = "0"b
				then do;
					q -> left = b72;
					q -> right = lda_du;
					goto done;
				     end;

				if substr (b72, 1, 18) = "0"b
				then do;
					q -> left = substr (b72, 19, 18);
					q -> right = lda_dl;
					goto done;
				     end;

				goto l1;
			     end;

			substr (anaq_ap, 1, 18) = bit (fixed (2 * (72 - shift_amount), 18), 18);
			if q -> full_word = anaq_ap
			then do;
				q -> full_word = fw;
				goto done;
			     end;

			substr (als_ins, 1, 18) = bit (shift_amount, 18);
			if q -> full_word = als_ins
			then goto ga;

			if shift_amount < 37
			then goto tls;
			substr (als_ins, 1, 18) = bit (fixed (shift_amount - 36, 18), 18);
			if q -> full_word = als_ins
			then do;
				q2 = addrel (q, -1);
				if q2 -> instruction.op_code ^= lda
				then goto l1;
				q2 -> instruction.op_code = ldq;
				goto ga;
			     end;

tls:
			substr (lls_ins, 1, 18) = bit (shift_amount, 18);
			if q -> full_word ^= lls_ins
			then goto l1;
ga:
			substr (anaq_ap, 1, 18) = bit (fixed (144 + 2 * shift_amount, 18), 18);
			q -> full_word = anaq_ap;
			goto done;
		     end;

		if rhs = lrs
		then do;

/* check for anaq	ap|2*(72-N) */

			shift_amount = fixed (output_pt -> left, 18);
			substr (anaq_ap, 1, 18) = bit (fixed (2 * (72 - shift_amount), 18), 18);
			if q -> full_word = anaq_ap
			then do;
				q -> full_word = fw;
				go to done;
			     end;
		     end;

		if rhs = qls
		then do;
			if q -> right ^= qls
			then goto l1;

/* have two consecutive qls instructions, combine them */

			q -> left = bit (fixed (fixed (q -> left, 18) + fixed (output_pt -> left, 18), 18), 18);
			goto done;
		     end;

/* the following section recognizes consecutive adq or sbq
	        instructions and attempts to combine constant terms */

		if rhs = adq_dl
		then s1 = 1;
		else if rhs = sbq_dl
		then s1 = -1;
		else goto m1;

		j = 0;
		if q -> right = adq_dl
		then s2 = 1;
		else if q -> right = sbq_dl
		then s2 = -1;
		else do;

/* if word before ldq has 2 in offset field, it may be
		        part of min | max macro so we'll skip the optimization */

			if addrel (q, -1) -> left = "000000000000000010"b
			then goto l1;

			j = 2;
			if q -> right = ldq_dl
			then s2 = 1;
			else if q -> right = lcq_dl
			then s2 = -1;
			else goto l1;
		     end;

/* if we are in abs sequence, skip the optimization */

		if addrel (q, -2) -> full_word = tpl_3_ic
		then go to m1;

		k = s1 * fixed (output_pt -> left, 18) + s2 * fixed (q -> left, 18);

		if k = 0
		then do;
			if j ^= 0
			then q -> full_word = ldq_0_dl;
			else do;
				output_pt = q;
				reloc_pt = addrel (reloc_pt, -1);
				sym_use_pt = addrel (sym_use_pt, -1);
				text_pos = text_pos - 1;
			     end;
			goto done;
		     end;

		if abs (k) > 111111111111111111b
		then goto l1;

		q -> right = dl_inst (j + fixed (k > 0, 1));

		q -> left = bit (k, 18);
		goto done;

m1:
		if not_constant
		then goto l1;

/* the follwing section first tries to optimize multiplications
	        with 2 constant operands, and then tries to replace
	        multipications by a constant power of two by a left shift
	        instruction */

		if inst = mpy
		then do;
			if cg_stat$cur_node -> operand (1) -> reference.data_type ^= real_fix_bin_1
			then goto l1;

			if rhs = mpy_dl & (q -> right = ldq_dl | q -> right = lcq_dl)
			     & addrel (q, -1) -> left ^= "000002"b3 & addrel (q, -2) -> full_word ^= tpl_3_ic
			then do;
				k71 = fixed (output_pt -> left, 18) * fixed (q -> left, 18);

				if k71 <= 111111111111111111b
				then do;
					q -> left = bit (fixed (k71, 18), 18);
					go to done;
				     end;
			     end;

			constant_value = fixed (const_string, 36);
			k = power_of_two (constant_value);
			if k = 0
			then goto l1;

			if q -> right = qls
			then do;
				q -> left = bit (fixed (fixed (q -> left, 18) + k, 18), 18);
				goto done;
			     end;

			output_pt -> full_word = bit (k, 18) || qls;
			goto l1;
		     end;

l1:
		text_pos = text_pos + 1;
		goto done;
	     end;

/* have macro of size words, may have arguments used */

	mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
	addressable = "1"b;

	do i = 0 to size - 1;

	     call put_word;
	end;

done:
	if count_arg
	then do i = 1 to num_args;
		if substr (count_arg, i, 1)
		then call adjust_ref_count (arg_blk -> arg (i), -1);
	     end;

	if text_pos >= cg_stat$max_program_size
	then call cg_error (311, cg_stat$max_program_size);

	do i = first_pos to text_pos - 1;

	     inst = text_pt -> instruction.op_code;
	     mop = binary (substr (inst, 1, 9), 9) + 512 * binary (substr (inst, 10, 1), 1);
	     info = instruction_info_$instruction_info (mop);
	     PR = binary (text_pt -> instruction.base, 3);

/* See if we have a reference to a pl1_operator_. Note that the following tests are
   carefully arranged in such a way as to make the code execute as quickly as possible.
   Needless to say, the following tests rely on knowledge of how the generated code
   addresses operators. Note that not all references use pr0, so we don't test that. */

	     if text_pt -> instruction.ext_base & (text_pt -> instruction.tag = ""b)
		& ((inst = tsx0) | (inst = tsp2) | (inst = tra) | (inst = tsp4) | (inst = tsp3))
	     then do;
		     offset = binary (text_pt -> instruction.offset, 15);

		     if offset <= pl1_operator_names_$last
		     then substr (cg_stat$used_operator, offset, 1) = "1"b;

		     if (inst = tsx0) | (inst = tsp3)
		     then do;

/* We have a normal or math operator. See how it affects the registers & indicators.
   A major assumption here is that an operator that modifies the Q or AQ
   also sets the ARITHMETIC indicators for that register. Most of the operators
   do just that. All operators that behave otherwise (i.e. set the LOGICAL
   indicators) must be in the operator_info table in instruction_info. */

			     do j = lbound (operator_info.entry, 1) to hbound (operator_info.entry, 1)
				while (operator_info.entry (j).last < offset);
			     end;

			     if j <= hbound (operator_info.entry, 1)
			     then if operator_info.entry (j).first <= offset
				then found = "1"b;
				else found = "0"b;
			     else found = "0"b;

			     if found
			     then info = operator_info.entry (j).info;
			     else do;
				     string (info.changes) = substr (erase, 1, 2);
						/* A, Q */
				     info.changes.indicators = "1"b;
				     info.fixed_pt = "1"b;
						/* one of these must be true... */
				     info.float_pt = "1"b;
						/* ...all exceptions are in table */

				     if substr (erase, 14, 1)
				     then info.changes.b (1) = "1"b;
				end;
			end;
		     else if inst = tsp4
		     then string (info.changes) = "111111111"b;

		end;

	     if eis & xec_eis
	     then string (info.changes) = "001"b;

/* The following statement should set the indicators to -1 (invalid), but we can't
   do so until all of the places that depend on the incorrect value have been
   fixed to set it to 0 themselves. Anybody that issues sztl-type instructions
   (for example) is affected. */

	     if info.changes.indicators
	     then machine_state.indicators = 0;

	     if info.changes.q
	     then do;
		     q_reg.changed = i;
		     q_reg.instruction = text_pt -> full_word;
		end;

	     if info.changes.a
	     then do;
		     a_reg.changed = i;
		     a_reg.instruction = text_pt -> full_word;
		end;

	     if (info.fixed_pt | info.float_pt) & info.changes.q
	     then machine_state.indicators = ind_arithmetic;
	     else if info.changes.indicators & info.changes.a
	     then machine_state.indicators = ind_logical;

	     if info.some_base
	     then call change_base_ (i, which_base (PR));

	     else do PR = lbound (info.changes.b, 1) to hbound (info.changes.b, 1);
		     if info.changes.b (PR)
		     then call change_base_ (i, (PR));
		end;


	     do j = 0 to 7;
		if info.changes.x (j)
		then do;
			index_regs (j).changed = i;
			index_regs (j).instruction = text_pt -> full_word;
			machine_state.indicators = ind_x (j);
		     end;
	     end;

	     if info.changes.dr
	     then machine_state.indicators = ind_decimal_reg;

	     text_pt = addrel (text_pt, 1);

/* Next sequence skips over EIS descriptors if they exist */

	     nwords = info.num_words - 1;
	     if eis
	     then if xec_eis
		then nwords = 2;

	     if nwords > 0
	     then do;

/* eis instruction */

		     if ^compare
		     then if machine_state.indicators = ind_known_refs
			then do;

/* we have set a value without setting the indicators,
		        remove it from the indicators */

				p = arg_blk -> arg (1);
				if p = indicators_ref (2)
				then machine_state.indicators = ind_invalid;
				else if p = indicators_ref (3)
				then machine_state.indicators = ind_invalid;
			     end;

		     i = i + nwords;
		     text_pt = addrel (text_pt, nwords);
		end;

	end;

	cg_stat$text_pos = text_pos;

	if made_perm_addressable
	then arg_blk -> arg (1) -> reference.perm_address = hold_perm_address;

	return;

expmac$zero:
     entry (macro);

	cg_stat$last_macro, mac = macro;

	if mac < 1
	then goto unknown;
	if mac > macro_table_$macro_count
	then goto unknown;

	num_args = 0;
	count_arg = (7)"0"b;

	mac_pt = addr (macro_table_$macro_table (mac));

	if mac_pt -> full_word = "0"b
	then return;

	erase = mac_pt -> macro_def.erase;

	if erase
	then call state_man$erase_reg (erase);

	size = fixed (mac_pt -> macro_def.size, 8);

	first_pos, text_pos = cg_stat$text_pos;
	text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);

/* there must be a macro body if there are no args */

	if size = 0
	then do;
		call cg_error (304, mac);
		return;
	     end;

	mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);
	do i = 0 to size - 1;
	     output_pt -> full_word = mac_pt -> full_word;
	     reloc_pt -> full_word = "0"b;

/* convert the sequence
			ldq	x
			llr	36
	        into the instruction
			lda	x	*/

/* We cannot do the optimization if the
	        q register could have been loaded via
	        more than 1 path (min or max bifs)*/

	     if output_pt -> full_word = llr_36
	     then if machine_state.indicators = ind_arithmetic
		then do;
			q = addrel (output_pt, -1);
			if q -> instruction.op_code = ldq
			then do;
				q -> instruction.op_code = lda;
				goto l4;
			     end;
		     end;


	     output_pt = addrel (output_pt, 1);
	     reloc_pt = addrel (reloc_pt, 1);
	     text_pos = text_pos + 1;

l4:
	     mac_pt = addrel (mac_pt, 1);
	end;

	goto done;

expmac$abs:
     entry (blk_pt, blk_cnt);

dcl	blk_pt		ptr,			/* points at block to be appended */
	blk_cnt		fixed bin;		/* number of words in block */

dcl	blk		(blk_cnt) fixed bin based;

	if blk_cnt <= 0
	then return;

	cg_stat$last_macro = 0;

/* we use the fact that the relocation segment will be
	   filled with zeros as its length grows */

	addrel (cg_stat$text_base, cg_stat$text_pos) -> blk = blk_pt -> blk;

	cg_stat$text_pos = cg_stat$text_pos + blk_cnt;
	if cg_stat$text_pos >= cg_stat$max_program_size
	then call cg_error (311, cg_stat$max_program_size);

	return;

expmac$interpret:
     entry (macro_start, node_pt, refs, atom);

/* This entry is called to interpret the macro sequence
	   starting at "macro_start" */

dcl	macro_start	fixed bin,		/* start of sequence */
	node_pt		ptr,			/* points at operator node */
	refs		(4) ptr,			/* ref nodes for operands */
	atom		(4) bit (1) aligned;	/* ON if operand is atomic */

dcl	(b1, b2, b3)	bit (1),
	(depth, code)	fixed bin,
	ref		(4) ptr defined (refs),
	(
	stack		(10),
	rand		(4)
	)		ptr;

dcl	1 special_word	aligned based,
	  2 part1		unal bit (18),
	  2 op		unal bit (9),
	  2 skip		unal bit (3),
	  2 part2		unal bit (6);

dcl	special_erase	bit (15) aligned based;

dcl	sp_erase		bit (19) aligned;

	mac_pt = addr (macro_start);
	goto init;

expmac$conditional:
     entry (macro, node_pt, refs, atom);

	mac_pt = addr (macro_table_$macro_table (macro));

	erase = mac_pt -> macro_def.erase;

	if erase
	then call state_man$erase_reg (erase);

	mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);

/* initialize */

init:
	first_pos, text_pos = cg_stat$text_pos;
	text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);

	num_args = node_pt -> operator.number;

	rand (2) = node_pt -> operand (2);
	rand (3) = node_pt -> operand (3);
	if num_args >= 4
	then rand (4) = node_pt -> operand (4);

	code = fixed (atom (2) || atom (3), 2);

	arg_blk = addr (refs);
	addressable = "0"b;
	count_arg = (7)"0"b;

	depth = 0;

/* if bit 28 of word from macro table is off, this is ordinary instruction */

loop:
	if ^mac_pt -> instruction.flag
	then do;
		call put_word;
		goto loop;
	     end;

/* have special control word */

	mop = fixed (mac_pt -> special_word.op, 9);
	s2 = fixed (mac_pt -> special_word.part2, 9);
	s1 = fixed (mac_pt -> special_word.part1, 18);
	k = fixed (mac_pt -> arg_word.number, 3);
	if k > 0
	then if k <= num_args
	     then p = ref (k);
	goto sw (mop);

/* end of macro sequence */

sw (0):
	if depth = 0
	then goto done;

	mac_pt = stack (depth);
	depth = depth - 1;
	goto next;

/* IF operator */

sw (1):
	b2 = "1"b;
	goto test;

/* IFNOT operator */

sw (2):
	b2 = "0"b;

test:
	if s2 = 1
	then b1 = ref (2) -> reference.value_in.q;
	else if s2 = 2
	then b1 = ref (3) -> reference.value_in.q;
	else if s2 = 3
	then b1 = ref (2) -> reference.value_in.a;
	else if s2 = 4
	then b1 = ref (3) -> reference.value_in.a;
	else if s2 = 5
	then b1 = ref (2) -> reference.value_in.complex_aq;
	else if s2 = 6
	then b1 = ref (3) -> reference.value_in.complex_aq;
	else if s2 = 7
	then b1 = constant_zero (ref (2));
	else if s2 = 8
	then b1 = constant_zero (ref (3));
	else if s2 = 9
	then b1 = atom (2);
	else if s2 = 10
	then b1 = atom (3);
	else if s2 = 11
	then b1 = atom (4);
	else b1 = expmac_test (s2, node_pt, refs, atom);

	if b1 = b2
	then do;

/* test succeeded */

next:
		mac_pt = addrel (mac_pt, 1);
		goto loop;
	     end;

/* test failed */

	goto sw (4);

/* FLIPTO operator */

sw (3):
	q = ref (2);
	ref (2) = ref (3);
	ref (3) = q;

	q = rand (2);
	rand (2) = rand (3);
	rand (3) = q;

	b1 = atom (2);
	atom (2) = atom (3);
	atom (3) = b1;

	code = fixed (atom (2) || atom (3), 2);

/* JUMP operator */

sw (4):
	if s1 = 0
	then goto done;
	mac_pt = ptr (mac_pt, s1);
	goto loop;

/* PUT operator */

sw (5):
	depth = depth + 1;
	stack (depth) = mac_pt;
	goto sw (4);

/* FETCH operator */

sw (6):
	b2 = "0"b;

f1:
	b1 = atom (k);
	b3 = "0"b;

f2:
	cg_stat$text_pos = text_pos;

	if b1
	then call load (ref (k), 0);
	else call compile_exp (rand (k));

	if b2 & ref (k) -> reference.data_type ^= real_fix_bin_2
	then call expmac$zero ((fx1_to_fx2));

	if b3
	then if ref (k) -> reference.value_in.complex_aq
	     then do;
		     q = ref (k);
		     string (q -> reference.address) = string (cg_stat$complex_ac -> reference.address);
		     q -> reference.relocation = cg_stat$complex_ac -> reference.relocation;
		     q -> reference.perm_address = "1"b;
		end;
	     else ref (k) = rand (k) -> operand (1);

f3:
	text_pos = cg_stat$text_pos;
	output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);
	goto next;

/* GET_FX2 operator */

sw (7):
	b2 = "1"b;
	goto f1;

/* COMPILE operator */

sw (8):
	b1, b2, b3 = "0"b;
	goto f2;

/* CPLALT operator */

sw (9):
	b3 = "1"b;
	b1, b2 = "0"b;
	goto f2;

/* CPLSAVE operator */

sw (10):
	cg_stat$text_pos = text_pos;

	ref (k) = compile_exp$save (rand (k));

	goto f3;

/* LOAD operator */

sw (11):
	b1 = "1"b;
	b2, b3 = "0"b;
	goto f2;

/* ADD operator */

sw (12):
	if p -> reference.no_address
	then call call_ma;

	output_pt -> full_word = string (p -> reference.address);
	output_pt -> instruction.op_code = add_op (p -> reference.data_type);

	q2 = p -> reference.symbol;
	if q2 ^= null
	then sym_use_pt -> packedptr = q2;

	reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
	reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);

	output_pt = addrel (output_pt, 1);
	reloc_pt = addrel (reloc_pt, 1);
	sym_use_pt = addrel (sym_use_pt, 1);
	text_pos = text_pos + 1;
	goto next;

/* SWITCH operator */

sw (13):
	if s2 = 1
	then n = code;
	else if s2 = 2
	then n = fixed (node_pt -> operator.op_code, 9);
	else if s2 = 3
	then n = ref (1) -> reference.data_type;
	else if s2 = 4
	then n = ref (2) -> reference.data_type;
	else if s2 = 5
	then n = ref (3) -> reference.data_type;

	mac_pt = addrel (mac_pt, n - s1 + 1);
	goto loop;

/* ERASE operator */

sw (14):
	cg_stat$text_pos = text_pos;

	sp_erase = mac_pt -> special_erase;
	call state_man$erase_reg (sp_erase);
	goto f3;

/* BUMP operator */

sw (15):
	if ^p -> reference.shared
	then p -> reference.ref_count = p -> reference.ref_count + 1;

	goto next;

/* DROP operator */

sw (16):
	if ^p -> reference.shared
	then call adjust_ref_count (p, -1);

	goto next;

expmac$fill_usage:
     entry (val, last_use);

dcl	(val, last_use, use, prev_use)
			fixed bin (17);

	use = last_use;
	do while (use ^= 0);
	     output_pt = addrel (cg_stat$text_base, use);
	     prev_use = fixed (output_pt -> forward_ref.offset, 17);

	     if output_pt -> forward_ref.eis_flag
	     then do;
		     output_pt -> forward_ref.eis_flag = "0"b;
		     use = use - output_pt -> descriptor.char;
		     output_pt -> descriptor.char = 0;
		end;

	     call set_offset (val - use);
	     use = prev_use;
	end;

	return;




/* Macro expander for EIS instructions */

expmac$eis:
     entry (macro, arg_pt);

dcl	lreg		(3) bit (1) aligned;	/* "1"b if length is in a register */
dcl	len		(3) bit (4) aligned;	/* register containing length */
dcl	count		(3) bit (1) aligned;	/* "1"b if reference count is to be decremented */

dcl	cat		bit (1) aligned;		/* "1"b if target length should be taken from source length */
dcl	length_in_q	bit (1) aligned;		/* "1"b if length for move is in q register */
dcl	compare		bit (1) aligned;		/* "1"b if macro is an EIS comparison */
dcl	xec_eis		bit (1) aligned;		/* "1"b if macro xec's an EIS instruction */
dcl	(nwords, type)	fixed bin;
dcl	ichar		fixed bin (3);
dcl	ibit		fixed bin (4);
dcl	scale		fixed bin (6);
dcl	ptarray		(2) ptr;

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

dcl	cg_stat$eis_temp	ptr ext;

dcl	1 descriptor	based aligned,		/* layout of operand descr */
	  2 word_address	bit (18) unal,
	  2 char		fixed bin (2) uns unal,
	  2 bit		fixed bin (4) uns unal,
	  2 length	bit (12) unal;

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


dcl	1 mod_factor	aligned,			/* layout of modification_factor field */
	  2 ext_base	bit (1) unal,
	  2 tag		unal,
	    3 length_in_reg bit (1),
	    3 indirect_descriptor
			bit (1),
	    3 offset_reg	bit (4);

dcl	copy_temp		entry (ptr) returns (ptr);
dcl	make_n_addressable	entry (ptr, fixed bin);
dcl	load_size$xr_or_aq	entry (ptr, bit (4) aligned);
dcl	state_man$unlock	entry ();
dcl	aq_man$lock	entry (ptr, fixed bin);

	num_args = 2;
	ptarray (1) = cg_stat$eis_temp;
	ptarray (2) = arg_pt;
	arg_blk = addr (ptarray);
	go to join_eis;

expmac$one_eis:
     entry (macro, arg_pt);

	num_args = 1;
	arg_blk = addr (arg_pt);
	go to join_eis;

expmac$two_eis:
     entry (macro, arg_pt, arg_pt2);

dcl	arg_pt2		ptr;

	num_args = 2;
	ptarray (1) = arg_pt;
	ptarray (2) = arg_pt2;
	arg_blk = addr (ptarray);
	go to join_eis;

expmac$many_eis:
     entry (macro, arg_pt, arg_cnt);

	if arg_cnt <= 0
	then return;
	arg_blk = arg_pt;
	num_args = arg_cnt;

join_eis:
	eis = "1"b;
	count_arg = (7)"0"b;

/* Check for short string temporaries not in storage.  If found, then store
   from aq */

	do i = 1 to num_args;
	     p = arg_blk -> arg (i);
	     if p -> reference.temp_ref
	     then if ^p -> reference.value_in.storage & ^p -> reference.array_ref & ^p -> reference.aggregate
		then if p -> reference.data_type >= char_string
		     then if ^p -> reference.long_ref & ^p -> reference.varying_ref
			then if p -> reference.value_in.a
			     then do;
				     if p -> reference.shared
				     then p, arg_blk -> arg (i) = copy_temp (p);
				     p -> reference.ref_count = p -> reference.ref_count + 1;
				     p -> reference.value_in.storage = "1"b;
				     p -> reference.store_ins = bit (cg_stat$text_pos, 18);
				     size = p -> reference.c_length * convert_size (p -> reference.data_type);

				     call expmac$one ((sta), p, fixed (size > bits_per_word, 1));
				end;
			     else call error315;
			else ;
		     else if p -> reference.data_type > 0
		     then if p -> reference.data_type <= real_fix_bin_2
			then if p -> reference.value_in.q
			     then call aq_man$save_aq (p, 0);
			     else call save_temp;
	end;

/* Initialize */

	mac = macro;

	if macro <= 0
	then go to unknown;
	if macro > macro_table_$macro_count
	then go to unknown;

	mac_pt = addr (macro_table_$macro_table (mac));
	if mac_pt -> full_word = "0"b
	then return;

	cat = mac_pt -> macro_def.cat;
	length_in_q = mac_pt -> macro_def.length_in_q;
	compare = mac_pt -> macro_def.compare;
	xec_eis = mac_pt -> macro_def.xec_eis;
	if xec_eis
	then n = -num_args;
	else n = num_args;
	if length_in_q
	then call aq_man$lock (null, 2);

/* Make all rands addressable */

	call make_n_addressable (arg_blk, n);

/* Get lengths for all the rands and determine whose reference counts are
  to be decremented */

	do i = 1 to num_args;
	     p = arg_blk -> arg (i);

	     if length_in_q
	     then do;
		     lreg (i) = "1"b;
		     len (i) = "0110"b;		/* q */
		end;
	     else if cat & i = 1
	     then ;
	     else do;
		     lreg (i) =
			p -> reference.length ^= null | p -> reference.c_length > 4095
			| (p -> reference.varying_ref & p -> reference.c_length = 0) | xec_eis;
		     if lreg (i)
		     then call load_size$xr_or_aq (p, len (i));
		end;
	     count (i) =
		^(p -> reference.shared | (i = 1 & p -> reference.temp_ref & ^p -> reference.aggregate & ^compare));
	     if count (i)
	     then if p -> reference.ref_count = 1
		then call need_temp (p, "01"b);
	end;

	if cat
	then do;
		lreg (1) = lreg (2);
		len (1) = len (2);
	     end;

	erase = mac_pt -> macro_def.erase;
	if erase
	then call state_man$erase_reg (erase);

	cg_stat$last_macro = mac;

	text_pos, first_pos = cg_stat$text_pos;
	text_pt, output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);

	size = fixed (mac_pt -> macro_def.size, 8);

	mac_pt = ptr (mac_pt, mac_pt -> macro_def.rel_ptr);

/* Start filling in the text */

	output_pt -> full_word = mac_pt -> full_word;
	reloc_pt -> full_word = "0"b;

	inc = 0;
	inst = output_pt -> instruction.op_code;

	if ^xec_eis
	then do;
		mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
		nwords = instruction_info_$instruction_info (mop).num_words;
	     end;
	else nwords = 3;

/* Loop to fill in the operand descriptors */

	do i = 1 to nwords - 1;

	     output_pt = addrel (output_pt, 1);
	     reloc_pt = addrel (reloc_pt, 1);
	     sym_use_pt = addrel (sym_use_pt, 1);

	     mac_pt = addrel (mac_pt, 1);

	     k = fixed (mac_pt -> arg_word.number, 3);
	     if mac_pt -> instruction.base
	     then k = 0;

/* Check for use of argument */

	     if k ^= 0
	     then do;

		     if k <= num_args
		     then p = arg_blk -> arg (k);
		     else do;
			     call cg_error (303, macro);
			     go to step;
			end;

		     q2 = p -> reference.symbol;
		     if q2 ^= null
		     then sym_use_pt -> packedptr = q2;

		     output_pt -> full_word = string (p -> reference.address);
		     type = mac_pt -> descriptor.bit;

/* See if we must build a descriptor */

/* Meanings of values of type (operand types of macros in macro_table.table) */
/* 0 = address	   */
/* 1 = decimal	   */
/* 2 = 8-bit character */
/* 3 = bit	   */
/* 4 = 4-bit character */

		     if type > 0
		     then do;
			     string (mod_factor) = substr (string (p -> reference.address), 30, 7);
			     mod_factor.length_in_reg = lreg (k);

			     if lreg (k)
			     then output_pt -> descriptor.length = "00000000"b || len (k);
			     else do;
				     q = p;
				     if cat
				     then if k = 1
					then q = arg_blk -> arg (2);
				     if mac_pt -> descriptor.length = (12)"0"b
				     then output_pt -> descriptor.length =
					     bit (fixed (q -> reference.c_length, 12), 12);
				     else output_pt -> descriptor.length = mac_pt -> descriptor.length;
				end;

			     if ^xec_eis
			     then substr (text_pt -> full_word, mf (i), 7) = string (mod_factor);

			     if type <= 2 | type = 4
			     then do;
				     ichar = p -> reference.c_f_offset;
				     ibit = 0;
				end;
			     else do;
				     ichar = divide (p -> reference.c_f_offset, bits_per_char, 2, 0);
				     ibit = mod (p -> reference.c_f_offset, bits_per_char);
				end;

			     if ichar > 0
			     then if q2 ^= null & type = 1
				then if q2 -> symbol.unaligned & q2 -> symbol.decimal
				     then output_pt -> four_bit_descriptor.char = ichar;
				     else output_pt -> descriptor.char = ichar;
				else output_pt -> descriptor.char = ichar;
			     if ibit > 0
			     then output_pt -> descriptor.bit = ibit;

			     if type = 1
			     then do;
				     if p -> reference.data_type = complex_fix_dec
					| p -> reference.data_type = complex_flt_dec
				     then output_pt -> descriptor.length =
					     bit (divide (p -> reference.c_length, 2, 12, 0), 12);
				     if p -> reference.data_type = real_fix_dec
					| p -> reference.data_type = complex_fix_dec
				     then do;
					     if q2 ^= null
					     then if q2 -> symbol.unaligned & q2 -> symbol.decimal
						then output_pt -> four_bit_descriptor.bit = 5;
						else output_pt -> descriptor.bit = 1;
					     else output_pt -> descriptor.bit = 1;
					     if q2 ^= null
					     then do;
						     scale = q2 -> symbol.scale;
						     if scale > max_dec_scale | scale < min_dec_scale
						     then scale = 0;
						     else scale = -scale;
						     if scale < 0
						     then scale = scale + 64;
						     if scale ^= 0
						     then substr (output_pt -> descriptor.length, 1, 6) =
							     bit (scale, 6);
						end;
					end;
				     else if q2 ^= null
				     then if q2 -> symbol.unaligned & q2 -> symbol.decimal
					then output_pt -> four_bit_descriptor.bit = 4;
						/* 4-bit float decimal */

				     if k = 1
				     then if instruction_info_$instruction_info (mop).changes.dr
					then do;
						p -> reference.value_in.decimal_aq = "1"b;
						decimal_reg.variable = p;
					     end;
				end;
			     else if type = 4
			     then do;
				     output_pt -> four_bit_descriptor.bit = 4;
				     output_pt -> four_bit_descriptor.char = ichar;
				end;
			end;

		     if p -> reference.ic_ref
		     then call text_ref;

		     reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
		     reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);

		     if count (k)
		     then call adjust_ref_count (p, -1);
		end;

	     else do;
		     output_pt -> full_word = mac_pt -> full_word;
		     reloc_pt -> full_word = "0"b;
		end;
step:
	end;

/* Unlock all registers locked for this instruction */

	call state_man$unlock;

	text_pos = text_pos + nwords;

/* See if we have non-EIS sequence following EIS instruction.  If so, put_word will handle it */

	if size > nwords
	then do;
		output_pt = addrel (output_pt, 1);
		reloc_pt = addrel (reloc_pt, 1);
		sym_use_pt = addrel (sym_use_pt, 1);
		mac_pt = addrel (mac_pt, 1);
		eis = "0"b;
		do i = nwords to size - 1;
		     call put_word;
		end;
	     end;

	go to done;



put_word:
     proc;

dcl	inc_orig		fixed bin;

/* check for use of argument */

	k = fixed (mac_pt -> arg_word.number, 3);
	if mac_pt -> instruction.tag
	then k = 0;
	if mac_pt -> instruction.base
	then k = 0;

	inst = mac_pt -> instruction.op_code;
	mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);

/* check for use of argument */

	if k ^= 0
	then do;

		if k <= num_args
		then p = arg_blk -> arg (k);
		else do;
			call cg_error (303, macro);
			return;
		     end;

/* check for base register being loaded */

		if inst = eapbp
		then do;
			call call_base_man;
			goto l3;
		     end;

/* make sure arg is addressable */

		if ^addressable
		then call call_ma;

		fw = string (p -> reference.address);

		inc, inc_orig = fixed (mac_pt -> arg_word.increment, 12);

/* if macro word is of form
			op argk+inc
		   and the corresponding argument has indirection,
		   we must either load value of inc into an index,
		   or we must load base register with address */

		if inc = 0
		then goto copy;

		if substr (p -> address.tag, 1, 2) = "00"b
		then goto copy;

		if p -> address.tag = "010000"b	/* * */
		then do;

/* have simple case, just load value of inc into x0 */

			output_pt -> left = bit (fixed (inc, 18), 18);
			output_pt -> right = eax0;

			substr (fw, 31, 6) = "111000"b;
						/* *0 */

			output_pt = addrel (output_pt, 1);
			reloc_pt = addrel (reloc_pt, 1);
			sym_use_pt = addrel (sym_use_pt, 1);
			text_pos = text_pos + 1;
			inc = 0;
		     end;
		else do;
			call adjust_ref_count (p, 1);
			call call_base_man;
			fw = string (p -> reference.address);
		     end;

/* copy word from macro table into output */

copy:
		output_pt -> full_word = mac_pt -> full_word;

/* combine kth arg with macro word */

		output_pt -> left = "0"b;
		output_pt -> full_word = output_pt -> full_word | fw;

		q2 = p -> reference.symbol;
		if q2 ^= null
		then sym_use_pt -> packedptr = q2;

		if p -> reference.ic_ref
		then call text_ref;
		else if inc > 0
		then if output_pt -> instruction.ext_base
		     then output_pt -> instruction.offset =
			     bit (fixed (fixed (output_pt -> instruction.offset, 15) + inc, 15), 15);
		     else output_pt -> left = bit (fixed (fixed (output_pt -> left, 18) + inc, 18), 18);

		reloc_pt -> left_rel = substr (p -> reference.relocation, 1, 6);
		reloc_pt -> right_rel = substr (p -> reference.relocation, 7, 6);

		if ^p -> reference.shared & inc_orig = 0 & ^substr (count_arg, k, 1)
		then substr (count_arg, k, 1) = "1"b;

	     end;

	else do;
		output_pt -> full_word = mac_pt -> full_word;
		p = null;
		reloc_pt -> full_word = "0"b;
	     end;

	if reloc_pt -> left_rel = rc_a
	then do;
		if output_pt -> full_word = eppbp_bp_up_zero
		then goto l3;
		if output_pt -> full_word = epplp_lp_up_zero
		then goto l3;
		if output_pt -> full_word = eppab_ab_up_zero
		then go to l3;
		if output_pt -> full_word = eppbb_bb_up_zero
		then go to l3;
		if output_pt -> full_word = epplb_lb_up_zero
		then go to l3;
		if output_pt -> full_word = eppsb_sb_up_zero
		then go to l3;
	     end;

	q = addrel (output_pt, -1);

/* following section flushes sequence
			fld	x
			fst	x
	        which may arise in some complex arithmetic sequences */

	if inst = fst
	then do;
		fw = output_pt -> full_word;
		substr (fw, 19, 10) = fld;
		if q -> full_word = fw
		then goto prev;
	     end;

	if i > 0
	then goto l2;

	if output_pt -> right = adq_dl
	then s1 = 1;
	else if output_pt -> right = sbq_dl
	then s1 = -1;
	else goto l2;

	j = 0;
	if q -> right = adq_dl
	then s2 = 1;
	else if q -> right = sbq_dl
	then s2 = -1;
	else do;

/* if word before ldq has 2 in offset field, it may be
		        part of min | max macro so we'll skip the optimization */

		if addrel (q, -1) -> left = "000000000000000010"b
		then goto l2;

		j = 2;
		if q -> right = ldq_dl
		then s2 = 1;
		else if q -> right = lcq_dl
		then s2 = -1;
		else goto l2;
	     end;

/* if we are in abs  sequence, skip optimization */

	if addrel (q, -2) -> full_word = tpl_3_ic
	then go to l2;

	k = s1 * fixed (output_pt -> left, 18) + s2 * fixed (q -> left, 18);

	if k = 0
	then do;
		if j ^= 0
		then q -> full_word = ldq_0_dl;
		else do;
prev:
			output_pt = q;
			reloc_pt = addrel (reloc_pt, -1);
			sym_use_pt = addrel (sym_use_pt, -1);
			text_pos = text_pos - 1;
		     end;
		goto l3;
	     end;

	if abs (k) > 111111111111111111b
	then goto l2;

	q -> right = dl_inst (j + fixed (k > 0, 1));

	q -> left = bit (k, 18);
	goto l3;

l2:
	output_pt = addrel (output_pt, 1);
	reloc_pt = addrel (reloc_pt, 1);
	sym_use_pt = addrel (sym_use_pt, 1);
	text_pos = text_pos + 1;

l3:
	mac_pt = addrel (mac_pt, 1);
     end;

call_base_man:
     proc;

dcl	hold_perm_address	bit (1) aligned;

	cg_stat$text_pos = text_pos;

	if addressable
	then do;
		hold_perm_address = p -> reference.perm_address;
		p -> reference.perm_address = "1"b;
	     end;

	call base_man$load_var (2, p, 1);

	if addressable
	then p -> reference.perm_address = hold_perm_address;

	text_pos = cg_stat$text_pos;
	output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);

     end;

call_ma:
     proc;

	cg_stat$text_pos = text_pos;

	call m_a (p, "0"b);

	text_pos = cg_stat$text_pos;
	output_pt = addrel (cg_stat$text_base, text_pos);
	reloc_pt = addrel (cg_stat$text_reloc_base, text_pos);
	sym_use_pt = addrel (cg_stat$sym_use_base, text_pos);

     end;

set_offset:
     proc (off_val);

dcl	pt		ptr,
	off_val		fixed bin (18);

	pt = output_pt;

	if off_val >= 0
	then pt -> ic_instruction.offset = bit (off_val, 18);
	else pt -> ic_instruction.offset = bit (fixed (262144 + off_val, 18), 18);

     end;

text_ref:
     proc;

dcl	(q, s)		ptr,
	offset		fixed bin (18),
	temp		fixed bin (35);

	offset = text_pos;

	if p -> reference.defined_ref
	then s = p -> reference.qualifier;
	else s = p;
	s = s -> reference.symbol;
	if s = null
	then goto so2;
	if s -> node.type = label_node
	then goto so1;

	if s -> symbol.label
	then goto so1;
	if s -> symbol.entry
	then goto so1;
	if ^s -> symbol.constant
	then goto so;

	not_constant = "0"b;

	q = s -> symbol.initial;
	if q = null
	then goto so1;

	if p -> reference.c_offset ^= 0
	then if p -> reference.units ^= word_
	     then goto so;

	if p -> reference.forward_ref
	then q = addrel (q, inc + p -> reference.c_offset);
	else q = addrel (cg_stat$text_base, inc + fixed (substr (string (p -> reference.address), 1, 18), 18));

	const_string = q -> full_word;

	if instruction_info_$instruction_info (mop).directable
	then do;

		if eis
		then do;
			if i = 2
			then if q -> right = "0"b
			     then do;
				     output_pt -> left = q -> left;
				     substr (text_pt -> full_word, 15, 4) = "0011"b;
						/* du */
				     return;
				end;
			go to so;
		     end;

		if q -> left = "0"b
		then do;
is_dl:
			output_pt -> left = q -> right;
			output_pt -> instruction.tag = "000111"b;
						/* dl */
			return;
		     end;

		if q -> right = "0"b
		then do;
			output_pt -> left = q -> left;
			output_pt -> instruction.tag = "000011"b;
						/* du */
			return;
		     end;

		if q -> fix_bin > 0
		then goto so;

		temp = -q -> fix_bin;
		q = addr (temp);

		if (18)"0"b || q -> right ^= q -> full_word
		then goto so;

		if inst = ldq
		then inst = lcq;
		else if inst = adq
		then inst = sbq;
		else if inst = sbq
		then inst = adq;
		else if inst = lcq
		then inst = ldq;
		else goto so;

		output_pt -> instruction.op_code = inst;
		mop = fixed (substr (inst, 1, 9), 9) + 512 * fixed (substr (inst, 10, 1), 1);
		goto is_dl;

	     end;

so:
	s -> symbol.allocate = "1"b;

so1:
	if p -> reference.forward_ref
	then do;
		if s -> symbol.location > max_obj_seg_size
		then do;
			call cg_error (333, max_obj_seg_size);
			return;
		     end;
		output_pt -> forward_ref.offset = bit (fixed (s -> symbol.location, 17), 17);
		if eis
		then do;
			output_pt -> forward_ref.eis_flag = "1"b;
			s -> symbol.location = offset + i;
			output_pt -> descriptor.char = i;
		     end;
		else s -> symbol.location = offset;
	     end;
	else do;
so2:
		call set_offset (fixed (output_pt -> ic_instruction.offset, 18) + inc - offset);
	     end;
     end;


save_temp:
     proc;

dcl	i		fixed bin (18);
dcl	mac		fixed bin (15);

/* have reference to fixed binary temp without value in storage.
	        if value is in an index register, we'll transfer it to storage
	        or the q register.  If value is in q, we'll store it unless
	        the original macro was ldfx1, in which case we have an error. */

	if p -> reference.value_in.q
	then do;
		if macro = ldfx1
		then call error315;
		else do;
			p -> reference.value_in.storage = "1"b;
			p -> reference.ref_count = p -> reference.ref_count + 1;
			call expmac (stfx1, p);
		     end;
		return;
	     end;

	if string (p -> reference.value_in.x) = "0"b
	then do;
		call error315;
		return;
	     end;

	do i = 0 to 7 while (^p -> reference.value_in.x (i));
	end;

	if macro = ldfx1
	then do;
		if p -> reference.symbol -> symbol.c_dcl_size > default_fix_bin_p
		then mac = xr18_to_q;
		else mac = xr_to_q;
		q = c_a (i, 8);			/* 0,i */
		call expmac (mac, q);
		call adjust_ref_count (p, -1);
		return;
	     end;

	p -> reference.value_in.storage = "1"b;
	p -> reference.ref_count = p -> reference.ref_count + 2;
	call expmac ((zero_mac), p);
	call expmac (sxl0 + i, p);

     end;


error315:
     proc;

	call error (315, cg_stat$cur_statement, p);

     end;

change_base_:
     procedure (insx, base);
declare	insx		fixed bin (18);
declare	base		fixed bin;
declare	k		fixed bin;
declare	q		ptr;

	if insx <= base_regs (base).changed
	then return;

	base_regs (base).changed = insx;
	base_regs (base).instruction = text_pt -> full_word;

	q = base_regs (base).variable;
	k = base_regs (base).type;
	if q = null
	then k = 0;

	if k = 1
	then q -> reference.value_in.b (base) = "0"b;
	else if k = 2
	then q -> reference.address_in.b (base) = "0"b;

	base_regs (base).type = 0;

     end change_base_;

     end;




		    expmac_test.pl1                 10/03/83  1730.5rew 10/03/83  1008.3        6165



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


/* interim version */

expmac_test: proc(test,node_pt,ref,atom) returns(bit(1));

dcl	test	fixed bin,
	node_pt	ptr,
	ref(3)	ptr,
	atom(3)	bit(1) aligned;

	return("0"b);
	end;




		    fixed_to_float.pl1              10/03/83  1730.5rew 10/03/83  1008.3       23247



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

/* Procedures to generate conversions to and from fixed binary scaled

   Initial Version:  3 January 1972 by BLW	*/

fixed_to_float: proc(pt);

dcl	pt ptr;		/* points at a reference node */

dcl	(p,q) ptr,
	exp fixed bin(8),
	(type,scale) fixed bin,
	full_word bit(36) aligned,
	word bit(36) aligned based;

dcl	cg_stat$text_pos fixed bin(18) ext,
	cg_stat$text_base ptr ext;

dcl	(addrel,bit,fixed,substr) builtin;

dcl	expmac$zero entry(fixed bin(15)),
	expmac entry(fixed bin(15),ptr),
	generate_constant$bit_string entry(bit(*) aligned,fixed bin) returns(ptr);

dcl (	fx1_to_fl2	init(122),
	fx1_to_fx2	init(88),
	fxscaled_to_fl2	init(518),
	fl2_to_fx2	init(125),
	fl2_to_fxscaled	init(519)) fixed bin(15) int static;

%include cgsystem;
%include reference;
%include symbol;
%include data_types;

	p = pt;
	type = p -> reference.data_type;
	scale = p -> reference.symbol -> symbol.scale;

	if scale = 0
	then do;
	     call expmac$zero(fx1_to_fl2 + type - real_fix_bin_1);
	     return;
	     end;

	if type = real_fix_bin_1 then call expmac$zero((fx1_to_fx2));

	full_word = "0"b;
	exp = bits_per_two_words - 1 - scale;

	if exp >= 0 then substr(full_word,1,8) = bit(exp,8);
	else substr(full_word,1,8) = bit(fixed(256+exp,8),8);

	call expmac((fxscaled_to_fl2),generate_constant$bit_string(full_word,(bits_per_word)));
	return;

float_to_fixed: entry(pt);

	p = pt;
	scale = p -> reference.symbol -> symbol.scale;

	if scale = 0
	then do;
	     call expmac$zero((fl2_to_fx2));
	     return;
	     end;
	call expmac$zero((fl2_to_fxscaled));

	q = addrel(cg_stat$text_base,cg_stat$text_pos);
	exp = bits_per_two_words - 1 - scale;

	if exp >= 0 then substr(q -> word,1,8) = bit(exp,8);
	else substr(q -> word,1,8) = bit(fixed(256+exp,8),8);

	cg_stat$text_pos = cg_stat$text_pos + 1;
	end;




		    gen_pl1_linkage.pl1             10/03/83  1730.5rew 10/03/83  1008.3       69309



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


/* This program is called to generate the linkage section

   Initial Version: 21 January 1971 by BLW for pl2	  
	Modified: 23 June 1975 by EEW to remove trace entry word
	Modified:	12 January 1976 by RAB to allocate all externals if symbol table built
		fixes bug 1454
	Modified:	1 June 1976 by RAB for *system links	*/

gen_pl1_linkage: proc(pt);

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

dcl	(p,block_pt,sym_pt,tok_pt,t_pt,def_ptr,def_reloc_ptr,
	 link_ptr,link_reloc_ptr) ptr,
	(loc,n,def_pos,link_pos) fixed bin(18),
	(first,no_runtime_symbol) aligned bit(1);

dcl	(null,index,fixed,bit,addrel,rel,substr) builtin;

dcl	create_list entry(fixed bin) returns(ptr),
	error entry(fixed bin,ptr,ptr),
	initialize_ext_static entry(ptr) returns(bit(18) aligned),
	gen_pl1_linkage entry(ptr),
	generate_definition entry(char(*) aligned,fixed bin(3),bit(18) aligned),
	compile_link entry(char(*) aligned,bit(18) aligned,fixed bin) returns(fixed bin(18));

dcl	(cg_static_$def_pos,cg_static_$link_pos,cg_static_$aos_array,cg_static_$link_begin,
	 cg_static_$def_origin,cg_static_$text_pos) fixed bin(18) ext,
	(cg_static_$def_base,cg_static_$def_reloc_base,cg_static_$link_base,
	 cg_static_$link_reloc_base,cg_static_$root,cg_static_$ext_proc_list,cg_static_$ext_var_list) ptr ext,
	(cg_static_$star_symbol_up_zero,cg_static_$last_def,cg_static_$zero_def,cg_static_$seg_def) bit(18) aligned ext,
	cg_static_$seg_name char(32) varying ext,
	(cg_static_$generate_symtab,cg_static_$table_option,cg_static_$use_type_6) bit(1) ext;

dcl (	rc_dp_t	initial("000000000000010101000000000000010000"b),
	rc_lb_lb	initial("000000000000011000000000000000011000"b))
	bit(36)	internal static;

dcl	fi_mod bit(6) int static init("100110"b);	/* fi mod = 46 oct */

dcl	1 type_block	aligned based,
	2 (type,trap_ptr)	unal bit(18),
	2 (seg_id,exp)	unal bit(18),
	2 (blk_ptr,int_val)	unal bit(18);

dcl	1 fault_pair	aligned based,
	2 minus_star	unal bit(18),
	2 unused		unal bit(12),
	2 tag		unal bit(6),
	2 expr_word	unal bit(18),
	2 rest		unal bit(18);

dcl	1 def_header	aligned based,
	2 forward		unal bit(18),
	2 backward	unal bit(18),
	2 skip		unal bit(18),
	2 flags		unal bit(18);

dcl	address		fixed bin(35) based;

dcl	word(0:1)		aligned bit(36) based,
	reloc(0:3)	aligned bit(36) based;

	/* We make use of the fact that an 18 bit relocation code is
	   padded to 36 bits with zeros on the right when assign to
	   the full word reloc fields since almost all right-hand_sides
	   are absolute */

%include relbts;
%include list;
%include block;
%include symbol;
%include token;
%include nodes;
%include segname_def;

	no_runtime_symbol = ^ (cg_static_$table_option | cg_static_$generate_symtab);

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

	     sym_pt = block_pt -> block.declaration;
	     do while(sym_pt ^= null);

		if sym_pt -> node.type ^= symbol_node then goto loop;
		if ^ sym_pt -> symbol.external then goto loop;
		if no_runtime_symbol
		then if ^ sym_pt -> symbol.allocate
		     then goto loop;
		if sym_pt -> symbol.condition then goto loop;
		if sym_pt -> symbol.arg_descriptor then goto loop;
		if sym_pt -> symbol.builtin then goto loop;
		if sym_pt -> symbol.father ^= null then goto loop;

		tok_pt = sym_pt -> symbol.token;

		if sym_pt -> symbol.entry & sym_pt -> symbol.constant
		then do;

		     /* we have an ext entry, generate link if
		        its an outward reference */

		     if sym_pt -> symbol.initial = null
		     then if sym_pt -> symbol.allocate
		     then do;
			sym_pt -> symbol.location = compile_link(tok_pt -> token.string,"0"b,0);
			sym_pt -> symbol.allocated = "1"b;

			p = create_list(2);
			p -> element(2) = sym_pt;
			p -> element(1) = cg_static_$ext_proc_list;
			cg_static_$ext_proc_list = p;
			end;

		     goto loop;
		     end;


		/* we have a variable, put it on list for prepare_symbol_map */

		p = create_list(2);
		p -> element(2) = sym_pt;
		p -> element(1) = cg_static_$ext_var_list;
		cg_static_$ext_var_list = p;

		if index(tok_pt -> token.string,"$") = 0 | cg_static_$use_type_6
		then do;
		     sym_pt -> symbol.location = cg_static_$link_pos;
		     sym_pt -> symbol.location = compile_link(tok_pt -> token.string,
		      initialize_ext_static(sym_pt),1);
		     end;
		else do;
		     if sym_pt -> symbol.initialed
			then call error(345,null,sym_pt);
		     loc,
		     sym_pt -> symbol.location = compile_link(tok_pt -> token.string,"0"b,1);

		     if sym_pt -> symbol.son ^= null
			then call fill_loc((sym_pt -> symbol.son));
		     end;

		sym_pt -> symbol.allocated = "1"b;

loop:		sym_pt = sym_pt -> symbol.next;
		end;

	     /* thru with this block, now do sons and then brother */

	     p = block_pt -> block.son;
	     if p ^= null then call gen_pl1_linkage(p);
	     block_pt = block_pt -> block.brother;
	     end;

	return;

gen_pl1_linkage$init_linkage: entry;

	/* This entry is called to initialize the linkage generator.
	   It generates the class 3 segname definition and the definition
	   for "symbol_table".  A link to <*symbol>|0 is generated if needed */

	cg_static_$ext_proc_list, cg_static_$ext_var_list = null;

	link_pos = cg_static_$link_pos;
	cg_static_$link_begin, link_pos = link_pos + mod(link_pos,2);   /* make EVEN */

	/* generate definition header.  the word of zeros terminating
	   the definition chain will be a location 2 */

	cg_static_$def_base -> def_header.flags = "11"b;	/* new, ignore */
	cg_static_$def_reloc_base -> reloc(0) = rc_dp;
	cg_static_$zero_def = "000000000000000010"b;
	cg_static_$last_def = "000000000000000000"b;
	cg_static_$def_pos = 3;

	/* generate definition for segname, class 3 */

	call generate_definition((cg_static_$seg_name),3,cg_static_$zero_def);

	/* generate definition for "symbol_table" */

	call generate_definition("symbol_table",2,"0"b);

	addrel(cg_static_$def_base,cg_static_$seg_def) -> segname_def.defblock = cg_static_$last_def;

	/* generate link to <*symbol>|0 only if it is needed */

	if cg_static_$generate_symtab then goto ml;
	if ^ cg_static_$table_option then goto done;

ml:	link_ptr = addrel(cg_static_$link_base,link_pos);
	link_reloc_ptr = addrel(cg_static_$link_reloc_base,link_pos);

	def_pos = cg_static_$def_pos;
	def_ptr = addrel(cg_static_$def_base,def_pos);
	def_reloc_ptr = addrel(cg_static_$def_reloc_base,def_pos);

	def_ptr -> type_block.type = "000000000000000001"b;
	def_ptr -> type_block.seg_id = "000000000000000010"b;

	def_ptr -> type_block.blk_ptr = bit(def_pos,18);
	def_reloc_ptr -> reloc(2) = rc_dp;

	link_ptr -> address = -link_pos * 262144;
	link_ptr -> fault_pair.tag = fi_mod;
	link_reloc_ptr -> reloc(0) = rc_nlb;

	link_ptr -> fault_pair.expr_word = bit(fixed(def_pos+2,18),18);
	link_reloc_ptr -> reloc(1) = rc_dp;

	cg_static_$star_symbol_up_zero = bit(link_pos,18);

	cg_static_$def_pos = cg_static_$def_pos + 3;
	link_pos = link_pos + 2;

done:	cg_static_$link_pos = link_pos;
	return;


fill_loc:	     proc(pt);

dcl	     (pt,s) ptr;

	     do s = pt repeat s -> symbol.brother while(s ^= null);
		s -> symbol.location = loc;

		if s -> symbol.son ^= null
		     then call fill_loc((s -> symbol.son));

		if s -> symbol.initialed
		     then call error(345,null,s);
		end;

	     end;

	end;




		    gen_pl1_symbol.pl1              11/20/86  1408.9r w 11/20/86  1145.0      100071



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


/* Program to create symbol table for Version II PL/I

   Initial Version: 11 September 1972 by BLW
	Modified: 22 January 1972 by BLW
	Modified:	18 July 1975 by RAB for link_head.static_length
	Modified:	1 Dec 1976 by RAB for -long_profile
	Modified: 27 October 1980 by M. N. Davidoff to increase length of pl1_stat_$options.

	This entry initializes the symbol table header
*/
/* format: style3 */
gen_pl1_symbol$beg_symbol:
     proc;

dcl	cg_static_$version_name
			char (132) varying ext,
	cg_static_$seg_name char (32) varying ext,
	cg_static_$compiler_name
			char (12) varying ext;
dcl	pl1_stat_$options	char (400) varying ext;
dcl	pl1_stat_$user_id	char (32) aligned ext,
	cg_static_$last_def bit (18) ext,
	(
	cg_static_$text_reloc_base,
	cg_static_$link_base,
	cg_static_$def_base,
	cg_static_$link_reloc_base,
	cg_static_$sym_base,
	cg_static_$sym_reloc_base,
	cg_static_$def_reloc_base
	)		ptr ext,
	(
	cg_static_$text_pos,
	cg_static_$link_pos,
	cg_static_$def_pos,
	cg_static_$link_begin,
	cg_static_$version_number,
	cg_static_$sym_pos,
	cg_static_$profile_pos,
	pl1_stat_$greatest_severity,
	cg_static_$stat_pos,
	cg_static_$profile_start
	)		fixed bin (18) ext,
	cg_static_$clock_time
			fixed bin (71) ext static,
	(
	cg_static_$generate_symtab,
	cg_static_$table_option,
	cg_static_$separate_static,
	cg_static_$io_used,
	cg_static_$profile_option,
	cg_static_$generate_map,
	cg_static_$long_profile
	)		bit (1) ext static,
	code_gen_$symbol_table
			fixed bin (15) external static;

dcl	1 cg_static_$statement_map
			ext unaligned,
	  2 first		bit (18),
	  2 last		bit (18);

dcl	(p, sym_reloc_ptr, map_ptr, link_base, link_reloc_base, sym_base, sym_ptr)
			ptr,
	info_ptr		ptr int static,
	(link_pos, sym_pos) fixed bin (18),
	(i, j, k, l, n)	fixed bin (15),
	sym_rel_bit_count	fixed bin (27),
	b18		bit (18) aligned;

dcl	error		entry (fixed bin, ptr, ptr);

dcl	(addr, addrel, bit, divide, fixed, index, length, mod, null, size, string, substr)
			builtin;

dcl	max_link_size	init (16384) fixed bin int static;

dcl	1 link_head	aligned based (p),
	  2 word_zero	unaligned bit (36),
	  2 word_one,
	    3 def_base	unaligned bit (18),
	    3 rh		unaligned bit (18),
	  2 word_two	unaligned bit (36),
	  2 word_three	unaligned bit (36),
	  2 word_four	unaligned bit (36),
	  2 word_five	unaligned bit (36),
	  2 word_six,
	    3 first_link	unaligned bit (18),
	    3 block_length	unaligned bit (18),
	  2 word_seven,
	    3 skip	unal bit (18),
	    3 static_length unaligned bit (18);

dcl	reloc		(0:1) bit (36) aligned based;

dcl	1 relinfo		aligned based,
	  2 version	fixed bin,
	  2 rel_bit_count	fixed bin,
	  2 relbits	bit (i refer (rel_bit_count)) unaligned;

dcl	1 reloc_in	aligned based (p),
	  2 half_word	(0:1000) unaligned bit (18);

%include definition;
%include relbts;
%include std_symbol_header;
%include source_map;
%include source_list;
%include pl1_symbol_block;

/* Generate the symbol table header.  Ref. MSB-27 */

	sym_ptr = cg_static_$sym_base;
	cg_static_$sym_pos = size (sym_ptr -> std_symbol_header);

	sym_ptr -> std_symbol_header.dcl_version = 1;
	sym_ptr -> std_symbol_header.identifier = "symbtree";
	sym_ptr -> std_symbol_header.gen_number = cg_static_$version_number;
	sym_ptr -> std_symbol_header.gen_created = addr (code_gen_$symbol_table) -> std_symbol_header.object_created;
	sym_ptr -> std_symbol_header.object_created = cg_static_$clock_time;
	sym_ptr -> std_symbol_header.generator = cg_static_$compiler_name;
	string (sym_ptr -> std_symbol_header.gen_version) = store_string ((cg_static_$version_name));

	m = index (pl1_stat_$user_id, " ") - 1;
	if m < 0
	then m = length (pl1_stat_$user_id);
	string (sym_ptr -> std_symbol_header.userid) = store_string (substr (pl1_stat_$user_id, 1, m));

	string (sym_ptr -> std_symbol_header.comment) = store_string ((pl1_stat_$options));
	sym_ptr -> std_symbol_header.text_boundary = "000000000000000010"b;
	sym_ptr -> std_symbol_header.stat_boundary = "000000000000000010"b;

/* generate source map (which has to start on even boundary) */

	cg_static_$sym_pos = cg_static_$sym_pos + mod (cg_static_$sym_pos, 2);

	sym_ptr -> std_symbol_header.source_map = bit (cg_static_$sym_pos, 18);

	map_ptr = addrel (cg_static_$sym_base, cg_static_$sym_pos);
	map_ptr -> source_map.version = 1;
	map_ptr -> source_map.number, n = pl1_stat_$last_source + 1;

	cg_static_$sym_pos = cg_static_$sym_pos + size (map_ptr -> source_map);

	do m = 0 to pl1_stat_$last_source;
	     string (map_ptr -> source_map.map (m + 1).pathname) = store_string (source.pathname);
	     map_ptr -> source_map.map (m + 1).uid = source.uid;
	     map_ptr -> source_map.map (m + 1).dtm = source.dtm;
	end;

/* generate pl1 symbol block */

	sym_ptr -> std_symbol_header.area_pointer = bit (cg_static_$sym_pos, 18);

	info_ptr, sym_ptr = addrel (cg_static_$sym_base, cg_static_$sym_pos);
	sym_reloc_ptr = addrel (cg_static_$sym_reloc_base, cg_static_$sym_pos);

	cg_static_$sym_pos = cg_static_$sym_pos + size (sym_ptr -> pl1_symbol_block);

	sym_ptr -> pl1_symbol_block.version = 1;
	sym_ptr -> pl1_symbol_block.identifier = "pl1info";
	sym_ptr -> pl1_symbol_block.greatest_severity = pl1_stat_$greatest_severity;

	sym_ptr -> pl1_symbol_block.flags.io = cg_static_$io_used;
	sym_ptr -> pl1_symbol_block.flags.map = cg_static_$generate_map;

	string (sym_ptr -> pl1_symbol_block.segname) = store_string ((cg_static_$seg_name));

	if cg_static_$generate_symtab | cg_static_$table_option
	then do;
		sym_ptr -> pl1_symbol_block.flags.table = "1"b;

		sym_ptr -> pl1_symbol_block.root = bit (cg_static_$sym_pos, 18);
	     end;

	if cg_static_$profile_option
	then do;
		sym_ptr -> pl1_symbol_block.flags.profile = "1"b;
		sym_ptr -> pl1_symbol_block.profile = bit (cg_static_$profile_pos, 18);
		sym_reloc_ptr -> pl1_symbol_block.profile = rc_is18;
	     end;

	if cg_static_$long_profile
	then do;
		sym_ptr -> pl1_symbol_block.flags.long_profile = "1"b;
		sym_ptr -> pl1_symbol_block.profile = bit (cg_static_$profile_start, 18);
		sym_reloc_ptr -> pl1_symbol_block.profile = rc_is18;
	     end;

	cg_static_$sym_base -> std_symbol_header.maxi_truncate = bit (cg_static_$sym_pos, 18);

	return;

/* This entry does the following:
		1.  Fills in the linkage section header.  Ref. MSPM BD.7.01
		2.  Fills in the rel bits for the linkage header.
		3.  Transfers and packs the relocation bits generated during compilation into
		    packed regions in the symbol segment.  Ref. MSPM BD.2.01

	Assumptions:
		1. Any field not explicity set will contain 0's.
		2. The relocation code for absolute relocation is assumed to
		   be zero;  when an 18 bit relocation code is assigned to
		   the full relocation word, absolute relocation will be set
		   for the right hand side.	*/

/* because of a glitch in the coding of the Multics checker, the word of
	   of zeros pointed at by the forward chain of the last definition has to
	   be the last word in the definition section */

gen_pl1_symbol$end_symbol:
     entry;

	addrel (cg_static_$def_base, cg_static_$last_def) -> definition.forward = bit (cg_static_$def_pos, 18);
	cg_static_$def_pos = cg_static_$def_pos + 1;

	link_pos = cg_static_$link_pos;

	if link_pos > max_link_size
	then call error (259, null, null);

	link_base = cg_static_$link_base;
	link_reloc_base = cg_static_$link_reloc_base;

	sym_base = cg_static_$sym_base;
	sym_pos = cg_static_$sym_pos;
	sym_ptr = addrel (sym_base, sym_pos);

/* Fill in linkage header information */

	link_base -> link_head.def_base = bit (cg_static_$text_pos, 18);

	link_base -> link_head.first_link = bit (cg_static_$link_begin, 18);

	link_base -> link_head.block_length = bit (cg_static_$link_pos, 18);

	if cg_static_$separate_static
	then link_base -> link_head.static_length = bit (cg_static_$stat_pos, 18);
	else link_base -> link_head.static_length = bit (fixed (cg_static_$link_begin - size (link_head), 18), 18);

/* Fill in rel bits for linkage header */

	link_reloc_base -> reloc (1) = rc_t;

/* Convert relcation bits to packed format */

	sym_base -> std_symbol_header.mini_truncate = bit (sym_pos, 18);

	l = 1;
	sym_rel_bit_count = sym_pos;

	do p = cg_static_$text_reloc_base, cg_static_$def_reloc_base, link_reloc_base, cg_static_$sym_reloc_base;

	     b18 = bit (sym_pos, 18);

	     if l = 1
	     then do;
		     m = cg_static_$text_pos;
		     sym_base -> std_symbol_header.rel_text = b18;
		end;
	     else if l = 2
	     then do;
		     m = cg_static_$def_pos;
		     sym_base -> std_symbol_header.rel_def = b18;
		end;
	     else if l = 3
	     then do;
		     m = link_pos;
		     sym_base -> std_symbol_header.rel_link = b18;
		end;
	     else if l = 4
	     then do;
		     m = sym_rel_bit_count;
		     sym_base -> std_symbol_header.rel_symbol = b18;
		end;

	     m = m * 2;

	     sym_ptr -> relinfo.version = 1;

	     i, k = 0;

	     do j = 0 to m - 1;
		b18 = p -> reloc_in.half_word (j);
		if b18
		then do;
			if k ^= 0
			then do;

/* have a string of "k" consecutive half-words with
			   absolute relocation;  use expanded absolute coding
			   if there are more than 15 half words */

				call expanded_absolute;

				k = 0;
			     end;

			substr (sym_ptr -> relbits, i + 1, 5) = substr (b18, 14, 5);
			i = i + 5;
		     end;
		else k = k + 1;
	     end;

	     if k ^= 0
	     then call expanded_absolute;

	     sym_ptr -> rel_bit_count = i;
	     l = l + 1;

	     j = size (sym_ptr -> relinfo);
	     sym_pos = sym_pos + j;
	     sym_ptr = addrel (sym_ptr, j);
	end;

	cg_static_$sym_pos = sym_pos;

	cg_static_$sym_base -> std_symbol_header.block_size = bit (sym_pos, 18);

	if cg_static_$generate_map
	then string (info_ptr -> pl1_symbol_block.map) = string (cg_static_$statement_map);

	return;

expanded_absolute:
     proc;

	if k < 16
	then i = i + k;
	else do;
		do while (k > 1023);
		     substr (sym_ptr -> relbits, i + 1, 15) = "111101111111111"b;
		     i = i + 15;
		     k = k - 1023;
		end;

		substr (sym_ptr -> relbits, i + 1, 15) = "11110"b || bit (fixed (k, 10), 10);
		i = i + 15;
	     end;
     end expanded_absolute;

store_string:
     proc (str) returns (bit (36));

dcl	str		char (*) aligned;

dcl	p		ptr,
	b36		bit (36),
	based_string	char (length (str)) based aligned;

	if length (str) = 0
	then return ((36)"0"b);

	substr (b36, 1, 18) = bit (cg_static_$sym_pos, 18);
	p = addrel (cg_static_$sym_base, cg_static_$sym_pos);
	p -> based_string = str;
	cg_static_$sym_pos = cg_static_$sym_pos + divide (length (str) + 3, 4, 17, 0);
	substr (b36, 19, 18) = bit (fixed (length (str), 18), 18);
	return (b36);
     end store_string;

     end gen_pl1_symbol$beg_symbol;




		    generate_constant.pl1           10/03/83  1730.5rew 10/03/83  1008.4       40563



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


/* procedure to generate a symbol node for a code generator constant

   Initial Version: 13 September 1971 by BLW
	Modified: 27 April 1972 by BLW
	Modified:	27 July 1973 by RAB	*/

generate_constant: proc(const,n_words) returns(ptr) ;

dcl	const bit(*) aligned,	/* constant to generate */
	n_words fixed bin;		/* number of words to gen, or zero */

dcl	cg_stat$constant_list ptr ext;

dcl	(p,q,pc) ptr,
	(n,n_bits,n_chars,dt) fixed bin,
	(dummy,bs,cs,reloc) bit(1) aligned,
	const_string bit(n_bits) aligned based;

dcl	create_symbol entry(ptr,ptr,bit(3) aligned) returns(ptr);

dcl	(addr,divide,length,null,string) builtin;

%include pl1_tree_areas;
%include cgsystem;
%include reference;
%include symbol;
%include declare_type;
%include data_types;
%include boundary;

	pc = addr(const);
	dt = bit_string;
	bs = "1"b;
	cs, reloc = "0"b;

	if n_words ^= 0 then n = n_words;
	else n = divide(length(const) + bits_per_word - 1,bits_per_word,17,0);

join:	n_bits = n * bits_per_word;

join1:	p = cg_stat$constant_list;
	do while(p ^= null);
	     if p -> symbol.varying then goto loop;

	     if bs
	     then do;
		if ^ p -> symbol.bit then goto loop;
		if p -> symbol.c_dcl_size ^= n_bits then goto loop;
		end;

	     if cs
	     then do;
		if ^ p -> symbol.char then go to loop;
		if p -> symbol.c_dcl_size ^= n_chars then go to loop;
		end;

	     if reloc
	     then if ^ p -> symbol.storage_block
		then go to loop;

	     if p -> symbol.c_word_size >= n
	     then if p -> symbol.initial -> const_string = pc -> const_string
		then goto done;

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

	allocate const_string in(tree_area) set(q);
	q -> const_string = pc -> const_string;

	p = create_symbol(null,null,by_compiler);
	p -> symbol.multi_use = cg_stat$constant_list;
	cg_stat$constant_list = p;

	p -> symbol.c_word_size = n;

	if ^ reloc
	then if n = 2
	     then p -> symbol.boundary = mod2_;
	     else p -> symbol.boundary = word_;
	else if double
	     then p -> symbol.boundary = mod2_;
	     else p -> symbol.boundary = word_;

	p -> symbol.c_bit_size = n_bits;

	if cs
	then do;
	     p -> symbol.char = "1"b;
	     p -> symbol.c_dcl_size = n_chars;
	     end;
	else do;
	     p -> symbol.c_dcl_size = n_bits;
	     if bs then p -> symbol.bit = "1"b;
	     if reloc then p -> symbol.storage_block = "1"b;
	     end;

	p -> symbol.initial = q;
	p -> symbol.constant = "1"b;

	q = p -> symbol.reference;
	q -> reference.c_length = p -> symbol.c_dcl_size;
	if n_bits > bits_per_two_words then q -> reference.long_ref = "1"b;

done:	q = p -> symbol.reference;
	string(q -> reference.bits) = "11"b;
	q -> reference.data_type = dt;
	q -> reference.units = word_;
	q -> reference.no_address = "1"b;
	q -> reference.perm_address = "0"b;
	return(q);

generate_constant$real_fix_bin_1: entry(integer) returns(ptr);

dcl	integer fixed bin;

	pc = addr(integer);
	n = 1;
	dt = real_fix_bin_1;
	bs, cs, reloc = "0"b;
	goto join;

generate_constant$bit_string: entry(const,nb) returns(ptr);

dcl	nb fixed bin;		/* number of bits */

	n_bits = nb;
	n = divide(n_bits + bits_per_word - 1,bits_per_word,17,0);
	bs = "1"b;
	cs, reloc = "0"b;

	pc = addr(const);
	dt = bit_string;
	goto join1;

generate_constant$char_string:	entry(char_const,nc) returns(ptr);

dcl	char_const char(*) aligned,
	nc fixed bin;		/* number of characters in char_const */

	n_chars = nc;
	n_bits = bits_per_char*n_chars;
	n = divide(n_bits + bits_per_word - 1,bits_per_word,17,0);
	bs = "0"b;
	cs = "1"b;
	reloc = "0"b;

	dt = char_string;
	pc = addr(char_const);
	go to join1;

generate_constant$relocatable:	entry(pt,n_words,double) returns(ptr);

dcl	pt ptr,			/* pointer to relocatable constant */
	double bit(1) aligned;	/* "1"b if constant should be on mod2_ boundary */

	/* entry point to generate relocatable constants for EIS descriptors
	   and constant argument lists containing ITP pairs for quick calls */

	n = n_words;
	pc = pt;
	bs, cs = "0"b;
	reloc = "1"b;
	dt = real_fix_bin_1;
	go to join;

	end;




		    generate_definition.pl1         11/20/86  1408.9r w 11/20/86  1145.0       22932



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


/* Procedure to generate a Multics definition

   Initial Version: 19 August 1972 by BLW	*/

generate_definition: proc(name,class,value);

dcl	name char(*) aligned,	/* symbol for definition */
	class fixed bin(3),		/* class of definition */
	value bit(18) aligned;	/* value of definition */

dcl	(cg_static_$def_base,cg_static_$def_reloc_base) ptr ext,
	cg_static_$def_pos fixed bin(18) ext,
	(cg_static_$last_def,cg_static_$zero_def,cg_static_$seg_def) bit(18) aligned ext;

dcl	(b18,def_pos) bit(18) aligned,
	(def_ptr,def_reloc_ptr) ptr;

dcl	(addrel,bit,fixed,size,string) builtin;

dcl	name_assign entry(char(*) aligned) returns(bit(18) aligned);

dcl	1 reloc(0:2)	aligned based,
	2 left		unal bit(18),
	2 right		unal bit(18);

dcl	rel_code(0:3) aligned bit(18) int static
	init("000000000000010000"b,	/* text */
	     "000000000000010010"b,	/* link 18 */
	     "000000000000010110"b,	/* symbol */
	     "000000000000010101"b);	/* definition */

%include relbts;
%include definition;

	b18 = name_assign(name);

	def_pos = bit(cg_static_$def_pos,18);
	def_ptr = addrel(cg_static_$def_base,def_pos);
	def_reloc_ptr = addrel(cg_static_$def_reloc_base,def_pos);

	if cg_static_$last_def then def_ptr -> definition.backward = cg_static_$last_def;
	else def_ptr -> definition.backward = cg_static_$zero_def;

	addrel(cg_static_$def_base,cg_static_$last_def) -> definition.forward = def_pos;

	def_ptr -> definition.forward = cg_static_$zero_def;

	def_ptr -> definition.new = "1"b;
	def_ptr -> definition.symbol = b18;
	def_ptr -> definition.value = value;

	def_ptr -> definition.class = bit(class,3);

	if class = 3 then cg_static_$seg_def = def_pos;
	else do;
	     def_ptr -> definition.segname = cg_static_$seg_def;
	     def_ptr -> definition.entry = bit(fixed(class = 0,1),1);
	     end;

	string(def_reloc_ptr -> reloc(0)) = rc_dp || rc_dp;
	def_reloc_ptr -> reloc(1).left = rel_code(class);
	string(def_reloc_ptr -> reloc(2)) = rc_dp || rc_dp;

	cg_static_$def_pos = cg_static_$def_pos + 3;
	cg_static_$last_def = def_pos;

	end;




		    get_imaginary.pl1               10/03/83  1730.5rew 10/03/83  1008.4       14319



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


get_imaginary:	proc(pt) returns(ptr);

/* Modified: 25 Apr 1979 by PCK to implement 4-bit decimal */

/* Produces a reference to the imaginary part of a complex variable.
   Note that c_length refers to the length of the real and imaginary parts
   combined.  */

dcl	(p,pt,q,s) ptr;

dcl	get_reference entry() returns(ptr);

dcl	(divide,mod) builtin;

%include reference;
%include boundary;
%include symbol;

	q = get_reference();
	p = pt;
	if ^ p -> reference.shared
	     then p -> reference.ref_count = p -> reference.ref_count + 1;
	q -> reference.qualifier = p;
	q -> reference.symbol = p -> reference.symbol;
	q -> reference.c_length = p -> reference.c_length;

	s = p -> reference.symbol;
	q -> reference.c_offset = divide(q -> reference.c_length,2,24,0);

	if s -> symbol.unaligned
	then do;
		q -> reference.units = digit_;
		q -> reference.c_offset = q -> reference.c_offset + mod(q -> reference.c_offset,2);
	     end;
	else q -> reference.units = character_;

	q -> reference.data_type = p -> reference.data_type;
	q -> reference.defined_ref = "1"b;

	return(q);

end;




		    get_reference.pl1               10/03/83  1730.5rew 10/03/83  1008.5       25893



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


/* This procedure is called by various code generator modules to obtain
   a reference node for temporary use.  A list of previously allocated
   nodes is maintained and each call returns the next node on the list.
   If the end of the list is reached, a new node is allocated.

   The program is initialized by the statement
	cg_stat$first_ref, cg_stat$next_ref = null;

   The list of reference nodes will be re-used starting at the begining,
   if the statement
	cg_stat$next_ref = cg_stat$first_ref;
   is executed.

   Initial Version:  3 Februrary 1971 by BLW
	Modified:	30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
		See prepare_operand for details.	*/

get_reference: proc returns(ptr);

dcl	(p,q) ptr,
	n fixed bin,
	(cg_stat$first_ref,cg_stat$next_ref,cg_stat$m_s_p) ptr ext,
	create_list entry(fixed bin) returns(ptr),
	create_reference entry(ptr) returns(ptr),
	(state_man$flush_ref,state_man$flush_address) entry(ptr);

dcl	(null,string) builtin;

%include list;
%include cg_reference;
%include boundary;

	if cg_stat$next_ref = null
	then do;
	     q = create_list(2);
	     p, q -> element(2) = create_reference(null);
	     q -> element(1) = cg_stat$first_ref;
	     cg_stat$first_ref = q;
	     goto l1;
	     end;

	q = cg_stat$next_ref;
	p = q -> element(2);
	cg_stat$next_ref = q -> element(1);

	p -> reference.offset,
	p -> reference.symbol,
	p -> reference.qualifier,
	p -> reference.length = null;

	p -> reference.c_offset,
	p -> reference.c_length,
	p -> reference.data_type = 0;

	p -> reference.value_in.storage = "0"b;
	p -> reference.store_ins = "0"b;

	if cg_stat$m_s_p ^= null
	then do;
	     if string(p -> reference.address_in.b) then call state_man$flush_address(p);
	     if string(p -> reference.value_in) then call state_man$flush_ref(p);
	     end;

l1:	string(p -> reference.bits) = "11"b;	/* padded, aligned */
	string(p -> reference.relocation) = "0"b;
	string(p -> reference.more_bits) = "0"b;

	p -> reference.padded_for_store_ref,
	p -> reference.aligned_for_store_ref = "1"b;

	p -> reference.c_f_offset = 0;

	p -> reference.units = word_;

	string(p -> reference.address) = "0000000000000000000000000001"b;	/* no_address */
	string(p -> reference.info) = "0"b;
	p -> reference.array_ref, p -> reference.varying_ref, p -> reference.shared = "0"b;

	p -> reference.ref_count = 1;

	return(p);

	end;




		    get_single_ref.pl1              07/30/86  0922.8rew 07/28/86  1500.1       18612



/****^  ***********************************************************
        *                                                         *
        * 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-16,Ginter), approve(86-07-16,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 */


/* Initial Version:	7 July 1975 by R. A. Barnes
	Modified:	28 May 1979 by RAB to update reference.address.offset if
		perm_address is on.
	Modified: 17 June 1985 by MM to fix 2110 by calling m_a if
		perm_address isn't on.  Now the perm_address bit will
		always be set after this routine is called.  */

get_single_ref:	proc(p) returns(ptr);

/* this procedure produces a reference to the right half of a double precision
   fixed binary variable so that it can be used with single precision instructions.
   It is called by aq_man, assign_op, and xr_man. */

dcl	(p,q) ptr;
dcl	mod builtin;

dcl	get_reference entry() returns(ptr);
dcl	adjust_ref_count entry(ptr,fixed bin);
dcl	m_a entry (ptr, bit(2) aligned);

%include reference;

	q = get_reference();
	q -> reference = p -> reference;

	if ^q -> reference.perm_address
	then do;
	     call m_a (q, "00"b);			/* fixes 2110 */
	     q -> reference.perm_address = "1"b;
	     end;

	if mod(q->reference.c_offset,2) = 0
	then do;
	     q -> reference.c_offset = q -> reference.c_offset + 1;
	     q -> reference.address.offset = bit(fixed(fixed(q -> reference.address.offset,15) + 1,15),15);
	     end;

	if ^ p -> reference.shared
	     then call adjust_ref_count(p,-1);
	return(q);

end;




		    get_variable.pl1                10/03/83  1730.5rew 10/03/83  1008.5       15354



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


/* procedure to return pointer to reference node of an automatic integer variable

   Initial Version: 12 December 1971 by BLW
	Modified:	20 July 1973 by RAB for EIS
	Modified:	30 March 1980 by RAB for reference.aligned_for_store_ref.
		See prepare_operand for details.	*/

get_variable: proc(pt) returns(ptr);

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

dcl	(p,cb) ptr,
	null builtin,
	create_symbol entry(ptr,ptr,bit(3) aligned) returns(ptr);

dcl	max_string_len_p	init(24) fixed bin int static;

%include block;
%include symbol;
%include reference;
%include data_types;
%include declare_type;

	cb = pt;
	p = create_symbol(cb,null,(by_compiler));
	p -> symbol.c_word_size = 1;
	p -> symbol.c_dcl_size = max_string_len_p;

	p -> symbol.allocate,
	p -> symbol.fixed,
	p -> symbol.binary,
	p -> symbol.real,
	p -> symbol.auto = "1"b;

	p -> symbol.location = cb -> block.last_auto_loc;
	p -> symbol.allocated = "1"b;

	cb -> block.last_auto_loc = cb -> block.last_auto_loc + 1;

	p = p -> symbol.reference;

	p -> reference.data_type = real_fix_bin_1;
	p -> reference.aligned_ref,
	p -> reference.aligned_for_store_ref,
	p -> reference.allocate,
	p -> reference.allocated = "1"b;

	return(p);
	end;




		    initialize_ext_static.pl1       10/03/83  1730.5rew 10/03/83  1008.5       29187



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


/* procedure to initialize external static storage */

initialize_ext_static: proc(pt) returns(bit(18) aligned);

dcl	pt ptr;		/* points at symbol node */

dcl	(d,sym_pt,grow_pt,init_pt) ptr,
	cptr(3) based ptr,
	(n,loc,init_val) fixed bin,
	use_pool bit(1) aligned,
	grow_info bit(18),
	error_$no_text entry(fixed bin,1,2 bit(8),2 bit(14),2 bit(5),ptr),
	initialize_int_static entry(ptr,ptr);

dcl	cg_static_$def_base ptr ext,
	cg_static_$def_pool(0:10) fixed bin(18) ext,
	cg_static_$def_pool_size fixed bin ext,
	cg_static_$def_pos fixed bin(18) ext;

dcl	(addrel,bit,divide,fixed,null) builtin;

dcl	word(0:2) fixed bin based;

%include symbol;
%include reference;
%include boundary;

	sym_pt = pt;
	loc = sym_pt -> symbol.location;

	if sym_pt -> symbol.controlled then goto even;
	if sym_pt -> symbol.boundary = mod2_
	then if ^ sym_pt -> symbol.area
	     then if sym_pt -> symbol.initial ^= null | sym_pt -> symbol.structure
		then
even:		     cg_static_$def_pos = cg_static_$def_pos + mod(cg_static_$def_pos,2);

	grow_info = bit(cg_static_$def_pos,18);
	grow_pt = addrel(cg_static_$def_base,grow_info);
	init_pt = addrel(grow_pt,2);

	if sym_pt -> symbol.controlled
	then do;
	     init_val = 3;
	     n = 6;

	     init_pt -> cptr(1) = null;
	     init_pt -> cptr(2) = null;
	     init_pt -> cptr(3) = null;

	     d = sym_pt -> symbol.descriptor -> reference.symbol;
	     if d -> symbol.controlled
	     then do;
		d -> symbol.location = loc;
		d -> symbol.allocated = "1"b;
		end;

	     call fill_cs(sym_pt -> symbol.son);
	     end;
	else do;
	     n = sym_pt -> symbol.c_word_size;

	     init_val = 0;

	     if sym_pt -> symbol.area
	     then if sym_pt -> symbol.array ^= null
		then goto init;
		else init_val = 4;
	     else do;
		if sym_pt -> symbol.initial ^= null
		then do;
init:		     call initialize_int_static(sym_pt,init_pt);
		     init_val = 3;
		     end;

		call fill_cs(sym_pt -> symbol.son);
		end;
	     end;

	use_pool = init_val = 0 & n <= cg_static_$def_pool_size;
	if use_pool
	then if cg_static_$def_pool(n) ^= 0
	     then return(bit(cg_static_$def_pool(n),18));

	grow_pt -> word(0) = n;
	grow_pt -> word(1) = init_val;

	if use_pool
	     then cg_static_$def_pool(n) = cg_static_$def_pos;

	cg_static_$def_pos = cg_static_$def_pos + 2 + fixed(init_val = 3,1)*n;

	return(grow_info);

fill_cs:	     proc(pt);

dcl	     pt ptr unaligned,
	     p ptr aligned;

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

		if (p -> symbol.initial ^= null | p -> symbol.area) & sym_pt -> symbol.static
		then do;
		     call initialize_int_static(p,init_pt);
		     init_val = 3;
		     end;

		p -> symbol.location = loc;

		call fill_cs(p -> symbol.son);

		p = p -> symbol.brother;
		end;

	     end;

	end;




		    initialize_int_static.pl1       09/19/89  1224.3rew 09/19/89  1013.6      149868



/****^  ***********************************************************
        *                                                         *
        * 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-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
     install(89-09-19,MR12.3-1068):
     Fix bug 1884.
                                                   END HISTORY COMMENTS */


/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
initialize_int_static:
     proc (s, address);

/* Modified 770629 by PG to fix 1606 (not diagnosing multiple initial values for scalar)
/* Modified 771102 by PG to diagnose wrong number of initial elements for arrays
/* Modified 14 July 1978 by PCK for unsigned binary
/* Modified: 25 Apr 1979 by PCK to implement 4-bit decimal
/* Modified: 07 Mar 89 by RW internal static bit strings incorrectly initialized
*/

dcl      (
         s,
         address,
         stack (128),
         v,
         r,
         a,
         b
         ) ptr;
dcl      (total_array_elements, total_initial_elements) fixed bin (24);
dcl      (offset, units, index, k, i) fixed bin (15);
dcl      area_size fixed bin (31);
dcl      (sub, high, low, multiplier) (128) fixed bin (15);

dcl      1 initial aligned based,			/* this must map into storage */
	 2 node_type unaligned bit (9),		/* as if it were a 3 element */
	 2 reserved bit (12) unaligned,
	 2 number fixed (14) unaligned,		/* list node.		*/
	 2 factor fixed (17) unaligned,
	 2 index fixed (17) unaligned,
	 2 value ptr unaligned,
	 2 next ptr unaligned;

dcl      1 area_target based (address) aligned,
	 2 spacer (offset) fixed bin,
	 2 (z1, z2) fixed bin,
	 2 size fixed bin,
	 2 z3 fixed bin;

dcl      1 new_area_target aligned based (address),
	 2 spacer (offset) fixed bin,
	 2 image area (area_size);

dcl      (null, bit, char, abs, addr, min, empty, unspec) builtin;
dcl      create_token entry (char (*), bit (9) aligned) returns (ptr);
dcl      error_$no_text entry (fixed bin (15), 1, 2 bit (8), 2 bit (14), 2 bit (5), ptr);
dcl      token_to_binary entry (ptr) returns (fixed bin);

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

dcl      cg_static_$null_value bit (72) ext aligned,
         cg_static_$packed_null_value bit (36) ext aligned,
         cg_static_$offset_null_value bit (36) ext aligned;

dcl      (fixed, substr, string) builtin;

%include symbol;
%include array;
%include reference;
%include token;
%include token_types;
%include list;
%include operator;
%include system;
%include nodes;

/* program */

	r = s -> symbol.reference;

	if ^s -> symbol.area then do;
	     v = s -> symbol.initial;
	     if v = null then
		return;

	     if s -> symbol.label then
		call print (320);
	     if s -> symbol.entry then
		call print (322);

	     if v -> node.type ^= list_node then
		call print (323);
	end;

	if ^s -> symbol.dimensioned then do;
	     offset = r -> reference.c_offset;
	     units = r -> reference.units;

	     if s -> symbol.area then
		if ^pl1_stat_$use_old_area then do;
		     area_size = s -> symbol.c_dcl_size;
		     new_area_target.image = empty;
		end;
		else do;
		     area_target.z1, area_target.z2, area_target.z3 = 0;
		     area_target.size = s -> symbol.c_dcl_size;
		end;
	     else do;
unravel:						/* We are initializing a scalar. Make sure only one initial element */
						/* has been speicified. */
		if v -> list.element (3) ^= null then
		     call print (442);

		if v -> list.element (1) -> node.type ^= token_node then
		     call print (442);

		if v -> list.element (1) -> token.type ^= dec_integer then
		     call print (442);

		if token_to_binary ((v -> list.element (1))) ^= 1 then
		     call print (442);

		if v -> list.element (2) ^= null then
		     if v -> list.element (2) -> node.type = list_node then do;
			v = v -> list.element (2);
			go to unravel;
		     end;

		call assignf ((v -> list.element (2)));
	     end;

	     return;
	end;

/* this is an array, call compile to pre-process the initial attribute. */

	a = s -> symbol.array;
	total_initial_elements = 0;

	if ^s -> symbol.area then
	     if ^compile (v, total_initial_elements) then
		call print (324);

/* walk through the bounds to collect vectors of bounds, initial subscripts,and multipliers. */

	k, index = 0;
	total_array_elements = 1;
	do b = a -> array.bounds repeat (b -> bound.next) while (b ^= null);
	     index = index + 1;
	     sub (index), low (index) = b -> bound.c_lower;
	     high (index) = b -> bound.c_upper;
	     total_array_elements = total_array_elements * (b -> bound.c_upper - b -> bound.c_lower + 1);
	     multiplier (index) = b -> bound.c_multiplier;
	end;

	if ^s -> symbol.area & (total_array_elements ^= total_initial_elements) then
	     call print (292);			/* wrong number of initial elements for array */

/* simulate the effect of a nest of do loops written as:

	do i(n) = lbound(a,n) to hbound(a,n);
	do i(n-1) = lbound(a,n-1) to hbound(a,n-1);
	do i(n-2) = lbound(a,n-2) to hbound(a,n-2);
		.
		.
		.
	do i(1) = lbound(a,1) to hbound(a,1);
	a(i(n),i(n-1),i(n-2),...i(1)) = value from initial attribute;
	end all loops;
							*/

next:
	call subscript;

	if s -> symbol.area then
	     if ^pl1_stat_$use_old_area then do;
		area_size = s -> symbol.c_dcl_size;
		new_area_target.image = empty;
	     end;
	     else do;
		area_target.z1, area_target.z2, area_target.z3 = 0;
		area_target.size = s -> symbol.c_dcl_size;
	     end;
	else
	     call assignf ((next_value ()));

	sub (1) = sub (1) + 1;
	if sub (1) <= high (1) then
	     go to next;
	i = 1;

overflow:
	sub (i) = low (i);
	i = i + 1;
	if i > index then
	     return;
	sub (i) = sub (i) + 1;
	if sub (i) > high (i) then
	     go to overflow;
	go to next;

/* Subroutine to compile the initial attribute. The chain of list nodes is overwritten with a chain of
   "initial" nodes, with the repetition factors converted to binary. */

compile:
     proc (p, n) returns (bit (1) aligned);

/* parameters */

declare	(
	p ptr,
	n fixed bin (24)
	) parameter;

/* automatic */

declare	(f, q, t) ptr,
	k fixed bin (24);

/* program */

	do q = p repeat (q -> initial.next) while (q ^= null);
	     f = q -> list.element (1);
	     if f -> node.type = token_node then do;
		if f -> token.type ^= dec_integer then
		     go to fail;
		q -> initial.factor = token_to_binary (f);
	     end;
	     else
		go to fail;

	     q -> initial.index = 0;
	     t = q -> initial.value;

	     if t ^= null then
		if t -> node.type = list_node then do;
		     k = 0;
		     if ^compile (t, k) then
			go to fail;

		     n = n + q -> initial.factor * k;
		end;
		else
		     n = n + q -> initial.factor;
	     else
		n = n + q -> initial.factor;
	end;
	return ("1"b);
fail:
	return ("0"b);
     end;

/* subroutine to extract the next value from a pre-processed initial attribute. */

next_value:
     proc returns (ptr);

dcl      lv ptr;

	lv = v;

begin:
	if lv = null then
	     return (null);
ok:
	if lv -> initial.factor = lv -> initial.index /* done with this batch, pop back up */ then do;
	     lv -> initial.index = 0;
	     v, lv = lv -> initial.next;
	     if lv ^= null then
		goto ok;

	     if k = 0 then
		call print (292);			/* can't happen because we already checked, but... */

	     v, lv = stack (k);
	     k = k - 1;
	     go to begin;
	end;
	lv -> initial.index = lv -> initial.index + 1;
	if lv -> initial.value = null then
	     return (null);				/* asterisk as value */
	if lv -> initial.value -> node.type = list_node then do;
	     k = k + 1;
	     stack (k) = lv;
	     v, lv = lv -> initial.value;
	     go to begin;

	end;
	return (lv -> initial.value);
     end;

/* subroutine to develop the offset of an array element. */

subscript:
     proc;

dcl      (factor, sunits, off, i) fixed bin (15);
dcl      convert (5, 5) fixed bin (15, 1) int static
	    initial (1, 4.5, 9, 18, 36, 4.5, 1, 2, 4, 8, 9, 2, 1, 2, 4, 18, 4, 2, 1, 2, 36, 8, 4, 2, 1);

	factor = 1;
	units = r -> reference.units;
	sunits = a -> array.offset_units;
	off = r -> reference.c_offset;
	if off = 0 then
	     units = sunits;
	else if units > sunits then do;
	     off = off * convert (units, sunits);
	     units = sunits;
	end;
	else
	     factor = convert (units, sunits);
	off = off - a -> array.c_virtual_origin * factor;
	do i = 1 to index;
	     off = off + sub (i) * multiplier (i) * factor;
	end;
	offset = off;
     end subscript;

/* subroutine to assign a value to static storage referenced by address. */

assignf:
     proc (pv);

dcl      convert (0:5) fixed bin (15, 1) int static initial (36, 1, 4.5, 9, 18, 36);
dcl      (v, pv, sym, inptr, pp) ptr;
dcl      op char (1);
dcl      not_complex bit (1);
dcl      (insize, tsize) fixed bin (31);
dcl      (word_offset, bit_offset) fixed bin;
dcl      t fixed bin (6);
dcl      value1 bit (2294);
dcl      value2 char (256) aligned;
dcl      char1 char (1) based;
dcl      char_image char (insize) based aligned;
dcl      bit_image bit (insize) based aligned;

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

dcl      intype fixed bin (31);

dcl      inscale_prec fixed bin (31),
         tscale_prec fixed bin (31);

dcl      1 info based (addr (inscale_prec)),
	 2 inscale fixed bin (17) unal,
	 2 inprec fixed bin (17) unal,
         1 outfo based (addr (tscale_prec)),
	 2 tscale fixed bin (17) unal,
	 2 tprec fixed bin (17) unal;

dcl      char_to_numeric_ entry (ptr, fixed bin (31), fixed bin (31), ptr, fixed bin (31)),
         assign_ entry (ptr, fixed bin (31), fixed bin (31), ptr, fixed bin (31), fixed bin (31)),
         pack_picture_ entry (char (*), char (*), char (*) aligned);


dcl      (
         add init ("000010001"b),			/* opnd(1) <- opnd(2) + opnd(3) */
         sub init ("000010010"b)
         ) /* opnd(1) <- opnd(2) - opnd(3) */ bit (9) aligned int static;

dcl      1 char_target aligned based (address),
	 2 spacer unal bit (bit_offset),
	 2 image unal char (tsize);

dcl      1 bit_target aligned based (address),
	 2 spacer unal bit (bit_offset),
	 2 image unal bit (tsize);

dcl      1 ptr_target based (address),
	 2 spacer (word_offset) fixed bin,
	 2 image ptr;

dcl      1 packed_ptr_target aligned based (address),
	 2 spacer unal bit (bit_offset),
	 2 image unal ptr;

dcl      1 offset_target aligned based (address),
	 2 spacer unal bit (bit_offset),
	 2 image unal offset;

dcl      1 arith_target aligned based (address),
	 2 spacer unal bit (bit_offset),
	 2 image unal bit (1);

dcl      1 varying_target based (address),
	 2 spacer (word_offset - 1) fixed bin,
	 2 image fixed bin (15);

dcl      map_type (24:28) fixed bin (31) int static init (42,
						/* character */
	    18,					/* real fixed dec */
	    22,					/* cplx fixed dec */
	    20,					/* real float dec */
	    24 /* cplx float dec */);

%include picture_image;
%include pl1_descriptor_type_fcn;

	v = pv;
	if v = null then
	     return;

	sym = s;
	word_offset = offset;

	if sym -> symbol.varying then
	     word_offset = word_offset + 1;
	bit_offset = word_offset * convert (units);
	not_complex = "1"b;

	if v -> node.type = symbol_node then do;
	     insize, tsize = v -> symbol.c_bit_size;
	     bit_target.image = v -> symbol.initial -> bit_image;
	     return;
	end;

	if sym -> symbol.ptr then do;
	     if is_null () then
		if sym -> symbol.packed then
		     unspec (packed_ptr_target.image) = cg_static_$packed_null_value;
		else
		     unspec (ptr_target.image) = cg_static_$null_value;
	     return;
	end;

	if sym -> symbol.offset then do;
	     if is_null () then
		unspec (offset_target.image) = cg_static_$offset_null_value;
	     return;
	end;

	on conversion, size, fixedoverflow, overflow go to error1;
	on stringsize call print (-347);

	tsize = sym -> symbol.c_dcl_size;

	if v -> node.type = operator_node then do;
	     if v -> operator.op_code = add then
		op = "+";
	     else if v -> operator.op_code = sub then
		op = "-";
	     else
		call print (324);
	     if v -> operator.operand (2) -> node.type = token_node
		& v -> operator.operand (3) -> node.type = token_node then do;
		not_complex = "0"b;
		v = create_token (v -> operator.operand (2) -> token.string || op
		     || v -> operator.operand (3) -> token.string, (char_string));
	     end;
	     else
		call print (324);
	end;
	if v -> node.type ^= token_node then
	     call print (324);

	if (v -> token.type & is_constant) = "0"b then
	     call print (324);
	insize = v -> token.size;

	if (v -> token.type & is_arithmetic_constant) = is_arithmetic_constant then do;
	     if sym -> symbol.fixed | sym -> symbol.float then
		go to l1;

	     call char_to_numeric_ (addr (value1), intype, inscale_prec, addr (v -> token.string), insize);
	end;

	if sym -> symbol.char then do;
	     if (v -> token.type & is_arithmetic_constant) = is_arithmetic_constant then do;
		call print (-233);
		call assign_ (addr (value2), 21 * 2, tsize, addr (value1), intype, inscale_prec);
		insize = inprec;
(stringsize):
		char_target.image = addr (value2) -> char_image;
	     end;

	     if v -> token.type = bit_string then do;
(stringsize):
		char_target.image = char (bit (substr (v -> token.string, 1, v -> token.size - 1)));
		call print (-486);
	     end;
	     else if v -> token.type = char_string then
(stringsize):
		char_target.image = v -> token.string;

	     if sym -> symbol.varying then
		varying_target.image = min (insize, tsize);

	     return;
	end;

	if sym -> symbol.bit then do;
	     if (v -> token.type & is_arithmetic_constant) = is_arithmetic_constant then do;
		call print (-233);
		call assign_ (addr (value2), 19 * 2, tsize, addr (value1), intype, inscale_prec);
		insize = inprec;
(stringsize):
		bit_target.image = addr (value2) -> bit_image;
	     end;
	     else if v -> token.type = bit_string then do;
		insize = v -> token.size - 1;		/* used below if varying */
(stringsize):
		bit_target.image = bit (substr (v -> token.string, 1, insize));
	     end;
	     else if v -> token.type = char_string then do;
(stringsize):
		bit_target.image = bit (v -> token.string);
		call print (-488);
	     end;

	     if sym -> symbol.varying then
		varying_target.image = min (insize, tsize);
	     return;
	end;

	if sym -> symbol.picture then do;
	     if v -> token.type = bit_string then do;
		inscale_prec, insize = insize - 1;
		addr (value1) -> bit_image = bit (substr (v -> token.string, 1, insize));
		intype = 19 * 2;
	     end;

	     if v -> token.type = char_string then do;
		intype = 21 * 2;
		inscale_prec = insize;
		inptr = addr (v -> token.string);
	     end;
	     else
		inptr = addr (value1);

	     pp = sym -> symbol.general -> reference.symbol -> symbol.initial;

	     tscale_prec =
		pp -> picture_image.prec + 262144 * (pp -> picture_image.scale - pp -> picture_image.scalefactor);

	     call assign_ (addr (value2), map_type (pp -> picture_image.type), tscale_prec, inptr, intype, inscale_prec)
		;
	     call pack_picture_ (char_target.image, pp -> char1, value2);

	     return;
	end;


/* this is an arithmetic target. */

	if ((v -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant) & not_complex then
	     call print (-235);

l1:
	tprec = sym -> symbol.c_dcl_size;
	tscale = sym -> symbol.scale;
	t = pl1_descriptor_type (substr (string (sym -> symbol.attributes), 1, 36), sym -> symbol.c_dcl_size);

	call assign_ (addr (arith_target.image), t * 2 + fixed (sym -> symbol.packed), tscale_prec,
	     addr (v -> token.string), 21 * 2, (v -> token.size));

	return;
error1:
	call print (260);


is_null:
	proc () returns (bit (1) aligned);

	     if v -> node.type = reference_node then
		v = v -> reference.symbol;

	     if v -> node.type = token_node then
		if v -> token.type = identifier then
		     if v -> token.string = "null" then
			return ("1"b);

	     call print (341);
	     return ("0"b);

	end is_null;


     end assignf;

/* subroutine to print error messages. */

print:
     proc (m);

dcl      m fixed bin (15);

	call error_$no_text (abs (m), s -> symbol.source_id, s);
	if m > 0 then
	     go to exit;
     end;
exit:
     end /* initialize_int_static */;




		    inline_operation.pl1            10/03/83  1730.5rew 10/03/83  1008.5       19431



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


/* This procedure decides if an operation can be done inline
   or if it requires the generation of a call

   Initial Version: 25 October 1972 by BLW	*/

inline_operation: proc(node_pt,ref,atom) returns(bit(1) aligned);

dcl	node_pt ptr,		/* points at operator node */
	ref(3) ptr,		/* ptrs to reference nodes for operands */
	atom(3) bit(1) aligned;	/* "1"b if operand(i) atomic */

dcl	(null,string) builtin,
	complex_operand(3) bit(1) unaligned;

dcl	compile_exp$save entry(ptr) returns(ptr);

%include reference;
%include symbol;
%include operator;
%include data_types;
%include op_codes;

	string(complex_operand) = "0"b;

	if ref(1) ^= null then call test(1);

	call test(2);

	if node_pt -> operator.number = 3 then call test(3);

	if string(complex_operand)
	then do;

	     if node_pt -> operator.op_code = abs_fun then goto no;

	     if ^ complex_operand(2)
	     then if ref(2) -> reference.data_type ^= real_flt_bin_1
		then goto no;

	     if node_pt -> operator.number = 3
	     then if ^ complex_operand(3)
		then if ref(3) -> reference.data_type ^= real_flt_bin_1
		     then goto no;
	     end;

yes:	return("1"b);

no:	return("0"b);

test:	     proc(k);

dcl	     k fixed bin,
	     (p,s) ptr;

	     p = ref(k);
	     s = p -> reference.symbol;

	     if s -> symbol.decimal then goto no;

	     if s -> symbol.complex
	     then do;
		if p -> reference.data_type ^= complex_flt_bin_1 then goto no;
		complex_operand(k) = "1"b;
		if k > 1
		then if ^ atom(k)
		then if ^ p -> reference.aligned_ref
		then do;
		     ref(k) = compile_exp$save((node_pt -> operand(k)));
		     atom(k) = "1"b;
		     end;
		end;

	     end;

	end;




		    instruction_info.alm            10/03/83  1730.5rew 10/03/83  1008.3      155034



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

" instruction information segment - BLW - August, 1970
" Modified 791029 by PG to introduce fl and fx bits.
" Modified 791220 by RAB to allow du modification for index register instructions.
" Modified 800109 by PG to add operator info.
" Modified 800225 by PG to add w flag.
" Modified 800908 by MND to indicate tsp5 modifies pr5 not pr4, tsp7 modifies pr7 not pr6,
"	and spl doesn't change indicators (i bit was on).
"
	name	instruction_info
	segdef	instruction_info
"
" Following bits encode which parts of machine state are altered by an instruction
"
	bool	a,400000
	bool	q,200000

" The indicator (i) bit is used as follows:
"	If a register & the indicators are modified, then the instruction
"	is assumed to set the indicators for that register.
"	Else if no registers are modified, then the instruction invalidates
"	the indicators.
"
"	If fx, then the indicators are for fixed-point.
"	Else if fl, then the indicators are for floating-point.
"	Else if i then the indicators are for logical data.
"
"	Arithmetic data (fx | fl) requires the Zero and Negative indicators.
"	Logical data requires the Zero, Negative, and Carry indicators.
"	The behavior of the other indicators does not matter.
"
	bool	i,100000
	bool	aq,a+q
"
	bool	bp,40000
	bool	lp,20000
	bool	ab,10000
	bool	bb,4000
	bool	lb,2000
	bool	sb,1000
	bool	ap,0
	bool	sp,0
	bool	bases,ap+bp+lp+sp+ab+bb+lb+sb
"
	bool	x0,400
	bool	x1,200
	bool	x2,100
	bool	x3,40
	bool	x4,20
	bool	x5,10
	bool	x6,4
	bool	x7,2
	bool	indices,x0+x1+x2+x3+x4+x5+x6+x7
"
	bool	dr,1
"
	bool	all,aq+i+bases+indices+dr

"
" Following bit indicates if an instruction can use a du|dl modifier
"
	bool	d,400000
"
" Following bit indicates that an instruction performs a fixed-point
" modification of the Q or AQ register, and sets the Zero and Negative
" indicators valid for the Q or AQ.
"
	bool	fx,200000		DL
"
" Following bit indicates that an instruction performs a floating-point
" modification of the EAQ register, and sets the Zero and Negative
" indicators valid for the EAQ.
"
	bool	fl,100000		DL
"
" Following bit indicates that an instruction invalidates either
" the Zero, Negative, or Carry indicator (or any combination),
" and does not update them upon completion. The implementation
" of this flag is incomplete...it is used only by the ADE and LDE
" instructions in this version of the tables.
"
	bool	w,40000		DL
"
" The following bit indicates that the instruction
" modifies whatever base register is specified
" in the top three bits, regardless of the state of
" bit 29. This is used for the aXbd, sXbd class of things

	bool	some_base,40000	DL
"
instruction_info:
	zero	all
	zero	all	mme
	zero	all	drl
	zero	all
	zero	all	mme2
	zero	all	mme3
	zero	all
	zero	all	mme4
	zero	all
	zero	0	nop
	zero	all
	zero	0,d	puls1
	zero	0,d	puls2
	zero	all	cioc
	zero	all
	zero	all
	zero	i+x0,d	adlx0
	zero	i+x1,d	adlx1
	zero	i+x2,d	adlx2
	zero	i+x3,d	adlx3
	zero	i+x4,d	adlx4
	zero	i+x5,d	adlx5
	zero	i+x6,d	adlx6
	zero	i+x7,d	adlx7
	zero	all
	zero	all
	zero	i+q	ldqc
	zero	aq+i,d+fx	adl
	zero	i+a	ldac
	zero	a+i,d	adla
	zero	q+i,d+fx	adlq
	zero	aq+i,fx	adlaq
	zero	i	asx0
	zero	i	asx1
	zero	i	asx2
	zero	i	asx3
	zero	i	asx4
	zero	i	asx5
	zero	i	asx6
	zero	i	asx7
	zero	ap,d	adwpap
	zero	ab,d	adwpab
	zero	bp,d	adwpbp
	zero	bb,d	adwpbb
	zero	i	aos
	zero	i	asa
	zero	i	asq
	zero	all	sscr
	zero	i+x0,d	adx0
	zero	i+x1,d	adx1
	zero	i+x2,d	adx2
	zero	i+x3,d	adx3
	zero	i+x4,d	adx4
	zero	i+x5,d	adx5
	zero	i+x6,d	adx6
	zero	i+x7,d	adx7
	zero	all
	zero	a+i,d	awca
	zero	q+i,d	awcq
	zero	all	lreg
	zero	all
	zero	a+i,d	ada
	zero	q+i,d+fx	adq
	zero	aq+i,fx	adaq
	zero	i,d	cmpx0
	zero	i,d	cmpx1
	zero	i,d	cmpx2
	zero	i,d	cmpx3
	zero	i,d	cmpx4
	zero	i,d	cmpx5
	zero	i,d	cmpx6
	zero	i,d	cmpx7
	zero	all
	zero	i,d	cwl
	zero	all
	zero	all
	zero	all
	zero	i,d	cmpa
	zero	i,d	cmpq
	zero	i	cmpaq
	zero	i+x0,d	sblx0
	zero	i+x1,d	sblx1
	zero	i+x2,d	sblx2
	zero	i+x3,d	sblx3
	zero	i+x4,d	sblx4
	zero	i+x5,d	sblx5
	zero	i+x6,d	sblx6
	zero	i+x7,d	sblx7
	zero 	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	a+i,d	sbla
	zero	q+i,d+fx	sblq
	zero	aq+i,fx	sblaq
	zero	i	ssx0
	zero	i	ssx1
	zero	i	ssx2
	zero	i	ssx3
	zero	i	ssx4
	zero	i	ssx5
	zero	i	ssx6
	zero	i	ssx7
	zero	lp,d	adwplp
	zero	lb,d	adwplb
	zero	sp,d	adwpsp
	zero	sb,d	adwpsb
	zero	all	sdbr
	zero	i	ssa
	zero	i	ssq
	zero	all
	zero	i+x0,d	sbx0
	zero	i+x1,d	sbx1
	zero	i+x2,d	sbx2
	zero	i+x3,d	sbx3
	zero	i+x4,d	sbx4
	zero	i+x5,d	sbx5
	zero	i+x6,d	sbx6
	zero	i+x7,d	sbx7
	zero	all
	zero	a+i,d	swca
	zero	q+i,d	swcq
	zero	bases	lpri
	zero	all
	zero	a+i,d	sba
	zero	q+i,d+fx	sbq
	zero	aq+i,fx	sbaq
	zero	i,d	cnax0
	zero	i,d	cnax1
	zero	i,d	cnax2
	zero	i,d	cnax3
	zero	i,d	cnax4
	zero	i,d	cnax5
	zero	i,d	cnax6
	zero	i,d	cnax7
	zero	all
	zero	i	cmk
	zero	i+a	absa
	zero	i+aq	epaq
	zero	i,d	sznc
	zero	i,d	cnaa
	zero	i,d	cnaq
	zero	i	cnaaq
	zero	i+x0,d	ldx0
	zero	i+x1,d	ldx1
	zero	i+x2,d	ldx2
	zero	i+x3,d	ldx3
	zero	i+x4,d	ldx4
	zero	i+x5,d	ldx5
	zero	i+x6,d	ldx6
	zero	i+x7,d	ldx7
	zero	all	lbar
	zero	all	rsw
	zero	all	ldbr
	zero	all	rmcm
	zero	i,d	szn
	zero	a+i,d	lda
	zero	q+i,d+fx	ldq
	zero	aq+i,fx	ldaq
	zero	i	orsx0
	zero	i	orsx1
	zero	i	orsx2
	zero	i	orsx3
	zero	i	orsx4
	zero	i	orsx5
	zero	i	orsx6
	zero	i	orsx7
	zero	0	spriap
	zero	0	spbpap
	zero	0	spribp
	zero	0	spbpbp
	zero	0	spri
	zero	i	orsa
	zero	i	orsq
	zero	all	lsdp
	zero	i+x0,d	orx0
	zero	i+x1,d	orx1
	zero	i+x2,d	orx2
	zero	i+x3,d	orx3
	zero	i+x4,d	orx4
	zero	i+x5,d	orx5
	zero	i+x6,d	orx6
	zero	i+x7,d	orx7
	zero	ap	tspap
	zero	ab	tspab
	zero	bp	tspbp
	zero	bb	tspbb
	zero	all
	zero	a+i,d	ora
	zero	q+i,d	orq
	zero	aq+i	oraq
	zero	i,d	canx0
	zero	i,d	canx1
	zero	i,d	canx2
	zero	i,d	canx3
	zero	i,d	canx4
	zero	i,d	canx5
	zero	i,d	canx6
	zero	i,d	canx7
	zero	ap	eawpap
	zero	ap	easpap
	zero	bp	eawpbp
	zero	bp	easpbp
	zero	all
	zero	i,d	cana
	zero	i,d	canq
	zero	i	canaq
	zero	i+x0,d	lcx0
	zero	i+x1,d	lcx1
	zero	i+x2,d	lcx2
	zero	i+x3,d	lcx3
	zero	i+x4,d	lcx4
	zero	i+x5,d	lcx5
	zero	i+x6,d	lcx6
	zero	i+x7,d	lcx7
	zero	lp	eawplp
	zero	lp	easplp
	zero	sp	eawpsp
	zero	sp	easpsp
	zero	all
	zero	a+i,d	lca
	zero	q+i,d+fx	lcq
	zero	aq+i,fx	lcaq
	zero	i	ansx0
	zero	i	ansx1
	zero	i	ansx2
	zero	i	ansx3
	zero	i	ansx4
	zero	i	ansx5
	zero	i	ansx6
	zero	i	ansx7
	zero	ap	eppap
	zero	ab	epbpab
	zero	bp	eppbp
	zero	bb	epbpbb
	zero	i	stac
	zero	i	ansa
	zero	i	ansq
	zero	0	stcd
	zero	i+x0,d	anx0
	zero	i+x1,d	anx1
	zero	i+x2,d	anx2
	zero	i+x3,d	anx3
	zero	i+x4,d	anx4
	zero	i+x5,d	anx5
	zero	i+x6,d	anx6
	zero	i+x7,d	anx7
	zero	lp	epplp
	zero	lb	epbplb
	zero	sp	eppsp
	zero	sb	epbpsb
	zero	all
	zero	a+i,d	ana
	zero	q+i,d	anq
	zero	aq+i	anaq
	zero	all
	zero	aq+i,d+fx	mpf
	zero	aq+i,d+fx	mpy
	zero	all
	zero	all
	zero	i,d	cmg
	zero	all
	zero	all
	zero	all
	zero	aq,d+w	lde
	zero	all
	zero	all	rscr
	zero	all
	zero	aq,d+w	ade
	zero	all
	zero	all
	zero	all
	zero	aq+i,d+fl	ufm
	zero	all
	zero	aq+i,fl	dufm
	zero	all
	zero	i,d	fcmg
	zero	all
	zero	i	dfcmg
	zero	i,d	fszn
	zero	aq+i,d+fl	fld
	zero	all
	zero	aq+i,fl	dfld
	zero	all
	zero	aq+i,d+fl	ufa
	zero	all
	zero	aq+i,fl	dufa
	zero	0	sxl0
	zero	0	sxl1
	zero	0	sxl2
	zero	0	sxl3
	zero	0	sxl4
	zero	0	sxl5
	zero	0	sxl6
	zero	0	sxl7
	zero	0	stz
	zero	all	smic
	zero	all	scpr
	zero	all
	zero	all	stt
	zero	0	fst
	zero	0	ste
	zero	0	dfst
	zero	all
	zero	aq+i,d+fl	fmp
	zero	all
	zero	aq+i,fl	dfmp
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i	fstr
	zero	aq+i,fl	frd
	zero	i	dfstr
	zero	aq+i,fl	dfrd
	zero	all
	zero	aq+i,d+fl	fad
	zero	all
	zero	aq+i,fl	dfad
	zero	all	rpl
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all	bcd
	zero	aq+i,d+fx	div
	zero	aq+i,d	dvf
	zero	all
	zero	all
	zero	all
	zero	aq+i,fl	fneg
	zero	all
	zero	i,d	fcmp
	zero	all
	zero	i	dfcmp
	zero	all	rpt
	zero	all
	zero	all
	zero	all
	zero	all
	zero	aq+i,d+fl	fdi
	zero	all
	zero	aq+i,fl	dfdi
	zero	all
	zero	a+i	neg
	zero	all	cams
	zero	aq+i,fx	negl
	zero	all
	zero	aq+i,d+fl	ufs
	zero	all
	zero	aq+i,fl	dufs
	zero	0	sprpap
	zero	0	sprpab
	zero	0	sprpbp
	zero	0	sprpbb
	zero	0	sprplp
	zero	0	sprplb
	zero	0	sprpsp
	zero	0	sprpsb
	zero	all	sbar
	zero	0	stba
	zero	0	stbq
	zero	all	smcm
	zero	0	stc1
	zero	all
	zero	all
	zero	all	ssdp
	zero	all	rpd
	zero	all
	zero	all
	zero	all
	zero	all
	zero	aq+i,d+fl	fdv
	zero	all
	zero	aq+i,fl	dfdv
	zero	all
	zero	all
	zero	all
	zero	aq+i,fl	fno
	zero	all
	zero	aq+i,d+fl	fsb
	zero	all
	zero	aq+i,fl	dfsb
	zero	0	tze
	zero	0	tnz
	zero	0	tnc
	zero	0	trc
	zero	0	tmi
	zero	0	tpl
	zero	all
	zero	0	ttf
	zero	all	rtcd
	zero	all
	zero	all
	zero	all	rcu
	zero	0	teo
	zero	0	teu
	zero	all	dis
	zero	0	tov
	zero	i+x0	eax0
	zero	i+x1	eax1
	zero	i+x2	eax2
	zero	i+x3	eax3
	zero	i+x4	eax4
	zero	i+x5	eax5
	zero	i+x6	eax6
	zero	i+x7	eax7
	zero	all	ret
	zero	all
	zero	all
	zero	all	rccl
	zero	i	ldi
	zero	a+i	eaa
	zero	q+i	eaq
	zero	i	ldt
	zero	i	ersx0
	zero	i	ersx1
	zero	i	ersx2
	zero	i	ersx3
	zero	i	ersx4
	zero	i	ersx5
	zero	i	ersx6
	zero	i	ersx7
	zero	0	sprilp
	zero	0	spbplb
	zero	0	sprisp
	zero	0	spbpsb
	zero	i	stacq
	zero	i	ersa
	zero	i	ersq
	zero	all	scu
	zero	i+x0,d	erx0
	zero	i+x1,d	erx1
	zero	i+x2,d	erx2
	zero	i+x3,d	erx3
	zero	i+x4,d	erx4
	zero	i+x5,d	erx5
	zero	i+x6,d	erx6
	zero	i+x7,d	erx7
	zero	aq+i+bases	tsplp
	zero	lb	tsplb
	zero	sp	tspsp
	zero	sb	tspsb
	zero	all	lcpr
	zero	a+i,d	era
	zero	q+i,d	erq
	zero	aq+i	eraq
	zero	x0	tsx0
	zero	x1	tsx1
	zero	x2	tsx2
	zero	x3	tsx3
	zero	x4	tsx4
	zero	x5	tsx5
	zero	x6	tsx6
	zero	x7	tsx7
	zero	0	tra
	zero	all
	zero	all
	zero	all	callsp
	zero	all
	zero	all	tss
	zero	all	xec
	zero	all	xed
	zero	i+x0,d	lxl0
	zero	i+x1,d	lxl1
	zero	i+x2,d	lxl2
	zero	i+x3,d	lxl3
	zero	i+x4,d	lxl4
	zero	i+x5,d	lxl5
	zero	i+x6,d	lxl6
	zero	i+x7,d	lxl7
	zero	all
	zero	a+i	ars
	zero	q+i,fx	qrs
	zero	aq+i,fx	lrs
	zero	all
	zero	a+i	als
	zero	q+i	qls
	zero	aq+i	lls
	zero	0	stx0
	zero	0	stx1
	zero	0	stx2
	zero	0	stx3
	zero	0	stx4
	zero	0	stx5
	zero	0	stx6
	zero	0	stx7
	zero	0	stc2
	zero	0	stca
	zero	0	stcq
	zero	0	sreg
	zero	0	sti
	zero	0	sta
	zero	0	stq
	zero	0	staq
	zero	ap	lprpap
	zero	ab	lprpab
	zero	bp	lprpbp
	zero	bb	lprpbb
	zero	lp	lprplp
	zero	lb	lprplb
	zero	sp	lprpsp
	zero	sb	lprpsb
	zero	all
	zero	a+i	arl
	zero	q+i	qrl
	zero	aq+i	lrl
	zero	all	gtb
	zero	a+i	alr
	zero	q+i	qlr
	zero	aq+i	llr
"
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0,4*2	mve
	zero	all
	zero	all
	zero	all
	zero	0,4*2	mvne
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i,3*2	csl
	zero	i,3*2	csr
	zero	all
	zero	all
	zero	i,3*2	sztl
	zero	i,3*2	sztr
	zero	i,3*2	cmpb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0,3*2	mlr
	zero	0,3*2	mrl
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i,3*2	cmpc
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0,d+4*2	scd
	zero	0,d+4*2	scdr
	zero	all
	zero	all
	zero	0,d+4*2	scm
	zero	0,d+4*2	scmr
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all	sptr
	zero	all
	zero	all
	zero	all
	zero	0,4*2	mvt
	zero	all
	zero	all
	zero	all
	zero	0,4*2	tct
	zero	0,4*2	tctr
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all	lptr
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i+dr,3*2	ad2d
	zero	i+dr,3*2	sb2d
	zero	all
	zero	all
	zero	i+dr,3*2	mp2d
	zero	i+dr,3*2	dv2d
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i+dr,4*2	ad3d
	zero	i+dr,4*2	sb3d
	zero	all
	zero	all
	zero	i+dr,4*2	mp3d
	zero	i+dr,4*2	dv3d
	zero	all
	zero	all
	zero	all	lsdr
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	spbpap
	zero	0	spriab
	zero	0	spbpbp
	zero	0	spribb
	zero	all	ssdr
	zero	all
	zero	all
	zero	all	lptp
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i+dr,3*2	mvn
	zero	i+dr,3*2	btd
	zero	all
	zero	i,3*2	cmpn
	zero	all
	zero	i,3*2	dtb
	zero	all
	zero	all
	zero	ab	easpab
	zero	ab	eawpab
	zero	bb	easpbb
	zero	bb	eawpbb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	lb	easplb
	zero	lb	eawplb
	zero	sb	easpsb
	zero	sb	eawpsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	ap	epbpap
	zero	ab	eppab
	zero	bp	epbpbp
	zero	bb	eppbb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	lp	epbplp
	zero	lb	epplb
	zero	sp	epbpsp
	zero	sb	eppsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	sareg
	zero	all
	zero	all
	zero	all
	zero	0	spl
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	bases	lareg
	zero	all
	zero	all
	zero	all
	zero	0	lpl
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0,some_base	a9bd
	zero	0,some_base	a6bd
	zero      0,some_base	a4bd
	zero	0,some_base	abd
	zero	all
	zero	all
	zero	all
	zero	0,some_base	awd
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0,some_base	s9bd
	zero	0,some_base	s6bd
	zero	0,some_base	s4bd
	zero	0,some_base	sbd
	zero	all
	zero	all
	zero	all
	zero	0,some_base	swd
	zero	all
	zero	all
	zero	all	camp
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	araap
	zero	0	araab
	zero	0	arabp
	zero	0	arabb
	zero	0	aralp
	zero	0	aralb
	zero	0	arasp
	zero	0	arasb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all	sptp
	zero	ap	aarap
	zero	ab	aarab
	zero	bp	aarbp
	zero	bb	aarbb
	zero	lp	aarlp
	zero	lb	aarlb
	zero	sp	aarsp
	zero	sb	aarsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	i	trtn
	zero	0	trtf
	zero	all
	zero	all
	zero	0	tmoz
	zero	0	tpnz
	zero	0	ttn
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	arnap
	zero	0	arnab
	zero	0	arnbp
	zero	0	arnbb
	zero	0	arnlp
	zero	0	arnlb
	zero	0	arnsp
	zero	0	arnsb
	zero	0	spbplp
	zero	0	sprilb
	zero	0	spbpsp
	zero	0	sprisb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	ap	narap
	zero	ab	narab
	zero	bp	narbp
	zero	bb	narbb
	zero	lp	narlp
	zero	lb	narlb
	zero	sp	narsp
	zero	sb	narsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	sarap
	zero	0	sarab
	zero	0	sarbp
	zero	0	sarbb
	zero	0	sarlp
	zero	0	sarlb
	zero	0	sarsp
	zero	0	sarsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	0	sra
	zero	all
	zero	all
	zero	all
	zero	ap	larap
	zero	ab	larab
	zero	bp	larbp
	zero	bb	larbb
	zero	lp	larlp
	zero	lb	larlb
	zero	sp	larsp
	zero	sb	larsb
	zero	all
	zero	all
	zero	all
	zero	all
	zero	all	lra
	zero	all
	zero	all
	zero	all
" 
" Register information for nonstandard pl1_operators_.
"
" The entries must be in ascending order and the intervals must be nonoverlapping.
"
	segdef	operators
operators:
	vfd	36/((end_operators-start_operators)/2)	number of entries
	equ	start_operators,*
	zero	309,310		fx1_to_fl2, fx2_to_fl2
	zero	aq+i,fl
	zero	316,346		r_l_a to r_le_s
	zero	a+i
	zero	352,352		set_stack
	zero	a+q+i+bp+sp
	zero	406,408		put_field, put_field_chk, put_control
	zero	a+q+i+ap+x6+bp	
	zero	434,434		longbs_to_bs18
	zero	aq+i+bp
	zero	435,435		stac_mac
	zero	a+i
	zero	558,558		fetch_bits
	zero	aq+i
	zero	787,787		long_profile
	zero	0
	zero	796,796		stacq_mac
	zero	a+i
	equ	end_operators,*
"
	end




		    io_op.pl1                       10/03/83  1730.5rew 10/03/83  1008.6       88605



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


/* procedure to compile I/O operators

   Initial Version: 19 October 1971 by BLW
	Modified:  3 October 1972 by BLW
	Modified:	28 February 1973 by RAB
	Modified:	18 June 1973 by RAB	
	Modified:	30 December 1974 by RAB to fix 1282
	Modified:	25 February 1975 by RAB for quick put list
	Modified:	12 January 1976 by RAB to fix 1455
	Modified:	10 January 1978 by RAB to fix 1697
	Modified: 1 May 1979 by PCK to implement 4-bit decimal */

io_op:	proc(pt);

dcl	pt ptr;		/* points at operator node */

dcl	(cg_stat$cur_block,cg_stat$cur_statement,cg_stat$text_base) ptr ext,
	cg_stat$generate_symtab bit(1) ext,
	cg_stat$star_symbol_up_zero bit(18) ext;

dcl	(p,psp,psr,sslp,q,p2,p3,p4,arg(3),rand(3)) ptr,
	(psloc,i,n,macro,ok) fixed bin(15),
	quick_stream_op bit(1) aligned init("0"b),
	(atomic,useless) bit(1) aligned;

dcl	odd_bases bit(19) int static aligned init("0000000000000001111"b);

dcl	(addr,bit,fixed,null,substr) builtin;

dcl	expmac entry(fixed bin(15),ptr),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	long_op$io entry(ptr,fixed bin(15)),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	load entry(ptr,fixed bin),
	base_man$load_var entry(fixed bin,ptr,fixed bin);
dcl	base_man$load_linkage entry returns(bit(3) aligned);
dcl	(compile_exp, fortran_$fortran_io_op) entry(ptr),
	compile_exp$save_exp entry(ptr) returns(ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	xr_man$load_var entry(ptr,fixed bin(17)),
	xr_man$super_lock entry(fixed bin(17)),
	c_a entry(fixed bin(18),fixed bin) returns(ptr),
	base_man$store_ptr_to entry(ptr,ptr),
	state_man$erase_reg entry(bit(19) aligned),
	state_man$flush_ref entry(ptr),
	state_man$flush entry();
dcl	m_a entry(ptr,bit(2) aligned);
dcl	expmac$zero entry(fixed bin(15)),
	aq_man$lock entry(ptr,fixed bin);
dcl	copy_temp entry(ptr) returns(ptr);
dcl	stack_temp$assign_temp entry(ptr),
	declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),ptr) returns(ptr);

dcl (	get_term_mac	init(313),
	put_data_mac	init(328),
	lda		init(1),
	ldfx1		init(7),
	stfx1		init(15),
	zero_mac		init(308),
	symtab_mac	init(320),
	init_ps_mac	init(339),
	init_sslp		init(340),
	io_macro(0:15)	init(495,499,0,503,507,(8)0,587,498,506),
	put_field_mac		init(502),
	stream_prep_mac	init(396),
	recio_mac		init(485),
	form_desc		init(513),
	load_pt		init(60)) fixed bin(15) int static;

dcl	fixbin fixed bin based aligned;

%include ps_map;
%include block;
%include symbol;
%include reference;
%include statement;
%include operator;
%include list;
%include op_codes;
%include statement_types;
%include bases;
%include machine_state;
%include relocation_bits;
%include data_types;
%include boundary;
%include mask;

	p = pt;

	if p -> operator.op_code > record_io
	then if p -> operator.op_code < put_control
	     then do;
	          call fortran_$fortran_io_op(p);
	          return;
	          end;
	     else quick_stream_op = "1"b;

	psp = cg_stat$cur_block -> block.plio_ps -> element(1);
	psr = psp -> symbol.reference;

	rand(1) = p -> operand(1);
	rand(2) = p -> operand(2);
	rand(3) = p -> operand(3);
	if p -> op_code = stream_prep
	then do;
	     arg(1) = rand(1);
	     arg(2) = prepare_operand(rand(2),-1,atomic);
	     call ma_and_flush(2);
	     call expmac$many((stream_prep_mac),addr(arg),2);
	     arg(1) -> reference.perm_address = "0"b;
	     arg(2) -> reference.perm_address = "0"b;
	     return;
	     end;

	if p -> op_code = record_io
	then do;
	     arg(1) = rand(1);
	     call ma_and_flush(1);

	     if p -> operator.number = 2
	     then do;
		arg(2) = prepare_operand(rand(2),-1,atomic);
		call base_man$load_var(2,arg(2),1);
		end;

	     call expmac((recio_mac),arg(1));
	     arg(1) -> reference.perm_address = "0"b;
	     return;
	     end;

	if p -> op_code = terminate_trans
	then do;
	     call ma_and_flush(0);
	     call expmac$zero(get_term_mac + fixed(cg_stat$cur_statement -> statement_type = put_statement,1));
	     return;
	     end;

	psloc = psp -> symbol.location;

	if p -> op_code = get_data_trans
	then do;

	     /* set ptr to OK list */

	     if rand(1) -> operator.number = 0
	     then do;
		q = generate_constant$real_fix_bin_1(0);
		call state_man$flush;
		end;
	     else do;
		ok = rand(1) -> operator.number;
		q = c_a((ok),10);
		do i = 1 to addrel(cg_stat$text_base,ok) -> fixbin;	/* KLUDGE to find out original number of operands */
		     call state_man$flush_ref((rand(1) -> operand(i)));
		end;
		end;

	     call base_man$store_ptr_to(q,c_a(psloc + ps_special_list,4));
	     return;
	     end;

	if p -> op_code = put_data_trans
	then do;

	     /* process subscript list */

	     sslp = cg_stat$cur_block -> block.plio_ssl;
	     n = sslp -> symbol.location;
	     sslp = sslp -> symbol.reference;

	     sslp -> reference.perm_address = "0"b;

	     if rand(1) = null then call expmac((zero_mac),sslp);
	     else do;
		call expmac((ldfx1),c_a((rand(1) -> list.number),2));
		call expmac((stfx1),sslp);
		sslp -> reference.perm_address = "1"b;

		do i = 1 to rand(1) -> list.number;
		     sslp -> address.offset = bit(fixed(n+i,15),15);

		     p2 = rand(1) -> element(i);
		     p3 = prepare_operand(p2,1,atomic);
		     if atomic then call load(p3,0); else call compile_exp(p2);

		     call expmac((stfx1),sslp);
		     end;
		end;

	     p2 = prepare_operand(rand(2),-1,atomic);

	     /* put symtab offset into ps */

	     call protect_areg;
	     q = c_a(fixed(rand(2) -> reference.symbol -> symbol.runtime,18),2);
	     q -> reference.relocation = rc_s;
	     call expmac((lda),q);

	     macro = put_data_mac;
	     goto l2;
	     end;

	if p->op_code = put_control
	then do;
	     p2 = prepare_operand(rand(2),-1,atomic);

	     p3 = prepare_operand(rand(1),-1,atomic);
	     call compile_exp(rand(2));
	     call xr_man$load_var(rand(1),6);

	     call expmac$zero((io_macro(13)));
	     return;
	     end;

	/* get|put list|edit */

	p2 = prepare_operand(rand(2),-1,atomic);

	if ^ atomic then p2 = compile_exp$save_exp(rand(2));

	if rand(1) ^= null
	then p3 = prepare_operand(rand(1),-1,atomic);
	else do;
	     p3 = c_a(0,2);
	     p3 -> reference.data_type = real_fix_bin_1;
	     atomic = "1"b;
	     end;

	if p->op_code = put_field_chk 
	then do;
	     p4 =prepare_operand(rand(3),-1,useless);
	     call xr_man$load_var(rand(3),6);
	     call xr_man$super_lock(6);
	     end;

	if atomic 
	then call load(p3,0);
	else if quick_stream_op
	     then call compile_exp(rand(1));
	     else do;
		q = rand(1) -> operand(3);
		p3 = prepare_operand(q,1,atomic);
		if atomic then call load(p3,0); else call compile_exp(q);
		call expmac((form_desc),prepare_operand((rand(1) -> operand(2)),-1,atomic));
		end;

	macro = io_macro(fixed(substr(p -> op_code,6,4),4));

	p3 = p2 -> reference.symbol;
	if p3 -> symbol.picture
	then if ^quick_stream_op
	then do;
	     p3 = c_a((p3 -> symbol.general -> reference.symbol -> symbol.location),3);
	     p3 -> reference.relocation = rc_t;
	     call protect_areg;
	     call expmac((lda),p3);
	     end;

l2:	call long_op$io(p2,macro);
	if p -> op_code = get_list_trans | p -> op_code = get_edit_trans
	     then call state_man$flush_ref(p2);
	return;

io_op$init_ps: entry;

	/* This entry is called to initialize the ps space */

	psp = cg_stat$cur_block -> block.plio_ps -> element(1);
	arg(1) = psp -> symbol.reference;
	arg(1) -> reference.units = word_;

	call expmac((init_ps_mac),arg(1));
	arg(1) -> reference.perm_address = "0"b;

	base_regs(1).type = 0;
	arg(1) -> reference.address_in.b(1) = "0"b;

	if cg_stat$generate_symtab
	then do;
	     arg(2) = c_a(fixed(cg_stat$star_symbol_up_zero,18),9);
	     arg(2) -> address.base = base_man$load_linkage();

	     arg(3) = c_a((cg_stat$cur_block -> block.symbol_block),3);
	     arg(3) -> reference.relocation = rc_s;

	     call expmac$many((symtab_mac),addr(arg),3);
	     end;

	sslp = cg_stat$cur_block -> block.plio_ssl;
	if sslp ^= null
	then do;
	     arg(2) = sslp -> symbol.reference;
	     arg(2) -> reference.units = word_;
	     call expmac$many((init_sslp),addr(arg),2);
	     end;

	sslp = cg_stat$cur_block -> block.plio_fa;
	if sslp ^= null
	then do;
	     sslp -> symbol.reference -> reference.units = word_;
	     call base_man$store_ptr_to((sslp -> symbol.reference),
	       c_a(psp -> symbol.location + ps_format_area,4));
	     end;



ma_and_flush:	proc(n);
dcl	(i,n) fixed bin;

	do i = 1 to n;
	     call m_a(arg(i),"0"b);
	     arg(i) -> reference.perm_address = "1"b;
	end;

	call state_man$erase_reg((odd_bases));

	end;

/*	NOT PRESENTLY USED

get_temp:	proc() returns(ptr);

dcl	r ptr;

     */	/* returns reference to a char(256) varying temporary */	/*

	r = declare_temporary(char_mask | varying_mask | aligned_mask,256,0,null);
	r = copy_temp(r);
	r -> reference.c_length = r -> reference.symbol -> symbol.c_dcl_size;
	r = prepare_operand(r,1,atomic);
	call stack_temp$assign_temp(r);
	return(r);

	end;

	MAYBE SOMEDAY AGAIN	*/

protect_areg:  proc;

	/* makes sure that long_op does not clobber the a_register by 
	   calling base_man (fixes bug 1282) */

	if p2 -> reference.units < word_ | p2 -> reference.big_offset
	then do;
	     call aq_man$lock(null,2);
	     if ^ p2 -> reference.shared
		then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
	     call base_man$load_var(2,p2,1);
	     end;

	end;

end;




		    jump_op.pl1                     09/29/89  1337.1rew 09/29/89  1335.9      153747



/****^  ***********************************************************
        *                                                         *
        * 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-28,JRGray), approve(89-07-28,MCR8123), audit(89-09-12,Vu),
     install(89-09-22,MR12.3-1073):
     Called state_man$save_regs to save temps before conditionals are
     evaluated (pl1 2091 2177).
  2) change(89-09-26,JRGray), approve(89-09-26,MCR8123), audit(89-09-27,Vu),
     install(89-09-29,MR12.3-1076):
     Fixed so that saving registers for label arrays no longer causes side
     effects.
                                                   END HISTORY COMMENTS */


/* procedure to compile jumps and conditional jumps

   Initial Version: 29 March 1971 by BLW for Version II
	Modified:  9 January 1973 by BLW
	Modified:	12 June 1973 by RAB for EIS
	Modified:	7 May 1974 by RAB to fix bug 941 by providing eval_primaries
	Modified:	23 October 1974 by RAB to fix bug 1242
	Modified:	2 November 1975 by RAB to allow outside access to eval_prim
	Modified:	16 May 1976 by RAB to fix 1497
	Modified:	23 June 1976 by RAB to centralize use of cg_stat$last_call
	Modified:	1 July 1976 by RAB for label array improvements
	Modified:	29 July 1976 by RAB to fix minor bug in label array stuff
	Modified:	5 November 1976 by RAB to take advantage of fix to bugs 1542 & 1546
		in operator_semantics
	Modified:	9 March 1977 by RAB to remove some dead code caused by previous change
	Modified 790703 by PG to fix 1844 (using a decimal expression in an if statement and the then or else clause
		sometimes generated bad code), and to remove old_fortran jump_three_way.
	Modified 790824 by PG to tension goto's only if -optimize was specified.
*/

jump_op:	proc(pt);

/* parameters */

dcl	pt ptr;		/* points at an operator node */

/* automatic */

dcl	(pb,p,arg(3),q,s1,save_p1) ptr,
	(atomic,p2_atomic,p3_atomic,conditional,is_return,load_index) bit(1) aligned,
	(dt,i,j,k,n,macro,code,hard,size,count,start,finish) fixed bin(15);

/* based */

dcl	based_bit_string bit(size) aligned based;

/* builtins */

dcl	(fixed,null,substr) builtin;

/* defined */

dcl	p1 ptr defined(arg(1)),
	p2 ptr defined(arg(2)),
	p3 ptr defined(arg(3));

/* entries */

dcl	expmac entry(fixed bin(15),ptr),
	expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
	expmac$zero entry(fixed bin(15)),
	error entry(fixed bin,ptr,ptr),
	base_man$load_var entry(fixed bin,ptr,fixed bin),
	xr_man$load_any_var entry(ptr,fixed bin(15),fixed bin),
	xr_man$load_const entry(fixed bin(15),fixed bin),
	c_a entry(fixed bin(15),fixed bin) returns(ptr);
dcl	m_a entry(ptr,bit(2) aligned);
dcl	compile_exp$save entry(ptr) returns(ptr),
	need_temp entry(ptr,bit(2) aligned),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	state_man$flush entry,
	state_man$create_ms entry returns(ptr),
	state_man$save_regs entry(ptr),
	state_man$save_ms entry(ptr,bit(1) aligned),
	state_man$discard_ms entry,
	set_indicators entry(ptr,ptr,ptr,fixed bin(15)) returns(fixed bin(15));

/* external static */

dcl	(cg_stat$cur_block,cg_stat$cur_statement,cg_stat$jump_label,cg_stat$m_s_p) ptr ext,
	cg_stat$text_pos fixed bin(18) ext,
	cg_stat$skip_to_label bit(1) ext,
	cg_stat$cur_level fixed bin ext,
	cg_stat$optimize bit (1) aligned external static;

/* internal static */

dcl (	tra		init(169),
	tra_ext_1		init(170),
	tra_ext_2		init(171)) fixed bin (15) int static;

dcl	reverse(8) fixed bin(15) int static
	init(2,1,8,7,6,5,4,3);

dcl	jump_table(8 /* operator */, 0:1 /* string? */, 0:1 /* reversed? */) fixed bin(15) int static
	init(	/* true	*/ 181, 181, 181, 181,
		/* false	*/ 180, 180, 180, 180,
		/*  <	*/ 176, 178, 177, 179,
		/*  >	*/ 178, 176, 179, 177,
		/*  =	*/ 180, 180, 180, 180,
		/*  ^=	*/ 181, 181, 181, 181,
		/*  <=	*/ 182, 184, 183, 185,
		/*  >=	*/ 184, 182, 185, 183);

/* include files */

%include reference;
%include operator;
%include symbol;
%include label;
%include block;
%include statement;
%include nodes;
%include op_codes;
%include data_types;
%include list;

/* program */

	pb = cg_stat$cur_block;

	p = pt;
	s1, p1 = p -> operand(1);

	/* if the destination of this transfer is another transfer,
	   go directly to destination of other transfer */

	if p1 -> node.type = label_node & cg_stat$optimize
	then do;
		do count = 1 to 10;			/* limit number of attempts */
		     p3 = p1 -> label.statement;
		     q = p3 -> statement.root;

		     do while(q = null);
			p3 = p3 -> statement.next;
			if p3 = null then goto prep;
			q = p3 -> statement.root;
		     end;

		     if q -> operator.op_code ^= jump then goto prep;

		     if p3 = cg_stat$cur_statement
		     then do;
			call error(325,p3,null);	/* infinite loop */
			goto prep;
			end;

		     p2 = q -> operand(1);
		     if p2 -> node.type ^= label_node then goto prep;
		     if p1 -> label.block_node ^= p2 -> label.block_node then goto prep;

		     p1 = p2;
		end;

prep:	     if s1 ^= p1
	     then do;

		/* if we actually skipped over a transfer, we have to correct the
		   reference counts on the statements involved */

		q = s1 -> label.statement;
		q -> statement.reference_count = q -> statement.reference_count - 1;

		q = p1 -> label.statement;
		q -> statement.reference_count = q -> statement.reference_count + 1;

		end;

	     end;

	else if p1 -> node.type = reference_node
	     then if p1 -> reference.symbol = null
		then do;

		     /* a reference node with no symbol would have been created
		        by a call to c_a.  This is used to indicate a conditional
		        return statement	     */

		     is_return = "1"b;
		     goto sh;
		     end;
		else if p1 -> reference.symbol -> node.type = label_node
		     then call init_label_array_info;

	is_return = "0"b;

	/* operator_semantics ensures that operand(1) of a conditional jump
	   operator will not be an operator node nor a reference node with
	   expressions hanging off.  This used to arise in the case of
	   if <expr> then goto <lab>; when <lab> was other than a simple
	   reference to a label constant */

	p1 = prepare_operand(p1,1,atomic);
	dt = p1 -> reference.data_type;
	s1 = p1 -> reference.symbol;

sh:	hard = 0;

	/* get integer giving op_code going from 0 to 8 */

	i, n = fixed(p -> operator.op_code,9) - fixed(jump,9);

	if n >= 3 then n = 3;

	if n > 0
	then do;

	     /* have conditional jump */

	     if is_return then goto cond_ok;

	     if dt = label_constant
	     then if cg_stat$cur_level = s1 -> label.block_node -> block.level
		then do;
		     if ^ cg_stat$cur_statement -> statement.checked
		     then if ^ s1 -> label.allocated
			then call eval_primaries((s1 -> label.statement));
			else if s1 -> label.array
			     then call eval_all_primaries;
		     go to cond_ok;
		     end;

	     /* special action needed for conditional transfer to something
	        other than a label constant */

	     hard = 1;
	     i = reverse(i);
	     save_p1 = p1;

	     s1 = cg_stat$jump_label;
	     s1 -> label.allocated = "0"b;
	     s1 -> label.location = 0;
	     p1 = prepare_operand(s1,1,atomic);

cond_ok:	     conditional = "1"b;
	     p2 = p -> operand(2);
	     goto switch(n);
	     end;

	if dt = label_constant
	then if s1 -> label.array
	then if p1 -> reference.offset ^= null
	then if ^ cg_stat$cur_statement -> statement.checked
	then if cg_stat$cur_block = s1 -> label.block_node
	then call eval_all_primaries;

	/* have unconditional jump */

uncond:	conditional = "0"b;

	if dt = local_label_variable
	then do;

	     q = s1 -> symbol.block_node;

	     if q = pb
	     then do;

		/* the local label variable is declared in current block,
		   can transfer indirectly thru the pointer */

jump_ind:		call m_a(p1,"1"b);			/* no indirection allowed */
		p1 -> reference.perm_address = "1"b;
		substr(p1 -> address.tag,2,1) = "1"b;	/* r mod -> r* mod */
		goto put_tra;
		end;

	     /* if none of the blocks between this one and the block in
	        which the local label variable is declared have stack frames,
	        we also can jump indirectly */

	     do while(pb -> block.no_stack);
		pb = pb -> block.father;
		end;

	     if q = pb then goto jump_ind;

	     /* must use an unwinder to do the transfer */

unwind:	     macro = tra_ext_2;
	     load_index = "0"b;
	     goto load_bp;
	     end;

	/* if operand(1) is a pointer, we have jump to a do block */

	if dt = unpacked_ptr then goto jump_ind;

	if dt = real_fix_bin_1
	then do;

	     /* have transfer resulting from Fortran assigned goto */

	     call xr_man$load_any_var(p1,k,0);
	     p1 = c_a(k,8);			/* 0,xr */
	     goto put_tra;
	     end;

	if dt ^= label_constant then goto unwind;

	/* get number of blocks between current block and block in
	   which the constant appears */

	k = cg_stat$cur_level - s1 -> label.block_node -> block.level;

	if k ^= 0
	then do;

	     /* must use an unwinder since label is in an outer block */

	     load_index = "1"b;
	     macro = tra_ext_1;

load_bp:	     call base_man$load_var(2,p1,1);	/* load ptr into bp */

	     if load_index
		then call xr_man$load_const(k,7);	/* load x7 with number of frames to walk */

	     call state_man$discard_ms;

	     call expmac$zero(macro);
	     goto done;
	     end;

put_tra:	macro = tra;

	goto put;

	/* opcode is jump_true */

switch(1):
	if hard = 1 then goto sw_2;

sw_1:	if p2 -> node.type ^= operator_node then goto jump_tf;

	/* look for case "if ^ bit(1) then ..." */

	if p2 -> operator.op_code ^= not_bits then goto jump_tf;
	if p2 -> operand(1) -> reference.c_length ^= 1 then goto jump_tf;
	if ^ p2 -> operand(1) -> reference.shared then go to jump_tf;

	/* have case "if ^ bit(1)", remove the not and change to jump_false */

	pt -> operand(2), p2 = p2 -> operand(2);
	i = i + 1;
	goto jump_tf;

	/* opcode is jump_false */

switch(2):
	if hard = 1 then goto sw_1;

sw_2:	if p2 -> node.type ^= operator_node then goto chk_const;

	/* look for case of form "if ^ bit(1) then return;" */

	if p2 -> operator.op_code ^= not_bits then goto jump_tf;
	if p2 -> operand(1) -> reference.c_length ^= 1 then goto jump_tf;
	if ^ p2 -> operand(1) -> reference.shared then go to jump_tf;

	/* remove the node and change to jump_true */

	pt -> operand(2), p2 = p2 -> operand(2);
	i = i - 1;
	goto jump_tf;

	/* look for jump produces by construct
		do while("1"b);
	   and eliminate the test	*/

chk_const:
	if p2 -> reference.offset ^= null then goto jump_tf;
	if p2 -> reference.c_offset ^= 0 then goto jump_tf;
	if p2 -> reference.length ^= null then goto jump_tf;

	q = p2 -> reference.symbol;
	if ^ q -> symbol.constant then goto jump_tf;
	if ^ q -> symbol.bit then goto jump_tf;
	if q -> symbol.varying then goto jump_tf;
	if q -> symbol.dimensioned then goto jump_tf;

	if hard > 0 then goto jump_tf;

	size = q -> symbol.c_dcl_size;
	if q -> symbol.initial -> based_bit_string then return;

jump_tf:	code = 5;
	p3 = null;
	goto jump_rel;

	/* have conditional jump */

switch(3):
	code = 0;

jump_rel:	p2 = prepare_operand(p2,1,p2_atomic);

	if code = 0
	then do;
	     p3 = prepare_operand((p -> operand(3)),1,p3_atomic);
	     code = fixed(p2_atomic || p3_atomic,2);
	     end;

	if ^is_return & hard = 0 & dt = label_constant then	/* save useful registers now to avoid clobbering indicators later */
	     if s1 -> label.array then call label_array_save_regs;
	     else if ^s1 -> label.allocated then call state_man$save_regs((s1 -> label.statement));

	k = set_indicators(pt,p2,p3,code);

	if p2 -> reference.data_type <= real_flt_bin_2 then j = 0;
	else do;
	     q = p2 -> reference.symbol;
	     j = fixed(q -> symbol.bit | q -> symbol.char,1);
	     end;

	macro = jump_table(i,j,k);

put:	if is_return then goto putx;

	call m_a(p1,"0"b);
	p1 -> reference.perm_address = "1"b;

	if p1 -> reference.ref_count = 1
	then if p1 -> reference.offset ^= null | p1 -> reference.qualifier ^= null
	     then call need_temp(p1,"10"b);

	if dt = label_constant
	then if hard ^= 0
	     then call state_man$flush;
	     else if s1 -> label.array
		then call process_label_array;
		else if ^ s1 -> label.allocated
		     then call state_man$save_ms((s1 -> label.statement),conditional);
		     else if ^ conditional
			then call state_man$discard_ms;
			else;
	else if hard ^= 0
	     then call state_man$flush;

putx:	call expmac(macro,p1);

	if hard = 1
	then do;

	     /* just finished first part of conditional transfer to jump_label,
	        how go unconditional transfer to the real label */

	     p1 = save_p1;

	     s1 = p1 -> reference.symbol;
	     hard = 2;
	     goto uncond;
	     end;

done:	if hard = 2
	then do;
	     call expmac$fill_usage(cg_stat$text_pos,(cg_stat$jump_label -> label.location));
	     if cg_stat$m_s_p = null then cg_stat$m_s_p = state_man$create_ms();
	     else call state_man$flush;
	     cg_stat$skip_to_label = "0"b;
	     end;
	else cg_stat$skip_to_label = ^ conditional;

	return;

jump_op$eval_primaries:	entry(pt);

	p1 = pt;
	if p1 -> node.type = label_node
	then call eval_primaries((p1 -> label.statement));
	else do;
	     call init_label_array_info;
	     call eval_all_primaries;
	     end;
	return;



eval_primaries:	proc(stm);

	     /* eval_primaries is called before an easy conditional forward
	     jump to ensure that all expressions known now and known
	     at the label are fully evaluated.  It searches the primary list
	     at the label.  This routine is necessary because the code generator
	     does not usually evaluate the addr_fun operator as an optimization,
	     and because short unaligned strings are most often not converted
	     to aligned temporaries when they are stored, but rather when they
	     are loaded again later.  Thus, an anomalous situation would
	     arise, if an expr, like those mentioned above, was encountered
	     before a conditional forward jump without its being evaluated,
	     was evaluated along one branch of execution, thus making the
	     code generator think it was already evaluated when it encountered
	     the expr yet again along the other branch of execution.  */

dcl	     (prim,q,r,stm) ptr;

	     do prim = stm -> statement.reference_list
		repeat prim -> element(4) while(prim ^= null);
		q = prim -> element(1);
		if q -> node.type = operator_node
		then do;
		     r = q -> operand(1);
	 	     if ^ r -> reference.evaluated
		     then if r -> reference.ref_count > 1
			then if q -> operator.op_code = addr_fun
			     then call evaluate;
		     end;
		else if ^ q -> reference.aligned_ref
		     then if q -> reference.ref_count > 1
			then if ^q -> reference.symbol -> symbol.decimal
			     then call evaluate;
		end;

evaluate:		proc;

		/* evaluate q */

dcl		atomic bit(1) aligned;

		r = prepare_operand(q,1,atomic);

		if ^ atomic
		then if ^ r -> reference.aggregate
		     then r = compile_exp$save(q);

		end;

	     end;


init_label_array_info: proc;

/* initializes start, finish for further use */

	     if p1 -> reference.offset = null
	     then start, finish = p1 -> reference.c_offset + 1;

	     else do;
		start = 1;
		finish = p1 ->reference.symbol -> label.statement -> list.number;
		end;

	     end;


eval_all_primaries:	proc;

	     /* finds all statements for which eval_primaries must be called.
	        called only for label array in same block */

dcl	     (q,vector) ptr;
dcl	     i fixed bin;

	     vector = p1 -> reference.symbol -> label.statement;

	     do i = start to finish;
		if vector -> list.element(i) ^= null
		then do;
		     q = vector -> element(i);
		     if q -> statement.object.start = 0
			then call eval_primaries(q);
		     end;
		end;

	     end;


process_label_array: proc;

	     /* handle machine state for local jumps to label array target */

dcl	     (vector,q) ptr;
dcl	     i fixed bin;
dcl	     cond bit(1) aligned;

	     cond = conditional | start ^= finish;
	     vector = s1 -> label.statement;

	     do i = start to finish;
		if vector -> element(i) ^= null
		then do;
		     q = vector -> element(i);
		     if q -> statement.object.start = 0
		     then call state_man$save_ms(q,cond);
		     else if ^ cond
			then call state_man$discard_ms;
		     end;
		end;

	     if start ^= finish
		then call state_man$discard_ms;

	     end;

label_array_save_regs:	proc;

	/* saves temp-values before local jumps to label array target */

dcl	i fixed bin;
dcl	q ptr;

	do i =  start to finish;
	     q = s1 -> label.statement -> element(i);
	     if q ^= null then
		if q -> statement.object.start = 0 then call state_man$save_regs(q);
	  end;
     end label_array_save_regs;

end jump_op;




		    length_op.pl1                   10/03/83  1730.5rew 10/03/83  1008.7       41094



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


/* program to process length operator

	Written:	23 April 1974 by RAB
	Modified:	18 November 1974 by RAB for assign of desc elim	*/

length_op:	proc(pt) returns(ptr);

dcl	pt ptr;		/* points at operator node */

dcl	(p,p1,p2,q,s,s2) ptr;
dcl	(doing_length,useless) bit(1) aligned;

dcl	cg_stat$cur_block ptr ext static;

dcl	adjust_ref_count entry(ptr,fixed bin);
dcl	call_op entry(ptr) returns(ptr);
dcl	compile_exp$save entry(ptr) returns(ptr);
dcl	create_symbol entry(ptr,ptr,bit(3) aligned) returns(ptr);
dcl	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr);
dcl	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
dcl	share_expression entry(ptr) returns(ptr);

dcl	null builtin;

dcl	fix_bin(0:1) fixed bin based;

%include cgsystem;
%include symbol;
%include reference;
%include operator;
%include boundary;
%include data_types;
%include nodes;
%include temporary;
%include op_codes;

	doing_length = "1"b;

begin:
	p = pt;
	q = p -> operand(1);

	/* get reference to length field (-1) of varying string */

	p2 = p -> operand(2);

	if p2 -> node.type = operator_node
	then if p2 -> operand(1) -> reference.evaluated
	     then p2 = p2 -> operand(1);
	     else if p2 -> operator.op_code = std_call
		then p2 = call_op(p2);
		else p2 = compile_exp$save(p2);

	s2 = p2 -> reference.symbol;
	if s2 -> symbol.constant & p2 -> reference.offset = null
	     then return(generate_constant$real_fix_bin_1(s2 -> symbol.initial -> fix_bin
			(p2 -> reference.c_offset)));

	p2 = prepare_operand(p2,1,useless);

	/* we need a new symbol to hold both the proper storage
	   class and the proper precision */

	s = create_symbol(null,null,(s2 -> symbol.dcl_type));
	p1 = s -> symbol.reference;
	s -> symbol.attributes = s2 -> symbol.attributes;
	s -> symbol.location = s2 -> symbol.location;
	s -> symbol.block_node = s2 -> symbol.block_node;
	s -> symbol.father = s2 -> symbol.father;
	s -> symbol.initial = s2 -> symbol.initial;
	s -> symbol.allocated = s2 -> symbol.allocated;
	s -> symbol.token = s2 -> symbol.token;
	string (s -> symbol.data_type) = string (q -> reference.symbol -> symbol.data_type);
	s -> symbol.binary = "1"b;
	s -> symbol.c_bit_size = bits_per_word;
	s -> symbol.c_word_size = 1;
	s -> symbol.c_dcl_size = q -> reference.symbol -> symbol.c_dcl_size;

	/* set up the reference node */

	p1 -> reference = p2 -> reference;
	p1 -> reference.shared = "0"b;
	if q -> reference.shared
	     then p1 -> reference.ref_count = 1;
	     else p1 -> reference.ref_count = q -> reference.ref_count;

	q = p1;
	q -> reference.symbol = s;
	p -> operand(1) = q;

	string(q -> reference.info) = "0"b;
	q -> reference.value_in.storage = p2 -> reference.value_in.storage;

	if doing_length
	     then q -> reference.c_offset = q -> reference.c_offset - 1;
	q -> reference.units = word_;
	q -> reference.data_type = real_fix_bin_1;
	q -> reference.varying_ref = "0"b;
	q -> reference.c_length = bits_per_word;
	string(q -> reference.bits) = "0100000111000"b;	/* aligned, evaluated, allocate, allocated */

	q -> reference.defined_ref = s -> symbol.defined;
	q -> reference.aliasable = s -> symbol.aliasable | (s -> symbol.auto 
				& (cg_stat$cur_block ^= s -> symbol.block_node)
				& s -> symbol.passed_as_arg);
	q -> reference.temp_ref = s -> symbol.temporary;
	q -> reference.aggregate = p2 -> reference.aggregate;
	q -> reference.perm_address = "0"b;
	q -> reference.no_address = "1"b;

	if q -> reference.qualifier ^= null
	then if q -> reference.qualifier -> node.type = temporary_node
	     then q -> reference.qualifier -> temporary.ref_count = q -> reference.qualifier -> temporary.ref_count + 1;
	     else q -> reference.qualifier = share_expression((q -> reference.qualifier));

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

	if ^ p2 -> reference.shared
	     then call adjust_ref_count(p2,-1);

	return(q);


assign_desc_op:	entry(pt) returns(ptr);

	/* eliminate assignment of descriptor to temporary */

	doing_length = "0"b;
	go to begin;
	end;




		    load.pl1                        10/03/83  1730.5rew 10/03/83  1008.9      115560



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


/* Procedure to generate instructions to load a value

   Initial Version: 23 September 1971 by BLW
	Modified:  5 November 1972 by BLW
	Modified:	15 February 1973 by RAB
	Modified:	22 June 1973 by RAB for EIS
	Modified:	15 June 1976 by RAB to fix 1502
	Modified:	19 March 1977 by RAB for aq_man$left_shift
	Modified: 16 July 1978 by PCK for unsigned binary
	Modified:	9 December 1978 by RAB to fix 1803 (faults on get list(picture);)
	Modified:	17 July 1979 by RAB to check for load(decimal_value,...).
*/

load:	proc(pt,control);

dcl	pt ptr,		/* points at reference node */
	control fixed bin;	/* non-zero if negative should be loaded */

dcl	(p,q) ptr,
	(i,n,type,size,d,dt,k,aq_length,units,cfo) fixed bin,
	offset fixed bin(8),
	(mac,macro,shift) fixed bin(15),
	mask bit(72) aligned,
	(fs,ft,arith,available) bit(1) aligned,
	for_save bit(1) aligned init("0"b),
	cg_stat$cur_statement ptr ext static,
	error entry(fixed bin,ptr,ptr),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	generate_constant entry(bit(*) aligned,fixed bin) returns(ptr),
	stack_temp$free_temp entry(ptr),
	(long_op,long_op$c_or_b) entry(ptr,fixed bin,fixed bin(15)),
	(xr_man$load_var,adjust_ref_count) entry(ptr,fixed bin),
	xr_man$load_const entry(fixed bin,fixed bin),
	aq_man$trim_aq entry(fixed bin),
	aq_man$left_shift entry(fixed bin(8),bit(1) aligned),
	save_value entry(ptr),
	make_n_addressable entry(ptr,fixed bin),
	get_reference entry() returns(ptr),
	state_man$erase_reg entry(bit(19) aligned),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	expmac entry(fixed bin(15),ptr);

dcl	(addr,bit,fixed,mod,null,substr) builtin;

dcl (	ldfx1		init(7),
	ldfx2		init(8),
	negate_op(4)	init(255,38,39,39),
	testfx1		init(508),
	test_lda		init(332),
	cana		init(323),
	lda		init(1),
	als		init(134),
	lls		init(63),
	anaq		init(42),
	lrl		init(62),
	lrs		init(492),
	unpack_fl1	init(486),
	unpack_cfl1	init(488),
	clear_aq		init(58),
	move_cs_load_1	init(100),
	set_chars		init(436),
	load_logical	init(380)) fixed bin(15) int static;

dcl	operator_table	init(262046) fixed bin(18) int static;	/* = 262144 - 98 */

%include cgsystem;
%include cg_reference;
%include data_types;
%include machine_state;
%include boundary;
%include symbol;

	p = pt;

begin:	available, fs, ft = "0"b;

	type = p -> reference.data_type;

l4:	if type = unpacked_ptr
	then do;
	     type = real_fix_bin_2;
	     goto chk;
	     end;

	if type = packed_ptr
	then do;
	     mac = lrl;
	     type = real_fix_bin_1;
	     goto chk;
	     end;

	if type >= char_string
	then do;
	     arith = "0"b;
	     goto string_;
	     end;

	if type >= real_fix_dec
	then do;
	     call error(374,cg_stat$cur_statement,p);
	     return;
	     end;

	mac = lrs;
	if p -> reference.symbol ^= null
	then if p -> reference.symbol -> symbol.unsigned
	     then mac = lrl;

chk:	arith = "1"b;

	if control ^= 0
	then do;
	     n = 3;
	     if p -> reference.value_in.q
	     then if type >= real_fix_bin_2 | (p -> reference.temp_ref & ^ p -> reference.value_in.storage)
		then do;
		     call adjust_ref_count(p,-1);
		     call expmac$zero((negate_op(type)));
		     return;
		     end;
	     end;
	else do;
	     n = -1;

	     if p -> reference.value_in.q
	     then do;
		if ft
		then if machine_state.indicators ^= 2
		     then if (p -> reference.temp_ref & ^ p -> reference.value_in.storage) | ^ p -> reference.aligned_ref
			then do;
			     call expmac$zero(testfx1 + type - 1);
			     machine_state.indicators = 2;
			     end;
			else go to l1;

drop:		if ^ p -> reference.shared
		     then call adjust_ref_count(p,-1);

		if ^ p -> reference.long_ref
		     then call sv_value;

		return;
		end;
	     end;

l1:	if ^ p -> reference.aligned_ref
	then do;
	     size = p -> reference.c_length;
	     type = bit_string;
	     if fs then goto l2; else goto str1;
	     end;

	if type = complex_flt_bin_1 then macro = ldfx2;
	else macro = ldfx1 + n + type;

	call expmac(macro,p);

thru:	call sv_value;

	if control = 0
	then do;
	     q_reg.variable(1) = p;
	     q_reg.number = 1;
	     machine_state.indicators = 2;
	     p -> reference.value_in.q = "1"b;
	     end;

	return;

	/* we have a bit or character string to be loaded */

string_:	if p -> reference.long_ref
	then do;

lg:	     if p -> reference.value_in.string_aq
		then goto drop;

	     call long_op$c_or_b(p,0,(set_chars));

	     string_reg.variable = p;
	     string_reg.size = p -> reference.c_length;

	     p -> reference.value_in.string_aq = "1"b;
	     return;
	     end;

	size = p -> reference.c_length * convert_size(type);

	if size = 0
	then do;
caq:	     call expmac$zero((clear_aq));
	     goto l72;
	     end;

l2:	if p -> reference.value_in.a
	then do;
	     if ft
	     then if machine_state.indicators ^= 1
		then goto str1;

	     if a_reg.size < size then goto str1;

	     call adjust_ref_count(p,-1);

	     offset = a_reg.offset;
	     if offset ^= 0
	     then do;
		aq_length, k = offset + size;

		if size ^= a_reg.size
		     then a_reg.length = k;
		     else k, aq_length = a_reg.length;
		goto sh;
		end;

	     if mod(a_reg.length,bits_per_word) ^= 0 & ^ fs then goto mask_it;

	     if a_reg.size = size
	     then do;
		if mod(a_reg.length,bits_per_word) = 0
		     then call sv_value;
		return;
		end;

	     goto mask_it;
	     end;

	/* the following section handles the case which arises from
		unspec(fixed(float_var))
	   where the value we want can be in the q register */

	if p -> reference.value_in.q
	then do;
slide:	     units = p -> reference.units;
	     if units = word_ then cfo = 0;
	     else do;
		cfo = mod(p -> reference.c_offset * convert_offset(units),
		 bits_per_word);
		if cfo < 0 then cfo = cfo + bits_per_word;
		end;

	     call adjust_ref_count(p,-1);

	     /* this operation effectively erases both a and q
	        since the shift moves the value from q to a
	        rather than simply changing a_reg.offset */

	     call state_man$erase_reg("11"b);	/* fixes bug 1502 */

	     call expmac((lls),c_a((cfo + bits_per_word),1));

	     k, aq_length = size;

	     if fs then goto done; else goto l5;
	     end;

str1:	if size > bits_per_word then d = fixed(control ^= 0,1); else d = 0;

	aq_length = bits_per_word*(d + 1);

	if p -> reference.aligned_ref
	then do;
	     if ft then macro = test_lda; else macro = lda;
	     call expmac$one(macro,p,d);
	     goto done;
	     end;

	call setup;

sh:	if offset > 0
	then do;
	     call aq_man$left_shift(offset, k > bits_per_word);
	     k, aq_length = a_reg.length;
	     end;
	else if p -> reference.padded_ref then goto done;

l5:	if mod(k,bits_per_word) ^= 0
	then do;
mask_it:	     call aq_man$trim_aq(size);
l72:	     aq_length = bits_per_two_words;
	     end;

done:	if arith & ^ fs
	then do;

	     type = p -> reference.data_type;

	     if type <= real_fix_bin_2 | type = packed_ptr
	     then do;
		k = bits_per_two_words - size;
em:		call expmac(mac,c_a(k,1));
		goto thru;
		end;

	     if type <= real_flt_bin_2
	     then do;
		call expmac$zero(unpack_fl1 - real_flt_bin_1 + type);
		goto thru;
		end;

	     if type = complex_flt_bin_1
	     then do;
		k = bits_per_word - divide(size,2,17,0);
		if k > 0
		then do;
		     mac = unpack_cfl1;
		     goto em;
		     end;
		end;

	     goto thru;
	     end;

	a_reg.length = aq_length;
	a_reg.offset = 0;

done1:	a_reg.size = size;

	if a_reg.offset = 0
	then call sv_value;

	a_reg.number = 1;
	a_reg.variable(1) = p;
	p -> reference.value_in.a = "1"b;

	if fs
	then if ^ p -> reference.aligned_ref
	     then if a_reg.offset ^= 0 | mod(a_reg.length,bits_per_word) ^= 0
		then machine_state.indicators = 0;

back:	return;

load$for_test: entry(pt,control);

	/* this entry is called to load a bit string whose value
	   is to be tested against zero */

	p = pt;

	if ^ p -> reference.aligned_ref
	then if p -> reference.ref_count > 1
		then goto begin;

	ft = "1"b;
	arith, fs, available = "0"b;

	type = p -> reference.data_type;

	if p -> reference.ref_count > 1 then goto l4;

	if type ^= bit_string then goto l4;

	if p -> reference.value_in.a
	then do;
	     if machine_state.indicators = 1
	     then if a_reg.offset = 0
		then if mod(a_reg.length,bits_per_word) = 0
		      then goto drop;

	     call adjust_ref_count(p,-1);
	     available = "1"b;
	     end;

	size = p -> reference.c_length;

	if p -> reference.aligned_ref & ^ available
	then do;
	     call expmac$one((test_lda),p,control);
	     a_reg.offset = 0;
	     a_reg.length = fixed(size > bits_per_word,1) * bits_per_word + bits_per_word;
	     goto done1;
	     end;

	call setup;

	mask = (72)"0"b;
	substr(mask,cfo+1,size) = (72)"1"b;

	q = generate_constant(mask,d+1);

	call expmac(cana+d,q);

	if available then return;

done2:	a_reg.offset = cfo;
	a_reg.length = k;
	goto done1;

load$for_store: entry(pt,control);

	/* this entry is called to load a value which will be stored elsewhere */

	p = pt;

	if ^ p -> reference.aligned_ref
	then if p -> reference.ref_count > 1
	     then goto begin;

	fs = "1"b;
	arith, available, ft = "0"b;

	type = p -> reference.data_type;

	if type ^= char_string
	then if type ^= bit_string
	     then goto l4;

	if p -> reference.long_ref then goto lg;

	size = p -> reference.c_length * convert_size(type);

	if p -> reference.value_in.a
	     then if a_reg.size >= size
		then goto drop;
		else;
	     else if p -> reference.value_in.q
		then goto slide;

	if size = 0 then goto caq;

	if p -> reference.aligned_ref then goto str1;

	call setup;

	goto done2;

load$short_string: entry(pt,control);

	/* this procedure is called to load the first word or two
	   of a long string */

	fs = "1"b;
	arith, available, ft = "0"b;

	p = pt;
	type = p -> reference.data_type;

	size = bits_per_word*(control+1);
	goto l2;

load$long_string: entry(pt);

	/* this entry is called to load the long string register
	   with a short string */

	p = pt;
	type = p -> reference.data_type;
	goto lg;

load$for_save:	entry(pt,control);

	/* called by compile_exp$save when it has a hard_to_load string that wants to be
	   converted to an aligned temporary in storage and does not need to be loaded */

	p = pt;
	for_save = "1"b;
	go to begin;

sv_value:	     proc;

	     if ^ p -> reference.aligned_ref
	     then if p -> reference.ref_count > 0
		then call save_value(p);

	     end;

setup:	     proc;

	     dcl (p1,p2) ptr;

	     units = p -> reference.units;
	     if available
	     then cfo, offset = a_reg.offset;
	     else if units = word_
		then cfo, offset = 0;
		else do;
		     cfo = mod(p -> reference.c_offset * convert_offset(units),bits_per_word);
		     if cfo < 0 then cfo = cfo + bits_per_word;

		     if ^ p -> reference.hard_to_load
			then offset = cfo;
			else offset = 0;
		     end;

	     k = size + offset;

	     d = fixed(k > bits_per_word,1);

	     if available then return;

	/* if reference is hard to load we will move it into an aligned padded temporary
	   and load it from there */

	     if p -> reference.hard_to_load
	     then do;
		if (^ arith | mod(size,bits_per_word) = 0) & (p -> reference.ref_count > 1 | for_save)
		   & ^ p -> reference.aggregate
		then do;

		     /* We have a string with a high reference count, we will want future
		        reference to the string to be made to the temporary we are using
		        for the load */

		     call make_n_addressable(addr(pt),1);	/* make addressable and lock regs */

		     p2 = get_reference();		/* We will copy address into place holder */

		     p2 -> reference = p -> reference;
		     p2 -> reference.qualifier, p2 -> reference.offset, p2 -> reference.length = null;
		     string(p2 -> reference.info) = "0"b;
		     p2 -> reference.perm_address = "1"b;

		     call save_value(p);		/* convert to temporary */

		     p -> reference.value_in.storage = "1"b;
		     p1 = p;
		     end;

		else do;

		     /* Use double_temp as place to move */

		     p1 = c_a(46,4);
		     p2 = p;
		     end;

		dt = type - char_string;

		call expmac$two_eis(move_cs_load_1 + 2*d + dt,p1,p2);

		if for_save then go to back;

		call expmac$one((lda),p1,d);
		aq_length = bits_per_word * (d + 1);
		go to done;
		end;


	     call expmac$one((lda),p,d);

	     a_reg.size = size;
	     a_reg.offset = cfo;
	     a_reg.length = k;

	     end;

	end;




		    load_size.pl1                   10/03/83  1730.5rew 10/03/83  1008.9       47151



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


/* Program to load size of specified string

   Modified: 14 December 1972 by BLW
  Modified: 22 May 1973 by RAB
	Modified:	6 May 1977 by RAB to fix 1617
	Modified:	11 August 1978 by RAB to fix 1729
	Modified:	18 December 1978 by RAB to fix 1805	*/

load_size: proc(pt);

dcl	pt ptr;		/* points at reference node */
dcl	breg bit(4) aligned;	/* reg picked for loading size */
dcl	preg fixed bin;		/* reg to be used for loading size */

dcl	(p,q,q1) ptr,
	(for_eis,in_storage,in_str_aq,useless) bit(1) aligned,
	addr_hold bit(36) aligned,
	reloc_hold bit(12) aligned,
	macro fixed bin(15),
	(n,reg) fixed bin;

dcl	expmac entry(fixed bin(15),ptr),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	m_a entry(ptr,bit(2) aligned),
	eval_exp entry(ptr,bit(1) aligned) returns(ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	(state_man$flush_ref,state_man$update_ref) entry(ptr),
	aq_man$load_var entry(ptr,fixed bin),
	(aq_man$load_any_var_and_lock,xr_man$load_any_var_and_lock) entry(ptr,fixed bin,fixed bin),
	aq_man$lock entry(ptr,fixed bin);

dcl	(bit,fixed,null) builtin;

dcl	fix_bin(0:1) fixed bin based;

dcl	load_aq(2)	init(1,7) fixed bin(15) int static;

%include reference;
%include symbol;
%include operator;
%include nodes;

	for_eis = "0"b;
	reg = 2;
	go to join;

load_size$a_or_q:	entry(pt,preg);

	for_eis = "0"b;
	reg = preg;
	go to join;

load_size$xr_or_aq:	entry(pt,breg);

	for_eis = "1"b;

join:	p = pt;
	q = p -> reference.length;
	n = p -> reference.c_length;

	if p -> reference.varying_ref
	then do;

	     if q ^= null then goto l2;
	     if n ^= 0 then goto l3;

	     /* for a varying string, we'll load the word before the
	        start of the string if string is not constant */

	     q = p -> reference.offset;
	     if q = null
	     then do;
		q = p -> reference.symbol;
		if q -> symbol.constant
		then do;
		     n = q -> symbol.initial -> fix_bin(p -> reference.c_offset);
		     goto l3;
		     end;
		end;

	     if ^p -> reference.shared
		then p -> reference.ref_count = p -> reference.ref_count + 1;

	     if string(p -> reference.address_in.b) ^= "0"b & ^ p -> reference.temp_ref 
					/* temp_ref restriction same as in m_a */
	     then do;
		if p -> address.offset ^= (15)"0"b | p -> reference.no_address
		     then call m_a(p,"00"b);
		p -> address.offset = (15)"1"b;
		p -> reference.perm_address = "1"b;
		end;
	     else do;
		addr_hold = string(p -> reference.address);
		reloc_hold = p -> reference.relocation;
		p -> reference.c_offset = p -> reference.c_offset - 1;
		call m_a(p,"00"b);
		p -> reference.c_offset = p -> reference.c_offset + 1;
		p -> reference.perm_address = "1"b;
		end;

	     if for_eis
	     then do;
		q = p;
		call load_reg;

		/* We don't want to believe that the varying string itself
		   is in the a or q register */

		in_storage = p -> reference.value_in.storage;
		in_str_aq = p -> reference.value_in.string_aq;
		call state_man$flush_ref(p);
		if in_str_aq
		     then call state_man$update_ref(q);
		p -> reference.value_in.storage = in_storage;
		end;
	     else call expmac((load_aq(reg)),p);

	     if string(p -> reference.address_in.b) ^= "0"b & ^ p -> reference.temp_ref
	     then p -> address.offset = (15)"0"b;
	     else do;
		string(p -> reference.address) = addr_hold;
		p -> reference.relocation = reloc_hold;
		end;

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

	     return;
	     end;

	if q = null
	then do;
l3:	     q = generate_constant$real_fix_bin_1(n);
	     goto l1;
	     end;

l2:	if q -> node.type = operator_node
	then do;
	     q1 = q -> operand(1);
	     if q1 -> reference.evaluated then q = q1;
	     else do;
		q, p -> reference.length = eval_exp(q,"1"b);
		if q -> node.type = operator_node
		     then q = q -> operand(1);
		end;
	     end;

l1:	if ^ q -> reference.shared
	then q -> reference.ref_count = q -> reference.ref_count + 1;

	if q -> reference.data_type = 0 then q = prepare_operand(q,1,useless);

	if ^ for_eis
	     then call aq_man$load_var(q,reg);
	     else call load_reg;


load_reg:	proc;

dcl	reg fixed bin;

	if q -> reference.value_in.a
	then do;
	     breg = "0101"b;	/* a */
	     reg = 1;
	     go to lock_aq;
	     end;

	if q -> reference.value_in.q
	then do;
	     breg = "0110"b;	/* q */
	     reg = 2;
lock_aq:	     call aq_man$lock(null,reg);
	     if ^ q -> reference.shared
		then q -> reference.ref_count = q -> reference.ref_count - 1;
	     return;
	     end;

	if p -> reference.big_length
	then do;
	     call aq_man$load_any_var_and_lock(q,reg,0);
	     breg = "01"b || bit(fixed(reg,2),2);
	     end;
	else do;
	     call xr_man$load_any_var_and_lock(q,reg,0);
	     breg = "1"b || bit(fixed(reg,3),3);
	     end;

	end;



	end;




		    long_op.pl1                     10/03/83  1730.5rew 10/03/83  1008.9       58266



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


/* This procedure generates a jump to an out-of-line string operator,
   it loads	bp	with a pointer to the string
		q	with size of string
   before generating the jump

   Initial Version:  2 September 1971 by BLW for Version II
	Modified: 15 July 1972 by BLW	
	Modified:	15 February 1973 by RAB
	Modified:	11 June 1973 by RAB for EIS
	Modified:	26 November 1974 by RAB for long_op$one_eis
	Modified:	5 July 1976 by RAB to fix 1504	*/

long_op:	proc(pt,size,macro);

dcl	pt ptr,		/* ptr to reference node */
	size fixed bin,	/* = 0 means use size from reference node */
	macro fixed bin(15); /* operator to be generated */

dcl	cg_stat$extended_stack bit(1) ext;
dcl	cg_stat$text_pos fixed bin(18) ext;

dcl	(p,q) ptr,
	mac fixed bin(15),
	(no_size,have_arg,flush,adjust) bit(1),
	(i,n,cfo) fixed bin;

dcl	odd_bases bit(19) aligned int static init("0000000000000001111"b);

dcl	xr_man$load_var entry(ptr,fixed bin),
	xr_man$load_const entry(fixed bin,fixed bin),
	base_man$load_var entry(fixed bin,ptr,fixed bin),
	load_size entry(ptr),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	load entry(ptr,fixed bin),
	aq_man$lock entry(ptr,fixed bin),
	state_man$erase_reg entry(bit(19) aligned),
	state_man$unlock entry,
	need_temp entry(ptr,bit(2) aligned),
	expmac$zero entry(fixed bin(15)),
	(expmac,expmac$eis,expmac$one_eis) entry(fixed bin(15),ptr),
	adjust_ref_count entry(ptr,fixed bin),
	state_man$update_ref entry(ptr),
	base_man$update_base entry(fixed bin,ptr,fixed bin),
	c_a entry(fixed bin,fixed bin) returns(ptr);

dcl	mac_prog entry(fixed bin(15),ptr) variable;

dcl	(abs,mod,null) builtin;

dcl	ldfx1 fixed bin(15) int static init(7);

%include cgsystem;
%include reference;
%include data_types;

	p = pt;
	mac = macro;
	flush, no_size, have_arg = "0"b;

common:
l1:

/* load the string size if requested */


	if ^no_size
	     then if size = 0
		then call load_size(p);
		else call load(generate_constant$real_fix_bin_1(abs(size)),0);

/* lock the q register so that base_man doesn't accidentally flush it */

	call aq_man$lock(null,2);

	adjust = "0"b;

/* If this is a string temporary, protect it from premature release */

	if p -> reference.temp_ref
	     then if p -> reference.ref_count = 1
		     then do;
			adjust = "1"b;
			p -> reference.ref_count = 2;
			call need_temp(p,"11"b);
			end;

/* Load the bp with the address of the string */

	call base_man$load_var(2,p,1);

	if flush then call state_man$erase_reg((odd_bases));

	if have_arg then call expmac(mac,arg);
	else call expmac$zero(mac);

	call state_man$unlock;

	if adjust
	     then call adjust_ref_count(p,-1);

	return;

long_op$c_or_b: entry(pt,size,macro);

	p = pt;
	mac = macro;
	flush, no_size, have_arg = "0"b;

	if p -> reference.data_type = bit_string then mac = mac + 1;

	goto common;

long_op$extend_stack: entry(pt,op);

dcl	op fixed bin(15);

	p = pt;
	call load_size(p);
	call expmac$zero(op);
	cg_stat$extended_stack = "1"b;
	call state_man$update_ref(p);
	call base_man$update_base(2,p,1);
	return;

long_op$no_size: entry(pt,op);

	flush = "0"b;
n_size:
	p = pt;
	mac = op;
	no_size = "1"b;
	have_arg = "0"b;
	goto common;

long_op$with_arg: entry(pt,size,macro,arg);

dcl	arg ptr;

	p = pt;
	mac = macro;
	flush, no_size = "0"b;
	have_arg = "1"b;
	goto common;

long_op$io:	entry(pt,op);

	flush = "1"b;
	go to n_size;

long_op$eis_operator:	entry(pt,p2,macro);

dcl	(p2,ref(2)) ptr;
dcl	check bit(1) aligned;
dcl	base_man$load_var_and_lock entry(fixed bin,ptr,fixed bin);
dcl	load_size$a_or_q entry(ptr,fixed bin);

	/* Used to make 2 operand calls to pl1_operators_.   Pointers to operands 1 and 2
	are loaded into the bp and ab, respectively, and the lengths of the 2 operands
	are loaded into the q and a registers, respectively. */

	ref(1) = pt;
	ref(2) = p2;
	mac = macro;

	/* Protect length exprs & string temps from being prematurely released, then
	   load the pointer registers with the addresses of the operands, free the
	   unneeded temps, and load the lengths */

	do i = 1 to 2;
	if ^ ref(i) -> reference.shared
	then do;
	     n, ref(i) -> reference.ref_count = ref(i) -> reference.ref_count + 1;
	     check = n = 2;
	     end;
	else check = "0"b;
	call base_man$load_var_and_lock(2,ref(i),2*i-1);
	if check then call need_temp(ref(i),"11"b);
	call load_size$a_or_q(ref(i),3-i);
	if i = 1
	     then call aq_man$lock(null,2);
	end;

	/* Unlock the registers and issue the macro */

	call state_man$unlock;

	call expmac$zero(macro);

	/* Lower reference counts originally raised */

	do i = 1 to 2;
	if ^ ref(i) -> reference.shared then call adjust_ref_count(ref(i),-1);
	end;

	return;

long_op$eis:	entry(pt,size,macro);

dcl	size_hold fixed bin(24);
dcl	length_hold ptr unal;
dcl	big_length_hold bit(1) aligned;

	mac_prog = expmac$eis;
	go to eis_join;

long_op$one_eis:	entry(pt,size,macro);

	mac_prog = expmac$one_eis;

eis_join:
	p = pt;
	mac = macro;

	if size = 0
	then call mac_prog(mac,p);
	else do;
	     call save_length;
	     call mac_prog(mac,p);
	     call restore_length;
	     end;

	return;

long_op$two_eis:	entry(pt,size,macro,pt2);

dcl	pt2 ptr;
dcl	expmac$two_eis entry(fixed bin(15),ptr,ptr);

	p = pt2;

	if size = 0
	then call expmac$two_eis(macro,pt,p);
	else do;
	     call save_length;

	     call expmac$two_eis(macro,pt,p);

	     call restore_length;
	     end;

	return;

save_length:	proc;

	     size_hold = p -> reference.c_length;
	     length_hold = p -> reference.length;
	     big_length_hold = p -> reference.big_length;
	     p -> reference.c_length = size;
	     p -> reference.big_length = size > max_index_register_value;
	     p -> reference.length = null;

	     end;

restore_length:	proc;

	     p -> reference.big_length = big_length_hold;
	     p -> reference.c_length = size_hold;
	     p -> reference.length = length_hold;
	     if length_hold ^= null
	     then if p -> reference.ref_count = 0
		then call adjust_ref_count((length_hold),-1);

	     end;

	end;




		    m_a.pl1                         09/19/89  1224.3rew 09/19/89  1013.9      241947



/****^  ***********************************************************
        *                                                         *
        * 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-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
     install(89-09-19,MR12.3-1068):
     Fix bug 1899.
                                                   END HISTORY COMMENTS */


/* Program to make a reference addressable

   Initial Version: 16 April 1971 by BLW for Version II
	Modified: 10 May 1973 by RAB for multiple base regs
	Modified:	19 June 1973 by RAB for EIS
	Modified:	4 June 1975 by RAB for separate_static
	Modified:	27 November 1975 by RAB to fix 1431
	Modified:	11 May 1976 by RAB to fix 1496
	Modified:	2 Oct 1976 by RAB to fix 1530
	Modified:	9 Mar 1977 by RAB to eliminate mod_word operator
	Modified:	11 Jan 1978 by RAB to set base_regs(i).used
	Modified:	11 Aug 1978 by RAB to fix 1734
	Modified:	31 Dec 1978 by RAB to fix 1807 (bad code for internal
		file constants if linkage section >16k)
	Modified: 14 Dec 1988 by RW null pointer with defined references.
*/
/* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
%page;
m_a:
     proc (pt, bits);

dcl      pt ptr,					/* points at ref node to be made addressable */
         bits aligned bit (2),			/* 2 bits as follows: */
         no_ind aligned bit (1),			/* "1"b if no indirection allowed */
         eis aligned bit (1);				/* "1"b if addressing for EIS instruction */

dcl      (
         cg_stat$cur_block,
         cg_stat$cur_statement,
         cg_stat$long_string_temp
         ) ptr ext,
         cg_stat$extended_stack bit (1) ext,
         cg_stat$text_pos fixed bin (18) ext,
         cg_stat$cur_level fixed bin ext;

dcl      ref ptr,					/* points at ref node to be made addressable */
         r1 ptr;					/* points at ref node from which addressing info
				   is obtained.  r1 starts off equal to ref. */

dcl      (p1, p2, ro, s1, q, vwo) ptr,
         (i, k) fixed bin,
         xr fixed bin (3),
         base bit (3),
         (dont_load, have_loaded, useless) bit (1) aligned,
         (word_offset, save_word_offset, off, delta) fixed bin (15),
         (fract_offset, save_fract_offset, fo) fixed bin (6),
         (ind_word, multiple) fixed bin (18),
         base_offset fixed bin (24),
         locked bit (1) aligned,
         fok bit (1) aligned,
         (tag, tagind) bit (6) aligned,
         reloc bit (12) aligned,
         op_code bit (9) aligned;

dcl      (abs, bit, divide, fixed, mod, null, string, substr) builtin;

dcl      m_a entry (ptr, bit (2) aligned);
dcl      expmac entry (fixed bin (15), ptr);
dcl      base_man$load_arg_ptr entry (fixed bin, ptr, fixed bin) returns (bit (3) aligned);
dcl      base_man$load_stack_indirect entry (fixed bin (18)) returns (bit (3) aligned);
dcl      base_man$load_display entry (fixed bin) returns (bit (3) aligned);
dcl      base_man$load_link_indirect entry (fixed bin, bit (12) aligned) returns (bit (3) aligned);
dcl      base_man$load_controlled entry (fixed bin, fixed bin (15)) returns (bit (3) aligned);
dcl      base_man$load_linkage entry returns (bit (3) aligned);
dcl      base_man$load_static entry returns (bit (3) aligned);
dcl      base_man_link_or_static entry returns (bit (3) aligned) variable;
dcl      base_man$load_any_var entry (fixed bin, ptr) returns (bit (3) aligned);
dcl      base_man$load_arg entry (fixed bin, ptr) returns (bit (3) aligned);
dcl      base_man$load_var entry (fixed bin, ptr, fixed bin),
         stack_temp$free_temp entry (ptr),
         stack_temp$assign_temp entry (ptr),
         stack_temp$assign_block entry (ptr, fixed bin),
         stack_temp$assign_aggregate entry (ptr),
         stack_temp$assign_return_value entry (ptr),
         copy_temp entry (ptr) returns (ptr),
         cg_error entry (fixed bin, fixed bin),
         error entry (fixed bin, ptr, ptr),
         prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
         aq_man$load_any_const entry (fixed bin (24), fixed bin (2)),
         aq_man$load_any_var entry (ptr, fixed bin (2), fixed bin (24)),
         xr_man$lock entry (ptr, fixed bin (3)),
         xr_man$unlock entry (fixed bin (3)),
         xr_man$load_any_const entry (fixed bin (18), fixed bin (3)),
         xr_man$load_any_var entry (ptr, fixed bin (3), fixed bin (18));

dcl      (
         r_mod init ("001"b),
         ri_mod init ("011"b),
         ir_mod init ("111"b)
         ) bit (3) int static;

dcl      (
         aq_mod init ("0001"b),
         iaq_mod init ("1101"b)
         ) bit (4) int static;

dcl      fix_bin fixed bin (15) based;

dcl      (
         first_base init (1),
         last_base init (6)
         ) fixed bin int static;

dcl      load_pt init (60) fixed bin (15) int static;

%page;
%include cgsystem;
%page;
%include nodes;
%page;
%include cg_reference;
%page;
%include symbol;
%page;
%include temporary;
%page;
%include operator;
%page;
%include block;
%page;
%include relocation_bits;
%page;
%include op_codes;
%page;
%include bases;
%page;
%include machine_state;
%page;
%include boundary;
%page;
/* program */

	no_ind = substr (bits, 1, 1);
	eis = substr (bits, 2, 1);

	ref, r1 = pt;
	if ^ref -> reference.no_address then
	     if ref -> reference.perm_address then
		if no_ind then
		     goto test1;
		else
		     return;

	dont_load, ref -> reference.even, ref -> reference.forward_ref, ref -> reference.ic_ref,
	     ref -> reference.relocation, string (ref -> reference.address) = "0"b;

	ref -> reference.c_f_offset = 0;

	s1 = ref -> reference.symbol;

/* check for address already in a base register 
	   (we skip this code for temporaries so that
	    store$save_string_temp works)	        */

	if ^ref -> reference.temp_ref then do;

	     if string (ref -> reference.address_in.b) then
		do i = first_base to last_base;
		     if ref -> reference.address_in.b (i) then do;
			ref -> reference.base = bases (i);
			ref -> reference.ext_base = "1"b;
			base_regs (i).used = cg_stat$text_pos;
			return;
		     end;
		end;

	end;

	locked, reloc = "0"b;

/* get variable word offset */

	call get_vwo (ref);

	word_offset, fract_offset = 0;
	call get_c_offset;

	if ^eis then
	     fok = "1"b;
	else
	     fok = fract_offset = 0 & ^(no_ind & vwo ^= null);

	if ref -> reference.temp_ref then do;

temp:
	     if r1 -> reference.aggregate then do;
		if s1 -> symbol.varying then
		     word_offset = word_offset + 1;

/* if the temp aggregate is a structure, we want to allocate
		   the level 1 temporary instead of the descendant */

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

		if p1 -> symbol.initial = null then
		     call stack_temp$assign_aggregate (p1);

		p2 = p1 -> symbol.initial;

		if p1 -> symbol.word_size = null then do;
		     word_offset = word_offset + p2 -> temporary.location;
		     goto lv;
		end;

		call load_vwo;

		if word_offset = 0 & fok & abs (p2 -> temporary.location) < 16384 then do;
		     tag = tagind;
		     word_offset = p2 -> temporary.location;
		     goto t1;
		end;

		ref -> address.base = base_man$load_stack_indirect (p2 -> temporary.location);
		goto so1;
	     end;

	     if r1 -> reference.address_in.storage then do;
		if r1 -> reference.allocated then
		     if r1 -> reference.qualifier ^= null then
			ind_word = r1 -> reference.qualifier -> temporary.location;
		     else
			goto err330;
		else if r1 -> reference.value_in.string_aq then
		     ind_word = fixed (cg_stat$long_string_temp -> address.offset, 15);
		else do;
err330:
		     call error (330, cg_stat$cur_statement, r1);
		     return;
		end;
		if word_offset = 0 & fok then do;
		     r1 -> reference.even = "1"b;
		     word_offset = ind_word;
		     call load_vwo;
		     tag = tag | substr (ri_mod, 1, 2);
		     goto t1;
		end;
		else do;
		     call load_vwo;
		     ref -> address.base = base_man$load_stack_indirect (ind_word);
		     goto so;
		end;
	     end;

	     if ^r1 -> reference.allocated then do;
		if ^r1 -> reference.allocate then
		     ref, r1, pt = copy_temp (r1);
		call stack_temp$assign_temp (r1);
	     end;
	     else if r1 -> reference.qualifier = null then do;
		call error (316, cg_stat$cur_statement, r1);
		return;
	     end;

	     word_offset = word_offset + r1 -> reference.qualifier -> temporary.location;
	     goto lv;
	end;

	p1 = ref -> reference.qualifier;

	if s1 -> node.type ^= symbol_node then
	     goto dr;

	if s1 -> symbol.return_value then do;

	     do p2 = s1 repeat p2 -> symbol.father while (p2 -> symbol.father ^= null);
	     end;

	     p1 = p2 -> symbol.initial;

	     if p1 ^= null /* not 1st reference */ then do;
		if s1 -> symbol.varying then
		     if s1 -> symbol.dimensioned | s1 -> symbol.member then
			word_offset = word_offset + 1;
		call load_vwo;

		if word_offset = 0 & fok & abs (p1 -> temporary.location) < 16384 then do;
		     word_offset = p1 -> temporary.location;
		     tag = tagind;
		end;
		else do;
		     ref -> address.base = base_man$load_stack_indirect (p1 -> temporary.location);
		     goto so1;
		end;

	     end;
	     else do;				/* p1 is NULL */

/* 1st reference, get 2 word slot to hold ptr to datum */

		call stack_temp$assign_return_value (p2);
		p1 = p2 -> symbol.initial;
		word_offset = p1 -> temporary.location;
		call load_vwo;

/* the stack will get extended when call is made to the procedure
returning the star extent value, so turn the bit on now */

		cg_stat$extended_stack = "1"b;
	     end;

	     goto t1;
	end;

dr:
	if ref -> reference.defined_ref then do;
	     if p1 = null then do;			/* write file (afile) from (thing); where "thing" is a defined  structure */
		p1 = s1 -> symbol.reference -> reference.qualifier;
	     end;

	     r1 = p1;

l0:
	     if r1 -> node.type = operator_node then
		r1 = r1 -> operand (1);

	     if r1 -> reference.defined_ref then do;
		r1 = r1 -> reference.qualifier;
		goto l0;
	     end;

	     if s1 -> symbol.varying & s1 -> symbol.member then
		word_offset = word_offset + 1;

l0b:
	     s1 = r1 -> reference.symbol;

	     if r1 -> reference.temp_ref & r1 -> reference.address_in.storage then
		goto l0a;

	     if s1 -> symbol.return_value then
		goto l0a;

	     if vwo = null & ref -> reference.units = r1 -> reference.units then
		call get_vwo (r1);
	     else if r1 -> reference.offset ^= null then do;
l0a:
		if ^r1 -> reference.shared then
		     r1 -> reference.ref_count = r1 -> reference.ref_count + 1;
		ref -> address.base = base_man$load_any_var (2, r1);
		call load_vwo;
		goto so1;
	     end;

	     call get_c_offset;

	     if r1 -> reference.temp_ref then
		goto temp;

	     p1 = r1 -> reference.qualifier;
	end;

	if p1 ^= null then
	     goto have_qual;

	if s1 -> node.type = label_node then
	     goto lv;

	if s1 -> symbol.constant then do;
	     if s1 -> symbol.varying then
		word_offset = word_offset + 1;
	     if s1 -> symbol.file & s1 -> symbol.internal then
		word_offset = word_offset + s1 -> symbol.location;
	     goto lv;
	end;

	if s1 -> symbol.parameter | s1 -> symbol.param_desc then do;
	     p1 = s1 -> symbol.reference -> reference.qualifier;
	     goto have_qual;
	end;

	if r1 -> reference.temp_ref then
	     word_offset = word_offset + r1 -> reference.qualifier -> temporary.location;
	else if ^(s1 -> symbol.static & s1 -> symbol.external | s1 -> symbol.controlled) then
	     word_offset = word_offset + s1 -> symbol.location;

	if s1 -> symbol.varying then
	     if s1 -> symbol.auto | s1 -> symbol.static | s1 -> symbol.controlled then
		word_offset = word_offset + 1;

/* load variable word offset into an index register and reduce
	   word offset to a value less than 16384 */

lv:
	call load_vwo;

	if s1 ^= null then
	     if s1 -> node.type = label_node then
		goto l3a;

	if r1 -> reference.temp_ref then do;
t1:
	     ref -> address.base = sp;
	     goto so;
	end;

	if s1 -> symbol.auto then do;

	     k = cg_stat$cur_level - s1 -> symbol.block_node -> block.level;
	     if k = 0 then
		goto t1;

/* load ptr to display(k) level back */

	     ref -> address.base = base_man$load_display (k);

so:
	     if tag = "000000"b then
		ref -> reference.even = mod (word_offset, 2) = 0;

so1:
	     ref -> address.offset = bit (word_offset, 15);
	     if eis then
		ref -> reference.c_f_offset = fract_offset;

	     ref -> address.tag = tag;
	     ref -> reference.relocation = reloc;

seteb1:
	     ref -> address.ext_base = "1"b;

/* if no indirection is permitted, we may have to generate a
	        ptr to the reference in a base register */

	     if no_ind then do;

test1:
		if substr (ref -> address.tag, 1, 2) = "00"b then
		     return;

/* we have to load pointer to reference into a base to get rid
		   of indirection, but we don't want to count this as a reference */

		ref -> reference.perm_address = "1"b;

call_baseman:
		if ^ref -> reference.shared then
		     ref -> reference.ref_count = ref -> reference.ref_count + 1;

		base = base_man$load_any_var (2, ref);

		ref -> address.ext_base = "1"b;
		ref -> address.base = base;

		ref -> reference.c_f_offset = 0;
		ref -> address.tag, ref -> address.offset, ref -> reference.perm_address = "0"b;

	     end;

	     return;
	end;

	if s1 -> symbol.static then do;

	     if s1 -> symbol.internal then do;
is:
		reloc = rc_is15;
		ref -> address.base = base_man$load_static ();
		goto so;
	     end;

/* external static or reference to link */

lr:
	     reloc = rc_lp15;
	     base_man_link_or_static = base_man$load_linkage;

lr1:
	     if word_offset = 0 & fok then do;

		off = s1 -> symbol.location;
		if off >= 16384 then do;
		     if tag ^= (6)"0"b then
			goto gen;

		     multiple = off - mod (off, 16384);
		     call xr_man$load_any_const (multiple, xr);
		     tagind = ri_mod || bit (xr, 3);

		     off = off - multiple;
		end;

		ref -> address.base = base_man_link_or_static ();
		ref -> reference.relocation = reloc;
		ref -> address.offset = bit (fixed (off, 15), 15);
es:
		ref -> reference.tag = tagind;
		goto seteb1;
	     end;

/* generate an instruction of the form
			eapbp	lp|k,*
	        where 'k' is offset of link */

gen:
	     ref -> address.base = base_man$load_link_indirect ((s1 -> symbol.location), reloc);
	     reloc = "0"b;
	     goto so1;
	end;

	if s1 -> symbol.constant then do;

	     if s1 -> symbol.entry then
		if s1 -> symbol.initial ^= null | s1 -> symbol.internal then
		     goto l3a;
		else
		     goto lr;

	     if s1 -> symbol.external then
		goto lr;

	     if s1 -> symbol.file then
		goto is;

	     if s1 -> symbol.equivalence ^= null then
		s1 = s1 -> symbol.equivalence;

l3a:
	     if ^s1 -> symbol.allocated then do;
		ref -> reference.forward_ref = "1"b;

		if tag ^= "000000"b | word_offset ^= 0 then do;
		     p1 = s1 -> symbol.reference;
		     if p1 -> reference.data_type = 0 then
			p1 = prepare_operand (p1, 0, useless);
		     ref -> address.base = base_man$load_any_var (2, p1);
		     goto so1;
		end;

		if s1 -> node.type = symbol_node then
		     if s1 -> symbol.c_word_size = 2 | s1 -> symbol.boundary = mod2_ then
			ref -> reference.even = "1"b;

		goto l3b;
	     end;

/* the constant reference occurs earlier in text section */

	     word_offset = word_offset + s1 -> symbol.location;

	     if tag = "000000"b then do;
		ref -> reference.even = mod (word_offset, 2) = 0;
l3b:
		ref -> reference.ic_ref = "1"b;
		ref -> address.tag = "000100"b;	/* IC */
	     end;
	     else do;
		ref -> reference.relocation = rc_t;
		ref -> address.tag = tag;
	     end;

/* put an 18 bit offset into the address */

	     substr (string (ref -> reference.address), 1, 18) = bit (fixed (word_offset, 18), 18);
	     if eis then
		ref -> reference.c_f_offset = fract_offset;
	     return;
	end;

	if s1 -> symbol.controlled then do;

	     if tag = "0"b then
		ref -> reference.even = mod (word_offset, 2) = 0;

	     if s1 -> symbol.internal then do;
		reloc = rc_is15;
		base_man_link_or_static = base_man$load_static;
		goto lr1;
	     end;

/* external controlled */

	     delta = 2 * fixed (s1 -> symbol.arg_descriptor, 1);

	     if word_offset = 0 & fok then do;
		ref -> address.base = base_man$load_link_indirect ((s1 -> symbol.location), (rc_lp15));
		ref -> address.offset = bit (delta, 15);
		ref -> address.tag = tagind;
	     end;
	     else do;
		ref -> address.base = base_man$load_controlled ((s1 -> symbol.location), delta);
		ref -> address.offset = bit (word_offset, 15);
		ref -> address.tag = tag;
		if eis then
		     ref -> reference.c_f_offset = fract_offset;
	     end;

	     goto seteb1;
	end;

/* ERROR */

	call cg_error (305, fixed (string (s1 -> symbol.storage_class), 10));
	goto t1;

/* have a qualifier */

have_qual:
	if s1 -> symbol.varying then
	     if s1 -> symbol.based | (s1 -> symbol.auto & s1 -> symbol.exp_extents) | s1 -> symbol.member then
		word_offset = word_offset + 1;

	if eis then
	     if ref -> reference.units = word_ then
		if abs (word_offset) >= 16384 then
		     goto call_baseman;

	if p1 -> node.type = reference_node then
	     goto l5;

	op_code = p1 -> operator.op_code;

	if op_code = addr_fun then do;
	     if p1 -> operand (1) -> reference.evaluated then
		goto l4a;

	     r1 = p1 -> operand (2);

	     if r1 -> reference.varying_ref then
		word_offset = word_offset - 1;

	     if r1 -> reference.defined_ref then
		goto l0a;
	     goto l0b;
	end;

	if op_code = param_ptr then do;
	     i = 0;				/* load arg ptr */
	     goto l4;
	end;

	if op_code = param_desc_ptr then do;
	     i = 1;				/* load desc ptr */

l4:
	     call load_vwo;

	     q = p1 -> operand (3);
	     k = p1 -> operand (2) -> reference.symbol -> symbol.initial -> fix_bin;

	     if word_offset = 0 & fok & ^no_ind then do;
		ref -> address.base = base_man$load_arg (i, q);
		ref -> address.offset = bit (fixed (2 * (k - i), 15), 15);
		goto es;
	     end;

	     ref -> address.base = base_man$load_arg_ptr (i, q, k);
	     goto so1;
	end;

/* the operator is not a special one, so it must have been
	   evaluated by prepare_operand, pick up the temporary */

l4a:
	p1 = p1 -> operand (1);

l5:
	if ^p1 -> reference.shared then
	     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;

/* check to see if the value of the qualifier is in a base */

	do i = first_base to last_base;
	     if p1 -> reference.value_in.b (i) then do;

/* value is in base, load vwo into an xr and
		   see if value of qualifier is still in base;
		   if so, we're home free! */

		call load_vwo;

		if p1 -> reference.value_in.b (i) then do;
		     ref -> address.base = bases (i);
		     base_regs (i).used = cg_stat$text_pos;

		     if ^p1 -> reference.shared then
			p1 -> reference.ref_count = p1 -> reference.ref_count - 1;
		     goto so1;
		end;

/* the qualifier got forced out of the base by
   the process of making the variable word offset
   addressable, so go lock the offset in the index */

		goto lock;
	     end;

	end;

/* if the variable word offset and qualifier are not both automatic
	   variables declared in the current stack frame, we may have a
	   conflict such that the base register(s) needed to address the
	   offset may conflict with the base register(s) needed to address
	   the qualifier.  We resolve this problem by loading the offset
	   into the index register before making the pointer addressable
	   rather than afterwards, and call a special entry to "lock"
	   the value into the index register.  (Note that if the ref has a "big"
	   offset, loading it requires the a or q, which could affect
	   the qualifier's offset.) */

	if ^ro -> reference.big_offset then do;
	     if vwo = null then
		goto l6;

	     p2 = vwo -> reference.symbol;
	     if p2 -> symbol.temporary then
		goto l6;

	     if p2 -> symbol.auto then
		if p2 -> symbol.block_node = cg_stat$cur_block then
		     goto l6;

	     if p1 -> reference.temp_ref then
		goto l6;

	     p2 = p1 -> reference.symbol;
	     if p2 -> symbol.auto then
		if p2 -> symbol.block_node = cg_stat$cur_block then
		     goto l6;
	end;

/* may have the conflict */

	call load_vwo;

lock:
	if xr >= 0 then do;
	     call xr_man$lock (vwo, xr);
	     locked = "1"b;
	end;

	word_offset = save_word_offset;
	fract_offset = save_fract_offset;

/* make the qualifier permanently addressable */

l6:
	call m_a (p1, "00"b);
	p1 -> reference.perm_address = "1"b;

	if locked then do;
	     if vwo -> reference.value_in.x (xr) then
		dont_load = "1"b;
	     call xr_man$unlock (xr);
	     if base_offset ^= 0 then
		vwo -> reference.value_in.x (xr) = "0"b;
	end;

	call load_vwo;

/* we may be able to use the ptr via indirection if the qualified
	   variable has a zero word offset and there is no subscript or
	   indirection on the qualifier */

	if word_offset ^= 0 then
	     goto l7;

	if ^fok then
	     goto l7;

	if no_ind then
	     goto l7;

	if tag then
	     if substr (p1 -> reference.tag, 3, 4) then
		goto l7;

	if substr (p1 -> reference.tag, 1, 2) then
	     base = base_man$load_any_var (2, p1);
	else if ^p1 -> reference.shared then
	     p1 -> reference.ref_count = p1 -> reference.ref_count - 1;

	string (ref -> address) = string (p1 -> address);
	ref -> reference.relocation = p1 -> reference.relocation;

	if tag then
	     ref -> address.tag = tagind;
	else
	     substr (ref -> address.tag, 1, 2) = ri_mod;

	p1 -> reference.perm_address = "0"b;

	goto seteb1;

/* can't use the qualifier via indirection, have to load
	   it into a base register */

l7:
	ref -> address.base = base_man$load_any_var (1, p1);
	p1 -> reference.perm_address = "0"b;

	goto so1;

%page;
get_c_offset:
     proc ();

dcl      word_off fixed bin (15);
dcl      fract_off fixed bin (6);

	if r1 -> reference.c_offset = 0 then
	     return;

	word_off = divide (r1 -> reference.c_offset, units_per_word (r1 -> reference.units), 15, 0);
	fract_off = mod (r1 -> reference.c_offset, units_per_word (r1 -> reference.units));

	if fract_off ^= 0 then
	     if r1 -> reference.c_offset < 0 then
		word_off = word_off - 1;

	word_offset = word_offset + word_off;

	if ref -> reference.units = r1 -> reference.units then do;
	     fract_offset = fract_offset + fract_off;

	     if fract_offset >= units_per_word (r1 -> reference.units) then do;
		fract_offset = fract_offset - units_per_word (r1 -> reference.units);
		word_offset = word_offset + 1;
	     end;
	end;

     end get_c_offset;


%page;
/* vwo takes on two different meanings depending on the value of eis.  When
   eis is "0"b, vwo means variable_word_offset.  However, when eis is "1"b,
   vwo refers to variable offset instead of variable_word_offset unless 
   reference.modword_in_offset is ON.  The EIS instructions take their offsets
   in the reference units rather than in word units like the other instructions. */

get_vwo:
     proc (rp);

dcl      rp ptr parameter;

	have_loaded = "0"b;

	ro = rp;

	vwo = rp -> reference.offset;

	if vwo ^= null then do;
	     if rp -> reference.units = word_ | rp -> reference.modword_in_offset then do;
		if eis then
		     goto call_baseman;
	     end;
	     else if ^eis then
		goto print;

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

	     if ^vwo -> reference.shared then
		vwo -> reference.ref_count = vwo -> reference.ref_count + 1;
	end;

	return;

print:
	call error (312, cg_stat$cur_statement, rp);
	vwo = null;
     end get_vwo;
%page;
load_vwo:
     proc ();

dcl      bxr bit (3) aligned;
dcl      aq fixed bin (2);
dcl      baq bit (2) aligned;

dcl      max_num (18) fixed bin (18) int static
	    init (1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767, 65535, 131071, 262143);

	xr = -1;

	save_word_offset = word_offset;
	save_fract_offset = fract_offset;
	base_offset = 0;

	if s1 ^= null then do;
	     if s1 -> node.type ^= symbol_node then
		goto vwo_1;
	     if s1 -> symbol.constant & ^ro -> reference.temp_ref & ^(s1 -> symbol.internal & s1 -> symbol.file) then
		goto vwo_1;
	end;

	if abs (word_offset) >= 16384 then do;
	     base_offset = word_offset - mod (word_offset, 16384);
	     word_offset = word_offset - base_offset;
	end;

vwo_1:
	if eis then do;
	     if base_offset ^= 0 then
		if ro -> reference.units = word_ then
		     goto call_baseman;
		else
		     base_offset = base_offset * units_per_word (ro -> reference.units);
	     if ^no_ind then do;
		base_offset = base_offset + fract_offset;
		fract_offset = 0;
		fok = "1"b;
	     end;
	end;

	if dont_load then
	     goto vwo_3;

	if vwo ^= null then do;

	     if eis then do;
		if ro -> reference.big_offset then
		     goto large;
		if base_offset > 0 then
		     if base_offset + max_num (vwo -> reference.symbol -> symbol.c_dcl_size)
			> max_index_register_value then
			goto large;
	     end;

	     if have_loaded then
		if ^vwo -> reference.shared then
		     vwo -> reference.ref_count = vwo -> reference.ref_count + 1;

	     have_loaded = "1"b;

/* can use QL | AL modification if value of offset is in Q|A register
		   and we don't have complex data type */

	     if s1 -> node.type = symbol_node then
		if s1 -> symbol.complex then
		     goto vwo_1a;

	     if base_offset ^= 0 then
		goto vwo_1a;

	     if vwo -> reference.value_in.q then do;
		tag = "000110"b;			/* ql */
		tagind = "110110"b;			/* *ql */

vwo_1b:
		if ^vwo -> reference.shared then
		     vwo -> reference.ref_count = vwo -> reference.ref_count - 1;

		goto vwo_3;
	     end;

	     if vwo -> reference.value_in.a then do;
		tag = "000101"b;			/* al */
		tagind = "110101"b;			/* *al */
		goto vwo_1b;
	     end;

vwo_1a:
	     call xr_man$load_any_var (vwo, xr, (base_offset));
	     goto vwo_2;
	end;

	if base_offset ^= 0 then do;
	     if base_offset >= 262144 then do;
		call aq_man$load_any_const (base_offset, aq);
		goto vwo_4;
	     end;
	     call xr_man$load_any_const ((base_offset), xr);
vwo_2:
	     bxr = bit (xr, 3);
	     tag = r_mod || bxr;
	     tagind = ir_mod || bxr;
	end;
	else do;
	     tag = "000000"b;
	     tagind = "010000"b;
	end;

vwo_3:
	if word_offset < 0 then
	     word_offset = word_offset + 262144;

	return;

large:
	if have_loaded then
	     goto vwo_3;
	call aq_man$load_any_var (vwo, aq, base_offset);
vwo_4:
	baq = bit (aq, 2);
	tag = aq_mod || baq;
	tagind = iaq_mod || baq;
	have_loaded = "1"b;
	goto vwo_3;

     end load_vwo;

     end m_a;




		    macro_table.table               07/30/86  0926.6rew 07/30/86  0925.4      543600



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1986 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-07-15,Ginter), approve(86-07-15,MCR7287),
"     audit(86-07-16,Mabey):
"     Bug fixes for the MR12.0 release of the compiler
"                                                      END HISTORY COMMENTS

" pl/1 macro definition segment
"
"	Modified: 15 Feb 1978 by PCK to implement options(main) and the stop statement
"	Modified: 29 Mar 1978 by PCK to implement macro for storing sp
"	Modified: 16 June 1978 by PCK to implement size checking for unsigned binary
"	Modified: 25 Aug 1978 by RAB to help fix 1780
"	Modified: 19 Dec 1978 by RAB to improve ref cnt in bound_ck op
"	Modified: 24 Apr 1979 by PCK to implement 4-bit decimal
"	Modified: 16 Jul 1979 by RAB to remove absfx1_atm
"	Modified: 26 Jul 1979 by PCK to implement rank and byte builtins
"	Modified 790801 by PG to remove dvfx2, dvfx3, j_3_way*, and validate_pic.
"	Modified 790817 by RAB to improve code for a & ^ b where a and b are long strings.
"	Modified 790821 by RAB so that (move test)_andnot_1 use a fill of 1 to take care of source
"		being shorter than the target.
"	Modified December '79 by BSG for index_rev_* ops, and removing some superfluous
"		indications of sr erasing.
"	Modified 18 June 1980 by M. N. Davidoff to indicate that ix_chars and ix_rev_chars erase sr.
"		This turns out not to be superfluous.  (bug 1970)
"	Modified 11 September 81 by EBush to add prepare_call_long and
"		prepare_quick_call_long.
"	Modified 26 July 82 BIM wordno and segno
"	Modified 04 January 85 Keith Loepere to get ringno in baseptr right
"	Modified 20 June 86 MM unpack_fl1 modifies A and Q regs
"
	name	macro_table
	segdef	macro_table
	segdef	macro_count
	segdef	eax_array
"
	bool	op_vec,551	from assembly of pl1_operators
	bool	mod2_tab,543
	bool	mod4_tab,545
	bool	tct_mask_,242
	bool	ptr_mask_,460
	bool	fx1_to_fl2_,465	..
	bool	fx2_to_fl2_,466	..
	bool	blanks_,440	..
	bool	r_l_a_,474	..
	bool	r_g_s_,477	..
	bool	r_g_a_,503	..
	bool	r_l_s_,507	..
	bool	r_e_as_,512	..
	bool	r_ne_as_,515	..
	bool	r_le_a_,520	..
	bool	r_ge_s_,524	..
	bool	r_ge_a_,527	..
	bool	r_le_s_,532	..
	bool	set_stack_,540	..
	bool	ones,110		..
	equ	lg1,50
"
	equ	ops_ptr,28
	equ	csl_vector,-114
	equ	bitno_to_charno_,-790
"
	equ	ps_ptr,42
"
" The following bits are used to indicate which register are changed by a macro
"
	bool	a,400000
	bool	q,200000
	bool	aq,a+q
	bool	sr,100000
	bool	cr,040000
	bool	dr,020000
	bool	x0,010000
	bool	x1,004000
	bool	x2,002000
	bool	x3,001000
	bool	x4,000400
	bool	x5,000200
	bool	x6,000100
	bool	x7,000040
	bool	bp,000020
	bool	lp,000010
	bool	indices,x0+x1+x2+x3+x4+x5+x6+x7
	bool	bases,bp+lp
	bool	all,aq+indices+bases+cr+dr+sr
"
" The following bits indicate if a particular type of address modification
" is not allowed on arg1 of a macro
"
	bool	no_al,000004
	bool	no_ql,000002
	bool	perm,000001
"
" The following bits are used for expanding EIS macros
"
	bool	cat,400000
	bool	l_in_q,200000
	bool	compare,100000
	bool	xec_eis,40000
"
eax_array:
	eax0	0,ql
	eax1	0,ql
	eax2	0,ql
	eax3	0,ql
	eax4	0,ql
	eax5	0,ql
	eax6	0,ql
	eax7	0,ql
	eax0	0,al
	eax1	0,al
	eax2	0,al
	eax3	0,al
	eax4	0,al
	eax5	0,al
	eax6	0,al
	eax7	0,al
	eax0	0,au
	eax1	0,au
	eax2	0,au
	eax3	0,au
	eax4	0,au
	eax5	0,au
	eax6	0,au
	eax7	0,au
"
	equ	arg1,1*4096
	equ	arg2,2*4096
	equ	arg3,3*4096
	equ	arg4,4*4096
"
" The following symbols are used to define the types of operands for EIS instructions
"
	bool	addr,000000
	bool	dec,010000
	bool	char,020000
	bool	bit,030000
	bool	char4,040000
"
" The following bits are used to define the bool values for csl and csr instructions
"
	bool	move,03
	bool	and,01
	bool	or,07
	bool	xor,06
	bool	not,14
"
	bool	blank,040
	bool	plus,053
"
macro_table:
	lda	0		lda		1
	zero	a
	zero	lda_ldq,2		lda_ldq		2
	zero	aq+no_al
	ldaq	0		ldaq		3
	zero	aq
	sta	0		sta		4
	zero	0
	zero	sta_stq,2		sta_stq		5
	zero	0
	staq	0		staq		6
	zero	0
	ldq	0		ldfx1		7
	zero	q
	ldaq	0		ldfx2		8
	zero	aq
	fld	0		ldfl1		9
	zero	aq
	dfld	0		ldfl2		10
	zero	aq
	lcq	0		lcfx1		11
	zero	q
	lcaq	0		lcfx2		12
	zero	aq
	zero	lcfl1,2		lcfl1		13
	zero	aq
	zero	lcfl2,2		lcfl2		14
	zero	aq
	stq	0		stfx1		15
	zero	0
	staq	0		stfx2		16
	zero	0
	fst	0		stfl1		17
	zero	0
	dfst	0		stfl2		18
	zero	0
	adq	0		adfx1		19
	zero	q
	adaq	0		adfx2		20
	zero	aq
	adl	0		adfx3		21
	zero	aq
	sbq	0		sbfx1		22
	zero	q
	sbaq	0		sbfx2		23
	zero	aq
	zero	sbfx3,2		sbfx3		24
	zero	aq
	mpy	0		mpfx1		25
	zero	aq
	div	0		dvfx1		26
	zero	aq
	fad	0		adfl1		27
	zero	aq
	dfad	0		adfl2		28
	zero	aq
	fsb	0		sbfl1		29
	zero	aq
	dfsb	0		sbfl2		30
	zero	aq
	fmp	0		mpfl1		31
	zero	aq
	dfmp	0		mpfl2		32
	zero	aq
	fdv	0		dvfl1		33
	zero	aq
	dfdv	0		dvfl2		34
	zero	aq
	fdi	0		difl1		35
	zero	aq
	dfdi	0		difl2		36
	zero	aq
	zero	neg,1		neg		37
	zero	a
	zero	negl,1		negl		38
	zero	aq
	zero	fneg,1		fneg		39
	zero	aq
	ana	0		ana		40
	zero	a
	zero	ana_anq,2		ana_anq		41
	zero	aq
	anaq	0		anaq		42
	zero	aq
	ansa	0		ansa		43
	zero	0
	zero	ansa_ansq,2	ansa_ansq		44
	zero	0
	zero	ansa_ansq,2	ansaq		45
	zero	0
	ora	0		ora		46
	zero	a
	zero	ora_orq,2		ora_orq		47
	zero	aq
	oraq	0		oraq		48
	zero	aq
	orsa	0		orsa		49
	zero	0
	zero	orsa_orsq,2	orsa_orsq		50
	zero	0
	zero	orsa_orsq,2	orsaq		51
	zero	0
	era	0		era		52
	zero	a
	zero	era_erq,2		era_erq		53
	zero	aq
	eraq	0		eraq		54
	zero	aq
	ersa	0		ersa		55
	zero	0
	zero	ersa_ersq,2	ersa_ersq		56
	zero	0
	zero	ersa_ersq,2	ersaq		57
	zero	0
	zero	clear_aq,1	clear_aq		58
	zero	aq
	zero	clear_q,1		clear_q		59
	zero	q
	eppbp	0		load_pt		60
	zero	0
	spribp	0		store_pt		61
	zero	0
	lrl	0		lrl		62
	zero	q
	lls	0		lls		63
	zero	q
	lxl0	0		lxl0		64
	zero	0
	lxl1	0		lxl1		65
	zero	0
	lxl2	0		lxl2		66
	zero	0
	lxl3	0		lxl3		67
	zero	0
	lxl4	0		lxl4		68
	zero	0
	lxl5	0		lxl5		69
	zero	0
	lxl6	0		lxl6		70
	zero	0
	lxl7	0		lxl7		71
	zero	0
	ldx0	0		ldx0		72
	zero	0
	ldx1	0		ldx1		73
	zero	0
	ldx2	0		ldx2		74
	zero	0
	ldx3	0		ldx3		75
	zero	0
	ldx4	0		ldx4		76
	zero	0
	ldx5	0		ldx5		77
	zero	0
	ldx6	0		ldx6		78
	zero	0
	ldx7	0		ldx7		79
	zero	0
	adx0	0		adx0		80
	zero	0
	adx1	0		adx1		81
	zero	0
	adx2	0		adx2		82
	zero	0
	adx3	0		adx3		83
	zero	0
	adx4	0		adx4		84
	zero	0
	adx5	0		adx5		85
	zero	0
	adx6	0		adx6		86
	zero	0
	adx7	0		adx7		87
	zero	0
	zero	fx1_to_fx2,2	fx1_to_fx2	88
	zero	aq
	zero	alloc_char_temp,1	alloc_char_temp	89
	zero	a+bp+sr
	zero	alloc_bit_temp,1	alloc_bit_temp	90
	zero	a+bp+sr
	zero	alloc_temp,1	alloc_temp	91
	zero	aq+bp
	zero	realloc_char_temp,1 realloc_char_temp	92
	zero	aq+bp+sr
	zero	realloc_bit_temp,1	realloc_bit_temp	93
	zero	aq+bp+sr
	zero	sqrt_mac,1	sqrt_mac		94
	zero	0
	zero	dsqrt_mac,1	dsqrt_mac		95
	zero	0
	zero	test_bits,3	test_bits		96
	zero	0,compare
	zero	leave_begin_block,1 leave_begin_block	97
	zero	all
	zero	move_chars,3	move_chars	98
	zero	0
	zero	move_bits,3	move_bits		99
	zero	0
	zero	move_cs_load_1,3	move_cs_load_1	100
	zero	0
	zero	move_bs_load_1,3	move_bs_load_1	101
	zero	0
	zero	move_cs_load_2,3	move_cs_load_2	102
	zero	0
	zero	move_bs_load_2,3	move_bs_load_2	103
	zero	0
	zero	translate_2,1	translate_2	104
	zero	sr+cr+bp+aq
	zero	translate_3,1	translate_3	105
	zero	sr+cr+bp+aq
	zero	shift_and_mask_1,3	shift_and_mask_1	106
	zero	a
	zero	shift_and_mask_2,3	shift_and_mask_2	107
	zero	aq
	zero	b2c_mac,2		b2c_mac		108
	zero	aq
	zero	b2w_mac,2		b2w_mac		109
	zero	aq
	zero	c2b_mac,1		c2b_mac		110
	zero	aq
	zero	inline_translate	inline_translate	111
	zero	0
	zero	c2w_mac,2		c2w_mac		112
	zero	aq
	zero	pf_mac,2		pf_mac		113
	zero	aq
	zero	so_mac,2		so_mac		114
	zero	aq+bp
	zero	mod_bit_mac,1	mod_bit_mac	115
	zero	aq
	zero	mod2_mac,2	mod2_mac		116
	zero	q
	zero	mod4_mac,2	mod4_mac		117
	zero	q
	zero	mod8_mac,2	mod8_mac		118
	zero	q
	zero	mod16_mac,2	mod16_mac		119
	zero	q
	zero	ext_and_1,1	ext_and_1		120
	zero	aq+bp
	zero	ext_and_2,1	ext_and_2		121
	zero	aq+bp
	zero	fx1_to_fl2,1	fx1_to_fl2	122
	zero	aq
	zero	fx2_to_fl2,2	fx2_to_fl2	123
	zero	aq
	zero	fl2_to_fx1,1	fl2_to_fx1	124
	zero	aq
	zero	fl2_to_fx2,1	fl2_to_fx2	125
	zero	aq
	zero	absfx1,3		absfx1		126
	zero	q
	zero	absfx2,2		absfx2		127
	zero	aq
	zero	absfl1,2		absfl1		128
	zero	aq
	zero	absfl2,2		absfl2		129
	zero	aq
	zero	0		fx2_to_fx1	130
	zero	0
	zero	longbs_to_bs18,1	longbs_to_bs18	131
	zero	aq+bp
	zero	longbs_to_fx2,1	longbs_to_fx2	132
	zero	aq+bp
	zero	longbs_to_fl2,3	longbs_to_fl2	133
	zero	aq+bp
	als	0		als		134
	zero	0
	zero	blank_q,1		blank_q		135
	zero	aq
	cmpq	0		cpfx1		136
	zero	0
	cmpaq	0		cpfx2		137
	zero	0
	fcmp	0		cpfl1		138
	zero	0
	dfcmp	0		cpfl2		139
	zero	0
	cmpa	0		cpcs1		140
	zero	0
	zero	cpcs1_odd,3	cpcs1+1		141
	zero	0
	cmpaq	0		cpcs1+2		142
	zero	0
	cmpa	0		cpcs1+3		143
	zero	0
	zero	cpcs1_odd,3	cpcs1+4		144
	zero	0
	cmpaq	0		cpcs1+5		145
	zero	0
	zero	cpcs_ext1,1	cpcs1+6		146
	zero	aq+bp
	zero	cpcs_ext2,1	cpcs1+7		147
	zero	aq+bp
	zero	comp_bits,1	comp_bits		148
	zero	aq+bp
	cmpa	0		cpbs1		149
	zero	0
	zero	cpbs1_odd,3	cpbs1+1		150
	zero	0
	zero	cpbs1_even,2	cpbs1+2		151
	zero	0
	zero	cpbs2,3		cpbs1+3		152
	zero	0
	zero	cpbs2_odd,3	cpbs1+4		153
	zero	0
	cmpaq	0		cpbs1+5		154
	zero	0
	zero	cpbs_ext1,1	cpbs1+6		155
	zero	aq+bp
	zero	cpbs_ext2,1	cpbs1+7		156
	zero	aq+bp
	zero	test_translate,9	test_translate	157
	zero	q,compare
	zero	test_trans_rev,9	test_trans_rev	158
	zero	q,compare
	zero	r_l_a,1		r_l_a		159
	zero	a
	zero	r_l_s,1		r_l_s		160
	zero	a
	zero	r_g_a,1		r_g_a		161
	zero	a
	zero	r_g_s,1		r_g_s		162
	zero	a
	zero	r_e_as,1		r_e_as		163
	zero	a
	zero	r_ne_as,1		r_ne_as		164
	zero	a
	zero	r_le_a,1		r_le_a		165
	zero	a
	zero	r_le_s,1		r_le_s		166
	zero	a
	zero	r_ge_a,1		r_ge_a		167
	zero	a
	zero	r_ge_s,1		r_ge_s		168
	zero	a
	tra	0		tra		169
	zero	0
	zero	tra_ext_1,1	tra_ext_1		170
	zero	0
	zero	tra_ext_2,1	tra_ext_2		171
	zero	0
	zero	load_pt_reg,2	load_pt_reg	172
	zero	0
	zero	make_lv,3		make_lv		173
	zero	bp+cr+aq
	zero	store_lv,2	store_lv		174
	zero	aq+bp
	zero	set_stack,2	set_stack		175
	zero	aq+bp
	tmi	0		j_l_a		176
	zero	0
	tnc	0		j_l_s		177
	zero	0
	tpnz	0		j_g_a		178
	zero	0
	zero	j_g_s,2		j_g_s		179
	zero	0
	tze	0		j_e_as		180
	zero	0
	tnz	0		j_ne_as		181
	zero	0
	tmoz	0		j_le_a		182
	zero	0
	zero	j_le_s,2		j_le_s		183
	zero	0
	tpl	0		j_ge_a		184
	zero	0
	trc	0		j_ge_s		185
	zero	0
	zero	cp_chars,3	cp_chars		186
	zero	0,compare
	zero	cp_bits,3		cp_bits		187
	zero	0,compare
	zero	ftn_read,1	ftn_read		188
	zero	all
	zero	ftn_write,1	ftn_write		189
	zero	all
	zero	ftn_manip,1	ftn_manip		190
	zero	all
	zero	ftn_scalar_xmit,2	ftn_scalar_xmit	191
	zero	x6+bases
	zero	ftn_array_xmit,2	ftn_array_xmit	192
	zero	x6+bases
	zero	ftn_term,1	ftn_term		193
	zero	all
	zero	reset_stack,1	reset_stack	194
	zero	x0
	zero	get_ops_mac,4	get_ops_mac	195
	zero	0
	zero	entry_macro,3	entry_macro	196
	zero	all
	zero	enter_begin_block,2 enter_begin_block	197
	zero	0
	zero	return_mac,1	return_mac	198
	zero	0
	zero	inline_search,7	inline_search	199
	zero	q,compare
	zero	cat_realloc_char,1	cat_realloc_char	200
	zero	aq+bp
	zero	cat_realloc_bit,1	cat_realloc_bit	201
	zero	aq+bp
	zero	enter_prologue,1	enter_prologue	202
	zero	0
	zero	leave_prologue,2	leave_prologue	203
	zero	x0
	zero	call_prologue,1	call_prologue	204
	zero	all
	zero	load_offsets,2	load_offsets	205
	zero	q
	zero	store_offsets,2	store_offsets	206
	zero	q
	zero	inline_verify,7	inline_verify	207
	zero	q,compare
	zero	stac_mac,1	stac_mac		208
	zero	aq+bp
	zero	sign_mac,1	sign_mac		209
	zero	aq
	zero	qls_9,1		qls_9		210
	zero	0
	zero	set_bit_addr,1	set_bit_addr	211
	zero	0
	zero	pointer_mac_bs,1	pointer_mac_bs	212
	zero	bp
	zero	pointer_mac_fx,1	pointer_mac_fx	213
	zero	bp
	zero	addrel_mac_bs,1	addrel_mac_bs	214
	zero	bp
	zero	addrel_mac_fx,1	addrel_mac_fx	215
	zero	bp
	zero	baseptr_mac_bs,2	baseptr_mac_bs	216
	zero	bp
	zero	baseptr_mac_fx,2	baseptr_mac_fx	217
	zero	bp
	zero	cat_move_chars,3	cat_move_chars	218
	zero	0,cat
	zero	cat_move_bits,3	cat_move_bits	219
	zero	0,cat
	zero	cmp_suffix_1,2	cmp_suffix_1	220
	zero	0
	zero	move_numeric_edit,4 move_numeric_edit	221
	zero	0
	zero	dtb_1,3		dtb_1		222
	zero	0
	zero	dtb_2,3		dtb_2		223
	zero	0
	zero	btd_1,3		btd_1		224
	zero	0
	zero	btd_2,3		btd_2		225
	zero	0
	zero	cpbs3,3		cpbs3		226
	zero	0,compare
	zero	sin_mac,1		sin_mac		227
	zero	0
	zero	dsin_mac,1	dsin_mac		228
	zero	0
	zero	save_string_aq,3	save_string_aq	229
	zero	0
	zero	call_ent_var,1	call_ent_var	230
	zero	0
	zero	call_ent_var_d,1	call_ent_var_desc	231
	zero	0
	zero	call_ext_in,1	call_ext_in	232
	zero	0
	zero	call_ext_in_d,1	call_ext_in_desc	233
	zero	0
	zero	call_ext_out,1	call_ext_out	234
	zero	0
	zero	call_ext_out_d,1	call_ext_out_desc	235
	zero	0
	zero	call_int_this,1	call_int_this	236
	zero	0
	zero	call_int_this_d,1	call_int_this_desc	237
	zero	0
	zero	call_int_other,1	call_int_other	238
	zero	0
	zero	call_int_other_d,1	call_int_other_desc 239
	zero	0
	zero	segno_mac,2	segno_mac		240
	zero	q
	zero	baseno_mac,1	baseno_mac	241
	zero	a
	zero	off_mac_easy,2	off_mac_easy	242
	zero	aq
	zero	off_mac_easy_pk,2	off_mac_easy_pk	243
	zero	aq
	zero	args_by_2_mac,2	args_by_2_mac	244
	zero	q
	arl	0		arl		245
	zero	0
	zero	bound_ck_mac	bound_ck_mac	246
	zero	aq
	zero	min_fx1,3		min_fx1		247
	zero	q
	zero	min_fx2,3		min_fx2		248
	zero	aq
	zero	min_fl1,3		min_fl1		249
	zero	aq
	zero	min_fl2,3		min_fl2		250
	zero	aq
	zero	max_fx1,3		max_fx1		251
	zero	q
	zero	max_fx2,3		max_fx2		252
	zero	aq
	zero	max_fl1,3		max_fl1		253
	zero	aq
	zero	max_fl2,3		max_fl2		254
	zero	aq
	zero	neg_q,2		neg_q		255
	zero	q
	zero	ix_rev_chars,1	ix_rev_chars	256
	zero	aq+sr
	zero	copy_mac,3	copy_mac		257
	zero	0,l_in_q
	zero	mpfx2,2		mpfx2		258
	zero	aq+perm
	zero	mpfx3,2		mpfx3		259
	zero	aq+perm
	div	0		dvfx1		260
	zero	aq
	zero	test_andnot_0,3	test_andnot_0	261
	zero	0,compare
	zero	test_andnot_1,3	test_andnot_1	262
	zero	0,compare
	zero	substr_ck_mac	substr_ck_mac	263
	zero	aq
	zero	move_and,3	move_and		264
	zero	0
	zero	sind_mac,1	sind_mac		265
	zero	0
	zero	dsind_mac,1	dsind_mac		266
	zero	0
	zero	test_and,3	test_and		267
	zero	0,compare
	zero	set_ptr_to,2	set_ptr_to	268
	zero	0
	zero	mdfl1,2		mdfl1		269
	zero	aq+sr+perm
	zero	mdfl2,2		mdfl2		270
	zero	aq+sr+perm
	zero	mdfx1,2		mdfx1		271
	zero	aq+sr+perm
	zero	mdfx2,2		mdfx2		272
	zero	aq+sr+perm
	zero	mdfx3,2		mdfx3		273
	zero	aq+sr+perm
	zero	mdfx4,2		mdfx4		274
	zero	aq+sr+perm
	zero	make_desc_mac,2	make_desc_mac	275
	zero	q
	stcq	0		set_desc_size	276
	zero	0
	orsq	0		insert_adj	277
	zero	q
	zero	pic_test,4	pic_test		278
	zero	dr,compare
	zero	quick_desc_size,2	quick_desc_size	279
	zero	q
	zero	compare_files,3	compare_files	280
	zero	aq
	zero	pad_chars,1	pad_chars		281
	zero	aq
	zero	pad_bits,1	pad_bits		282
	zero	aq
	zero	load_link_pt,1	load_link_pt	283
	zero	0
	zero	get_desc_size,4	get_desc_size	284
	zero	q
	zero	assign_label_const,2 assign_label_const 285
	zero	0
	zero	load_display_ptr,1	load_display_ptr	286
	zero	0
	zero	walk_display_ptr,1	walk_display_ptr	287
	zero	0
	zero	begin_return,2	begin_return_mac	288
	zero	all
	zero	signal_mac,2	signal_mac	289
	zero	aq
	zero	revert_mac,1	revert_mac	290
	zero	0
	zero	enable_mac,4	enable_mac	291
	zero	all
	zero	get_area_mod_8,5	get_area_mod_8	292
	zero	q
	zero	fx1_to_bs,4	fx1_to_bs		293
	zero	a
	zero	fx2_to_bs,4	fx2_to_bs		294
	zero	aq
	stba	0		stba		295
	zero	0
	stbq	0		stbq		296
	zero	0
	stca	0		stca		297
	zero	0
	stcq	0		stcq		298
	zero	0
	zero	quick_return,1	quick_return	299
	zero	0
	zero	fetch_chars,1	fetch_chars	300
	zero	aq
	zero	fetch_bits,1	fetch_bits	301
	zero	aq
	zero	mod_byte_mac,3	mod_byte_mac	302
	zero	aq
	zero	mod_byte_mac_exp,3	mod_byte_mac_exp	303
	zero	aq
	zero	move_or,3		move_or		304
	zero	0
	zero	support_mac,1	support_mac	305
	zero	a
	zero	a_to_x0,1		a_to_x0		306
	zero	x0
	zero	zero_mac_p_1,1	zero_mac_p_1	307
	zero	0
	stz	0		zero_mac		308
	zero	0
	aos	0		aos_mac		309
	zero	0
	asq	0		incr_mac		310
	zero	0
	ssq	0		diff_mac		311
	zero	0
	nop	0		nop_mac		312
	zero	0
	zero	get_term_mac,1	get_term_mac	313
	zero	bases+x6
	zero	put_term_mac,1	put_term_mac	314
	zero	bases+x6
	zero	is_label_const,2	is_label_const	315
	zero	0
	zero	mod_half_mac,3	mod_half_mac	316
	zero	aq
	zero	mod_half_mac_exp,3	mod_half_mac_exp	317
	zero	aq
	zero	beg_ev_proc,5	beg_ev_proc	318
	zero	0
	zero	end_ev_proc,2	end_ev_proc	319
	zero	0
	zero	symtab_mac,4	symtab_mac	320
	zero	0
	zero	io_signal_mac,2	io_signal_mac	321
	zero	aq
	zero	end_ev_label,3	end_ev_label	322
	zero	0
	cana	0		cana		323
	zero	0
	canaq	0		canaq		324
	zero	0
	zero	compare_labels,7	compare_labels	325
	zero	aq
	zero	pointer_mac_const,1 point_mac_const	326
	zero	bp
	zero	addrel_mac_const,1	addrel_mac_const	327
	zero	bp
	zero	put_data,1	put_data		328
	zero	x6+bases
	zero	cos_mac,1		cos_mac,1		329
	zero	0
	zero	dcos_mac,1	dcos_mac		330
	zero	0
	zero	test_or,3		test_or		331
	zero	0,compare
	lda	0		test_lda		332
	zero	a
	zero	test_lda_ldq,3	test_lda_ldq	333
	zero	aq+no_al
	ldaq	0		test_ldaq		334
	zero	aq
	zero	move_not,3	move_not		335
	zero	0
	zero	cosd_mac,1	cosd_mac		336
	zero	0
	zero	dcosd_mac,1	dcosd_mac		337
	zero	0
	zero	test_not,3	test_not		338
	zero	0,compare
	zero	init_ps_mac,3	init_ps_mac	339
	zero	0
	zero	init_sslp,2	init_sslp		340
	zero	0
	zero	move_xor,3	move_xor		341
	zero	0
	zero	tan_mac,1		tan_mac		342
	zero	0
	zero	dtan_mac,1	dtan_mac		343
	zero	0
	zero	test_xor,3	test_xor		344
	zero	0,compare
	sxl0	0		sxl0		345
	zero	0
	sxl1	0		sxl1		346
	zero	0
	sxl2	0		sxl2		347
	zero	0
	sxl3	0		sxl3		348
	zero	0
	sxl4	0		sxl4		349
	zero	0
	sxl5	0		sxl5		350
	zero	0
	sxl6	0		sxl6		351
	zero	0
	sxl7	0		sxl7		352
	zero	7
	eax0	0		eax0		353
	zero	0
	eax1	0		eax1		354
	zero	0
	eax2	0		eax2		355
	zero	0
	eax3	0		eax3		356
	zero	0
	eax4	0		eax4		357
	zero	0
	eax5	0		eax5		358
	zero	0
	eax6	0		eax6		359
	zero	0
	eax7	0		eax7		360
	zero	0
	epplp	0		load_lp		361
	zero	0
	zero	prepare_call,2	prepare_call	362
	zero	aq
	zero	prepare_quick_call,3	prepare_quick_call	363
	zero	bp+aq
	zero	quick_entry,1	quick_entry	364
	zero	0
	zero	quick_entry_args,2	quick_entry_args	365
	zero	0
	zero	quick_entry_desc,4	quick_entry_desc	366
	zero	0
	zero	quick_call,1	quick_call	367
	zero	0
	zero	verify_rev_chars,1	verify_rev_chars	368
	zero	aq+sr
	zero	search_rev_chars,1	search_rev_chars	369
	zero	aq+sr
	eaa	0		eaa		371
	zero	a
	eaq	0		eaq		371
	zero	q
	llr	0		llr		372
	zero	aq
	a9bdx	0|0		setcharno_mac	373
	zero	0
	abdx	0|0		setbitno_mac	374
	zero	0
	zero	0		UNUSED		375
	zero	0
	epaq	0		epaq		376
	zero	aq
	zero	0		UNUSED		377
	zero	0
	zero	0		UNUSED		378
	zero	0
	zero	assign_lab_to_int,2 assign_lab_to_int	379
	zero	q
	zero	load_logical,2	load_logical	380
	zero	a
	zero	store_logical,3	store_logical	381
	zero	0
	zero	not_logical,1	not_logical	382
	zero	a
	zero	mask_logical,1	mask_logical	383
	zero	a
	zero	trunc_fl,1	trunc_fl		384
	zero	aq
	zero	tran_sign_fx1,2	tran_sign_fx1	385
	zero	aq+perm
	zero	tran_sign_fl,2	tran_sign_fl	386
	zero	aq+perm
	zero	fort_mod_fx1,2	fort_mod_fx1	387
	zero	aq
	zero	fort_mod_fl1,2	fort_mod_fl1	388
	zero	aq+perm
	zero	0		UNUSED		389
	zero	0
	zero	rflb1_to_cflb1,3	rflb1_to_cflb1	390
	zero	aq
	zero	move_andnot_0,3	move_andnot_0	391
	zero	0,0
	zero	move_andnot_1,3	move_andnot_1	392
	zero	0,0
	zero	store_bp_hard,3	store_bp_hard	393
	zero	aq
	zero	atm_rflb1_to_cflb1,2 atm_rflb1_to_cflb1 394
	zero	aq
	zero	rfb1_to_cflb1,1	rfb1_to_cflb1	395
	zero	aq
	zero	stream_prep_mac,3	stream_prep_mac	396
	zero	a+bases+x6
	zero	loop_end_var,4	loop_end_var	397
	zero	aq
	zero	rfb2_to_cflb1,1	rfb2_to_cflb1	398
	zero	aq
	zero	complex_mac	complex_mac	399
	zero	aq
	zero	conjg_mac		conjg_mac		400
	zero	aq
	zero	real_mac		real_mac		401
	zero	aq
	zero	imag_mac		imag_mac		402
	zero	aq
	zero	square_fx1,2	square_fx1	403
	zero	aq
	zero	h2w_mac,2		h2w_mac		404
	zero	aq
	zero	square_fl1,2	square_fl1	405
	zero	aq
	zero	square_fl2,2	square_fl2	406
	zero	aq
	zero	unpk_to_pk,1	unpk_to_pk	407
	zero	aq
	zero	pk_to_unpk,1	pk_to_unpk	408
	zero	aq
	sprilp	0		store_lp		409
	zero	0
	zero	bp_to_aq,2	bp_to_aq		410
	zero	aq
	zero	lp_to_aq,2	lp_to_aq		411
	zero	aq
	zero	real_to_real_tr,1	real_to_real_tr	412
	zero	all-sr
	zero	real_to_real_rd,1	real_to_real_rd	413
	zero	all-sr
	zero	any_to_any_tr,1	any_to_any_tr	414
	zero	all-sr
	zero	any_to_any_rd,1	any_to_any_rd	415
	zero	all-sr
	zero	unpack_pic,1	unpack_pic	416
	zero	all
	zero	edit_pic,1	edit_pic		417
	zero	all
	qrl	0		qrl		418
	zero	q
	zero	zero_chars,3	zero_chars	419
	zero	0
	zero	chars_move,3	chars_move	420
	zero	0
	zero	bits_move,3	bits_move		421
	zero	0
	zero	tand_mac,1	tand_mac		422
	zero	0
	zero	dtand_mac,1	dtand_mac		423
	zero	0
	zero	asin_mac,1	asin_mac		424
	zero	0
	zero	dasin_mac,1	dasin_mac		425
	zero	0
	zero	asind_mac,1	asind_mac		426
	zero	0
	zero	dasind_mac,1	dasind_mac	427
	zero	0
	zero	acos_mac,1	acos_mac		428
	zero	0
	zero	dacos_mac,1	dacos_mac		429
	zero	0
	zero	acosd_mac,1	acosd_mac		430
	zero	0
	zero	dacosd_mac,1	dacosd_mac	431
	zero	0
	zero	atan_mac,1	atan_mac		432
	zero	0
	zero	datan_mac,1	datan_mac		433
	zero	0
	zero	atand_mac,1	atand_mac		434
	zero	0
	zero	datand_mac,1	datand_mac	435
	zero	0
	zero	set_chars,1	set_chars		436
	zero	a+sr
	zero	set_bits,1	set_bits		437
	zero	a+sr
	zero	move_decimal,3	move_decimal	438
	zero	dr
	zero	move_decimal_rd,3	move_decimal_rd	439
	zero	dr
	zero	add_decimal,4	add_decimal	440
	zero	dr
	zero	add_decimal_rd,4	add_decimal_rd	441
	zero	dr
	zero	add_decimal_2,3	add_decimal_2	442
	zero	dr
	zero	add_decimal_2_rd,3	add_decimal_2_rd	443
	zero	dr
	zero	chars_move_vt,3	chars_move_vt	444
	zero	0,l_in_q
	zero	bits_move_vt,3	bits_move_vt	445
	zero	0,l_in_q
	zero	sub_decimal,4	sub_decimal	446
	zero	dr
	zero	sub_decimal_rd,4	sub_decimal_rd	447
	zero	dr
	zero	sub_decimal_2,3	sub_decimal_2	448
	zero	dr
	zero	sub_decimal_2_rd,3	sub_decimal_2_rd	449
	zero	dr
	zero	mult_decimal,4	mult_decimal	450
	zero	dr
	zero	mult_decimal_rd,4	mult_decimal_rd	451
	zero	dr
	zero	ix_chars,1	ix_chars		452
	zero	aq+sr
	zero	ix_bits,1		ix_bits		453
	zero	aq+bp+sr
	zero	mult_decimal_2,3	mult_decimal_2	454
	zero	dr
	zero	mult_decimal_2_rd,3 mult_decimal_2_rd	455
	zero	dr
	zero	div_decimal,4	div_decimal	456
	zero	dr
	zero	div_decimal_rd,4	div_decimal_rd	457
	zero	dr
	zero	div_decimal_2,3	div_decimal_2	458
	zero	dr
	zero	div_decimal_2_rd,3	div_decimal_2_rd	459
	zero	dr
	zero	ix_chars_1,8	ix_chars_1	460
	zero	q,compare
	zero	ix_bits_1,1	ix_bits_1		461
	zero	aq+bp+sr
	zero	ix_chars_2,8	ix_chars_2	462
	zero	q,compare
	zero	ix_rev_chars_1,8	ix_rev_chars_1	463
	zero	q,compare
	zero	ix_rev_chars_2,8	ix_rev_chars_2	464
	zero	q,compare
	zero	mpcdec,2		mpcdec		465
	zero	a+x1+x2+x3+x4
	zero	dvcdec,2		dvcdec		466
	zero	a+x1+x2+x3+x4
	zero	dvrcdec,2		dvrcdec		467
	zero	a+x1+x2+x3+x4
	zero	zero_bits,3	zero_bits		468
	zero	0
	zero	one_bits,3	one_bits		469
	zero	0
	zero	bool_mac_1,3	bool_mac_1	470
	zero	0,xec_eis
	zero	bool_mac_2,3	bool_mac_2	471
	zero	0,xec_eis
	zero	blank_chars,3	blank_chars	472
	zero	0
	zero	abs_decimal,3	abs_decimal	473
	zero	dr
	zero	min_dec,4		min_dec		474
	zero	dr
	zero	max_dec,4		max_dec		475
	zero	dr
	zero	copy_bits,3	copy_bits		476
	zero	0,cat
	zero	log2_mac,1	log2_mac		477
	zero	0
	zero	dlog2_mac,1	dlog2_mac		478
	zero	0
	zero	zero_chars_q,3	zero_chars_q	479
	zero	0,l_in_q
	zero	return_words,2	return_words	480
	zero	0
	zero	move_words,3	move_words	481
	zero	0,cat
	zero	log_mac,1		log_mac		482
	zero	0
	zero	dlog_mac,1	dlog_mac		483
	zero	0
	zero	one_chars,3	one_chars		484
	zero	0
	zero	recio_mac,2	recio_mac		485
	zero	aq+x6+bases
	zero	unpack_fl1,2	unpack_fl1	486
	zero	aq
	zero	unpack_fl2,2	unpack_fl2	487
	zero	0
	zero	unpack_cfl1,2	unpack_cfl1	488
	zero	0
	zero	pack_fl1,2	pack_fl1		489
	zero	0
	zero	pack_fl2,2	pack_fl2		490
	zero	0
	zero	pack_cfl1,2	pack_cfl1		491
	zero	0
	lrs	0		lrs		492
	zero	aq
	zero	open_mac,1	open_mac		493
	zero	x6+bases
	zero	close_mac,1	close_mac		494
	zero	x6+bases
	zero	get_list,1	get_list		495
	zero	x6+bases
	zero	log10_mac,1	log10_mac		496
	zero	0
	zero	dlog10_mac,1	dlog10_mac	497
	zero	0
	zero	put_field,1	put_field		498
	zero	bases+x6
	zero	get_edit,1	get_edit		499
	zero	x6+bases
	zero	exp_mac,1		exp_mac		500
	zero	0
	zero	dexp_mac,1	dexp_mac		501
	zero	0
	zero	alloc_based_area,2	alloc_based_area	502
	zero	0
	zero	put_list,1	put_list		503
	zero	x6+bases
	zero	atan2_mac,1	atan2_mac		504
	zero	0
	zero	datan2_mac,1	datan2_mac	505
	zero	0
	zero	put_field_chk,1	put_field_chk	506
	zero	bases+x6
	zero	put_edit,1	put_edit		507
	zero	x6+bases
	zero	testfx1,1		testfx1		508
	zero	0
	zero	testfx2,1		testfx2		509
	zero	0
	zero	testfl1,1		testfl1		510
	zero	0
	zero	testfl2,1		testfl2		511
	zero	0
	zero	ss_enter_begin_block,2  ss_enter_begin_block  512
	zero	0
	orq	0		form_desc		513
	zero	q
	qrs	0		qrs		514
	zero	q
	qls	0		qls		515
	zero	q
	zero	fetch_pp,2	fetch_pp		516
	zero	aq
	zero	store_pp,2	store_pp		517
	zero	0
	zero	fxscaled_to_fl2,2	fxscaled_to_fl2	518
	zero	aq
	zero	fl2_to_fxscaled,1	fl2_to_fxscaled	519
	zero	aq
	zero	trunc_fx1,1	trunc_fx1		520
	zero	q
	zero	trunc_fx2,1	trunc_fx2		521
	zero	aq
	zero	ceil_fx1,1	ceil_fx1		522
	zero	q
	zero	ceil_fx2,1	ceil_fx2		523
	zero	aq
	zero	ceil_fl,1		ceil_fl		524
	zero	aq
	zero	floor_fx1,1	floor_fx1		525
	zero	q
	zero	floor_fx2,1	floor_fx2		526
	zero	aq
	zero	floor_fl,1	floor_fl		527
	zero	aq
	zero	nop_mac,1		nop_mac		528
	zero	0
	zero	round_fx1,1	round_fx1		529
	zero	q
	zero	round_fx2,1	round_fx2		530
	zero	aq
	zero	round_fl,2	round_fl		531
	zero	aq+bp+sr
	zero	compare_decimal,3	compare_decimal	532
	zero	dr,compare
	sprisp	0		stack_ptr		533
	zero	0
	zero	repeat,1		repeat		534
	zero	aq+bp+sr
	zero	divide_fx1,2	divide_fx1	535
	zero	aq+sr+perm
	zero	divide_fx2,2	divide_fx2	536
	zero	aq+sr+perm
	zero	divide_fx3,2	divide_fx3	537
	zero	aq+sr+perm
	zero	divide_fx4,2	divide_fx4	538
	zero	aq+sr+perm
	zero	verify,1		verify		539
	zero	q+sr
	zero	search,1		search		540
	zero	q+sr
	zero	ceil_dec,2	ceil_dec		541
	zero	aq+x1+x2
	zero	floor_dec,2	floor_dec		542
	zero	aq+x1+x2
	zero	sign_dec,2	sign_dec		543
	zero	q
	zero	abs_cdec,2	abs_cdec		544
	zero	aq+x1+x2+x3+x4
	zero	trunc_dec,2	trunc_dec		545
	zero	aq+x1+x2
	zero	mod_dec,2		mod_dec		546
	zero	aq+x1+x2
	zero	reverse_cs,1	reverse_cs	547
	zero	aq+bp+sr
	zero	reverse_bs,1	reverse_bs	548
	zero	aq+bp+sr
	zero	scaled_mdfx1,2	scaled_mdfx1	549
	zero	aq+sr+perm
	zero	scaled_mdfx2,2	scaled_mdfx2	550
	zero	aq+sr+perm
	zero	scaled_mdfx3,2	scaled_mdfx3	551
	zero	aq+sr+perm
	zero	scaled_mdfx4,2	scaled_mdfx4	552
	zero	aq+sr+perm
	zero	size_check_fx1,1	size_check_fx1	553
	zero	0
	zero	size_check_fx2,1	size_check_fx2	554
	zero	0
	zero	chars_move_ck,3	chars_move_ck	555
	zero	0
	zero	bits_move_ck,3	bits_move_ck	556
	zero	0
	zero	atan2d_mac,1	atan2d_mac	557
	zero	0
	zero	datan2d_mac,1	datan2d_mac	558
	zero	0
	zero	int_p_real,1	int_p_real	559
	zero	0
	zero	int_p_dbl,1	int_p_dbl		560
	zero	0
	zero	dbl_p_real,1	dbl_p_real	561
	zero	0
	zero	dbl_p_dbl,1	dbl_p_dbl		562
	zero	0
	zero	signal_stringsize,1 signal_stringsize	563
	zero	0
	zero	dbl_p_int,1	dbl_p_int		564
	zero	0
	zero	real_p_real,1	real_p_real	565
	zero	0
	zero	size_ck_varying,4	size_ck_varying	566
	zero	q
	zero	size_ck_suffix,5	size_ck_suffix	567
	zero	q
	zero	move_3,6		move_3		568
	zero	a
	zero	move_odd_odd_3,4	move_odd_odd_3	569
	zero	aq
	zero	move_odd_odd_4,6	move_odd_odd_4	570
	zero	aq
	zero	move_odd_odd_5,6	move_odd_odd_5	571
	zero	aq
	zero	move_odd_even_3,5	move_odd_even_3	572
	zero	aq
	zero	move_odd_even_4,6	move_odd_even_4	573
	zero	aq
	zero	move_even_odd_3,5	move_even_odd_3	574
	zero	aq
	zero	move_even_odd_4,6	move_even_odd_4	575
	zero	aq
	zero	move_even_even_3,4	move_even_even_3	576
	zero	aq
	zero	move_even_even_4,4	move_even_even_4	577
	zero	aq
	zero	move_even_even_5,6	move_even_even_5	578
	zero	aq
	zero	move_even_even_6,6	move_even_even_6	579
	zero	aq
	zero	move_odd,2	move_odd		580
	zero	a
	zero	move_even,2	move_even		581
	zero	aq
	zero	size_ck_decimal,2	size_ck_decimal	582
	zero	all
	zero	xr_to_q,2		xr_to_q		583
	zero	q
	zero	packed_to_bp,2	packed_to_bp	584
	zero	bp
	zero	packed_bit_offset,1 packed_bit_offset	585
	zero	q
	zero	return_chars,1	return_chars	586
	zero	0
	zero	put_control,1	put_control	587
	zero	bases+x6
	zero	fetch_chars_eis,1	fetch_chars_eis	588
	zero	aq
	zero	fetch_bits_eis,1	fetch_bits_eis	589
	zero	aq
	zero	return_bits,1	return_bits	590
	zero	0
	zero	real_p_int,1	real_p_int	591
	zero	0
	zero	int_p_int,1	int_p_int		592
	zero	0
	zero	enable_file_2,5	enable_file_2	593
	zero	aq		(see macro)
	zero	ext_entry,3	ext_entry		594
	zero	all
	zero	ext_entry_desc,3	ext_entry_desc	595
	zero	all
	zero	int_entry,3	int_entry		596
	zero	all
	zero	int_entry_desc,3	int_entry_desc	597
	zero	all
	zero	val_entry,3	val_entry		598
	zero	all
	zero	val_entry_desc,3	val_entry_desc	599
	zero	all
	zero	off_mac_hard,2	off_mac_hard	600
	zero	aq
	zero	off_mac_hard_pk,2	off_mac_hard_pk	601
	zero	aq
	zero	pl1_ptr_easy,1	pl1_ptr_easy	602
	zero	aq+bp
	zero	pl1_ptr_easy_pk,1	pl1_ptr_easy_pk	603
	zero	aq+bp
	zero	pl1_ptr_hard,1	pl1_ptr_hard	604
	zero	aq+bp
	zero	pl1_ptr_hard_pk,1	pl1_ptr_hard_pk	605
	zero	aq+bp
	zero	enable_file,4	enable_file	606
	zero	aq		(see macro)
	zero	revert_file,3	revert_file	607
	zero	bp+lp+aq
	zero	alloc_block,2	alloc_block	608
	zero	bp+lp+aq+cr
	zero	free_block,2	free_block	609
	zero	bp+lp+aq+cr
	zero	push_ctl_data,2	push_ctl_data	610
	zero	bp+lp+aq+cr
	zero	push_ctl_desc,2	push_ctl_desc	611
	zero	bp+lp+aq+cr
	zero	pop_ctl_data,2	pop_ctl_data	612
	zero	bp+lp+aq+cr
	zero	pop_ctl_desc,2	pop_ctl_desc	613
	zero	bp+lp+aq+cr
	zero	allocation,2	allocation	614
	zero	bp+aq
	cana	0		and_for_test	615
	zero	0
	zero	ana_anq,2		and_for_test_odd	616
	zero	aq
	canaq	0		and_for_test_even	617
	zero	0
	epp1	0		load_ab		618
	zero	0
	epp3	0		load_bb		619
	zero	0
	epp5	0		load_lb		620
	zero	0
	epp7	0		load_sb		621
	zero	0
	spri1	0		store_ab		622
	zero	0
	spri3	0		store_bb		623
	zero	0
	spri5	0		store_lb		624
	zero	0
	spri7	0		store_sb		625
	zero	0
	zero	ab_to_aq,2	ab_to_aq		626
	zero	aq
	zero	bb_to_aq,2	bb_to_aq		627
	zero	aq
	zero	lb_to_aq,2	lb_to_aq		628
	zero	aq
	zero	sb_to_aq,2	sb_to_aq		629
	zero	aq
	sprpbp	0		store_packed_bp	630
	zero	0
	sprplp	0		store_packed_lp	631
	zero	0
	sprp1	0		store_packed_ab	632
	zero	0
	sprp3	0		store_packed_bb	633
	zero	0
	sprp5	0		store_packed_lb	634
	zero	0
	sprp7	0		store_packed_sb	635
	zero	0
	lprpbp	0		load_packed_bp	636
	zero	0
	lprplp	0		load_packed_lp	637
	zero	0
	lprp1	0		load_packed_ab	638
	zero	0
	lprp3	0		load_packed_bb	639
	zero	0
	lprp5	0		load_packed_lb	640
	zero	0
	lprp7	0		load_packed_sb	641
	zero	0
	zero	zero_bo_bp,1	zero_bo_bp	642
	zero	bp
	zero	abd,1		abd		643
	zero	0
	zero	a9bd,1		a9bd		644
	zero	0
	ada	0		ada		645
	zero	a
	zero	ss_ext_entry,3	ss_ext_entry	646
	zero	all
	zero	ss_ext_entry_desc,3 ss_ext_entry_desc	647
	zero	all
	zero	ss_int_entry,3	ss_int_entry	648
	zero	all
	zero	ss_int_entry_desc,3 ss_int_entry_desc	649
	zero	all
	zero	ss_val_entry,3	ss_val_entry	650
	zero	all
	zero	ss_val_entry_desc,3 ss_val_entry_desc	651
	zero	all
	zero	pointer_mac_c_ab,1	pointer_mac_c_ab	652
	zero	0
	zero	pointer_mac_c_bb,1	pointer_mac_c_bb	653
	zero	0
	zero	pointer_mac_c_lb,1	pointer_mac_c_lb	654
	zero	0
	zero	pointer_mac_c_sb,1	pointer_mac_c_sb	655
	zero	0
	zero	addrel_mac_c_ab,1	addrel_mac_c_ab	656
	zero	0
	zero	addrel_mac_c_bb,1	addrel_mac_c_bb	657
	zero	0
	zero	addrel_mac_c_lb,1	addrel_mac_c_lb	658
	zero	0
	zero	addrel_mac_c_sb,1	addrel_mac_c_sb	659
	zero	0
	zero	pointer_mac_bs_ab,1 pointer_mac_bs_ab	660
	zero	0
	zero	pointer_mac_fx_ab,1 pointer_mac_fx_ab	661
	zero	0
	zero	pointer_mac_bs_bb,1 pointer_mac_bs_bb	662
	zero	0
	zero	pointer_mac_fx_bb,1 pointer_mac_fx_bb	663
	zero	0
	zero	pointer_mac_bs_lb,1 pointer_mac_bs_lb	664
	zero	0
	zero	pointer_mac_fx_lb,1 pointer_mac_fx_lb	665
	zero	0
	zero	pointer_mac_bs_sb,1 pointer_mac_bs_sb	666
	zero	0
	zero	pointer_mac_fx_sb,1 pointer_mac_fx_sb	667
	zero	0
	zero	addrel_mac_bs_ab,1	addrel_mac_bs_ab	668
	zero	0
	zero	addrel_mac_fx_ab,1	addrel_mac_fx_ab	669
	zero	0
	zero	addrel_mac_bs_bb,1	addrel_mac_bs_bb	670
	zero	0
	zero	addrel_mac_fx_bb,1	addrel_mac_fx_bb	671
	zero	0
	zero	addrel_mac_bs_lb,1	addrel_mac_bs_lb	672
	zero	0
	zero	addrel_mac_fx_lb,1	addrel_mac_fx_lb	673
	zero	0
	zero	addrel_mac_bs_sb,1	addrel_mac_bs_sb	674
	zero	0
	zero	addrel_mac_fx_sb,1	addrel_mac_fx_sb	675
	zero	0
	zero	baseptr_mac_bs_ab,2 baseptr_mac_bs_ab	676
	zero	0
	zero	baseptr_mac_fx_ab,2 baseptr_mac_fx_ab	677
	zero	0
	zero	baseptr_mac_bs_bb,2 baseptr_mac_bs_bb	678
	zero	0
	zero	baseptr_mac_fx_bb,2 baseptr_mac_fx_bb	679
	zero	0
	zero	baseptr_mac_bs_lb,2 baseptr_mac_bs_lb	680
	zero	0
	zero	baseptr_mac_fx_lb,2 baseptr_mac_fx_lb	681
	zero	0
	zero	baseptr_mac_bs_sb,2 baseptr_mac_bs_sb	682
	zero	0
	zero	baseptr_mac_fx_sb,2 baseptr_mac_fx_sb	683
	zero	0
	zero	zero_bo_ab,1	zero_bo_ab	684
	zero	0
	zero	zero_bo_bb,1	zero_bo_bb	685
	zero	0
	zero	zero_bo_lb,1	zero_bo_lb	686
	zero	0
	zero	zero_bo_sb,1	zero_bo_sb	687
	zero	0
	anq	0		anq		688
	zero	q
	erq	0		erq		689
	zero	q
	ersq	0		ersq		690
	zero	0
	zero	charno_mac,5	charno_mac	691
	zero	aq
	zero	bitno_mac,6	bitno_mac		692
	zero      aq
	zero	0		UNUSED		693
	zero	0
	zero	0		UNUSED		694
	zero	0
	zero	alloc_based_mac,2	alloc_based_mac	695
	zero	0
	zero	free_based_mac,1	free_based_mac	696
	zero	0
	zero	empty_area_mac,1	empty_area_mac	697
	zero	0
	zero	size_ck_suffix_1,4	size_ck_suffix_1	698
	zero	0
	zero	long_profile_mac,1	long_profile_mac	699
	zero	0
	zero	ix_before_chars,1	ix_before_chars	700
	zero	aq+bp+sr
	zero	ix_before_bits,1	ix_before_bits	701
	zero	aq+bp+sr
	zero	ix_after_chars,1	ix_after_chars	702
	zero	aq+bp+sr
	zero	ix_after_bits,1	ix_after_bits	703
	zero	aq+bp+sr
	zero	ix_before_chars_1,5 ix_before_chars_1	704
	zero	q,compare
	zero	ix_before_bits_1,1	ix_before_bits_1	705
	zero	aq+bp+sr
	zero	ix_after_chars_1,7	ix_after_chars_1	706
	zero	q,compare
	zero	ix_after_bits_1,1	ix_after_bits_1	707
	zero	aq+bp+sr
	zero	ix_before_chars_2,7 ix_before_chars_2	708
	zero	q,compare
	zero	ix_after_chars_2,8	ix_after_chars_2	709
	zero	q,compare
	zero	verify_ltrim,1	verify_ltrim	710
	zero	q+sr
	zero	verify_rtrim,1	verify_rtrim	711
	zero	q+sr
	zero	verify_ltrim_inline,6 verify_ltrim_inline 712
	zero	q,compare
	zero	verify_rtrim_inline,6 verify_rtrim_inline 713
	zero	q,compare
	stx0	0		stx0		714
	zero	0
	stx1	0		stx1		715
	zero	0
	stx2	0		stx2		716
	zero	0
	stx3	0		stx3		717
	zero	0
	stx4	0		stx4		718
	zero	0
	stx5	0		stx5		719
	zero	0
	stx6	0		stx6		720
	zero	0
	stx7	0		stx7		721
	zero	0
	zero	stacq_mac,2	stacq_mac		722
	zero	aq
	zero	clock_mac,1	clock_mac		723
	zero	aq+lp		(also pr7)
	zero	vclock_mac,1	vclock_mac	724
	zero	aq+bp+lp		(also pr7)
	ars	0		ars		725
	zero	a
	zero	stop_mac,1	stop_mac		726
	zero	0
	zero	return_main_mac,1	return_main_mac	727
	zero	0
	zero	set_main_mac,1	set_main_mac	728
	zero	0
	zero	begin_return_main,2 begin_return_main	729
	zero	all
	sprp6	0		store_packed_sp	730
	zero	0
	zero	size_check_uns_fx1,1 size_check_uns_fx1 731
	zero	0
	zero	size_check_uns_fx2,1 size_check_uns_fx2 732
	zero	0
	zero	uns_fx1_to_bs,2	uns_fx1_to_bs	733
	zero	a
	zero	uns_fx2_to_bs,2	uns_fx2_to_bs	734
	zero	aq
	zero	xr18_to_q,2	xr18_to_q		735
	zero	q
	zero	a4bd,1		a4bd		736
	zero	0
	zero	abs_decimal_4bit,3	abs_decimal_4bit	737
	zero	dr
	zero	digit_to_bit,2	digit_to_bit	738
	zero	aq
	zero	zero_4bcs,3	zero_4bcs		739
	zero	dr
	zero	rank_eis_mac,3	rank_eis_mac	740
	zero	0
	zero	prepare_call_long,3 prepare_call_long	741
	zero	aq
	zero	prepare_quick_call_long,4	prepare_quick_call_long	742
	zero	bp+aq
	"
macro_count:
	vfd	36/(*-macro_table)/2 all macros must precede this line
"
" definitions of multi_word macros
"
lda_ldq:
	lda	arg1
	ldq	arg1+1
sta_stq:
	sta	arg1
	stq	arg1+1
lcfl1:
	fld	arg1
fneg:
	fneg
lcfl2:
	dfld	arg1
	fneg
sbfx3:
	adl	arg1
negl:
	negl
neg:
	neg
ana_anq:
	ana	arg1
	anq	arg1+1
ansa_ansq:
	ansa	arg1
	ansq	arg1+1
ora_orq:
	ora	arg1
	orq	arg1+1
orsa_orsq:
	orsa	arg1
	orsq	arg1+1
era_erq:
	era	arg1
	erq	arg1+1
ersa_ersq:
	ersa	arg1
	ersq	arg1+1
clear_aq:
	fld	0,dl
clear_q:
	ldq	0,dl
fx1_to_fx2:
	llr	36
	lrs	36
alloc_char_temp:
	tsx0	ap|op_vec+0
alloc_bit_temp:
	tsx0	ap|op_vec+1
alloc_temp:
	tsx0	ap|op_vec+2
realloc_char_temp:
	tsx0	ap|op_vec+3
realloc_bit_temp:
	tsx0	ap|op_vec+4
store_string:
	tsx0	ap|op_vec+28
cat_realloc_char:
	tsx0	ap|op_vec+29
cat_realloc_bit:
	tsx0	ap|op_vec+30
chars_move_vt:
chars_move:
move_chars:
cat_move_chars:
	mlr	(0),(0),fill(blank)
	zero	arg2,char
	zero	arg1,char
bits_move_vt:
bits_move:
copy_bits:
move_bits:
cat_move_bits:
	csl	(0),(0),bool(move)
	zero	arg2,bit
	zero	arg1,bit
move_cs_load_1:
	mlr	(0),(0),fill(0)
	zero	arg2,char
	zero	arg1,char+4
move_bs_load_1:
	csl	(0),(0),bool(move)
	zero	arg2,bit
	zero	arg1,bit+36
move_cs_load_2:
	mlr	(0),(0),fill(0)
	zero	arg2,char
	zero	arg1,char+8
move_bs_load_2:
	csl	(0),(0),bool(move)
	zero	arg2,bit
	zero	arg1,bit+72
save_string_aq:
	mlr	(pr),(0),fill(0)
	desc9a	sp|40,8
	zero	arg1,char+8
move_not:
	csl	(0),(0),bool(not)
	zero	arg2,bit
	zero	arg1,bit
move_and:
	csl	(0),(0),bool(and)
	zero	arg2,bit
	zero	arg1,bit
move_or:
	csl	(0),(0),bool(or)
	zero	arg2,bit
	zero	arg1,bit
move_andnot_0:
	csl	(0),(0),bool(02)
	zero	arg2,bit
	zero	arg1,bit
move_andnot_1:
	csl	(0),(0),bool(04),fill(1)	"forces zeroes in result if source shorter
	zero	arg2,bit
	zero	arg1,bit
test_bits:
	sztl	(0),(0),bool(move)
	zero	arg2,bit
	zero	arg1,bit
test_not:
	sztl	(0),(0),bool(not)
	zero	arg2,bit
	zero	arg1,bit
test_and:
	sztl	(0),(0),bool(and)
	zero	arg2,bit
	zero	arg1,bit
test_or:
	sztl	(0),(0),bool(or)
	zero	arg2,bit
	zero	arg1,bit
test_xor:
	sztl	(0),(0),bool(xor)
	zero	arg2,bit
	zero	arg1,bit
test_andnot_0:
	sztl	(0),(0),bool(02)
	zero	arg2,bit
	zero	arg1,bit
test_andnot_1:
	sztl	(0),(0),bool(04),fill(1)	"forces zeroes  in result if source shorter
	zero	arg2,bit
	zero	arg1,bit
move_decimal:
move_numeric:
	mvn	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
move_decimal_rd:
	mvn	(0),(0),round
	zero	arg2,dec
	zero	arg1,dec
add_decimal:
	ad3d	(0),(0),(0)
	zero	arg2,dec
	zero	arg3,dec
	zero	arg1,dec
add_decimal_rd:
	ad3d	(0),(0),(0),round
	zero	arg2,dec
	zero	arg3,dec
	zero	arg1,dec
add_decimal_2:
	ad2d	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
add_decimal_2_rd:
	ad2d	(0),(0),round
	zero	arg2,dec
	zero	arg1,dec
sub_decimal:
	sb3d	(0),(0),(0)
	zero	arg3,dec
	zero	arg2,dec
	zero	arg1,dec
sub_decimal_rd:
	sb3d	(0),(0),(0),round
	zero	arg3,dec
	zero	arg2,dec
	zero	arg1,dec
sub_decimal_2:
	sb2d	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
sub_decimal_2_rd:
	sb2d	(0),(0),round
	zero	arg2,dec
	zero	arg1,dec
mult_decimal:
	mp3d	(0),(0),(0)
	zero	arg2,dec
	zero	arg3,dec
	zero	arg1,dec
mult_decimal_rd:
	mp3d	(0),(0),(0),round
	zero	arg2,dec
	zero	arg3,dec
	zero	arg1,dec
mult_decimal_2:
	mp2d	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
mult_decimal_2_rd:
	mp2d	(0),(0),round
	zero	arg2,dec
	zero	arg1,dec
"
"	At present, the hardware does rounding on floating point decimal division incorrectly,
"	so we don't actually generate a divide with the round bit on.
"
div_decimal:
div_decimal_rd:
	dv3d	(0),(0),(0)
	zero	arg3,dec
	zero	arg2,dec
	zero	arg1,dec
div_decimal_2:
div_decimal_2_rd:
	dv2d	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
compare_decimal:
	cmpn	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
move_numeric_edit:
	mvne	(0),(0),(0)
	zero	arg2,dec
	zero	arg3,char
	zero	arg1,char
pic_test:
	cmpn	(0),(0)
	zero	arg1,dec
	zero	arg2,dec
	tze	arg3
dtb_1:
	dtb	(0),(0)
	zero	arg2,dec
	zero	arg1,char+4
dtb_2:
	dtb	(0),(0)
	zero	arg2,dec
	zero	arg1,char+8
btd_1:
	btd	(0),(0)
	zero	arg2,char+4
	zero	arg1,dec
btd_2:
	btd	(0),(0)
	zero	arg2,char+8
	zero	arg1,dec
mpcdec:
	epp2	arg1
	tsx0	ap|op_vec+392
dvcdec:
	epp2	arg1
	tsx0	ap|op_vec+393
dvrcdec:
	epp2	arg1
	tsx0	ap|op_vec+394
abs_decimal:
	mlr	(0),(0),fill(plus)
	zero	0
	zero	arg1,char+1
abs_decimal_4bit:
	mlr	(0),(0),fill(plus)
	zero	0
	zero	arg1,char4+1
min_dec:
	cmpn	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
	tmoz	4,ic
max_dec:
	cmpn	(0),(0)
	zero	arg2,dec
	zero	arg1,dec
	tpl	4,ic
ceil_dec:
	epp2	arg1
	tsx0	ap|op_vec+395
floor_dec:
	epp2	arg1
	tsx0	ap|op_vec+396
sign_dec:
	epp2	arg1
	tsx0	ap|op_vec+397
abs_cdec:
	epp2	arg1
	tsx0	ap|op_vec+398
trunc_dec:
	epp2	arg1
	tsx0	ap|op_vec+399
mod_dec:
	epp2	arg1
	tsx0	ap|op_vec+400
comp_bits:
	tsx0	ap|op_vec+20
support_mac:
	tsx0	ap|op_vec+401
a_to_x0:
	eax0	0,al
b2c_mac:
	adq	8,dl
	div	9,dl
b2w_mac:
	adq	35,dl
	div	36,dl
c2b_mac:
	mpy	9,dl
c2w_mac:
	adq	3,dl
	qrs	2
digit_to_bit:
	mpy	9,dl
	qrs	1
pf_mac:
	qrs	9
	anq	=o777,dl
so_mac:
	tsx0	ap|op_vec+72
	spribp	arg1
longbs_to_bs18:
	tsx0	ap|op_vec+73
mod_bit_mac:
	div	36,dl
mod2_mac:
	adq	1,dl
	anq	=o777776,dl
mod4_mac:
	adq	3,dl
	anq	=o777774,dl
mod8_mac:
	adq	7,dl
	anq	=o777770,dl
mod16_mac:
	adq	15,dl
	anq	=o777760,dl
translate_2:
	tsx0	ap|op_vec+337
translate_3:
	tsx0	ap|op_vec+338
inline_translate:
	mvt	(0),(0),fill(blank)
	zero	arg2,char
	zero	arg1,char
	zero	arg3,addr
ext_and_1:
	tsx0	ap|op_vec+18
ext_and_2:
	tsx0	ap|op_vec+19
fx1_to_fl2:
	tsx0	ap|fx1_to_fl2_
trunc_fl:
	tsx0	ap|op_vec+235
fl2_to_fx1:
	tsx0	ap|op_vec+67
fx2_to_fl2:
	lde	=71b25,du
	fad	=0.,du
fl2_to_fx2:
	tsx0	ap|op_vec+68
longbs_to_fx2:
	tsx0	ap|op_vec+69
longbs_to_fl2:
	tsx0	ap|op_vec+69
	llr	36
	lrs	36
blank_q:
	ldq	ap|blanks_
cpcs1_odd:
cpbs2_odd:
	cmpa	arg1
	tnz	2,ic
	cmpq	arg1+1
cpcs_ext1:
	tsx0	ap|op_vec+24
cpcs_ext2:
	tsx0	ap|op_vec+25
cpbs1_odd:
	cmpa	arg1
	tnz	2,ic
	szn	arg1+1
cpbs1_even:
	ldq	0,du
	cmpaq	arg1
cpbs2:
	cmpa	arg1
	tnz	2,ic
	cmpq	0,du
cpbs_ext1:
	tsx0	ap|op_vec+26
cpbs_ext2:
	tsx0	ap|op_vec+27
cpbs3:
	cmpb	(0),(0)
	zero	arg1,bit
	zero	0
cp_chars:
	cmpc	(0),(0),fill(blank)
	zero	arg1,char
	zero	arg2,char
cp_bits:
	cmpb	(0),(0),fill(0)
	zero	arg1,bit
	zero	arg2,bit
r_l_a:
	tsx0	ap|r_l_a_
r_l_s:
	tsx0	ap|r_l_s_
r_g_a:
	tsx0	ap|r_g_a_
r_g_s:
	tsx0	ap|r_g_s_
r_e_as:
	tsx0	ap|r_e_as_
r_ne_as:
	tsx0	ap|r_ne_as_
r_le_a:
	tsx0	ap|r_le_a_
r_le_s:
	tsx0	ap|r_le_s_
r_ge_a:
	tsx0	ap|r_ge_a_
r_ge_s:
	tsx0	ap|r_ge_s_
tra_ext_1:
	tra	ap|op_vec+70
tra_ext_2:
	tra	ap|op_vec+71
load_pt_reg:
	eppbp	arg1
	spribp	sp|40
make_lv:
	eppbp	arg1
	ldq	arg2
	tsx0	ap|op_vec+66
store_lv:
	eppbp	arg1
	tsx0	ap|op_vec+65
set_stack:
	ldq	arg1
	tsx0	ap|set_stack_
j_g_s:
	tze	2,ic
	trc	arg1
j_le_s:
	tnc	arg1
	tze	arg1
reset_stack:
	tsx0	ap|op_vec+163
get_ops_mac:
	epaq	0,ic
	lprplp	sb|22,*au
	eppbp	arg1
	tra	0,0
ss_enter_begin_block:
	eax7	0
	tspbp	ap|op_vec+405
enter_begin_block:
	eax7	0
	tspbp	ap|op_vec+35
leave_begin_block:
	tsx0	ap|op_vec+36
return_mac:
	tra	ap|op_vec+48
entry_macro:
	eax7	0
	tsx0	arg2
	tspbp	arg1
enter_prologue:
	sxl0	arg1
leave_prologue:
	lxl0	arg1
	tra	0,0
call_prologue:
	tsx0	arg1
call_ent_var_d:
	tsx0	ap|op_vec+37
call_ent_var:
	tsx0	ap|op_vec+38
call_ext_in_d:
	tsx0	ap|op_vec+39
call_ext_in:
	tsx0	ap|op_vec+40
call_ext_out_d:
	tsx0	ap|op_vec+41
call_ext_out:
	tsx0	ap|op_vec+42
call_int_this_d:
	tsx0	ap|op_vec+43
call_int_this:
	tsx0	ap|op_vec+44
call_int_other_d:
	tsx0	ap|op_vec+45
call_int_other:
	tsx0	ap|op_vec+46
prepare_call:
	eax1	arg1
	fld	arg2
qls_9:
	qls	9
set_bit_addr:
	sxl1	arg1+1
pointer_mac_bs:
	eawpbp	0,au
pointer_mac_fx:
	eawpbp	0,ql
addrel_mac_bs:
	awd	bp|0,au
addrel_mac_fx:
	awd	bp|0,ql
baseptr_mac_bs:
	epbpbp	sp|0
	easpbp	0,au
baseptr_mac_fx:
	epbpbp	sp|0
	easpbp	0,ql
pointer_mac_bs_ab:
	eawpab	0,au
pointer_mac_fx_ab:
	eawpab	0,ql
pointer_mac_bs_bb:
	eawpbb	0,au
pointer_mac_fx_bb:
	eawpbb	0,ql
pointer_mac_bs_lb:
	eawplb	0,au
pointer_mac_fx_lb:
	eawplb	0,ql
pointer_mac_bs_sb:
	eawpsb	0,au
pointer_mac_fx_sb:
	eawpsb	0,ql
addrel_mac_bs_ab:
	awd	ab|0,au
addrel_mac_fx_ab:
	awd	ab|0,ql
addrel_mac_bs_bb:
	awd	bb|0,au
addrel_mac_fx_bb:
	awd	bb|0,ql
addrel_mac_bs_lb:
	awd	lb|0,au
addrel_mac_fx_lb:
	awd	lb|0,ql
addrel_mac_bs_sb:
	awd	sb|0,au
addrel_mac_fx_sb:
	awd	sb|0,ql
baseptr_mac_bs_ab:
	epbpab	sp|0
	easpab	0,au
baseptr_mac_fx_ab:
	epbpab	sp|0
	easpab	0,ql
baseptr_mac_bs_bb:
	epbpbb	sp|0
	easpbb	0,au
baseptr_mac_fx_bb:
	epbpbb	sp|0
	easpbb	0,ql
baseptr_mac_bs_lb:
	epbplb	sp|0
	easplb	0,au
baseptr_mac_fx_lb:
	epbplb	sp|0
	easplb	0,ql
baseptr_mac_bs_sb:
	epbpsb	sp|0
	easpsb	0,au
baseptr_mac_fx_sb:
	epbpsb	sp|0
	easpsb	0,ql
set_chars:
	tsx0	ap|op_vec+302
set_bits:
	tsx0	ap|op_vec+303
absfx1:
	tpl	3,ic
	erq	ap|ones
	adq	1,dl
absfx2:
	tpl	2,ic
	negl
absfl1:
absfl2:
	tpl	2,ic
	fneg
load_offsets:
	ldq	arg1+1
	sbq	arg2
store_offsets:
	ldq	arg1
	asq	arg2+1
stac_mac:
	tsx0	ap|op_vec+74
sign_mac:
	tsx0	ap|op_vec+75
baseno_mac:
	ana	=o077777,du
segno_mac:
	llr	18		" segno to QL
	anq	=o077777,dl	" by itself
mod_byte_mac:
	lda	arg1
	lrs	2
	qrl	34
mod_byte_mac_exp:
	lda	0,dl
	lls	34
	qrl	34
mod_half_mac:
	lda	arg1
	lrs	1
	qrl	35
mod_half_mac_exp:
	lda	0,dl
	lls	35
	qrl	35
"
bound_ck_mac:
	ifnot	atm2
	cplsave	arg2
*
	ifnot	atm3
	cplsave	arg3
*
	fetch	arg4
	lda	arg3
	switch	1,type2
	jump	bnd_ck_fx1
	jump	bnd_ck_fx2
bnd_ck_fx1:
	bump	arg2		"we don't want cwl to drop count to zero
	cwl	arg2
	tze	2,ic
	tsx0	ap|op_vec+76
	erase	q+lp
	ldq	arg2
	drop	arg2		"only 1st use of arg2 dropped the count
**
bnd_ck_fx2:
	cwl	arg2+1
	tze	2,ic
	tsx0	ap|op_vec+76
	erase	q+lp
	ldq	arg2+1
	drop	arg2
**
"
args_by_2_mac:
	ldq	sp|26,*
	qrs	18
min_fx1:
	cmpq	arg1
	tmi	2,ic
	ldq	arg1
min_fx2:
	cmpaq	arg1
	tmi	2,ic
	ldaq	arg1
min_fl1:
	fcmp	arg1
	tmi	2,ic
	fld	arg1
min_fl2:
	dfcmp	arg1
	tmi	2,ic
	dfld	arg1
max_fx1:
	cmpq	arg1
	tpl	2,ic
	ldq	arg1
max_fx2:
	cmpaq	arg1
	tpl	2,ic
	ldaq	arg1
max_fl1:
	fcmp	arg1
	tpl	2,ic
	fld	arg1
max_fl2:
	dfcmp	arg1
	tpl	2,ic
	dfld	arg1
neg_q:
	erq	ap|ones
	adq	1,dl
mpfx2:
	eppbp	arg1
	tsx0	ap|op_vec+80
mpfx3:
	eppbp	arg1
	tsx0	ap|op_vec+81
substr_ck_mac:
	ifnot	atm2
	cplsave	arg2
*
	ifnot	atm3
	cplsave	arg3
*
	fetch	arg4
	lda	arg3
	switch	1,type2
	jump	range_ck_fx1
	jump	range_ck_fx2
range_ck_fx1:
	bump	arg2
	cwl	arg2
	tze	2,ic
	tsx0	ap|op_vec+404
	erase	q+lp
	ldq	arg2
	drop	arg2	second use of arg2 in non-macro.
**
range_ck_fx2:
	cwl	arg2+1
	tze	2,ic
	tsx0	ap|op_vec+404
	erase	q+lp
	ldq	arg2+1
	drop	arg2
**
"
set_ptr_to:
	eppbp	arg1
	spribp	arg2
mdfl1:
	eppbp	arg1
	tsx0	ap|op_vec+89
mdfl2:
	eppbp	arg1
	tsx0	ap|op_vec+90
mdfx1:
	eppbp	arg1
	tsx0	ap|op_vec+91
mdfx2:
	eppbp	arg1
	tsx0	ap|op_vec+92
mdfx3:
	eppbp	arg1
	tsx0	ap|op_vec+93
mdfx4:
	eppbp	arg1
	tsx0	ap|op_vec+94
divide_fx1:
	epp2	arg1
	tsx0	ap|op_vec+329
divide_fx2:
	epp2	arg1
	tsx0	ap|op_vec+330
divide_fx3:
	epp2	arg1
	tsx0	ap|op_vec+331
divide_fx4:
	epp2	arg1
	tsx0	ap|op_vec+332
scaled_mdfx1:
	epp2	arg1
	tsx0	ap|op_vec+333
scaled_mdfx2:
	epp2	arg1
	tsx0	ap|op_vec+334
scaled_mdfx3:
	epp2	arg1
	tsx0	ap|op_vec+335
scaled_mdfx4:
	epp2	arg1
	tsx0	ap|op_vec+336
make_desc_mac:
	orq	arg2
	stq	arg1
quick_desc_size:
	ldq	arg1
	anq	ap|168		=o000077777777
get_desc_size:
	ldq	arg1
	tmi	2,ic
	anq	=o777777,dl
	anq	ap|168		=o000077777777
pad_chars:
	tsx0	ap|op_vec+99
pad_bits:
	tsx0	ap|op_vec+100
load_link_pt:
	epplp	sp|36,*
assign_label_const:
	sprilp	arg1
	sprisp	arg1+2
is_label_const:
	spribp	arg1
	sprisp	arg1+2
load_display_ptr:
	epplp	sp|32,*
walk_display_ptr:
	epplp	lp|32,*
begin_return:
	ldq	arg1
	tra	ap|op_vec+47
begin_return_main:
	ldq	arg1
	tra	ap|op_vec+443
revert_mac:
	stz	arg1+4
signal_mac:
	eppbp	arg1		string
	tsx0	ap|op_vec+101
enable_mac:
	eppbp	arg1		string
	tsx0	ap|op_vec+102
	tra	arg3		body of on_unit
	arg	arg2		stack loc of on_unit
get_area_mod_8:
	eppbp	arg1
	eaq	bp|7
	anq	=o777770,du
	eawpbp	0,qu
	spribp	arg2
fx1_to_bs:
	lda	arg1
	tpl	2,ic
	neg	0
	als	arg2
fx2_to_bs:
	ldaq	arg1
	tpl	2,ic
	negl	0
	lls	arg2
uns_fx1_to_bs:
	lda	arg1
	als	arg2
uns_fx2_to_bs:
	ldaq	arg1
	lls	arg2
ix_chars:
	tsx0	ap|op_vec+304
ix_rev_chars:
	tsx0	ap|op_vec+448
verify_rev_chars:
	tsx0	ap|op_vec+449
search_rev_chars:
	tsx0	ap|op_vec+450
ix_bits:
	tsx0	ap|op_vec+305
move_xor:
	csl	(0),(0),bool(xor)
	zero	arg2,bit
	zero	arg1,bit
beg_ev_proc:
	lxl7	0,dl
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+190
	vfd	18/2,18/0
	vfd	36/0
end_ev_proc:
	stq	arg1
	tra	ap|op_vec+48
symtab_mac:
	eppbp	arg2
	spribp	arg1+2
	adwpbp	arg3
	spribp	arg1+4
init_ps_mac:
	sprisp	arg1
	eppbp	arg1
	spribp	sp|ps_ptr
init_sslp:
	eppbp	arg2
	spribp	arg1+8
io_signal_mac:
	eppbp	arg1
	tsx0	ap|op_vec+139
end_ev_label:
	eppbp	arg1
	tsx0	ap|op_vec+65	move_label_variable
	tra	ap|op_vec+48	return
pointer_mac_const:
	eawpbp	0
addrel_mac_const:
	adwpbp	0,du
pointer_mac_c_ab:
	eawpab	0
pointer_mac_c_bb:
	eawpbb	0
pointer_mac_c_lb:
	eawplb	0
pointer_mac_c_sb:
	eawpsb	0
addrel_mac_c_ab:
	adwpab	0,du
addrel_mac_c_bb:
	adwpbb	0,du
addrel_mac_c_lb:
	adwplb	0,du
addrel_mac_c_sb:
	adwpsb	0,du
test_lda_ldq:
	lda	arg1
	ldq	arg1+1
	cmpaq	ap|0
testfx1:
	cmpq	0,dl
testfx2:
	cmpaq	ap|0
testfl1:
	fcmp	ap|2
testfl2:
	dfcmp	ap|2
ix_before_chars_1:
ix_chars_1:
	scm	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
ix_chars_2:
	scd	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
ix_rev_chars_1:
	scmr	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
ix_rev_chars_2:
	scdr	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
ix_bits_1:
	tsx0	ap|op_vec+307
zero_bits:
	csl	(0),(0),bool(move),fill(0)
	zero	0
	zero	arg1,bit
one_bits:
	csl	(0),(0),bool(move),fill(1)
	zero	0
	zero	arg1,bit
bool_mac_1:
	xec	ap|csl_vector,al
	zero	arg2,bit
	zero	arg1,bit
bool_mac_2:
	xec	ap|csl_vector,0
	zero	arg2,bit
	zero	arg1,bit
blank_chars:
	mlr	(0),(0),fill(blank)
	zero	0
	zero	arg1,char
zero_chars_q:
zero_chars:
	mlr	(0),(0)
	zero	0
	zero	arg1,char
one_chars:
	mlr	(0),(0),fill(777)
	zero	0
	zero	arg1,char
off_mac_easy:
	eppbp	arg1
	tsx0	ap|op_vec+285
off_mac_easy_pk:
	eppbp	arg1
	tsx0	ap|op_vec+286
off_mac_hard:
	eppbp	arg1
	tsx0	ap|op_vec+287
off_mac_hard_pk:
	eppbp	arg1
	tsx0	ap|op_vec+288
quick_return:
	rtcd	arg1
quick_entry:
quick_entry_args:
quick_entry_desc:
	sprilp	arg1
	spribp	arg1+2
	eppbp	bp|2,au
	spribp	arg1+4
quick_call:
	tsplp	arg1
prepare_quick_call:
	eppbp	arg1
	fld	arg2
	staq	bp|0
assign_lab_to_int:
	eax0	arg2
	sxl0	arg1
load_logical:
	lda	arg1
mask_logical:
	ana	=o400000,du
store_logical:
	era	arg1
	ana	=o400000,du
	ersa	arg1
not_logical:
	era	=o400000,du
tran_sign_fx1:
	eppbp	arg1
	tsx0	ap|op_vec+77
tran_sign_fl:
	eppbp	arg1
	tsx0	ap|op_vec+78
fort_mod_fx1:
	div	arg1
	lrs	36
fort_mod_fl1:
	eppbp	arg1
	tsx0	ap|op_vec+142
"unused_389:
"unused_391:
"unused_392:
rflb1_to_cflb1:
	fst	sp|44
	lda	sp|44
	ldq	=0.0,du
atm_rflb1_to_cflb1:
	lda	arg1
	ldq	=0.0,du
rfb1_to_cflb1:
	tsx0	ap|op_vec+143
rfb2_to_cflb1:
	tsx0	ap|op_vec+144
loop_end_var:
	ldq	arg2
	aos	arg2
	cmpq	arg3
	tmi	arg1
store_bp_hard:
	spribp	sp|46
	ldaq	sp|46
	staq	arg1
complex_mac:
	bump	arg1
	fetch	arg2
	fst	arg1
	drop	arg1
	fetch	arg3
	fst	arg1+1
**
conjg_mac:
	bump	arg1
	bump	arg2
	ifnot	atm2
	cplalt	arg2
*
	fld	arg2
	fst	arg1
	fld	arg2+1
	fneg	0
	fst	arg1+1
	drop	arg1
	drop	arg2
**
real_mac:
	ifnot	atm2
	cplalt	arg2
*
	fld	arg2
**
imag_mac:
	ifnot	atm2
	cplalt	arg2
*
	fld	arg2+1
	drop	arg2
**
square_fx1:
	stq	sp|46
	mpy	sp|46
square_fl1:
	fst	sp|46
	fmp	sp|46
square_fl2:
	dfst	sp|46
	dfmp	sp|46
h2w_mac:
	adq	1,dl
	qrs	1
unpk_to_pk:
	tsx0	ap|op_vec+7
pk_to_unpk:
	tsx0	ap|op_vec+6
bp_to_aq:
	spribp	sp|46
	ldaq	sp|46
lp_to_aq:
	sprilp	sp|46
	ldaq	sp|46
real_to_real_rd:
	tsx0	ap|op_vec+323
real_to_real_tr:
	tsx0	ap|op_vec+324
any_to_any_rd:
	tsx0	ap|op_vec+325
any_to_any_tr:
	tsx0	ap|op_vec+326
unpack_pic:
	tsx0	ap|op_vec+327
edit_pic:
	tsx0	ap|op_vec+328
shift_and_mask_1:
	als	arg1
	ana	arg2
	arl	arg1
shift_and_mask_2:
	lls	arg1
	anaq	arg2
	lrl	arg1
return_words:
	lxl0	arg1
	tra	ap|op_vec+183
return_bits:
	tra	ap|op_vec+309
return_chars:
	tra	ap|op_vec+308
fetch_chars:
	tsx0	ap|op_vec+196
fetch_bits:
fetch_bits_eis:
	tsx0	ap|op_vec+197
fetch_chars_eis:
	tsx0	ap|op_vec+403
get_term_mac:
	tsx0	ap|op_vec+198
put_term_mac:
	tsx0	ap|op_vec+199
put_data:
	tsx0	ap|op_vec+310
get_list:
	tsx0	ap|op_vec+314
get_edit:
	tsx0	ap|op_vec+313
put_list:
	tsx0	ap|op_vec+312
put_edit:
	tsx0	ap|op_vec+311
put_field:
	tsx0	ap|op_vec+406
put_field_chk:
	tsx0	ap|op_vec+407
put_control:
	tsx0	ap|op_vec+408
ftn_read:
	tsx0	ap|op_vec+317
ftn_write:
	tsx0	ap|op_vec+318
ftn_manip:
	tsx0	ap|op_vec+319
ftn_scalar_xmit:
	epp2	arg1
	tsx0	ap|op_vec+320
ftn_array_xmit:
	epp2	arg1
	tsx0	ap|op_vec+321
ftn_term:
	tsx0	ap|op_vec+322
stream_prep_mac:
	lda	arg1
	eppbp	arg2
	tsx0	ap|op_vec+205
recio_mac:
	lda	arg1
	tsx0	ap|op_vec+206
unpack_fl1:
	sta	sp|44
	fld	sp|44
unpack_fl2:
	staq	sp|44
	dfld	sp|44
unpack_cfl1:
	lrl	arg1
	als	arg1
pack_fl1:
	fst	sp|44
	lda	sp|44
pack_fl2:
	dfst	sp|44
	ldaq	sp|44
pack_cfl1:
	arl	arg1
	lls	arg1
open_mac:
	tsx0	ap|op_vec+207
close_mac:
	tsx0	ap|op_vec+208
compare_labels:
	ldaq	arg1
	eraq	arg2
	anaq	ap|ptr_mask_
	tnz	arg3
compare_files:
	ldaq	arg1+2
	eraq	arg2+2
	anaq	ap|ptr_mask_
fetch_pp:
	ldaq	arg1
	lda	sp|46
store_pp:
	spribp	arg1
	stq	arg1+1
fxscaled_to_fl2:
	lde	arg1
	fad	=0.,du
fl2_to_fxscaled:
	tsx0	ap|op_vec+226
"
trunc_fx1:
	tsx0	ap|op_vec+227
trunc_fx2:
	tsx0	ap|op_vec+228
ceil_fx1:
	tsx0	ap|op_vec+229
ceil_fx2:
	tsx0	ap|op_vec+230
ceil_fl:
	tsx0	ap|op_vec+231
floor_fx1:
	tsx0	ap|op_vec+232
floor_fx2:
	tsx0	ap|op_vec+233
floor_fl:
	tsx0	ap|op_vec+234
nop_mac:
	nop	0,du
round_fx1:
	tsx0	ap|op_vec+236
round_fx2:
	tsx0	ap|op_vec+237
round_fl:
	tsx0	ap|op_vec+292
	arg	arg1
repeat:
	tsx0	ap|op_vec+238
verify:
	tsx0	ap|op_vec+315
search:
	tsx0	ap|op_vec+316
reverse_cs:
	tsx0	ap|op_vec+251
reverse_bs:
	tsx0	ap|op_vec+252
chars_move_ck:
	mlr	(0),(0),fill(blank),enablefault
	zero	arg2,char
	zero	arg1,char
bits_move_ck:
	csl	(0),(0),bool(move),enablefault
	zero	arg2,bit
	zero	arg1,bit
signal_stringsize:
	tsx0	ap|op_vec+267
size_check_fx1:
	tsx0	ap|op_vec+265
size_check_fx2:
	tsx0	ap|op_vec+266
size_check_uns_fx1:
	tsx0	ap|op_vec+444
size_check_uns_fx2:
	tsx0	ap|op_vec+445
size_ck_varying:
	cmpq	arg1
	tmoz	3,ic
	tsx0	ap|op_vec+267
	ldq	arg1
size_ck_suffix:
	cmpq	arg1
	tpl	3,ic
	tsx0	ap|op_vec+267
	tra	2,ic
	ldq	arg1
cmp_suffix_1:
	cmpq	arg1
	tpl	5,ic
size_ck_suffix_1:
	cmpq	arg1
	tmi	3,ic
	tsx0	ap|op_vec+267
	tra	5,ic
size_ck_decimal:
	eax0	2,ic
	tov	ap|op_vec+385
move_3:
move_odd:
	lda	arg2
	sta	arg1
	lda	arg2+1
	sta	arg1+1
	lda	arg2+2
	sta	arg1+2
move_odd_odd_3:
move_odd_odd_5:
	lda	arg2
	sta	arg1
	ldaq	arg2+1
	staq	arg1+1
	ldaq	arg2+3
	staq	arg1+3
move_odd_odd_4:
	lda	arg2
	sta	arg1
	ldaq	arg2+1
	staq	arg1+1
	lda	arg2+3
	sta	arg1+3
move_odd_even_3:
	ldaq	arg2
	sta	arg1
	stq	arg1+1
	lda	arg2+2
	sta	arg1+2
move_odd_even_4:
	ldaq	arg2
	sta	arg1
	stq	arg1+1
	ldaq	arg2+2
	sta	arg1+2
	stq	arg1+3
move_even_odd_3:
	lda	arg2
	ldq	arg2+1
	staq	arg1
	lda	arg2+2
	sta	arg1+2
move_even_odd_4:
	lda	arg2
	ldq	arg2+1
	staq	arg1
	lda	arg2+2
	ldq	arg2+3
	staq	arg1+2
move_even:
move_even_even_3:
	ldaq	arg2
	staq	arg1
	lda	arg2+2
	sta	arg1+2
move_even_even_4:
move_even_even_6:
	ldaq	arg2
	staq	arg1
	ldaq	arg2+2
	staq	arg1+2
	ldaq	arg2+4
	staq	arg1+4
move_even_even_5:
	ldaq	arg2
	staq	arg1
	ldaq	arg2+2
	staq	arg1+2
	lda	arg2+4
	sta	arg1+4
pl1_ptr_hard:
	tsx0	ap|op_vec+270
pl1_ptr_hard_pk:
	tsx0	ap|op_vec+289
pl1_ptr_easy:
	tsx0	ap|op_vec+290
pl1_ptr_easy_pk:
	tsx0	ap|op_vec+291
xr_to_q:
	eaq	arg1
	qrs	18
xr18_to_q:
	eaq	arg1
	qrl	18
packed_to_bp:
	stq	sp|46
	lprpbp	sp|46
packed_bit_offset:
	qrl	30
move_words:
copy_mac:
	mlr	(0),(0)
	zero	arg2,char
	zero	arg1,char
ext_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+188
ext_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+189
int_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+190
int_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+191
val_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+192
val_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+193
ss_ext_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+386
ss_ext_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+387
ss_int_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+388
ss_int_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+389
ss_val_entry:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+390
ss_val_entry_desc:
	eax7	0
	eppbp	sb|ops_ptr,*
	tspbp	bp|op_vec+391
inline_verify:
	scm	(0),(0)
	zero	arg2,char
	zero	arg1,char
	arg	sp|46
	ldq	1,dl
	ttn	2,ic
	ldq	0,dl
inline_search:
	scm	(0),(0)
	zero	arg2,char
	zero	arg1,char
	arg	sp|46
	ldq	1,dl
	ttf	2,ic
	ldq	0,dl
verify_ltrim_inline:
test_translate:
	tct	(0)
	zero	arg1,char
	zero	arg2,addr
	arg	sp|46
	ldq	sp|46
	anq	ap|tct_mask_
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
verify_rtrim_inline:
test_trans_rev:
	tctr	(0)
	zero	arg1,char
	zero	arg2,addr
	arg	sp|46
	ldq	sp|46
	anq	ap|tct_mask_
	ttf	2,ic
	lcq	1,dl
	adq	1,dl
"
sqrt_mac:
	tsp3	ap|op_vec+339
sin_mac:
	tsp3	ap|op_vec+340
sind_mac:
	tsp3	ap|op_vec+341
cos_mac:
	tsp3	ap|op_vec+342
cosd_mac:
	tsp3	ap|op_vec+343
tan_mac:
	tsp3	ap|op_vec+344
tand_mac:
	tsp3	ap|op_vec+345
asin_mac:
	tsp3	ap|op_vec+346
asind_mac:
	tsp3	ap|op_vec+347
acos_mac:
	tsp3	ap|op_vec+348
acosd_mac:
	tsp3	ap|op_vec+349
atan_mac:
	tsp3	ap|op_vec+350
atand_mac:
	tsp3	ap|op_vec+351
log2_mac:
	tsp3	ap|op_vec+352
log_mac:
	tsp3	ap|op_vec+353
log10_mac:
	tsp3	ap|op_vec+354
exp_mac:
	tsp3	ap|op_vec+355
dsqrt_mac:
	tsp3	ap|op_vec+356
dsin_mac:
	tsp3	ap|op_vec+357
dsind_mac:
	tsp3	ap|op_vec+358
dcos_mac:
	tsp3	ap|op_vec+359
dcosd_mac:
	tsp3	ap|op_vec+360
dtan_mac:
	tsp3	ap|op_vec+361
dtand_mac:
	tsp3	ap|op_vec+362
dasin_mac:
	tsp3	ap|op_vec+363
dasind_mac:
	tsp3	ap|op_vec+364
dacos_mac:
	tsp3	ap|op_vec+365
dacosd_mac:
	tsp3	ap|op_vec+366
datan_mac:
	tsp3	ap|op_vec+367
datand_mac:
	tsp3	ap|op_vec+368
dlog2_mac:
	tsp3	ap|op_vec+369
dlog_mac:
	tsp3	ap|op_vec+370
dlog10_mac:
	tsp3	ap|op_vec+371
dexp_mac:
	tsp3	ap|op_vec+372
atan2_mac:
	tsp3	ap|op_vec+373
atan2d_mac:
	tsp3	ap|op_vec+374
datan2_mac:
	tsp3	ap|op_vec+375
datan2d_mac:
	tsp3	ap|op_vec+376
int_p_real:
	tsp3	ap|op_vec+377
int_p_dbl:
	tsp3	ap|op_vec+378
dbl_p_real:
	tsp3	ap|op_vec+379
dbl_p_dbl:
	tsp3	ap|op_vec+380
dbl_p_int:
	tsp3	ap|op_vec+381
real_p_real:
	tsp3	ap|op_vec+382
real_p_int:
	tsp3	ap|op_vec+383
int_p_int:
	tsp3	ap|op_vec+384
"				state_man$flush called after this macro
enable_file:
	eppbp	arg2
	eaa	arg1
	tsx0	ap|op_vec+293
	tra	arg3
"				state_man$flush called after this macro
enable_file_2:
	eppbp	arg2
	eaa	arg1
	ora	arg4
	tsx0	ap|op_vec+293
	tra	arg3
"
revert_file:
	eppbp	arg2
	eaa	arg1
	tsx0	ap|op_vec+294
"
alloc_block:
	eppbp	arg1
	tsx0	ap|op_vec+295
"
free_block:
	eppbp	arg1
	tsx0	ap|op_vec+296
"
push_ctl_data:
	eppbp	arg1
	tsx0	ap|op_vec+297
"
push_ctl_desc:
	eppbp	arg1
	tsx0	ap|op_vec+298
"
pop_ctl_data:
	eppbp	arg1
	tsx0	ap|op_vec+299
"
pop_ctl_desc:
	eppbp	arg1
	tsx0	ap|op_vec+300
"
allocation:
	eppbp	arg1
	tsx0	ap|op_vec+301
"
ab_to_aq:
	spri1	sp|46
	ldaq	sp|46
"
bb_to_aq:
	spri3	sp|46
	ldaq	sp|46
"
lb_to_aq:
	spri5	sp|46
	ldaq	sp|46
"
sb_to_aq:
	spri7	sp|46
	ldaq	sp|46
"
zero_bo_bp:
	adwpbp	0,du
zero_bo_ab:
	adwpab	0,du
zero_bo_bb:
	adwpbb	0,du
zero_bo_lb:
	adwplb	0,du
zero_bo_sb:
	adwpsb	0,du
"
abd:
	abd	ap|arg1
"
a9bd:
	a9bd	ap|arg1
"
a4bd:
	a4bd	ap|arg1
"
zero_mac_p_1:
	stz	arg1+1
"
alloc_based_area:
	tsx0	pr0|op_vec+409
	tra	arg1
alloc_based_mac:
	tsx0	pr0|op_vec+410
	tra	arg1
free_based_mac:
	tsx0	pr0|op_vec+411
empty_area_mac:
	tsx0	pr0|op_vec+412
"
long_profile_mac:
	tsx0	pr0|op_vec+426
"
ix_before_chars:
	tsx0	ap|op_vec+427
ix_before_bits:
	tsx0	ap|op_vec+428
ix_after_chars:
	tsx0	ap|op_vec+429
ix_after_bits:
	tsx0	ap|op_vec+430
ix_before_bits_1:
	tsx0	ap|op_vec+431
ix_after_chars_1:
	scm	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttn	2,ic
	adq	1,dl
ix_after_bits_1:
	tsx0	ap|op_vec+432
ix_before_chars_2:
	scd	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	ttf	2,ic
	adq	1,dl
ix_after_chars_2:
	scd	(0),(0)
	zero	arg1,char
	zero	arg2,char
	arg	sp|46
	ldq	sp|46
	adq	1,dl
	ttn	2,ic
	adq	1,dl
verify_ltrim:
	tsx0	ap|op_vec+433
verify_rtrim:
	tsx0	ap|op_vec+434
"
stacq_mac:
	ldq	arg1
	tsx0	ap|op_vec+435
"
clock_mac:
	tsx0	ap|op_vec+436
"
vclock_mac:
	tsx0	ap|op_vec+437
"
stop_mac:
	tra	ap|op_vec+440
"
return_main_mac:
	tra	ap|op_vec+441
"
set_main_mac:
	tsx0	ap|op_vec+442
"
zero_4bcs:
	mlr	(0),(0),fill(0)
	zero	0
	zero	arg1,char4+2
"
rank_eis_mac:
	mrl	(0),(0),fill(0)
	zero	arg2,char+1
	zero	arg1,char+4
"
prepare_call_long:
	eax1	arg1
	lda	arg2
	ldq	0,du
"
prepare_quick_call_long:
	eppbp	arg1
	lda	arg2
	ldq	0,du
	staq	bp|0

charno_mac:
	llr	18		" word count in AL, bit in QU
	ana	=o777777,dl	" flush ringno from AU
	als	2		" char count
	ada	ap|bitno_to_charno_,qu " bitno is in QU
	lrl	36		" back to the Q
bitno_mac:
				" S R
				" W B 
	llr	54		" B S
				" R W 
	ars	18		" 0 B
				" R W
	sta	sp|46		" stash
	anq	=o777777,dl	" 0 B
				" 0 W
	mpy	36,dl		" 0 0
				" W*36
	adq	sp|46		" 0 0
				" W*36+B

	end




		    make_both_addressable.pl1       10/03/83  1730.5rew 10/03/83  1008.9       38862



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


/* Procedure to make two or three references addressable at the same time

   Initial Version: 19 December 1971 by BLW
	Modified:  2 October 1972 by BLW
	Modified:	19 February 1973 by RAB
         Rewritten:	20 May 1973 by RAB for EIS
	Modified:	19 July 1974 by RAB to recognize that parameters
		are no longer referenced through lp
	Modified:	25 December 1976 by RAB to fix 1566	*/

make_both_addressable: proc(pt1,pt2,pno_ind);

dcl	pt1 ptr,		/* points at first ref to be made addressable */
	pt2 ptr,		/* points at second ref to be made addressable */
	pno_ind bit(1) aligned;	/* "1"b indicates no indirection allowed */

dcl	(p(3),s(3),q2) ptr;

dcl	(i,j,lbase,lx,n) fixed bin;

dcl	(eis,lock_base,lock_index,no_ind,no_tag) bit(1) aligned;

dcl	bit3 bit(3) aligned;

dcl	(m_a, need_temp) entry(ptr,bit(2) aligned),
	(base_man$lock,base_man$unlock,xr_man$super_lock,xr_man$super_unlock) entry(fixed bin),
	aq_man$lock entry(ptr,fixed bin),
	base_man$load_any_var entry(fixed bin,ptr,bit(3) aligned);

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

dcl	cg_stat$cur_block ptr ext static;

%include nodes;
%include reference;
%include operator;
%include bases;

	no_tag, eis = "0"b;
	no_ind = pno_ind;
	n = 2;
	p(1) = pt1;
	p(2) = pt2;

common:	lock_base, lock_index = "0"b;

	if p(1) -> reference.perm_address
	     then j = 2;
	     else j = 1;

	do i = j + 1 to n;
	if string(p(i) -> reference.address_in.b) then go to flip;

	q2 = p(i) -> reference.qualifier;
	if q2 ^= null
	then if q2 -> node.type ^= temporary_node
	then do;
	     if q2 -> node.type = operator_node then q2 = q2 -> operand(1);

	     if string(q2 -> reference.value_in.b)
	     then do;
flip:		q2 = p(j);
		p(j) = p(i);
		p(i) = q2;
		j = i;
		end;
	     end;
	end;

	do i = 1 to n;
	s(i) = p(i) -> reference.symbol;
	end;

	do i = 1 to n;

	if ^ p(i) -> reference.perm_address
	     then call m_a(p(i),no_ind || eis);

	if ^ eis
	then if i ^= 1
	     then go to step;

	if no_tag
	then if p(i) -> address.tag
	     then do;
		call get_base;
		go to base_lock;
		end;

	if p(i) -> reference.ext_base
	then if p(i) -> address.base ^= sp
	     then do;
		if ^ eis
		then do;
		     if s(1) = null then go to check_index;
		     if s(1) -> node.type ^= symbol_node then go to check_index;
		     if s(2) = null then go to check_index;
		     if s(2) -> node.type ^= symbol_node then go to check_index;
		     end;

		if p(i) -> address.base ^= lp
		then do;
base_lock:
		     lock_base = "1"b;
		     lbase = which_base(fixed(p(i) -> address.base,3));
		     call base_man$lock(lbase);
		     end;
		else;	/* lp is only used to address linkage (static) section */
		end;

check_index:
	if substr(p(i) -> address.tag,3,1)
	then do;
	     lock_index = "1"b;
	     lx = fixed(substr(p(i) -> address.tag,4,3),3);
	     call xr_man$super_lock(lx);
	     end;
	else if eis
	     then if substr(p(i) -> address.tag,4,1)
		then do;
		     lx = fixed(substr(p(i) -> address.tag,5,2),2);
		     if lx > 0
		     then if lx <= 2
			then call aq_man$lock(p(i),lx);
		     end;

step:	if p(i) -> reference.ref_count = 1 then call need_temp(p(i),"10"b);
	end;

	if eis then return;

	if lock_index
	     then call xr_man$super_unlock(lx);

	if lock_base
	     then call base_man$unlock(lbase);

	p(1) -> reference.perm_address = "1"b;
	p(2) -> reference.perm_address = "1"b;
	return;


make_n_addressable:	entry(pt,pn);

dcl	pt ptr,
	pn fixed bin;

dcl	ptarray(3) ptr aligned based(pt);

	no_ind, eis = "1"b;
	no_tag = pn < 0;
	n = abs(pn);
	do i = 1 to n;
	     p(i) = ptarray(i);
	     end;
	go to common;



get_base:	     proc;

	     p(i) -> reference.perm_address = "1"b;

	     if ^ p(i) -> reference.shared
	     then p(i) -> reference.ref_count = p(i) -> reference.ref_count + 1;

	     call base_man$load_any_var(2,p(i),bit3);

	     end;
end;




		    make_mod.pl1                    10/03/83  1730.5rew 10/03/83  1008.9        7020



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


/* this program returns the smallest number j such that
	j >= n
    and	j = 0 mod m

   Initial Version:  3 April, 1969 by BLW	*/

make_mod: proc(n,m) returns(fixed bin);

dcl	(n,j,k,m) fixed bin;

	j = n;
	k = mod(j,m);
	if k ^= 0 then j = j + m - k;
	return(j);

	end;




		    min_max.pl1                     10/03/83  1730.5rew 10/03/83  1009.0       58680



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


/* program to compile min and max functions for pl/1

   Note:	The min and max macros generated by this program make 2 references
   to their input argument.  Hence, the reference count on the reference node
   returned by compile_exp$save must be increased by 1, and the reference
   counts for the 3rd thru last temporary in the case of more than 3 operands
   must be 3 instead of 2 as might be expected.  Since the first temporary
   is merely loaded, a reference count of 2 is sufficient.

   Initial Version:  1 April, 1969 by BLW
	Modified:  5 May, 1971 by BLW for Version II
	Modified: 25 October, 1972 by, BLW
	Modified:	17 October, 1973 by RAB for EIS
	Modified:	10 September, 1975 by RAB to fix 1416
	Modified:	9 December 1976 by RAB to fix pos_dif_fun bug
	Modified:	30 January 1977 by RAB to fix 1570
	Modified:	19 March 1977 by RAB to fix 1597
	Modified:	1 June 1977 by RAB to improve min(atm,exp)
	Modified:	2 June 1977 by RAB to improve register management for 2 args	
	Modified 780830 by PG to remove pos_dif_fun
*/

min_max:
	procedure (pt);

/* parameters */

dcl	pt ptr parameter;				/* points at operator node */

/* automatic */

dcl	(p,op_pt,p2,p3,s1,ref(128)) ptr,
	(i,n_rands,type(128),scale(128)) fixed bin,
	op_code bit(9) aligned,
	which fixed bin(15),
	(p1_fx2,b1,check_scale) bit(1) aligned,
	atom(128) bit(1) aligned;

/* entries */

dcl	compile_exp entry(ptr),
	compile_exp$save entry(ptr) returns(ptr),
	decimal_op entry(ptr,(128) ptr,(128) bit(1) aligned),
	compile_exp$save_fix_scaled entry(ptr,fixed bin,fixed bin) returns(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	state_man$erase_reg entry(bit(19) aligned),
	aq_man$fix_scale entry(ptr,fixed bin,fixed bin),
	load entry(ptr,fixed bin),
	expmac entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15)),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);

/* external static */

dcl	cg_stat$temp_ref ptr ext;

/* internal static */

dcl (	rfb1_to_rfb2	init(88),
	min_fx1		init(247),
	max_fx1		init(251)) fixed bin(15) int static;

/* include files */

%include operator;
%include reference;
%include symbol;
%include machine_state;
%include data_types;
%include op_codes;

/* program */

	op_pt = pt;

	n_rands = op_pt -> operator.number;
	do i = 1 to n_rands;
	     ref(i) = prepare_operand((op_pt -> operand(i)),1,b1);
	     type(i) = ref(i) -> reference.data_type;
	     scale(i) = ref(i) -> reference.symbol -> symbol.scale;
	     atom(i) = b1;
	     end;

	op_code = op_pt -> operator.op_code;

	s1 = ref(1) -> reference.symbol;

	if s1 -> symbol.decimal
	then do;
	     call decimal_op(op_pt,ref,atom);
	     goto done;
	     end;

	check_scale = "0"b;
	p1_fx2 = type(1) = real_fix_bin_2;

	if s1 -> symbol.fixed
	then do i = 2 to n_rands;
		if scale(i) ^= scale(1)
		then do;
		     atom(i) = "0"b;
		     check_scale = "1"b;
		     end;

		if p1_fx2
		then if n_rands > 3
		     then if type(i) = real_fix_bin_1
			then atom(i) = "0"b;
		end;

	if op_code = min_fun then which = min_fx1;
	else which = max_fx1;

	if n_rands > 3 then goto mm_long;

	p2 = op_pt -> operand(2);
	p3 = op_pt -> operand(3);

	/* if both operands are the same, compile one & decrement ref_count */

	if p2 = p3
	then do;
	     call compile_exp(p2);
	     if ^ ref(3) -> reference.shared
		then call adjust_ref_count(ref(3),-1);

	     /* since compile_exp will call state_man$update_ref,
	        we must flush the q if we are putting in a temp */

	     if ref(2) -> reference.temp_ref
		then call state_man$erase_reg("01"b);
	     goto done;
	     end;

	/* put longer of two operands on right */

	if type(2) > type(3)
	     then call flip_rands;

	if atom(2)
	then do;
	     if atom(3) then goto mm_aa;

	     /* have f(atm,exp) */

	     if type(2) >= type(3)
	     then do;
		call flip_rands;
		go to mm_ea;
		end;

	     if check_scale & scale(1) ^= scale(3)
	     then do;
		ref(3) = compile_exp$save_fix_scaled(p3,scale(1),type(1));
		type(3) = type(1);
		end;
	     else ref(3) = compile_exp$save(p3);

	     /* have f(atm,atm) */

mm_aa:	     if ref(3) -> reference.value_in.q
	     then if type(2) >= type(3)
		then call flip_rands;

	     call load(ref(2),0);
	     end;
	else do;
	     if atom(3) then goto mm_ea;

	     /* have f(exp,exp) */

	     if check_scale & scale(1) ^= scale(3)
	     then do;
		ref(3) = compile_exp$save_fix_scaled(p3,scale(1),type(1));
		type(3) = type(1);
		end;
	     else ref(3) = compile_exp$save(p3);

	     /* have f(exp,atm) */

mm_ea:	     call compile_exp(p2);

	     if check_scale & scale(1) ^= scale(2)
	     then do;
		call aq_man$fix_scale(ref(2),scale(1),type(1));
		type(2) = type(1);
		end;

	     end;

	if p1_fx2 then if type(2) = real_fix_bin_1
	then call expmac$zero((rfb1_to_rfb2));

	call expmac(which + type(3) - real_fix_bin_1,ref(3));
	goto done;

	/* f(a1,a2,...,an).  evaluate all expressions and if
	   type of result is real_fix_bin_2, convert all single
	   precision fixed to double */

mm_long:	do i = 2 to n_rands;
	     if ^ atom(i)
	     then if (check_scale & scale(1) ^= scale(i)) | (p1_fx2 & type(i) = real_fix_bin_1)
		then do;
		     ref(i) = compile_exp$save_fix_scaled((op_pt -> operand(i)),scale(1),type(1));
		     type(i) = type(1);
		     end;
		else ref(i) = compile_exp$save((op_pt -> operand(i)));

	     end;

	call load(ref(2),0);

	do i = 3 to n_rands;
	     call expmac(which + type(i) - real_fix_bin_1,ref(i));
	     end;

done:	cg_stat$temp_ref = ref(1);

	/* set indicators to reflect the fact that the machine indicators
	   do not correspond to the value of the min|max function */

	machine_state.indicators = -1;
	return;


flip_rands:	proc;

	     /* flips operands for case of 2 operands */

	     p = ref(2);
	     ref(2) = ref(3);
	     ref(3) = p;

	     p = p2;
	     p2 = p3;
	     p3 = p;

	     b1 = atom(2);
	     atom(2) = atom(3);
	     atom(3) = b1;

	     i = type(2);
	     type(2) = type(3);
	     type(3) = i;

	     i = scale(2);
	     scale(2) = scale(3);
	     scale(3) = i;

	     end;
	end;




		    move_data.pl1                   10/03/83  1730.5rew 10/03/83  1009.0       93672



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


/* Procedure to move a block of data

   Modified:  3 January 1973 by BLW
  Modified:  19 February 1973 by RAB
 Modified:  12 June 1973 by RAB for EIS
Modified:	21 December 1974 by RAB to fix bug 1277
Modified:	22 January 1975 by RAB to fix bug 1314
Modified:	22 July 1975 by RAB to fix bug 1388
Modified:	9 February 1976 by RAB to fix 1462 & change ref cnt for dec
Modified:	26 May 1976 by RAB to improve determination of reference.even for structures
Modified:	5 July 1976 by RAB to fix 1504
   Modified: 27 October 1977 by RAB to more efficiently move packed aggregates of words
   Modified: 28 October 1977 by RAB to more efficiently move an aggregate when one is on even bound
	and other is on unknown bound
   Modified 781127 by PG to fix bug 1801 (setting even bit when it wasn't), introduced one year ago, and just found today!
   Modified 781128 by RAB to remove PG's fix to 1801 and put it in get_array_size
   Modified 790523 by RAB to fix 1820 & 1836 caused by assignment to complex
	binary temp other than complex_flt_bin_1
*/

move_data: proc(pt);

dcl	pt ptr;		/* points at an operator node */

dcl	(p,q,q1,q2,p1,p2,s,arg(2)) ptr,
	pd ptr defined(arg(1)),
	ps ptr defined(arg(2)),
	(adjust,atomic,big_length_hold,have_constant_length,sp_ok) bit(1) aligned,
	base bit(3) aligned,
	(case,i,n,amount) fixed bin,
	macro fixed bin(15);

dcl	(addr,addrel,bit,divide,fixed,mod,null,substr) builtin;

dcl	base_man$store_ptr_to entry(ptr,ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	state_man$erase_reg entry(bit(19) aligned),
	c_a entry(fixed bin,fixed bin) returns(ptr),
	make_both_addressable entry(ptr,ptr,bit(1) aligned),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	adjust_ref_count entry(ptr,fixed bin),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	load entry(ptr,fixed bin),
	compile_exp entry(ptr),
	eval_exp entry(ptr,bit(1) aligned) returns(ptr),
	long_op$two_eis entry(ptr,fixed bin,fixed bin(15),ptr),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	expmac entry(fixed bin(15),ptr),
	base_man$load_any_var_and_lock entry(fixed bin,ptr) returns(bit(3) aligned);

dcl	double_data bit(24) int static init("010111110000000111111110"b);

dcl	alters(0:1) bit(19) aligned static init("1"b,"11"b);

dcl (	copy_mac		init(257),
	set_bits		init(440),
	move_words	init(481),
	lda		init(1),
	sta		init(4),
	nop_mac		init(528),
	move_3		init(568),
	conv_mac(2)	init(515,26),	/* qls, dvfx1 */
	copy_bits		init(476)) fixed bin(15) int static;

dcl	table(0:1,0:1,3:6) fixed bin(15) int static
	init(	/* odd, odd */	569, 570, 571, 0,
		/* odd, even */	572, 573, 0, 0,
		/* even, odd */	574, 575, 0, 0,
		/* even, even */	576, 577, 578, 579);

dcl	conv_factor(2) fixed bin int static
	init(2,9);	/* bits, bits_per_char */

dcl	fix_bin		fixed bin based;

%include reference;
%include symbol;
%include array;
%include nodes;
%include bases;
%include operator;
%include op_codes;
%include cgsystem;
%include boundary;

	adjust = "0"b;

	p = pt;

	pd = prepare_operand((p -> operand(1)),-1,atomic);
	ps = prepare_operand((p -> operand(2)),-1,atomic);

	have_constant_length = "0"b;
	q = p -> operand(3);
	if q -> node.type ^= operator_node
	then if q -> reference.symbol -> symbol.constant
	     then do;
		have_constant_length = "1"b;
		amount = q -> reference.symbol -> symbol.initial -> fix_bin;
		end;

	if p -> operator.op_code = copy_string
	then do;

	     /* we have copy_string, if the move cannot be done with
	        words, go to str */

	     if have_constant_length
	     then if mod(amount,bits_per_word) = 0
		 & ps -> reference.units = word_ & ^ ps -> reference.fo_in_qual
		 & pd -> reference.units = word_ & ^ pd -> reference.fo_in_qual
		then amount = divide(amount,bits_per_word,17,0);
		else go to str;
	     else go to str;
	     end;

	/* have copy words case */

	if pd -> reference.temp_ref
	     then pd -> reference.value_in.storage = "1"b;

	if ps -> reference.varying_ref
	then do;

	     /* must adjust c_offset to move entire varying array */

	     adjust = "1"b;
	     ps -> reference.c_offset = ps -> reference.c_offset - 1;
	     pd -> reference.c_offset = pd -> reference.c_offset - 1;
	     end;

	if have_constant_length
	     then go to const;

	/* have unknown amount of words to move */

	case = 1;
	call make_copy;

	if adjust
	     then call adjust_offset;

	return;

	/* have constant number of words to move, do it in-line using mlr instruction
	   if more than 3 words (or word-pairs) have to be moved */

const:	if amount > 6 then go to long;

	call state_man$erase_reg((alters(fixed(amount > 1,1))));

	call make_both_addressable(pd,ps,amount > 1);

	do i = 1 to 2;
	     if ^ arg(i) -> reference.even
	     then do;
		s = arg(i) -> reference.symbol;
		if arg(i) -> reference.data_type > 0
		then do;
		     if substr(double_data,arg(i) -> reference.data_type,1)
		     then if ^ s -> symbol.packed
		     then arg(i) -> reference.even = "1"b;
		     end;
		else do;

		     /* structure */

		     if ^ arg(i) -> reference.array_ref & s -> symbol.array ^= null
		     then if s -> symbol.array -> array.element_boundary > word_
			then arg(i) -> reference.even = "1"b;
			else;
		     else if s -> symbol.boundary > word_
			then arg(i) -> reference.even = "1"b;
		     end;
		end;
	     end;

	if amount <= 2
	then do;
	     if pd -> reference.temp_ref & ^ pd -> reference.aggregate
	     then if pd -> reference.symbol -> symbol.decimal
		 | pd -> reference.symbol -> symbol.complex	/* fixes 1820 & 1836 */
		then pd -> reference.ref_count = pd -> reference.ref_count + 1;

	     amount = amount - 1;
	     call expmac$one((lda),ps,amount);
	     call expmac$one((sta),pd,amount);
	     goto done;
	     end;

	/* if an address is not known to be even, it may not necessarily be known
	   to be odd, check to see if non-even addresses are really odd */

	if ^ pd -> reference.even & ^ ps -> reference.even
	 & (((pd -> address.base ^= sp & pd -> address.base ^= lp) | pd -> address.tag ^= "0"b)
	  | ((ps -> address.base ^= sp & ps -> address.base ^= lp) | ps -> address.tag ^= "0"b))
	then do;

	     /* neither address is even and one is not known to be even or odd */

	     if amount > 3 then goto long;

	     macro = move_3;

move:	     if pd -> reference.temp_ref & ^ pd -> reference.aggregate
	     then if pd -> reference.long_ref
		 | pd -> reference.symbol -> symbol.decimal
		 | pd -> reference.symbol -> symbol.complex	/* fixes 1822 & 1836 */
		then pd -> reference.ref_count = pd -> reference.ref_count + 1;

	     call expmac$many(macro,addr(arg),2);
done:	     pd -> reference.perm_address,
	     ps -> reference.perm_address = "0"b;

	     if adjust
		then call adjust_offset;

	     return;
	     end;

	/* either both addresses are known to be odd, or at least one address
	   is known to be even, see if we have special sequence to move specified
	   number of words */

	if amount <= 6
	then do;

	     macro = table(fixed(pd -> reference.even,1),fixed(ps -> reference.even,1),amount);

	     if macro ^= 0 then goto move;
	     end;

	/* we'll have to use an EIS instruction */

/* Turn off perm address bits because we must make rands eis addressable */

long:	pd -> reference.perm_address,
	ps -> reference.perm_address = "0"b;

/* Issue move macro */

	n = chars_per_word * amount;
issue_move_mac:
	call long_op$two_eis(pd,n,(move_words),ps);

	if adjust
	     then call adjust_offset;

	return;


	/* have to do a string move */

str:	q1 = pd;
	q2 = ps;

	if pd -> reference.temp_ref
	     then pd -> reference.value_in.storage = "1"b;

	if ps -> reference.symbol -> symbol.char
	 | ps -> reference.symbol -> symbol.picture
	 | ps -> reference.symbol -> symbol.decimal
	then do;

	     /* can use MLR for characters */

	     q = p -> operand(3);

	     /* q is in bits */

	     if have_constant_length
	     then do;
		n = divide(amount,bits_per_char,17,0);
		go to issue_move_mac;
		end;

	     case = 2;
	     call make_copy;
	     return;
	     end;

	p1 = p -> operand(3);
	p1 = eval_exp(p1,"1"b);

	p2 = q2 -> reference.length;
	q2 -> reference.length = p1;

	big_length_hold = q2 -> reference.big_length;
	if p1 -> node.type = operator_node
	     then p1 = p1 -> operand(1);
	q2 -> reference.big_length = p1 -> reference.symbol -> symbol.c_dcl_size > max_p_xreg;

	do i = 1 to 2;
	     if arg(i) -> reference.units = character_
	     then do;

		/* since copy_bits is a CSL, we cannot allow character offset expr's */

		if ^ arg(i) -> reference.shared
		then arg(i) -> reference.ref_count = arg(i) -> reference.ref_count + 1;
		base = base_man$load_any_var_and_lock(2,arg(i));
		arg(i) -> reference.perm_address = "1"b;
		end;
	     end;

	call expmac$two_eis((copy_bits),q1,q2);
	q2 -> reference.length = p2;
	q2 -> reference.big_length = big_length_hold;

	q1 -> reference.perm_address,
	q2 -> reference.perm_address = "0"b;

	return;

move_block: entry(dest,source,number);

dcl	dest ptr,			/* points at ref of destination */
	source ptr,		/* points at ref of source */
	number fixed bin;		/* number of words to move */

	pd = dest;
	ps = source;
	amount = number;

	adjust = "0"b;

	goto const;

make_copy:     proc;

	     /* does a copy_words or copy_string with an MLR instruction */

	     /* first, load the length of the object to be moved */

	     q = prepare_operand(q,1,atomic);
	     if atomic then call load(q,0); else call compile_exp((p -> operand(3)));

	     /* convert the length to characters */

	     call expmac((conv_mac(case)),c_a((conv_factor(case)),case));

	     /* finally, issue the copy macro (an MLR instruction) */

	     call expmac$two_eis((copy_mac),pd,ps);

	     end;


adjust_offset:	proc;

	     ps -> reference.c_offset = ps -> reference.c_offset + 1;
	     pd -> reference.c_offset = pd -> reference.c_offset + 1;

	     end;



	end;




		    mst.pl1                         10/24/88  1634.0r w 10/24/88  1358.7      211428



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


/* Procedure to create symbol table for PL/I

   Initial Version:  3 June 1970 by BLW
	Modified: 20 May 1971 by BLW
	Modified: 10 March 1972 by BLW for Version II
	Modified:  3 October 1972 by BLW
	Modified: 21 January 1973 by BLW for controlled
	Modified: 23 October 1973 by BLW for pictures 
	Modified:	13 October 1975 by RAB to fix 1430
	Modified:	23 August 1976 by RAB to fix 1516
	Modified:	10 November 1976 by RAB to fix 1548
	Modified:	18 July 1977 to diagnose over-large separation between declarations of a var 
	Modified: 17 July 1978 for unsigned binary by PCK
	Modified:	6 September 1978 by RAB to fix 1785
	Modified:	27 September 1978 by RAB to straighten out filling in the data_type field.
	Modified: 23 January 1979 by DS to fix bug 1817
	Modified: 25 Apr 1979 by PCK to implement 4-bit decimal.
	Modified: 25 March 1980 by M. N. Davidoff for new sym_sort_alphabetic calling sequence that is independent of
		pl1_symbol_print.
	Modified: 830509 BIM for symbol.explicit_packed.
*/
/* format: style3 */
mst$block_nodes:
     proc (pt, father) returns (fixed bin (18));

dcl	pt		ptr,			/* points at block node */
	father		fixed bin (18);		/* symbol location of father */

dcl	(
	cg_static_$sym_base,
	cg_static_$sym_reloc_base,
	cg_static_$cur_block,
	cg_static_$root
	)		ptr ext,
	cg_static_$table_option
			bit (1) ext,
	cg_static_$compiler_name
			char (12) varying ext,
	(
	cg_static_$cur_level,
	cg_static_$sym_pos,
	cg_static_$sym_origin
	)		fixed bin ext;

dcl	(p, p1, p2, bp, q, prev, sym_ptr, srp, cb, ref)
			ptr,
	(base_list, offset_list, block_list, quick_list)
			ptr int static,
	vec		(0:5) fixed bin (18) int static,
	(max_n, min_n)	fixed bin int static,
	(sym_pos, sym_loc, prev_loc, i, k, j, jstart, delta, units)
			fixed bin (18),
	co		fixed bin (31),
	lgth		(0:6) fixed bin (16) int static init (1, 2, 4, 8, 16, 32, 64);
dcl	get_data		bit (1) aligned;
dcl	(n, dtype, inc)	fixed bin (18),
	next_offset	fixed bin (14),
	class		fixed bin (4);

dcl	max_token_length	fixed bin int static init (256),
						/* expected max length */
	1 tokens		(256 /* max_token_length */) int static,
	  2 first		unal bit (18),		/* offset of first token with this length */
	  2 last		unal bit (18);		/* offset of last token with this length */

dcl	(addr, addrel, bit, divide, fixed, max, min, null, rel, string, substr, subtract)
			builtin;

dcl	mst$block_nodes	entry (ptr, fixed bin (18)) returns (fixed bin (18)),
	mst$data_nodes	entry (ptr, fixed bin (18)) returns (fixed bin (18));
dcl	sym_sort_alphabetic$by_size
			entry (ptr, fixed bin);
dcl	create_list	entry (fixed bin) returns (ptr),
	e_v		entry (ptr, fixed bin (35), ptr, fixed bin (31), fixed bin) returns (bit (36) aligned),
	error		entry (fixed bin, ptr, ptr);

dcl	(
	ext_entry_in_type	init (26),
	ext_entry_out_type	init (27),
	int_entry_type	init (25),
	picture_type	init (63)
	)		fixed bin static;

dcl	reloc		(0:9) bit (36) aligned based;

dcl	1 acc		aligned based,
	  2 count		unal bit (9),
	  2 string	unal char (n);

dcl	1 record		based,
	  2 next		ptr,
	  2 ptr		ptr,			/* points at symbol for ptr base or offset area */
	  2 sym_loc	fixed bin;		/* location of symbol node */

%include pl1_tree_areas;
%include token_list;
%include block;
%include list;
%include operator;
%include statement;
%include token;
%include label;
%include symbol;
%include reference;
%include array;
%include nodes;
%include boundary;
%include declare_type;
%include token_types;
%include block_types;
%include op_codes;
%include system;
%include relbts;
%include reloc_lower;
%include runtime_symbol;
%include pl1_descriptor_type_fcn;

/* program */

	bp = pt;

	if bp = cg_static_$root
	then do;
		base_list, offset_list, block_list, quick_list = null;
		max_n = 1;
		min_n = 1000;

		do i = 1 to max_token_length;
		     tokens.first (i), tokens.last (i) = "0"b;
		end;
	     end;

	sym_pos = cg_static_$sym_pos;
	sym_ptr = addrel (cg_static_$sym_base, sym_pos);

	cg_static_$cur_block = bp;
	cg_static_$cur_level = bp -> block.level;

	if bp -> block.block_type = begin_block
	then goto b1;

	if bp -> block.main = null
	then goto b1;
	q = bp -> block.main -> statement.labels -> element (2) -> reference.symbol -> symbol.token;

	if q -> token.loc = "0"b
	then call make_acc;

	sym_ptr -> runtime_block.name = bit (fixed (262144 + (fixed (q -> token.loc, 18) - sym_pos), 18), 18);

b1:
	bp -> block.symbol_block = sym_pos;

	p = create_list (2);
	p -> element (2) = sym_ptr;
	p -> element (1) = block_list;
	block_list = p;

	sym_ptr -> runtime_block.flag = "1"b;
	sym_ptr -> runtime_block.standard = "1"b;
	sym_ptr -> runtime_block.quick = bp -> block.no_stack;

	if sym_ptr -> runtime_block.quick
	then do;
		sym_ptr -> runtime_block.entry_info = bit (bp -> block.entry_info, 18);
		q = bp -> block.owner;
		call make_record (quick_list);
	     end;

	sym_ptr -> runtime_block.fortran = cg_static_$compiler_name = "fortran";
	sym_ptr -> runtime_block.type = "011000"b;	/* 24 */
	sym_ptr -> runtime_block.header = bit (fixed (262144 - sym_pos, 18), 18);
	sym_ptr -> runtime_block.father = bit (fixed (262144 + (father - sym_pos), 18), 18);

	cg_static_$sym_pos = sym_pos + 10;
	if sym_ptr -> runtime_block.quick
	then cg_static_$sym_pos = cg_static_$sym_pos + 1;
	p = bp -> block.declaration;
	get_data = bp -> block.get_data;

	k = 0;
	do while (p ^= null);
	     q = p;

	     if p -> symbol.dcl_type = by_compiler
	     then goto step;

	     if p -> node.type = label_node
	     then if cg_static_$table_option
		then goto yes;
		else goto step;

	     if p -> symbol.cross_references = null & ^p -> symbol.allocate & ^get_data
	     then go to step;

	     if p -> symbol.builtin
	     then goto step;
	     if p -> symbol.condition
	     then goto step;

	     if p -> symbol.runtime ^= "0"b
	     then goto step;

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

	     if q -> symbol.entry & q -> symbol.external & q -> symbol.constant & q -> symbol.initial = null
	     then goto step;

	     if q -> symbol.put_in_symtab
	     then goto yes;
	     if get_data
	     then goto yes;
	     if ^cg_static_$table_option
	     then goto step;

/* we have to set the qualifier fields of all reference nodes
	        hanging from symbol nodes in a defined structure to point
	        to the base reference of the defined variable */

yes:
	     if q -> node.type = symbol_node
	     then if q -> symbol.defined
		then call set_qualifier (q, p -> symbol.reference -> reference.qualifier);

	     sym_loc = mst$data_nodes (q, sym_pos);

	     if sym_loc = 0
	     then goto step;

	     k = k + 1;
	     token_list (k) = q;

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

	if k = 0
	then goto do_son;

	call sym_sort_alphabetic$by_size (pl1_stat_$token_list_ptr, (k));

	prev = null;
	jstart = 1;

	do i = 1 to k;

	     p = token_list (i);
	     if p -> node.type = label_node
	     then sym_loc = fixed (p -> label.symbol_table, 18);
	     else sym_loc = fixed (p -> symbol.runtime, 18);

	     delta = sym_loc - sym_pos;

	     if prev = null
	     then sym_ptr -> runtime_block.start = bit (delta, 18);
	     else do;
		     n = sym_loc - prev_loc;
		     if n > 0
		     then prev -> runtime_symbol.brother = bit (fixed (n, 18), 18);
		     else prev -> runtime_symbol.brother = bit (fixed (262144 + n, 18), 18);
		end;

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

	     do j = jstart to 4;
		if n >= lgth (j)
		then if sym_ptr -> runtime_block.chain (j) = "0"b
		     then do;
			     jstart = j + 1;
			     sym_ptr -> runtime_block.chain (j) = bit (delta, 18);
			end;
	     end;

	     prev = addrel (cg_static_$sym_base, sym_loc);
	     prev_loc = sym_loc;

	end;

do_son:
	if bp -> block.son ^= null
	then sym_ptr -> runtime_block.son = bit (fixed (mst$block_nodes ((bp -> block.son), sym_pos) - sym_pos, 18), 18);

	if bp -> block.brother ^= null
	then sym_ptr -> runtime_block.brother =
		bit (fixed (mst$block_nodes ((bp -> block.brother), father) - sym_pos, 18), 18);

	if bp ^= cg_static_$root
	then goto thru;

/* make symbol table of based variable specify symbol table of variable
	   mentioned in the based(p) phrase */

	p = base_list;
	do while (p ^= null);
	     sym_loc = p -> record.sym_loc;
	     q = addrel (cg_static_$sym_base, sym_loc);

	     n = fixed (p -> record.ptr -> runtime, 18) - sym_loc;
	     if n >= 0
	     then q -> runtime_symbol.location = bit (fixed (n, 18), 18);
	     else q -> runtime_symbol.location = bit (fixed (262144 + n, 18), 18);

	     p = p -> record.next;
	end;

/* make size field in symbol table of offset variable specify symbol
	   table of variable mentioned in the offset(a) phrase */

	p = offset_list;
	do while (p ^= null);
	     sym_loc = p -> record.sym_loc;
	     addrel (cg_static_$sym_base, sym_loc) -> runtime_symbol.size =
		fixed (p -> record.ptr -> runtime, 18) - sym_loc;

	     p = p -> record.next;
	end;

/* link quick blocks to their owners */

	p = quick_list;
	do while (p ^= null);
	     sym_loc = p -> record.sym_loc;
	     q = addrel (cg_static_$sym_base, sym_loc);

	     q -> runtime_block.owner_flag = "1"b;

	     n = p -> record.ptr -> block.symbol_block - sym_loc;
	     if n >= 0
	     then q -> runtime_block.owner = bit (fixed (n, 18), 18);
	     else q -> runtime_block.owner = bit (fixed (262144 + n, 18), 18);

	     p = p -> record.next;
	end;

/* link together the fragments of the token list */

	i = min_n;

link:
	sym_loc = fixed (tokens.last (i), 18);
	p = addrel (cg_static_$sym_base, sym_loc);

	do j = i + 1 to max_n;
	     if tokens.first (j)
	     then do;
		     k = fixed (tokens.first (j), 18) - sym_loc;
		     if k >= 0
		     then p -> runtime_token.next = bit (k, 18);
		     else p -> runtime_token.next = bit (fixed (262144 + k, 18), 18);

		     i = j;
		     goto link;
		end;
	end;

/* set vec(i) to location of first token whose length n
	   is such that 2 ** i <= n < 2 ** (i+1) */

	vec (0), vec (1), vec (2), vec (3), vec (4), vec (5) = 0;

	do i = 0 to 5;
	     do j = lgth (i) to lgth (i + 1);
		if tokens.first (j)
		then do;
			vec (i) = fixed (tokens.first (j), 18);
			goto next_i;
		     end;
	     end;
next_i:
	end;

/* now set the token(i) field in all of the blocks we processed */

	p = block_list;
	do while (p ^= null);
	     q = p -> element (2);

	     sym_loc = fixed (rel (q), 18) - cg_static_$sym_origin;

	     do i = 0 to 5;
		if vec (i) ^= 0
		then do;
			k = vec (i) - sym_loc;
			if k >= 0
			then q -> runtime_block.token (i) = bit (k, 18);
			else q -> runtime_block.token (i) = bit (fixed (262144 + k, 18), 18);
		     end;
	     end;

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

thru:
	return (sym_pos);

mst$data_nodes:
     entry (pt, father) returns (fixed bin (18));

	p = pt;
	cb = cg_static_$cur_block;

	if p -> node.type = symbol_node
	then if p -> symbol.defined
	     then call check_defined (p -> symbol.equivalence);

	sym_pos = cg_static_$sym_pos;
	sym_ptr = addrel (cg_static_$sym_base, sym_pos);

	q = p -> symbol.token;
	if q -> token.loc = "0"b
	then call make_acc;

	k = fixed (q -> token.loc, 18);
	sym_ptr -> runtime_symbol.name = bit (fixed (262144 + k - sym_pos, 18), 18);

	p1 = addrel (cg_static_$sym_base, k - 1);
	if p1 -> runtime_token.dcl
	then do;
		next_offset =
		     16384 + fixed (rel (addrel (p1, p1 -> runtime_token.dcl)), 18) - cg_static_$sym_origin - sym_pos;
		if next_offset > 0
		then sym_ptr -> runtime_symbol.next = bit (fixed (next_offset, 14), 14);
		else call error (366, null, p);
	     end;
	p1 -> runtime_token.dcl = bit (fixed (sym_pos - k + 1, 18), 18);

	sym_ptr -> runtime_symbol.father = bit (fixed (262144 + (father - sym_pos), 18), 18);

	sym_ptr -> runtime_symbol.flag = "1"b;

	srp = addrel (cg_static_$sym_reloc_base, sym_pos);

	if p -> node.type = label_node
	then goto lab;

	p -> runtime = bit (sym_pos, 18);

	sym_ptr -> runtime_symbol.level = bit (fixed (p -> symbol.level, 6), 6);

	sym_ptr -> runtime_symbol.aligned = p -> symbol.aligned;
	sym_ptr -> runtime_symbol.packed = p -> symbol.packed | p -> symbol.explicit_packed;
	if p -> symbol.scale >= 0
	then sym_ptr -> runtime_symbol.scale = bit (fixed (p -> symbol.scale, 8), 8);
	else sym_ptr -> runtime_symbol.scale = bit (fixed (256 + p -> symbol.scale, 8), 8);

	if ^p -> symbol.entry
	then if p -> symbol.picture
	     then do;
		     sym_ptr -> runtime_symbol.size = p -> symbol.general -> reference.symbol -> symbol.location;
		     srp -> reloc (4) = rc_a_t;
		end;
	     else if p -> symtab_size = null
	     then sym_ptr -> runtime_symbol.size = p -> symbol.c_dcl_size;
	     else srp -> reloc (4) = e_v (p, sym_ptr -> runtime_symbol.size, (p -> symtab_size), 0, 1);

	ref = p -> symbol.reference;

	if p -> symbol.picture
	then dtype = picture_type;

	else if p -> symbol.entry & p -> symbol.constant
	then if p -> symbol.external
	     then if p -> symbol.initial ^= null
		then dtype = ext_entry_in_type;
		else dtype = ext_entry_out_type;
	     else dtype = int_entry_type;

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

		if p -> symbol.offset
		then do;
			q = p -> symbol.general;
			if q ^= null
			then if q -> node.type = reference_node
			     then if q -> reference.offset = null
				then do;
					q = q -> reference.symbol;
					call make_record (offset_list);
				     end;
		     end;
	     end;

	p2 = p;

	if p2 -> symbol.defined
	then do;

/* defined ok, change so actually encode storage class of
	        base reference */

		p2 = ref -> reference.qualifier -> reference.symbol;
		ref = p2 -> symbol.reference;
	     end;

	if p2 -> symbol.auto
	then do;

		if ref -> reference.qualifier = null
		then class = 1;
		else do;
			class = 2;
			p2 = ref -> reference.qualifier -> reference.symbol;
		     end;

		goto l2c;
	     end;

	if p2 -> symbol.based
	then do;
		class = 3;

		q = ref -> reference.qualifier;
		if q = null
		then goto l2;

		if q -> node.type = reference_node
		then do;
			if q -> reference.offset ^= null
			then goto l2;

			q = q -> reference.symbol;
			if q -> symbol.cross_references ^= null
			then call make_record (base_list);
		     end;

		goto l2;
	     end;

	if p2 -> symbol.parameter
	then do;

		if ref -> reference.qualifier -> node.type = operator_node
		then do;
			class = 9;
			if p2 -> symbol.father ^= null
			then p2 -> symbol.location = p2 -> symbol.father -> symbol.location;
		     end;
		else do;
			class = 8;
			p2 = ref -> reference.qualifier -> reference.symbol;
		     end;

		goto l2c;
	     end;

	if p2 -> symbol.static
	then do;
static:
		if p2 -> symbol.external
		then srp -> reloc (3) = rc_lp18;
		else srp -> reloc (3) = rc_is18;
		class = 4 + fixed (p2 -> symbol.external, 1);
		goto l2c;
	     end;

	if p2 -> symbol.constant
	then do;
		if p2 -> symbol.file
		then goto static;

		class = 12;
		goto l2c;
	     end;

	if p2 -> symbol.controlled
	then do;
		class = 6 + fixed (p2 -> symbol.external, 1);
		goto l2c;
	     end;

	class = 0;

l2c:
	sym_ptr -> runtime_symbol.location = bit (fixed (p2 -> symbol.location, 18), 18);
l2:
	sym_ptr -> runtime_symbol.class = bit (class, 4);

	ref = p -> symbol.reference;

	if class = 12
	then srp -> reloc (3) = rc_t;			/* text relocation */

	p2 = ref -> reference.offset;
	co = ref -> reference.c_offset;

	units = ref -> reference.units;
	if units = 0
	then goto ec;

	if units = word_
	then do;
		units = 0;
		goto ec;
	     end;

	if p2 = null
	then goto ec;

	if p2 -> node.type ^= operator_node
	then goto ec;

	if p2 -> op_code = mod_bit
	then goto elim;
	if p2 -> op_code = mod_byte
	then goto elim;
	if p2 -> op_code ^= mod_half
	then goto ec;

elim:
	p2 = p2 -> operand (3);

ec:
	if p2 = null
	then sym_ptr -> runtime_symbol.offset = co;
	else srp -> reloc (5) = e_v (p, sym_ptr -> runtime_symbol.offset, p2, co, 2);

	call encode_runtime_units (sym_ptr -> runtime_symbol.units, sym_ptr -> runtime_symbol.use_digit, units);

	q = p -> symbol.array;

	if q = null
	then do;
		if sym_ptr -> runtime_symbol.offset = 0
		then do;
			sym_ptr -> runtime_symbol.simple = "1"b;
			inc = 5;
		     end;
		else inc = 6;
		goto l3;
	     end;

	units = q -> array.offset_units;
	if units = word_
	then units = 0;

	call encode_runtime_units (sym_ptr -> runtime_symbol.array_units, sym_ptr -> runtime_symbol.use_digit, units);

	sym_ptr -> runtime_symbol.ndims = bit (fixed (q -> number_of_dimensions, 6), 6);
	inc = 7 + 3 * q -> number_of_dimensions;

	p2 = q -> symtab_virtual_origin;
	if p2 = null
	then sym_ptr -> runtime_symbol.virtual_org = q -> c_virtual_origin;
	else srp -> reloc (6) = e_v (p, sym_ptr -> virtual_org, p2, (q -> c_virtual_origin), 3);

	p2 = addr (sym_ptr -> runtime_symbol.bounds (q -> number_of_dimensions));
	i = inc - 1;
	q = q -> array.bounds;

	do while (q ^= null);

	     if q -> symtab_lower = null
	     then p2 -> runtime_bound.lower = q -> c_lower;
	     else srp -> reloc (i - 2) = e_v (p, p2 -> runtime_bound.lower, (q -> symtab_lower), 0, 4);

	     if q -> symtab_upper = null
	     then p2 -> runtime_bound.upper = q -> c_upper;
	     else srp -> reloc (i - 1) = e_v (p, p2 -> runtime_bound.upper, (q -> symtab_upper), 0, 5);

	     if q -> c_multiplier ^= 0
	     then p2 -> runtime_bound.multiplier = q -> c_multiplier;
	     else if q -> symtab_multiplier = null
	     then call error (339, null, p);
	     else srp -> reloc (i) = e_v (p, p2 -> runtime_bound.multiplier, (q -> symtab_multiplier), 0, 6);

	     p2 = addrel (p2, -3);
	     q = q -> bound.next;
	     i = i - 3;

	end;

l3:
	cg_static_$sym_pos = sym_pos + inc;

	sym_ptr -> runtime_symbol.type = bit (fixed (dtype, 6), 6);

	q = p -> symbol.son;
	if q = null
	then goto done;

	prev_loc = mst$data_nodes (q, sym_pos);
	sym_ptr -> runtime_symbol.son = bit (fixed (prev_loc - sym_pos, 18), 18);

	q = q -> symbol.brother;
	do while (q ^= null);
	     sym_loc = mst$data_nodes (q, sym_pos);
	     addrel (cg_static_$sym_base, prev_loc) -> runtime_symbol.brother = bit (fixed (sym_loc - prev_loc, 18), 18);
	     prev_loc = sym_loc;
	     q = q -> symbol.brother;
	end;

done:
ret:
	return (sym_pos);

defined_error:
	call error (306, null, p);
	return (0);

/* have label node */

lab:
	p -> label.symbol_table = bit (sym_pos, 18);
	sym_ptr -> runtime_symbol.type = "011000"b;	/* label constant */

	if p -> label.array
	then do;
		inc = 10;
		sym_ptr -> runtime_symbol.ndims = "000001"b;
		sym_ptr -> runtime_symbol.location = bit (fixed (p -> label.location, 18), 18);

		sym_ptr -> runtime_symbol.virtual_org, sym_ptr -> runtime_symbol.bounds (1).lower = p -> label.low_bound;
		sym_ptr -> runtime_symbol.bounds (1).upper = p -> label.high_bound;
		sym_ptr -> runtime_symbol.bounds (1).multiplier = 1;
	     end;
	else do;
		inc = 4;
		sym_ptr -> runtime_symbol.simple = "1"b;
	     end;

	sym_ptr -> runtime_symbol.class = "1100"b;
	srp -> reloc (3) = rc_t;

	cg_static_$sym_pos = sym_pos + inc;

	goto ret;

make_record:
     proc (list_head);

dcl	list_head		ptr;

dcl	tp		ptr;

	allocate record in (tree_area) set (tp);
	tp -> record.next = list_head;
	list_head = tp;

	tp -> record.sym_loc = sym_pos;
	tp -> record.ptr = q;
     end;

set_qualifier:
     proc (sym_pt, qual);

dcl	sym_pt		ptr,			/* points at symbol node */
	qual		ptr unal;			/* points at reference node*/

dcl	sp		ptr;

	sp = sym_pt;
	do while (sp ^= null);
	     sp -> symbol.reference -> reference.qualifier = qual;
	     if sp -> symbol.son ^= null
	     then call set_qualifier ((sp -> symbol.son), qual);

	     sp = sp -> symbol.brother;
	end;

     end;

check_defined:
     proc (tree_in);

dcl	tree_in		ptr unal,
	tree		ptr,
	i		fixed bin;

	tree = tree_in;

	if tree = null
	then return;

	if tree -> node.type = operator_node
	then do i = 1 to tree -> operator.number;
		call check_defined (tree -> operand (i));
	     end;

	else if tree -> node.type = list_node
	then do i = 1 to tree -> list.number;
		call check_defined (tree -> element (i));
	     end;

	else if tree -> node.type = reference_node
	then call check_defined (tree -> reference.offset);

	else if tree -> node.type = token_node
	then do;
		if tree -> token.type = asterisk
		then goto defined_error;
		if tree -> token.type = isub
		then goto defined_error;
	     end;

     end;

make_acc:
     proc;

dcl	k		fixed bin (18),
	(tp1, tp2, tp3)	ptr;

/* this procedure is called to add a token to the list of tokens being
	        maintained in the symbol buffer. tokens.first(n) specifies the first
	       token on the list of tokens of size n, tokens.last(n) specifies
	       the last token on the list */

	n = q -> token.size;
	min_n = min (n, min_n);
	max_n = max (n, max_n);

	tp1 = addrel (sym_ptr, 1);
	tp1 -> acc.string = q -> token.string;
	tp1 -> acc.count = bit (fixed (n, 9), 9);

	q -> token.loc = bit (fixed (sym_pos + 1, 18), 18);

	if tokens.first (n) = (18)"0"b
	then do;
		tokens.first (n), tokens.last (n) = bit (sym_pos, 18);
		goto bump;
	     end;

	tp2 = null;
	tp3 = addrel (cg_static_$sym_base, tokens.first (n));
	do while (tp3 ^= null);
	     if addrel (tp3, 1) -> acc.string > tp1 -> acc.string
	     then do;
		     if tp2 = null
		     then tokens.first (n) = bit (sym_pos, 18);
		     else do;
			     k = sym_pos - fixed (rel (tp2), 18) + cg_static_$sym_origin;
			     if k >= 0
			     then tp2 -> runtime_token.next = bit (k, 18);
			     else tp2 -> runtime_token.next = bit (fixed (262144 + k, 18), 18);
			end;

		     k = fixed (rel (tp3), 18) - cg_static_$sym_origin - sym_pos;
		     if k >= 0
		     then sym_ptr -> runtime_token.next = bit (k, 18);
		     else sym_ptr -> runtime_token.next = bit (fixed (262144 + k, 18), 18);

		     goto bump;
		end;

	     tp2 = tp3;
	     if tp3 -> runtime_token.next
	     then tp3 = addrel (tp3, tp3 -> runtime_token.next);
	     else tp3 = null;
	end;

/* new token belongs at end of list */

	tokens.last (n) = bit (sym_pos, 18);
	k = sym_pos - fixed (rel (tp2), 18) + cg_static_$sym_origin;
	if k >= 0
	then tp2 -> runtime_token.next = bit (k, 18);
	else tp2 -> runtime_token.next = bit (fixed (262144 + k, 18), 18);

/* update position in symbol buffer by number of words in string plus 1 */

bump:
	k = divide (n + 4, 4, 17, 0) + 1;
	sym_ptr = addrel (sym_ptr, k);
	sym_pos = sym_pos + k;

     end;						/* Convert internal encoding of offset units to external (runtime symbol table) encoding */

encode_runtime_units:
     procedure (runtime_units, half_really_digit, internal_units);

/* parameters */

dcl	runtime_units	bit (2) unaligned;
dcl	half_really_digit	bit (1) unaligned;
dcl	internal_units	fixed bin (18);

	if internal_units <= bit_
	then runtime_units = bit (fixed (internal_units, 2), 2);
	else if internal_units = digit_
	then do;
		runtime_units = bit (fixed (character_, 2), 2);
		half_really_digit = "1"b;		/* External encoding of half_
						   is numerically equal to the internal encoding of char_ */
	     end;
	else runtime_units = bit (subtract (internal_units, 1, 2, 0), 2);

     end /* encode_runtime_units */;

     end /* mst */;




		    name_assign.pl1                 10/03/83  1730.5rew 10/03/83  1009.0       17073



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

name_assign: proc(name) returns(bit(18) aligned);

dcl	name char(*) aligned,
	(n,def_pos) fixed bin(18),
	(p,q) ptr;

dcl	create_list entry(fixed bin) returns(ptr);

dcl	(addrel,divide,fixed,length,null,rel) builtin;

dcl	(cg_static_$name_list,cg_static_$def_base) ptr ext,
	(cg_static_$def_origin,cg_static_$def_pos) fixed bin(18) ext;

dcl	1 name_mask	aligned based,
	2 count		unal bit(9),
	2 string		unal char(n);

%include list;

	p = cg_static_$name_list;

	do while(p ^= null);

	     q = p -> list.element(2);

	     n = fixed(q -> count,9);
	     if length(name) = n
	     then if name = q -> string
		then do;
		     def_pos = fixed(rel(q),18) - cg_static_$def_origin;
		     goto ret;
		     end;

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

	n = length(name);
	p = create_list(2);

	p -> list.element(1) = cg_static_$name_list;
	cg_static_$name_list = p;

	def_pos = cg_static_$def_pos;
	p -> list.element(2), q = addrel(cg_static_$def_base,def_pos);

	q -> count = bit(fixed(n,9),9);
	q -> string = name;

	cg_static_$def_pos = def_pos + divide(n+4,4,17,0);

ret:	return(bit(def_pos,18));

	end;




		    need_temp.pl1                   10/03/83  1730.5rew 10/03/83  1009.0       17397



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


need_temp:	proc(pt,bit2);

/*	Modified:	9 April 1977 by RAB to remove mod_word operator	*/

dcl	(o,p,pt,q) ptr;
dcl	bit2 bit(2) aligned;
dcl	(check_length, check_qual_and_off) bit(1) aligned;
dcl	(null,substr) builtin;

%include operator;
%include reference;
%include nodes;


/* need_temp is called by expmac when pt has a reference count of 1 to try to prevent
   unnecessary saving of temporary values whose reference counts are momentarily to be
   counted down to zero */

	p = pt;
	check_qual_and_off = substr(bit2,1,1);
	check_length = substr(bit2,2,1);

	if check_length
	then do;
	     if p ->reference.value_in.string_aq
		then p -> reference.dont_save = "1"b;
	     q = p -> reference.length;
	     if q ^= null
	     then do;
		if q -> node.type = operator_node
		     then q = q -> operand(1);
		call check;
		end;
	     end;

	if ^ check_qual_and_off then return;

	q = p -> reference.qualifier;
	if q ^= null
	then do;
	     if q -> node.type = operator_node
		then q = q -> operand(1);
	     if q -> node.type = reference_node
		then call check;
	     end;

	q = p -> reference.offset;
	if q = null then return;

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

	call check;

check:	proc;

	if q -> reference.shared then return;
	if q -> reference.dont_save then return;
	if q -> reference.ref_count ^= 1 then return;
	q -> reference.dont_save = "1"b;
	call need_temp(q,"11"b);
end;

end;




		    opcode_info.alm                 10/03/83  1730.5rew 10/03/83  1009.0       66672



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

"
" Modified 770617 by PG to add clock, vclock, and stacq.
" Modified 780329 by PCK to add stackframeptr, stackbaseptr, environmentptr, & codeptr builtins
" Modified 780828 by PG to delete pos_dif_fun
" Modified 25 Apr 1979 by PCK to implement 4-bit decimal.  digit_to_bit was added.
" Modified 25 Jul 1979 by PCK to implement rank and byte builtins.
" Modified 790807 by PG to delete jump_three_way.
" Modified 820726 BIM wordno, segno
"
" Format of opcode_info entries:
"
" dcl	1 op_info		aligned based,
"	2 action1		bit (6) unal,
"	2 action2		bit (6) unal,
"	2 macro		bit (18) unal,
"	2 delta		bit (2) unal,
"	2 call_code	bit (4) unal;
"
"
	name	opcode_info
	segdef	opcode_info
	segdef	last_opcode
	segdef	table
"
opcode_info:
"
class_0:
class_1:
	vfd	6/5		zero opcode
	vfd	6/3,6/1		add
	vfd	6/3,6/1		sub
	vfd	6/3,6/1		mult
	vfd	6/3,6/1		div
	vfd	6/3,6/1		negate
	vfd	6/3,6/2		exp
"
class_2:
	vfd	6/5		unused
	vfd	6/3,6/3		and_bits
	vfd	6/3,6/3		or_bits
	vfd	6/3,6/3		xor_bits
	vfd	6/3,6/3		not_bits
	vfd	6/3,6/14		cat_string
	vfd	6/3,6/33,18/470	bool_fun
"
class_3:
	vfd	6/5		unused
	vfd	6/1		assign
	vfd	6/1		assign_size_ck
	vfd	6/3,6/18,18/308	assign_zero
	vfd	6/4		copy_words
	vfd	6/4		copy_string
	vfd	6/4		make_desc
	vfd	6/1		assign_round
	vfd	6/1		pack
	vfd	6/1		unpack
"
class_4:
	vfd	6/5		unused
	vfd	6/5		unused
	vfd	6/5		unused
	vfd	6/5		unused
	vfd	6/3,6/4		less_than
	vfd	6/3,6/4		greater_than
	vfd	6/3,6/4		equal
	vfd	6/3,6/4		not_equal
	vfd	6/3,6/4		less_or_equal
	vfd	6/3,6/4		greater_or_equal
"
class_5:
	vfd	6/5		unused
	vfd	6/4		jump
	vfd	6/4		jump_true
	vfd	6/4		jump_false
	vfd	6/4		jump_if_lt
	vfd	6/4		jump_if_gt
	vfd	6/4		jump_if_eq
	vfd	6/4		jump_if_ne
	vfd	6/4		jump_if_le
	vfd	6/4		jump_if_ge
"
class_6:
	vfd	6/5		unused
	vfd	6/4		std_arg_list
	vfd	6/4		unused
	vfd	6/4		std_call
	vfd	6/4		unused
	vfd	6/4		std_entry
	vfd	6/4		unused
	vfd	6/4		ex_prologue
	vfd	6/4		allot_auto
	vfd	6/6		param_ptr
	vfd	6/6		param_desc_ptr
	vfd	6/4		std_return
	vfd	6/4		allot_ctl
	vfd	6/4		free_ctl
"
class_7:
	vfd	6/5		mod_bit
	vfd	6/5		mod_byte
	vfd	6/5		mod_half
	vfd	6/4		mod_word
"
class_8:
	vfd	6/3,6/6,18/108	bit_to_char
	vfd	6/3,6/6,18/109	bit_to_word
	vfd	6/3,6/6,18/112	char_to_word
	vfd	6/3,6/6,18/404	half_to_word
	vfd	6/3,6/6,18/116	word_to_mod2
	vfd	6/3,6/6,18/117	word_to_mod4
	vfd	6/3,6/6,18/118	word_to_mod8
	vfd	6/3,6/5,18/1	rel_fun
	vfd	6/3,6/5,18/10	baseno_fun
	vfd	6/3,6/19,18/284	desc_size
	vfd	6/5		bit_pointer
	vfd	6/3,6/15		index_before_fun
	vfd	6/3,6/15		index_after_fun
	vfd	6/3,6/25,18/710	verify_ltrim_fun
	vfd	6/3,6/25,18/711	verify_rtrim_fun
	vfd	6/3,6/6,18/738	digit_to_bit
"
class_9:
	vfd	6/3,6/20,18/522,2/0,4/6	ceil_fun	01001 0000
	vfd	6/3,6/20,18/525,2/0,4/7	floor_fun	      0001
	vfd	6/3,6/22,18/529,2/0,4/8	round_fun	      0010
	vfd	6/3,6/31,18/209,2/0,4/9	sign_fun	      0011
	vfd	6/3,6/7,18/0,2/0,4/10	abs_fun	      0100
	vfd	6/3,6/8,18/520,2/0,4/11	trunc_fun	      0101
	vfd	6/3,6/37			byte_fun	      0110
	vfd	6/3,6/38			rank_fun	      0111
	vfd	6/3,6/15,18/256		index_rev_fun   1000
	vfd	6/3,6/25,18/369		search_rev_fun  1001
	vfd	6/3,6/25,18/368		verify_rev_fun  1010
          vfd       6/3,6/5,18/2		wordno_fun      1011
	vfd	6/3,6/5,18/9		segno_fun       1100
	vfd	6/3,6/5,18/4		bitno_fun	      1101
	vfd	6/3,6/5,18/3		charno_fun      1110
"
class_10:
	vfd	6/3,6/15		index_fun
	vfd	6/3,6/17		off_fun
	vfd	6/3,6/29,18/399,2/0,4/9	complex_fun
	vfd	6/3,6/29,18/400,2/0,4/11	conjg_fun
	vfd	6/3,6/9,18/387,2/1	mod_fun
	vfd	6/3,6/24,18/534	repeat_fun
	vfd	6/3,6/25,18/539	verify_fun
	vfd	6/3,6/26,18/104	translate_fun
	vfd	6/4		unused
	vfd	6/3,6/30,18/401,2/0,4/6	real_fun
	vfd	6/3,6/30,18/402,2/0,4/7	imag_fun
	vfd	6/3,6/16		length_fun
	vfd	6/3,6/21,18/271,2/0,4/12	pl1_mod_fun
	vfd	6/3,6/25,18/540	search_fun
	vfd	6/3,6/32,18/614	allocation_fun
	vfd	6/3,6/24,18/547	reverse_fun
"
class_11:
	vfd	6/6		addr_fun
	vfd	6/6		addr_fun_bits
	vfd	6/6		ptr_fun
	vfd	6/6		baseptr_fun
	vfd	6/6		addrel_fun
	vfd	6/6		codeptr_fun
	vfd	6/6		environmentptr_fun
	vfd	6/6		stackbaseptr_fun
	vfd	6/6		stackframeptr_fun
	vfd	6/6,6/1		setcharno_fun
	vfd	6/6,6/2		addcharno_fun
	vfd	6/6,6/3		setbitno_fun
	vfd	6/6,6/4		addbitno_fun
"
class_12:
	vfd	6/2		min_fun
	vfd	6/2		max_fun
"
class_13:
	vfd	6/4		unused
	vfd	6/3,6/18,18/533	stack_ptr
	vfd	6/4		empty_area
	vfd	6/5		unused
	vfd	6/4		enable_on
	vfd	6/4		revert_on
	vfd	6/4		signal_on
	vfd	6/3,6/27,18/208	lock_fun
	vfd	6/3,6/35,18/722	stacq_fun
	vfd	6/3,6/36,18/723	clock_fun
	vfd	6/3,6/36,18/724	vclock_fun
"
class_14:
	vfd	6/3,6/10,18/246	bound_ck
	vfd	6/3,6/10,18/263	range_ck
	vfd	6/4		loop
	vfd	6/4		join
	vfd	6/4		allot_based
	vfd	6/4		free_based
"
class_15:
	vfd	6/5		unused
	vfd	6/4		r_parn
	vfd	6/4		l_parn
	vfd	6/4		r_format
	vfd	6/4		c_format
	vfd	6/4		f_format
	vfd	6/4		e_format
	vfd	6/4		b_format
	vfd	6/4		a_format
	vfd	6/4		x_format
	vfd	6/4		skip_format
	vfd	6/4		column_format
	vfd	6/4		page_format
	vfd	6/4		line_format
	vfd	6/4		bn_format
"
class_16:
	vfd	6/4		get_list_trans
	vfd	6/4		get_edit_trans
	vfd	6/4		get_data_trans
	vfd	6/4		put_list_trans
	vfd	6/4		put_edit_trans
	vfd	6/4		put_data_trans
	vfd	6/4		terminate_trans
	vfd	6/4		stream_prep
	vfd	6/4		record_io
	vfd	6/4		fortran_read
	vfd	6/4		fortran_write
	vfd	6/4		ftn_file_manip
	vfd	6/4		ftn_trans_loop
	vfd	6/4		put_control
	vfd	6/4		put_field
	vfd	6/4		put_field_chk
"
class_17:
	vfd	6/5		unused
	vfd	6/4		return_value
	vfd	6/4		allot_var
	vfd	6/4		free_var
	vfd	6/4		get_file
	vfd	6/4		get_string
	vfd	6/4		put_file
	vfd	6/4		put_string
	vfd	6/4		open_file
	vfd	6/4		close_file
	vfd	6/4		read_file
	vfd	6/4		write_file
	vfd	6/4		locate_file
	vfd	6/4		do_fun
	vfd	6/4		do_spec
"
class_18:
	vfd	6/4		rewrite_file
	vfd	6/4		delete_file
	vfd	6/4		unlock_file
	vfd	6/4		lock_file
	vfd	6/4		unused
	vfd	6/4		refer
	vfd	6/4		prefix_plus
	vfd	6/4		nop
"
class_19:
	vfd	6/3,6/34,18/94	sqrt_fun
	vfd	6/3,6/34,18/227	sin_fun
	vfd	6/3,6/34,18/265	sind_fun
	vfd	6/3,6/34,18/329	cos_fun
	vfd	6/3,6/34,18/336	cosd_fun
	vfd	6/3,6/34,18/342	tan_fun
	vfd	6/3,6/34,18/422	tand_fun
	vfd	6/3,6/34,18/424	asin_fun
	vfd	6/3,6/34,18/426	asind_fun
	vfd	6/3,6/34,18/428	acos_fun
	vfd	6/3,6/34,18/430	acosd_fun
	vfd	6/3,6/34,18/432	atan_fun
	vfd	6/3,6/34,18/434	atand_fun
	vfd	6/3,6/34,18/477	log2_fun
	vfd	6/3,6/34,18/482	log_fun
	vfd	6/3,6/34,18/496	log10_fun
"
class_20:
	vfd	6/3,6/34,18/500	exp_fun
"
last_opcode:
	vfd	36/*		all of opcode_info before this line
"
table:
	zero	0,class_0-class_0
	zero	0,class_1-class_0
	zero	0,class_2-class_0
	zero	0,class_3-class_0
	zero	0,class_4-class_0
	zero	0,class_5-class_0
	zero	0,class_6-class_0
	zero	0,class_7-class_0
	zero	0,class_8-class_0
	zero	0,class_9-class_0
	zero	0,class_10-class_0
	zero	0,class_11-class_0
	zero	0,class_12-class_0
	zero	0,class_13-class_0
	zero	0,class_14-class_0
	zero	0,class_15-class_0
	zero	0,class_16-class_0
	zero	0,class_17-class_0
	zero	0,class_18-class_0
	zero	0,class_19-class_0
	zero	0,class_20-class_0
"
	end




		    optimize_if.pl1                 10/03/83  1730.5rew 10/03/83  1009.1       91386



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


/* procedure to optimize an if statement

   Initial Version:	1 November 1975 by RAB
	Modified:	1 July 1976 by RAB for label array improvements
	Modified:	23 Jan 1977 by RAB to make recursive for combine_tests
	Modified:	9 Mar 1977 by RAB to remove some dead code
	Modified:	12 March 1977 by RAB to change handling of mod_word
	Modified:	9 April 1977 by RAB to remove mod_word	*/

/* if statements are optimized by changing boolean operations into jumps.
   Among the transformations performed are:

   jump_true(target,or_bits(a,b)) -> jump_true(target,a), jump_true(target,b)

   jump_true(target,and_bits(a,b)) -> jump_false(next,a), jump_true(target,b)

   jump_true(target,not_bits(a)) -> jump_false(target,a)

   jump_false(target,and_bits(a,b)) -> jump_false(target,a), jump_false(target,b)

   jump_false(target,or_bits(a,b)) -> jump_true(next,a), jump_false(target,b)

   jump_false(target,not_bits(a)) -> jump_true(target,a)

   These transformations are not performed if the boolean operators have already
   been evaluated or if their values are needed later on */

optimize_if:	proc(pt);

dcl	pt ptr;	/* points at statement being optimized */

dcl	(jop,lp,next,nextlab,p3,st,target,tree,next_tree) ptr;
dcl	(jump_code,op_code) bit(9) aligned;

dcl	(cg_stat$cur_block,pl1_stat_$cur_statement) ptr ext static;
dcl	cg_stat$cur_level fixed bin ext static;

dcl (	rel_op		init("00100"b),
	jump_op		init("00101"b)
			) bit(5) aligned int static;

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

dcl	create_list entry(fixed bin) returns(ptr);
dcl	create_label entry(ptr,ptr,bit(3) aligned) returns(ptr);
dcl	create_operator entry(bit(9) aligned,fixed bin(15)) returns(ptr);
dcl	create_statement entry(bit(9) aligned,ptr,ptr,bit(12) aligned) returns(ptr);
dcl	share_expression entry(ptr) returns(ptr);
dcl	jump_op$eval_primaries entry(ptr);
dcl	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
dcl	compile_exp entry(ptr);

%include nodes;
%include block;
%include statement;
%include statement_types;
%include label;
%include declare_type;
%include list;
%include reference;
%include operator;
%include op_codes;
%include jump_complement;
%include machine_state;

	st = pt;
	jop = st -> statement.root;

	if ^ st -> statement.checked
	then do;
	     target = jop -> operand(1);

	     if target -> node.type = label_node
	     then if ^ target -> label.allocated
		then if cg_stat$cur_level = target -> label.block_node -> block.level
		     then call jump_op$eval_primaries(target);
		     else;
		else;
	     else do;

		/* operator_semantics has ensured that the target of a
		   conditional jump will not be an operator nor a reference
	  	   with expressions hanging off it, so that calling
		   check_expr for the target is unnecessary */

		if target -> node.type = reference_node
		then if target -> reference.symbol ^= null
		     then if target -> reference.symbol -> node.type = label_node
			then if target -> reference.symbol -> label.block_node = cg_stat$cur_block
			     then call jump_op$eval_primaries(target);
		end;

	     call check_expr((jop -> operand(2)));
	     st -> statement.checked = "1"b;
	     end;


	do while("1"b);
	     tree = jop -> operand(2);

	     if tree -> node.type ^= operator_node then return;
	     if tree -> operand(1) -> reference.evaluated then return;
	     if tree -> operand(1) -> reference.c_length ^= 1 then return;

	     jump_code = jop -> operator.op_code;
	     op_code = tree -> operator.op_code;

	     if op_code = not_bits
	     then do;

		/* not - complement the type of jump */

		jop -> operator.op_code = jump_complement(fixed(substr(jump_code,6,4),4));
		jop -> operand(2) = tree -> operand(2);
		end;

	     else if substr(op_code,1,5) = rel_op
	     then do;

		/* rel_op - change into a jump_rel and return */

		if jump_code = jump_true
		     then substr(tree -> operator.op_code,1,5) = jump_op;
		     else tree -> operator.op_code = jump_complement(fixed(substr(op_code,6,4),4));

		tree -> operand(1) = jop -> operand(1);
		st -> statement.root = tree;
		return;
		end;

	     else if op_code = and_bits | op_code = or_bits
	     then do;

		/* or_bits | and_bits - split into 2 statements */

		if machine_state.indicators = 1
		then do;

		     /* if result of second computation is in a with
		        indicators set, do that one first */

		     p3 = tree -> operand(3);
		     if p3 -> node.type = operator_node
			then p3 = p3 -> operand(1);

		     if p3 -> reference.value_in.a & p3 -> reference.allocate
		     then do;
			p3 = tree -> operand(3);
			tree -> operand(3) = tree -> operand(2);
			tree -> operand(2) = p3;
			end;
		     end;

		if op_code = and_bits & jump_code = jump_false
		 | op_code = or_bits & jump_code = jump_true
		then do;

		     /* simply duplicate the statement */

		     call make(/* jump_code,target,tree -> operand(3) */);

		     jop -> operand(2) = tree -> operand(2);

		     target = jop -> operand(1);
		     if target -> node.type = label_node
			then target -> label.statement -> statement.reference_count =
			     target -> label.statement -> statement.reference_count + 1;
			else target = share_target_expression(target);
		     end;

	          else do;

		     /* make a second statement; reverse the form of
		        the first statement and redirect to the next
		        statement */

		     next = st -> statement.next;

		     call make(/* jump_code,target,tree -> operand(3) */);

		     jop -> operand(2) = tree -> operand(2);

		     if jump_code = jump_true
			then jop -> operator.op_code = jump_false;
			else jop -> operator.op_code = jump_true;

		     nextlab = create_label(cg_stat$cur_block,null,(by_compiler));
		     lp = create_list(2);

		     /* connect nextlab to next stmt */

		     jop -> operand(1) = nextlab;
		     nextlab -> label.statement = next;

		     lp -> element(2) = nextlab;
		     lp -> element(1) = next -> statement.labels;
		     next -> statement.labels = lp;

		     string(nextlab -> label.source_id) = string(next -> statement.source_id);

		     /* reference_count updated once for new reference and once for new label */

		     next -> statement.reference_count = next -> statement.reference_count + 2;

		     /* optimizer didn't know about this label, so make sure all temps
		        are saved before anyone jumps here */

		     next -> statement.save_temps = "1"b;
		     end;

		next_tree = st -> statement.next -> statement.root;

		if next_tree -> operand(2) -> node.type = operator_node
		then if ^ next_tree -> operand(2) -> operand(1) -> reference.evaluated
		then if next_tree -> operand(2) -> operand(1) -> reference.c_length = 1
		then call optimize_if((st -> statement.next));

		end;

	     else return;

	     end;

/*  */
make:	     proc(/* op_code,target,expr */);

	     /* make a new if statement */

dcl	     (new,op) ptr;

	     pl1_stat_$cur_statement = st;	/* otherwise create_statement fails */

	     new = create_statement((if_statement),st,null,(st -> statement.prefix));
	     op = create_operator((jump_code),2);

	     new -> statement.generated,
	     new -> statement.checked = "1"b;
	     new -> statement.root = op;

	     op -> operand(1) = jop -> operand(1);
	     op -> operand(2) = tree -> operand(3);

	     end;
/**/
share_target_expression: proc(p) returns(ptr);

	     /* updates all relevant reference counts when a jump target is
	        NOT a label (it might be a subscripted label reference)
	        Note, however, that operator_semantics has ensured that the
	        target of a conditional jump will not be an operator nor a
	        reference with expressions hanging off it. */

dcl	     (p,q,vector) ptr;
dcl	     i fixed bin;

	     if p -> reference.symbol ^= null
	     then if p -> reference.symbol -> node.type = label_node
	     then do;
		vector = p -> reference.symbol -> label.statement;

		q = vector -> element(p -> reference.c_offset + 1);
		q -> statement.reference_count = q -> statement.reference_count + 1;
		end;

	     if ^ p -> reference.shared
		then p -> reference.ref_count = p -> reference.ref_count + 1;

	     return(p);

	     end;
/*  */
check_expr:	proc(pt);

	     /* forces evaluation of any expression that could be used in
	        more than one place */

dcl	     (pt,p,q) ptr;
dcl	     (i,n) fixed bin;
dcl	     atomic bit(1) aligned;

	     p = pt;
	     if p = null then return;
	     if p -> node.type = temporary_node then return;

	     if p -> node.type = list_node
	     then do;

		/* should appear only in arg lists */

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

	     q = p;

	     if p -> node.type = operator_node
	     then do;
		if p -> operator.op_code = param_ptr | p -> operator.op_code = param_desc_ptr
		     then return;

		if p -> operator.op_code = std_call
		     then n = 2;
		     else n = 1;

		p = p -> operand(1);

		if p -> reference.ref_count <= n
		then do;
		     do i = q -> operator.number to 2 by -1;
			call check_expr((q -> operand(i)));
			end;
		     return;
		     end;
		end;

	     else do;
		if p -> reference.ref_count <= 1
		then do;
		     if p -> reference.length ^= null
			then call check_expr((p -> reference.length));
		     if p -> reference.qualifier ^= null
			then call check_expr((p -> reference.qualifier));
		     if p -> reference.offset ^= null
			then call check_expr((p -> reference.offset));
		     return;
		     end;
		end;

	     p = prepare_operand(q,1,atomic);

	     if ^ atomic
	     then do;
		p -> reference.ref_count = p -> reference.ref_count + 1;
		call compile_exp(q);
		end;

	     return;
	     end;

	end;




		    pointer_builtins.pl1            10/03/83  1730.5rew 10/03/83  1009.1      204048



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

/* procedure to compile pointer valued operators

   Initial Version: 19 August 1971 by BLW
	Modified: 11 February 1973 by RAB
	Modified:	16 October 1975 by RAB to use all regs
	Modified:	26 March 1975 by RAB to fix bug 1479 introduced
		16 October 1975
	Modified:	27 April 1976 by RAB to fix 1493
	Modified:	7 Dec 1976 by RAB to fix 1559
	Modified:	9 May 1977 by RAB to fix 1617
	Modified:	10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address	
	Modified: 29 March 1978 by PCK to add stackframeptr, stackbaseptr, environmentptr, and codeptr
	Modified: 19 August 1978 by PCK to fix bug 1742	*/

/* Modified BIM 12/82 to add the Palter builtins (addcharno, setcharno, etc. */
/* Modified BIM 1/83 to un-share the first operand always, since it will  */
/*	 be in the machine state in a PR. This, together with */
/*	 conversion of many compile_exp$save calls to compile_exp, */
/*	 removes a bunch of spurious stores. */
/* Modified BIM 6/83 to stop calling get_base in addr. get_base assumes */
/*         that ref (2) is a pointer VAR to be dicked with, not an object */
/*	 whose addr is to be returned. */
/* Modified BIM 9/83 to fix some malingering problems in the new bifs, */
/*	 including an uninitialized variable in NO_FUNS. */

pointer_builtins:
     proc (pt, store_it);

dcl	pt		ptr,			/* points at operator node */
	store_it		bit (1) aligned;		/* "1"b if value should be stored */

dcl	(
	p,
	q,
	p2,
	s3,
	ref		(3),
	b2
	)		ptr,
	(i, ibase, macro, mac_1, n, old_changed)
			fixed bin (15),
	last_freed	fixed bin (18),
	base		bit (3) aligned,
	op_code		bit (9) aligned,
	(
	atom		(3),
	adjust,
	in_base
	)		bit (1) aligned;

dcl	(
	cg_stat$temp_ref,
	cg_stat$text_base
	)		ptr ext,
	cg_stat$text_pos	fixed bin ext,
	cg_stat$null_value	bit (72) aligned ext,
	cg_stat$cur_level	fixed bin ext;

dcl	adjust_ref_count	entry (pointer, fixed bin);
dcl	base_man$load_any_var
			entry (fixed bin, ptr) returns (bit (3) aligned);
dcl	prepare_operand	entry (ptr, fixed bin (15), bit (1) aligned) returns (ptr),
	compile_exp$save	entry (ptr) returns (ptr),
	compile_exp	entry (ptr),
	c_a		entry (fixed bin (15), fixed bin) returns (ptr),
	load		entry (ptr, fixed bin),
	(
	base_man$load_var,
	base_man$update_base
	)		entry (fixed bin, ptr, fixed bin (15));
dcl	base_man$load_arg_ptr
			entry (fixed bin (15), ptr, fixed bin) returns (bit (3) aligned);
dcl	base_man$load_display
			entry (fixed bin, bit (3) aligned),
	generate_constant$bit_string
			entry (bit (*) aligned, fixed bin) returns (ptr);
dcl	base_to_core	entry (fixed bin (15), ptr),
	state_man$flush_address
			entry (ptr),
	state_man$flush_ref entry (ptr),
	store_bit_address	entry (ptr, ptr, fixed bin (18)),
	store		entry (ptr),
	expmac$zero	entry (fixed bin (15));
dcl	type2		fixed bin (17),
	m_a		entry (ptr, bit (2) aligned),
	cg_error		entry (fixed bin, fixed bin (9));
declare	cg_stat$cur_statement
			pointer external;

dcl	(
	SETCHARNO		init (1),
	ADDCHARNO		init (2),
	SETBITNO		init (3),
	ADDBITNO		init (4)
	)		fixed bin int static options (constant);

dcl	(abs, addrel, bit, fixed, index, null, string)
			builtin;

dcl	fix_bin		fixed bin based;

dcl	ldfx2		init (8) fixed bin (15) static;

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

dcl	1 instruction	aligned based,
	  2 base		bit (3) unal,
	  2 offset	bit (15) unal,
	  2 op_code	bit (10) unal,
	  2 skip		bit (2) unal,
	  2 tag		bit (6) unal;

dcl	(
	pointer_mac_const	(6) init (326, 0, 652, 653, 654, 655),
	addrel_mac_const	(6) init (327, 0, 656, 657, 658, 659),
	zero_bo		(6) init (642, 0, 684, 685, 686, 687),
	longbs_to_bs18	init (131),
	pl1_pointer_easy	init (602),
	pl1_pointer_hard	init (604),		/*	pointer_mac_bs(6)	init(212,0,660,662,664,666), */
	pointer_mac_fx	(6) init (213, 0, 661, 663, 665, 667),
						/*	addrel_mac_bs(6)	init(214,0,668,670,672,674), */
	addrel_mac_fx	(6) init (215, 0, 669, 671, 673, 675),
						/*	baseptr_mac_bs(6)	init(216,0,676,678,680,682), */
	baseptr_mac_fx	(6) init (217, 0, 677, 679, 681, 683)
	)		fixed bin (15) int static;

dcl	epbx		(0:7)
			init ("0111010001"b, "0111010101"b, "0111110001"b, "0111010010"b, "0111010110"b,
			"0111110010"b, "0111110110"b, "0111110101"b) bit (10) aligned int static;

%include cgsystem;
%include operator;
%include reference;
%include symbol;
%include block;
%include op_codes;
%include data_types;
%include nodes;
%include machine_state;
%include bases;
%include temporary;

	p = pt;
	p2 = p -> operand (2);


	op_code = p -> operator.op_code;

	if op_code = param_ptr
	then do;
		i = 0;

		goto l4;
	     end;

	if op_code = param_desc_ptr
	then do;
		i = 1;

l4:
		ref (1) = prepare_operand ((p -> operand (1)), 1, atom (1));

		base =
		     base_man$load_arg_ptr (i, (p -> operand (3)),
		     p2 -> reference.symbol -> symbol.initial -> fix_bin);

		ibase = which_base (fixed (base, 3));
		goto to_core;
	     end;

	if op_code >= ptr_fun
	then n = 1;
	else n = -1;

	do i = 1 to p -> operator.number;
	     ref (i) = prepare_operand ((p -> operand (i)), n, atom (i));
	end;

	if op_code = setcharno_fun
	then call NO_FUNS (SETCHARNO);
	else if op_code = addcharno_fun
	then call NO_FUNS (ADDCHARNO);
	else if op_code = setbitno_fun
	then call NO_FUNS (SETBITNO);
	else if op_code = addbitno_fun
	then call NO_FUNS (ADDBITNO);			/* these dont return here */

	if op_code = addr_fun
	then do;

		if ^atom (2)
		then if p2 -> node.type = operator_node
		     then ref (2) = compile_exp$save (p2);
						/* make addr (expression) work, invalid though it is */

		adjust, in_base = "0"b;		/* of interest only in the varying case */

		if ref (2) -> reference.varying_ref
		then do;
			adjust = "1"b;
			call adjust_c_offset (-1);
		     end;

		ibase = which_base (bin (base_man$load_any_var (2, ref (2)), 3));

		if adjust
		then call reset_c_offset (-1);

		ref (2) -> reference.address_in.b (ibase) = "0"b;
						/* we cannot remember both addr (ref (2)) and ref (1). */
		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;
to_core:
		if ref (1) -> reference.allocate
		then if store_it
		     then call base_to_core (ibase, ref (1));
		     else ;
		else call state_man$flush_ref (ref (1));

		if ibase ^= 7			/* protect pr6 from optimization for stackframeptr */
		then call base_man$update_base (1, ref (1), ibase);
		else call state_man$flush_ref (ref (1));

		ref (1) -> reference.evaluated = "1"b;	/* Cannot be shared at this point */
done:
		cg_stat$temp_ref = ref (1);
		return;
	     end;

	if op_code = addr_fun_bits
	then do;

		if ^atom (2)
		then if p2 -> node.type = operator_node
		     then ref (2) = compile_exp$save (p2);
						/* see above */

		ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
		last_freed = 0;
		if ref (1) -> reference.temp_ref
		then if ref (1) -> reference.qualifier ^= null
		     then last_freed = ref (1) -> reference.qualifier -> temporary.last_freed;

		if store_it
		then call store_bit_address (ref (1), ref (2), last_freed);
		else begin;
declare	base_bits		bit (3) aligned;
			base_bits = base_man$load_any_var (2 /* addr */, ref (2));
			call base_man$update_base (1, ref (1), (which_base (fixed (base_bits, 3))));
		     end;
		goto done;
	     end;

	if op_code = ptr_fun
	then do;

		if ref (2) -> reference.symbol -> symbol.ptr
		then do;

/* this is Multics version of ptr builtin */
/* The ref count must be bumped here because the optimiser */
/* does not know that we hit the output temp twice -- once */
/* when we compile it, once when we load it. */

			if ^atom (2)
			then if p2 -> node.type = operator_node
			     then do;
				     call adjust_ref_count ((p2 -> operator.operand (1)), +1);
				     call compile_exp (p2);
				     ref (2) = p2 -> operator.operand (1);
				end;

			if ref (3) -> reference.offset ^= null
			then goto l1;
			if ref (3) -> reference.c_offset ^= 0
			then goto l1;

			s3 = ref (3) -> reference.symbol;
			if s3 -> symbol.constant
			then
Multics_POINTER_CONSTANT:
			     do;
				ibase = get_base ();
				mac_1 = pointer_mac_const (ibase);
				goto c0;
			     end;

			goto l1;
		     end;

/* this is PL/1 version of ptr builtin */


		if ^atom (2)
		then ref (2) = compile_exp$save (p2);

		call load (ref (2), 0);

		q = ref (3) -> reference.symbol;
		if q -> symbol.internal & (q -> symbol.auto | q -> symbol.static)
		then macro = pl1_pointer_easy;
		else macro = pl1_pointer_hard;

		call base_man$load_var (2, ref (3), 1);

		call expmac$zero (macro + ref (1) -> reference.data_type - unpacked_ptr);

		ref (2) -> reference.address_in.b (1) = "0"b;
		base_regs (1).variable = null;
		base_regs (1).type = 0;

/* next 3 lines necessary because store won't always update state */

		q_reg.variable (1) = ref (1);
		q_reg.number = 1;
		ref (1) -> reference.value_in.q = "1"b;

		if ref (1) -> reference.allocate & store_it
		then call store (ref (1));

		else do;
			if ^ref (1) -> reference.allocate
			then call state_man$flush_ref (ref (1));

			q_reg.variable (1) = ref (1);
			q_reg.number = 1;
			ref (1) -> reference.value_in.q = "1"b;
		     end;

		call base_man$update_base (1, ref (1), 1);

		goto done;
	     end;

	if op_code = addrel_fun
	then do;

		if ^atom (2)
		then if p2 -> node.type = operator_node
		     then do;
			     call adjust_ref_count ((p2 -> operator.operand (1)), 1);
						/* we will call base_man, which costs an extra ref_count hit */
			     call compile_exp (p2);
			     ref (2) = p2 -> operator.operand (1);
			end;

		if ref (3) -> reference.offset ^= null
		then goto l1;
		if ref (3) -> reference.c_offset ^= 0
		then goto l1;

		s3 = ref (3) -> reference.symbol;
		if ^s3 -> symbol.constant
		then goto l1;

		ibase = get_base ();
		mac_1 = addrel_mac_const (ibase);

c0:
		q = s3 -> symbol.initial;

		if ref (3) -> reference.data_type = bit_string
		then do;
			if ref (3) -> reference.long_ref
			then goto l1;
			if ref (3) -> reference.c_length > 18
			then goto l1;
		     end;
		else if abs (q -> fix_bin) >= 131072
		then goto l1;

		old_changed = base_regs (ibase).changed;

		call base_man$load_var (1, ref (2), ibase);
		ref (2) -> reference.value_in.b (ibase) = "0"b;
		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;
		n = base_regs (ibase).changed;

		if op_code = ptr_fun
		then if q -> fix_bin = 0 & n ^= old_changed
		     then do;
			     q = addrel (cg_stat$text_base, n);
			     q -> instruction.op_code = epbx (ibase);
			     base_regs (ibase).instruction = string (q -> instruction);
			     goto to_core;
			end;


		call expmac$zero (mac_1);

		p = addrel (cg_stat$text_base, cg_stat$text_pos - 1);

		if ref (3) -> reference.data_type = bit_string
		then p -> left = q -> left;
		else do;
			if q -> fix_bin >= 0
			then p -> left = bit (fixed (q -> fix_bin, 18), 18);
			else p -> left = bit (fixed (262144 + q -> fix_bin, 18), 18);
		     end;

		goto to_core;

l1:
		if atom (3)
		then call load (ref (3), 0);
		else call compile_exp ((p -> operand (3)));

		if ref (3) -> reference.long_ref
		then call expmac$zero ((longbs_to_bs18));

		ibase = get_base ();
		if op_code = ptr_fun
		then macro = pointer_mac_fx (ibase);
		else macro = addrel_mac_fx (ibase);

		old_changed = base_regs (ibase).changed;

		call base_man$load_var (1, ref (2), ibase);
		ref (2) -> reference.value_in.b (ibase) = "0"b;
		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;

		if op_code ^= addrel_fun
		then do;
l2a:
			call expmac$zero (macro - fixed (ref (3) -> reference.data_type = bit_string, 1));
			goto to_core;
		     end;

		n = base_regs (ibase).changed;
		if n = old_changed
		then go to l2a;
		q = addrel (cg_stat$text_base, n);

		if q -> instruction.tag = "000000"b
		then do;
			if ref (3) -> reference.data_type = bit_string
			then do;
				if a_reg.changed > n
				then go to l2a;
				q -> instruction.tag = "000001"b;
						/* au */
			     end;
			else do;
				if q_reg.changed > n
				then go to l2a;
				q -> instruction.tag = "000110"b;
						/* ql */
			     end;
			go to set_inst;
		     end;

		if q -> instruction.tag ^= "010000"b
		then goto l2a;

		if ref (3) -> reference.data_type = bit_string
		then do;
			if a_reg.changed > n
			then goto l2a;
			q -> instruction.tag = "110001"b;
						/* *au */
		     end;
		else do;
			if q_reg.changed > n
			then goto l2a;
			q -> instruction.tag = "110110"b;
						/* *ql */
		     end;
set_inst:
		base_regs (ibase).instruction = string (q -> instruction);
		call expmac$zero ((zero_bo (ibase)));
		goto to_core;
	     end;

	if op_code = baseptr_fun
	then do;

		if atom (2)
		then call load (ref (2), 0);
		else call compile_exp ((p -> operand (2)));
		if p -> operator.operand (2) -> node.type = operator_node
		then ref (2) = p -> operator.operand (2) -> operator.operand (1);

		ibase = get_base ();
		macro = baseptr_mac_fx (ibase);
		ref (3) = ref (2);

		goto l2a;
	     end;

	if op_code = stackframeptr_fun
	then do;
		if ref (1) -> reference.allocate & store_it
		then do;
			ibase = which_base (6);
			goto to_core;
		     end;

		ref (2) = c_a (0, 4);

		ibase = get_base ();

		call base_man$load_var (2, ref (2), ibase);

		ref (2) -> reference.address_in.b (ibase) = "0"b;
		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;
		goto to_core;
	     end;

	if op_code = stackbaseptr_fun
	then do;
		ref (2) = c_a (0, 4);

		ibase = get_base ();

		old_changed = base_regs (ibase).changed;

		call base_man$load_var (2, ref (2), ibase);
		ref (2) -> reference.address_in.b (ibase) = "0"b;
		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;
		n = base_regs (ibase).changed;

		if n ^= old_changed
		then do;
			q = addrel (cg_stat$text_base, n);
			q -> instruction.op_code = epbx (ibase);
			base_regs (ibase).instruction = string (q -> instruction);
			goto to_core;
		     end;

		call expmac$zero ((pointer_mac_const (ibase)));
		goto to_core;
	     end;

	if op_code = codeptr_fun
	then do;

		if ^atom (2)
		then ref (2) = compile_exp$save (p2);
		ibase = get_base ();
		type2 = ref (2) -> reference.data_type;

		if type2 = label_constant | (ext_entry_in <= type2 & type2 <= int_entry_other)
		then do;				/* process label, format, and entry constants */
			call base_man$load_var (2, ref (2), ibase);
			ref (2) -> reference.address_in.b (ibase) = "0"b;
		     end;
		else do;				/* process label, format, and entry variables */
			call base_man$load_var (1, ref (2), ibase);
			ref (2) -> reference.value_in.b (ibase) = "0"b;
		     end;

		base_regs (ibase).variable = null;
		base_regs (ibase).type = 0;
		goto to_core;

	     end;

	if op_code = environmentptr_fun
	then do;
		if ^atom (2)
		then ref (2) = compile_exp$save (p2);
		type2 = ref (2) -> reference.data_type;

		if type2 = ext_entry_in | type2 = ext_entry_out
		then do;				/* process external entry constants */
			ref (2) = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
			ref (2) -> reference.data_type = unpacked_ptr;
			ibase = get_base ();
			call base_man$load_var (1, ref (2), ibase);
			ref (2) -> reference.value_in.b (ibase) = "0"b;
			base_regs (ibase).variable = null;
			base_regs (ibase).type = 0;
		     end;

		else if type2 = label_constant | type2 = int_entry | type2 = int_entry_other
		then do;				/* process label, format, and internal entry constants */
			b2 = ref (2) -> reference.symbol -> symbol.block_node;
			if cg_stat$cur_level = b2 -> block.level
			then do;
				if ref (1) -> reference.allocate & store_it
				then do;
					ibase = which_base (6);
					goto to_core;
				     end;

				ref (2) = c_a (0, 4);
				ibase = get_base ();
				call base_man$load_var (2, ref (2), ibase);
				ref (2) -> reference.address_in.b (ibase) = "0"b;
			     end;
			else do;
				call base_man$load_display (cg_stat$cur_level - b2 -> block.level, base);
				ibase = which_base (fixed (base, 3));
			     end;
		     end;

		else do;				/* process label, format, and entry variables */
			ibase = get_base ();
			call adjust_c_offset (2);
			call base_man$load_var (1, ref (2), ibase);
			call reset_c_offset (2);
			base_regs (ibase).variable = null;
			base_regs (ibase).type = 0;

		     end;

		goto to_core;

	     end;

err:
	call cg_error (301, fixed (op_code, 9));


get_base:
     proc returns (fixed bin (15));

dcl	i		fixed bin (15);
dcl	(
	first_base	init (3),
	last_base		init (6)
	)		fixed bin (15) int static;

/* all these functions destroy the PR containing op (2). If this */
/* is of the form a = OP (a, ...) then this is fine, or if we */
/* have no other use for a. Otherwise, copy a into another PR */
/* to keep the original value around */

	if string (ref (2) -> reference.value_in.b)
	then if ref (2) -> reference.ref_count = 1 | ref (1) = ref (2)
	     then return (index (string (ref (2) -> reference.value_in.b), "1"b) - 1);
	     else ;
	else if ref (2) -> reference.data_type >= unpacked_ptr
	then do;

/* m_a can load pointer regs */

		call m_a (ref (2), "00"b);
		ref (2) -> reference.perm_address = "1"b;
						/* base_man will turn off  */
	     end;

	do i = 1, first_base to last_base;
	     if base_regs (i).type = 0
	     then return (i);
	     else if base_regs (i).type <= 2
	     then if base_regs (i).variable -> reference.hit_zero | ^base_regs (i).variable -> reference.allocate
		then return (i);
	end;

	return (1);
     end;

adjust_c_offset:
     proc (adjust_offset);

dcl	adjust_offset	fixed bin;

	ref (2) -> reference.c_offset = ref (2) -> reference.c_offset + adjust_offset;

	if string (ref (2) -> reference.address_in.b)
	then do;
		if ref (2) -> reference.address.offset ^= (15)"0"b
		then call m_a (ref (2), "00"b);
		call state_man$flush_address (ref (2));
		in_base = "1"b;
		if adjust_offset >= 0
		then ref (2) -> address.offset = bit (fixed (adjust_offset, 15), 15);
		else ref (2) -> address.offset = bit (fixed (adjust_offset + 32768, 15), 15);
		ref (2) -> reference.perm_address = "1"b;
		ref (2) -> reference.no_address = "0"b;
	     end;
	else in_base = "0"b;

     end;

reset_c_offset:
     proc (adjust_offset);

dcl	adjust_offset	fixed bin;

	ref (2) -> reference.c_offset = ref (2) -> reference.c_offset - adjust_offset;

	if in_base
	then do;
		ref (2) -> address.offset = (15)"0"b;
		ref (2) -> reference.perm_address = "0"b;
	     end;

     end;


/* The following uses a different approach from the rest of this program */
/* to avoid the piles and piles of macros used by the pointer and addrel */
/* cases, or the patching of instructions, this just uses a locked base register */
/* to avoid the problem of a pointer qualified second argument */

NO_FUNS:
     procedure (Funx);
declare	Funx		fixed bin;
declare	base_man$load_var_and_lock
			entry (fixed bin, ptr, fixed bin (15));
declare	base_man$unlock	entry (fixed bin (15));

declare	q		pointer;

declare	expmac		entry (fixed bin (15), pointer);
declare	base_bits		bit (3) aligned;
declare	s3_constant	bit (1) aligned;
declare	constant_zero	bit (1) aligned;
declare	constant_value	fixed bin (24);
declare	based_fb_24	fixed bin (24) based;

declare	MACRO		(4) fixed bin (15) init (373, 373, 374, 374) int static options (constant);
declare	binary		builtin;


          s3_constant = "0"b; /* until proven guilty */

	s3 = ref (3) -> reference.symbol; /* prepare_operand made ref (3) the output operand if its non-atomic */
	if s3 -> symbol.constant
	then do;
		s3_constant = "1"b;
		constant_value = s3 -> symbol.initial -> based_fb_24;
	     end;

	constant_zero = s3_constant & constant_value = 0;

	if constant_zero
	then if Funx = ADDCHARNO | Funx = ADDBITNO
	     then do;
		     ibase = get_base ();		/* find the var in a base */
		     call base_man$load_var (1, ref (2), ibase);
						/* in case it was in no register yet */
		     go to to_core;			/* and return it there */
		end;

	if ^atom (2)
	then call compile_exp (p2);

	if s3_constant
	then do;					/* if even number of words, optimize */
		if constant_zero
		then call CONVERT_TO_POINTER_CONSTANT (0);
		if Funx = SETCHARNO & mod (constant_value, 4) = 0
		then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 4, 24, 0));
		else if Funx = SETBITNO & mod (constant_value, 36) = 0
		then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 36, 24, 0));
	     end;

	q = c_a (0, 1);				/* get a constant ref node */

	ibase = get_base ();
	base_bits = bases (ibase);
	call base_man$load_var_and_lock (1, ref (2), ibase);
						/* will just find and lock if get_base loaded */

/* This code could call aq_man$load_any_var, and then set the modifier */
/* on the instruction appropriately. */

	if ^atom (3)				/* atomize 3 */
	then call compile_exp ((p -> operator.operand (3)));
	else call load (ref (3), 0);			/* dont negate */

	q -> reference.address.base = base_bits;
	q -> reference.address.tag = "06"b3;		/* QL */
	q -> reference.relocation = ""b;

	if Funx = ADDCHARNO | Funx = ADDBITNO		/* add... */
	then q -> reference.address.ext_base = "1"b;	/* turn on bit 29 */
	call expmac (MACRO (Funx), q);
	call base_man$unlock (ibase);
	machine_state.base_regs (ibase).variable = null ();
	machine_state.base_regs (ibase).type = 0;
	ref (2) -> reference.value_in.b (ibase) = "0"b;
	go to to_core;				/* store if that is the right thing, then return. */

CONVERT_TO_POINTER_CONSTANT:
     procedure (Word_offset);
declare	Word_offset	fixed bin (24);
declare	declare_constant	ext entry (bit (*) aligned, bit (36) aligned, fixed bin (31), fixed bin (31))
			returns (pointer);
declare	size		fixed bin (31);
declare	value		bit (36) aligned;
declare	substr		builtin;

%include mask;

/***** This procedure does not patch the tree. Perhaps a better way */
/* would be for something in the semantics to detect these cases, and */
/* have it make the tree start out as pointer (foo, bar), but I */
/* don't know how to do that, and I do know how to do this. --BIM */

	op_code = ptr_fun;

	size = 18;
	value = unspec (Word_offset);

	ref (3) = declare_constant (value, fixed_binary_real_mask | unsigned_mask, size, 0);
	s3 = ref (3) -> reference.symbol;		/* global depended on */
	go to Multics_POINTER_CONSTANT;
     end CONVERT_TO_POINTER_CONSTANT;


     end NO_FUNS;

     end pointer_builtins;




		    power_of_two.alm                10/03/83  1730.5rew 10/03/83  1009.1        8676



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

"
" function to return N where 2**N=M, returns 0 if M is not power of 2
"
" usage is N = power_of_two(M)
"
	name	power_of_two
	entry	power_of_two
"
power_of_two:
	lda	0,dl		init answer
	ldq	ap|2,*		get M
	sbq	1,dl		get M-1
	anq	ap|2,*		form M & (M-1)
	tnz	done		^= 0 means not power of 2
	ldq	ap|2,*		restore M
	qrl	1		shift right
	tze	done		shift until zero
	ada	1,dl		update count
	tra	-3,ic		and try again
done:	sta	ap|4,*		store N where 2**N=M
	short_return
	end




		    prepare_operand.pl1             10/03/83  1730.5rew 10/03/83  1009.1      244971



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


/* program to process operand of an operator node

	Modified:  21 May 1973 by RAB for multiple base regs
	Modified:	19 June 1973 by RAB for EIS
	Modified:	8 August 1974 by RAB to fix 1206
	Modified:	18 November 1974 by RAB to fix 1257, 1258
	Modified:	22 November 1974 by RAB to remove setting of passed_as_arg
	Modified:	26 June 1976 by RAB to fix 1503 (changed handling of
		qualifier for defined_ref)
	Modified:	5 Oct 1976 by RAB to improve unspec(char_expr)
	Modified:	24 Nov 1976 by RAB to fix 1555
	Modified:	14 Sept 1977 by RAB to fix 1662
	Modified:	15 Dec 1977 by RAB to fix 1694
	Modified:	9 March 1978 by RAB to fix 1714 (setting of aligned_ref for packed decimal)
	Modified:	22 Jan 1979 by RAB to fix 1814 (ERROR 313 for multiple occurrences of
		packed based qualifiers in if stmt)
		pointer_chain now sets reference.evaluated after call to
		base_man$load_packed
	Modified: 25 Apr 1979 by PCK to implement 4-bit decimal
	Modified: 4 Mar 1980 by PCK to fix 1910 and 1911
	Modified:	30 Mar 1980 by RAB to add reference.(padded aligned)_for_store_ref
		as a partial fix to bug 1186, the famous PADDED REFERENCE BUG.
          Modified 830118 BIM to copy_temp on all pointers.
	Modified 830427 BIM to support ptr options (packed);
*/

/* format: style3,^indnoniterdo,indend */
prepare_operand:
     proc (pt, evaluate, atomic) returns (ptr);

dcl	pt		ptr,			/* points at reference|operator node */
	evaluate		fixed bin,		/* < 0 means evaluate offset but not size,
				   = 0 means don't evaluate size or offset,
				   > 0 means evaluate size and offset */
	atomic		bit (1) aligned;		/* set "1"b if operand is atomic */

dcl	(p, p1, p2, q, s)	ptr,
	(cfo, eval, n, bit_length)
			fixed bin,
	(str, useless, here_before, padded_bit)
			bit (1) aligned,
	op_code		bit (9) aligned;

dcl	(
	cg_stat$long_string_temp,
	cg_stat$cur_block,
	cg_stat$cur_statement,
	cg_stat$cur_node
	)		ptr ext;

dcl	(
	assign_op,
	compile_exp,
	stack_temp$assign_aggregate,
	state_man$update_ref
	)		entry (ptr),
	adjust_ref_count	entry (ptr, fixed bin),
	state_man$update_reg
			entry (ptr, bit (19) aligned),
	state_man$erase_reg entry (bit (19) aligned),
	(
	compile_exp$save,
	compile_exp$save_exp
	)		entry (ptr) returns (ptr),
	eval_exp		entry (ptr, bit (1) aligned) returns (ptr),
	get_reference	entry returns (ptr),
	prepare_operand	entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
	copy_temp		entry (ptr) returns (ptr),
	generate_constant$real_fix_bin_1
			entry (fixed bin) returns (ptr),
	check_o_and_s	entry (ptr) returns (ptr),
	load		entry (ptr, fixed bin),
	call_op		entry (ptr) returns (ptr),
	base_man$load_packed
			entry (ptr, fixed bin),
	pointer_builtins	entry (ptr, bit (1) aligned),
	length_op		entry (ptr) returns (ptr),
	assign_desc_op	entry (ptr) returns (ptr),
	decimal_op$change_target
			entry (ptr) returns (bit (1) aligned),
	decimal_op$get_float_temp
			entry (fixed bin (24), bit (1) aligned) returns (ptr),
	assign_op$to_dec_scaled
			entry (ptr, ptr);

dcl	(addrel, divide, fixed, max, mod, null, string, substr)
			builtin;

dcl	fix_bin		(0:1) fixed bin based;

dcl	io_class		init ("10000"b) bit (5) int static;

%include cgsystem;
%include reference;
%include symbol;
%include array;
%include label;
%include operator;
%include nodes;
%include op_codes;
%include data_types;
%include boundary;
%include machine_state;

	p, q = pt;
	atomic = "1"b;

	eval = evaluate;

	if p -> node.type = label_node
	then do;

	     q = get_reference ();
	     q -> reference.symbol = p;

l1:
	     q -> reference.data_type = label_constant;
	     q -> reference.allocated = p -> label.allocated;
	     q -> reference.aliasable, q -> reference.temp_ref, q -> reference.defined_ref, q -> reference.allocate = "0"b;
	     goto l3;
	     end;

	if p -> node.type = operator_node
	then do;

	     if p -> operator.op_code = desc_size
	     then do;
		q = check_o_and_s (p);
		if q ^= null
		then goto go;
		end;

	     q = p -> operand (1);

/* check for expression already done */

	     if q -> reference.evaluated
	     then if q -> reference.data_type = 0
		then goto l8a;
		else do;
		     if eval > 0
		     then if q -> reference.symbol -> node.type = symbol_node
			then if q -> reference.symbol -> symbol.return_value
			     then q -> reference.length = eval_exp ((q -> reference.length), "1"b);
		     if ^q -> reference.aligned_ref
		     then atomic = "0"b;
		     goto done;
		     end;

	     if p -> operator.op_code = assign
	     then do;
		s = p -> operand (2);
		if s -> node.type ^= reference_node
		then goto l8;
		if s -> reference.symbol -> node.type ^= symbol_node
		then goto l8;
		if ^s -> reference.symbol -> symbol.arg_descriptor
		then goto l8;
		if ^q -> reference.symbol -> symbol.temporary
		then goto l8;

/* have assignment of element of arg_descriptor to a temporary,
		   eliminate the unnecessary assignment */

		if q -> reference.shared
		then do;
		     q = s;
		     goto go;
		     end;
		else do;
		     q = assign_desc_op (p);
		     go to exit;
		     end;
		end;

	     if p -> operator.op_code = length_fun
	     then do;
		q = length_op (p);
		go to exit;
		end;

	     if p -> operator.op_code = std_call
	     then do;
		q = call_op (p);
		if ^q -> reference.aligned_ref
		then atomic = "0"b;
		goto done;
		end;

l8:
	     eval = 0;
l8a:
	     atomic = "0"b;
	     end;

/* set fields not yet set by declaration processor */

go:
	p1 = q -> reference.qualifier;
	s = q -> reference.symbol;

	here_before = q -> reference.data_type ^= 0 & ^q -> reference.shared;

	if s -> node.type = label_node
	then do;
	     p = s;
	     goto l1;
	     end;

	q -> reference.aggregate =
	     q -> reference.array_ref | s -> symbol.structure | s -> symbol.arg_descriptor | s -> symbol.storage_block
	     | ((s -> symbol.dimensioned | s -> symbol.member) & s -> symbol.temporary);

	q -> reference.aliasable =
	     s -> symbol.aliasable
	     | (s -> symbol.auto & (cg_stat$cur_block ^= s -> symbol.block_node) & s -> symbol.passed_as_arg);
	q -> reference.temp_ref = q -> reference.temp_ref | s -> symbol.temporary;
	q -> reference.allocated =
	     q -> reference.allocated | (s -> symbol.allocated & q -> reference.temp_ref = s -> symbol.temporary);
	q -> reference.defined_ref = s -> symbol.defined & ^q -> reference.temp_ref;
	q -> reference.allocate =
	     q -> reference.allocate | s -> symbol.allocate | q -> reference.ref_count > 0 | q -> reference.aggregate
	     | ^q -> reference.temp_ref;

/*			THE PADDED REFERENCE PROBLEM

	The code generator uses reference.aligned_ref to specify that an
	operand may be directly used in a computation with a register
	(such as addition or intersection) without first extracting it by
	shifting and/or masking.  Prepare_operand develops this bit from
	various sources, such as the offset units, symbol.packed, and
	reference.padded_ref.  reference.padded_ref specifies that the
	reference is that last in a machine word and that zeroes may be
	considered to exist between the rightmost bit of the reference and
	the right end of the machine word, if there is any gap.  The semantic
	translator develops the bit for packed items only under the assumption
	that unpacked items are always padded.  A level-one packed item is
	considered padded if the declaration is for an original generation of
	storage rather than for an alias of an original generation; thus a
	level-one item is padded if it is neither based, defined, nor parameter.
	Packed structure members are considered padded only if they abut the
	right end of a word, if the next item to the right is unpacked, or if
	they abut the right end of a padded structure.  This setting is
	generally correct ignoring considerations of the substr pseudovariable.
	The semantic translator furthermore considers all substr references
	to be unpadded since there may be more non-zero bits to the right in
	the full generation of the string.  Since the substr pseudovariable may
	only set part of a string, it makes sense to assume that the target
	of a substr is unpadded unless the compiler can prove that the whole
	string is set before it is fetched and other conditions for
	padded references hold.  Here comes the reason for the bug.  The
	code generator marks vars that are passed_as_arg or parameters as
	always unpadded (even if unpacked) because their aliases might be
	set by substr, but ignores more complete aliasing rules. Furthermore,
	until 30 March 1980, the code generator used the same bits to determine
	whether an item should be padded when stored as were used to
	determine padded fetches.  The combination of these 2 flaws allowed
	for vars to be stored unpadded, but fetched padded.  Since 30 March
	1980, this has been partially corrected by determining whether to
	zero out remaining bits in a word independently from whether it
	might be a target of substr elsewhere.  Thus reference.aligned_for_storre_ref
	and reference.padded_for_store_ref are introduced.  A complete fix
	would involve using more complete aliasing rules and attempting to
	ensure that all potential substr targets were somehow initialized
	with proper padding, if necessary.  (Note that the Multics implementation
	allocates static and controlled vars from storage that is preinitialized
	to zeroes, so the problem only exists for vars whose original generation
	is automatic or based.)  A complete fix would be incompatable with
	pre March 30, 1980 behavior because of aliasing problems.  It is
	hoped the fix of March 30, 1980 will greatly reduce that
	incompatability so that the complete fix might be tried after several
	years.
*/

	q -> reference.padded_for_store_ref = q -> reference.padded_ref;

	if ^s -> symbol.packed
	then do;
	     padded_bit,
		q -> reference.padded_for_store_ref =
		^q -> reference.substr | q -> reference.c_length = s -> symbol.c_dcl_size;

	     if ^(s -> symbol.parameter | (s -> symbol.defined & s -> symbol.overlayed))
	     then q -> reference.padded_ref = padded_bit;
	     end;

/* The following is a bad remnant of the old padded reference scheme
	   that we hope to drop, eventually.  Note that reference.padded_for_store_ref
	   is not affected. */

	if s -> symbol.passed_as_arg
	then if ^s -> symbol.constant
	     then q -> reference.padded_ref = "0"b;

	/* end of code that we eventually hope to drop */

	if p1 ^= null
	then if p1 -> node.type ^= temporary_node
	     then if eval ^= 0
		then if ^q -> reference.defined_ref
		     then call pointer_chain (q);
		     else call defined_chain (q);

/* encode data type of reference */

	if s -> symbol.binary
	then do;
	     if s -> symbol.fixed
	     then if s -> symbol.c_dcl_size > max_p_fix_bin_1
		then n = real_fix_bin_2;
		else n = real_fix_bin_1;
	     else if s -> symbol.c_dcl_size > max_p_flt_bin_1
	     then n = real_flt_bin_2;
	     else n = real_flt_bin_1;

	     if s -> symbol.complex
	     then n = n + 4;
	     goto set;
	     end;

	if s -> symbol.decimal
	then do;
	     n = real_fix_dec + fixed (s -> symbol.float, 1);
	     if s -> symbol.complex
	     then n = n + 2;

set:
	     q -> reference.data_type = n;
	     goto l2;
	     end;

	if s -> symbol.char | s -> symbol.picture
	then do;
	     q -> reference.data_type = char_string;
	     goto l2;
	     end;

	if s -> symbol.bit
	then do;
	     q -> reference.data_type = bit_string;
	     goto l2;
	     end;

	if s -> symbol.offset
	then do;
	     q -> reference.data_type = real_fix_bin_1;
	     goto l2;
	     end;

	if s -> symbol.ptr
	then do;
	     if q -> reference.temp_ref      /* temp ptr operands are copied */
	     then if q -> reference.shared   /* so they can be in the machine state correctly */
	     then do;
		     q = copy_temp (q);
		     q -> reference.ref_count = 2; /* create, then use */
		     if p -> node.type = operator_node
		     then p -> operator.operand (1) = q;
		end;
	     q -> reference.data_type = unpacked_ptr + fixed (s -> symbol.packed | s -> symbol.unaligned | s -> symbol.explicit_packed, 1);
	     goto l2;
	     end;

	if s -> symbol.label
	then do;
	     q -> reference.data_type = label_variable - fixed (s -> symbol.local, 1);
	     goto l2;
	     end;

	if s -> symbol.arg_descriptor
	then do;
	     q -> reference.data_type = real_fix_bin_1;
	     goto l2;
	     end;

	if s -> symbol.file
	then do;
	     q -> reference.data_type = local_label_variable;
	     goto l2;
	     end;

	if s -> symbol.format
	then do;
	     q -> reference.data_type = local_label_variable - fixed (s -> symbol.constant, 1);
	     goto l2;
	     end;

	if s -> symbol.area
	then do;
	     q -> reference.data_type = real_fix_bin_2;
	     go to l2;
	     end;

	if s -> symbol.entry
	then if s -> symbol.variable | s -> symbol.temporary
	     then q -> reference.data_type = entry_variable;
	     else if s -> symbol.external
	     then q -> reference.data_type = ext_entry_in + fixed (s -> symbol.initial = null);
	     else q -> reference.data_type = int_entry;

l2:
	str = s -> symbol.char | s -> symbol.bit | s -> symbol.picture;

	if here_before
	then do;
	     if (s -> symbol.packed & ^(str | s -> symbol.decimal))
		| (str & ^(q -> reference.long_ref | q -> reference.varying_ref))
	     then if ^q -> reference.aligned_ref
		then atomic = "0"b;

	     goto done;
	     end;

	n = q -> reference.units;
	if n = 0
	then n, q -> reference.units = word_;

	else if n ^= word_ & q -> reference.offset = null
	then if mod (q -> reference.c_offset, units_per_word (n)) = 0
	     then do;
		q -> reference.c_offset = divide (q -> reference.c_offset, units_per_word (n), 17, 0);
		n, q -> reference.units = word_;
		end;

	q -> reference.aligned_for_store_ref, q -> reference.aligned_ref = n = word_ & ^q -> reference.fo_in_qual;

	if n < word_
	then if q -> reference.data_type > 0
	     then if q -> reference.data_type = char_string | (s -> symbol.decimal & ^s -> symbol.unaligned)
		then if n ^= character_
		     then call bad;
		     else ;
		else if s -> symbol.decimal & s -> symbol.unaligned
		then if n ^= digit_
		     then call bad;
		     else ;
		else if n ^= bit_
		then call bad;

	if str
	then do;

	     bit_length = q -> reference.c_length * convert_size (q -> reference.data_type);
	     if q -> reference.c_length = 0 & q -> reference.length = null
	     then q -> reference.aligned_for_store_ref, q -> reference.aligned_ref = "1"b;

	     if q -> reference.length ^= null
	     then do;
		q -> reference.long_ref = "1"b;
		if q -> reference.shared
		then go to l3;			/* This catches call from mst for symbol.reference */
		q -> reference.big_length = is_big ((q -> reference.length));
		go to l3;
		end;

	     if q -> reference.c_length > max_short_size (q -> reference.data_type)
	     then do;
		q -> reference.big_length = q -> reference.c_length > max_index_register_value;
		q -> reference.long_ref = "1"b;
		if q -> reference.temp_ref
		then call check_assign;
		go to l3;
		end;

	     if q -> reference.varying_ref
	     then do;
		q -> reference.big_length = "1"b;
		if q -> reference.symbol -> symbol.dcl_size = null
		then if q -> reference.symbol -> symbol.c_dcl_size <= max_index_register_value
		     then q -> reference.big_length = "0"b;
		go to l3;
		end;

	     q -> reference.aligned_ref =
		q -> reference.aligned_ref & (q -> reference.padded_ref | mod (bit_length, bits_per_word) = 0);

	     q -> reference.aligned_for_store_ref =
		q -> reference.aligned_for_store_ref
		& (q -> reference.padded_for_store_ref | mod (bit_length, bits_per_word) = 0);
	     goto l5b;
	     end;

	bit_length = q -> reference.c_length;

	if bit_length = 0
	then do;
	     if s -> symbol.array = null
	     then bit_length = s -> symbol.c_bit_size;
	     else bit_length = s -> symbol.array -> array.c_element_size_bits;

	     if s -> symbol.decimal
	     then if s -> symbol.unaligned
		then do;
		     if s -> symbol.float
		     then q -> reference.c_length = s -> symbol.c_dcl_size + 3;
		     else q -> reference.c_length = s -> symbol.c_dcl_size + 1;

		     if s -> symbol.complex
		     then q -> reference.c_length = 2 * q -> reference.c_length;
		     end;
		else q -> reference.c_length = divide (bit_length, bits_per_char, 24, 0);
	     else q -> reference.c_length = bit_length;
	     end;

	if s -> symbol.decimal
	then do;
	     call prepare_decimal;
	     if s -> symbol.packed
	     then do;
		q -> reference.aligned_ref =
		     q -> reference.aligned_ref & (q -> reference.padded_ref | mod (bit_length, bits_per_word) = 0);
		q -> reference.aligned_for_store_ref =
		     q -> reference.aligned_for_store_ref
		     & (q -> reference.padded_for_store_ref | mod (bit_length, bits_per_word) = 0);
		end;
	     go to l5b;
	     end;

	if s -> symbol.packed
	then do;
	     if s -> symbol.binary
		& ^(q -> reference.data_type = real_fix_bin_1 | q -> reference.data_type = real_flt_bin_1)
	     then do;
		q -> reference.aligned_ref =
		     q -> reference.aligned_ref
		     & (s -> symbol.boundary > word_ & mod (bit_length, bits_per_two_words) = 0);
		q -> reference.aligned_for_store_ref =
		     q -> reference.aligned_for_store_ref
		     & (s -> symbol.boundary > word_ & mod (bit_length, bits_per_two_words) = 0);
		end;

	     else if ^s -> symbol.ptr
	     then do;
		if s -> symbol.structure
		then do;
		     q -> reference.aligned_ref = q -> reference.aligned_ref & q -> reference.padded_ref;
		     q -> reference.aligned_for_store_ref =
			q -> reference.aligned_for_store_ref & q -> reference.padded_for_store_ref;
		     end;
		q -> reference.aligned_ref = q -> reference.aligned_ref & (mod (bit_length, bits_per_word) = 0);
		q -> reference.aligned_for_store_ref =
		     q -> reference.aligned_for_store_ref & (mod (bit_length, bits_per_word) = 0);
		end;
l5b:
	     if ^q -> reference.aligned_ref
	     then atomic = "0"b;
	     end;

l3:
	if q -> reference.aggregate & q -> reference.temp_ref
	then do;

/* this is an aggregate temp, walk back to level 1 ancestor and
		assign storage if non-already assigned */

	     do p2 = s repeat (p2 -> symbol.father) while (p2 -> symbol.father ^= null);
	     end;

	     if p2 -> symbol.initial = null
	     then call stack_temp$assign_aggregate (p2);
	     end;

/* develop hard_to_load bit */

	if ^q -> reference.aligned_ref
	then if q -> reference.fo_in_qual
	     then q -> reference.hard_to_load = "1"b;
	     else do;
		n = q -> reference.units;
		if n < word_
		then if q -> reference.offset ^= null & ^q -> reference.modword_in_offset
		     then q -> reference.hard_to_load = "1"b;
		     else if ^q -> reference.long_ref
		     then do;
			cfo = mod (q -> reference.c_offset * convert_offset (n), bits_per_word);
			if cfo < 0
			then cfo = cfo + bits_per_word;
			q -> reference.hard_to_load = cfo + bit_length > bits_per_two_words;
			end;
		end;

	if eval = 0
	then goto done;

	if eval > 0
	then if q -> reference.length ^= null
	     then q -> reference.length = eval_exp ((q -> reference.length), (q -> reference.big_length));

	if q -> reference.offset ^= null
	then do;
	     if n < word_ & ^q -> reference.modword_in_offset
	     then do;
		q -> reference.big_offset = q -> reference.big_offset | is_big ((q -> reference.offset));
		end;

	     q -> reference.offset = eval_exp ((q -> reference.offset), (q -> reference.big_offset));
	     end;

done:
	q -> reference.no_address = "1"b;
	q -> reference.perm_address = "0"b;

	if q -> reference.defined_ref
	then do;
	     if p1 = null
	     then goto exit;

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

	     if p1 -> reference.temp_ref
	     then do;

		if substr (string (p1 -> reference.value_in), 1, 2) = "00"b
		then goto def_done;

		if q -> reference.hard_to_load
		then go to erase_no_update;

/* the defined base is in A or Q register */

		if q -> reference.data_type ^= bit_string
		then do;
		     if q -> reference.data_type ^= p1 -> reference.data_type
		     then go to erase_no_update;

same:
		     string (q -> reference.value_in) =
			string (q -> reference.value_in) | string (p1 -> reference.value_in);
		     call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
		     call state_man$update_reg (q, string (q -> reference.value_in));
		     if q -> reference.value_in.a
		     then if p1 -> reference.data_type = char_string
			then if a_reg.size < p1 -> reference.c_length * bits_per_char
			     then a_reg.length = a_reg.size + a_reg.offset;
		     goto exit;
		     end;

/* the defined temporary is a bit string (possibly from unspec or substr) */

		if p1 -> reference.data_type ^= bit_string
		then do;
		     if p1 -> reference.data_type = real_fix_bin_1
		     then goto same;
		     if p1 -> reference.data_type = packed_ptr
		     then goto same;
		     if p1 -> reference.data_type = char_string
		     then goto same;

		     if p1 -> reference.data_type = real_fix_bin_2 | p1 -> reference.data_type = unpacked_ptr
		     then do;
			q -> reference.value_in.a = "1"b;
			call state_man$update_reg (q, "1"b);
			goto exit;
			end;

erase_no_update:
		     call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
		     end;
		else do;
		     call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
		     call state_man$update_ref (q);
		     if a_reg.size < p1 -> reference.c_length
		     then a_reg.length = a_reg.size + a_reg.offset;
		     end;

def_done:
		end;
	     else do;
		q -> reference.allocate, q -> reference.allocated = "1"b;
		q -> reference.temp_ref = "0"b;
		end;

	     end;

exit:
	return (q);

pointer_chain:
     proc (pt);

dcl	(pt, qp, tp, sp, rp)
			ptr,
	dummy		fixed bin,
	useless		bit (1) aligned,
	op_code		bit (9) aligned;

	qp = pt -> reference.qualifier;
	if qp -> node.type = reference_node
	then do;
	     qp = prepare_operand (qp, 1, useless);
	     return;
	     end;

	tp = qp -> operand (1);
	if tp -> reference.evaluated
	then return;

	op_code = qp -> operator.op_code;
	if op_code = std_call
	then do;
	     pt -> reference.qualifier = call_op (qp);
	     return;
	     end;

	if op_code = addr_fun
	then do;
	     qp -> operand (2) = prepare_operand ((qp -> operand (2)), 1, useless);
	     return;
	     end;

	sp = tp -> reference.symbol;

	if op_code = assign /* must be (unpacked temp) <- (packed) */
	then do;
	     if qp -> operator.operand (1) -> reference.temp_ref
	     then if qp -> operator.operand (1) -> reference.shared
	     then qp -> operator.operand (1) = copy_temp ((qp -> operator.operand (1)));
	     call base_man$load_packed (qp, dummy);
	     qp -> operand (1) -> reference.evaluated = "1"b;
	     return;
	     end;

	if op_code = param_ptr
	then return;
	if op_code = param_desc_ptr
	then return;

/* must be a pointer valued builtin function */

	if sp -> symbol.temporary
	then if tp -> reference.shared
	     then qp -> operand (1) = copy_temp (tp);

	call pointer_builtins (qp, "0"b);
	qp -> operand (1) -> reference.evaluated = "1"b;

     end;


defined_chain:
     proc (pt);

dcl	(pt, qp, rp)	ptr;
dcl	atomic		bit (1) aligned;

	qp = pt -> reference.qualifier;

	if qp -> node.type = reference_node
	then qp = prepare_operand (qp, 1, atomic);
	else if ^qp -> operand (1) -> reference.evaluated
	then do;
	     rp = prepare_operand (qp, 1, atomic);
	     if ^atomic
	     then rp = compile_exp$save_exp (qp);
	     end;

     end;


is_big:
     proc (pt) reducible returns (bit (1) aligned);

/* is_big determines if the precision of an offset or length expression is
   too big to fit in an index register */

dcl	(p, pt)		ptr;
dcl	result		bit (1) aligned;

	p = pt;

	if p -> node.type = operator_node
	then if p -> operator.op_code = length_fun
	     then do;
		p = p -> operand (2);
		if p -> node.type = operator_node
		then p = p -> operand (1);
		p = p -> reference.symbol;
		result = "1"b;
		if p -> symbol.dcl_size = null
		then if p -> symbol.c_dcl_size <= max_index_register_value
		     then result = "0"b;
		return (result);
		end;
	     else p = p -> operand (1);

	return (p -> reference.symbol -> symbol.c_dcl_size > max_p_xreg);

     end;


check_assign:
     proc;

/* This code is necessary because assign_op cannot have a shared temporary
   as the target of a conversion to long string */

dcl	p2		ptr;

	if q -> reference.shared
	then if p -> node.type = operator_node
	     then if substr (p -> operator.op_code, 1, 5) = "00011"b
						/* assign class */
		then do;
		     p2 = p -> operand (2);
		     if p2 -> node.type = operator_node
		     then p2 = p2 -> operand (1);
		     if (string (p2 -> reference.symbol -> symbol.data_type) & "0111111111111111111"b)
			^= (string (s -> symbol.data_type) & "0111111111111111111"b)
		     then q, p -> operand (1) = copy_temp (q);
		     end;

     end;


prepare_decimal:
     proc;

/* prepare_decimal is needed to make up for a disagreement between the hardware and
   the language.  PL/I allows scales from -128 to 127 while the hardware will only take
   decimal scales from -31 to +32.  In order to get around this restriction, we must,
   in most cases, replace any fixed decimal temporaries whose scale is outside the
   hardware limits to floating temporaries of the same precision.  */

dcl	r		ptr;
dcl	(
	i,
	scale		(3)
	)		fixed bin;

	if s -> symbol.temporary
	then if s -> symbol.fixed
	     then if s -> symbol.scale < min_dec_scale | s -> symbol.scale > max_dec_scale
		then if p -> node.type = operator_node
		     then if p -> operator.number >= 3
			then if p -> operator.op_code ^= complex_fun
			     then if p -> operator.op_code ^= round_fun
				then do;
				     if decimal_op$change_target (p)
				     then do;
					r = decimal_op$get_float_temp (s -> symbol.c_dcl_size,
					     (s -> symbol.complex));

					if cg_stat$cur_node ^= null
					then if cg_stat$cur_node -> operator.op_code = std_call
					     then go to keep_fixed;
					     else if substr (cg_stat$cur_node -> operator.op_code, 1, 5) = io_class
					     then go to keep_fixed;

					if s -> symbol.c_dcl_size < max_p_fix_dec
					then do;
					     if ^q -> reference.shared
					     then r -> reference.ref_count = q -> reference.ref_count;
					     q, p -> operand (1) = r;
					     s = r -> reference.symbol;
					     end;
					else do;
keep_fixed:
					     p -> operand (1) = r;
					     r = compile_exp$save (p);
					     if q -> reference.shared
					     then q = copy_temp (q);
					     call assign_op$to_dec_scaled (q, r);
					     p -> operand (1) = q;
					     atomic = "1"b;
					     end;
					end;
				     end;

     end;




bad:
     proc;

dcl	error		entry (fixed bin, ptr, ptr);

	if q -> reference.offset = null
	then if q -> reference.temp_ref
	     then if q -> reference.data_type = real_fix_bin_1
		then return;

	call error (332, cg_stat$cur_statement, q);

     end;

     end;




		    save_value.pl1                  10/03/83  1730.5rew 10/03/83  1009.1       24291



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


/* Procedure to save value of a reference by converting it into an aligned temporary

   Initial Version:  9 February 1972 by BLW
	Modified: 12 December 1972 by BLW
	Modified:	15 February 1973 by RAB
	Modified:	9 March 1977 by RAB to change mod_word handling
	Modified:	25 March 1977 by RAB to fix 1599
	Modified:	9 April 1977 by RAB to remove mod_word
	Modified:	30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
		See prepare_operand for details.	*/

save_value: proc(pt);

dcl	pt ptr;		/* points at a reference node */

dcl	(p,q) ptr,
	n fixed bin,
	(null,substr) builtin,
	adjust_ref_count entry(ptr,fixed bin),
	stack_temp$free_temp entry(ptr),
	state_man$flush_address entry(ptr);

%include reference;
%include operator;
%include boundary;
%include nodes;

	p = pt;

	if p -> reference.temp_ref & (p -> reference.aggregate | p -> reference.dont_save)
	     then return;

	q = p -> reference.length;
	if q ^= null
	then do;
	     if q -> node.type = operator_node then q = q -> operand(1);
	     if ^ q -> reference.shared
		then call adjust_ref_count(q,-1);
	     end;

	q = p -> reference.qualifier;
	if q ^= null
	then do;
	     if q -> node.type = temporary_node
	     then call stack_temp$free_temp(p);
	     else do;
		if q -> node.type = operator_node
		     then q = q -> operand(1);
		if ^ q -> reference.shared
		     then call adjust_ref_count(q,-1);
		end;
	     end;

	q = p -> reference.offset;
	if q ^= null
	then do;
	     if q -> node.type = operator_node
		then q = q -> operand(1);

	     if ^ q -> reference.shared
		then call adjust_ref_count(q,-1);
	     end;

	p -> reference.aligned_ref,
	p -> reference.temp_ref,
	p -> reference.padded_ref,
	p -> reference.aligned_for_store_ref,
	p -> reference.padded_for_store_ref = "1"b;

	p -> reference.units = word_;

	p -> reference.length,
	p -> reference.offset,
	p -> reference.qualifier = null;

	p -> reference.c_offset = 0;

	p -> reference.fo_in_qual,
	p -> reference.hard_to_load,
	p -> reference.store_ins,
	p -> reference.defined_ref,
	p -> reference.allocated,
	p -> reference.value_in.storage = "0"b;

	if string(p -> reference.address_in)
	     then call state_man$flush_address(p);
	end;




		    set_indicators.pl1              10/03/83  1730.5rew 10/03/83  1009.2      189036



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


/* this procedure is called to set the logical indicators.  it
   generates a compare sequence.

   Initial Version: 28 November, 1968 by BLW	
	Modified: 19 December, 1971 by BLW for Version II
	Modified: 29 January, 1973 by BLW
	Modified: 28 April, 1973 by RAB
	Modified:	20 June 1973 by RAB for EIS 
	Modified:	13 October 1975 by RAB to remember comparisons
	Modified:	29 October 1975 by RAB to check p3 in q
	Modified:	25 November 1975 by RAB to fix 1442
	Modified:	21 December 1976 by RAB to fix 1565
	Modified:	15 January 1978 by RAB to move refs(1) = null; towards
		beginning of program
	Modified: 25 Apr 1979 by PCK to implement 4-bit decimal and fix bug 1832
	Modified:	28 Jul 1979 by RAB to fix 1837 (if "" = char_string fails)	*/

set_indicators: proc(pt,p2_par,p3_par,code) returns(fixed bin(1));

dcl	pt	ptr,		/* points at operator node */
	p2_par	ptr,		/* points at left ref node */
	p3_par	ptr,		/* points at right ref node */
	code	fixed bin;	/* context code */

dcl	(cg_stat$text_pos,cg_stat$last_macro,compare_ptrs$compare_ptrs,
	complex_stuff$complex_compare,cg_stat$cur_level,cg_stat$packed_null_value) fixed bin ext,
	cg_stat$null_value bit(72) aligned ext,
	(cg_stat$text_base,cg_stat$cur_block,
	 cg_stat$long_string_temp,cg_stat$single_temp) ptr ext;

dcl	(p,refs(3),q,q2,q3,t,sym(2:3),node_pt,arg(3)) ptr,
	p2s ptr defined(sym(2)),
	p3s ptr defined(sym(3)),
	p2 ptr defined(refs(2)),
	p3 ptr defined(refs(3)),
	(i,s1,s2,s3,size2,size3,type1,type2,type3,dt,k,case,n,prec,scale(3)) fixed bin,
	(macro,op) fixed bin(15),
	atom(3) bit(1) aligned,
	b2 bit(2) aligned,
	(reversed,zero(2:3),const(2:3),atomic,check_scale,ext_ent) aligned bit(1),
	toff bit(15) aligned,
	pl_stat$last_macro fixed bin(15) ext static,
	(mac1,mac2) fixed bin(15);

dcl	c_a entry(fixed bin,fixed bin) returns(ptr),
	generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	base_man$load_var entry(fixed bin,ptr,fixed bin),
	create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
	gen_arithmetic_call entry(ptr,(3) ptr,(3) bit(1) aligned),
	inline_operation entry(ptr,(3) ptr,(3) bit(1) aligned) returns(bit(1) aligned),
	load entry(ptr,fixed bin),
	(compile_exp,compile_exp$for_test) entry(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	aq_man$fix_scale entry(ptr,fixed bin,fixed bin),
	compile_exp$save_fix_scaled entry(ptr,fixed bin,fixed bin) returns(ptr),
	(compile_exp$save,compile_exp$save_exp) entry(ptr) returns(ptr),
	aq_man$save_aq entry(ptr,fixed bin),
	make_both_addressable entry(ptr,ptr,bit(1) aligned),
	expmac$interpret entry(fixed bin,ptr,(3) ptr,(3) bit(1) aligned),
	expmac$fill_usage entry(fixed bin(17),fixed bin(17)),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$one_eis entry(fixed bin(15),ptr),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	load$for_test entry(ptr,fixed bin),
	aq_man$pad_aq entry(fixed bin,fixed bin),
	base_man$store_ptr_to entry(ptr,ptr),
	generate_constant$bit_string entry(bit(*) aligned,fixed bin) returns(ptr),
	store entry(ptr),
	state_man$erase_reg entry(bit(19) aligned),
	assign_op$fix_dec_scaled entry(ptr),
	get_imaginary entry(ptr) returns(ptr),
	expmac$zero entry(fixed bin(15)),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac entry(fixed bin(15),ptr);

dcl	(abs,addr,addrel,bit,fixed,max,min,null,string,ceil,substr) builtin;

dcl	1 instruction	aligned based,
	2 left		unal bit(18),
	2 op_code		unal bit(9),
	2 rest		unal bit(9);

dcl (	z2 based(addr(zero(2))),
	z3 based(addr(zero(3))),
	c2 based(addr(const(2))),
	c3 based(addr(const(3)))) bit(1) aligned;

dcl (	scale1 defined(scale(1)),
	scale2 defined(scale(2)),
	scale3 defined(scale(3))) fixed bin;

dcl	fix_bin		fixed bin based,
	flt_bin		float bin based,
	fix_bin_71	fixed bin(71) based,
	flt_bin_63	float bin(63) based,
	bit_72		bit(72) aligned based;

dcl (	stfx1		init(15),
	ana		init(40),
	eraq		init(54),
	oraq		init(48),
	anaq		init(42),
	cana		init(615),
	canaq		init(617),
	fx1_to_fx2	init(88),
	make_lv		init(173),
	set_label_const	init(315),
	compare_labels	init(325),
	compare_files	init(280),
	comp_decimal	init(532),
	jump_ne		init(181),
	cpbs3		init(226),
	set_chars		init(436),
	cp_chars		init(186),
	cpcs1		init(140),
	cpbs1		init(149),
	cpfx1		init(136),
	cpfl1		init(138),
	clear_aq		init(58)) fixed bin(15) int static;

dcl	1 decimal_constant based aligned,
	2 sign char(1) unal,
	2 magnitude char(prec) unal,
	2 exponent bit(9) unal;

dcl	1 packed_decimal_constant based aligned,
	2 sign_and_magnitude bit(ceil(bits_per_packed_digit*(prec+1))) unal,
	2 exponent bit(9) unal;

%include cgsystem;
%include reference;
%include label;
%include nodes;
%include block;
%include symbol;
%include operator;
%include data_types;
%include declare_type;
%include machine_state;

begin:	reversed, check_scale = "0"b;
	node_pt = pt;
	b2 = bit(fixed(code,2),2);
	atom(2) = substr(b2,1,1);
	atom(3) = substr(b2,2,1);

	p2 = p2_par;
	p3 = p3_par;

	if machine_state.indicators = -2
	then if p2 = indicators_ref(2)
	     then if p3 = indicators_ref(3)
		then do;
		     call adjust_refs;
		     return(0);
		     end;
		else;
	     else if p3 = indicators_ref(2)
		then if p2 = indicators_ref(3)
		     then do;
			call adjust_refs;
			return(1);
			end;

	q2 = node_pt -> operand(2);
	type2 = p2 -> reference.data_type;
	p2s = p2 -> reference.symbol;

	scale2 = p2s -> symbol.scale;
	c2 = p2s -> symbol.constant & p2 -> reference.offset = null & p2 -> reference.c_offset = 0;

	if code = 5
	then do;
	     z3 = "1"b;
	     goto str;
	     end;

	q3 = node_pt -> operand(3);
	type3 = p3 -> reference.data_type;
	p3s = p3 -> reference.symbol;

	s2, s3 = 0;

	if p2s -> node.type = label_node then goto lv1;
	if p2s -> symbol.label | p2s -> symbol.format | p2s -> symbol.entry
	     then go to label_compare;

	if p2s -> symbol.file then goto file_compare;

	refs(1) = null;

	if p2s -> symbol.ptr
	then do;

	     /* have comparision of two pointers.  check to see if we are comparing
	        a packed ptr with null, if so replace the null with a packed representation.
	        note that we assume that null is the only pointer constant */

	     if p2 -> reference.data_type = packed_ptr
	     then if p3s -> symbol.constant
		then do;
		     p3 = generate_constant$real_fix_bin_1(cg_stat$packed_null_value);
		     p3 -> reference.data_type = packed_ptr;
		     end;
		else;
	     else if p3 -> reference.data_type = packed_ptr
		then if p2s -> symbol.constant
		     then do;
			p2 = generate_constant$real_fix_bin_1(cg_stat$packed_null_value);
			p2 -> reference.data_type = packed_ptr;
			end;

	     call expmac$interpret(compare_ptrs$compare_ptrs,node_pt,refs,atom);
	     goto cp_exit;
	     end;

	z2, z3 = "0"b;

	scale3 = p3s -> symbol.scale;
	c3 = p3s -> symbol.constant & p3 -> reference.offset = null & p3 -> reference.c_offset = 0;

	if p2s -> symbol.decimal & p3s -> symbol.decimal
	then do;
	     do i = 2 to 3;
		if atom(i)
		then if const(i)
		     then if ^ sym(i) -> symbol.complex
			then do;
			     prec = sym(i) -> symbol.c_dcl_size;
			     if sym(i) -> symbol.unaligned
			     then zero(i) = substr(sym(i) -> symbol.initial -> packed_decimal_constant.sign_and_magnitude,6) = ""b;
			     else zero(i) = sym(i) -> symbol.initial -> decimal_constant.magnitude = substr((64)"0",1,prec);
			     end;
			else;
		     else;
		else refs(i) = compile_exp$save_exp((node_pt -> operand(i)));
		end;

	     /* If one of the operands is zero, see if the last operation set the indicators
	        for the other operand */

	     if z2
		then call flip_rands;

	     if z3
	     then do;
		if p2 -> reference.value_in.decimal_aq
		then if machine_state.indicators = 14
		     then do;
			if ^ p2 -> reference.shared
			     then call adjust_ref_count(p2,-1);
			go to cp_exit;
			end;
		call compare_decimal;
		end;

	     else do;
		if max(scale2,scale3) <= max_dec_scale & min(scale2,scale3) >= min_dec_scale
		then call compare_decimal;

		else if type2 = type3 & abs(scale2 - scale3) <= max_dec_scale - min_dec_scale
		     then do;
			if scale2 > scale3
			     then k = min_dec_scale;
			     else k = max_dec_scale;
			p2s -> symbol.scale = k + (scale2 - scale3);
			p3s -> symbol.scale = k;

			call compare_decimal;

			p2s -> symbol.scale = scale2;
			p3s -> symbol.scale = scale3;
			end;

		     else do;
			do i = 2 to 3;
			     if scale(i) > max_dec_scale | scale(i) < min_dec_scale
				then call assign_op$fix_dec_scaled(refs(i));
			     end;

			call compare_decimal;
			end;
		end;

	     go to cp_exit;
	     end;

	if p2s -> symbol.complex | p3s -> symbol.complex
	then do;
	     if ^ inline_operation(node_pt,refs,atom)
		then call gen_arithmetic_call(node_pt,refs,atom);
	          else call expmac$interpret(complex_stuff$complex_compare,node_pt,refs,atom);
	     goto cp_exit;
	     end;

	if type2 <= real_fix_bin_2
	then do;

	     mac1 = cpfx1;
	     mac2 = fx1_to_fx2;

	     type1 = max(type2,type3);
	     scale1 = max(scale2,scale3);

	     if scale1 ^= scale2
	     then do;
		atom(2) = "0"b;
		goto l1;
		end;

	     if scale1 ^= scale3
	     then do;
		atom(3) = "0"b;

l1:		check_scale = "1"b;
		code = fixed(atom(2) || atom(3),2);
		end;

	     s1 = type1 - real_fix_bin_1;
	     s2 = type2 - real_fix_bin_1;
	     s3 = type3 - real_fix_bin_1;

	     if c2
	     then do;
		t = p2s -> symbol.initial;
		if s2 = 0 then z2 = t -> fix_bin = 0;
		else z2 = t -> fix_bin_71 = 0;
		end;

	     if c3
	     then do;
		t = p3s -> symbol.initial;
		if s3 = 0 then z3 = t -> fix_bin = 0;
		else z3 = t -> fix_bin_71 = 0;
		end;

sk:	     k = 2*s2 + s3;
	     goto arith_sw(code);
	     end;

	if type2 <= real_flt_bin_2
	then do;

	     mac1 = cpfl1;
	     mac2 = 0;

	     s2 = type2 - real_flt_bin_1;
	     s3 = type3 - real_flt_bin_1;

	     if c2
	     then do;
		t = p2s -> symbol.initial;
		if s2 = 0 then z2 = t -> flt_bin = 0.0e0;
		else z2 = t -> flt_bin_63 = 0.0e0;
		end;

	     if c3
	     then do;
		t = p3s -> symbol.initial;
		if s3 = 0 then z3 = t -> flt_bin = 0.0e0;
		else z3 = t -> flt_bin_63 = 0.0e0;
		end;

	     goto sk;
	     end;

	/* have string comparsion */

str:	if p2 -> reference.long_ref | p2 -> reference.varying_ref | p2 -> reference.hard_to_load then s2 = 5;
	else do;

	     size2 = p2 -> reference.c_length * convert_size(type2);
	     s2 = 2 * fixed(size2 > bits_per_word,1);

	     if c2 & type2 = bit_string
		then z2 = substr(p2s -> symbol.initial -> bit_72,1,size2) = "0"b;

	     end;

	dt = type2 - char_string;

	if dt = 0 then op = cpcs1; else op = cpbs1;

	if code < 5 then goto st_cp;

	/* have true|false comparison */

st_0:	if s2 < 5
	then do;

	     /* string is short, load value into aq and compare
	        with zero, if necessary */

	     if p2 = q2
	     then do;
lft:		call load$for_test(p2,s2);
		goto cp_exit;
		end;

	     if p2 -> reference.evaluated then goto lft;

	     call compile_exp$for_test(q2);

	     if s2 = 0 then goto cp_exit;

	     /* not single word string, can skip compare if
	        last macro set indicators for entire AQ */

	     n = cg_stat$last_macro;
	     if n = eraq then goto cp_exit;
	     if n = oraq then goto cp_exit;
	     if n = anaq then goto cp_exit;

	     /* If last operation was and_for_test, 
	        then indicators were set correctly */

	     if n = cana then go to cp_exit;
	     if n = canaq then goto cp_exit;

	     p3 = c_a(0,5);

	     s3 = s2;
	     goto st_aa_4;
	     end;

	/* have long string */

	if ^ atom(2)
	then if q2 -> node.type ^= reference_node
	     then if ^ p2 -> reference.evaluated
		then do;
		     call compile_exp$for_test(q2);
		     if machine_state.indicators = 0
		     then do;
			if ^ p2 -> reference.shared
			     then call adjust_ref_count(p2,-1);
			go to cp_exit;
			end;
		     end;

	call expmac$one_eis((cpbs3),p2);

	goto cp_exit;

	/* must actually compare two strings,
	   encode length of right */

st_cp:	if p3 -> reference.long_ref | p3 -> reference.varying_ref | p3 -> reference.hard_to_load then s3 = 5;
	else do;

	     size3 = p3 -> reference.c_length * convert_size(type3);
	     s3 = 2 * fixed(size3 > bits_per_word,1);

	     if c3 & type3 = bit_string
		then z3 = substr(p3s -> symbol.initial -> bit_72,1,size3) = "0"b;

	     end;

	if z2 then call flip_rands;

	if z3
	then if substr(node_pt -> operator.op_code,7,2) = "11"b /* equal, not_equal, jump_if_eq, jump_if_ne */
	     then go to st_0;

	goto string_sw(code);

	/* have atm : atm */

string_sw(3):
st_aa:	if s2 + s3 > 4
	     then go to st_ee_1;	/* at least one of the operands is long */

	/* if p3 in a, flip */

	if p3 -> reference.value_in.a then call flip_rands;

	/* both operands are short, check for char string */

	if type2 = char_string
	then do;

	     /* for char string comparisons, we must pad shorter
	        string to length of longer.  put longer on right */

	     if size2 > size3 then call flip_rands;
	     end;

	else if s2 > s3
	     then call flip_rands;

	/* have one aligned string in storage */

st_aa_2:	call load(p2,s2);

st_aa_3:	if type2 = char_string
	then do;

	     /* pad shorter string to length of longer */

	     call aq_man$pad_aq(type2,size3);
	     k = 0;
	     end;
	else do;
st_aa_4:	     k = 3*fixed(a_reg.size > bits_per_word,1);
	     end;

	macro = op + k;

	call expmac$one(macro,p3,s3);

	call update_indicators;

	/* comparison done */

cp_exit:	return(fixed(reversed,1));

	/* have atm : exp */

string_sw(2):
st_ae:	call flip_rands;

	/* have exp:atm */

string_sw(1):
st_ea:	if s2 = 5
	then do;

	     /* expression is long */

	     if q2 -> node.type ^= reference_node
		then call compile_exp(q2);
	     goto st_ee_1;
	     end;

	/* expression is short */

	if s3 = 5
	then do;

	     /* atm on right is long */

	     p2 = compile_exp$save_exp(q2);
	     go to st_ee_1;
	     end;

	/* right operand is short also */

	if type2 = char_string
	then if size2 > size3
	     then do;
		p2 = compile_exp$save(q2);
		call flip_rands;
		go to st_aa_2;
		end;

	call compile_exp(q2);

	goto st_aa_3;

	/* have exp : exp */

string_sw(0):
st_ee:	if s2 > s3 then call flip_rands;
	if s2+s3 >= 5 then goto st_ee_2;
	if size2 > size3 then call flip_rands;

	/* now have longer string on right */

	if s3 < 5
	then do;

	     /* both strings are short */

	     p3 = compile_exp$save(q3);
	     call compile_exp(q2);
	     goto st_aa_3;
	     end;

	/* have long string on right */

st_ee_2:

	/* one or both strings are long, compile left expression, then
	   save temp ptr in stack (p2 is altered) */

	p2 = compile_exp$save_exp(q2);

	/* compile right expression */

	if q3 -> node.type ^= reference_node
	     then call compile_exp(q3);

st_ee_1:	call expmac$two_eis(cp_chars+dt,p2,p3);
	call update_indicators;
	goto cp_exit;

	/*		Arithmetic comparisons */

	/* have atm : atm */

arith_sw(3):
ar_aa:	if p3 -> reference.value_in.q then call flip_rands;

	if k = 2 | z2 then call flip_rands;

ar_aa_0:	if z3 
	then do;
	     call load$for_test(p2,0);
	     goto cp_exit;
	     end;

	if z2
	then do;
	     reversed = ^ reversed;
	     call load$for_test(p3,0);
	     goto cp_exit;
	     end;

ar_aa_3:	call load(p2,0);

arith_ea_sw(1):
ar_aa_1:	if type2 < type3
	then if mac2 ^= 0
	     then call expmac$zero(mac2);

arith_ea_sw(0):
arith_ea_sw(3):
ar_aa_2:	call expmac(mac1+s3,p3);
	call update_indicators;
	goto cp_exit;

	/* have exp : exp */

arith_sw(0):
ar_ee:	if k = 2 then call flip_rands;

	if check_scale & scale1 ^= scale3
	then do;
	     p3 = compile_exp$save_fix_scaled(q3,scale1,type1);
	     type3 = type1;
	     s3 = s1;
	     end;
	else p3 = compile_exp$save(q3);

	call compile_exp(q2);
	if check_scale & scale1 ^= scale2
	then do;
	     call aq_man$fix_scale(p2,scale1,type1);
	     type2 = type1;
	     s2 = s1;
	     end;

	goto ar_aa_1;

	/* have atm : exp */

arith_sw(2):
ar_ae:	call flip_rands;

	/* have exp : atm */

arith_sw(1):
ar_ea:	if z3
	then if p2 = q2
	     then do;
		call load$for_test(p2,0);
		go to cp_exit;
		end;

	/* if we may need to save the result later, we must increment the ref_count now */

	if k = 2
	then if ^ p2 -> reference.shared
	     then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;

	call compile_exp(q2);

	if check_scale & scale1 ^= scale2
	then do;
	     call aq_man$fix_scale(p2,scale1,type1);
	     type2 = type1;
	     s2 = s1;
	     k = 2*s2 + s3;
	     end;

	if z3
	then if machine_state.indicators >= 0
	     then do;
		if k = 2
		then if ^ p2 -> reference.shared
		     then call adjust_ref_count(p2,-1);
		go to cp_exit;
		end;

	goto arith_ea_sw(k);

arith_ea_sw(2):
	call aq_man$save_aq(p2,0);
	call flip_rands;
	goto ar_aa_3;

	/* We have comparison of labels, entries, or formats */

label_compare:
	if p2s -> symbol.constant
	then do;
lv1:	     ext_ent = (type2 = ext_entry_out) | (type2 = ext_entry_in);
	     k = cg_stat$cur_level - p2s -> symbol.block_node -> block.level;

	     if k = 0 | ext_ent
	     then do;
		arg(1) = c_a(56,4);
		if ext_ent
		then do;
		     arg(1) -> reference.data_type = unpacked_ptr;
		     call base_man$store_ptr_to(p2,arg(1));

		     p2 = generate_constant$bit_string(cg_stat$null_value,(bits_per_two_words));
		     p2 -> reference.data_type = unpacked_ptr;
		     call load(p2,0);
		     toff = arg(1) -> address.offset;
		     arg(1) -> address.offset = bit(fixed(fixed(toff,15)+2,15),15);
		     call store(arg(1));
		     arg(1) -> address.offset = toff;
		     end;
		else do;
		     call base_man$load_var(2,p2,1);
		     call expmac((set_label_const),arg(1));
		     end;
		end;
	     else do;
		arg(1) = p2;
		if ^ p2 -> reference.shared
		     then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
		arg(2) = c_a(k,2);
		call expmac$many((make_lv),addr(arg),2);

		string(p2 -> reference.address) = string(cg_stat$long_string_temp -> reference.address);
		p2 -> reference.relocation = cg_stat$long_string_temp -> reference.relocation;
		p2 -> reference.perm_address = "1"b;
		p2 -> reference.ic_ref = "0"b;
		end;
	     p2 -> reference.forward_ref = "0"b;

lv2:	     arg(2) = p3;
	     p2 = create_label(cg_stat$cur_block,null,(by_compiler));
	     arg(3) = prepare_operand(p2,1,atomic);
	     call expmac$many((compare_labels),addr(arg),3);
	     call expmac$fill_usage(cg_stat$text_pos,(p2 -> label.location));
	     goto cp_exit;
	     end;

	if p3s -> node.type = label_node
	then do;
lv3:	     call flip_rands;
	     goto lv1;
	     end;

	if p3s -> symbol.constant then goto lv3;

file_compare:
	call state_man$erase_reg("11"b);	/* a and q must not be used for addressing */
	call make_both_addressable(p2,p3,"1"b);

	arg(1) = p2;
	if ^p2s -> symbol.file then go to lv2;
	arg(2) = p3;
	call expmac$many((compare_files),addr(arg),2);
	goto cp_exit;


update_indicators:	proc;

	     /* a compare instruction has been used to set the indicators,
	        update machine_state with appropriate refs or punt */

	     if p2 -> reference.allocate & p3 -> reference.allocate
	     then do;
		indicators_ref(2) = p2;
		indicators_ref(3) = p3;
		machine_state.indicators = -2;
		end;
	     else machine_state.indicators = -1;

	     end;


compare_decimal:	proc;

dcl	     (lab,lab_ref,imag(2:3)) ptr;

	     if type2 > real_flt_dec
	     then do i = 2 to 3;
		imag(i) = get_imaginary(refs(i));
		end;

	     call expmac$two_eis((comp_decimal),p2,p3);

	     if type2 <= real_flt_dec
	     then do;
		if ^ z3
		     then call update_indicators;
		return;
		end;

	     lab = create_label(cg_stat$cur_block,null,(by_compiler));
	     lab_ref = prepare_operand(lab,1,atomic);
	     call expmac((jump_ne),lab_ref);
	     call expmac$two_eis((comp_decimal),imag(2),imag(3));
	     call expmac$fill_usage(cg_stat$text_pos,(lab -> label.location));
	     call update_indicators;

	     end;



flip_rands:    proc;

dcl	     p ptr,
	     z bit(1) aligned,
	     t fixed bin;

	     p = p2; p2 = p3; p3 = p;
	     p = q2; q2 = q3; q3 = p;
	     p = p2s; p2s = p3s; p3s = p;

	     t = type2; type2 = type3; type3 = t;
	     t = s2; s2 = s3; s3 = t;
	     t = size2; size2 = size3; size3 = t;
	     t = scale2; scale2 = scale3; scale3 = t;

	     z = atom(2);
	     atom(2) = atom(3);
	     atom(3) = z;
	     code = fixed(atom(2) || atom(3),2);

	     z = z2; z2 = z3; z3 = z;
	     k = 2*s2 + s3;
	     reversed = ^reversed;
	     end;


adjust_refs:   proc;

	     if ^ p2 -> reference.shared
		then call adjust_ref_count(p2,-1);
	     if ^ p3 -> reference.shared
		then call adjust_ref_count(p3,-1);

	     end;

	end;




		    stack_temp.pl1                  10/03/83  1730.5rew 10/03/83  1009.2       62685



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


/* Procedure to manage allocation of temporaries in stack

	Modified:	23 April 1973 by RAB
	Modified:	1 May 1977 by RAB to fix bug in assign_aggregate
	Modified:	10 September 1977 by RAB to fix 1613 by setting temporary.last_freed
	Modified 780717 by PG to count number of temporary nodes allocated
	Modified 791016 by PG to check temporary.ref_count < 0
*/

stack_temp$assign_temp: proc(ref_pt) ;

/* parameters */

dcl	ref_pt ptr parameter;	/* points at temp reference to be allocated */

/* external static */

dcl	(cg_stat$cur_block,cg_stat$cur_statement,cg_stat$agg_temps) ptr ext,
	cg_stat$max_stack_size fixed bin ext,
	cg_stat$text_pos fixed bin(18) ext,
	cg_stat$extended_stack bit(1) ext,
	pl1_stat_$node_uses (18) fixed bin external static;

/* automatic */

dcl	(p,r,s,o) ptr,
	atomic bit(1) aligned,
	(size,bit_length) fixed bin;

/* entries */

dcl	error entry(fixed bin,ptr,ptr),
	cg_error entry(fixed bin,fixed bin),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	compile_exp entry(ptr),
	expmac$zero entry(fixed bin(15)),
	expmac entry(fixed bin(15),ptr),
	c_a entry(fixed bin(18),fixed bin) returns(ptr);

/* internal static */

dcl (	alloc_words	init(91),
	store_bp		init(61)) fixed bin(15) int static;

/* builtins */

dcl	(bin, divide, mod, null) builtin;

/* include files */

%include pl1_tree_areas;
%include temporary;
%include nodes;
%include block;
%include reference;
%include symbol;
%include machine_state;
%include cgsystem;
%include data_types;

/* program */

	r = ref_pt;
	s = r -> reference.symbol;

	if r -> reference.aggregate
	then do;

	     /* this is aggregate temp so assign storage to level 1 ancestor
	        if none already assigned */

	     r -> reference.allocated = "1"b;

	     do p = s repeat(p -> symbol.father) while(p -> symbol.father ^= null);
		end;

	     if p -> symbol.initial = null then goto agg; else return;
	     end;

	if s = null
	then if r -> reference.data_type = 0
	     then size = r -> reference.c_length;
	     else go to get_length;
	else if s -> symbol.temporary
	     then size = s -> symbol.c_word_size;
	     else do;
get_length:	bit_length = r -> reference.c_length;
		if r -> reference.data_type = char_string
		     then bit_length = bit_length * bits_per_char;
		size = divide(bit_length+bits_per_word-1,bits_per_word,17,0);
		end;

common:	r -> reference.qualifier = get_temp(size);
	r -> reference.qualifier -> temporary.ref_count = 1;
	r -> reference.allocated = "1"b;

	if ^ r -> reference.address_in.storage
	then if r -> reference.varying_ref
	     then r -> reference.c_offset = r -> reference.c_offset + 1;

	return;

stack_temp$assign_block: entry(ref_pt,amount);

dcl	amount fixed bin;

	r = ref_pt;
	size = amount;
	goto common;

stack_temp$free_temp: entry(ref_pt);

	r = ref_pt;

	s = r -> reference.qualifier;
	if s = null then return;

	if s -> node.type ^= temporary_node then return;

	if (r -> reference.ref_count < 0) | (s -> temporary.ref_count < 0)
	then do;
	     call error(314,cg_stat$cur_statement,r);
	     return;
	     end;

	r -> reference.qualifier = null;

	call put_temp(s);
	return;

stack_temp$assign_return_value:	entry(sym_pt);

	p = sym_pt;

	r = get_temp(2);
	p -> symbol.initial = r;

	go to chain_agg;

stack_temp$assign_aggregate: entry(sym_pt);

dcl	sym_pt ptr;

	p = sym_pt;

agg:	if p -> symbol.word_size = null then size = p -> symbol.c_word_size;
	else do;
	     o = p -> symbol.word_size;
	     r = prepare_operand(o,1,atomic);
	     call compile_exp(o);
	     call expmac$zero((alloc_words));
	     cg_stat$extended_stack = "1"b;
	     size = 2;
	     end;

	r = get_temp(size);
	p -> symbol.initial = r;

	if p -> symbol.word_size ^= null
	then do;
	     call expmac((store_bp),c_a(r -> temporary.location,4));
	     base_regs(1).type = 3;
	     base_regs(1).constant = r -> temporary.location;
	     end;

chain_agg:
	r -> temporary.symbol = p;
	r -> temporary.next = cg_stat$agg_temps;
	cg_stat$agg_temps = r;

	return;

stack_temp$free_aggregates: entry;

	p = cg_stat$agg_temps;
	do while(p ^= null);
	     p -> temporary.symbol -> symbol.initial = null;
	     r = p -> temporary.next;
	     call put_temp(p);
	     p = r;
	     end;

	cg_stat$agg_temps = null;
	return;

get_temp:	     proc(amount) returns(ptr);

dcl	     (amount,amt,loc,i) fixed bin,
	     (cb,s,prev,p) ptr;

	     cb = cg_stat$cur_block;
	     loc = cb -> block.last_auto_loc;

	     amt = amount;
	     if amt >= 3 then goto big;

	     if amt = 0 then amt = 1;

	     i = amt;
	     p = cb -> block.free_temps(i);

	     if p ^= null
	     then do;
l0:		cb -> block.free_temps(i) = p -> temporary.next;
l1:		return(p);
		end;

	     if i = 1
	     then do;
l3:		p = create_temp(amt);
		cb -> block.last_auto_loc = loc + amt;

		if cb -> block.last_auto_loc > cg_stat$max_stack_size
		then call cg_error(308,cg_stat$max_stack_size);

		goto l1;
		end;

l4:	     if mod(loc,2) = 0 then goto l3;

	     p = create_temp(1);
	     p -> temporary.next = cb -> block.free_temps(1);
	     cb -> block.free_temps(1) = p;
	     loc = loc + 1;
	     goto l3;

big:	     prev = null;
	     i = 3;
	     p = cb -> block.free_temps(3);

	     do while(p ^= null);

		if p -> temporary.size >= amt
		then do;
		     if prev = null then goto l0;
		     prev -> temporary.next = p -> temporary.next;
		     goto l1;
		     end;

		prev = p;
		p = p -> temporary.next;
		end;

	     goto l4;

put_temp:	     entry(temp);

dcl	     temp ptr;

	     cb = cg_stat$cur_block;

	     s = temp;
	     s -> temporary.last_freed = cg_stat$text_pos;
	     i, amt = s -> temporary.size;

	     if i < 3
	     then do;
l5:		s -> temporary.next = cb -> block.free_temps(i);
		cb -> block.free_temps(i) = s;
		return;
		end;

	     prev = null;
	     i = 3;
	     p = cb -> block.free_temps(3);

	     do while(p ^= null);

		if amt < p -> temporary.size
		then do;
l6:		     if prev = null then goto l5;
		     s -> temporary.next = prev -> temporary.next;
		     prev -> temporary.next = s;
		     return;
		     end;

		prev = p;
		p = p -> temporary.next;
		end;

	     goto l6;

create_temp:	proc(number) returns(ptr);

dcl		number fixed bin,
		q ptr;

		allocate temporary in(xeq_tree_area) set(q);
		pl1_stat_$node_uses (bin (temporary_node, 9)) = pl1_stat_$node_uses (bin (temporary_node, 9)) + 1;
		q -> temporary.node_type = temporary_node;
		q -> temporary.location = loc;
		q -> temporary.size = number;
		return(q);

		end;

	     end;

	end;




		    state_man.pl1                   09/22/89  1403.5rew 09/22/89  1358.2      299997



/****^  ***********************************************************
        *                                                         *
        * 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-02-27,Huen), approve(87-02-27,MCR7625), audit(87-02-27,RWaters),
     install(87-05-21,MR12.1-1033):
     Fix High priority
     bug2106 ::  When a PL/1 stack frame is larger than 2 ** 14 words, bad code
     is generated for the put_edit statement.
  2) change(89-07-28,JRGray), approve(89-07-28,MCR8123), audit(89-09-12,Vu),
     install(89-09-22,MR12.3-1073):
     Added the state_man_$save_regs ep to save temp values (pl1 2091 2177).
                                                   END HISTORY COMMENTS */
/* Procedure to manage the machine state nodes

   Initial Version: 27 April 1971 by BLW
	Modified:  4 November 1972 by BLW 	
	Modified:  15 February 1973 by RAB
	Modified:	11 June 1973 by RAB for EIS
	Modified:	29 May 1974 by RAB to save the string aq
	Modified:	16 November 1974 by RAB to fix bug 1223
	Modified:	18 November 1974 by RAB to fix 1258
	Modified:	5 June 1975 by RAB for separate_static
	Modified:	13 October 1975 by RAB to remember comparisons
	Modified:	1 November 1975 by RAB to check save_temps bit
	Modified:	24 November 1975 by RAB to check aggregate bit in save_temp
	Modified:	8 January 1976 by RAB to fix bug 1452 in merge_ms
	Modified:	29 April 1976 by RAB to fix bug 1494
	Modified:	23 June 1976 by RAB to centralize use of cg_stat$last_call	
	Modified:	25 March 1977 by RAB to fix 1599	
	Modified: April 1977 by RHS to change allocation scheme of xeq_tree_area
	Modified:	1 May 1977 by RAB to fix 1612
	Modified:	1 September 1977 by RAB to add state_man$flush_sym in order to fix 1664
	Modified 780717 by PG to count machine_state nodes allocated
	Modified:	7 August 1978 by RAB to fix 1751 by allowing save_temp to save complex_flt_bin_1 temps
          Modified: 30 January 1987 by SH&RW fixed bug 2106
*/

state_man$create_ms: proc (pt);

	dcl     pt		 ptr;		/* points at machine state node */

	dcl     (p, q)		 ptr,
	        sym		 ptr auto unal,
	        (erase, b19)	 bit (19) aligned,
	        (prev_state, found)	 bit (1) aligned,
	        text_pos		 fixed bin (18),
	        (i, j, n)		 fixed bin;

	dcl     (cg_stat$ms_list, cg_stat$m_s_p) ptr ext,
	        (cg_stat$text_pos, cg_stat$last_call) fixed bin (18) ext,
	        pl1_stat_$node_uses	 (18) fixed bin external static;

	dcl     c_a		 entry (fixed bin (18), fixed bin) returns (ptr),
	        expmac		 entry (fixed bin (15), ptr),
	        expmac$one		 entry (fixed bin (15), ptr, fixed bin (15)),
	        expmac$one_eis	 entry (fixed bin (15), ptr),
	        stack_temp$assign_block entry (ptr, fixed bin);

	dcl     (abs, bin, bit, fixed, index, min, mod, null, string, substr) builtin;

%include pl1_tree_areas;
%include cgsystem;
%include machine_state;
%include reference;
%include symbol;
%include operator;
%include list;
%include statement;
%include block;
%include nodes;
%include data_types;
%include boundary;
%include temporary;

	call get_ms;
	pt = m_s_p;

init:	machine_state.next,
	     string_reg.variable,
	     complex_reg.variable,
	     decimal_reg.variable = null;

	do i = 0 to 7;
	     index_regs (i).type = 0;
	     base_regs (i).type = 0;
	     base_regs (i).locked = 0;
	end;

init1:	machine_state.indicators,
	     a_reg.constant,
	     q_reg.constant,
	     a_reg.number_h_o,
	     q_reg.number_h_o,
	     a_reg.number,
	     q_reg.number,
	     a_reg.changed,
	     q_reg.changed = 0;

	a_reg.locked,
	     q_reg.locked,
	     a_reg.instruction,
	     q_reg.instruction = "0"b;

	cg_stat$last_call = cg_stat$text_pos;

	return;

state_man$save_ms: entry (pt, cond);

/* this entry is called to append a copy of the current machine
	   state to the list of states on a specified statement node */

	dcl     cond		 bit (1) aligned;	/* "1"b if transfer is conditional */

	dcl     (conditional, optimize) bit (1) aligned;

	p = pt;
	optimize = ^p -> statement.save_temps;

	conditional = cond;

	if conditional
	then do;
		call get_ms;
		m_s_p -> machine_state = cg_stat$m_s_p -> machine_state;
	     end;

	machine_state.next = p -> statement.state_list;
	p -> statement.state_list = m_s_p;
	p -> statement.reference_count = p -> statement.reference_count - 1;

	q = p -> statement.reference_list;

/* see if any of the expressions in the active registers have to be
	   saved because they will be needed at the statement being transfered 
	   to.  Also, turn off bit saying reference is in a register if this
	   is forward unconditional transfer */

	do i = 1 to a_reg.number;
	     p = a_reg.variable (i);
	     if need_ref () then call save_temp (1);
	     if ^conditional then p -> reference.value_in.a = "0"b;
	end;

	do i = 1 to q_reg.number;
	     p = q_reg.variable (i);
	     if need_ref () then call save_temp (2);
	     if ^conditional then p -> reference.value_in.q = "0"b;
	end;

	do i = 0 to 7;
	     if index_regs (i).type >= 2
	     then do;
		     p = index_regs (i).variable;
		     if p ^= null
		     then do;
			     if need_ref () then call save_temp (0);
			     if ^conditional then p -> reference.value_in.x (i) = "0"b;
			end;
		end;
	end;

	do i = 1 to 6;
	     p = base_regs (i).variable;
	     n = base_regs (i).type;
	     if p = null then n = 0;
	     if n = 1
	     then do;
		     if need_ref () then call save_temp (-i);
		     if ^conditional then p -> reference.value_in.b (i) = "0"b;
		end;
	     else if n = 2
	     then if ^conditional then p -> reference.address_in.b (i) = "0"b;
	end;

	if ^conditional
	then do;

		p = complex_reg.variable;
		if p ^= null then p -> reference.value_in.complex_aq = "0"b;

		p = string_reg.variable;
		if p ^= null then p -> reference.value_in.string_aq = "0"b;

		p = decimal_reg.variable;
		if p ^= null then p -> reference.value_in.decimal_aq = "0"b;

		cg_stat$m_s_p = null;
	     end;

	cg_stat$last_call = cg_stat$text_pos;

	return;

state_man$save_regs: entry (pt);

/* This entrypoint will see if any of the expressions in the active
   registers have to be saved because they will be needed at the statement
   being transfered to.  This is part of the job that state_man$save_ms does
   but is done here so that register saving will not clobber the indicators.
   This occurs when another register (usually an X register) is loaded in
   order to get a big enough offset to store a useful register. (PL1 2091) */

	p = pt;
	optimize = ^p -> statement.save_temps;	/* used by need_ref */
	q = p -> statement.reference_list;	/* used by need_ref */

	do i = 1 to a_reg.number;
	     p = a_reg.variable (i);
	     if need_ref () then call save_temp (1);
	end;

	do i = 1 to q_reg.number;
	     p = q_reg.variable (i);
	     if need_ref () then call save_temp (2);
	end;

	do i = 0 to 7;
	     if index_regs (i).type >= 2
	     then do;
		     p = index_regs (i).variable;
		     if p ^= null then if need_ref () then call save_temp (0);
		end;
	end;

	do i = 1 to 6;
	     p = base_regs (i).variable;
	     if p ^= null then
		if base_regs (i).type = 1 then
		     if need_ref () then call save_temp (-i);
	end;

	return;	/* end of save_regs */

state_man$merge_ms: entry (pt);

/* this entry is called to merge the machine states
	   attached to a statement node */

	if pt -> statement.reference_count = 0
	then erase = "0"b;
	else erase = (19)"1"b;

	p = pt -> statement.state_list;

	if m_s_p = null
	then do;

/* previous statement was unconditional transfer */

		if p = null
		then do;
			call get_ms;
			cg_stat$m_s_p = m_s_p;
			goto init;
		     end;

		m_s_p, cg_stat$m_s_p = p;
		p = machine_state.next;
		prev_state = "0"b;
	     end;

	else prev_state = "1"b;

	if erase
	then machine_state.indicators = 0;

	do while (p ^= null);

	     if machine_state.indicators ^= p -> machine_state.indicators
	     then machine_state.indicators = 0;
	     else if machine_state.indicators = -2
	     then if indicators_ref (2) ^= p -> indicators_ref (2)
		then machine_state.indicators = 0;
		else if indicators_ref (3) ^= p -> indicators_ref (3)
		then machine_state.indicators = 0;

	     if substr (erase, 1, 1) then goto scrub_a;

	     if a_reg.size ^= p -> a_reg.size
	     then do;
erase_a:		     substr (erase, 1, 1) = "1"b;

scrub_a:		     do j = 1 to p -> a_reg.number;
			q = p -> a_reg.variable (j);
			if q ^= null then q -> reference.value_in.a = "0"b;
		     end;


		     goto chk_q;
		end;

	     if a_reg.length ^= p -> a_reg.length then goto erase_a;
	     if a_reg.offset ^= p -> a_reg.offset then goto erase_a;
	     if a_reg.constant ^= p -> a_reg.constant then goto erase_a;

	     n = a_reg.number;
	     do i = 1 by 1 while (i <= n);

scan_a:		q = a_reg.variable (i);

		do j = 1 to p -> a_reg.number;
		     if q = p -> a_reg.variable (j)
		     then do;
			     p -> a_reg.variable (j) = null;
			     goto ok_a;
			end;
		end;

		q -> reference.value_in.a = "0"b;

		n = n - 1;
		if n = 0 then goto erase_a;
		if n < i then goto end_a;

		do j = i to n;
		     a_reg.variable (j) = a_reg.variable (j + 1);
		end;

		goto scan_a;

ok_a:	     end;

end_a:	     a_reg.number = n;

chk_q:	     if substr (erase, 2, 1) then goto scrub_q;

	     if q_reg.size ^= p -> q_reg.size
	     then do;
erase_q:		     substr (erase, 2, 1) = "1"b;

scrub_q:		     do j = 1 to p -> q_reg.number;
			q = p -> q_reg.variable (j);
			if q ^= null then q -> reference.value_in.q = "0"b;
		     end;
		     goto chk_sr;
		end;

	     if q_reg.length ^= p -> q_reg.length then goto erase_q;
	     if q_reg.offset ^= p -> q_reg.offset then goto erase_q;
	     if q_reg.constant ^= p -> q_reg.constant then goto erase_q;

	     n = q_reg.number;
	     do i = 1 by 1 while (i <= n);

scan_q:		q = q_reg.variable (i);

		do j = 1 to p -> q_reg.number;
		     if q = p -> q_reg.variable (j)
		     then do;
			     p -> q_reg.variable (j) = null;
			     goto ok_q;
			end;
		end;

		q -> reference.value_in.q = "0"b;

		n = n - 1;
		if n = 0 then goto erase_q;
		if n < i then goto end_q;

		do j = i to n;
		     q_reg.variable (j) = q_reg.variable (j + 1);
		end;

		goto scan_q;

ok_q:	     end;

end_q:	     q_reg.number = n;

chk_sr:	     if substr (erase, 3, 1) then goto scrub_sr;

	     if string_reg.size ^= p -> string_reg.size
	     then do;
erase_sr:		     substr (erase, 3, 1) = "1"b;

scrub_sr:		     q = p -> string_reg.variable;
		     if q ^= null then q -> reference.value_in.string_aq = "0"b;
		     goto chk_cx;
		end;

	     if string_reg.variable ^= p -> string_reg.variable then goto erase_sr;

chk_cx:	     if substr (erase, 4, 1) then goto scrub_cx;

	     if complex_reg.size ^= p -> complex_reg.size
	     then do;
erase_cx:		     substr (erase, 4, 1) = "1"b;

scrub_cx:		     q = p -> complex_reg.variable;
		     if q ^= null then q -> reference.value_in.complex_aq = "0"b;
		     goto chk_d;
		end;

	     if complex_reg.scale ^= p -> complex_reg.scale then goto erase_cx;
	     if complex_reg.variable ^= p -> complex_reg.variable then goto erase_cx;

chk_d:	     if substr (erase, 5, 1) then goto scrub_d;

	     if decimal_reg.size ^= p -> decimal_reg.size
	     then do;
erase_d:		     substr (erase, 5, 1) = "1"b;

scrub_d:		     q = p -> decimal_reg.variable;
		     if q ^= null then q -> reference.value_in.decimal_aq = "0"b;
		     goto chk_xr;
		end;

	     if decimal_reg.scale ^= p -> decimal_reg.scale then goto erase_d;
	     if decimal_reg.variable ^= p -> decimal_reg.variable then goto erase_d;

chk_xr:	     do i = 0 to 7;

		if substr (erase, i + 6, 1) then goto scrub_xr;

		n = index_regs (i).type;
		if n ^= p -> index_regs (i).type
		then do;
erase_xr:			substr (erase, i + 6, 1) = "1"b;

scrub_xr:			if p -> index_regs (i).type >= 2
			then do;
				q = p -> index_regs (i).variable;
				if q ^= null then q -> reference.value_in.x (i) = "0"b;
			     end;

			goto end_xr;
		     end;

		if n >= 2
		then if index_regs (i).variable ^= p -> index_regs (i).variable
		     then goto erase_xr;

		if index_regs (i).constant ^= p -> index_regs (i).constant then goto erase_xr;

end_xr:	     end;

chk_base:	     do i = 1 to 6;

		if substr (erase, i + 13, 1) then goto scrub_base;

		n = base_regs (i).type;
		if n ^= p -> base_regs (i).type
		then do;
erase_base:		substr (erase, i + 13, 1) = "1"b;

scrub_base:		q = p -> base_regs (i).variable;

			n = p -> base_regs (i).type;
			if q = null then n = 0;
			if n = 1 then q -> reference.value_in.b (i) = "0"b;
			else if n = 2 then q -> reference.address_in.b (i) = "0"b;

			goto end_base;
		     end;

		if n = 0 then goto end_base;

		if substr ("11000110110000"b, n, 1)
		then if base_regs (i).variable ^= p -> base_regs (i).variable
		     then goto erase_base;

		if substr ("00110001111101"b, n, 1)
		then if base_regs (i).constant ^= p -> base_regs (i).constant
		     then goto erase_base;

end_base:	     end;

	     q = p;
	     p = p -> machine_state.next;

	     q -> machine_state.next = cg_stat$ms_list;
	     cg_stat$ms_list = q;
	end;

	if erase
	then call wipe;

	if prev_state | (^erase = "0"b) then return;

	if a_reg.constant = 0
	then do i = 1 to a_reg.number;
		a_reg (i).variable -> reference.value_in.a = "1"b;
	     end;

	if q_reg.constant = 0
	then do i = 1 to q_reg.number;
		q_reg (i).variable -> reference.value_in.q = "1"b;
	     end;

	q = string_reg.variable;
	if q ^= null then q -> reference.value_in.string_aq = "1"b;

	q = complex_reg.variable;
	if q ^= null then q -> reference.value_in.complex_aq = "1"b;

	q = decimal_reg.variable;
	if q ^= null then q -> reference.value_in.decimal_aq = "1"b;

	do i = 0 to 7;
	     if index_regs (i).type >= 2
	     then if index_regs (i).constant = 0
		then do;
			q = index_regs (i).variable;
			if q ^= null then q -> reference.value_in.x (i) = "1"b;
		     end;
	end;

	do i = 1 to 6;
	     q = base_regs (i).variable;
	     n = base_regs (i).type;
	     if q = null then n = 0;
	     if n = 1 then q -> reference.value_in.b (i) = "1"b;
	     else if n = 2 then q -> reference.address_in.b (i) = "1"b;
	end;

	return;

state_man$discard_ms: entry;

/* this entry is called to discard the current machine state after
	   an unconditional transfer back to a previously defined label */

	machine_state.next = cg_stat$ms_list;
	cg_stat$ms_list = m_s_p;
	cg_stat$m_s_p = null;

/* now flush state */

state_man$flush: entry;

/* this entry is called to completely flush the machine state */

	machine_state.indicators = 0;

/* save the index registers used by the operator */

	erase = ("1111100000000111111"b);
	call wipe;

/* free all registers */

	erase = (19)"1"b;
	call wipe;

	cg_stat$last_call = cg_stat$text_pos;
	return;

state_man$flush_ref: entry (pt);

/* this entry is called to flush a particular reference from
	   the machine state */

	p = pt;

	if machine_state.indicators = -2
	then if p = indicators_ref (2)
	     then machine_state.indicators = 0;
	     else if p = indicators_ref (3)
	     then machine_state.indicators = 0;

/* can't test reference.value_in because ref could
	   be in reg with a constant added */

	n = a_reg.number;
	do i = 1 to n;
	     if a_reg.variable (i) = p
	     then do;
		     a_reg.number = n - 1;

		     do i = i + 1 to n;
			a_reg.variable (i - 1) = a_reg.variable (i);
		     end;

		     goto frq;
		end;
	end;

frq:	n = q_reg.number;
	do i = 1 to n;
	     if q_reg.variable (i) = p
	     then do;
		     q_reg.number = n - 1;

		     do i = i + 1 to n;
			q_reg.variable (i - 1) = q_reg.variable (i);
		     end;

		     goto frsr;
		end;
	end;

frsr:	if string_reg.variable = p then string_reg.variable = null;

	if complex_reg.variable = p then complex_reg.variable = null;

	if decimal_reg.variable = p then decimal_reg.variable = null;

	do i = 0 to 7;
	     n = index_regs (i).type;
	     if abs (n) >= 2
	     then if index_regs (i).variable = p
		then do;
			index_regs (i).type = min (0, n);
			index_regs (i).variable = null;
		     end;
	end;

	do i = 1 to 6;
	     if base_regs (i).type = 1
	     then if base_regs (i).variable = p
		then base_regs (i).type = 0;
	end;

	string (p -> reference.value_in) = "0"b;
	return;

state_man$flush_address: entry (pt);

/* this entry is called to remove the address of a reference
	   from the machine state  */

	p = pt;

	do i = 1 to 6;
	     if base_regs (i).type = 2
	     then if base_regs (i).variable = p
		then base_regs (i).type = 0;
	end;

	string (p -> reference.address_in.b) = "0"b;
	return;

state_man$flush_sym: entry (pt);

/* this entry is called to flush all references to a particular
	   symbol from the machine state.  it should be called whenever
	   a short string is set by an EIS instruction (which does not
	   alter a register). */

	sym = pt;

	if machine_state.indicators = -2
	then if sym = indicators_ref (2) -> reference.symbol
	     then machine_state.indicators = 0;
	     else if sym = indicators_ref (3) -> reference.symbol
	     then machine_state.indicators = 0;

	i = 1;
	do while (i <= a_reg.number);
	     if sym = a_reg.variable (i) -> reference.symbol
	     then do;
		     a_reg.variable (i) -> reference.value_in.a = "0"b;
		     a_reg.number = a_reg.number - 1;
		     do j = i to a_reg.number;
			a_reg.variable (j) = a_reg.variable (j + 1);
		     end;
		end;
	     else i = i + 1;
	end;

	i = 1;
	do while (i <= q_reg.number);
	     if sym = q_reg.variable (i) -> reference.symbol
	     then do;
		     q_reg.variable (i) -> reference.value_in.q = "0"b;
		     q_reg.number = q_reg.number - 1;
		     do j = i to q_reg.number;
			q_reg.variable (j) = q_reg.variable (j + 1);
		     end;
		end;
	     else i = i + 1;
	end;

	if string_reg.variable ^= null
	then if sym = string_reg.variable -> reference.symbol
	     then do;
		     string_reg.variable -> reference.value_in.string_aq = "0"b;
		     string_reg.variable = null;
		end;

	if complex_reg.variable ^= null
	then if sym = complex_reg.variable -> reference.symbol
	     then do;
		     complex_reg.variable -> reference.value_in.complex_aq = "0"b;
		     complex_reg.variable = null;
		end;

	if decimal_reg.variable ^= null
	then if sym = decimal_reg.variable -> reference.symbol
	     then do;
		     decimal_reg.variable -> reference.value_in.decimal_aq = "0"b;
		     decimal_reg.variable = null;
		end;

	do i = 0 to 7;
	     if abs (index_regs (i).type) >= 2
	     then do;
		     q = index_regs (i).variable;
		     if sym = q -> reference.symbol
		     then do;
			     q -> reference.value_in.x (i) = "0"b;
			     index_regs (i).type = 0;
			end;
		end;
	end;

	do i = 1 to 6;
	     if base_regs (i).type = 1
	     then do;
		     q = base_regs (i).variable;
		     if sym = q -> reference.symbol
		     then do;
			     q -> reference.value_in.b (i) = "0"b;
			     base_regs (i).type = 0;
			end;
		end;
	end;

	return;

state_man$update_ref: entry (pt);

/* this entry is called to add a reference to machine state */

	p = pt;
	if p -> reference.data_type <= real_flt_bin_2 then goto up_q;

	if p -> reference.data_type <= complex_flt_bin_2
	then do;

/* update complex register */

		q = complex_reg.variable;
		if q ^= null then q -> reference.value_in.complex_aq = "0"b;

		complex_reg.variable = p;
		p -> reference.value_in.complex_aq = "1"b;

		return;
	     end;

	if p -> reference.long_ref
	then do;

/* update string register */

		q = string_reg.variable;
		if q ^= null then q -> reference.value_in.string_aq = "0"b;

		string_reg.variable = p;
		string_reg.size = p -> reference.c_length;
		p -> reference.value_in.string_aq = "1"b;

		p -> reference.address_in.storage = "1"b;

		return;
	     end;

/* update a register */

up_a:	do i = 1 to a_reg.number;
	     a_reg.variable (i) -> reference.value_in.a = "0"b;
	end;

	n = p -> reference.data_type;
	if n = bit_string | n = char_string
	then do;
		a_reg.size = p -> reference.c_length * convert_size (n);
		a_reg.offset = mod (convert_offset (p -> reference.units) * p -> reference.c_offset, bits_per_two_words);
		if a_reg.offset + a_reg.size > bits_per_word then a_reg.length = bits_per_two_words;
		else a_reg.length = bits_per_word;
	     end;
	else a_reg.size, a_reg.offset = 0;

	a_reg.number = 1;
	a_reg.variable (1) = p;
	p -> reference.value_in.a = "1"b;

	return;

/* update q register */

up_q:	do i = 1 to q_reg.number;
	     q_reg.variable (i) -> reference.value_in.q = "0"b;
	end;

	q_reg.number = 1;
	q_reg.variable (1) = p;
	p -> reference.value_in.q = "1"b;

	return;

state_man$update_reg: entry (pt, which);

	dcl     (which, update)	 bit (19) aligned;

	p = pt;
	update = which;

	if substr (update, 1, 1) then goto up_a;
	if substr (update, 2, 1) then goto up_q;

	return;

state_man$erase_reg: entry (what);

/* this entry is called to erase the contents of some register(s) */

	dcl     what		 bit (19) aligned;	/* what to erase */

	erase = what;

	if substr (erase, 1, 1)
	then do;

/* if we are erasing a register, we have to check for
	        double fixed, floating point, or unpacked ptr
	        values left in "q" register */

		if q_reg.number > 0
		then do;

			p = q_reg (1).variable;
			n = p -> reference.data_type;

			if n = real_fix_bin_2
			     | n = real_flt_bin_1
			     | n = real_flt_bin_2
			     | n = unpacked_ptr
			then

/* have to erase q as well as a */

			     substr (erase, 2, 1) = "1"b;
		     end;

		call wipe;
		return;
	     end;

	if substr (erase, 2, 1)
	then do;

/* if we are erasing q register, we have to check for
	        a string value that may have gotten shifted into q
	        register from a */

		if a_reg.number ^= 0
		then if a_reg.size + a_reg.offset > bits_per_word
		     then substr (erase, 1, 1) = "1"b;
		     else a_reg.length = min (a_reg.length, bits_per_word);

	     end;

	call wipe;
	return;

state_man$erase_temps: entry;

/* This entry is called to save in storage any fixed binary temporary
	   values with precision such that they could be loaded into index registers
	   via eax instructions.  It is used to prevent sequence like
		ldq	j
		cmq	k
		eax5	0,al
		tsx0	ap|r_e_as
	   from being generated		*/

	erase = "0"b;

	b19 = "1"b;
	do i = 1 to a_reg.number;
	     p = a_reg (i).variable;
	     if p -> reference.temp_ref then call check_temp;
	end;

	found = "0"b;
	do i = 1 to q_reg.number while (^found);
	     p = q_reg (i).variable;
	     n = p -> reference.data_type;

	     if n = real_fix_bin_2 | n = real_flt_bin_2
		| n = real_flt_bin_1 | n = unpacked_ptr
	     then found = "1"b;
	end;

	if found
	then do;
		b19 = "01"b;
		do i = 1 to q_reg.number;
		     p = q_reg (i).variable;
		     if p -> reference.temp_ref then call check_temp;
		end;
	     end;

	if erase
	then do;
		call wipe;
		cg_stat$last_call = cg_stat$text_pos;	/* prevent xr_man from changing to eax	*/
	     end;

	return;

state_man$unlock: entry;

/* Unlocks all registers and updates used fields when necessary (for EIS) */

	a_reg.locked, q_reg.locked = "0"b;
	a_reg.number_h_o, q_reg.number_h_o = 0;

	text_pos = cg_stat$text_pos;

	do i = 0 to 7;
	     if index_regs (i).type < 0
	     then do;
		     if index_regs (i).variable ^= null
		     then index_regs (i).type = abs (index_regs (i).type);
		     else index_regs (i).type = 0;
		     index_regs (i).used = text_pos;
		end;
	end;

	do i = 1 to 6;
	     if base_regs (i).locked ^= 0
	     then do;
		     base_regs (i).locked = 0;
		     base_regs (i).used = text_pos;
		end;
	end;

	return;

state_man$set_aliasables: entry (pt);

/* When an aliasable variable (one that may have an alias) is set, all potential aliases must
   be removed from the machine state.  We only search for shared aliases because the optimizer
   and semantic_translator have automatically handled unshared aliases by the reference count
   scheme. */

	dcl     all		 bit (1) aligned;	/* "1"b if _a_l_l aliasables are to be flushed */

	p = pt;
	all = p = null;

	if machine_state.indicators = -2
	then do;
		q = indicators_ref (2);
		if compare_aliasables ()
		then machine_state.indicators = 0;
		else do;
			q = indicators_ref (3);
			if compare_aliasables ()
			then machine_state.indicators = 0;
		     end;
	     end;

	n = a_reg.number;
	i = 1;
	do while (i <= n);
	     q = a_reg.variable (i);
	     if compare_aliasables ()
	     then do;
		     q -> reference.value_in.a = "0"b;
		     n = n - 1;
		     do j = i to n;
			a_reg.variable (j) = a_reg.variable (j + 1);
		     end;
		end;
	     else i = i + 1;
	end;
	a_reg.number = n;

	n = q_reg.number;
	i = 1;
	do while (i <= n);
	     q = q_reg.variable (i);
	     if compare_aliasables ()
	     then do;
		     q -> reference.value_in.q = "0"b;
		     n = n - 1;
		     do j = i to n;
			q_reg.variable (j) = q_reg.variable (j + 1);
		     end;
		end;
	     else i = i + 1;
	end;
	q_reg.number = n;

	q = string_reg.variable;
	if q ^= null
	then if compare_aliasables ()
	     then do;
		     q -> reference.value_in.string_aq = "0"b;
		     string_reg.variable = null;
		end;

	q = complex_reg.variable;
	if q ^= null
	then if compare_aliasables ()
	     then do;
		     q -> reference.value_in.complex_aq = "0"b;
		     complex_reg.variable = null;
		end;

	q = decimal_reg.variable;
	if q ^= null
	then if compare_aliasables ()
	     then do;
		     q -> reference.value_in.decimal_aq = "0"b;
		     decimal_reg.variable = null;
		end;

	do i = 0 to 7;
	     if index_regs (i).type >= 2
	     then do;
		     q = index_regs (i).variable;
		     if compare_aliasables ()
		     then do;
			     q -> reference.value_in.x (i) = "0"b;
			     index_regs (i).type = 0;
			end;
		end;
	end;

	do i = 1 to 6;
	     if base_regs (i).type = 1
	     then do;
		     q = base_regs (i).variable;
		     if compare_aliasables ()
		     then do;
			     q -> reference.value_in.b (i) = "0"b;
			     base_regs (i).type = 0;
			end;
		end;
	end;

	return;


check_temp: proc;

	if p -> reference.data_type ^= real_fix_bin_1 then goto back;
	if p -> reference.value_in.storage then goto back;
	if p -> reference.ref_count < 1 then goto back;
	if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
	then erase = erase | b19;

back: end;

get_ms: proc;

	m_s_p = cg_stat$ms_list;
	if m_s_p ^= null then cg_stat$ms_list = machine_state.next;
	else do;
		allocate machine_state in (xeq_tree_area) set (m_s_p);
		m_s_p -> node.type = machine_state_node;
		pl1_stat_$node_uses (bin (machine_state_node, 9)) = pl1_stat_$node_uses (bin (machine_state_node, 9)) + 1;
	     end;

     end;

compare_aliasables: proc () returns (bit aligned);

	if p ^= q
	then if q -> reference.shared
	     then if all
		then if q -> reference.aliasable
		     then return ("1"b);
		     else if q -> reference.symbol -> symbol.block_node ^= null
		     then return (q -> reference.symbol -> symbol.block_node -> block.flush_at_call);
		     else ;
		else if q -> reference.aliasable
		then return (compare_alias ((p -> reference.symbol), (q -> reference.symbol)));

	return ("0"b);
     end;

%include compare_alias;


wipe: proc;

	if substr (erase, 1, 1)
	then do;

		do i = 1 to a_reg.number;
		     p = a_reg.variable (i);
		     call save_temp (1);
		     p -> reference.value_in.a = "0"b;
		end;

		a_reg.constant,
		     a_reg.number = 0;
	     end;

	if substr (erase, 2, 1)
	then do;

		do i = 1 to q_reg.number;
		     p = q_reg.variable (i);
		     call save_temp (2);
		     p -> reference.value_in.q = "0"b;
		end;

		q_reg.constant,
		     q_reg.number = 0;
	     end;

	if substr (erase, 3, 1)
	then do;
		p = string_reg.variable;
		if p ^= null
		then do;
			call save_temp (3);
			p -> reference.value_in.string_aq = "0"b;
			string_reg.variable = null;
		     end;
	     end;

	if substr (erase, 4, 1)
	then do;
		q = complex_reg.variable;
		if q ^= null
		then do;
			q -> reference.value_in.complex_aq = "0"b;
			complex_reg.variable = null;
		     end;
	     end;

	if substr (erase, 5, 1)
	then do;
		q = decimal_reg.variable;
		if q ^= null
		then do;
			q -> reference.value_in.decimal_aq = "0"b;
			decimal_reg.variable = null;
		     end;
	     end;

	do i = 0 to 7;
	     if substr (erase, i + 6, 1)
	     then do;
		     if index_regs (i).type >= 2
		     then do;
			     p = index_regs (i).variable;
			     if p ^= null
			     then do;
				     call save_temp (0);
				     p -> reference.value_in.x (i) = "0"b;
				end;
			end;

		     index_regs (i).type = 0;
		end;
	end;

	do i = 1 to 6;
	     if substr (erase, i + 13, 1)
	     then do;
		     p = base_regs (i).variable;
		     n = base_regs (i).type;
		     if p = null then n = 0;

		     if n = 1
		     then do;
			     p -> reference.value_in.b (i) = "0"b;
			     call save_temp (-i);
			end;
		     else if n = 2
		     then p -> reference.address_in.b (i) = "0"b;

		     base_regs (i).type = 0;
		end;
	end;


     end;


save_temp: proc (reg);

	dcl     reg		 fixed bin;

	dcl     ca		 ptr;

	dcl     (macro, t, k)	 fixed bin (15);

	dcl     (stfx1		 init (15),
	        stfx2		 init (16),
	        save_string_aq	 init (229),
	        sxl0		 init (345),
	        stx0		 init (714),
	        zero_mac		 init (308),
	        store_base		 (23:24, 6) init (61, 409, 622, 623, 624, 625, /* unpacked */
				 630, 631, 632, 633, 634, 635), /* packed */
	        sta		 init (4)) fixed bin (15) int static;

	if cg_stat$m_s_p = null then return;

	if ^p -> reference.temp_ref then goto exit;

	if p -> reference.ref_count <= 0 then goto exit;

	if p -> reference.value_in.storage then goto exit;

	if p -> reference.symbol = null then goto exit;

	if p -> reference.dont_save then go to exit;

	if p -> reference.aggregate then go to exit;

	t = p -> reference.data_type;

	if reg = 2
	then do;
		if t = unpacked_ptr
		then if string (p -> reference.value_in.b)
		     then goto exit; else goto save;

		if t = real_fix_bin_1
		then if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
		     then if string (p -> reference.value_in.x)
			then goto exit;
	     end;

save:	p -> reference.store_ins = bit (cg_stat$text_pos, 18);
	p -> reference.ref_count = p -> reference.ref_count + 1;

	if reg < 0
	then do;
		macro = store_base (t, abs (reg));
		goto gen;
	     end;

	if reg = 3
	then do;
		if p -> reference.allocated then go to exit;
		if ^p -> reference.address_in.storage then go to exit;

		call stack_temp$assign_block (p, 2);

/* we must ensure that saving the string aq does
		   not alter any registers */

		if string (p -> reference.address_in.b)
		then do;
			k = index (string (p -> reference.address_in.b), "1"b) - 1;
			p -> reference.address_in.storage = "0"b;
			call expmac ((store_base (23, k)), p);
			p -> reference.address_in.storage = "1"b;
		     end;
		else do;
			ca = c_a (p -> reference.qualifier -> temporary.location, 4);
			call expmac$one_eis ((save_string_aq), ca);
			p -> reference.ref_count = p -> reference.ref_count - 1;
		     end;

		go to exit;
	     end;

	if reg = 1
	then do;
		if t < char_string then k = 0;
		else k = fixed (p -> reference.c_length * convert_size (t) > bits_per_word, 1);
		call expmac$one ((sta), p, k);

		if a_reg.offset ^= 0
		then do;
			p -> reference.aligned_ref = "0"b;
			p -> reference.c_offset = a_reg.offset;
			p -> reference.units = bit_;
		     end;
	     end;
	else do;
		if reg = 0
		then do;
			if p -> reference.symbol -> symbol.c_dcl_size < bits_per_half
			then do;
				macro = stx0 + i;

/* convert the value in index register to "packed"
			   integer in storage */

				p -> reference.aligned_ref = "0"b;
				p -> reference.c_offset = 0;
				p -> reference.c_length = bits_per_half;
				p -> reference.units = word_;

/* We set reference.dont_save as a
			   kludge to fix bug 1599.  This
			   prevents save_value from converting
			   this back to an aligned temp,
			   which could cause problems after
			   an if statement. */

				p -> reference.dont_save = "1"b;
			     end;

			else do;
				macro = sxl0 + i;
				p -> reference.ref_count = p -> reference.ref_count + 1;
				call expmac ((zero_mac), p);
			     end;
		     end;
		else if t = unpacked_ptr | t = complex_flt_bin_1 then macro = stfx2;
		else if t = packed_ptr | t = bit_string then macro = stfx1;
		else macro = stfx1 - 1 + t;

gen:		call expmac (macro, p);
	     end;

	p -> reference.value_in.storage = "1"b;

exit: end;

need_ref: proc returns (bit (1) aligned);

	dcl     (p1, p2)		 ptr;

	if ^optimize
	then return ("1"b);

	if p -> reference.temp_ref
	then do p1 = q repeat (p1 -> element (4)) while (p1 ^= null);
		p2 = p1 -> element (1);

		if p2 -> node.type = operator_node
		then do;
			if substr (p2 -> operator.op_code, 1, 5) = "00111"b /* mod_bit class */
			then if p2 -> operand (2) = p
			     then return ("1"b);

			p2 = p2 -> operand (1);
		     end;

		if p = p2 then return ("1"b);
	     end;

	return ("0"b);
     end;

     end;




		    store.pl1                       10/03/83  1730.5rew 10/03/83  1009.4      116289



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


/* Procedure to generate store sequences

   Initial Version: 10 September 1971 by BLW
	Modified: 4 November 1972 by BLW
	Modified:	15 February 1973 by RAB
	Modified:	22 June 1973 by RAB for EIS
	Modified:	26 October 1975 by RAB to spec case fixed bin unal
	Modified:	19 March 1977 by RAB for aq_man$left_shift
		and aq_man$right_shift
	Modified:	7 August 1978 by RAB to fix 1751 by changing setting
		of store_it for complex_flt_bin_1
	Modified:	30 March 1980 by RAB for reference.(padded aligned)_for_store_ref.
		See prepare_operand for details.	*/

store:	proc(pt);

dcl	pt ptr;		/* points at reference node */

dcl	cg_stat$save_exp_called bit(1) aligned ext,
	cg_stat$text_pos fixed bin(18) ext,
	cg_stat$complex_ac ptr ext;

dcl	(p,q,arg(2)) ptr,
	(type,size,cfo,unit_size,unit_offset,d,i,j,k,u,n,n1,n2,n3,n4,units) fixed bin,
	(store_it,contiguous,all_ones,all_zeros,b1,arith) bit(1) aligned,
	(macro,offset) fixed bin(15),
	shift fixed bin(8),
	bs bit(12),
	mask bit(72) aligned,
	in_q fixed bin(1) initial(0),
	base3 bit(3) aligned,
	xec(2) bit(36) aligned,
	(ta,tq) bit(6);

dcl	m_a entry(ptr,bit(2) aligned);
dcl	c_a entry(fixed bin,fixed bin) returns(ptr),
	xr_man$load_const entry(fixed bin,fixed bin),
	expmac$abs entry(ptr,fixed bin),
	expmac$zero entry(fixed bin(15)),
	expmac$many entry(fixed bin(15),ptr,fixed bin),
	expmac$two_eis entry(fixed bin(15),ptr,ptr),
	long_op$c_or_b entry(ptr,fixed bin,fixed bin(15)),
	xr_man$load_var entry(ptr,fixed bin),
	base_man$load_any_var entry(fixed bin,ptr,bit(3) aligned),
	stack_temp$assign_block entry(ptr,fixed bin),
	state_man$flush_ref entry(ptr),
	state_man$erase_reg entry(bit(19) aligned),
	(aq_man$left_shift, aq_man$right_shift) entry(fixed bin(8),bit(1) aligned),
	aq_man$check_strings entry(fixed bin),
	aq_man$trim_aq entry(fixed bin),
	generate_constant entry(bit(*) aligned,fixed bin) returns(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	expmac$one entry(fixed bin(15),ptr,fixed bin),
	expmac entry(fixed bin(15),ptr);

dcl	(abs,addr,addrel,bit,divide,fixed,mod,min,null,string,substr) builtin;

dcl (	bytes(2)		init(9,6),
	nbspw(2)		init(4,6)) fixed bin int static;

dcl	operator_table	init(262046) fixed bin(18) int static;	/* = 262144 - 98 */

	/* The following values are offsets obtained from a compilation
	   of pl1_operators_ */

dcl (	co_to_bo		init(0),
	ho_to_bo		init(4),
	store_a9_co	init(6),
	store_q9_co	init(26),		/* 32 octal */
	store_a9_ho	init(42),		/* 52 octal */
	store_q9_ho	init(54),		/* 66 octal */
	store_a6_ho	init(64),		/* 100 octal */
	store_q6_ho	init(82))		/* 122 octal */
			fixed bin static;

dcl	full(2) aligned bit(6) int static init("111100"b, "111111"b);

dcl	init_xec_7(2) bit(36) aligned int static
	init(	"000000000000000000111111011001011111"b,	/* lrl ap|0,7*	*/
		"000000000000000000111001110001001111"b);	/* xec ap|0,7	*/

dcl	init_xec_q(2) bit(36) aligned int static
	init(	"000000000000000000111111001001010110"b,	/* arl ap|0,ql*	*/
		"000000000000000000111001110001000110"b);	/* xec ap|0,ql	*/

dcl (	stfx1		init(15),
	stfx2		init(16),
	store_pt		init(61),
	shift_and_mask	init(106),
	als		init(134),
	ana(0:1)		init(40,688),
	anaq		init(42),
	era(0:1)		init(52,689),
	ersa(0:1)		init(55,690),
	lls		init(63),
	lrl		init(62),
	arl		init(245),
	orsa		init(49),
	pack_fl1		init(489),
	pack_cfl1		init(491),
	move_chars	init(98),
	store_units(2)	init(295,297),
	sta		init(4),
	st_reg(0:1)	init(4,15),
	store_logical	init(381)) fixed bin(15) int static;

%include cgsystem;
%include reference;
%include machine_state;
%include data_types;
%include boundary;
%include bases;

	all_zeros, all_ones = "0"b;

s0:	p = pt;

	if p -> reference.temp_ref & ^ p -> reference.aggregate
	then do;
	     if ^ p -> reference.allocated
	     then do;
		if p -> reference.data_type = complex_flt_bin_1
		then call expmac((stfx2),cg_stat$complex_ac);
		return;
		end;

	     store_it = cg_stat$save_exp_called;
	     end;
	else store_it = "1"b;

	goto l0;

store$force: entry(pt);

	all_zeros, all_ones = "0"b;
	p = pt;
	store_it = "1"b;

l0:	call state_man$flush_ref(p);

	type = p -> reference.data_type;

	if type = unpacked_ptr
	then do;
	     type = real_fix_bin_2;
	     goto l1;
	     end;

	if type = packed_ptr
	then do;
	     type = real_fix_bin_1;
	     goto l1;
	     end;

	if type >= char_string
	then do;
	     arith = "0"b;
	     goto string_;
	     end;

l1:	arith = "1"b;

	if ^ p -> reference.aligned_for_store_ref
	then do;

	     if p -> reference.temp_ref
		then p -> reference.value_in.storage = "1"b;

	     if type = real_fix_bin_1
	     then do;
		size = p -> reference.c_length;

		if p -> reference.hard_to_load
		then if size = bits_per_word
		     then do;
			in_q = 1;
			go to str1;
			end;
		     else;
		else do;
		     cfo = mod(p -> reference.c_offset * convert_offset(p -> reference.units),36);
		     if cfo < 0 then cfo = cfo + 36;

		     if cfo = bits_per_word - size
		     then do;
			in_q = 1;
			go to str1;
			end;
		     end;
		end;

	     call state_man$erase_reg("1"b);	/* erase a register */

	     a_reg.size, size = p -> reference.c_length;
	     a_reg.length = 72;

	     if type <= real_fix_bin_2
	     then do;
		a_reg.offset = 72 - size;
		goto str1;
		end;

	     if type <= real_flt_bin_2
	     then do;
		call expmac$zero(pack_fl1 - real_flt_bin_1 + type);
		a_reg.offset = 0;
		goto str1;
		end;

	     if type = complex_flt_bin_1
	     then do;
		k = bits_per_word - divide(size,2,17,0);
		if k > 0
		     then call expmac((pack_cfl1),c_a(k,1));
		a_reg.offset = 0;
		goto str1;
		end;

	     goto str1;
	     end;

	if type = complex_flt_bin_1 then macro = stfx2;
	else macro = stfx1 - 1 + type;

	if store_it then call expmac(macro,p);

up_q:	do i = 1 to q_reg.number;
	     if q_reg.variable(i) = p then goto thru;
	     end;

	if i < 11
	then do;
	     q_reg.number = i;
	     q_reg.variable(i) = p;
	     p -> reference.value_in.q = "1"b;
	     end;

thru:	if p -> reference.temp_ref & store_it
	then do;
	     p -> reference.store_ins = bit(fixed(cg_stat$text_pos - 1,18),18);
	     p -> reference.value_in.storage = "1"b;
	     end;

	return;

string_:	if ^ store_it then goto update_a;

	size = p -> reference.c_length * convert_size(type);

str1:

/* If a reference is hard_to_load, it is also hard to store and we will use EIS to
   accomplish the feat */

	if p -> reference.hard_to_load
	then do;

	     /* First shift string to the left of the aq */

	     if in_q = 0
	     then if a_reg.offset > 0
		then call aq_man$left_shift(a_reg.offset, a_reg.length > bits_per_word);

	     /* store the string in the double temp (sp|46) */

	     q = c_a(46,4);
	     q -> reference.c_length = p -> reference.c_length;

	     call expmac$one((st_reg(in_q)),q,fixed(size > bits_per_word,1));

	     /* Now update the machine state */

	     if ^ arith
		then call up_a;
		else type = bit_string;

	     /* Finally move from the temp to the actual reference */

	     if p -> reference.temp_ref
		then p -> reference.value_in.storage = "1"b;

	     call expmac$two_eis((move_chars + type - char_string),p,q);

	     if in_q ^= 0 then go to up_q;
	     return;
	     end;

	units = p -> reference.units;

	if units = word_
	then cfo = 0;
	else do;
	     cfo = mod(p -> reference.c_offset * convert_offset(units),36);
	     if cfo < 0 then cfo = cfo + 36;
	     end;

	/* have constant bit offset, do the store out-of-line if
	   the string overlaps into third word */

	offset = cfo;
	k = size + offset;
	d = fixed(k > 36,1);
	contiguous = k <= 36;

	if all_zeros then goto s1;
	if in_q > 0 then goto s1;

	shift = offset - a_reg.offset;
	if shift = 0 then goto s1;

	b1 = a_reg.length <= 36 & contiguous;

	if shift < 0
	then call aq_man$left_shift(- shift, ^ b1);

	else do;

	     if b1
		then i = bits_per_word;
		else i = bits_per_two_words;

	     call aq_man$check_strings(i-shift);
	     if a_reg.size + offset > i then a_reg.size = i - offset;

	     call aq_man$right_shift(shift, ^ b1);
	     end;

s1:	if offset > 0 then goto check;

          if size = 0
          then if ^ p -> reference.temp_ref
	     then goto easy_done;

	if mod(size,36) = 0
	then do;
	     if a_reg.length < size then call aq_man$trim_aq(size);
	     goto blast;
	     end;

	if ^ p -> reference.padded_for_store_ref then goto check;

	/* can do single store, trim any excess bits on right */

	if all_zeros then goto blast;

	if a_reg.size > size | a_reg.length < 36*(d + 1)
	then do;
	     call aq_man$trim_aq(size);
	     a_reg.size = size;
	     end;

blast:	call expmac$one((sta),p,d);
	goto easy_done;

	/* if offset is a constant multiple of 6 or 9 and size is a
	   multiple also, generate a stca-stcq or stba-stbq sequence.
	   otherwise, use insert code */

check:

	do i = 1 to 2;
	     u = bytes(i);
	     if mod(offset,u) = 0
	     then do;
		j = mod(size,u);
		if j = 0 then goto easy;

		if p -> reference.padded_for_store_ref
		then do;
		     size = size + (u - j);
		     goto easy;
		     end;

		end;
	     end;

	/* we must insert value into storage */

insert:	if all_ones
	then do;
	     call expmac$one((orsa),p,d);
	     go to easy_done;
	     end;

	if ^p -> reference.shared
	     then p -> reference.ref_count = p -> reference.ref_count + 1;

	call expmac$one((era(in_q)),p,d);

	p -> reference.perm_address = "1"b;


	/* have constant bit offset, no shifting needed */

	if offset = 0 then q = c_a(k,5);
	else do;
	     mask = (72)"0"b;
	     substr(mask,offset+1,size) = (72)"1"b;
	     if substr(mask,72,1) then q = c_a((offset),7);
	     else q = generate_constant(mask,d+1);
	     end;

	call expmac$one((ana(in_q)),q,d);

	call expmac$one((ersa(in_q)),p,d);

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

	if in_q > 0
	     then return;

done:	a_reg.size = 0;

	do i = 1 to a_reg.number;
	a_reg.variable(i) -> reference.value_in.a = "0"b;
	end;

	a_reg.number = 0;

	return;

	/* can use special character instructions, calculate modifiers */

easy:	unit_offset = divide(offset,u,17,0);
	unit_size = divide(size,u,17,0);

	bs = "0"b;
	substr(bs,unit_offset+1,unit_size) = (12)"1"b;

	n = nbspw(i);
	ta = substr(bs,1,n);
	tq = substr(bs,n+1,n);

	/* make destination addressable, place address in any base register if original address
	   has any tag other than 0 */

	call m_a(p,"0"b);

	if p -> reference.tag
	then do;
	     if cfo ^= 0
		then p -> reference.units = word_;	/* Inhibit base_man from loading fractional offset */
	     p -> reference.perm_address = "1"b;
	     if ^p -> reference.shared
		then p -> reference.ref_count = p -> reference.ref_count + 1;
	     call base_man$load_any_var(2,p,base3);
	     if cfo ^= 0
	     then do;

		/* Since we do not have full address in the pointer register,
		   we must flush its address from the machine state */

		p -> reference.units = units;
		j = which_base(fixed(base3,3));
		base_regs(j).type = 0;
		p -> reference.address_in.b(j) = "0"b;
		end;
	     end;

	p -> reference.perm_address = "1"b;

	if ta = full(i) then macro = sta;
	else do;
	     macro = store_units(i) + in_q;
	     p -> reference.tag = ta;
	     end;

	if ^p -> reference.shared
	     then p -> reference.ref_count = p -> reference.ref_count + 1;

	call expmac(macro,p);

	if k <= 36
	then do;
	     call adjust_ref_count(p,-1);
	     if in_q > 0 then go to up_q;
	     go to easy_done;
	     end;

	if tq = full(i)
	then do;
	     macro = stfx1;
	     tq = "0"b;
	     end;
	else macro = store_units(i) + 1;

	p -> address.offset = bit(fixed(fixed(p -> address.offset,15)+1,15),15);
	p -> address.tag = tq;


	call expmac(macro,p);

	a_reg.size = size;
	a_reg.length = size + offset;

easy_done:
	p -> reference.perm_address = "0"b;

	if arith then return;

	a_reg.offset = offset;

update_a:	call up_a;

	if a_reg.number = 0
	     then return;
	     else go to thru;

store$all_ones: entry(pt);

	all_ones = "1"b;
	all_zeros = "0"b;
	goto s0;

store$all_zeros: entry(pt);

	all_ones = "0"b;
	all_zeros = "1"b;
	goto s0;

store$save_string_temp: entry(pt);

	p = pt;
	call stack_temp$assign_block(p,2);
	p -> reference.address_in.storage = "0"b;
	p -> reference.store_ins = bit(cg_stat$text_pos,18);
	call expmac((store_pt),p);
	p -> reference.address_in.storage = "1"b;
	return;


up_a:	proc;

	do i = 1 to a_reg.number;
	if a_reg.variable(i) = p then return;
	end;

	if i < 11
	then do;
	     a_reg.number = i;
	     a_reg.variable(i) = p;
	     p -> reference.value_in.a = "1"b;
	     end;

end;


	end;




		    store_bit_address.pl1           10/03/83  1730.5rew 10/03/83  1009.4       25362



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


/* procedure to set refa = addr(refb), possibly with bit offset */

/*	Modified:	12 June 1973 by RAB for EIS
	Modified:	5 Sept 1975 by RAB to fix 1415
	Modified:	10 Sept 1977 by RAB to fix 1613 by adding a_last_freed parameter	*/

store_bit_address: proc(refa,refb,a_last_freed);

dcl	(refa,refb) ptr;
dcl	a_last_freed fixed bin(18);	/* address at which temp storage used by refa was freed */

dcl	cg_stat$text_base ptr ext,
	cg_stat$last_call fixed bin ext;

dcl	(p,pa,pb) ptr,
	n fixed bin(15),
	shared bit(1) aligned,
	b36 bit(36) aligned,
	(i,units,bo) fixed bin;

dcl	base_man$store_ptr_to entry(ptr,ptr);
dcl	m_a entry(ptr,bit(2) aligned);

dcl	(addr,addrel,bit,fixed,mod,null,substr) builtin;


dcl	word bit(36) aligned based,
	1 instruction	aligned based,
	2 base		unal bit(3),
	2 offset		unal bit(15),
	2 rest		unal bit(18);

%include reference;
%include bases;

	pa = refa;
	pb = refb;

	/* check to see if this arg is a string expression which may end
	   in a stpbp instruction that saves a pointer to the string in a
	   temporary.  If this is the case, we'll change the stpbp to set
	   the proper arg position in the stack and alter the address of
	   the temporary */

	if fixed(pb -> reference.store_ins,18) <= cg_stat$last_call then goto set;

	if fixed(pb -> reference.store_ins,18) < a_last_freed then goto set;

	p = addrel(cg_stat$text_base,pb -> reference.store_ins);

	if (p -> word & "111000000000000000111111111111111111"b)
		   ^= "110000000000000000010101010001000000"b	/* stpbp sp|0 */
	then goto set;

	if pb -> address.base ^= bp
	then if pb -> address.base ^= sp
	     then go to set1;
	     else if p -> instruction.offset ^= pb -> address.offset
		then go to set1;

	if pa -> reference.no_address
	then do;
	     call m_a(pa,"0"b);
	     if pa -> address.base ^= sp
		then go to set1;
	     if pa -> address.tag
		then go to set1;
	     end;

	p -> instruction.offset, pb -> address.offset = pa -> address.offset;
	pb -> reference.store_ins = "0"b;
	pb -> reference.ref_count = pb -> reference.ref_count - 1;
	return;

/* Normal case:  have base_man store the pointer */

set:	if pb -> reference.symbol ^= null
	then if ^ pb -> reference.temp_ref | pb -> reference.length = null
	     then pb -> reference.no_address = "1"b;

set1:
	call base_man$store_ptr_to(pb,pa);

	end;




		    string_op.pl1                   10/03/83  1730.5rew 10/03/83  1009.4      122868



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


/* this procedure compiles string expressions

   Initial Version:  5 October, 1968 by BLW 
	Modified:  4 September 1971 by BLW for Version II
	Modified: 25 November 1972 by BLW
	Modified:	4 June 1973 by RAB for EIS
	Modified:	2 November 1975 by RAB to check for p3 in a
	Modified:	1 April 1979 by RAB to improve code generated when
		expression lengths are the same, and to add commentary
		on compiling string expressions.
	Modified:	20 August 1979 by RAB to improve code generated
		for a & ^ b, where a and b are long strings.
	Modified:	21 August 1979 by RAB to use check_lengths for andnot and
		to fix a bug in check_lengths.
	Modified:	30 March 1980 by RAB for reference.aligned_for_store_ref.
		See prepare_operand for details.	*/

string_op: proc(node_pt,refs,p_code);

dcl	node_pt	ptr,		/* points at operator node */
	refs(3) 	ptr,		/* ptrs to reference nodes for operands */
	p_code	fixed bin(15);	/* encodes local context of operator */

dcl	(cg_stat$double_temp,cg_stat$long_string_temp) ptr ext static,
	cg_stat$for_test_called bit(1) ext static;

dcl	(p,p1,p2,p3,q2,q3,ref(3) defined(refs)) ptr,
	for_test bit(1) aligned,
	doing_andnot bit(1) aligned,
	code fixed bin(2),
	atom(2:3) bit(1) aligned,
	(s2,s3,op,k,l_op,load_double,op_code,n,which_andnot) fixed bin(15);

dcl	load entry(ptr,fixed bin(15)),
	c_a entry(fixed bin(31),fixed bin) returns(ptr),
	aq_man$clear_q entry,
	string_temp entry(ptr,ptr,ptr) returns(ptr),
	expmac$eis entry(fixed bin(15),ptr),
	expmac$zero entry(fixed bin(15)),
	expmac entry(fixed bin(15),ptr),
	expmac$one entry(fixed bin(15),ptr,fixed bin(15)),
	prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	compile_exp entry(ptr),
	(compile_exp$save,compile_exp$save_exp) entry(ptr) returns(ptr);

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

dcl (	and		init(1),
	not		init(4)) fixed bin int static;

dcl (	era		init(52),
	move_not_bits	init(335),
	comp_bits		init(148),
	move_xor		init(341),
	ora		init(46),
	move_or		init(304),
	ana		init(40),
	and_for_test	init(615),
	move_and		init(264),
	move_andnot(0:1)	init(391,392),
	test_not		init(338),
	test_xor		init(344),
	test_or		init(331),
	test_and		init(267),
	test_andnot(0:1)	init(261,262),
	staq		init(6)) fixed bin(15) int static;

%include cgsystem;
%include reference;
%include operator;
%include machine_state;
%include op_codes;
%include nodes;

	/*  ON COMPILATION OF STRING EXPRESSIONS

	   Short string expressions (those of constant length <= 2 words) are
	   evaluated in the A or the AQ and present no problems of special
	   interest.

	   Long string expressions must be evaluated in string temporaries
	   which are allocated by string_temp.  There are 2 types of string
	   temps -- (1) those that are allocated in the stack at compile-
	   time like short temps, (2) those that are allocated by stack
	   extension at runtime.  string_temp decides which type of string
	   temporary to use.  The first type of temp is used if the reference
	   count of operand(1) is greater than 1 and it has a constant length.
	   Otherwise, a stack extension is used.  A  temp acquired by stack
	   extension is recognized by having reference.value_in.string_aq ON
	   (in which case, it is considered to be in the string aq) or by having
	   reference.address_in.storage ON.

	   string_temp may try to save on execution time by reusing or extending
	   previously allocated stack extension temporaries.  If operand(1)
	   requires a stack extension, operand(2) is in the string aq, and the
	   relation between the lengths of operand(2) and operand(3) is known
	   at compile-time (or one of the operands is short), then string_temp
	   will reuse operand(2)'s temp if the length of operand(1) and operand(2)
	   is the same, or extend operand(2)'s temp otherwise.  IF the previously
	   mentioned conditions are not satisfied, new temporary space must be
	   allocated.

	   When compile_exp is called for a long string expression, the location
	   of the string temp is not saved in storage.  When compile_exp$save or
	   compile_exp$save_exp is called for a long string expression and the
	   temp has been acquired by stack extension, the address of the temp is
	   saved in storage after expression evaluation.  This allows one to find
	   the temp if new stack extensions are made.  After calling compile_exp,
	   compile_exp$save, or compile_exp$save_exp on a long string expression,
	   the result reference count is left unchanged.

	   When string_op is processing a long string_expression,
	   it may call compile_exp for at most one long string expression, since
	   evaluating the other may cause other stack extensions.  compile_exp
	   must not be called  if other activity may affect the string aq or PR2.
	   In this latter case, compile_exp$save[_exp] must be called.  compile_exp
	   is also not called unless there is a chance that string_temp will be able
	   to reuse or extend an existing temp.
*/


begin:	p = node_pt;
	q2 = p -> operand(2);
	code = p_code;

	op_code = fixed(substr(p -> operator.op_code,6,4),4);

	p1 = ref(1);
	p2 = ref(2);

	if op_code ^= not
	then do;
	     q3 = p -> operand(3);
	     p3 = ref(3);
	     end;

	for_test = cg_stat$for_test_called;
	doing_andnot = "0"b;

	/* encode left size and dispatch on operator */

	if p2 -> reference.long_ref | p2 -> reference.varying_ref then s2 = 3;
	else s2 = 2*fixed(p2 -> reference.c_length > bits_per_word,1);

	goto switch(op_code);

	/* have not operation */

switch(4):
not_op:	if code ^= 0
	then 

	     /* atm, generate move-not_bits for long atm or
	        load short or double operand */

	     if s2 <= 2
	     then do;
		call load(p2,s2);
complement:	call expmac$one((era),c_a((p2 -> reference.c_length),5),s2);
		end;
	     else do;
comp_long:	p1 = string_temp(p,p2,null);
		if for_test then l_op = test_not; else l_op = move_not_bits;
		call expmac$eis(l_op,p2);
		end;

	else do;

	     /* exp, compile exp then generate comp_bits op
	        or actually complement bits in ac */

	     call compile_exp(q2);
	     if s2 > 2 then go to comp_long;
	     else goto complement;
	     end;

	goto string_done;

	/* Operation is EXCLUSIVE OR */

switch(3):
xor_op:	op = era;
	call check_lengths;
	if for_test then l_op = test_xor; else l_op = move_xor;
	load_double = 2;
	goto set_s3;

	/* operation is OR */

switch(2):
or_op:	op = ora;
	call check_lengths;
	if for_test then l_op = test_or; else l_op = move_or;
	load_double = 2;
	goto set_s3;

	/* operation is AND */

switch(1):
and_op:	if for_test
	then do;
	     op = and_for_test;
	     l_op = test_and;
	     end;
	else do;
	     op = ana;
	     l_op = move_and;
	     end;

set_s3:	if p3 -> reference.long_ref | p3 -> reference.varying_ref then s3 = 3;
	else s3 = 2*fixed(p3 -> reference.c_length > bits_per_word,1);

	if op_code = and
	then do;
	     load_double = 2*fixed(s2 = s3,1);

	     /* See if we have a & ^ b.  If we do, we can shorten
	        3 instructions to 2 */

	     if can_do_andnot(which_andnot)
	     then do;
		atom(2) = code >= 2;
		atom(3) = mod(code,2) ^= 0;

		if which_andnot = 0
		     then call setup_andnot(p2,q2,s2,atom(2));
		     else call setup_andnot(p3,q3,s3,atom(3));

		code = fixed(atom(2) || atom(3), 2);

		call check_lengths;

		if for_test
		     then l_op = test_andnot(which_andnot);
		     else l_op = move_andnot(which_andnot);

		doing_andnot = "1"b;
		end;
	     end;

	/* at this point the left and right sizes are coded in
	   s2 and s3 as 0: short, 2: double, 3: long.  now
	   dispatch on context of operator node */

	goto ao_sw(code);

	/* operation is atom-atom, reverse operands if
	   right operand longer than left */

ao_sw(3):
ao_aa:	if p3 -> reference.value_in.a then call flip_rands;

	if s2 < s3 then call flip_rands;

	/* check for long operand(s) */

	if s2 > 2 then goto ao_aa_l;

	/* at this point right operand is shorter or same,
	   s3 = 0 for single, s3 = 2 for double */

	call load(p2,load_double);
ao_aa_1:	if op_code = and & s3 < s2 then call aq_man$clear_q;
	call expmac$one(op,p3,s3);

	goto string_done;

	/* left (and possible right) operand is long */

ao_aa_l:	p1 = string_temp(p,p2,p3);

ao_aa_l1:	if s3 > 2 | op_code = and | ^ p1 -> reference.aligned_for_store_ref | for_test 
	then do;

	     /* right operand is long */

	     call long_op;
	     end;
	else do;

	     /* right operand is short, generate
	        xxsa or xxsa_xxsq macro */

	     call load(p3,2);
ao_aa_l3:
	     if p1 -> reference.temp_ref
	     then if ^ p1 -> reference.shared
		then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
	     call expmac$one(op+3,p1,s3);
	     machine_state.indicators = -1;
	     end;

	goto string_done;

	/* operation is atom-expression, reverse */

ao_sw(2):
ao_ae:	call flip_rands;

	/* operation is expression-atom */

ao_sw(1):
ao_ea:	if s2 > 2
	then do;

	     /* left is long, compile, then treat like
	        atom-atom case */

	     if p1 -> reference.length = null
	      | (p2 -> reference.length = p3 -> reference.length
	         & ^ p2 -> reference.varying_ref
	         & ^ p3 -> reference.varying_ref)
		then call compile_exp(q2);
		else p2 = compile_exp$save(q2);
	     go to ao_aa_l;
	     end;

	/* left ^long, check for right long */

	if s3 > 2
	then do;

	     /* if right is really an expression, save value and treat
	        like atom-atom case */

	     p2 = compile_exp$save_exp(q2);
	     call flip_rands;
	     goto ao_aa_l;
	     end;

	/* neither operand is long */

	if ^ p3 -> reference.aligned_ref then p3 = compile_exp$save(p3);
	call compile_exp(q2);
	if s2 < s3 | (s3 ^= s2 & op_code = and) then call aq_man$clear_q;
	call expmac$one(op,p3,s3);

	goto string_done;

	/* operation is expression-expression */

ao_sw(0):
ao_ee:	if s2 < s3 then call flip_rands;

	/* at this point, right operand is shorter */

	if s3 > 2 then goto ao_ee_1;

	/* right operand is not long, left may be */

	if s2 > 2 then go to ao_ee_1;

	/* left is also not long */

	p3 = compile_exp$save(q3);
	call compile_exp(q2);
	goto ao_aa_1;

	/* both are long, check for the situation where the relation between
	   the lengths is unknown at compile-time */

ao_ee_1:	if p2 -> reference.length ^= p3 -> reference.length
	 | p2 -> reference.varying_ref
	 | p3 -> reference.varying_ref
	then do;

	     /* compile right expression, then save temp */

	     p3 = compile_exp$save(q3);

	     /* compile left expression and save pointer */

	     p2 = compile_exp$save(q2);

	     /* since make_addressable will recognize the
	        altered values of p2 and p3, we can treat like
	        atom-atom case now */

	     goto ao_aa_l;
	     end;

	if p2 -> reference.c_length < p3 -> reference.c_length then call flip_rands;

	/* both strings are constant or equal size, size2 >= size3 */

	p3 = compile_exp$save(q3);
	call compile_exp(q2);
	p1 = string_temp(p,p2,p3);
	call long_op;

	/* string operator done */

string_done:
	if ^ p1 -> reference.long_ref
	     then a_reg.size = p1 -> reference.c_length;
	return;

can_do_andnot: proc(which_andnot) returns(bit(1) aligned);

/* determines whether we have a & ^ b, which can be optimized. */

dcl	     which_andnot fixed bin(15);	/* 0, if operand(2) is not_bits
					   1, if operand(3) is not_bits (output) */

dcl	     i fixed bin;
dcl	     q ptr;

	     if p1 -> reference.long_ref
	     then do i = 2 to 3;
		q = p -> operand(i);
		if q -> node.type = operator_node
		then if q -> operator.op_code = not_bits
		then if ^ q -> operand(1) -> reference.evaluated
		then if q -> operand(1) -> reference.ref_count <= 1
		then do;
		     which_andnot = i - 2;
		     return("1"b);
		     end;
		end;

	     return("0"b);

	end /* can_do_andnot */;

setup_andnot:  proc(p_new,q,s,atom);

/* sets up string_op vars for andnot */

dcl	     p_new ptr,	/* new ref node */
	     q ptr,	/* new opnd */
	     s fixed bin(15),	/* new length code */
	     atom bit(1) aligned;

	     q = p -> operand(which_andnot+2) -> operand(2);

	     p_new = prepare_operand(q,1,atom);

	     if p_new -> reference.long_ref | p_new -> reference.varying_ref
		then s = 3;
		else s = 2 * fixed(p_new -> reference.c_length > bits_per_word, 1);

	     call adjust_ref_count((p -> operand(which_andnot+2) -> operand(1)), -1);

	     end /* setup_andnot */;

flip_rands:    proc;

dcl	     p ptr, s fixed;

	     p = p2; p2 = p3; p3 = p;
	     p = q2; q2 = q3; q3 = p;
	     s = s2; s2 = s3; s3 = s;

	     if doing_andnot
	     then do;
		which_andnot = mod(which_andnot+1,2);
		if for_test
		     then l_op = test_andnot(which_andnot);
		     else l_op = move_andnot(which_andnot);
		end;

	     end /* flip_rands */;


check_lengths:	proc;

	     if p1 -> reference.long_ref
	     then if for_test
		then if p2 -> reference.length ^= p3 -> reference.length
		      | p2 -> reference.c_length ^= p3 -> reference.c_length
		      | p2 -> reference.varying_ref
		      | p3 -> reference.varying_ref
		     then for_test, cg_stat$for_test_called = "0"b;

	     end /* check_lengths */;


long_op:	     proc;

	     call expmac$eis(l_op,p3);

	     end /* long_op */;

	end /* string_op */;




		    string_temp.pl1                 10/03/83  1730.5rew 10/03/83  1009.4       81927



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


/* format: style3 */
string_temp:
     proc (pt, pt2, pt3) returns (ptr);

/* Program to standardize the allocation of long string temps for string_op and cat_op */

/*	Written:	by Richard A. Barnes for EIS compiler
	Modified:	21 August 1978 by RAB to tighten restrictions in need_temp
	Modified:	1 April 1979 by RAB to improve code generated for equal
		expression lengths
	Modified:	15 April 1979 by RAB to make the determination in need_temp
		more precise by checking if generation overlaps are exact
	Modified:	30 March 1980 by RAB for reference.aligned_for_store_ref.
		See prepare_operand for details.
*/

dcl	pt		ptr,			/* operator node */
	pt2		ptr,			/* reference node of source to be optionally moved into temp.
			   the space for the source may be reused for the temp */
	pt3		ptr;			/* reference node of other operand */

dcl	(
	op,
	p1,
	p		(2:3),
	q
	)		ptr;
dcl	(dt, icat, k, size, type)
			fixed bin;
dcl	dont_move		bit (1) aligned;		/* ON if p(2) should NOT be moved into the new temp */

dcl	cg_stat$eis_temp	ptr ext;
dcl	cg_stat$for_test_called
			bit (1) aligned ext;

dcl	(
	realloc_char_temp	(0:1) init (92, 200),
	alloc_char_temp	init (89),
	zero_mac		(0:1) init (308, 307),
	move_chars	(0:1) init (98, 218)
	)		fixed bin (15) int static;

dcl	adjust_ref_count	entry (ptr, fixed bin);
dcl	copy_temp		entry (ptr) returns (ptr);
dcl	long_op$eis	entry (ptr, fixed bin, fixed bin (15));
dcl	expmac		entry (fixed bin (15), ptr);
dcl	get_reference	entry () returns (ptr);
dcl	long_op$extend_stack
			entry (ptr, fixed bin (15));
dcl	share_expression	entry (ptr) returns (ptr);
dcl	stack_temp$assign_temp
			entry (ptr);
dcl	state_man$update_ref
			entry (ptr);
dcl	base_man$update_base
			entry (fixed bin, ptr, fixed bin);

dcl	(fixed, min, mod, null)
			builtin;

%include operator;
%include op_codes;
%include reference;
%include symbol;
%include data_types;
%include boundary;
%include cgsystem;

	op = pt;
	p (3) = pt3;
	p (2) = pt2;

	p1 = op -> operand (1);
	type = p1 -> reference.data_type;
	dt = type - char_string;
	icat = fixed (op -> operator.op_code = cat_string, 1);
	dont_move = p (3) = null;

/* If for_test_called, we don't need a temporary */

	if cg_stat$for_test_called
	then do;
		cg_stat$eis_temp = p (2);
		if ^p (2) -> reference.shared
		then p (2) -> reference.ref_count = p (2) -> reference.ref_count + 1;
		return (p1);
	     end;

/* If operand(1) is a nontemporary, we must either create a temporary to work in,
   or use operand(1) as the output if it does not appear as an input operand
   in such a way as to destroy its value before it is used. */

	q = p1;

	if ^p1 -> reference.temp_ref
	then if need_temp ()
	     then do;
		     q = get_reference ();
		     q -> reference.data_type = p1 -> reference.data_type;
		     q -> reference.units = word_;
		     q -> reference.aligned_ref, q -> reference.aligned_for_store_ref, q -> reference.temp_ref = "1"b;
		     q -> reference.long_ref = p1 -> reference.long_ref;
		     q -> reference.c_length = p1 -> reference.c_length;
		     if p1 -> reference.length ^= null
		     then q -> reference.length = share_expression ((p1 -> reference.length));
		end;
	     else if q -> reference.length ^= null
	     then go to set_eis;

/* If the temporary is short, make sure it is unshared and has its allocate bit
   on so that storage may be associated with it */

	if ^q -> reference.long_ref
	then if ^q -> reference.allocate
	     then do;
		     q = copy_temp (q);
		     if p1 -> reference.temp_ref
		     then op -> operand (1) = q;
		end;

/* If the temporary has a constant length and is used more than once (or has allocate bit
   on), then we will now give it a spot in the stack rather than making a stack
   extension for it */

	if q -> reference.length = null
	then if q -> reference.allocate
	     then do;
		     if ^q -> reference.allocated
		     then if q -> reference.temp_ref
			then call stack_temp$assign_temp (q);
		     if ^q -> reference.long_ref
		     then if dt >= 0
			then do;

/* if operand(1) is an aligned ref, but its size does not fill out
                                 the word(s), zero out (last) word                                */

				q -> reference.value_in.storage = "1"b;
				size = q -> reference.c_length * convert_size (type);
				if mod (size, bits_per_word) ^= 0 & q -> reference.aligned_for_store_ref
				then do;
					q -> reference.ref_count = q -> reference.ref_count + 1;
					call expmac ((zero_mac (fixed (size > bits_per_word, 1))), q);
				     end;
			     end;
		     go to set_eis;
		end;

/* Aggregate temporaries have already been allocated, so it is wrong to
   allocate them again. */

	if q -> reference.aggregate
	then go to set_eis;

/* If we get here, we want to use a stack extension for the temporary, but we can still
   check to see if we can reuse a previously made extension or if we can extend it.
   This can be done if the relationship between the operand lengths is known
   at compile time. */

	if icat > 0
	then if p (2) -> reference.value_in.string_aq
	     then go to re_alloc;
	     else ;
	else if p (2) -> reference.value_in.string_aq
	then if q -> reference.length ^= null
	     then if dont_move
		then go to reuse;
		else if ^p (3) -> reference.varying_ref
			& (^p (3) -> reference.long_ref
			| (p (2) -> reference.length = p (3) -> reference.length & ^p (2) -> reference.varying_ref))
		then go to reuse;
		else ;

	     else do;
		     if q -> reference.c_length > p (2) -> reference.c_length
		     then do;
re_alloc:
			     call long_op$extend_stack (q, realloc_char_temp (icat) + dt);
			end;

		     else do;
reuse:
			     call state_man$update_ref (q);
			     if ^dont_move & p (2) -> reference.address_in.b (1)
			     then call base_man$update_base (2, q, 1);
			end;

		     if ^dont_move
		     then if ^p (2) -> reference.shared
			then call adjust_ref_count (p (2), -1);
		     cg_stat$eis_temp = q;
		     return (q);
		end;
	else ;

/* We must get a new stack extension */

	call long_op$extend_stack (q, alloc_char_temp + dt);

/* Update cg_stat$eis_temp and move in source operand */

set_eis:
	cg_stat$eis_temp = q;

	if ^dont_move
	then do;
		if op -> operator.op_code = and_bits
		then k = min (p (2) -> reference.c_length, p (3) -> reference.c_length);
		else k = 0;
		call long_op$eis (p (2), k, move_chars (icat) + dt);
	     end;

	return (q);


need_temp:
     proc returns (bit (1) aligned);

/* need_temp is called when operand(1) is not a temporary to determine if
   string_temp should replace operand(1) with a temporary in order to compile
   the expression.  need_temp tries to determine whether the generations of
   storage of operand(1) and the other operands overlap. */

dcl	alias		bit (1) aligned;
dcl	(i, n)		fixed bin;
dcl	(may_overlap, overlap_must_be_same_generation)
			bit (1) aligned;

	if q -> reference.defined_ref
	then return ("1"b);

	alias = q -> reference.aliasable;
	if dont_move
	then n = 2;
	else n = 3;

	do i = 2 to n;
	     call check_overlap (q, (p (i)), may_overlap, overlap_must_be_same_generation);

	     if may_overlap
	     then if ^overlap_must_be_same_generation | icat > 0 | i > 2
		then return ("1"b);
	end;

	if ^dont_move
	then if ^q -> reference.shared
	     then q -> reference.ref_count = q -> reference.ref_count + 1;
	return ("0"b);


check_overlap:
     proc (out, in, may_overlap, overlap_must_be_same_generation);

/* check_overlap determines if two operands may overlap, and, if they may, if
   the operands describe the same generation if they actually do
   overlap. */

dcl	out		ptr,			/* -> target reference node */
	in		ptr,			/* -> input reference node */
	may_overlap	bit (1) aligned,		/* ON if references may have overlapping storage (output) */
	overlap_must_be_same_generation
			bit (1) aligned;		/* ON -- if references overlap at all, they must
				   describe the same generation of storage (output) */

	may_overlap, overlap_must_be_same_generation = "0"b;

	if out -> reference.symbol = in -> reference.symbol
	then may_overlap = "1"b;
	else if alias
	then if in -> reference.aliasable
	     then if out -> reference.symbol -> symbol.aligned = in -> reference.symbol -> symbol.aligned
		then if out -> reference.symbol -> symbol.varying = in -> reference.symbol -> symbol.varying
		     then may_overlap = "1"b;

	if may_overlap
	then if ^in -> reference.substr & ^out -> reference.substr
		& (out -> reference.symbol -> symbol.aligned | out -> reference.symbol -> symbol.varying)
	     then overlap_must_be_same_generation = "1"b;

     end /* check_overlap */;


     end /* need_temp */;

     end;




		    xr_man.pl1                      10/03/83  1730.5rew 10/03/83  1009.4      142074



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


/* procedure to manage index registers

   Initial Version: 23 November, 1968 by BLW
	Modified: 18 May, 1971 by BLW for Version II
	Modified: 13 September, 1972 by BLW
	Modified: 11 February, 1973 by RAB
	Modified:	15 October 1975 by RAB for update_xr
	Modified:	3 November 1976 to fix 1545 by RAB
	Modified:	25 March 1977 by RAB to fix 1599
	Modified:	14 August 1978 by RAB to fix 1727
	Modified:	28 May 1979 by RAB to fix 1831 (a(b(i+j)-1) = 0;
		i = b(i+j); gets ERROR 315)
	Modified:	29 May 1979 by RAB to make minor changes to
		get_free_index, flush_old, and load_xr_v

   xr_man has the following entries:

   load_any_var	tries to find an index already holding specified
		variable.  if none exists, a new one is loaded.

   load_any_const	tries to find an index already holding specified
		constant.  if none exists, a new one is loaded

   load_var	loads specified index with variable unless index
		already holds variable

   load_const	loads specified index with constant unless index
		already holds constant

   lock		"locks" a variable in the index register in which
		it is known to be available;  a locked variable
		will be unloaded only if all the index registers
		become locked

   unlock		"unlocks" a variable

   super_lock	"super_locks" a variable in the index register in which it
		is known to be available.  A super_locked register cannot
		be unloaded.  This entry is called only from make_both_addressable.

   super_unlock	unlocks a register that was "super_locked"

   add_any_const	adds the contents of specified index register to specified constant
		and places result in any index register

   update_xr	updates the machine state to say that a variable is in the
		specified index

   The field "type" has the following meanings:

	0	empty

	1	constant

	2	variable + constant

	3	locked variable + constant

	-n	super_locked register of type n

						*/

xr_man$load_any_var: proc(var,xr,base_offset);

dcl	var	ptr,		/* points at var to be loaded */
	xr	fixed bin,	/* specifies index to load or loaded */
	base_offset fixed bin(18);	/* base offset to add to var */

dcl	cg_stat$last_index_used fixed bin ext,
	(cg_stat$text_pos,cg_stat$last_call) fixed bin(18) ext,
	(cg_stat$text_base,cg_stat$cur_statement) ptr ext,
	macro_table_$eax_array(0:15) fixed bin(15) ext static;

dcl	(p,vp) ptr,
	c fixed bin(18),
	sta_code bit(9) int static init("111101101"b),
	stq_code bit(9) int static init("111101110"b),
	staq_code bit(9) int static init("111101111"b),
	(i,j,k,type) fixed bin,
	lock bit(1) aligned init("0"b),
	expmac entry(fixed bin(15),ptr),
	c_a entry(fixed bin(18),fixed bin) returns(ptr),
	get_single_ref entry(ptr) returns(ptr),
	stack_temp$free_temp entry(ptr),
	adjust_ref_count entry(ptr,fixed bin),
	m_a entry(ptr,bit(2) aligned),
	error entry(fixed bin,ptr,ptr);

dcl	(abs,addrel,bit,fixed,min,mod,null,ptr,rel,string,substr) builtin;

dcl	word fixed bin based(p);

dcl	full_word bit(36) aligned based(p);

dcl	1 instruction	aligned based(p),
	2 offset		unal bit(18),
	2 op_code		unal bit(9),
	2 rest		unal bit(9);

dcl (	first_index	init(2),
	last_index	init(7)) fixed bin int static;

dcl	zero_mac 		init(308) fixed bin(15) int static;

%include cgsystem;
%include data_types;
%include boundary;
%include machine_state;
%include reference;
%include temporary;
%include symbol;
%include operator;
%include nodes;
%include "645op5";

	/* get ptr to variable */

join:	vp = var;

	j,k = -1;

	do i = first_index to last_index;
	     type = abs(index_regs(i).type);
	     if type = 0 then k = i;
	     else if type >= 2
		then if index_regs(i).variable = vp
		     then do;
			j = i;
			if index_regs(i).constant = base_offset then goto set_i_dec;
			end;
	     end;

	/* must load a register */

	call when_to_m_a;
	call get_free_index;
	c = base_offset;
	call load_xr_v(k);

ret_k:	xr = k;
	if lock
	     then index_regs(xr).type = -abs(index_regs(xr).type);
	return;

set_i_dec:
	if ^ vp -> reference.shared then call adjust_ref_count(vp,-1);

set_i:	index_regs(i).used = cg_stat$text_pos;

	xr = i;
	if lock
	     then index_regs(xr).type = -abs(index_regs(xr).type);
	return;

xr_man$load_any_const: entry(const,xr);

dcl	const	fixed bin(18);	/* value of constant to be loaded */

	k = -1;
	do i = first_index to last_index;
	     type = abs(index_regs(i).type);
	     if type = 0 then k = i;
	     else if type = 1
		then if index_regs(i).constant = const then goto set_i;
	     end;

	/* did not have index register holding exact value of
	   the constant, must load one */

	call get_free_index;
	call load_xr_c(k);
	goto ret_k;

xr_man$load_var: entry(var,xr);

	i = xr;

	vp = var;

	if index_regs(i).type < 2 then goto lv;
	if index_regs(i).variable ^= vp then goto lv;
	if index_regs(i).constant = 0
	then do;
	     if ^ vp -> reference.shared
	     then call adjust_ref_count(vp,-1);
	     goto lc_used;
	     end;

lv:	c = 0;
	j,k = -1;
	cg_stat$last_index_used = i;
	call when_to_m_a;
	call load_xr_v(xr);
	return;

xr_man$load_const:	entry(const,xr);

	i = xr;
	if index_regs(i).type ^= 1 then goto lc;

	if index_regs(i).constant = const
	then do;
lc_used:	     index_regs(i).used = cg_stat$text_pos;
	     return;
	     end;

lc:	call load_xr_c(xr);
	cg_stat$last_index_used = i;
	return;


xr_man$lock: entry(var,xr);

	i = xr;
	var -> reference.value_in.x(i) = "1"b;
	index_regs(i).variable = var;
	index_regs(i).type = 3;
	return;

xr_man$unlock: entry(ix);

dcl	ix fixed bin;

	index_regs(ix).type = 2;
	return;


xr_man$super_lock:	entry(ix);

	index_regs(ix).type = -abs(index_regs(ix).type);
	return;


xr_man$super_unlock:	entry(ix);

	index_regs(ix).type = abs(index_regs(ix).type);
	return;


xr_man$add_any_const:	entry(const,xr,old_xr);

dcl	old_xr fixed bin;

	j = old_xr;
	c = index_regs(j).constant + const;

	if index_regs(j).type >= 2
	then do;
	     vp = index_regs(j).variable;

	     if ^ vp -> reference.shared
		then vp -> reference.ref_count = vp -> reference.ref_count + 1;

	     call xr_man$load_any_var(vp,xr,c);

	     end;
	else call xr_man$load_any_const(c,xr);

	return;


xr_man$load_any_var_and_lock:	entry(var,xr,base_offset);

	lock = "1"b;
	go to join;


xr_man$update_xr:	entry(var,xr);

	vp = var;
	i = xr;

	call flush_old(i);

	vp -> reference.value_in.x(i) = "1"b;
	index_regs(i).type = 2;
	index_regs(i).variable = vp;
	index_regs(i).constant = 0;
	index_regs(i).used = cg_stat$text_pos;
	return;

/*  */


when_to_m_a:	proc;
dcl	p ptr;

/* Decide whether we must make vp addressable before looking for a free index register
   and loading vp */

	if j >= 0 then return;
	if vp->reference.value_in.a then return;
	if vp->reference.value_in.q then return;
	if string(vp->reference.value_in.x) then return;
	if ^ vp -> reference.no_address
	     then if vp -> reference.perm_address
		     then return;

	do p = vp->reference.offset repeat p->reference.offset while (p ^= null);
		if p->node.type = operator_node
		     then p = p->operand(1);
		if p->reference.ref_count > 1
		 | p -> reference.temp_ref & string(p -> reference.value_in.x) = "0"b
		then do;
			call m_a(vp,"0"b);
			vp->reference.perm_address = "1"b;
			if k >= 0
			     then if index_regs(k).type ^= 0
				then do;
					k = -1;
					do i = first_index to last_index;
						if index_regs(i).type = 0
						     then k = i;
					end;
				     end;
			return;
		     end;
	end;
end;



/*  */
get_free_index: proc;

	     /* if an empty register was found during scan use that,
	        otherwise, try to pick a register containing a constant;
	        if none, try to pick register containing unlocked
	        variable with smallest reference count; as a last
	        resort, pick locked variable with smallest reference
	        count */

dcl	     (i,j,cmin,ignore,n,type) fixed bin,
	     p ptr;

	     /* note: variable 'k' lives in outer block */

	     if k >= 0
	     then do;
		cg_stat$last_index_used = k;
		return;
		end;

	     ignore = 3;			/* ignore locked vars */

look:	     j = -1;
	     cmin = 123456;

	     do i = cg_stat$last_index_used + 1 to last_index, first_index to min(cg_stat$last_index_used,last_index);

		type = index_regs(i).type;

		if type >= 0 & type ^= ignore
		then do;

		     if type = 0 | type = 1
		     then do;
			k, cg_stat$last_index_used = i;
			return;
			end;

		     p = index_regs(i).variable;

		     if p -> reference.shared
		     then if p -> reference.temp_ref
			then n = 0;
			else n = 1;
		     else n = p -> reference.ref_count;

		     if n = 0
		     then do;
			k, cg_stat$last_index_used = i;
			return;
			end;

		     if n < cmin
		     then do;
			j = i;
			cmin = n;
			end;
		     else if n = cmin
			then if index_regs(i).used < index_regs(j).used
			     then do;
				j = i;
				cmin = n;
				end;
		     end;

		end;

	     if j >= 0
	     then do;
		k, cg_stat$last_index_used = j;
		return;
		end;

	     /* we should never get here with ignore already = 2 */

	     if ignore = 3
	     then do;
		ignore = 2;
		goto look;
		end;

	     call error(328,cg_stat$cur_statement,vp);
	     k = 1;
	     end;

/*  */
load_xr_v:     proc(xr);

dcl	     xr	fixed bin;	/* index to load */

dcl	     (p,q,old_p,text_pt) ptr,
	     x fixed bin,
	     b18 bit(18),
	     (n,text_pos,c1,i) fixed bin(18),
	     op_code bit(9) aligned;

	     x = xr;
	     p, q = vp;

	     c1 = c;
	     if c1 < 0 then c1 = c1 + 262144;		/* 2's complement */

	     if p -> reference.value_in.q
	     then do;
		n = 0;
		goto l2;
		end;

	     if p -> reference.value_in.a
	     then if p -> reference.aligned_ref | a_reg.offset = 0 | a_reg.offset = 18
	     then do;
		if ^ p -> reference.aligned_ref & a_reg.offset = 0
		     then n = 16;
		     else n = 8;
l2:
		call flush_old(x);

		text_pos = cg_stat$text_pos;
		cg_stat$text_pos = cg_stat$text_pos + 1;
		goto l3;
		end;

	     if j >= 0
	     then do;

		/* value of variable is in another index with different
		   base_offset, we can generate the instruction
			eaxx	diff,j			*/

		call flush_old(x);

		old_p = c_a((j),8);
		c1 = c - index_regs(j).constant;
		if c1 < 0 then c1 = c1 + 262144;
		substr(string(old_p -> reference.address),1,18) = bit(c1,18);
		call expmac(eax0+x,old_p);
		if ^p -> reference.shared
		     then call adjust_ref_count(p,-1);
		goto l4;
		end;

	     if p -> reference.value_in.storage then goto test;

	     if ^ p -> reference.temp_ref then goto gen_lxl;

	     if p -> reference.aggregate then goto gen_lxl;

	     call error(315,cg_stat$cur_statement,p);

test:	     if p -> reference.symbol -> symbol.c_dcl_size >= bits_per_half then goto gen_lxl;

	     text_pos = fixed(p -> reference.store_ins,18);
	     if text_pos < cg_stat$last_call then goto gen_lxl;

	     if c ^= 0
	     then if ^ p -> reference.dont_save
		then go to gen_lxl;

	     if index_regs(x).used >= text_pos
	     then do;
gen_lxl:		if p -> reference.data_type = real_fix_bin_2
		     then q = get_single_ref(p);

		n = lxl0;
		if ^ p -> reference.aligned_ref
		then if p -> reference.units = word_ 
		     then n = ldx0;

		if ^ q -> reference.perm_address
		then do;
		     call m_a(q,"00"b);
		     q -> reference.perm_address = "1"b;
		     end;

		call flush_old(x);

		call expmac(n+x,q);
		if c ^= 0
		then do;
		     old_p = c_a(c,1);
		     old_p -> reference.tag = "001"b || bit(fixed(x,3),3);
		     call expmac(eax0+x,old_p);
		     end;
		end;

	     else do;

		/* the index register was not used from the point of the
		   store instruction which evaluated the expression to
		   the current instruction.  we'll attempt to change the
		   store instruction into an eax instruction */

		text_pt = addrel(cg_stat$text_base,text_pos);
		op_code = text_pt -> instruction.op_code;

		if op_code = sta_code then n = 8;
		else if op_code = stq_code then n = 0;
		     else if op_code = staq_code then n = 0;
			else goto gen_lxl;

		/* make sure that the value was not used from the time it was
		   put in storage.  we do this by looking for the address of
		   the temporary being used.  This prevents a bug which might
		   occur in the sequence
			dcl (a(10),b(10,10)) fixed bin;
			a(k) = b(k,k);
		   where we might otherwise change "stq temp" into "eaxn 0,ql"
		   even though sequence for calculating b's subscript did
		   "adq temp"	*/

		b18 = "110"b || bit(fixed(mod(p -> reference.qualifier -> temporary.location,16384),15),15);
		do i = text_pos + 1 to cg_stat$text_pos - 1;
		     if b18 = addrel(cg_stat$text_base,i) -> instruction.offset then goto gen_lxl;
		     end;

		call flush_old(x);

		call stack_temp$free_temp(p);
		p -> reference.allocated = "0"b;
		p -> reference.store_ins = "0"b;
		p -> reference.value_in.storage = "0"b;

l3:		index_regs(x).changed = text_pos;
		text_pt = addrel(cg_stat$text_base,text_pos);

		text_pt -> word = macro_table_$eax_array(n+x);

		if c ^= 0
		then do;
		     if c > 0
			then c1 = c;
			else c1 = c + 262144;
		     text_pt -> instruction.offset = bit(c1,18);
		     end;

		index_regs(x).instruction = text_pt -> full_word;

		if ^p -> reference.shared
		     then call adjust_ref_count(p,-1);
		end;

l4:
	     index_regs(x).variable = p;
	     if c = 0
		then p -> reference.value_in.x(x) = "1"b;

	     if p -> reference.symbol ^= null then p -> reference.perm_address = "0"b;

	     index_regs(x).type = 2;
	     index_regs(x).constant = c;
	     index_regs(x).used = cg_stat$text_pos;
	     end;




load_xr_c:     proc(xr);

dcl	     (x,xr) fixed bin;

	     x = xr;

	     call flush_old(x);

	     index_regs(x).used = cg_stat$text_pos;
	     call expmac(lxl0+x,c_a(const,2));
	     index_regs(x).type = 1;
	     index_regs(x).constant = const;
	     end;


/*  */
flush_old:	proc(xr);

dcl	     (xr,x) fixed bin;
dcl	     old_p pointer;
dcl	     macro fixed bin(15);

	     x = xr;

	     if index_regs(x).type < 2
		then return;

	     /* have a variable in the index register, if it is a temporary
	        which doesn't exist in storage, we'll have to save it */

	     old_p = index_regs(x).variable;
	     old_p -> reference.value_in.x(x) = "0"b;

	     if ^ old_p -> reference.temp_ref
	      | old_p -> reference.value_in.storage
	      | index_regs(x).constant ^= 0
		then return;

	     if old_p -> reference.ref_count > 0
	     then do;
		if old_p -> reference.symbol -> symbol.c_dcl_size >= bits_per_half
		then do;
		     old_p -> reference.ref_count = old_p -> reference.ref_count + 2;
		     call expmac((zero_mac),old_p);
		     macro = sxl0 + x;
		     end;

		else do;
		     old_p -> reference.ref_count = old_p -> reference.ref_count + 1;

		     /* convert the old reference in index register into
		        a "packed" integer in storage */

		     old_p -> reference.aligned_ref = "0"b;
		     old_p -> reference.c_offset = 0;
		     old_p -> reference.c_length = bits_per_half;
		     old_p -> reference.units = word_;

		     /* We set reference.dont_save as a
		        kludge to fix bug 1599.  This
		        prevents save_value from converting
		        this back to an aligned temp,
		        which could cause problems after
		        an if statement. */

		     old_p -> reference.dont_save = "1"b;
		     macro = stx0 + x;
		     end;

		call expmac(macro,old_p);
		old_p -> reference.value_in.storage = "1"b;

		index_regs(x).used = cg_stat$text_pos;
		end;
	     end;


	end;

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