



		    fort_instruction_info_.cds      12/27/84  0834.7rew 12/27/84  0751.7       19152



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

/* format: style3,^delnl,linecom */
fort_instruction_info_:
     proc;

dcl	(i, j)		fixed bin;
dcl	code		fixed bin (35);

dcl	1 cdsa		aligned auto like cds_args;

dcl	1 fort_instruction_info_
			aligned,
	  2 fort_instruction_info_
			(0:1023) aligned,
	    3 alters	unaligned structure,
	      4 a		bit (1),
	      4 q		bit (1),
	      4 indicators	bit (1),
	      4 bases	(6) bit (1),
	      4 index_regs	(0:7) bit (1),
	      4 pad1	bit (1),
	    3 directable	bit (1) unaligned,
	    3 pad2	bit (17) unaligned;

dcl	1 pl1$instruction_info
			(0:1023) aligned ext static,
	  2 alters	bit (18) unal,
	  2 directable	bit (1) unal,
	  2 pad		bit (8) unal,
	  2 num_words	fixed bin (7) unal,
	  2 double_ins	bit (1) unal;

dcl	me		char (22) int static options (constant) init ("fort_instruction_info_");

dcl	create_data_segment_
			entry (ptr, fixed bin (35));

dcl	(addr, divide, mod, null, size, string)
			builtin;

%include cds_args;

/* initialize the table */

	do i = 0 to 1023;
	     j = divide (i, 2, 17, 0) + 512 * mod (i, 2);

	     string (fort_instruction_info_ (i).alters) = pl1$instruction_info (j).alters;
	     fort_instruction_info_.directable (i) = pl1$instruction_info.directable (j);
	     fort_instruction_info_ (i).pad2 = "0"b;
	end;

/* set up for create_data_segment_ */

	cdsa.sections (1).p = addr (fort_instruction_info_);
	cdsa.sections (1).len = size (fort_instruction_info_);
	cdsa.sections (1).struct_name = me;

	cdsa.seg_name = me;
	cdsa.num_exclude_names = 0;
	cdsa.exclude_array_ptr = null;

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	return;
     end;




		    fort_make_symbol_section.pl1    05/30/90  1552.3rew 05/30/90  1533.8      613530



/****^  *********************************************************
        *                                                       *
        * Copyright, (C) BULL HN Information Systems Inc., 1990 *
        *                                                       *
        * Copyright, (C) Honeywell Limited, 1983                *
        *                                                       *
        * Copyright (c) 1972 by Massachusetts Institute of      *
        * Technology and Honeywell Information Systems, Inc.    *
        *                                                       *
        ********************************************************* */



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 472.
  2) change(86-10-17,Ginter), approve(86-10-17,MCR7556), audit(86-10-22,Huen),
     install(86-11-13,MR12.0-1216):
     Fixed fortran bugs 496 and 502.
  3) change(87-04-15,Huen), approve(87-04-15,MCR7651), audit(87-04-15,RWaters),
     install(87-05-08,MR12.1-1031):
     Fix fortran bug 431.
  4) change(90-04-27,Huen), approve(90-04-27,MCR8159), audit(90-05-16,Gray),
     install(90-05-30,MR12.4-1011):
     ft_512 : enable probe to display correct values for parameter variables
     when the object segments are bound.
                                                   END HISTORY COMMENTS */


/* format: style3,^delnl,ifthenstmt,^indattr,indcom,indend,^inditerdo,^indnoniterdo,indnoniterend,linecom */
fort_make_symbol_section:
     procedure (P_shared_global_ptr, P_cg_global_ptr, P_param_ptr, P_sym_offset, P_sym_length);

	/* Fortran compiler's routines for building the runtime symbol table.

Written:	21 August 1979 by C R Davis (actually stolen from the CGs).

Modified: 31 Mar 90, SH - 512: Set up relocation information for the symbol
          table entries that describe parameter variables.
Modified: 17 Feb 87, RW & SH - 431: Allow substrings in Equivalence 
          statements for ANSI 77.
Modified: 09 Sep 86, AG - 496: use symbol.addr_hold when creating runtime
	symbol table for VL Common blocks whose first element is a
	nondimensioned symbol.
Modified: 16 Oct 85, BW - 472: Don't put lines without object code in the
	statement map.
Modified: 28 Mar 84, HH - Install HFP support.
Modified: 29 Aug 83, RG - To change call from lang_util_ to ioa_$rsnnl
Modified: 31 Jan 83, TO - Install LA/VLA support.
Modified: 23 Dec 82, TO - 367: Implement PARAMETER variables in table.
Modified: 17 December 1982, TO - Add '-long_profile' support.
Modified: 17 May 1982, TO - fix to runtime reference to character*(*)
	multiplier.  This must be a byte multiplier, the descriptor mult is
	bits.  Refer now to extended multipler which ends extended
	descriptor.
Modified:  4 May 1982, TO - fix to put star_extent length correctly addressed
	by runtime_symbol.size.
Modified:  4 May 1982, TO - fix to get_address to reflect that stack_indirects
	have their stack location in symbol.location, not in
	symbol.address.offset.
Modified: 18 February 1981, CRD - change process_variable to fill in lower
	bound information for Fortran 77 arrays.
Modified: 15 October 1979, CRD - renamed fort_make_symbol_table to
	fort_make_symbol_section.
Modified: 12 Spetember 1979, CRD - fix bug 241 (runtime_symbol.next
	invalid when symbols more than 16K apart.
Modified: 30 August 1979, CRD - set runtime_symbol.units and
	runtime_symbol.array_units in preparation for ANSI 77
	character mode.
*/


declare						/* Parameters */

	P_shared_global_ptr pointer,			/* Input */
	P_cg_global_ptr pointer,			/* Input */
	P_param_ptr pointer,			/* Input */
	P_sym_offset fixed binary (18),		/* Input */
	P_sym_length fixed binary (18);		/* Output */


declare						/* Automatic */

	a_base pointer,
	cg_global_ptr pointer,
	def_pos fixed binary (18),
	def_reloc_base pointer,
	first_namelist fixed binary (18),
	generate_map bit (1) aligned,
	generate_profile bit (1) aligned,
	generate_symtab bit (1) aligned,
	info_ptr pointer,
	last_pos fixed binary (18),
	link_base pointer,
	link_pos fixed binary (18),
	link_reloc_base pointer,
	profile_start fixed binary (18),
	shared_global_ptr pointer,
	star_symbol_link fixed binary (18),
	sym_base pointer,
	sym_pos fixed binary (18),
	symrel fixed binary (18),
	sym_reloc_base pointer,
	symtab_param_ptr pointer,
	text_pos fixed binary (18);

declare						/* Overlays */

	a_name (0:261119 - 2 * (number_of_lines + 1)) fixed binary (18) aligned based (a_base),
	polish (0:polish_max_len - 1) fixed binary (18) aligned based (polish_base),
	quads (0:quad_max_len - 1) fixed binary (18) aligned based (quadruple_base),
	rands (0:operand_max_len - 1) fixed binary (18) aligned based (operand_base),
	reloc (0:3) bit (36) aligned based,
	vsegname character (32) varying defined (objectname);

declare

	1 text_halfs (0:262143) aligned based (object_base),
	  2 left fixed binary (17) unaligned,
	  2 right fixed binary (17) unaligned;


declare

	1 reloc_halfs (0:262143) aligned based (relocation_base),
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;


declare						/* Builtins */

	(addr, addrel, binary, bit, divide, fixed, hbound, length, ltrim,
	max, min, mod, null, rel, size, string, substr, ptr, unspec, verify)
          builtin;

%include fort_nodes;

%include fort_opt_nodes;

%include fort_listing_nodes;

declare

	1 shared_globals structure aligned based (shared_global_ptr),

%include fort_shared_vars;

declare

	1 cg_globals structure aligned based (cg_global_ptr),

%include fort_cg_vars;

%include fort_options;

%include fort_system_constants;

declare

	1 symtab_parameters structure aligned based (symtab_param_ptr),

%include fort_symtab_parms;

%include pl1_symbol_block;

%include std_symbol_header;

%include profile_entry;
%include long_profile;

%include relbts;

	/* Copy input arguments */

	shared_global_ptr = P_shared_global_ptr;
	cg_global_ptr = P_cg_global_ptr;
	symtab_param_ptr = P_param_ptr;
	symrel = P_sym_offset;

	/* Copy status of partial object segment */

	link_base = symtab_parameters.link_base_ptr;
	link_reloc_base = symtab_parameters.link_reloc_base_ptr;
	def_reloc_base = symtab_parameters.def_reloc_base_ptr;
	text_pos = symtab_parameters.current_text_offset;
	def_pos = symtab_parameters.current_def_offset;
	link_pos = symtab_parameters.current_link_offset;
	last_pos = symtab_parameters.final_text_offset;
	profile_start = symtab_parameters.profile_offset;
	star_symbol_link = symtab_parameters.star_symbol_link;
	first_namelist = symtab_parameters.first_namelist_symbol;


	if shared_globals.options.list
	then a_base = addr (source_list (number_of_lines + 2));


	/* Set up symbol table and relocation pointers */

	sym_base = addrel (object_base, symrel);
	sym_reloc_base = addrel (relocation_base, symrel);
	sym_pos = 0;

	/* Decide how much of the symbol table to generate */

	generate_map = shared_globals.options.brief_table
	     | shared_globals.options.table
	     | shared_globals.options.profile;
	generate_profile = shared_globals.options.profile;
	generate_symtab = shared_globals.options.table
	     | shared_globals.options.namelist_used;

	/* Now start generating the symbol table */

	call init_symbol ();

	if generate_map
	then if shared_globals.options.optimize
	     then call gen_opt_statement_map ();
	     else call gen_statement_map ();

	if generate_symtab
	then do;
	     call make_symbol_table ();
	     call fill_sym_info_into_entries ();
	     if shared_globals.options.namelist_used
	     then call make_ok_lists ();
	     end;

	call end_symbol ();

	P_sym_length = sym_pos;			/* Return length */

	return;

init_symbol:
     procedure ();

	/* starts generating the symbol section */

dcl	(sym_ptr, map_ptr, sp, sym_reloc_ptr) ptr;

dcl	source_index fixed bin (18);
dcl	(m, n) fixed bin (18);

dcl	version_name_and_number char (148) varying;

dcl	fort_$symbol_table fixed bin (17) ext static;

dcl	size builtin;

%include source_map;

	/* generate symbol table header */

	sym_ptr = sym_base;
	sym_pos = size (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 = 1;
	sym_ptr -> std_symbol_header.gen_created = addr (fort_$symbol_table) -> std_symbol_header.object_created;

	sym_ptr -> std_symbol_header.object_created = date_time_compiled;

	sym_ptr -> std_symbol_header.generator = compiler_name;

	version_name_and_number =
	     fort_version_info$version_name || fort_version_info$version_number;
						/* keep store_string quick */
	string (sym_ptr -> std_symbol_header.gen_version) = store_string (version_name_and_number);

	string (sym_ptr -> std_symbol_header.userid) = store_string (vuser_id);

	string (sym_ptr -> std_symbol_header.comment) = store_string (options_string);

	sym_ptr -> std_symbol_header.text_boundary,
	     sym_ptr -> std_symbol_header.stat_boundary = "000000000000000010"b;

	/* generate source map (which must start on even boundary) */

	sym_pos = sym_pos + mod (sym_pos, 2);

	sym_ptr -> std_symbol_header.source_map = bit (sym_pos, 18);

	map_ptr = addrel (sym_base, sym_pos);
	map_ptr -> source_map.version = 1;
	map_ptr -> source_map.number, n = number_of_source_segments;

	sym_pos = sym_pos + size (source_map);

	source_index = first_segment;

	do m = 1 to n;
	     sp = addr (rands (source_index));
	     string (map_ptr -> source_map.map (m).pathname) = store_string (sp -> source.pathname);
	     map_ptr -> source_map.map (m).uid = sp -> source.uid;
	     map_ptr -> source_map.map (m).dtm = sp -> source.dtm;
	     source_index = sp -> source.next;
	     end;

	/* generate pl1 symbol block */

	sym_ptr -> std_symbol_header.area_pointer = bit (sym_pos, 18);

	info_ptr, sym_ptr = addrel (sym_base, sym_pos);
	sym_reloc_ptr = addrel (sym_reloc_base, sym_pos);

	sym_pos = sym_pos + size (pl1_symbol_block);

	sym_ptr -> pl1_symbol_block.version = 1;
	sym_ptr -> pl1_symbol_block.identifier = "pl1info";
	sym_ptr -> pl1_symbol_block.greatest_severity = error_level;

	sym_ptr -> pl1_symbol_block.flags.io = shared_globals.options.namelist_used;
	sym_ptr -> pl1_symbol_block.flags.map = generate_map;

	string (sym_ptr -> pl1_symbol_block.segname) = store_string (vsegname);

	if generate_profile
	then do;
	     sym_ptr -> pl1_symbol_block.flags.profile = "1"b;
	     sym_ptr -> pl1_symbol_block.profile = bit (profile_start, 18);
	     sym_reloc_ptr -> pl1_symbol_block.profile = rc_is18;
	     sym_ptr -> pl1_symbol_block.flags.long_profile =
		shared_globals.options.long_profile;
	     end;

	sym_base -> std_symbol_header.maxi_truncate = bit (sym_pos, 18);

	return;
     end init_symbol;

gen_opt_statement_map:
     procedure ();

	/* generates statement_map to support brief_table & table */

dcl	(cs, stm, q, pp, next_stm_ptr) ptr;
dcl	first_code_loc fixed bin (18);
dcl	first_time bit (1) aligned;
dcl	last_code_loc fixed bin (18);
dcl	map_start fixed bin (18);
dcl	profile_pos fixed bin (18);
dcl	old_id bit (27);

%include statement_map;

	if shared_globals.options.long_profile
	then do;
	     profile_pos = profile_start + size (long_profile_header);
	     pp = addrel (link_base, profile_start);
	     pp -> long_profile_header.nentries = 0;
	     end;
	else profile_pos = profile_start;

	map_start = sym_pos;
	info_ptr -> pl1_symbol_block.map.first = bit (sym_pos, 18);
	first_time = "1"b;

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram
	     while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));
	     old_id = (27)"1"b;

	     cs -> subprogram.map.first = sym_pos;

	     do cur_statement = cs -> subprogram.first_quad repeat binary (stm -> opt_statement.next, 18)
		while (cur_statement > 0 | first_time);
		first_time = "0"b;
		stm = addr (quads (cur_statement));

		if stm -> opt_statement.put_in_map & ^stm -> opt_statement.moved
		then if old_id ^= unspec (stm -> opt_statement.source_id)
			| generate_profile & stm -> opt_statement.put_in_profile
		     then do;
			first_code_loc = binary (stm -> opt_statement.location, 18);
			if stm -> opt_statement.next = "0"b
			then last_code_loc = -1;
			else do;
			     next_stm_ptr = ptr (stm, stm -> opt_statement.next);
			     last_code_loc = binary (next_stm_ptr -> opt_statement.location, 18) - 1;
			     end;
			if last_code_loc >= first_code_loc
						/* Only put the line in the statement map if it contains object code. */
			then do;
			     old_id = unspec (stm -> opt_statement.source_id);

			     q = addrel (sym_base, sym_pos);
			     q -> statement_map.location = stm -> opt_statement.location;
			     unspec (q -> statement_map.source_id) = unspec (stm -> opt_statement.source_id);
			     q -> statement_map.source_info.start =
				bit (fixed (stm -> opt_statement.start, 18), 18);
			     q -> statement_map.source_info.length = stm -> opt_statement.length;

			     addrel (sym_reloc_base, sym_pos) -> reloc (0) = rc_t;

			     if generate_profile
			     then if stm -> opt_statement.put_in_profile
				then do;
				     addrel (link_base, profile_pos) -> profile_entry.map =
					bit (fixed (sym_pos - map_start, 18), 18);
				     if shared_globals.options.long_profile
				     then do;
					profile_pos = profile_pos + size (long_profile_entry);
					pp -> long_profile_header.nentries =
					     pp -> long_profile_header.nentries + 1;
					end;
				     else profile_pos = profile_pos + size (profile_entry);
				     end;

			     sym_pos = sym_pos + size (statement_map);
			     end;
			end;
		end;
	     cs -> subprogram.map.last = sym_pos;
	     end;

	/* generate dummy last entry */

	q = addrel (sym_base, sym_pos);
	q -> statement_map.location = bit (last_pos, 18);
	unspec (q -> statement_map.source_id) = (27)"1"b;

	addrel (sym_reloc_base, sym_pos) -> reloc (0) = rc_t;

	if generate_profile
	then addrel (link_base, profile_pos) -> profile_entry.map = bit (fixed (sym_pos - map_start, 18), 18);

	sym_pos = sym_pos + size (statement_map);

	info_ptr -> pl1_symbol_block.map.last = bit (sym_pos, 18);

     end gen_opt_statement_map;

gen_statement_map:
     procedure ();

	/* generates statement_map to support brief_table & table */

dcl	(cs, stm, q, pp, next_stm_ptr) ptr;
dcl	first_code_loc fixed bin (18);
dcl	first_time bit (1) aligned;
dcl	last_code_loc fixed bin (18);
dcl	map_start fixed bin (18);
dcl	profile_pos fixed bin (18);
dcl	old_id bit (27);

%include statement_map;

	if shared_globals.options.long_profile
	then do;
	     profile_pos = profile_start + size (long_profile_header);
	     pp = addrel (link_base, profile_start);
	     pp -> long_profile_header.nentries = 0;
	     end;
	else profile_pos = profile_start;

	map_start = sym_pos;
	info_ptr -> pl1_symbol_block.map.first = bit (sym_pos, 18);
	first_time = "1"b;

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram
	     while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));
	     old_id = (27)"1"b;

	     cs -> subprogram.map.first = sym_pos;

	     do cur_statement = cs -> subprogram.first_polish repeat binary (stm -> statement.next, 18)
		while (cur_statement > 0 | first_time);
		first_time = "0"b;
		stm = addr (polish (cur_statement));

		if stm -> statement.put_in_map
		then if old_id ^= unspec (stm -> statement.source_id)
			| generate_profile & stm -> statement.put_in_profile
		     then do;
			first_code_loc = binary (stm -> statement.location, 18);
			if stm -> statement.next = "0"b
			then last_code_loc = -1;
			else do;
			     next_stm_ptr = ptr (stm, stm -> statement.next);
			     last_code_loc = binary (next_stm_ptr -> statement.location, 18) - 1;
			     end;
			if last_code_loc >= first_code_loc
						/* Only put the line in the statement map if it contains object code. */
			then do;
			     old_id = unspec (stm -> statement.source_id);

			     q = addrel (sym_base, sym_pos);
			     q -> statement_map.location = stm -> statement.location;
			     unspec (q -> statement_map.source_id) = unspec (stm -> statement.source_id);
			     q -> statement_map.source_info.start = bit (fixed (stm -> statement.start, 18), 18);
			     q -> statement_map.source_info.length = stm -> statement.length;

			     addrel (sym_reloc_base, sym_pos) -> reloc (0) = rc_t;

			     if generate_profile
			     then if stm -> statement.put_in_profile
				then do;
				     addrel (link_base, profile_pos) -> profile_entry.map =
					bit (fixed (sym_pos - map_start, 18), 18);
				     if shared_globals.options.long_profile
				     then do;
					profile_pos = profile_pos + size (long_profile_entry);
					pp -> long_profile_header.nentries =
					     pp -> long_profile_header.nentries + 1;
					end;
				     else profile_pos = profile_pos + size (profile_entry);
				     end;

			     sym_pos = sym_pos + size (statement_map);
			     end;
			end;
		end;
	     cs -> subprogram.map.last = sym_pos;
	     end;

	/* generate dummy last entry */

	q = addrel (sym_base, sym_pos);
	q -> statement_map.location = bit (last_pos, 18);
	string (q -> statement_map.source_id) = (27)"1"b;

	addrel (sym_reloc_base, sym_pos) -> reloc (0) = rc_t;

	if generate_profile
	then addrel (link_base, profile_pos) -> profile_entry.map = bit (fixed (sym_pos - map_start, 18), 18);

	sym_pos = sym_pos + size (statement_map);

	info_ptr -> pl1_symbol_block.map.last = bit (sym_pos, 18);

     end gen_statement_map;

fill_sym_info_into_entries:
     procedure ();

	/* puts runtime symbol table info into entry sequence */

dcl	(cs, s, p) ptr;
dcl	(sym, star_symbol) fixed bin (18);
dcl	text_pos fixed bin (18);

	s = addr (rands (star_symbol_link));
	star_symbol = s -> symbol.address.offset;
	if s -> symbol.large_address
	then star_symbol = star_symbol + s -> symbol.location;

	do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));
	     cs = addr (rands (s -> symbol.parent));

	     /* do the following only if runtime block was allocated */

	     if cs -> subprogram.runtime ^= 0
	     then do;
		text_pos = s -> label.location;	/* a slight kludge */

		/* fill in trailer */

		text_halfs (text_pos + 4).left = star_symbol;
		text_halfs (text_pos + 4).right = cs -> subprogram.runtime;

		reloc_halfs (text_pos + 4).left = rc_lp18;
		reloc_halfs (text_pos + 4).right = rc_s;

		/* fill in namelist information */

		if shared_globals.options.list	/* tell listing generator which are not insts */
		then do;
		     a_name (text_pos + 3) = -1;
		     a_name (text_pos + 4) = -1;
		     end;

		if cs -> subprogram.namelist_used
		then do;
		     if cs -> subprogram.subprogram_type = main_program
		     then p = s;			/* no associated rel con for main */
		     else p = addr (rands (s -> symbol.initial));
						/* get associated rel con */

		     text_pos = p -> label.hash_chain;
		     text_halfs (text_pos).left = cs -> subprogram.runtime;
		     reloc_halfs (text_pos).left = rc_s;
		     end;
		end;				/* do block for subprograms with runtime_block nodes */
	     end;

     end fill_sym_info_into_entries;

make_ok_lists:
     procedure ();

	/* builds ok lists for namelist */

dcl	(i, ipol, sym, text_pos) fixed bin (18);
dcl	(s, q, qr) ptr;

dcl	1 ok_list aligned based,
	  2 number fixed bin (18),
	  2 offset (polish (ipol) + 1) bit (18) unal;

dcl	1 ok_list_reloc aligned based,
	  2 number fixed bin (18),
	  2 offset (polish (ipol) + 1) bit (18) unal;

	do sym = first_namelist repeat s -> symbol.next_member while (sym > 0);
	     s = addr (rands (sym));
	     text_pos = s -> label.location;
	     q = addrel (object_base, text_pos);
	     qr = addrel (relocation_base, text_pos);
	     ipol = s -> symbol.initial;

	     q -> ok_list.number = polish (ipol) + 1;
	     q -> ok_list.offset (1) = s -> symbol.runtime;
	     qr -> ok_list_reloc.offset (1) = rc_s;

	     do i = 1 to polish (ipol);
		q -> ok_list.offset (i + 1) = addr (rands (polish (ipol + i))) -> symbol.runtime;
		qr -> ok_list_reloc.offset (i + 1) = rc_s;
		end;
	     end;

     end make_ok_lists;

end_symbol:
     procedure ();

	/* finishes off the symbol section */

dcl	(p, sym_ptr) ptr;
dcl	(i, j, k, l, m) fixed bin (18);
dcl	b18 bit (18) aligned;
dcl	sym_rel_bit_count fixed bin (27);

dcl	1 reloc_in aligned based (p),
	  2 half_word (0:1000) unaligned bit (18);

dcl	1 relinfo aligned based,
	  2 version fixed bin (18),
	  2 rel_bit_count fixed bin (18),
	  2 relbits bit (i refer (rel_bit_count)) unaligned;

	sym_base -> std_symbol_header.mini_truncate = bit (sym_pos, 18);

	/* following is section that packs relocation bits into the symbol section */

	l = 1;
	sym_rel_bit_count = sym_pos;
	sym_ptr = addrel (sym_base, sym_pos);

	if shared_globals.options.relocatable
	then do p = relocation_base, def_reloc_base, link_reloc_base, sym_reloc_base;

	     b18 = bit (sym_pos, 18);

	     if l = 1
	     then do;
		m = text_pos;
		sym_base -> std_symbol_header.rel_text = b18;
		end;
	     else if l = 2
	     then do;
		m = 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 halfwords */

			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;

	/* finish off symbol header */

	sym_base -> std_symbol_header.block_size = bit (sym_pos, 18);

expanded_absolute:
     procedure ();

	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;

     end end_symbol;

store_string:
     procedure (str) returns (bit (36) aligned);

dcl	str char (*) varying;

dcl	b36 bit (36),
	based_string char (length (str)) based aligned;

	if length (str) = 0
	then return ((36)"0"b);

	substr (b36, 1, 18) = bit (sym_pos, 18);
	addrel (sym_base, sym_pos) -> based_string = str;
	sym_pos = sym_pos + divide (length (str) + 3, 4, 17, 0);
	substr (b36, 19, 18) = bit (fixed (length (str), 18), 18);

	return (b36);

     end store_string;

make_symbol_table:
     procedure ();

	/* This procedure makes standard symbol table entries for the new fortran
   compiler.  It is called after the std_symbol_header and pl1_symbol_block
   nodes and the statement map have been created. The following global
   variables are assumed:

	sym_base - base of symbol section. ptr to std_symbol_header.
	sym_pos - current length of symbol section.
	symrel - offset of symbol section.
	info_ptr - ptr to pl1_symbol_block.
	objectname - name of the object segment.

   Others such as rands, polish, operand_base are not mentioned here.

*/


	/* Declarations */

dcl	all_symbols bit (1) aligned;			/* local copy of options.table */
dcl	alloc_len fixed bin (18);			/* length of CURRENT runtime_node being allocated */
dcl	blk fixed bin (18);
dcl	blkp ptr;					/* current runtime block pointer */
dcl	block_name char (32) varying;			/* name for VLA/LA base */
dcl	count fixed bin (18);			/* global count of symbols in sort array */
dcl	cur_subp ptr;				/* pointer to subprogram node */
dcl	convert_data_type (0:1, 0:6) fixed bin (6) init
	     (0, ft_integer_dtype, ft_real_dtype, ft_double_dtype, ft_complex_dtype, ft_logical_dtype, ft_char_dtype,
	     0, ft_integer_dtype, ft_hex_real_dtype, ft_hex_double_dtype, ft_hex_complex_dtype, ft_logical_dtype,
	     ft_char_dtype);
dcl	convert_size (0:5) fixed bin (18) int static options (constant) init (0, 35, 27, 63, 27, 1);
dcl	dp ptr;
dcl	ext_proc fixed bin (18);			/* offset of ext proc block */
dcl	factor fixed bin (19) int static options (constant) init (262144);
dcl	final (0:5) fixed bin (18);
dcl	fptype fixed bin (1) init (fixed (shared_globals.options.hfp, 1, 0));
dcl	i fixed bin (18);				/* temp */
dcl	i2 fixed bin (18);
dcl	j fixed bin (18);
dcl	last_blk fixed bin (18);			/* for building int proc brother chain */
dcl	last_len fixed bin (18);			/* for building length vectors */
dcl	last_sym fixed bin (18);			/* for chaining symbols */
dcl	lbl_name picture "99999";
dcl	length builtin;
dcl	lengths (0:6) fixed bin (18) int static options (constant) init (1, 2, 4, 8, 16, 32, 64);
dcl	max_len fixed bin (18);
dcl	min_len fixed bin (18);
dcl	n fixed bin (18);				/* = length(runtime_token.string); only set in get_acc_str! */
dcl	off fixed bin (18);				/* temp */
dcl	rel_bits bit (18) unaligned;			/* loop index */
dcl	pointer_pos fixed bin (18);			/* position of pointer runtime */
dcl	rel_bits2 bit (18) unaligned;			/* loop index */
dcl	root fixed bin (18);			/* offset of root block */
dcl	simple_len fixed bin (18) int static options (constant) init (5);
dcl	size builtin;
dcl	sp ptr;					/* pointer to symbol node */
dcl	sp2 ptr;					/* pointer to symbol node */
dcl	string builtin;
dcl	sym_sec (0:261119) fixed bin (18) aligned based (sym_base);
dcl	symp ptr;					/* current runtime symbol pointer */
dcl	sym_max_len fixed bin (18);			/* max sym section length */
dcl	symtab_base ptr;				/* base of array for sorting */
dcl	symtab_max fixed bin (18);			/* max length for array */
dcl	text_ref bit (4) aligned int static options (constant) init ("1100"b);
dcl	tkn_len fixed bin (9);			/* set by get_acc_str */
dcl	tkn_ptr ptr;				/* points to name for a runtime_token node, set by get_acc_str */
dcl	words (alloc_len) bit (36) aligned based;	/* to zero area for each allocated node */

dcl	1 symbol_template like runtime_symbol aligned;

dcl	1 block_template like runtime_block aligned;

dcl	1 token_list (256) aligned,
	  2 first fixed bin (18) unsigned unaligned,
	  2 last fixed bin (18) unsigned unaligned;

dcl	1 symbols (131071) aligned based (symtab_base),
	  2 str_p ptr unaligned,
	  2 offset fixed bin (18) unsigned unaligned,
	  2 length fixed bin (18) unsigned unaligned;

%include runtime_symbol;
%include std_descriptor_types;

	/* Initialization */

	unspec (block_template) = "0"b;

	block_template.flag = "1"b;
	block_template.fortran = "1"b;
	block_template.standard = "1"b;
	block_template.type = "011000"b;		/* 24 - procedure */
						/* all others = "0"b */

	unspec (symbol_template) = "0"b;

	symbol_template.flag = "1"b;
	symbol_template.aligned = "1"b;
	symbol_template.simple = "1"b;
						/* all others = "0"b */

	min_len = hbound (token_list, 1);		/* keep track of symbol length range */
	max_len = 0;
	unspec (token_list) = "0"b;

	symtab_base = addr (polish (next_free_polish));
	symtab_max = divide (polish_max_len - next_free_polish, 2, 17, 0);
						/* NOTE - size(symbols) = 2 */

	sym_max_len = object_max_len - symrel;		/* max sym sect len */

	cur_subprogram = 0;				/* for error messages */
	all_symbols = shared_globals.options.table;

	/* set relevant fields in pl1_symbol_block */

	info_ptr -> pl1_symbol_block.flags.table = "1"b;
	info_ptr -> pl1_symbol_block.flags.io = shared_globals.options.namelist_used;


	/* Allocate runtime root block

	     BY block_template	flag, quick, fortran, standard, owner_flag, skip, type, number, name, brother,
				entry_info.
	     IN allocate_block	father, header.
	     IN connect_symbols_to_block start, chain(*).
	     BY following code	map.first, map.last.
	     BY allocating root	son
	     BY finish up code	token(*) */

	last_blk = 0;				/* for brother chain */

	call allocate_block (0, size (runtime_block) - 1, 0, root, blkp);

	if generate_map
	then do;
	     blkp -> runtime_block.map.first =
		backward_ref (binary (info_ptr -> pl1_symbol_block.map.first, 18) - root);
	     blkp -> runtime_block.map.last = backward_ref (binary (info_ptr -> pl1_symbol_block.map.last, 18) - root);
	     end;

	/* allocate external entry constants for all entry points.

	     BY symbol_template	flag, skip, array_units, units, type, level, ndims, aligned, packed, simple,
				decimal, scale, son, class, next, size.
	     IN allocate_symbol	name, father.
	     IN connect_symbols_to_block brother.
	     BY following code	location.

	     NOTE - son is used to save text address of int entry const associated with this sym; used later */

	symbol_template.type = "011010"b;		/* 26 - external entry constant */
	symbol_template.class = text_ref;

	count = 0;
	do i = first_entry_name repeat sp -> symbol.next_symbol while (i ^= 0);
	     sp = addr (rands (i));
	     symp = null;				/* symbol may not be allocated */

	     if addr (rands (sp -> symbol.parent)) -> subprogram.namelist_used | all_symbols
	     then call allocate_symbol (get_acc_str$symbol (sp), simple_len, root, "1"b, symp);

	     /* continue only if the allocation was successful */

	     if symp ^= null
	     then do;
		call add_to_array;

		symp -> runtime_symbol.location = get_address (sp);
		addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_t;
						/* set reloc bits */

		/* if symbol has an associated int entry const, copy its text address */

		if sp -> symbol.initial ^= 0
		then symp -> runtime_symbol.son = unspec (addr (rands (sp -> symbol.initial)) -> label.location);

		sym_pos = sym_pos + simple_len;
		end;
	     end;					/* loop to generate ext entry consts */

	/* sort ext entry symbols and chain them together */

	call connect_symbols_to_block (root, blkp);


	/* Allocate runtime ext proc block

	     BY block_template	flag, quick, fortran, standard, owner_flag, skip, type, number, brother, entry_info.
	     IN allocate_block	name, father, header.
	     BY following code	start, map.first, map.last, chain(*).
	     BY allocating int procs	son
	     BY finish up code	token(*) */

	last_blk = 0;				/* for brother chain */

	call allocate_block (get_acc_str$varying (objectname), size (runtime_block) - 1, root, ext_proc, blkp);

	if generate_map
	then do;
	     blkp -> runtime_block.map.first =
		backward_ref (binary (info_ptr -> pl1_symbol_block.map.first, 18) - ext_proc);
	     blkp -> runtime_block.map.last =
		backward_ref (binary (info_ptr -> pl1_symbol_block.map.last, 18) - ext_proc);
	     end;

	/* allocate internal entry constants. Only main_entry_point_name does not have one. If we walk the root block's
	   declaration chain, we can allocate everything in symbol and block nodes in one pass.

	     BY symbol_template	flag, skip, array_units, units, type, level, ndims, aligned, packed, simple,
				decimal, scale, son, class, size.
	     IN allocate_symbol	name, father, next.
	     BY following code	brother, location. */

	last_sym = 0;				/* to build brother chain */
	last_len = 1;				/* to build block.chain(*) */
	symbol_template.type = "011001"b;		/* = 25; internal entry constant; class is already set */
	symp = addr (sym_sec (root));			/* to provide easy entry into the loop */

	do rel_bits = symp -> runtime_block.start repeat symp -> runtime_symbol.brother while (rel_bits ^= "0"b);
	     symp = addrel (symp, rel_bits);

	     /* allocate it if it has an associated internal entry constant */

	     if symp -> runtime_symbol.son ^= "0"b
	     then do;

		off = unpack (symp -> runtime_symbol.name) + binary (rel (symp), 18) - symrel;
						/* convert rel to absolute */

		call allocate_symbol (off, simple_len, ext_proc, "0"b, sp);

		sp -> runtime_symbol.location = symp -> runtime_symbol.son;
		symp -> runtime_symbol.son = "0"b;

		addrel (relocation_base, rel (sp)) -> runtime_symbol.location = rc_t;
						/* set reloc bits */

		if last_sym = 0
		then blkp -> runtime_block.start = forward_ref (sym_pos - ext_proc);
		else addr (sym_sec (last_sym)) -> runtime_symbol.brother = forward_ref (sym_pos - last_sym);

		last_sym = sym_pos;

		/* build runtime_block.chain(*) */

		tkn_len = binary (addr (sym_sec (off - 1)) -> runtime_token.size, 9);

		do i = last_len to 4;
		     if tkn_len >= lengths (i)
		     then if blkp -> runtime_block.chain (i) = "0"b
			then do;
			     last_len = i + 1;
			     blkp -> runtime_block.chain (i) = forward_ref (sym_pos - ext_proc);
			     end;
		     end;				/* loop to set chain(*) */

		sym_pos = sym_pos + simple_len;
		end;				/* do block to build int entry const symbol */
	     end;					/* loop thru ext entry constant symbols */


	/* Walk subprogram chain, building internal blocks with their symbols

	     block_template:	flag, quick, fortran, standard, owner_flag, skip, type, number, son.
	     allocate_block: proc	name, brother, father, header.
	     connect_symbols_to_block: start, chain(*).
	     following code		map.first, map.last, entry_info, owner.
	     finish up code		token(*). */

	block_template.quick = "1"b;
	block_template.owner_flag = "1"b;
	last_blk = 0;

	do cur_subprogram = first_subprogram repeat cur_subp -> subprogram.next_subprogram while (cur_subprogram ^= 0);
	     cur_subp = addr (rands (cur_subprogram));

	     /* allocate block node and its symbol nodes, only if required */

	     if cur_subp -> subprogram.namelist_used | all_symbols
	     then do;
		call allocate_block (get_acc_str$symbol (addr (rands (cur_subp -> subprogram.symbol))),
		     size (runtime_block), ext_proc, blk, blkp);
		cur_subp -> subprogram.runtime = blk;

		if cur_subp -> subprogram.entry_info = 0/* subprogram is not quick procedure */
		then do;
		     blkp -> runtime_block.quick = "0"b;
		     blkp -> runtime_block.owner_flag = "0"b;
		     sym_pos = sym_pos - 1;
		     end;

		else do;				/* quick procedure block */
		     blkp -> runtime_block.owner = backward_ref (ext_proc - blk);
		     blkp -> runtime_block.entry_info = unspec (cur_subp -> subprogram.entry_info);
		     end;

		if generate_map
		then do;
		     blkp -> runtime_block.map.first = backward_ref (cur_subp -> subprogram.map.first - blk);
		     blkp -> runtime_block.map.last = backward_ref (cur_subp -> subprogram.map.last - blk);
		     end;

		/* process all relevant declarations for the block */

		count = 0;

		/* automatic variables - buckets 1 to 4

		     BY symbol_template	flag, skip, array_units, units, level, [ndims,] aligned, packed,
					[simple,] decimal, scale, son, class, offset.
		     IN process_variable	type, [ndims,] [simple,] name, father, location, next, size,
					[virtual_org,] [bounds(*)]
		     IN connect_symbols_to_block brother */

		symbol_template.class = "0001"b;	/* automatic storage */

		do i = 1 to 4;
		     do j = cur_subp -> subprogram.storage_info (i).first repeat sp -> node.next while (j ^= 0);
			sp = addr (rands (j));

			if sp -> node.node_type = symbol_node
			then do;
			     call process_variable (sp, simple_len, "1"b, symp);
			     sym_pos = sym_pos + alloc_len;
			     end;

			else do i2 = sp -> header.first_element repeat sp2 -> symbol.next_member while (i2 ^= 0);
			     sp2 = addr (rands (i2));

			     call process_variable (sp2, simple_len, "1"b, symp);

			     if (sp2->symbol.equivalenced & sp2->symbol.in_equiv_stmnt & sp2->symbol.char_num > 0 & sp2->symbol.character & sp2->symbol.offset > 0) 
                                      then do;
				symp->runtime_symbol.aligned = "0"b;
				symp->runtime_symbol.simple  = "0"b;
				symp->runtime_symbol.packed  = "1"b;
				symp->runtime_symbol.offset = mod(sp2->symbol.offset, 4);
                                      end;
			     sym_pos = sym_pos + alloc_len;
			     end;
			end;			/* buckets 1 to 4 */
		     end;				/* automatic variables */

		/* static variables - buckets 5 to 8

		     BY symbol_template	flag, skip, array_units, units, level, [ndims,] aligned, packed,
					[simple,] decimal, scale, son, class, offset.
		     IN process_variable	type, [ndims,] [simple,] name, father, location, next, size,
					[virtual_org,] [bounds(*)]
		     IN connect_symbols_to_block brother */

		symbol_template.class = "0100"b;	/* static storage */

		do i = 5 to 8;
		     do j = cur_subp -> subprogram.storage_info (i).first repeat sp -> node.next while (j ^= 0);
			sp = addr (rands (j));

			if sp -> node.node_type = symbol_node
			then do;
			     call process_variable (sp, simple_len, "1"b, symp);

			     if symp ^= null
			     then do;
				sym_pos = sym_pos + alloc_len;
				addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_is18;
						/* set reloc bits */
				end;
			     end;

			else do i2 = sp -> header.first_element repeat sp2 -> symbol.next_member while (i2 ^= 0);
			     sp2 = addr (rands (i2));

			     call process_variable (sp2, simple_len, "1"b, symp);

			     if symp ^= null
			     then do;
				sym_pos = sym_pos + alloc_len;
				addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_is18;
						/* set reloc bits */
				end;
			     end;
			end;			/* buckets 5 to 8 */
		     end;				/* static variables */

		/* external entries and common block members - bucket 9

			COMMON BLOCK MEMBERS

		     BY symbol_template	flag, skip, array_units, units, level, [ndims], aligned, packed,
					simple, decimal, scale, son, location, class.
		     IN process_variable	type, [ndims], name, father, next, size, [virtual_org], [bounds(*)].
		     IN connect_symbols_to_block brother.
		     BY following code	offset.

			EXTERNAL ENTRY REFERENCES

		     BY symbol_template	flag, skip, array_units, units, type, level, ndims, aligned,
					packed, simple, decimal, scale, sone, class, size.
		     IN allocate_symbol	name, father, next.
		     IN connect_symbols_to_block brother.
		     BY following code	location. */

		do i = cur_subp -> storage_info (9).first repeat sp -> node.next while (i ^= 0);
		     sp = addr (rands (i));

		     if sp -> node.node_type = header_node
		     then do;
			symbol_template.class = "0101"b;
						/* external static */
			symbol_template.location = bit (fixed (sp -> header.location, 18), 18);
			symbol_template.simple = "0"b;

			do i2 = sp -> header.first_element repeat sp2 -> symbol.next_member while (i2 ^= 0);
			     sp2 = addr (rands (i2));

			     call process_variable (sp2, simple_len + 2, "0"b, symp);

			     if symp ^= null
			     then do;
				symp -> runtime_symbol.offset = sp2 -> symbol.offset;
				addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_lp18;
						/* set reloc bits */

				sym_pos = sym_pos + alloc_len;
				end;
			     end;			/* loop thru common block members */
			end;			/* case of common block chain */

		     else if sp -> symbol.initial = 0 & all_symbols
						/* for full table, allocate ext. ent. refs */
		     then do;
			symbol_template.class = "1101"b;
						/* link ref */
			symbol_template.type = "011011"b;
						/* ext entry ref */
			symbol_template.simple = "1"b;

			call allocate_symbol (get_acc_str$symbol (sp), simple_len, blk, "0"b, symp);

			if symp ^= null
			then do;
			     call add_to_array;

			     symp -> runtime_symbol.location = get_address (sp);
			     addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_lp18;
						/* set reloc bits */

			     sym_pos = sym_pos + alloc_len;
			     end;
			end;			/* case of external reference */
		     end;				/* bucket 9 */

		/* parameters - bucket 10

		     BY symbol_template	flag, skip, array_units, units, level, [ndims,] aligned, packed,
					simple, decimal, scale, son, offset.
		     IN process_variable	type, [ndims,] [simple,] name, father, next, size,
					[virtual_org,] [bounds(*)]
		     IN connect_symbols_to_block brother
		     BY following code	location, class. */

		symbol_template.simple = "1"b;

		do i = cur_subp -> subprogram.storage_info (10).first repeat sp -> symbol.next_symbol while (i ^= 0);

		     sp = addr (rands (i));

		     if sp -> symbol.VLA
		     then do;

			/* Allocate runtime block  for base pointer. */

			symbol_template.units = "00"b;
			symbol_template.type = "001101"b;
						/* Pointer */
			symbol_template.level = "00"b3;
			symbol_template.aligned = "0"b;
			symbol_template.packed = "1"b;/* Packed for VLA's */
			symbol_template.simple = "1"b;
			symbol_template.scale = "00"b3;
			symbol_template.size = 0;

			symbol_template.class = "0001"b;
						/* AUTOMATIC */
			block_name = "vla$parm$";
			symbol_template.location = bit (fixed (sp -> symbol.address.offset, 18), 18);

			block_name = block_name || sp -> symbol.name;
			call allocate_symbol (get_acc_str$varying (block_name),
			     simple_len, blk, "0"b, symp);
			call add_to_array;
			pointer_pos = sym_pos;	/* save runtime position */
			sym_pos = sym_pos + simple_len;

			/* Template for parameter off this base */

			symbol_template.simple = "0"b;
			symbol_template.packed = "0"b;
			symbol_template.aligned = "1"b;
			end;

		     call process_variable (sp, simple_len, "0"b, symp);


		     /* process runtime_symbol node only if it is allocated */

		     if symp ^= null
		     then do;
			if sp -> symbol.VLA
			then do;
			     symp -> runtime_symbol.location = rel_ref (pointer_pos - sym_pos);
			     symp -> runtime_symbol.class = "1010"b;
						/* VLA_based */
			     end;
			else if sp -> symbol.stack_indirect
			then do;
			     symp -> runtime_symbol.location = get_address (sp);
			     symp -> runtime_symbol.class = "1000"b;
			     end;
			else do;
			     symp -> runtime_symbol.location =
				bit (binary (divide (sp -> symbol.location, 2, 17, 0), 18), 18);
			     symp -> runtime_symbol.class = "1001"b;
			     end;

			sym_pos = sym_pos + alloc_len;
			end;			/* do block to finish off parameter runtime_symbol */
		     unspec (symbol_template) = "0"b;

		     symbol_template.flag = "1"b;
		     symbol_template.aligned = "1"b;
		     symbol_template.simple = "1"b;
						/* all others = "0"b */
		     end;				/* parameters - bucket 10 */

		/* namelist names, PARAMETER variables - bucket 11
		     All fields are set by the template. */


		do i = cur_subp -> subprogram.storage_info (11).first repeat sp -> symbol.next_symbol while (i ^= 0);
		     sp = addr (rands (i));

		     /* Process PARAMETER variables. */

		     if sp -> symbol.named_constant & ^sp -> symbol.by_compiler
		     then do;
			sp2 = addr (rands (sp -> symbol.initial));
			sp -> symbol.data_type = sp2 -> constant.data_type;
			symbol_template.simple = "1"b;
			symbol_template.location = bit (binary (sp2 -> constant.location, 18), 18);
			symbol_template.class = "1100"b;
			call process_variable (sp, simple_len, "0"b, symp);
			/* Bug 512: Set up reloc info */
			addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_t;
			if symp ^= null
			then do;
			     if sp -> symbol.character
			     then symp -> runtime_symbol.size = sp2 -> char_constant.length;
			     sym_pos = sym_pos + simple_len;
			     end;
			end /* named_constant */;
		     else if sp -> symbol.namelist
		     then do;
			symbol_template.type = "0"b;
			symbol_template.simple = "1"b;
			symbol_template.location = "0"b;
			symbol_template.class = "0"b;

			call allocate_symbol (get_acc_str$symbol (sp), simple_len, blk, "0"b, symp);
			call add_to_array;

			sp -> symbol.runtime = bit (sym_pos, 18);
			sym_pos = sym_pos + simple_len;
			end /* namelist */;
		     end /* do i */;		/* bucket 11 */

		/* Large Array block members - buckets 13, 14

			LARGE ARRAY BLOCK MEMBERS

		     BY symbol_template	flag, skip, array_units, units, level, [ndims], aligned, packed,
					simple, decimal, scale, son, location, class.
		     IN process_variable	type, [ndims], name, father, next, size, [virtual_org], [bounds(*)].
		     IN connect_symbols_to_block brother.
		     BY following code	offset. */


		do j = 13, 14;			/* scan auto and static */
		     do i = cur_subp -> storage_info (j).first repeat sp -> node.next while (i ^= 0);
			sp = addr (rands (i));

			if sp -> node.node_type = header_node
			then do;

			     /* Allocate runtime block  for base pointer. */

			     symbol_template.units = "00"b;
			     symbol_template.type = "001101"b;
						/* Pointer */
			     symbol_template.level = "00"b3;
			     symbol_template.aligned = "1"b;
			     symbol_template.packed = "0"b;
						/* Not packed for LA's */
			     symbol_template.simple = "1"b;
			     symbol_template.scale = "00"b3;
			     symbol_template.size = 0;

			     if sp -> header.static
			     then do;
				symbol_template.class = "0100"b;
						/* STATIC */
				block_name = "la$static$";
				end;
			     else do;
				symbol_template.class = "0001"b;
						/* AUTOMATIC */
				block_name = "la$auto$";
				end;

			     symbol_template.location = bit (fixed (sp -> header.location, 18), 18);

			     block_name = block_name || ltrim (octal (unspec (sp -> header.location)), "0");
			     call allocate_symbol (get_acc_str$varying (block_name),
				simple_len, blk, "0"b, symp);
			     call add_to_array;
			     pointer_pos = sym_pos;	/* save runtime position */
			     sym_pos = sym_pos + simple_len;
			     if sp -> header.static
			     then addrel (relocation_base, rel (symp)) ->
				     runtime_symbol.location = rc_is18;


			     /* Template for LA's off this header */

			     symbol_template.class = "0011"b;
						/* BASED */
			     symbol_template.packed = "0"b;
			     symbol_template.simple = "0"b;

			     do i2 = sp -> header.first_element repeat sp2 -> symbol.next_member while (i2 ^= 0);
				sp2 = addr (rands (i2));

				call process_variable (sp2, simple_len + 2, "0"b, symp);

				if symp ^= null
				then do;
				     symp -> runtime_symbol.offset = sp2 -> symbol.offset;
				     symp -> runtime_symbol.location = rel_ref (pointer_pos - sym_pos);
				     sym_pos = sym_pos + alloc_len;
				     end;
				end;		/* loop thru LA block members */
			     end;			/* case of LA block chain */
			end;
		     end;				/* buckets 13, 14 */


		/* Very Large Array block members - buckets 15, 16, 17

			VERY LARGE ARRAY BLOCK MEMBERS

		     BY symbol_template	flag, skip, array_units, units, level, [ndims], aligned, packed,
					simple, decimal, scale, son, location, class.
		     IN process_variable	type, [ndims], name, father, next, size, [virtual_org], [bounds(*)].
		     IN connect_symbols_to_block brother.
		     BY following code	offset. */


		do j = 15 to 17;			/* scan auto, static, and common */
		     do i = cur_subp -> storage_info (j).first repeat sp -> node.next while (i ^= 0);
			sp = addr (rands (i));

			if sp -> node.node_type = header_node
			then do;

			     /* Allocate runtime block  for base pointer. */

			     symbol_template.units = "00"b;
			     symbol_template.type = "001101"b;
						/* Pointer */
			     symbol_template.level = "00"b3;
			     symbol_template.aligned = "0"b;
			     symbol_template.packed = "1"b;
						/* Packed for VLA's */
			     symbol_template.simple = "1"b;
			     symbol_template.scale = "00"b3;
			     symbol_template.size = 0;

			     /*  Find the first member of the VLA group which has no offset and use its   */
			     /*  packed pointer as the base pointer for the VLA.                          */

			     do sp2 = addr (rands (sp -> header.first_element))
				repeat addr (rands (sp2 -> symbol.next_member)) while (sp2 -> symbol.offset ^= 0);
				end;

			     /* if the first element is a nondimensioned symbol (only happens in           */
			     /* VL Common), restore symbol.address.offset from symbol.addr_hold.	   */
			     if sp -> header.in_common & ^sp2 -> symbol.dimensioned
			     then
				substr (unspec (sp2 -> symbol.address), 1, 18) = sp2 -> symbol.addr_hold;

			     if ^sp2 -> symbol.large_address
			     then symbol_template.location = bit (fixed (sp2 -> symbol.address.offset, 18));
			     else symbol_template.location =
				     bit (fixed (sp2 -> symbol.address.offset + sp2 -> symbol.location, 18));

			     if sp -> header.static
			     then do;
				symbol_template.class = "0100"b;
						/* STATIC */
				block_name = "vla$static$" || sp2 -> symbol.name;
				end;
			     else if sp -> header.automatic
			     then do;
				symbol_template.class = "0001"b;
						/* AUTOMATIC */
				block_name = "vla$auto$" || sp2 -> symbol.name;
				end;
			     else do;
				symbol_template.class = "0100"b;
						/* COMMON */
				if sp -> header.block_name = "blnk*com"
				then block_name = "vla$common$_";
				else block_name = "vla$common$" || sp -> header.block_name;
				end;

			     call allocate_symbol (get_acc_str$varying (block_name),
				simple_len, blk, "0"b, symp);
			     call add_to_array;
			     pointer_pos = sym_pos;	/* save runtime position */
			     sym_pos = sym_pos + simple_len;
			     if sp -> header.static | sp -> header.in_common
			     then addrel (relocation_base, rel (symp)) ->
				     runtime_symbol.location = rc_is18;


			     /* Template for VLA's off this header */

			     symbol_template.class = "1010"b;
						/* VLA_based */
			     symbol_template.aligned = "1"b;
			     symbol_template.packed = "0"b;
			     symbol_template.simple = "0"b;

			     do i2 = sp -> header.first_element repeat sp2 -> symbol.next_member while (i2 ^= 0);
				sp2 = addr (rands (i2));

				call process_variable (sp2, simple_len + 2, "0"b, symp);

				if symp ^= null
				then do;
				     symp -> runtime_symbol.offset = sp2 -> symbol.offset;
				     symp -> runtime_symbol.location = rel_ref (pointer_pos - sym_pos);
				     sym_pos = sym_pos + alloc_len;
				     end;
				end;		/* loop thru VLA block members */
			     end;			/* case of VLA block chain */
			end;
		     end;				/* buckets 15, 16, 17 */


		/* labels - separate chain
		     All fields, except location, are set by the template.

			NOTE - allocated only if full symbol table. */

		symbol_template.type = "011000"b;	/* = 24; label */
		symbol_template.class = text_ref;

		if all_symbols
		then do i = cur_subp -> subprogram.first_label repeat sp -> label.next_label while (i ^= 0);
		     sp = addr (rands (i));

		     if sp -> label.name > 0 & sp -> label.name <= 99999 & string (sp -> label.usage) = "01"b
		     then do;
			lbl_name = sp -> label.name;
			call allocate_symbol (get_acc_str$varying (substr (lbl_name, verify (lbl_name, "0"))),
			     simple_len, blk, "0"b, symp);
			call add_to_array;

			symp -> runtime_symbol.location = unspec (sp -> label.location);
			addrel (relocation_base, rel (symp)) -> runtime_symbol.location = rc_t;
						/* set reloc bits */

			sym_pos = sym_pos + alloc_len;
			end;			/* executable user labels */
		     end;				/* labels */

		/* finish up the block */

		call connect_symbols_to_block (blk, blkp);

		end;				/* do block for subprograms to be allocated */
	     end;					/* loop thru subprogram nodes */


	/* Finish up - link up all tokens and set block.token(*) for all blocks */

	last_len = 0;				/* for building length vector */
	unspec (final) = "0"b;			/* length vector in absolute form */
	off = 0;					/* offset of previous token node */

	/* build one continuous list of tokens while calculating the absolute vector */

	do i = min_len to max_len;

	     if token_list (i).first > 0
	     then do;
		j = token_list (i).first;

		if off > 0 then addr (sym_sec (off)) -> runtime_token.next = rel_ref (j - off);
		off = j;

		do j = last_len to 5;
		     if i >= lengths (j)
		     then if final (j) = 0
			then do;
			     last_len = j + 1;
			     final (j) = off;
			     end;
		     end;				/* loop to set vector elements */
		off = token_list (i).last;		/* get end of the vector */
		end;				/* block to link up partial list of tokens */
	     end;					/* loop to find and link up all partial lists */

	/* now walk the block chains and set all their vectors */

	sp = sym_base;

	do rel_bits = bit (root, 18) repeat sp -> runtime_block.son while (rel_bits ^= "0"b);
	     sp = addrel (sp, rel_bits);
	     off = binary (rel (sp), 18) - symrel;

	     do i = 0 to 5;
		if final (i) > 0 then sp -> runtime_block.token (i) = rel_ref (final (i) - off);
		end;

	     sp2 = sp;

	     do rel_bits2 = sp -> runtime_block.son repeat sp2 -> runtime_block.brother while (rel_bits2 ^= "0"b);
		sp2 = addrel (sp2, rel_bits2);
		off = binary (rel (sp2), 18) - symrel;

		do i = 0 to 5;
		     if final (i) > 0 then sp2 -> runtime_block.token (i) = rel_ref (final (i) - off);
		     end;
		end;				/* loop through brother chain */
	     end;					/* loop through son chain */
	return;

allocate_block:
     procedure (a_name, a_len, a_parent, blk_off, blk_ptr);

dcl	B fixed bin (18);
dcl	BP ptr;
dcl	a_len fixed bin (18);
dcl	a_name fixed bin (18);
dcl	a_parent fixed bin (18);
dcl	blk_name fixed bin (18);
dcl	blk_off fixed bin (18);
dcl	blk_ptr ptr;
dcl	parent fixed bin (18);

	/* copy input arguments */

	blk_name = a_name;
	alloc_len = a_len;
	parent = a_parent;

	/* allocate block node */

	if sym_pos + alloc_len >= sym_max_len then call print_message (414, "object segment", object_max_len - bias);

	B = sym_pos;
	BP = addr (sym_sec (B));
	unspec (BP -> words) = unspec (block_template);
	sym_pos = sym_pos + alloc_len;

	/* link this block to its parent block */

	if parent = 0				/* parent is std_symbol_header */
	then do;
	     parent = binary (rel (sym_base), 18) - symrel;
	     info_ptr -> pl1_symbol_block.root = bit (B, 18);
	     end;

	/* if this block has no brother, it is first son; otherwise put it on brother chain */

	else if last_blk = 0
	then addr (sym_sec (parent)) -> runtime_block.son = forward_ref (B - parent);
	else addr (sym_sec (last_blk)) -> runtime_block.brother = forward_ref (B - last_blk);
	last_blk = B;

	BP -> runtime_block.father = backward_ref (parent - B);

	BP -> runtime_block.header = backward_ref (-B);

	/* set name field */

	if blk_name > 0 then BP -> runtime_block.name = backward_ref (blk_name - B);

	/* set output arguments */

	blk_off = B;
	blk_ptr = BP;
     end allocate_block;

allocate_symbol:
     procedure (a_name, a_len, a_parent, nd_sw, sym_ptr);

dcl	SP ptr;
dcl	a_len fixed bin (18);
dcl	a_name fixed bin (18);
dcl	a_parent fixed bin (18);
dcl	distance fixed bin (18);
dcl	last_dcl fixed bin (14);
dcl	namedup_is_error bit (1) aligned;
dcl	nd_sw bit (1) aligned;
dcl	sym_blk fixed bin (18);
dcl	sym_name fixed bin (18);
dcl	sym_ptr ptr;

	/* copy input arguments */

	sym_name = a_name - 1;			/* convert from acc off to node offset */
	alloc_len = a_len;
	sym_blk = a_parent;
	namedup_is_error = nd_sw;

	/* allocate symbol node */

	if sym_pos + alloc_len >= sym_max_len then call print_message (414, "object segment", object_max_len - bias);

	SP = addr (sym_sec (sym_pos));
	sym_ptr = SP;				/* set output argument */
	unspec (SP -> words) = unspec (symbol_template);

	/* link symbol to token */

	SP -> runtime_symbol.name = backward_ref (sym_name + 1 - sym_pos);

	/* link token to symbol */

	if addr (sym_sec (sym_name)) -> runtime_token.dcl ^= "0"b
						/* previous symbol declared with this name */
	then if namedup_is_error
	     then do;
		call print_message (428, addr (sym_sec (sym_name)) -> runtime_token.string);
		unspec (SP -> runtime_symbol) = "0"b;
		sym_ptr = null;			/* set output argument */
		return;
		end;
	     else do;				/* must chain all symbols with same name */
		last_dcl = unpack (addr (sym_sec (sym_name)) -> runtime_token.dcl) + sym_name;
						/* convert rel to absolute */
		distance = last_dcl - sym_pos;
		if distance + 16384 <= 0
		then do;				/* can't chain */
		     call print_message (503, addr (sym_sec (sym_name)) -> runtime_token.string);
		     SP -> runtime_symbol.next = "0"b;
		     end;
		else SP -> runtime_symbol.next = substr (backward_ref (distance), 5, 14);
		end;

	addr (sym_sec (sym_name)) -> runtime_token.dcl = forward_ref (sym_pos - sym_name);

	/* link to father block */

	SP -> runtime_symbol.father = backward_ref (sym_blk - sym_pos);
     end allocate_symbol;

add_to_array:
     procedure ();

	/* put symbol in sort array */

	count = count + 1;
	if count > symtab_max then call print_message (414, "sort array", symtab_max - bias);
	symbols (count).str_p = addrel (tkn_ptr, 1);
	symbols (count).length = tkn_len;
	symbols (count).offset = sym_pos;

     end add_to_array;

connect_symbols_to_block:
     procedure (a_parent, a_parent_ptr);		/* implied input: addr(symbols), count */

dcl	a_parent fixed bin (18);
dcl	a_parent_ptr ptr;
dcl	(i1, j1, len) fixed bin (18);
dcl	last_len fixed bin (18);
dcl	SB fixed bin (18);
dcl	SBP ptr;

	SB = a_parent;
	SBP = a_parent_ptr;

	call sort_symbols;

	last_len = 1;
	last_sym = 0;

	do i1 = 1 to count;

	     /* chain symbols together using the brother chain */

	     j1 = symbols (i1).offset;

	     if last_sym = 0
	     then SBP -> runtime_block.start = forward_ref (j1 - SB);
	     else addr (sym_sec (last_sym)) -> runtime_symbol.brother = rel_ref (j1 - last_sym);

	     last_sym = j1;

	     /* fill in lookup vector for block as we go */

	     len = symbols (i1).length;

	     do j1 = last_len to 4 while (len >= lengths (j1));
		if SBP -> runtime_block.chain (j1) = "0"b
		then do;
		     last_len = j1 + 1;
		     SBP -> runtime_block.chain (j1) = forward_ref (last_sym - SB);
		     end;
		end;
	     end;					/* loop to chain symbols and build block.chain(*) */
     end connect_symbols_to_block;

process_variable:
     procedure (a_symbol, a_len, a_set_address, a_var);

dcl	a_len fixed bin (18);
dcl	a_set_address bit (1) aligned;
dcl	a_symbol ptr;
dcl	a_var ptr;
dcl	i1 fixed bin (18);
dcl	mult fixed bin (18);
dcl	nd fixed bin (6);
dcl	set_address bit (1) aligned;
dcl	stack_offset fixed bin (18);
dcl	symb ptr;
dcl	var ptr;
dcl	encodep ptr;				/* pointer to encoded size */

	/* copy input arguments */

	symb = a_symbol;
	alloc_len = a_len;
	set_address = a_set_address;

	/* allocate symbol */

	if symb -> symbol.by_compiler | (^all_symbols & ^symb -> symbol.put_in_symtab)
	then do;
	     alloc_len = 0;
	     a_var = null;				/* set output argument */
	     return;
	     end;

	call allocate_symbol (get_acc_str$symbol (symb), alloc_len, blk, "0"b, var);
	call add_to_array;

	/* set data type and precision */

	var -> runtime_symbol.type = bit (convert_data_type (fptype, symb -> symbol.data_type), 6);

	if symb -> symbol.character
	then do;
	     if symb -> symbol.star_extents
	     then do;
		encodep = addr (var -> runtime_symbol.size);
		encodep -> encoded_value.flag = "10"b;	/* ENCODED */
		encodep -> encoded_value.code = "0"b;	/* Value is contents of stack word (n3) */
		encodep -> encoded_value.n1, encodep -> encoded_value.n2 = "0"b;
		encodep -> encoded_value.n3 = get_address (addr (rands (symb -> symbol.v_length)));
		end;
	     else var -> runtime_symbol.size = symb -> symbol.char_size + 1;
	     end;
	else var -> runtime_symbol.size = convert_size (symb -> symbol.data_type);

	var -> runtime_symbol.units = substr (unspec (symb -> symbol.units), 2, 2);

	/* set symbol address */

	if set_address then var -> runtime_symbol.location = get_address (symb);

	/* if symbol is dimensioned, add bound fields */

	if symb -> symbol.dimensioned
	then do;
	     dp = addr (rands (symb -> symbol.dimension));/* get pointer to dimension info */

	     nd = dp -> dimension.number_of_dims;	/* get and store number of dimensions */
	     var -> runtime_symbol.ndims = bit (nd, 6);
	     var -> runtime_symbol.simple = "0"b;	/* long runtime symbol node allocated */
	     var -> runtime_symbol.array_units = substr (unspec (symb -> symbol.units), 2, 2);
	     alloc_len = simple_len + 2 + 3 * nd;

	     if sym_pos + alloc_len >= sym_max_len
	     then call print_message (414, "object_segment", object_max_len - bias);

	     if symb -> symbol.v_length = 0
	     then mult = symb -> symbol.element_size;
	     else mult = 0;

	     /* if variable extents, may use values stored in the array's descriptor */

	     if symb -> symbol.variable_extents | symb -> symbol.star_extents
	     then stack_offset = binary (get_address (addr (rands (symb -> symbol.hash_chain))), 18);

	     /* process each bound in turn */

	     do i1 = 0 to nd - 1;

		/* multiplier is constant until variable bound is encountered */

		if mult > 0			/* multiplier is a constant */
		then var -> runtime_symbol.bounds (nd - i1).multiplier = mult;
		else do;

		     /* multiplier will refer to field in runtime descriptor for the array */
		     /* If we are character*(*) we need a character
		        multiplier from the extended descriptor. */

		     if symb -> symbol.star_extents
		     then var -> runtime_symbol.bounds (nd - i1).multiplier = stack_offset + i1 + 1 + nd * 3;
		     else var -> runtime_symbol.bounds (nd - i1).multiplier = stack_offset + i1 * 3 + 3;
		     substr (unspec (var -> runtime_symbol.bounds (nd - i1).multiplier), 1, 6) = "100000"b;
		     end;

		/* fill in the lower bound information */

		if dp -> dimension.v_bound (i1 + 1).lower
		then do;
		     mult = 0;
		     var -> runtime_symbol.bounds (nd - i1).lower = stack_offset + i1 * 3 + 1;
		     substr (unspec (var -> runtime_symbol.bounds (nd - i1).lower), 1, 6) = "100000"b;
		     end;
		else var -> runtime_symbol.bounds (nd - i1).lower = dp -> dimension.lower_bound (i1 + 1);

		/* fill in the upper bound information */

		if dp -> dimension.v_bound (i1 + 1).upper
		then do;
		     mult = 0;
		     var -> runtime_symbol.bounds (nd - i1).upper = stack_offset + i1 * 3 + 2;
		     substr (unspec (var -> runtime_symbol.bounds (nd - i1).upper), 1, 6) = "100000"b;
		     end;
		else var -> runtime_symbol.bounds (nd - i1).upper = dp -> dimension.upper_bound (i1 + 1);

		/* update multiplier for next dimension */

		if mult > 0
		then mult = mult * dp -> dimension.size (i1 + 1);

		end;

	     /* set virtual origin */

	     if dp -> dimension.variable_virtual_origin
	     then do;
		var -> runtime_symbol.virtual_org =
		     binary (get_address (addr (rands (dp -> dimension.virtual_origin))), 18);
		substr (unspec (var -> runtime_symbol.virtual_org), 1, 6) = "100000"b;
		end;
	     else var -> runtime_symbol.virtual_org = dp -> dimension.virtual_origin;

	     end;					/* do block for dimensioned variable */

	/* store offset of symbol entry in symbol node */

	if symb -> symbol.put_in_symtab then symb -> symbol.runtime = bit (sym_pos, 18);

	/* set output argument */

	a_var = var;

     end process_variable;

rel_ref:
     procedure (value) returns (bit (18) aligned);	/* procedure to produce rel pointers */

dcl	value fixed bin (18);

	if value >= 0
	then do;

forward_ref:
     entry (value) returns (bit (18) aligned);

	     return (bit (value, 18));
	     end;

	else do;

backward_ref:
     entry (value) returns (bit (18) aligned);

	     return (bit (binary (factor + value, 18), 18));
	     end;

     end rel_ref;


unpack:
     procedure (field) returns (fixed bin (18));

dcl	field bit (18) unaligned;

	if substr (field, 1, 1) = "0"b
	then return (binary (field, 18));
	else return (binary (field, 18) - factor);

     end unpack;


get_address:
     procedure (symbol_ptr) returns (bit (18) aligned);

dcl	symbol_ptr ptr;

	if symbol_ptr -> symbol.large_address
	then return (bit (binary (symbol_ptr -> symbol.address.offset + symbol_ptr -> symbol.location, 18), 18));
	else if symbol_ptr -> symbol.stack_indirect
	then return (bit (binary (symbol_ptr -> symbol.location, 18), 18));
	else return (bit (binary (symbol_ptr -> symbol.address.offset, 18), 18));

     end get_address;

get_acc_str:
     procedure (a_str) returns (fixed bin (18));

dcl	a_str char (*);
dcl	full_offset fixed bin (18);
dcl	last_tkn ptr;
dcl	not_found bit (1) aligned;
dcl	str char (256) varying;
dcl	sym_node ptr;
dcl	tkn_off fixed bin (18);
dcl	vstr char (32) varying;

dcl	1 acc aligned based,
	  2 pad1 bit (36) unaligned,
	  2 pad2 bit (9) unaligned,
	  2 str char (n) unaligned;

	/* copy input arguments */

	str = a_str;
	n, tkn_len = length (str);
	goto common;


get_acc_str$symbol:
     entry (sym_node) returns (fixed bin (18));

	str = sym_node -> symbol.name;
	n, tkn_len = length (str);
	goto common;


get_acc_str$varying:
     entry (vstr) returns (fixed bin (18));

	str = vstr;
	n, tkn_len = length (str);

common:

	/* save length info */

	min_len = min (n, min_len);
	max_len = max (n, max_len);

	/* search appropriate partial list for this token */

	last_tkn = null;				/* previous token in list */

	if token_list (n).first = 0
	then tkn_ptr = null;			/* first token for this list */
	else do;
	     tkn_ptr = addr (sym_sec (token_list (n).first));
	     not_found = "1"b;

	     do while (not_found);
		if str = tkn_ptr -> acc.str		/* token node already allocated */
		then return (binary (rel (tkn_ptr), 18) - symrel + 1);

		if str < tkn_ptr -> acc.str		/* strings must be ordered alphabetically */
		then not_found = "0"b;		/* insert new token here */
		else do;
		     last_tkn = tkn_ptr;		/* previous token in list */
		     if tkn_ptr -> runtime_token.next = "0"b
		     then do;			/* at the end of the list, get out */
			not_found = "0"b;
			tkn_ptr = null;		/* no following token in list */
			end;
		     else tkn_ptr = addrel (tkn_ptr, tkn_ptr -> runtime_token.next);
		     end;				/* do block to get next token */
		end;				/* loop thru partial list */
	     end;					/* do block for searching partial list */

	/* must create a new token node; first link it into the list */

	full_offset = symrel + sym_pos;

	if last_tkn = null
	then token_list (n).first = sym_pos;		/* token is at the head of the list */
	else last_tkn -> runtime_token.next = forward_ref (full_offset - binary (rel (last_tkn), 18));

	if tkn_ptr = null
	then do;
	     token_list (n).last = sym_pos;		/* token is at the tail of the list */
	     addr (sym_sec (sym_pos)) -> runtime_token.next = "0"b;
	     end;
	else addr (sym_sec (sym_pos)) -> runtime_token.next = backward_ref (binary (rel (tkn_ptr), 18) - full_offset);

	/* build a new token node */

	tkn_ptr = addr (sym_sec (sym_pos));
	tkn_off = sym_pos + 1;
	tkn_ptr -> runtime_token.dcl = "0"b;
	tkn_ptr -> runtime_token.size = tkn_len;
	substr (tkn_ptr -> runtime_token.string, 1, n) = str;

	/* bump length of sym section and return */

	sym_pos = sym_pos + size (tkn_ptr -> runtime_token);
	return (tkn_off);

     end get_acc_str;

sort_symbols:
     procedure ();

dcl	(i1, j1, d, first) fixed bin (18);
dcl	swap_em bit (1) aligned;
dcl	length builtin;

dcl	1 swap like symbols aligned;

dcl	1 j_struct aligned based (symbols (j1).str_p),
	  2 pad bit (9) unaligned,
	  2 j_string char (symbols (j1).length) unaligned;

dcl	1 j_plus_d_struct aligned based (symbols (j1 + d).str_p),
	  2 pad bit (9) unaligned,
	  2 j_plus_d_string char (symbols (j1 + d).length) unaligned;

	/* get first power of two greater than number of symbols */

	do d = 1 repeat d + d while (d <= count);
	     end;

	d = divide (d, 2, 17, 0) - 1;			/* get d such that d = 2**n-1 & 2**n < count <= 2**(n+1) */

	/* loop until entire list is processed */

	do while (d > 0);
	     do first = 1 to d;
		do i1 = first to count by d;

		     /* bubble strings up on its parital list */

		     j1 = i1;
		     swap_em = "1"b;

		     do while (swap_em & j1 > 0 & j1 + d <= count);

			swap_em = "0"b;

			if length (j_string) > length (j_plus_d_string)
			then swap_em = "1"b;
			else if length (j_string) = length (j_plus_d_string)
			then if j_string > j_plus_d_string
			     then swap_em = "1"b;

			if swap_em
			then do;
			     swap = symbols (j1);
			     symbols (j1) = symbols (j1 + d);
			     symbols (j1 + d) = swap;
			     j1 = j1 - d;
			     end;
			end;			/* bubble loop */
		     end;
		end;

	     d = divide (d, 2, 17, 0);
	     end;
     end sort_symbols;

octal:
     proc (bits) returns (char (12));

dcl	bits bit (36) aligned;
dcl	octal_string char (12) aligned;

dcl	ioa_$rsnnl entry options (variable);

	call ioa_$rsnnl ("^w", octal_string, 12, bits);
	return (octal_string);
     end octal;
     end make_symbol_table;

     end fort_make_symbol_section;




		    fort_message_table.alm          05/08/87  1041.1rew 05/08/87  1032.8      364626



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

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7286),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bug 452.
"  2) change(86-07-14,BWong), approve(86-07-14,MCR7382),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bugs 389, 411, 470, 476, and 481.
"  3) change(86-07-14,BWong), approve(86-07-14,MCR7442),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bug 498.
"  4) change(87-04-15,Huen), approve(87-04-15,MCR7651),
"     audit(87-04-15,RWaters), install(87-05-08,MR12.1-1031):
"     Fix fortran bug 479.
"                                                      END HISTORY COMMENTS


" Written:
"
" Modified:
"	13 Mar 86, NS - 498: Add message 194 for invalid unit numbers.
"	12 Dec 85, NS, MM, & BW - 389/481/482: Add message 366 for real
"		and double precision declarations that are not supported.
"		Add message 365 for complex declarations that are not
"		supported.
"	07 Nov 85, SH & MM - 476: Change message 422 from severity 3 to 
"		a warning.
"	29 Oct 85, BW - 411: Reword message 426 to specify word or character
"		units.
"	26 Sep 85, BW - 470: Reword messages 36 and 120.  Only significant
"		digits count in real and double precision constants.
"	13 May 85, BW - 452: Change messages 329 and 358 to severity 3.
"	05 Oct 84, MM - hfp_acs: Add message 522.
"	22 Jun 84, MM - Install typeless functions support.  Added messages
"		359, 360, 361, 362, 363, and 364.
"	13 Apr 84, MM - 419 Remove obsolete messages 2 and 7.
"	19 Sep 83, RG & MM - 242/370: Update messages 400 & 401.
"	24 Aug 83, TO - 401: Update message 136 for VLA mods.
"	14 Aug 83, HH - 387: Change message 155.
"	12 Jul 83, MM - Add 193 for illegal %globals
"	12 Jul 83, MM - Add 191, 192 for compilation option conflicts.
"	19 Jun 83, HH - 145: Add message 190.
"	17 Jun 83, HH - 383: Change messages 019 and 169.
"	31 Jan 83, TO & HH - Install LA/VLA support.
"	19 May 82, TO  - Make 468 a level 2 warning.
"	13 Apr 82, TO  - Modify message 384 to list line range.
"	 5 Apr 82, TO  - Add 189 for parameter list limit warning.
"	16 Nov 81, MEP - Add 188 for no s permission on directory containing include file
"	27 October 1981, CRD - Add 356, 357 for inquire statement.
"	20 October 1981, CRD - Add message 303 for internal files.
"	8 September 1981, CRD - Improve message 338.
"	23 June 1981, MEP - Added message 187, for invalid specification(s) in new I/O statements.
"	12 June 1981, MEP - Added message 40, for a missing, but indeterminate, keyword.  Made message 31 more general, 
"		with caller supplying the refinement.
"	11 June 1981, MEP - Changed the severity of error 48 to 3, as it is a bone fide error.
"	2 June 1981, MEP - Removed message 40, as fortran no longer requires at least one parameter for a function.
"	14 May 1981, MEP - Added message 186 for SAVE /foo/ for foo not a common-block name
"	11 May 1981, MEP - Revised wording of 93 for once per statement.
"	30 April 1981, MEP - Revised wording of message 15 for named block data subprogramsss.
"	16 April 1981, MEP - Revised wording of message 19 to include common blocks.
"	21 March 1981, MEP - Revised messages 78 and 136, added messages 166 - 168, 
"	          and 198 -199, all for new array bounds.
"	13 March 1981, CRD - Added message 468.
"	21 January 1981, CRD - Removed message 392.
"	29 December 1980, MEP - Reworded messages 178 -181 for block if.
"	18 December 1980, CRD - Reworded message 324 for block IF.
"	16 December 1980, MEP - Added messages 178 thru 181 for block if.
"	23 October 1980, CRD - Added message 314.
"	1 October 1980, CRD - Added message 392.
"	16 September 1980, CRD - Added message 391.
"	27 June 1980, CRD - Added message 355, for *-length parameter functions.
"	26 June 1980, CRD - Added message 159, for invalid substring dt.
"		Many changes and additions by PES and CRD went unrecorded.
"	03 Dec 1979, PES - Change msg 96 to be more precise.  Add msgs 153
"		thru 155 for ANSI77 character mode.
"	01 Oct 1979, PES - Added msg 147 for *-length misuse.
"	12 Sep 1979, CRD - Added msg 503 in fixing bug 241 (symbol nodes
"		too far apart to chain runtime_symbol.next).
"	18 Jul 1979, PES - Added msg 144 for change to exponentiation precedence.
"	12 Jul 1979, PES - Changed msgs 29 and 305 to reflect relaxed restriction on encode/decode
"		string--change phrase end line to end statement in recognition of ANSI 77.
"	02 Jun 1979, RAB - New messages for optimizer
"	21 Mar 1979, PES - New messages for %include and %(global options).
"	05 Dec 1978, PES - New messages for %global and %options.
"	26 Sep 1978, RAB - fixes 187 (add a new error message)
"	28 Jul 1978, PES - bug in entry for error 443 fixed.
"	30 May 1978, PES - converter error messages
"	18 Jan 1978, RAB - loop optimizer error messages
"	04 Jan 1978, DSL - implement print_once_per_(stmnt subpgm).
"	27 Dec 1977, DSL - change format of table to allow bit values to be associated with
"		each error message.
"	Previous changes went unrecorded.
	maclist	off
	macro	message
	vfd	9/&2,9/&l3,18/&n
	use	.message_area.
&u:	aci	"&3"
	use	.text.
	&end

	bool	print_once,400	" print only once per compilation
	bool	print_once_per_stmnt,200+print_once
	bool	print_once_per_subpgm,100+print_once
	bool	save_opnd3,060
	bool	save_opnd2,040
	bool	save_opnd1,020

	name	fort_message_table

	segdef	fort_message_table

fort_message_table:
	zero	0,message_text-1

	message	001,3,(This segment contains no FORTRAN statements, just comment lines.)
	message	002,0,()
	message	003,3,(Main program must be the first program unit in the segment.)
	message	004,2+print_once_per_subpgm,
		     (Executable statements cannot appear in a block data subprogram.)
	message	005,1,(This statement is preceded by an unconditional transfer of control and cannot be referenced.)
	message	006,3,(Syntax error in ^a statement. Text follows logical end of statement.)
	message	007,0,()
	message	008,3,(The do loop ending with ^a has not been terminated.)
	message	009,2,(Return value of function ^a has not been set.)
	message	010,3,(Syntax error. A variable name is required in place of ^a.)
	message	011,3,(Syntax error. A right parenthesis is required in place of ^a.)
	message	012,3,(The label ^a has been referenced but not declared.)
	message	013,3,(Syntax error. A slash is required in place of ^a.)
	message	014,3,(^a is declared with variable bounds but is not a parameter.)
	message	015,1+print_once,
		     (More than one unnamed block data subprogram.)
	message	016,3,(A ^a statement cannot terminate a do loop.)
	message	017,2,(A ^a statement cannot appear in a main program.)
	message	018,3,(^a is the index of two or more nested implied do loops.)
	message	019,3,(^a appears in a bound of ^a, but is not a common or parameter, scalar, integer variable.)
	message	020,3,(^a cannot be declared as a member of the common block ^a.)
	message	021,3,(^a cannot be referenced as a subroutine.)
	message	022,3,(Syntax error. A left parenthesis is required in place of ^a.)
	message	023,3,(Syntax error. A statement label is required in place of ^a.)
	message	024,3,(Syntax error. An unsigned integer constant is required in place of ^a.)
	message	025,3,(Syntax error. A reference to a scalar variable is required in place of ^a.)
	message	026,3,(Syntax error. A comma is required in place of ^a.)
	message	027,3,(Implementation restriction: Do loop and block if nesting has exceeded ^a.)
	message	028,3,(Syntax error. An equivalence group must contain at least two members.)
	message	029,2,(An ^a statement file must be a variable, array, or array element of arithmetic or character type.)
	message	030,3,(The ^a attribute is redundant or conflicting for ^a and is ignored.)
	message	031,3,(A ^a statement must have a ^a specification.)
	message	032,3,(This is not an assignment statement and ^a is not a known keyword.)
	message	033,3,(A global save statement must be the only save statement in a program unit.)
	message	034,3,(Syntax error. A left parenthesis encountered that does not delimit an implied do loop.)
	message	035,3,(A ^a statement cannot appear in a main program.)
	message	036,1+print_once_per_stmnt+save_opnd1,
		     (The real constant ^a has more than ^a significant digits and has been converted to double precision.)
	message	037,3,(Syntax error. A format statement must have a statement label.)
	message	038,3,(A program unit cannot contain both automatic statements and save statements.)
	message	039,3,(^a can only appear in this parameter list once.)
	message	040,3,(Syntax error. A keyword is required in place of ^a.)
	message	041,3,(Syntax error. A label, variable name, or list of labels is required in place of ^a.)
	message	042,3,(A ^a statement cannot be the second part of a logical if statement.)
	message	043,1,(^a has been referenced but not set.)
	message	044,3,(Syntax error. The keyword ^a is required in place of ^a.)
	message	045,3,(Syntax error. A single letter is required in place of ^a.)
	message	046,3,(Syntax error. The letter range specified must be in ascending alphabetical order.)
	message	047,3,(Syntax error. The letters in the letter range must be in the same case.)
	message	048,3,(The ^a keyword has been specified more than once in this statement.)
	message	049,3,(Syntax error. An equals sign is required in place of ^a.)
	message	050,3,(Syntax error. A constant is required in place of ^a.)
	message	051,3,(Syntax error. Only arithmetic constants can be signed.)
	message	052,3,(Syntax error. The characters ^a are out of place.)
	message	053,3,(Syntax error. A character string constant is required in place of ^a.)
	message	054,3,(Pathname in library statement is not acceptable.)
	message	055,3,(Implementation restriction: A statement function is limited to ^a arguments.)
	message	056,3,(This ^a statement is out of sequence and is ignored.)
	message	057,1,(Adding a word to common block ^a in order to store ^a on a double word boundary.)
	message	058,3,(^a is a member of common and cannot have variable bounds.)
	message	059,3,(Storage class for ^a conflicts with storage class of the equivalence group.)
	message	060,3,(Attempt to equivalence ^a to more than one location.)
	message	061,3,(Attempt to change the address of common block ^a.)
	message	062,3,(Cannot equivalence a member of a common block, ^a, to another common block, ^a.)
	message	063,3,(Alignment requirements for equivalence group containing ^a cannot be resolved.)
	message	064,3,(^a cannot appear in an equivalence group.)
	message	065,3,(^a cannot appear in an equivalence group because it has variable bounds.)
	message	066,3,(Syntax error. ^a is not a valid keyword for the ^a statement.)
	message	067,4,(Implementation restriction: ^a has overflowed its limit of ^a words.)
	message	068,1,(^a, which is a formal parameter of the statement function ^a, has not been referenced.)
	message	069,2+print_once_per_stmnt+save_opnd1,
		     (The statement label ^a is less than 1 or greater than 99999.)
	message	070,3,(The statement label ^a has been previously defined. This definition is ignored.)
	message	071,3,(This executable statement label is used as a format specification.)
	message	072,3,(This format statement label is used in an executable context.)
	message	073,3,(The statement label on this statement cannot be referenced.)
	message	074,3,(A reference to an executable statement label is required in place of ^a.)
	message	075,3,(A reference to a format statement label is required in place of ^a.)
	message	076,3,(A subscripted reference to ^a is not possible.)
	message	077,3,(This reference to ^a is not valid because it has variable bounds.)
	message	078,3,(The subscript ^a exceeds the corresponding ^a bound for ^a.)
	message	079,3,(A reference to ^a has ^a subscripts.)
	message	080,3,(Initialization of common blocks can only occur in a block data subprogram. ^a not initialized.)
	message	081,2+print_once_per_stmnt+save_opnd1,
		     (More than one initial value assigned to an element of ^a.)
	message	082,3,(Fewer constants than variables in a data specification.)
	message	083,3+print_once_per_stmnt+save_opnd2,
		     (The mode of ^a is not compatible with the mode of ^a.)
	message	084,3,(More constants than variables in a data specification.)
	message	085,3,(Implementation restriction: Format specification is longer than ^a characters.)
	message	086,3,(Syntax error in a format specification. ^a)
	message	087,3,(Implementation restriction: The character length of ^a exceeds ^a.)
	message	088,3,(Syntax error. A format or namelist reference is required in place of ^a.)
	message	089,3,(Implementation restriction: Implied do loop nesting exceeds ^a.)
	message	090,3,(Syntax error. Parentheses do not balance.)
	message	091,3,(Syntax error in an implied do loop.)
	message	092,3,(^a is not a keyword or variable name and cannot start a FORTRAN statement.)
	message	093,3+print_once_per_stmnt+save_opnd1,(^a cannot be declared as a builtin function.)
	message	094,3,(Syntax error. An operand is required in place of ^a.)
	message	095,3,(Only scalar variables and array elements may appear in a set context.)
	message	096,3+print_once_per_stmnt+save_opnd1,
		     (The function ^a cannot appear in a set context.)
	message	097,3,(^a is followed by a parenthesized list but is not dimensioned and cannot be a function.)
	message	098,3,(^a is dimensioned and must appear in this context with subscripts.)
	message	099,3,(^a is an entry value and cannot appear in this context.)
	message	100,3,(^a cannot appear in this context.)
	message	101,3,(Syntax error. A binary operator is required in place of ^a.)
	message	102,3,(Syntax error. Unexpected occurance of ^a.)
	message	103,1,(Implementation restriction: The line number ^a must be less than 16384.)
	message	104,2,(Missing end statement. One will be supplied by the compiler.)
	message	105,2,(Syntax error. Statement consisting of only a statement label.)
	message	106,3,(The character ^a is not a member of the FORTRAN character set or is out of place.)
	message	107,3,(Invalid use of ^a.)
	message	108,2,(Character string constant whose length is zero.)
	message	109,2,(A character string constant has been terminated by the end of the statement.)
	message	110,3,(Implementation restriction: More than ^a constants in this statement.)
	message	111,3,(Text of this statement exceeds ^a characters.)
	message	112,3,(A continuation line was encountered that was not preceded by an initial line.)
	message	113,3,(There is no line number on this line:^5x^a)
	message	114,3,(The rightmost six digits of ^a will be used as the line number.)
	message	115,3,(The line number ^a is not greater than ^a.)
	message	116,3,(Syntax error. Decimal point missing from end of an operator or logical constant.)
	message	117,3,(.^a. is not an operator or constant known to this compiler.)
	message	118,3,(Missing or incomplete exponent field. The value zero will be used.)
	message	119,3+print_once_per_stmnt+save_opnd1,
		     (Integer constant ^a cannot be represented internally.)
	message	120,3+print_once_per_stmnt+save_opnd2,
		     (More than ^a significant digits in the floating point constant ^a.)
	message	121,3+print_once_per_stmnt+save_opnd1,
		     (Exponent overflow while converting the floating point constant ^a.)
	message	122,3+print_once_per_stmnt+save_opnd1,
		     (Exponent underflow while converting the floating point constant ^a.)
	message	123,3,(Implementation restriction: More than ^a tokens in this statement.)
	message	124,3,(Implementation restriction: Tokens are limited to ^a characters.)
	message	125,2,(The data type of ^a must be the same as that of ^a.)
	message	126,3,(^a cannot be assigned an initial value.)
	message	127,3,(The name ^a cannot be used as an entry point name.)
	message	128,3,(^a is a member of blank common and cannot be assigned an initial value.)
	message	129,2,(The letter range specified in this statement overlaps a previous range.)
	message	130,3,(^a is contained in an octal constant but is not an octal digit.)
	message	131,3,(A statement label appears on a line without any other text.)
	message	132,1,(This statement contains a line with more than 80 characters.)
	message	133,3,(A non-numeric character was encountered in a label field.)
	message	134,2,(Text appears after the closing right parenthesis of a format specification.)
	message	135,3,(The variable ^a must be the index variable of a containing implied do loop.)
	message	136,3,(Implementation restriction: The ^a of ^a exceeds ^a.)
	message	137,3+print_once_per_stmnt+save_opnd1,
		     (A prefix minus cannot precede ^a.)
	message	138,3,(Implementation restriction: There are more than ^a arguments in this reference to ^a.)
	message	139,2,(A character constant used to initialize ^a is longer than ^a characters.)
	message	140,3,(Variable ^a has already been defined, and cannot appear in a ^a statement.)
	message	141,2,(^a must be a scalar integer reference.)
	message	142,3,(The named constant ^a must not appear in this context.)
	message	143,3,(The expression starting with ^a must be a scalar or subscripted variable.)
	message	144,1+print_once_per_stmnt,
		     (Warning: the meaning of multiple exponentiation has been changed from a previous release.)
	message	145,3,(This ^a statement cannot have an input-output list.)
	message	146,3,(This ^a statement must have an input-output list.)
	message	147,2,(Variable ^a was declared with *-length, but is not a parameter or external function--length has been set to ^a.)
	message	148,1,(Line ^a^a was interpreted as a comment, but a legal non-space character follows the initial c.)
	message	149,3,(Asterisks designating external units are not permitted in ^a statements.)
	message	150,1,(Unknown keyword ^a found in %global statement.)
	message	151,1,(Unknown keyword ^a found in %options statement.)
	message	152,3,(The terminating semicolon is missing from a %options or %global statement.)
	message	153,3+print_once_per_subpgm,
		     (The concatenation operator may only be used if the ansi77 control argument or option was specified.)
	message	154,3+print_once_per_subpgm,
		     (The substring operation may only be used if the ansi77 control argument or option was specified.)
	message	155,3,(Invalid substring of ^a:  ^a.)
	message	156,3+print_once_per_stmnt+save_opnd1,
		     (^a cannot contain both ansi77 character variables and other data types.)
	message	157,3+print_once_per_stmnt,
		     (An equivalence group cannot contain both ansi77 character variables and other data types.)
	message	158,3+print_once_per_stmnt,
		     (Star-extent character strings may only be used if the ansi77 control argument or option was specified.)
	message	159,3,(This statement contains a substring reference to ^a, which is not of the character data type.)
	message	160,3,(The %include statement does not contain a file name.)
	message	161,3,(The include file name ^a is longer than 19 characters.  Statement ignored.)
	message	162,3,(Include file ^a not found.  Statement ignored.)
	message	163,3,(Implementation restriction: only 255 include files allowed per compilation.  Include file ^a ignored.)
	message	164,3,(Implementation restriction:  include file ^a exceeds the nesting limit of 32.  Statement ignored.)
	message	165,3,(This reference to ^a would cause infinite recursion of include files.  Statement ignored.)
	message	166,3,(An assumed-size array is not permitted in an ^a statement.)
	message	167,3,(The array ^a has an assumed-size declarator in other than the upper bound of the last dimension.)
	message	168,3,(A lower dimension bound of ^a is greater than the corresponding upper bound.)
	message	169,3,(A dimension bound of ^a is not an arithmetic expression of integer constants and scalar variables.)
	message	170,4,(Compiler error:  An invalid data type has been encountered during evaluation of a parameter expression.)
	message	171,3,(A non-constant operand ^a was found while evaluating ^a.)
	message	172,3,(An operator whose operands are of invalid type was found while evalating ^a .)
	message	173,3,(An attempt was made to use an unimplemented operation while evaluating ^a.)
	message	174,3,(The ^a condition was raised during evaluation of ^a.)
	message	175,3,(An invalid operator was found during evaluation of ^a.)
	message	176,3,(An operand of invalid data type was found during evaluation of ^a.)
	message	177,4,(Compiler error:  the parameter statement work area has overflowed.)
	message	178,3,(The block if beginning at line ^a has not been terminated.)
	message	179,3,(The keyword ^a is missing in a ^a statement.)
	message	180,3,(There is no block if statement corresponding to this ^a statement.)
	message	181,3,(This ^a statement has followed an else statement in the same block if.)
	message	182,3,(The do loop ending at ^a must be ended before this ^a statement.)
	message	183,3,(This statement ends a do loop, but the do loop ending at ^a must be ended first.)
	message	184,3,(This statement ends a do loop, but the block if at line ^a must be ended first.)
	message	185,3,(The label ^a is on a statement that must not be referenced.)
	message	186,2,(^a is not the name of a common block.)
	message	187,3,(Invalid specification or combination of specifications in a ^a statement:  ^a.)
	message	188,2,(The compiler is unable to get status information on source or include file ^a.^/The object segment will be nonstandard.)
	message	189,2,(Implementation restriction:  There are more than ^a arguments in this parameter list.)
	message	190,3,(The label ^a is referenced from outside the do loop ending with ^a.)
	message	191,2,(The ^a ^a supercedes ^a.)
	message	192,2,(The control argument ^a supercedes the %global option ^a.)
	message	193,2,(An invalid %global has been found and will be ignored.  All %globals must be^/at the beginning of the program.)
	message	194,3,(Invalid unit number ^a.  Unit numbers must be in the range from 0 to 99.)
	message	195,0,()
	message	196,0,()
	message	197,0,()
	message	198,0,()
	message	199,0,()
	message	200,4,(Compiler error: the converter has encountered an unexpected operator with the op_code ^a.)
	message	201,4,(Compiler error: attempt to increment_polish beyond end of polish input stack.)
	message	202,4,(Compiler error: the converter work segment has overflowed while adding an entry to the ^a list.)
	message	203,3+print_once_per_subpgm,
		(Compiler error: an sf dummy arg has been found which does not match a known invocation.)
	message	204,3+print_once_per_stmnt,
		(Implementation restriction: an operator cannot use more than ^a operands.)
	message	205,4,(Compiler error: converter work stack pointer has become negative.)
	message	206,4,(Compiler error: converter work stack pointer has exceeded its upper bound of ^a.)
	message	207,0,()
	message	208,0,()
	message	209,0,()
	message	210,0,()
	message	211,0,()
	message	212,0,()
	message	213,0,()
	message	214,0,()
	message	215,0,()
	message	216,0,()
	message	217,0,()
	message	218,0,()
	message	219,0,()
	message	220,0,()
	message	221,0,()
	message	222,0,()
	message	223,0,()
	message	224,0,()
	message	225,0,()
	message	226,0,()
	message	227,0,()
	message	228,0,()
	message	229,3,(Constant type not implemented.)
	message	230,0,()
	message	231,0,()
	message	232,0,()
	message	233,0,()
	message	234,0,()
	message	235,0,()
	message	236,0,()
	message	237,0,()
	message	238,0,()
	message	239,0,()
	message	240,0,()
	message	241,0,()
	message	242,0,()
	message	243,0,()
	message	244,0,()
	message	245,0,()
	message	246,0,()
	message	247,0,()
	message	248,0,()
	message	249,0,()
	message	250,0,()
	message	251,0,()
	message	252,0,()
	message	253,0,()
	message	254,0,()
	message	255,0,()
	message	256,0,()
	message	257,0,()
	message	258,0,()
	message	259,0,()
	message	260,0,()
	message	261,0,()
	message	262,0,()
	message	263,0,()
	message	264,0,()
	message	265,0,()
	message	266,0,()
	message	267,0,()
	message	268,0,()
	message	269,0,()
	message	270,0,()
	message	271,0,()
	message	272,0,()
	message	273,0,()
	message	274,0,()
	message	275,0,()
	message	276,0,()
	message	277,0,()
	message	278,0,()
	message	279,0,()
	message	280,0,()
	message	281,0,()
	message	282,0,()
	message	283,0,()
	message	284,0,()
	message	285,0,()
	message	286,0,()
	message	287,0,()
	message	288,0,()
	message	289,0,()
	message	290,0,()
	message	291,0,()
	message	292,0,()
	message	293,0,()
	message	294,0,()
	message	295,0,()
	message	296,0,()
	message	297,0,()
	message	298,0,()
	message	299,0,()
	message	300,1,
		     (^a must be a scalar integer variable.)
	message	301,3,
		     (^a must be a scalar integer variable.)
	message	302,3,(The data type of a file expression, ^a, must be integer.)
	message	303,3,(An internal file must have the character data type.)
	message	304,3,(The record number expression, ^a, must be integer.)
	message	305,2,(The encode or decode string may not be of logical data type.)
	message	306,3,(Error detected in the definition of the statement function ^a.)
	message	307,3,(Insufficient number of arguments in a reference to the statement function ^a.)
	message	308,3,(Too many arguments supplied in a reference to the statement function ^a.)
	message	309,3,(The data type of ^a is not compatible with its use.)
	message	310,3,(The data type of ^a is not compatible with its use.)
	message	311,3,(^a is complex and ^a is double precision in an expression.)
	message	312,3,(^a is double precision and ^a is complex in an expression.)
	message	313,3,(The data type of ^a must be logical.)
	message	314,3,(The arguments to the builtin function ^a must have the same data type.)
	message	315,3,(^a does not have an arithmetic data type.)
	message	316,3,(The do-loop control variable ^a cannot be complex.)
	message	317,3,(^a in a do statement must be arithmetic.)
	message	318,3,(The do-loop control variable ^a must be arithmetic.)
	message	319,3,(Wrong number of arguments in a reference to the builtin function ^a.)
	message	320,3,(The builtin function ^a has an argument, ^a, that has an invalid data type.)
	message	321,3,(Error in the use of the builtin function ^a. ^a has an invalid data type.)
	message	322,3,(Error in the use of the builtin function ^a. ^a and ^a are complex values.)
	message	323,3,(The complex value ^a cannot be used in this comparison.)
	message	324,3,(^a in a logical if, block if, or else if statement must be a logical value.)
	message	325,3,(^a in an arithmetic if statement must be an arithmetic value.)
	message	326,3,(^a in a computed if statement must be an arithmetic value.)
	message	327,3,(Insufficient number of labels in a computed goto statement.)
	message	328,3,(The complex values ^a and ^a cannot be used in this comparison.)
	message	329,3,(The format item ^a must be an integer array or a character variable.)
	message	330,4,
		     (Compiler error: obsolete macro ^a occurs in the text.)
	message	331,3,(The margin setting ^a must have the integer data type.)
	message	332,3,(The filename ^a must be a character string.)
	message	333,3,(The filetype ^a must be a character string.)
	message	334,3,(In the use of the statement function ^a, ^a does not have the correct data type.)
	message	335,3,(The file to be chained to ^a must be a character string or an integer array.)
	message	336,3,(The system to be chained to ^a must be a character string or an integer array.)
	message	337,3,
		     (The character variable ^a cannot be assigned to an arithmetic variable.)
	message	338,3,(^a cannot be assigned to ^a, because it is not a logical variable.)
	message	339,3,
		     (The logical value ^a cannot be an operand of a relational operator.)
	message	340,3,
		     (The arithmetic value ^a can only be compared to another arithmetic value or a hollerith constant.)
	message	341,3,(^a does not have the character or integer data type and cannot be compared with ^a.)
	message	342,3,(Error in processing the label list in a computed goto statement.)
	message	343,3+print_once_per_subpgm+save_opnd1,
		     (The data type of the statement function ^a must be arithmetic or logical.)
	message	344,3,(Cannot convert a double precision expression to complex in the statement function ^a.)
	message	345,3,(Cannot convert a complex expression to double precision in the statement function ^a.)
	message	346,3,(Cannot convert the defining expression to the data type of the statement function ^a.)
	message	347,3,(The statement function ^a does not have the proper data type.)
	message	348,1+print_once_per_subpgm+save_opnd1,
		     (This reference to ^a contains a character argument that may require descriptors.)
	message	349,3,(An error has been detected in the processing of an open field.)
	message	350,3,(The iostat variable ^a must have the integer data type.)
	message	351,3,(The argument ^a used in this field must have the character data type.)
	message	352,3,(The argument ^a used in this field must have the integer data type.)
	message	353,3,(The argument ^a used in this field must have the logical data type.)
	message	354,3,(^a is used in a character expression but does not have the character data type.)
	message	355,3+print_once_per_stmnt+save_opnd1,
		(The character valued function parameter ^a may not be declared to have *-length.)
	message	356,3,(An error has been detected in the processing of an inquire statement field.)
	message	357,4,(Compiler error: Invalid field number ^a encountered in inquire statement.)
	message	358,3,(The format item ^a cannot be a Very Large Array.)
	message	359,3,(The fld function has an argument, ^a, that must have an integer data type.)
	message	360,3,(The fld function has an argument, ^a, that must have a one word data type.)
	message	361,3,(The value assigned to the fld function must be a one word data type.)
	message	362,3,(^a has an invalid data type.  Typeless expressions can only be compared with typeless or integer values.)
	message	363,2,(The first argument to the fld function must be an integer value in the range 0 to 35.)
	message	364,2,(The second argument to the fld function must be an integer value in the range 1 to 36.)
	message	365,2,(Implementation restriction: only precision of *8 supported for complex types - variables will acquire single precision *8 instead of *^a.)
	message	366,2,(Implementation restriction: only precisions of *4 and *8 are supported for real types - variables will acquire ^a precision instead of *^a.)
	message	367,0,()
	message	368,0,()
	message	369,0,()
	message	370,0,()
	message	371,0,()
	message	372,0,()
	message	373,0,()
	message	374,0,()
	message	375,0,()
	message	376,0,()
	message	377,0,()
	message	378,0,()
	message	379,0,()
	message	380,3,(An undefined label has been found in this program.)
	message	381,4,(Compiler error: the output from the optimizer overwrites the next statement.)
	message	382,4,(Compiler error: ^a does not agree with ^a.)
	message	383,4,(Compiler error: The optimizer has encountered an unexpected operator with the op_code ^a.)
	message	384,1,(The code from LINE ^a to LINE ^a is unreachable or unnecessary.  It will not be compiled.)
	message	385,4,(Implementation restriction: optimization has terminated due to lack of available bits in the masks.)
	message	386,4,(Compiler error: Inconsistency found between an operator and the inputs chain of one of its inputs.)
	message	387,1,(This loop has been eliminated because, after optimization, it has no effect on the result of the program.)
	message	388,4,(Implementation restriction: flow_unit table overflow.  Simplify flow of control:  use do statements for looping.)
	message	389,1,(This loop has no exit.)
	message	390,4,(Implementation restriction: optimizer has created too many new operators.)
	message	391,4,(Compiler error: an expression unthreaded by strength reduction is input to other expressions.)
	message	392,0,()
	message	393,0,()
	message	394,0,()
	message	395,0,()
	message	396,0,()
	message	397,0,()
	message	398,0,()
	message	399,0,()
	message	400,2,(^a has been called with an inconsistent number of arguments.)
	message	401,2,(^a is inconsistent with the corresponding argument type used in ^a.)
	message	402,4,(Compiler error: an invalid index has been used with a ^a macro.)
	message	403,4,(Compiler error: a return macro without arguments has been used to return from a func.)
	message	404,4,(Compiler error: a return macro with an argument has been used to return from a proc.)
	message	405,4,(Compiler error: an exit macro has been used to return from a func.)
	message	406,4,(Compiler error: an exit macro has been used in a proc not invoked by scan.)
	message	407,4,(Compiler error: ^a overflows its maximum of ^a words.)
	message	408,4,(Compiler error: an s_return has been used when no matching s_call exists.)
	message 	409,4,(Compiler error: an ind_jump macro was used when the eaq was not in an indicator substate.)
	message	410,4,(Compiler error: an if_ind or unless_ind macro was used when the eaq was in an invalid state.)
	message	411,4,(Compiler error: an add_to_address macro was used with non-rel_constant ^a.)
	message	412,4,(Compiler error: an attempt was made to get the character length of the non-character operand ^a.)
	message	413,4,(Compiler error: there was an attempt to execute a nonexecutable macro.)
	message	414,4,(Implementation restriction: ^a has overflowed its limit of ^a words.)
	message	415,4,(Compiler error: the reference count of ^a has become less than 0.)
	message	416,4,(Compiler error: ^a has an invalid address field.)
	message	417,4,(Compiler error: ^a needs a pointer register for addressing, but is neither a parameter nor in common.)
	message	418,4,(Compiler error: no index or pointer registers are available for allocation.)
	message	419,4,(Compiler error: the offset of ^a cannot be found in storage.)
	message	420,4,(Compiler error: an attempt was made to update the eaq with ^a to the ind state.)
	message	421,4,(Compiler error: an attempt was made to load ^a into an invalid eaq state.)
	message	422,1,(The subscript ^a of ^a is out of range.)
	message	423,3,(The number of subscripts of ^a does not equal the number of its bounds.)
	message	424,4,(Compiler error: ^a not implemented.)
	message	425,4,(Compiler error: operand stack in improper state at end of subprogram.)
	message	426,1,
		     (The length for common block ^a has been increased to ^a ^a.)
	message	427,4,(Compiler error: the address of ^a has been lost.)
	message	428,3,(The entry point ^a has been multiply declared.)
	message	429,2,(Multics restriction: The common block name ^a contains a dollar-sign and cannot be initialized.)
	message	430,3,(Compiler error: the value of ^a should be in the index register, but it has been lost.)
	message	431,1+print_once_per_subpgm+save_opnd2,
		     (The subscript ^a of parameter ^a is out of range.)
	message	432,2+print_once+save_opnd1,
		     (The common block ^a is initialized more than once. The first initialization is used.)
	message	433,4,
		     (Implementation restriction: the product of ^a and ^a cannot be stored in the stack.)
	message	434,1+print_once+save_opnd1,
		     (Common block ^a is declared with more than one length.)
	message	435,4,
		     (Compiler error: ^a must be a temporary or an array ref.)
	message	436,4,
		     (Compiler error: obsolete macro ^a occurs in the text.)
	message	437,4,
		     (Compiler error: a var proc is invoked by a call macro.)
	message	438,4,
		     (Compiler error: proc arg count not equal to actual arg count. ^a ^a)
	message	439,4,
		     (Compiler error: eaq not loaded by load_for_test macro.)
	message	440,4,
		     (Compiler error: eaq not loaded correctly for ^a.)
	message	441,4,
		     (Compiler error: operand ^a in return macro is not a temporary node.)
	message	442,4,
		     (Compiler error: temporary already has an address.)
	message	443,1+print_once_per_stmnt+save_opnd2,
		     (Only the first ^a characters of ^a can be used.)
	message	444,4,(Compiler error: This statement cannot have a machine state associated with it.)
	message	445,4,(Compiler error: ^a has an invalid ^a field.)
	message	446,4,(Compiler error: ^a has an uninitialized address field.)
	message	447,4,(Compiler error:  an increment cannot be added to the address of ^a.)
	message	448,4,(Compiler error: Could not put operand into EAQ machine state.)
	message	449,4,(Compiler error: Both A and Q found already locked by eaq_man.)
	message	450,4,(Compiler error: An operand which should be in the eaq was not found by get_eaq_name.)
	message	451,1+print_once_per_subpgm,
		     (Implementation restriction: Global ^a table overflows. Optimization may be degraded.)
	message	452,4,
		     (Compiler error: data type ^a undefined for a call to create_constant.)
	message	453,4,(Compiler error: attempt to load global item in a reserved register.)
	message	454,4,(Compiler error: attempt to set up ^a while it has a non-positive reference count.)
	message	455,4,(Compiler error: an operator appears in the polish that should only appear in the quadruples.)
	message	456,3,(Compiler error: the reference count of ^a was left too high.)
	message	457,3,(The ^a appears in a substring reference to ^a, but falls outside the range of a legal character index.)
	message	458,3,(The ^a which appears as a subscript of ^a does not have a numerical data type.)
	message	459,3,(The ^a which appears in a substring reference to ^a does not have a numerical data type.)
	message	460,3,(A substring reference to ^a has a constant length which is less than 1.)
	message	461,3,(The ^a intrinsic function may not be used as an external function.)
	message	462,4,(Compiler error: No integer constant was present on the operand stack when the int_to_char1 macro was invoked.)
	message	463,4,(Compiler error: No character constant was present on the operand stack when the char1_to_int macro was invoked.)
	message	464,4,(Compiler error: The optimizing code generator encountered the ^a intrinsic function.)
	message	465,4,(Compiler error: The output of an operator called from a scan is not a temporary.)
	message	466,4,(Compiler error: An emit_eis macro with the equal_lengths flag was encountered in which the length of the second operand was nonzero.)
	message	467,4,(Compiler error: base_man_store_temp cannot find a usable pointer register.)
	message	468,2,(^a requires argument descriptors and may not be passed the assumed size array ^a.)
	message	469,2,(Implementation restriction: Cannot initialize /^a/ the definition section would overflow its limit of ^a words.)

	message	470,4,(Compiler error: ^a is not a valid operand for ^a.)
	message	471,0,()
	message	472,0,()
	message	473,0,()
	message	474,0,()
	message	475,0,()
	message	476,0,()
	message	477,0,()
	message	478,0,()
	message	479,0,()
	message	480,0,()
	message	481,0,()
	message	482,0,()
	message	483,0,()
	message	484,0,()
	message	485,0,()
	message	486,0,()
	message	487,0,()
	message	488,0,()
	message	489,0,()
	message	490,0,()
	message	491,0,()
	message	492,0,()
	message	493,0,()
	message	494,0,()
	message	495,0,()
	message	496,0,()
	message	497,0,()
	message	498,0,()
	message	499,0,()
	message	500,2,(Cannot get pointer to subsequent source segment.)
	message	501,2,(Number of symbols exceeds ^a. Symbol table will be processed in sections.)
	message	502,2,(Compiler Error: Unknown node ^a discovered in symbol table.)
	message	503,2,(The symbol ^a cannot be chained to others of the same name because the symbol table is too large.)
	message	504,0,()
	message	505,0,()
	message	506,0,()
	message	507,0,()
	message	508,0,()
	message	509,0,()
	message	510,0,()
	message	511,0,()
	message	512,0,()
	message	513,0,()
	message	514,0,()
	message	515,0,()
	message	516,0,()
	message	517,0,()
	message	518,0,()
	message	519,0,()
	message	520,0,()
	message	521,0,()
	message	522,4,(Compiler request to enter Hexadecimal Floating Point mode was denied.)
	message	523,4,(Compiler error: VLA ^a has been encountered which is neither auto, static, common, nor parameter.)
	message	524,3,(Development compiler error:  ^a)
	message	525,4,
		     (Compiler error: unknown error ^a.)

message_text:
	join	/text/.message_area.

	end




		    fort_node_templates_.cds        12/27/84  0834.7rew 12/27/84  0751.8       22986



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

/* format: style3,^delnl,linecom */
fort_node_templates_:
     proc;

/* Written 28 September 1977 by Richard A. Barnes
	Modified:	25 September 1978 by RAB to help fix 187
	Modified:	2 June 1979 by RAB to add flow_unit.is_active_operator
	Modified:	28 June 1979 by RAB to add flow_unit.dim_or_alias_or_not_set.
	Modified:	2 July 1979 by RAB to fix 218 by moving loop_end_chain stuff
		from loop node to flow_unit node.
	Modified:	14 August 1979 by RAB to replace flow_unit.dim_or_alias_or_not_set
		with flow_unit.always_completely_set.	*/

dcl	me		char (20) int static options (constant) init ("fort_node_templates_");
dcl	code		fixed bin (35);

dcl	1 my_cds_args	aligned like cds_args;

dcl	1 auto_fort_node_templates_
			auto aligned,
	  2 flow_unit_template
			like flow_unit aligned;

dcl	com_err_		entry options (variable);
dcl	create_data_segment_
			entry (ptr, fixed bin (35));

dcl	(addr, null, size, unspec)
			builtin;

%include cds_args;
%include fort_opt_nodes;

	unspec (my_cds_args) = "0"b;

	unspec (auto_fort_node_templates_) = "0"b;

	my_cds_args.have_text = "1"b;
	my_cds_args.num_exclude_names = 0;
	my_cds_args.exclude_array_ptr = null;

	my_cds_args.seg_name = me;
	my_cds_args.sections (1).struct_name = "auto_" || me;
	my_cds_args.sections (1).len = size (auto_fort_node_templates_);
	my_cds_args.sections (1).p = addr (auto_fort_node_templates_);

	flow_unit_template.next,
	     flow_unit_template.back,
	     flow_unit_template.successors,
	     flow_unit_template.predecessors,
	     flow_unit_template.dominator,
	     flow_unit_template.loop,
	     flow_unit_template.next_in_loop,
	     flow_unit_template.loop_end_chain,
	     flow_unit_template.used,
	     flow_unit_template.set,
	     flow_unit_template.busy_on_entry,
	     flow_unit_template.set_multiple,
	     flow_unit_template.busy_on_exit,
	     flow_unit_template.dominated_by,
	     flow_unit_template.is_active_operator,
	     flow_unit_template.always_completely_set = null;

	call create_data_segment_ (addr (my_cds_args), code);

	if code ^= 0
	then call com_err_ (code, me);

     end;




		    fort_opt_macros_.alm            11/10/88  1423.8rew 11/10/88  1314.2     1199430



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

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7286),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bugs 430 and 463.
"  2) change(86-07-14,BWong), approve(86-07-14,MCR7442),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bug 410.
"  3) change(88-04-28,RWaters), approve(88-04-28,MCR7875),
"     audit(88-07-13,Huen), install(88-11-10,MR12.2-1209):
"     Implement SCP 6339: Removed the special case code for constants since
"     they can now be up to 128K characters long.
"                                                      END HISTORY COMMENTS


" Written:	January 1976, by G. D. Chang
" Rewritten:	November 1977, by D. S. Levin for optimizing code generator.
"
" Modified:
"         08 Mar 86, SH - 410: Fix bug in cv_bif_to_external where offsets 
"		into vector for dtan, asin, dasin and acos were out
"		of order.
"	08 Aug 85, BW - 430: Prevent emission of deallocation code for
"		automatic LA's and VLA's when they don't exist in the
"		compilation unit.
"	02 Aug 85, BW - 463: Removed code to save and restore stack
"		extents in 'quick_return' and 'make_quick_entry'.
"		This was only done when char star-extent variables
"		were concatenated.
"         12 May 95, BW - 452: Fix looping problem when a vla array is
"		incorrectly used as a format in a write statement.
"	16 Jan 85, MM - 446: Computed GOTO must save state before branching
"		but after loading the Q register and setting indicators.
"	10 Oct 84, MM - Change "fno" to "fad =0.0,du".
"	22 Jun 84, MM - Install typeless functions support.
"	28 Mar 84, HH - Install HFP support.
"	27 Jul 83, HH - 390: Computed GOTO must save state before branching.
"	17 Jun 83, HH - 383: Replace 'scan_parameter_list' subroutine with
"		'prepare_for_namelists' subr and 'process_param_list' proc.
"	 7 June 83, TO: 381 - Fix pr0|shorten_stack for registers pr1,x1.
"	14 Apr 83, HH - 376: Add support for 'len' builtin.
"	31 Jan 83, TO & HH - Install LA/VLA support.
"	10 January  1982, TO - Add 'emit_entry_defs' call to entries.
"	18 Dec 82, TO - Add 'emit_profile_entry' simple operator.
"	27 July 1982, TO - Fix check in relational operators to permit
"	     temporary nodes, such as expressions and function returns in
"	     relationals with character constants.
"	13 May 1982, HH - Add "fixedoverflow" check for multiplies.
"	 6 May 1982, TO - Add shorten stack to return from char*(*) function.
"	 3 May 1982, TO - Add arithmetic 'if' optimization for constant
"		expressions.
"	 1 April   1982, TO  - External intrinsic references to builtins.
"	29 October 1981, CRD - Inquire statement.
"	20 October 1981, CRD - Internal files.
"	4 September 1981, CRD - Fix bug 339.
"	27 August 1981, CRD - More general UNIT field in OPEN/CLOSE stmts.
"	21 August 1981, CRD - Blank field in OPEN statement.
"	31 July 1981, CRD - Add code to optimize jump_true and jump_false
"		operators with constant inputs.
"	28 July 1981, CRD - Allow format labels in assign_label operator,
"		and allow integer scalars in format operator.
"	10 June 1981, CRD - New polish for backspace/endfile/rewind.
"	12 May 1981, CRD - Add equiv_op, not_equiv_op.
"	23 April 1981, CRD - Fix bug 317.
"	13 March 1981, CRD - Modifications for assumed size arrays.
"	9 December 1980, CRD - Modifications for Fortran 77 block IF.  Also
"		moved error 330's to end of segment.
"	19 November 1980, CRD - Change several I/O routines to issue load_pr
"		macros BEFORE loading the A or Q.  This is necessary as
"		loading a pointer to a character array element may use the
"		A or Q.
"	28 October 1980, CRD - Add new intrinsics for Fortran 77.
"	24 September 1980, CRD - Change make_quick_entry to assert that pr1
"		contains the arg list ptr.
"	15 August 1980, CRD - Fix ref count bugs in variable length I/O.
"	13 August 1980, CRD - Add error_macro segdef.
"	16 July 1980, CRD - Key argument list consistency checking off
"		variable_arglist bit, not needs_descriptors bit.
"	15 July 1980, CRD - Centralize call-side descriptor checking in
"		descriptor_check subroutine.  Change logic so that
"		descriptors are automatically generated for calls with
"		character mode arguments in ansi77 mode.
"	27 June 1980, CRD - Add code to allow I/O of strings of variable
"		length.  Also insert check to make sure character valued
"		functions are not of *-length.
"	17 April 1980, CRD - Add code to implement concatenation.
"	26 March 1980, CRD - Fix bug in xmit_scalar - temps in Q not getting saved.
"	23 Feb 1980, RAB - improve code for conversion from float to integer,
"		add code to use ADE in multiply/divide by power of two for
"		floating point, fix glitch in open.
"	11 Feb 1980, CRD - add code for eight new builtins: CHAR, ICHAR,
"		INDEX, LEN, LGE, LGT, LLE, and LLT.
"	4 Feb 1980, CRD - add support for entries requiring descriptors.
"	27 Jan 1980, RAB - to improve code for jump_computed.
"	27 Jan 1980, RAB - to change most conversions from integer to float
"		from calls to pl1_operators_ to inline code.
"	27 Dec 1979, RAB - load pr2 before pr1 in the exponentiation operators,
"		add refresh_regs_if_next_is_jump and note_eligible_ind_var_use
"		in the relational operators, add note_eligible_ind_var_use
"		in the incrementing operators.  These changes will improve
"		object code generated by the register optimizer.
"	30 Nov 1979, RAB - Add support for certain operations in index registers
"		for the register optimizer.
"	03 Nov 1979, RAB - Add load_xreg, load_preg procs; use refresh_regs
"		macros for register optimizer.
"	03 Nov 1979, RAB - Remove lots of set_inds_valid macros having
"		changed return eaq_name to do the job.
"	31 Oct 1979, CRD - Add mpy to single_inst table.
"	17 Oct 1979, CRD - Insert lots of set_inds_valid macros, change
"		jump_true and jump_false to use ind_to_a.
"	09 Aug 1979, CRD - Fix bug 221 (dmod implemented incorrectly)
"	18 Jul 1979, CRD - Fix bug 226 re reference counts of complex temps.
"		convert_to_cmpx macro was erroneously swapping its operands
"		in the real and dp cases.
"	12 Jul 1979, PES - More forgiving encode/decode statement.  The string may
"		now be an array, simple variable, or array element of any type
"		but logical.
"	09 Jul 1979, CRD - Changes to fix bug 220, in which files do not
"		get closed if there is no STOP or CALL EXIT statement in the
"		main program.
"	02 May 1979, RAB - adds adwpn instructions to single_inst to support new
"		scheme for dealing with addresses >= 16K by using ptr regs.
"	18 Nov 1978, RAB - Centralizes rounding decisions in "round" and
"		"store" macros.  Precedes many floating compares
"		with rounds.
"	13 Sep 1978, PES - Changes to fix bug 183, in which fortran sometimes decides that
"		external subroutine names passed out as arguments in a call should be
"		treated as character strings.
"	05 Sep 1978, PES - Don't round in real & dp assignments if source was in storage.
"	27 Jul 1978, PES - Fix bug in handling of character function return args.
"	05 Apr 1978, DSL - Implement save_state,protect_indicators, fix bugs in
"		jump_true/jump_false.
"	30 Mar 1978, DSL - Use new macro, free_temp, to free arg list temp after
"		func ref.
"	22 Mar 1978, DSL - Bug fixes and min/max ref count changes.
"	15 Feb 1978, DSL - Changes for push_operand macro.
"	13 Feb 1978, DSL - Fix bug in atan2 bifs in which a "load_pr pr1"
"		made other operand references impossible.
"	02 Feb 1978, DSL - Fix jump_true/jump_false inversion. Add drop_counts
"		around (if unless)_ind. Make round_dp_to_real a function. Have assign_i
"		and assign_l perform stz optimization when appropriate.
"	05 Jan 1978, DSL - Implement double precision to complex conversion for
"		arithmetic infix oprs and for assignment.
"	04 Jan 1978, DSL - Implement rel ops for one char const opnd and one
"		arith opnd. Fix bug in func ref (unreported) in which no warning is
"		printed if return value is char and may need descriptors.
"	27 Dec 1977, DSL - fix bug in cv_bif_to_external (136); use new macros
"		pad_char_const_to_(word dw) in assign, fix bug in func_ref (130),
"		change macros to truncate on store when appropriate, introduce use
"		of new macro, dt_jump1.
"	15 Sep 1977, DSL - interim fix to abs bif until load_for_test macro
"		is available.
"	19 Jul 1977, DSL - fix bugs in open/close.
"	14 Jul 1977, DSL - 1) fix sf def for simple references.
"		2) change implementation of open/close. 3) fix sf ref for
"		logical sf. 4) prevent parameters from reaching
"		make_external_variable.
"	26 May 1977, GDC - allow statement functions to take character
"		arguments with character data-types.
"
	maclist	object
	include		fort_macros
	include		fort_equs

	include		stack_header
	include		stack_frame

	name		fort_opt_macros_

	segdef		operator_table
	segdef		single_inst
	segdef		interpreter_macros
	segdef		first_scan
	segdef		abort_list
	segdef		error_macro
	use		.text.

	include	fort_operator_table

	include	fort_single_inst

interpreter_macros:
	zero	check_subscript			1
	zero	subscript_mpy			2
	zero	move_eis				3


check_subscript:
	func	2

	if	arg1,=,op1,ret_sub

	load	q,arg2

	lda	1,dl
	cwl	arg1
	tze	2,ic
	tsx0	pr0|bound_ck_signal

ret_sub:
	return	arg1


subscript_mpy:
	proc	1


	if	arg1,=,1,ret_mpy

	if_check_multiply	subscript_mpy.1

	if	arg1,=,2,qls1

subscript_mpy.1:
	mpy	arg1

	unless_check_multiply	subscript_mpy.2
	tsx0		pr0|mpy_overflow_check

subscript_mpy.2:
	set_inds_valid	q

ret_mpy:	return

qls1:	emit_inst	1

	qls	1

	return


move_eis:
	proc	2

	emit_eis
	mlr	(),(pr),fill(040)
	desc9a	arg1
	desc9a	arg2

	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

first_scan:
	scan		continue,continue


abort_list:
	scan		continue,(continue,next)


error_macro:
	error

assign:	proc		1

	push_output
	swap		op2	" Put in expected order.

	dt_jump		(assign_ii,assign_ri,assign_di,assign_ci,assign_ir,assign_rr,assign_dr,assign_cr,assign_id,assign_rd,assign_dd,assign_cd,assign_ic,assign_rc,assign_dc,assign_cc,assign_e2,assign_e1,assign_t,assign_t)

assign_ii:
	unless_optype	constant,assign_ii.not_zero
	unless_zero	op1,assign_ii.not_zero
	stz		arg1
	flush_ref		arg1
	return

assign_ii.not_zero:
	if_global		arg1,assign_ii.check_induction_var
	if_global		arg2,assign_ii.check_induction_var

assign_ii.normal:
	load		q,arg2
	store		q,arg1
	return

assign_ii.check_induction_var:
	unless_induction_var	arg1,assign_ii.normal
	unless_induction_var	arg2,assign_ii.normal

	assign_index
	return

assign_ir:
	unless_optype	constant,assign_ir.not_const

assign_i.check_zero:
	convert_constant	int
	unless_zero	op1,assign_ii.not_zero
	stz		arg1
	flush_ref		arg1
	return

assign_ir.not_const:
	s_call		cv_load.ri_not_const
	store		q,arg1
	return

assign_ri:
	s_call		cv_load.ir
	store		eaq,arg1
	return

assign_id:
	if_optype		constant,assign_i.check_zero
	s_call		cv_load.di_not_const
	store		q,arg1
	return

assign_di:
	s_call		cv_load.id
	store		deaq,arg1
	return

assign_rr:
	load		eaq,arg2
	store		eaq,arg1
	return

assign_dd:
	load		deaq,arg2
	store		deaq,arg1
	return

assign_rd:
	load		deaq,arg2
	fstr		arg1
	return

assign_dr:
	load		eaq,arg2
	store		deaq,arg1,no_update
	return

assign_ic:
	if_optype		constant,assign_i.check_zero
	s_call		cv_load.ri_not_const
	store		q,arg1
	return

assign_ci:
	s_call		cv_load.ir
	jump		assign_cr.01

assign_rc:
	load		eaq,arg2
	store		eaq,arg1
	return

assign_cr:
	load		eaq,arg2
assign_cr.01:
	bump		arg1
	store		eaq,arg1,no_update
	fld		=0.,du
	fst		arg1+1
	return

assign_dc:
	load		eaq,arg2
	store		deaq,arg1,no_update
	return

assign_cd:
	load		deaq,arg2
	jump		assign_cr.01

assign_cc:
	load		aq,arg2
	store		aq,arg1
	return

assign_e2:
	if_dt		logical,assign_l
	if_dt		char,assign_h
	error		310,op1

assign_l:
	swap		arg1
	unless_dt		logical,logical.p
	swap		arg1
	unless_optype	constant,assign_l.not_zero
	unless_zero	arg2,assign_l.not_zero
	stz		arg1
	flush_ref		arg1
	return

assign_l.not_zero:
	load		a,arg2
	store		a,arg1
	return

assign_h:		" Modified 12/27/77 to allow char consts for all arith data types
	dt_jump1		arg1,(assign_ih,assign_rh,assign_dh,assign_ch,assign_lh,assign_hh,assign_th)

assign_ih:
assign_rh:
assign_lh:
assign_th:
	unless_optype	constant,char2.p
	pad_char_const_to_word	op1
	load		a,op1
	store		a,op2
	return

assign_dh:
assign_ch:
	unless_optype	constant,char2.p
	pad_char_const_to_dw	op1
	load		aq,op1
	store		aq,op2
	return


assign_hh:
	emit_eis
	mlr		(pr),(pr),fill(040)
	desc9a		arg2
	desc9a		arg1

	return

logical.p:
	print		338,arg1,op1
	return

char2.p:
	print		337,op1
	return

assign_e1:
	print		309,arg1
	return

assign_t:
	dt_jump1		arg1,(assign_t.normal,assign_t.normal,assign_e1,assign_e1,assign_t.to_logical,assign_t.normal)

assign_t.normal:
	unless_optype	constant,assign_t.not_zero
	unless_zero	op1,assign_t.not_zero
	stz		arg1
	flush_ref		arg1
	return

assign_t.not_zero:
	unless_one_word_dt	arg1,assign_e1		"trap assignments to invalid character vars
	load		tq,arg2
	store		tq,arg1
	return

assign_t.to_logical:
	unless_optype	constant,assign_t.logical.var
	unless_zero	op1,assign_t.logical.not_zero
	stz		arg1
	flush_ref		arg1
	return

assign_t.logical.var:
	load_for_test	tq,arg2
	emit		2
	tze		2,ic
	ldq		131072,du
	store		tq,arg1
	return

assign_t.logical.not_zero:
	use_q
	emit		1
	ldq		131072,du
	stq		arg1
	flush_ref		arg1
	return

add:	func		2

	dt_jump		(add_ii,add_ri,add_di,add_ci,add_ir,add_rr,add_dr,add_cr,add_id,add_rd,add_dd,add_cd,add_ic,add_rc,add_dc,add_cc,add_e2,add_e1,add_tl,add_tl)

add_ii:
	load_top		q
	adq		arg1
	return		q

add_ir:
	swap		arg1

add_ri:
	s_call		cv_load.ir
	fad		arg1
	return		eaq

add_id:
	swap		arg1

add_di:
	s_call		cv_load.id
	dfad		arg1
	return		deaq

add_rr:
	load_top		eaq
	fad		arg1
	return		eaq

add_dd:
	load_top		deaq
	dfad		arg1
	return		deaq

add_rd:
	swap		arg1

add_dr:
	if_eaq		eaq,arg2,add_dr.1

	load		deaq,arg1
	fad		arg2
	return		deaq

add_dr.1:
	dfad		arg1
	return		deaq

add_ic:
	swap		arg1

add_ci:
	bump		arg1
	s_call		cv_load.ir
	push_output
	bump		op1
	jump		add_cr.1

add_rc:
	swap		arg1

add_cr:
	bump		arg1
	push_output
	bump		op1

	if_eaq		eaq,arg2,add_cr.1
	if_eaq		eaq,arg1,add_cr.2

	load		ieaq,arg1
	store		ieaq,op1,no_update
	fld		arg1
	fad		arg2
	in_reg		eaq,op1
	return		op1

add_cr.1:
	fad		arg1
add_cr.11:
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

add_cr.2:
	fad		arg2
	jump		add_cr.11

add_dc:
	swap		arg1

add_cd:
	bump		arg1
	push_output
	bump		op1

	if_eaq		deaq,arg2,add_cd.1
	if_eaq		eaq,arg1,add_cd.2

	load		ieaq,arg1
	store		ieaq,op1,no_update
	fld		arg1
	dfad		arg2
	in_reg		eaq,op1
	return		op1

add_cd.1:
	fad		arg1
add_cd.11:
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

add_cd.2:
	dfad		arg2
	jump		add_cd.11

add_cc:
	bump		arg1
	bump		arg2
	push_output
	bump		op1
	if_eaq		eaq,arg2,add_cc.1
	if_eaq		ieaq,arg2,add_cc.2
	if_eaq		eaq,arg1,add_cc.3

	load		ieaq,arg1
	fad		arg2+1
add_cc.01:
	store		ieaq,op1,no_update
	fld		arg1
	fad		arg2
	in_reg		eaq,op1
	return		op1

add_cc.1:
	fad		arg1
add_cc.11:
	store		eaq,op1,no_update
	fld		arg1+1
	fad		arg2+1
	in_reg		ieaq,op1
	return		op1

add_cc.2:
	fad		arg1+1
	jump		add_cc.01

add_cc.3:
	fad		arg2
	jump		add_cc.11

add_e1:
	error		309,arg1

add_e2:
	error		310,arg2

add_tl:
	load_top		tq
	dt_jump1		arg1,(add_tl.1,add_e1,add_e1,add_e1,add_e1,add_e1,add_tl.1)

add_tl.1:
	adq		arg1
	return		tq

sub:	func		2

	dt_jump		(sub_ii,sub_ri,sub_di,sub_ci,sub_ir,sub_rr,sub_dr,sub_cr,sub_id,sub_rd,sub_dd,sub_cd,sub_ic,sub_rc,sub_dc,sub_cc,sub_e2,sub_e1,sub_tl,sub_tl)

sub_ii:
	load		q,arg1
	sbq		arg2
	return		q

sub_ir:
	swap		arg1

	s_call		cv_load.ir
	fsb		arg1
	return		eaq

sub_ri:
	if_eaq		q,arg2,sub_ri.1

	if_optype		constant,conv_sub_ri

	lcq		arg2
	s_call		cv_q_to_real
	fad		arg1
	return		eaq

conv_sub_ri:
	convert_constant	real
	load		eaq,arg1
	fsb		arg2
	return		eaq

sub_ri.1:
	s_call		cv_q_to_real
	emit_inst		1
	fneg
	fad		arg1
	return		eaq

sub_id:
	swap		arg1

	s_call		cv_load.id
	dfsb		arg1
	return		deaq

sub_di:
	if_eaq		q,arg2,sub_di.1

	if_optype		constant,conv_sub_di

	lcq		arg2
	s_call		cv_q_to_dp
	dfad		arg1
	return		deaq

conv_sub_di:
	convert_constant	dp
	load		deaq,arg1
	dfsb		arg2
	return		deaq

sub_di.1:
	s_call		cv_q_to_dp
	emit_inst		1
	fneg
	dfad		arg1
	return		deaq

sub_rr:
	if_eaq		eaq,arg2,sub_rr.1

	load		eaq,arg1
	fsb		arg2
	return		eaq

sub_rr.1:
	emit_inst		1
	fneg
	fad		arg1
	return		eaq

sub_dd:
	if_eaq		deaq,arg2,sub_dd.1

	load		deaq,arg1
	dfsb		arg2
	return		deaq

sub_dd.1:
	emit_inst		1
	fneg
	dfad		arg1
	return		deaq

sub_rd:
	if_eaq		deaq,arg2,sub_rd.1

	load		eaq,arg1
	dfsb		arg2
	return		deaq

sub_rd.1:
	emit_inst		1
	fneg
	fad		arg1
	return		deaq

sub_dr:
	if_eaq		eaq,arg2,sub_dr.1

	load		deaq,arg1
	fsb		arg2
	return		deaq

sub_dr.1:
	emit_inst		1
	fneg
	dfad		arg1
	return		deaq

sub_ic:
	bump		arg2
	push_output
	bump		op1

	swap		arg1
	s_call		cv_load.ir
	swap		arg1
	jump		sub_rc.1

sub_ci:
	bump		arg1
	push_output
	bump		op1

	swap		arg2

	if_optype		constant,conv_sub_ci

	swap		arg2
	lcq		arg2
	s_call		cv_q_to_real
	jump		sub_cr.10

conv_sub_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		sub_cr.1

sub_rc:
	bump		arg2
	push_output
	bump		op1

	if_eaq		eaq,arg1,sub_rc.1
	if_eaq		eaq,arg2,sub_rc.2

	load		ieaq,arg2
	emit_inst		1
	fneg
	store		ieaq,op1,no_update
	fld		arg1
	fsb		arg2
	in_reg		eaq,op1
	return		op1

sub_rc.1:
	fsb		arg2
sub_rc.11:
	store		eaq,op1,no_update
	fld		arg2+1
	emit_inst		1
	fneg
	in_reg		ieaq,op1
	return		op1

sub_rc.2:
	emit_inst		1
	fneg
	fad		arg1
	jump		sub_rc.11

sub_cr:
	bump		arg1
	push_output
	bump		op1

	if_eaq		eaq,arg2,sub_cr.1
	if_eaq		eaq,arg1,sub_cr.2

	load		ieaq,arg1
	store		ieaq,op1,no_update
	fld		arg1
	fsb		arg2
	in_reg		eaq,op1
	return		op1

sub_cr.1:
	emit_inst		1
	fneg
sub_cr.10:
	fad		arg1
sub_cr.11:
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

sub_cr.2:
	fsb		arg2
	jump		sub_cr.11

sub_dc:
	bump		arg2
	push_output
	bump		op1

	if_eaq		deaq,arg1,sub_dc.1
	if_eaq		eaq,arg2,sub_dc.2

	load		ieaq,arg2
	emit_inst		1
	fneg
	store		ieaq,op1,no_update
	dfld		arg1
	fsb		arg2
	in_reg		eaq,op1
	return		op1

sub_dc.1:
	fsb		arg2
sub_dc.11:
	store		eaq,op1,no_update
	fld		arg2+1
	emit_inst		1
	fneg
	in_reg		ieaq,op1
	return		op1

sub_dc.2:
	emit_inst		1
	fneg
	dfad		arg1
	jump		sub_dc.11

sub_cd:
	bump		arg1
	push_output
	bump		op1

	if_eaq		deaq,arg2,sub_cd.1
	if_eaq		eaq,arg1,sub_cd.2

	load		ieaq,arg1
	store		ieaq,op1,no_update
	fld		arg1
	dfsb		arg2
	in_reg		eaq,op1
	return		op1

sub_cd.1:
	emit_inst		1
	fneg
sub_cd.10:
	fad		arg1
sub_cd.11:
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

sub_cd.2:
	dfsb		arg2
	jump		sub_cd.11

sub_cc:
	bump		arg1
	bump		arg2
	push_output
	bump		op1

	if_eaq		eaq,arg2,sub_cc.1
	if_eaq		ieaq,arg2,sub_cc.2
	if_eaq		eaq,arg1,sub_cc.3

	load		ieaq,arg1
	fsb		arg2+1
sub_cc.01:
	store		ieaq,op1,no_update
	fld		arg1
	fsb		arg2
	in_reg		eaq,op1
	return		op1

sub_cc.1:
	emit_inst		1
	fneg
	fad		arg1
sub_cc.11:
	store		eaq,op1,no_update
	fld		arg1+1
	fsb		arg2+1
	in_reg		ieaq,op1
	return		op1

sub_cc.2:
	emit_inst		1
	fneg
	fad		arg1+1
	jump		sub_cc.01

sub_cc.3:
	fsb		arg2
	jump		sub_cc.11

sub_e1:
	error		309,arg1

sub_e2:
	error		310,arg2

sub_tl:
	unless_dt		(int,typeless),sub_e2
	dt_jump1		arg1,(sub_tl.1,sub_e1,sub_e1,sub_e1,sub_e1,sub_e1,sub_tl.1)

sub_tl.1:
	load		tq,arg1
	sbq		arg2
	return		tq

mult:	func		2

	dt_jump		(mult_ii,mult_ri,mult_di,mult_ci,mult_ir,mult_rr,mult_dr,mult_cr,mult_id,mult_rd,mult_dd,mult_cd,mult_ic,mult_rc,mult_dc,mult_cc,mult_e2,mult_e1,mult_tl,mult_tl)

mult_ii:
	if_check_multiply	mult_ii.1
	power_of_two	arg1,mult_ii.one_is
	power_of_two	arg2,mult_ii.two_is

mult_ii.1:
	load_top		q
	mpy		arg1

	unless_check_multiply	mult_ii.2
	tsx0		pr0|mpy_overflow_check

mult_ii.2:
	return		q

mult_ii.one_is:
	load		q,arg2
	qls		arg1
	return		q

mult_ii.two_is:
	load		q,arg1
	qls		arg2
	return		q

mult_ir:
	swap		arg1

mult_ri:
	s_call		cv_load.ir
	fmp		arg1
	return		eaq

mult_id:
	swap		arg1

mult_di:
	s_call		cv_load.id
	dfmp		arg1
	return		deaq

mult_rr:
	float_power_of_fpbase	arg1,mult_rr.one_is
	float_power_of_fpbase	arg2,mult_rr.two_is
	load_top		eaq
	fmp		arg1
	return		eaq

mult_rr.one_is:
	swap		arg1

mult_rr.two_is:
	load_for_test	eaq,arg1
	use_eaq
	tze		2,ic
	ade		arg2
	jump		mm_ret_eaq

mult_dd:
	float_power_of_fpbase	arg1,mult_dd.one_is
	float_power_of_fpbase	arg2,mult_dd.two_is
	load_top		deaq
	dfmp		arg1
	return		deaq

mult_dd.one_is:
	swap		arg1

mult_dd.two_is:
	load_for_test	deaq,arg1

use_ade.dd:
	use_eaq
	tze		2,ic
	ade		arg2
	jump		mm_ret_deaq

mult_rd:
	swap		arg1

mult_dr:
	float_power_of_fpbase	arg1,mult_dr.one_is
	float_power_of_fpbase	arg2,mult_dd.two_is
	if_eaq		eaq,arg2,mult_dr.1

	load		deaq,arg1
	fmp		arg2
	return		deaq

mult_dr.1:
	dfmp		arg1
	return		deaq

mult_dr.one_is:
	load_for_test	eaq,arg2
	swap		arg1
	jump		use_ade.dd

mult_ic:
	swap		arg1

mult_ci:
	bump		arg1
	push_output
	bump		op1

	swap		arg2

	if_optype		constant,conv_mult_ci

	swap		arg2
	push_temp		real
	bump		op1	" temp becomes arg2

	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real

	swap		arg2
	store		eaq,arg2,no_update
	pop		op1
	jump		mult_cr.1

conv_mult_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		mult_cr.1

mult_rc:
	swap		arg1

mult_cr:
	bump		arg1
	bump		arg2
	push_output
	bump		op1

	if_eaq		eaq,arg2,mult_cr.1
	if_eaq		eaq,arg1,mult_cr.2

	load		ieaq,arg1
	fmp		arg2
	store		ieaq,op1,no_update
	fld		arg1
	fmp		arg2
	in_reg		eaq,op1
	return		op1

mult_cr.1:
	fmp		arg1
mult_cr.11:
	store		eaq,op1,no_update
	fld		arg2
	fmp		arg1+1
	in_reg		ieaq,op1
	return		op1

mult_cr.2:
	fmp		arg2
	jump		mult_cr.11

mult_dc:
	swap		arg1

mult_cd:
	bump		arg1
	bump		arg2
	push_output
	bump		op1

	if_eaq		deaq,arg2,mult_cd.1
	if_eaq		eaq,arg1,mult_cd.2

	load		ieaq,arg1
	dfmp		arg2
	store		ieaq,op1,no_update
	fld		arg1
	dfmp		arg2
	in_reg		eaq,op1
	return		op1

mult_cd.1:
	fmp		arg1
mult_cd.11:
	store		eaq,op1,no_update
	dfld		arg2
	fmp		arg1+1
	in_reg		ieaq,op1
	return		op1

mult_cd.2:
	dfmp		arg2
	jump		mult_cd.11

mult_cc:
	load		aq,arg1
	bump		arg2
	load_pr		pr2,arg2
	use_eaq
	tsx0		pr0|complex_multiply
	drop		arg2
	ldaq		pr6|complex
	free_regs
	return		aq

mult_e1:
	error		309,arg1

mult_e2:
	error		310,arg2

mult_tl:
	unless_dt		(int,typeless),mult_e2
	dt_jump1		arg1,(mult_tl.1,mult_e1,mult_e1,mult_e1,mult_e1,mult_e1,mult_tl.1)

mult_tl.1:
	if_check_multiply	mult_tl.2
	power_of_two	arg1,mult_tl.one_is
	power_of_two	arg2,mult_tl.two_is

mult_tl.2:
	load_top		tq
	mpy		arg1

	unless_check_multiply	mult_tl.3
	tsx0		pr0|mpy_overflow_check

mult_tl.3:
	return		tq

mult_tl.one_is:
	load		tq,arg2
	qls		arg1
	return		tq

mult_tl.two_is:
	load		tq,arg1
	qls		arg2
	return		tq

div:	func		2

	dt_jump		(div_ii,div_ri,div_di,div_ci,div_ir,div_rr,div_dr,div_cr,div_id,div_rd,div_dd,div_cd,div_ic,div_rc,div_dc,div_cc,div_e2,div_e1,div_tl,div_tl)

div_ii:
	load		q,arg1
	div		arg2
	return		q

div_ir:
	swap		arg1

	s_call		cv_load.ir
	fdv		arg1
	return		eaq

div_ri:
	s_call		cv_load.ir
	fdi		arg1
	return		eaq

div_id:
	swap		arg1

	s_call		cv_load.id
	dfdv		arg1
	return		deaq

div_di:
	s_call		cv_load.id
	dfdi		arg1
	return		deaq

div_rr:
	float_power_of_fpbase	arg2,div_r.power_of_two,for_divide
	if_eaq		eaq,arg2,div_rr.1

	load		eaq,arg1
	fdv		arg2
	return		eaq

div_rr.1:
	fdi		arg1
	return		eaq

div_r.power_of_two:
	load_for_test	eaq,arg1
	use_eaq
	tze		2,ic
	ade		arg2
	jump		mm_ret_eaq

div_dd:
	float_power_of_fpbase	arg2,div_d.power_of_two,for_divide
	if_eaq		deaq,arg2,div_dd.1

	load		deaq,arg1
	dfdv		arg2
	return		deaq

div_dd.1:
	dfdi		arg1
	return		deaq


div_d.power_of_two:
	load_for_test	deaq,arg1
	use_eaq
	tze		2,ic
	ade		arg2
	jump		mm_ret_deaq

div_rd:
	float_power_of_fpbase	arg2,div_rd.power_of_two,for_divide
	load		eaq,arg1
	dfdv		arg2
	return		deaq

div_rd.power_of_two:
	load_for_test	eaq,arg1
	use_eaq
	tze		2,ic
	ade		arg2
	jump		mm_ret_deaq

div_dr:
	float_power_of_fpbase	arg2,div_d.power_of_two,for_divide
	load		eaq,arg2
	dfdi		arg1
	return		deaq

div_ic:
	swap		arg1

	if_optype		constant,conv_div_ic

	s_call		cv_load.ir

	swap		arg1
	fstr		sp|double_temp
	lda		sp|double_temp
	jump		div_rc.01

conv_div_ic:
	convert_constant	real
	swap		arg1
	jump		div_rc

div_ci:
	bump		arg1
	push_output
	bump		op1

	swap		arg2

	if_optype		constant,conv_div_ci

	swap		arg2
	push_temp		real
	bump		op1	" temp becomes arg2

	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real

	swap		arg2
	store		eaq,arg2,no_update
	pop		op1
	jump		div_cr.1

conv_div_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		div_cr.1

div_rc:
	load		a,arg1
div_rc.01:
	ldq		=0.,du
	bump		arg2
	load_pr		pr2,arg2
	use_eaq
	tsx0		pr0|complex_divide
	drop		arg2
	ldaq		pr6|complex
	free_regs
	return		aq

div_cr:
	bump		arg1
	bump		arg2
	push_output
	bump		op1

	if_eaq		eaq,arg2,div_cr.1
	if_eaq		eaq,arg1,div_cr.2

	load		ieaq,arg1
	fdv		arg2
div_cr.01:
	store		ieaq,op1,no_update
	fld		arg1
	fdv		arg2
	in_reg		eaq,op1
	return		op1

div_cr.1:
	fdi		arg1+1
	jump		div_cr.01

div_cr.2:
	fdv		arg2
	store		eaq,op1,no_update
	fld		arg1+1
	fdv		arg2
	in_reg		ieaq,op1
	return		op1

div_dc:
	swap		arg1
	call		round_dp_to_real
	swap		arg1
	jump		div_rc

div_cd:
	bump		arg1
	bump		arg2
	push_output
	bump		op1

	if_eaq		deaq,arg2,div_cd.1
	if_eaq		eaq,arg1,div_cd.2

	load		ieaq,arg1
	dfdv		arg2
div_cd.01:
	store		ieaq,op1,no_update
	fld		arg1
	dfdv		arg2
	in_reg		eaq,op1
	return		op1

div_cd.1:
	fdi		arg1+1
	jump		div_cd.01

div_cd.2:
	dfdv		arg2
	store		eaq,op1,no_update
	fld		arg1+1
	dfdv		arg2
	in_reg		ieaq,op1
	return		op1

div_cc:
	load		aq,arg1
	bump		arg2
	load_pr		pr2,arg2
	use_eaq
	tsx0		pr0|complex_divide
	drop		arg2
	ldaq		pr6|complex
	free_regs
	return		aq

div_e1:
	error		309,arg1

div_e2:
	error		310,arg2

div_tl:
	unless_dt		(int,typeless),div_e2
	dt_jump1		arg1,(div_tl.1,div_e1,div_e1,div_e1,div_e1,div_e1,div_tl.1)
	load		tq,arg1

div_tl.1:
	use_eaq
	div		arg2
	return		tq

cv_load.ir:
	if_optype		constant,conv_ir

	s_call		cv_int_to_float

	set_inds_valid	eaq
	s_return

conv_ir:
	convert_constant	real
	load		eaq,op1
	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

cv_load.ri:
	if_optype		constant,conv_ri

cv_load.ri_not_const:
	load		eaq,op1
	round		eaq
	s_call		cv_real_to_int
	set_inds_valid	q
	s_return

conv_ri:
	convert_constant	int
	load		q,op1
	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

cv_load.id:
	if_optype		constant,conv_id

	s_call		cv_int_to_float

	set_inds_valid	deaq
	s_return

conv_id:
	convert_constant	dp
	load		deaq,op1
	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

cv_load.di:
	if_optype		constant,conv_di

cv_load.di_not_const:
	load		deaq,op1
	round		deaq
	s_call		cv_dp_to_int
	set_inds_valid	q
	s_return

conv_di:
	convert_constant	int
	load		q,op1
	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

cv_int_to_float:
	if_eaq		q,op1,cv_int_to_float.q_loaded
	if_hfp		cv_int_to_hfp

cv_int_to_bfp:
	lda		op1
	emit_inst		3
	lrs		36
	lde		=71b25,du
	fad		=0.,du

	s_return

cv_int_to_hfp:
	lda		op1
	emit_inst		4
	lrs		36
	lde		=18b25,du
	fad		=0.,du
	fmp		P0.5H,du

	s_return

cv_q_to_real:
cv_q_to_dp:
cv_int_to_float.q_loaded:
	if_hfp		cv_int_to_hfp.q_loaded

cv_int_to_bfp.q_loaded:
	emit_inst		3
	lls		36
	lde		=35b25,du
	fad		=0.,du

	s_return

cv_int_to_hfp.q_loaded:
	emit_inst		3
	lls		36
	lde		=9b25,du
	fmp		P0.5H,du

	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

cv_real_to_int:
	if_ind		eaq,cv_float_to_int
	fcmp		=0.,du
	jump		cv_float_to_int

cv_dp_to_int:
	if_ind		deaq,cv_float_to_int
	fcmp		=0.,du

cv_float_to_int:
	if_hfp		cv_hfp_to_int

cv_bfp_to_int:
	use_eaq
	tpl		2,ic
	dufa		pr0|almost_one
	ufa		=71b25,du

	s_return

cv_hfp_to_int:
	use_eaq
	tpl		2,ic
	dufa		pr0|almost_one
	ufm		P2.0H,du
	ufa		=18b25,du

	s_return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

"	This function expects the top of the stack to be a dp operand. The top of the stack
"	is replaced by a real constant derived from the dp one. If the dp operand is not a
"	constant, a real temp is created. Ref count should be such that use of eaq causes the
"	temp to be stored.

round_dp_to_real:
	func		1

	if_optype		constant,round_dp_const
	push_temp		real
	load		deaq,op2
	return		eaq

round_dp_const:
	convert_constant	real
	return		op1

from_logical:
	error		309,arg1

from_char:
	error		310,arg1

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

convert_to_int:
	func		1

	dt_jump1		arg1,(to_int.int,to_int.real,to_int.dp,to_int.cmpx,from_logical,from_char,to_int.tl)

to_int.tl:
to_int.int:
	load		q,arg1
	return		q

to_int.real:
to_int.cmpx:
	s_call		cv_load.ri
	return		q

to_int.dp:
	s_call		cv_load.di
	return		q

convert_to_real:
	func		1

	dt_jump1		arg1,(to_real.int,to_real.real,to_real.dp,to_real.cmpx,from_logical,from_char)

to_real.int:
	s_call		cv_load.ir
	return		eaq

to_real.real:
	load		eaq,arg1
	return		eaq

to_real.dp:
	load		deaq,arg1
	return		eaq

to_real.cmpx:
	load		eaq,arg1
	return		eaq

convert_to_dp:
	func		1

	dt_jump1		arg1,(to_dp.int,to_dp.real,to_dp.dp,to_dp.cmpx,from_logical,from_char)

to_dp.int:
	s_call		cv_load.id
	return		deaq

to_dp.real:
	load		eaq,arg1
	return		deaq

to_dp.dp:
	load		deaq,arg1
	return		deaq

to_dp.cmpx:
	load		eaq,arg1
	return		deaq

convert_to_cmpx:
	func		1

	dt_jump1		arg1,(to_cmpx.int,to_cmpx.real,to_cmpx.dp,to_cmpx.cmpx,from_logical,from_char)

to_cmpx.int:
	push_output
	bump		op1
	fld		=0.0,du
	fst		op1+1
	swap		op2
	s_call		cv_load.ir
	return		eaq

to_cmpx.real:
	push_output
	bump		op1
	fld		=0.0,du
	fst		op1+1
	load		eaq,arg1
	return		eaq

to_cmpx.dp:
	push_output
	bump		op1
	fld		=0.0,du
	fst		op1+1
	load		deaq,arg1
	return		eaq

to_cmpx.cmpx:
	load		aq,arg1
	return		aq

exponentiation:
	func		2

	dt_jump		(exponentiation_ii,exponentiation_ri,exponentiation_di,exponentiation_ci,exponentiation_ir,exponentiation_rr,exponentiation_dr,exponentiation_cr,exponentiation_id,exponentiation_rd,exponentiation_dd,exponentiation_cd,exponentiation_ic,exponentiation_rc,exponentiation_dc,exponentiation_cc,exponentiation_e2,exponentiation_e1,exponentiation_e2,exponentiation_e1)

exponentiation_ii:
	push_temp		32

	load		q,arg1
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|int_p_int
	drop		arg2
	free_regs
	return		q

exponentiation_ir:
	push_temp		32

	swap		arg1

	s_call		cv_load.ir

	swap		arg1

	jump		exponentiation_rr.02

exponentiation_ri:
	push_temp		32

	load		eaq,arg1
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|real_p_int
	drop		arg2
	free_regs
	return		eaq

exponentiation_id:
	push_temp		32

	swap		arg1

	s_call		cv_load.id

	swap		arg1

	jump		exponentiation_dd.02

exponentiation_di:
	push_temp		32

	load		deaq,arg1
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|dbl_p_int
	drop		arg2
	free_regs
	return		deaq

exponentiation_rr:
	push_temp		32

	load		eaq,arg1
exponentiation_rr.02:
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|real_p_real
	drop		arg2
	free_regs
	return		eaq

exponentiation_dd:
	push_temp		32

	load		deaq,arg1
exponentiation_dd.02:
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|dbl_p_dbl
	drop		arg2
	free_regs
	return		deaq

exponentiation_rd:
	push_temp		32

	load		eaq,arg1
	jump		exponentiation_dd.02

exponentiation_dr:
	push_temp		32

	load		deaq,arg1
	bump		arg2
	load_pr		pr2,op1
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|dbl_p_real
	drop		arg2
	free_regs
	return		deaq

exponentiation_ic:
	push_temp		32
	load_pr		pr2,op1
	swap		arg1

	if_optype		constant,conv_exponentiation_ic

	swap		arg1
	push_output
	bump		op1,3		" temp becomes arg1 and is used 3 times
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_real
	store		eaq,op1,no_update
	fld		=0.,du
	fst		op1+1
	ldaq		op1
	jump		exponentiation_cc.01

conv_exponentiation_ic:
	convert_constant	cmpx

	swap		arg1
	load		aq,arg1
	jump		exponentiation_cc.01

exponentiation_ci:
	push_temp		32
	load_pr		pr2,op1
	push_output
	bump		op1,2		" temp is used at least twice

	swap		arg2

	if_optype		constant,conv_exponentiation_ci

	swap		arg2
	bump		op1,2		" conversion requires 2 more refs
	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real
	store		eaq,op1,no_update
	fld		=0.,du
	fst		op1+1
	jump		exponentiation_cr.01

conv_exponentiation_ci:
	convert_constant	cmpx

	swap		arg2
	load		aq,arg2
	staq		op1
	jump		exponentiation_cr.01

exponentiation_dc:
	swap		arg1
	call		round_dp_to_real
	swap		arg1

exponentiation_rc:
	push_temp		32
	load_pr		pr2,op1

	load		a,arg1
	ldq		=0.,du
	jump		exponentiation_cc.01

exponentiation_cd:
	call		round_dp_to_real

exponentiation_cr:
	push_temp		32
	load_pr		pr2,op1
	push_output
	bump		op1,2		" temp is used twice

	load		a,arg2
	ldq		=0.,du
	staq		op1
exponentiation_cr.01:
	ldaq		arg1
	bump		op1
	load_pr		pr1,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|cmpx_p_cmpx
	drop		op1
	ldaq		pr6|temp_pt
	free_regs
	return		aq

exponentiation_cc:
	push_temp		32
	load_pr		pr2,op1
	load		aq,arg1
exponentiation_cc.01:
	bump		arg2
	load_pr		pr1,arg2
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|cmpx_p_cmpx
	drop		arg2
	ldaq		pr6|temp_pt
	free_regs
	return		aq

exponentiation_e1:
	error		309,arg1

exponentiation_e2:
	error		310,arg2

negate:	func		1

	dt_jump1		op1,(negate_i,negate_r,negate_d,negate_c,negate_l,negate_h,negate_t)

negate_l:
negate_h:
	error		315,op1

negate_i:
negate_t:
	lcq		op1
	return		q

negate_r:
	load		eaq,op1
	emit_inst		1
	fneg
	return		eaq

negate_d:
	load		deaq,op1
	emit_inst		1
	fneg
	return		deaq

negate_c:
	push_output
	bump		op1
	bump		op2

	if_eaq		eaq,op2,negate_c.1

	load		ieaq,op2
	emit_inst		1
	fneg
	store		ieaq,op1,no_update
	load		eaq,op2
	emit_inst		1
	fneg
	in_reg		eaq,op1
	return		op1

negate_c.1:
	emit_inst		1
	fneg
	store		eaq,op1,no_update
	load		ieaq,op2
	emit_inst		1
	fneg
	in_reg		ieaq,op1
	return		op1

builtin:	func		2			last assigned number = 93
"
"	The builtin code depends on 3 indexed operators. Two uses are here. The other
"	appears in the cv_bif_to_external code. Remember to change ALL three.
"

	push_bif_index	arg1
	push_count_indexed	arg3,(1,1,1,1,1,1,1,1,1,1,1,2,2,1,1,1,2,2,2,1,1,1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,-1,1,1,1,1,1,1,1,1,1,2,1,2,2,2,2,1,1,1,1,1,1,1,1,1,1,2,-1,1,1,3,2,2,2,2,-1,-1)

	if		arg4,<,0,builtin_var
	if		arg2,=,op1,builtin2

wrong_number.p:
	error		319,arg1

builtin_var:
builtin2:
	push_operand	builtin3
	jump		builtin2

builtin3:
	jump_indexed	arg3,(abs,iabs,dabs,cabs,alog,dlog,clog,alog10,dlog10,atan,datan,atan2,datan2,cos,dcos,ccos,dim,idim,ddim,exp,dexp,cexp,max,amax0,amax1,max0,max1,dmax1,min,amin0,amin1,min0,min1,dmin1,mod,amod,dmod,sign,isign,dsign,sin,dsin,csin,sqrt,dsqrt,csqrt,tanh,int_builtin,aint,idint,float,ifix,sngl,real_builtin,aimag,dble,cmplx,conjg,tan,dtan,asin,dasin,acos,dacos,char_builtin,ichar,index,len,lge,lgt,lle,llt,cosh,sinh,dcosh,dsinh,dtanh,dint,anint,dnint,nint,idnint,dprod,and.tl,bool.tl,compl.tl,fld.tl,ilr.tl,ils.tl,irl.tl,irs.tl,or.tl,xor.tl)

mm_ret_q:
	push_output
	in_reg		q,op1
	use_ind
	return		op1

mm_ret_eaq:
	push_output
	in_reg		eaq,op1
	use_ind
	return		op1

mm_ret_deaq:
	push_output
	in_reg		deaq,op1
	use_ind
	return		op1

mm_ret_tq:
	push_output
	in_reg		tq,op1
	return		op1

wrong_type.p:
	error		320,arg1,op1

abs:						" builtin 01
	dt_jump1		op1,(iabs.1,abs.1,dabs.1,cabs.1,wrong_type.p,wrong_type.p,wrong_type.p)

iabs:						" builtin 02
	unless_dt		int,iabs.p
iabs.1:
	load_for_test	q,arg5
	use_eaq		protect_indicators		" save all temps before transfer
	tpl		3,ic
	erq		pr0|all_ones
	adq		1,dl
	return		q

abs.1:
	load_for_test	eaq,arg5
	use_eaq		protect_indicators		" save all temps before transfer
	tpl		2,ic
	emit_inst		1
	fneg
	return		eaq

dabs:						" builtin 03
	unless_dt		dp,dabs.p
dabs.1:
	load_for_test	deaq,arg5
	use_eaq		protect_indicators		" save all temps before transfer
	tpl		2,ic
	emit_inst		1
	fneg
	return		deaq

cabs:						" builtin 04
	unless_dt		cmpx,cabs.p
cabs.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|cabs_
	fld		pr6|temp_pt
	free_regs
	return		eaq

iabs.p:
	jump		bu_dt5.p

dabs.p:
	jump		bu_dt5.p

cabs.p:
	jump		bu_dt5.p

alog:						" builtin 05
	dt_jump1		op1,(alog_i,alog.1,dlog.1,clog.1,wrong_type.p,wrong_type.p,wrong_type.p)

alog.1:
	load		eaq,arg5
	jump		alog.2

alog_i:
	s_call		cv_load.ir

alog.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|log_
	free_regs
	return		eaq

dlog:						" builtin 06
	unless_dt		dp,bu_dt5.p
dlog.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dlog_
	free_regs
	return		deaq

clog:						" builtin 07
	unless_dt		cmpx,bu_dt5.p
clog.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|clog_
	ldaq		pr6|temp_pt
	free_regs
	return		aq

alog10:						" builtin 08
	dt_jump1		op1,(alog10_i,alog10.1,dlog10.1,bu_dt5.p,wrong_type.p,wrong_type.p,wrong_type.p)

alog10.1:
	load		eaq,arg5
	jump		alog10.2

alog10_i:
	s_call		cv_load.ir

alog10.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|alog10_
	free_regs
	return		eaq

dlog10:						" builtin 09
	unless_dt		dp,bu_dt5.p
dlog10.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dlog10_
	free_regs
	return		deaq

atan:						" builtin 10
	dt_jump1		op1,(atan_i,atan.1,datan.1,bu_dt5.p,wrong_type.p,wrong_type.p,wrong_type.p)

atan.1:
	load		eaq,arg5
	jump		atan.2

atan_i:
	s_call		cv_load.ir

atan.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|atan_
	free_regs
	return		eaq

datan:						" builtin 11
	unless_dt		dp,bu_dt5.p
datan.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|datan_
	free_regs
	return		deaq

atan2:						" builtin 12
	dt_jump		(atan2_ii,atan2_ri,atan2_di,atan2_ci,atan2_ir,atan2_rr,atan2_dr,atan2_cr,atan2_id,atan2_rd,atan2_dd,atan2_cd,atan2_ic,atan2_rc,atan2_dc,atan2_cc,atan2_e2,atan2_e1,atan2_e2,atan2_e1)

atan2_ii:
	s_call		builtin_2args_ii
	jump		atan2.1

atan2_ir:
	s_call		builtin_2args_ir
	jump		atan2.1

atan2_ri:
	s_call		builtin_2args_ri
	jump		atan2.1

atan2_id:
	s_call		builtin_2args_id
	jump		datan2.1

atan2_di:
	s_call		builtin_2args_di
	jump		datan2.1

atan2_rr:
	jump		atan2.1

atan2_dd:
	jump		datan2.1

atan2_rd:
	load		eaq,arg5
	push_temp		32
	load_pr		pr2,op1
	bump		arg6
	load_pr		pr1,arg6
	jump		datan2.2

atan2_dr:
	push_temp		dp
	load		eaq,arg6
	store		deaq,op1,no_update
	swap		arg6
	pop		op1
	jump		datan2.1

atan2_ic:
	jump		bu_dt6.p

atan2_ci:
	jump		bu_dt5.p

atan2_rc:
	jump		bu_dt6.p

atan2_cr:
	jump		bu_dt5.p

atan2_dc:
	jump		bu_dt6.p

atan2_cd:
	jump		bu_dt5.p

atan2_cc:
	jump		bu_dt5.p

atan2_e1:
	jump		bu_dt5.p

atan2_e2:
	jump		bu_dt6.p

atan2.1:
	load		eaq,arg5
	push_temp		32
	load_pr		pr2,op1
	bump		arg6
	load_pr		pr1,arg6
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|atan2_
	drop		arg6
	free_regs
	return		eaq

datan2:						" builtin 13
	swap		arg5
	unless_dt		dp,atan2.p
	swap		arg5
	unless_dt		dp,atan2_ee

datan2.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	bump		arg6
	load_pr		pr1,arg6
datan2.2:
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr3,pr4,pr5,pr7)
	tsp3		pr0|datan2_
	drop		arg6
	free_regs
	return		deaq

atan2.p:
atan2_ee:
	jump		bu_dt6.p

cos:						" builtin 14
	dt_jump1		op1,(cos_i,cos.1,dcos.1,ccos.1,wrong_type.p,wrong_type.p,wrong_type.p)

cos.1:
	load		eaq,arg5
	jump		cos.2

cos_i:
	s_call		cv_load.ir

cos.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|cos_
	free_regs
	return		eaq

dcos:						" builtin 15
	unless_dt		dp,dcos.p
dcos.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dcos_
	free_regs
	return		deaq

ccos:						" builtin 16
	unless_dt		cmpx,ccos.p
ccos.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|ccos_
	ldaq		pr6|temp_pt
	free_regs
	return		aq

dcos.p:
	jump		bu_dt5.p

ccos.p:
	jump		bu_dt5.p

dim:						" builtin 17
	dt_jump		(dim_ii,dim_ri,dim_di,dim_ci,dim_ir,dim_rr,dim_dr,dim_cr,dim_id,dim_rd,dim_dd,dim_cd,dim_ic,dim_rc,dim_dc,dim_cc,dim_e2,dim_e1,dim_e2,dim_e1)

idim:						" builtin 18
	swap		arg5
	unless_dt		int,idim.p
	swap		arg5
	unless_dt		int,idim.p

dim_ii:
	push_temp		int
	bump		op1		" temp is freed after 2nd ref
	bump		arg5
	bump		arg6

	load		q,arg5
	use_eaq
	make_addressable	arg5,arg6
	compare		q,arg6
	tmi		2,ic
	ldq		arg6
	stq		op1
	ldq		arg5
	sbq		op1
	return		q

dim_ir:
	s_call		builtin_2args_ir
	jump		dim.1

dim_ri:
	s_call		builtin_2args_ri
	jump		dim.1

dim_id:
	s_call		builtin_2args_id
	jump		ddim.1

dim_di:
	s_call		builtin_2args_di
	jump		ddim.1

dim_rr:
	jump		dim.1

dim_dd:
	jump		ddim.1

dim_rd:
	jump		rddim.1

dim_dr:
	jump		drdim.1

dim_ic:
	jump		bu_dt6.p

dim_ci:
	jump		bu_dt5.p

dim_rc:
	jump		bu_dt6.p

dim_cr:
	jump		bu_dt5.p

dim_dc:
	jump		bu_dt6.p

dim_cd:
	jump		bu_dt5.p

dim_cc:
	jump		bu_dt5.p

dim_e1:
	jump		bu_dt5.p

dim_e2:
	jump		bu_dt6.p

dim.1:
	bump		arg5
	bump		arg6
	load		eaq,arg5
	make_addressable	arg5,arg6
	compare		eaq,arg6		"saves arg5, if necessary
	tmi		2,ic
	fld		arg6
	emit_inst		1
	fneg
	fad		arg5
	return		eaq

ddim:						" builtin 19
	swap		arg5
	unless_dt		dp,ddim.p
	swap		arg5
	unless_dt		dp,ddim.p

ddim.1:
	bump		arg5
	bump		arg6
	load		deaq,arg5
	make_addressable	arg5,arg6
	compare		deaq,arg6		"saves arg5, if necessary
	tmi		2,ic
	dfld		arg6
	emit_inst		1
	fneg
	dfad		arg5
	return		deaq

rddim.1:
	bump		arg5
	bump		arg6
	load		eaq,arg5
	make_addressable	arg5,arg6
	compare		deaq,arg6		"saves arg5, if necessary
	tmi		2,ic
	dfld		arg6
	emit_inst		1
	fneg
	fad		arg5
	return		deaq

drdim.1:
	bump		arg5
	bump		arg6
	load		deaq,arg5
	make_addressable	arg5,arg6
	compare		eaq,arg6		"saves arg5, if necessary
	tmi		2,ic
	fld		arg6
	emit_inst		1
	fneg
	dfad		arg5
	return		deaq

idim.p:
ddim.p:
	jump		bu_dt6.p

exp:						" builtin 20
	dt_jump1		op1,(exp_i,exp.1,dexp.1,cexp.1,wrong_type.p,wrong_type.p)

exp.1:
	load		eaq,arg5
	jump		exp.2

exp_i:
	s_call		cv_load.ir

exp.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|exp_
	free_regs
	return		eaq

dexp:						" builtin 21
	unless_dt		dp,dexp.p

dexp.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dexp_
	free_regs
	return		deaq

cexp:						" builtin 22
	unless_dt		cmpx,cexp.p

cexp.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|cexp_
	ldaq		pr6|temp_pt
	free_regs
	return		aq

dexp.p:
	jump		bu_dt5.p

cexp.p:
	jump		bu_dt5.p

max:						" builtin 23
	unless		arg2,>,1,wrong_number.p
	dt_jump		(max_ii,max_ri,max_di,max_ci,max_ir,max_rr,max_dr,max_cr,max_id,max_rd,max_dd,max_cd,max_ic,max_rc,max_dc,max_cc,max_e2,max_e1,max_e2,max_e1)

max_ii:
	jump		g.max0

max_ir:
	s_call		builtin_2args_ir
	jump		g.amax1

max_ri:
	s_call		builtin_2args_ri
	jump		g.amax1

max_id:
	s_call		builtin_2args_id
	jump		g.dmax1

max_di:
	s_call		builtin_2args_di
	jump		g.dmax1

max_rr:
	jump		g.amax1

max_dd:
	jump		g.dmax1

max_rd:
	swap		op2
	load		eaq,op1
	pop		op1
	unless		arg2,>,2,g.dmax1.loop.1
	round		deaq
	jump		g.dmax1.loop.1

max_dr:
	swap		op2
	jump		max_rd

max_ic:
	jump		mm_dt1.p

max_ci:
	jump		mm_dt2.p

max_rc:
	jump		mm_dt1.p

max_cr:
	jump		mm_dt2.p

max_dc:
	jump		mm_dt1.p

max_cd:
	jump		mm_dt2.p

max_cc:
	jump		mm_dt1.p

max_e1:
	jump		mm_dt2.p

max_e2:
	jump		mm_dt1.p

g.max0:
	load_top		q
	pop		op1
	jump		g.max0.loop.1

g.max0.loop:
	use_eaq				" save temps before test and transfer
	dt_jump1		op1,(g.max0.loop.1,g.max0.real,g.max0.dp,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.max0.real:
	s_call		cv_q_to_real
	jump		g.amax1.loop.1

g.max0.dp:
	s_call		cv_q_to_dp
	jump		g.dmax1.loop.1

g.max0.loop.1:
	bump		op1		" because it is ref'd twice
	compare		q,op1
	tpl		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_q
	decrement		arg2,1
	jump		g.max0.loop

g.amax1:
	load_top		eaq
	pop		op1
	unless		arg2,>,2,g.amax1.loop.1
	round		eaq
	jump		g.amax1.loop.1

g.amax1.loop:
	use_eaq				" save temps before test and transfer
	set_rounded
	dt_jump1		op1,(g.amax1.int,g.amax1.loop.1,g.amax1.dp,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.amax1.int:
	push_temp		real
	bump		op1
	store		eaq,op1,no_update
	swap		op2
	s_call		cv_load.ir
	pop		op1		" remove int and use real temp
	jump		g.amax1.loop.1

g.amax1.dp:
	jump		g.dmax1.loop.1

g.amax1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tpl		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_eaq
	decrement		arg2,1
	jump		g.amax1.loop

g.dmax1:
	load_top		deaq
	pop		op1
	unless		arg2,>,2,g.dmax1.loop.1
	round		deaq
	jump		g.dmax1.loop.1

g.dmax1.loop:
	use_eaq				" save temps before test and transfer
	set_rounded
	dt_jump1		op1,(g.dmax1.int,g.dmax1.real,g.dmax1.loop.1,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.dmax1.int:
	push_temp		dp
	bump		op1
	store		deaq,op1,no_update
	swap		op2
	s_call		cv_load.id
	pop		op1		" remove int and use dp temp
	jump		g.dmax1.loop.1

g.dmax1.real:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tpl		2,ic
	fld		op1
	jump		g.dmax1.loop.2

g.dmax1.loop.1:
	bump		op1
	compare		deaq,op1
	tpl		2,ic
	dfld		op1

g.dmax1.loop.2:
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_deaq
	decrement		arg2,1
	jump		g.dmax1.loop

amax0:						" builtin 24
	unless		arg2,>,1,wrong_number.p
	unless_dt		int,amax0.p
	swap		op2
	unless_dt		int,amax0.p

	load_top		q
	pop		op1

amax0.loop:
	bump		op1		" because it is ref'd twice
	use_eaq				" save temps before test and transfer
	compare		q,op1
	tpl		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,amax0.r
	decrement		arg2,1
	if_dt		int,amax0.loop
	jump		amax0.p

amax0.r:
	s_call		cv_q_to_real
	jump		mm_ret_eaq

amax0.p:
	jump		mm_dt1.p

amax1:						" builtin 25
	unless		arg2,>,1,wrong_number.p
	unless_dt		real,amax1.p
	swap		op2
	unless_dt		real,amax1.p

	load_top		eaq
	pop		op1
	unless		arg2,>,2,amax1.loop.1
	round		eaq
	jump		amax1.loop.1

amax1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

amax1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tpl		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_eaq
	decrement		arg2,1
	if_dt		real,amax1.loop

amax1.p:
	jump		mm_dt1.p

max0:						" builtin 26
	unless		arg2,>,1,wrong_number.p
	unless_dt		int,max0.p
	swap		op2
	unless_dt		int,max0.p

	load_top		q
	pop		op1

max0.loop:
	bump		op1		" because it is ref'd twice
	use_eaq				" save temps before test and transfer
	compare		q,op1
	tpl		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_q
	decrement		arg2,1
	if_dt		int,max0.loop

max0.p:
	jump		mm_dt1.p

max1:						" builtin 27
	unless		arg2,>,1,wrong_number.p
	unless_dt		real,max1.p
	swap		op2
	unless_dt		real,max1.p

	load_top		eaq
	pop		op1
	unless		arg2,>,2,max1.loop.1
	round		eaq
	jump		max1.loop.1

max1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

max1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tpl		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,max1.r
	decrement		arg2,1
	if_dt		real,max1.loop
	jump		max1.p

max1.r:
	use_ind
	round		eaq
	s_call		cv_real_to_int
	jump		mm_ret_q

max1.p:
	jump		mm_dt1.p

dmax1:						" builtin 28
	unless		arg2,>,1,wrong_number.p
	unless_dt		dp,dmax1.p
	swap		op2
	unless_dt		dp,dmax1.p

	load_top		deaq
	pop		op1
	unless		arg2,>,2,dmax1.loop.1
	round		deaq
	jump		dmax1.loop.1

dmax1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

dmax1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		deaq,op1
	tpl		2,ic
	dfld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_deaq
	decrement		arg2,1
	if_dt		dp,dmax1.loop

dmax1.p:
	jump		mm_dt1.p

min:						" builtin 29
	unless		arg2,>,1,wrong_number.p
	dt_jump		(min_ii,min_ri,min_di,min_ci,min_ir,min_rr,min_dr,min_cr,min_id,min_rd,min_dd,min_cd,min_ic,min_rc,min_dc,min_cc,min_e2,min_e1,min_e2,min_e1)

min_ii:
	jump		g.min0

min_ir:
	s_call		builtin_2args_ir
	jump		g.amin1

min_ri:
	s_call		builtin_2args_ri
	jump		g.amin1

min_id:
	s_call		builtin_2args_id
	jump		g.dmin1

min_di:
	s_call		builtin_2args_di
	jump		g.dmin1

min_rr:
	jump		g.amin1

min_dd:
	jump		g.dmin1

min_rd:
	swap		op2
	load		eaq,op1
	pop		op1
	unless		arg2,>,2,g.dmin1.loop.1
	round		deaq
	jump		g.dmin1.loop.1

min_dr:
	swap		op2
	jump		min_rd

min_ic:
	jump		mm_dt1.p

min_ci:
	jump		mm_dt2.p

min_rc:
	jump		mm_dt1.p

min_cr:
	jump		mm_dt2.p

min_dc:
	jump		mm_dt1.p

min_cd:
	jump		mm_dt2.p

min_cc:
	jump		mm_dt1.p

min_e1:
	jump		mm_dt2.p

min_e2:
	jump		mm_dt1.p

g.min0:
	load_top		q
	pop		op1
	jump		g.min0.loop.1

g.min0.loop:
	use_eaq				" save temps before test and transfer
	dt_jump1		op1,(g.min0.loop.1,g.min0.real,g.min0.dp,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.min0.real:
	s_call		cv_q_to_real
	jump		g.amin1.loop.1

g.min0.dp:
	s_call		cv_q_to_dp
	jump		g.dmin1.loop.1

g.min0.loop.1:
	bump		op1		" because it is ref'd twice
	compare		q,op1
	tmoz		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_q
	decrement		arg2,1
	jump		g.min0.loop

g.amin1:
	load_top		eaq
	pop		op1
	unless		arg2,>,2,g.amin1.loop.1
	round		eaq
	jump		g.amin1.loop.1

g.amin1.loop:
	use_eaq				" save temps before test and transfer
	set_rounded
	dt_jump1		op1,(g.amin1.int,g.amin1.loop.1,g.amin1.dp,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.amin1.int:
	push_temp		real
	bump		op1
	store		eaq,op1,no_update
	swap		op2
	s_call		cv_load.ir
	pop		op1		" remove int and use real temp
	jump		g.amin1.loop.1

g.amin1.dp:
	jump		g.dmin1.loop.1

g.amin1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tmoz		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_eaq
	decrement		arg2,1
	jump		g.amin1.loop

g.dmin1:
	load_top		deaq
	pop		op1
	unless		arg2,>,2,g.dmin1.loop.1
	round		deaq
	jump		g.dmin1.loop.1

g.dmin1.loop:
	use_eaq				" save temps before test and transfer
	set_rounded
	dt_jump1		op1,(g.dmin1.int,g.dmin1.real,g.dmin1.loop.1,mm_dt1.p,wrong_type.p,wrong_type.p,wrong_type.p)

g.dmin1.int:
	push_temp		dp
	bump		op1
	store		deaq,op1,no_update
	swap		op2
	s_call		cv_load.id
	pop		op1		" remove int and use dp temp
	jump		g.dmin1.loop.1

g.dmin1.real:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tmoz		2,ic
	fld		op1
	jump		g.dmin1.loop.2

g.dmin1.loop.1:
	bump		op1
	compare		deaq,op1
	tmoz		2,ic
	dfld		op1

g.dmin1.loop.2:
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_deaq
	decrement		arg2,1
	jump		g.dmin1.loop

amin0:						" builtin 30
	unless		arg2,>,1,wrong_number.p
	unless_dt		int,amin0.p
	swap		op2
	unless_dt		int,amin0.p

	load_top		q
	pop		op1

amin0.loop:
	bump		op1		" because it is ref'd twice
	use_eaq				" save temps before test and transfer
	compare		q,op1
	tmoz		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,amin0.r

	decrement		arg2,1
	if_dt		int,amin0.loop
	jump		amin0.p

amin0.r:
	s_call		cv_q_to_real
	jump		mm_ret_eaq

amin0.p:
	jump		mm_dt1.p

amin1:						" builtin 31
	unless		arg2,>,1,wrong_number.p
	unless_dt		real,amin1.p
	swap		op2
	unless_dt		real,amin1.p

	load_top		eaq
	pop		op1
	unless		arg2,>,2,amin1.loop.1
	round		eaq
	jump		amin1.loop.1

amin1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

amin1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tmoz		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_eaq
	decrement		arg2,1
	if_dt		real,amin1.loop

amin1.p:
	jump		mm_dt1.p

min0:						" builtin 32
	unless		arg2,>,1,wrong_number.p
	unless_dt		int,min0.p
	swap		op2
	unless_dt		int,min0.p

	load_top		q
	pop		op1

min0.loop:
	bump		op1		" because it is ref'd twice
	use_eaq				" save temps before test and transfer
	compare		q,op1
	tmoz		2,ic
	ldq		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_q
	decrement		arg2,1
	if_dt		int,min0.loop

min0.p:
	jump		mm_dt1.p

min1:						" builtin 33
	unless		arg2,>,1,wrong_number.p
	unless_dt		real,min1.p
	swap		op2
	unless_dt		real,min1.p

	load_top		eaq
	pop		op1
	unless		arg2,>,2,min1.loop.1
	round		eaq
	jump		min1.loop.1

min1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

min1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		eaq,op1
	tmoz		2,ic
	fld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,min1.r
	decrement		arg2,1
	if_dt		real,min1.loop
	jump		min1.p

min1.r:
	use_ind
	round		eaq
	s_call		cv_real_to_int
	jump		mm_ret_q

min1.p:
	jump		mm_dt1.p

dmin1:						" builtin 34
	unless		arg2,>,1,wrong_number.p
	unless_dt		dp,dmin1.p
	swap		op2
	unless_dt		dp,dmin1.p

	load_top		deaq
	pop		op1
	unless		arg2,>,2,dmin1.loop.1
	round		deaq
	jump		dmin1.loop.1

dmin1.loop:
	use_eaq				"save temps before test and transfer
	set_rounded

dmin1.loop.1:
	bump		op1		" because it is ref'd twice
	compare		deaq,op1
	tmoz		2,ic
	dfld		op1
	pop		op1
	use_ind				" invalidate indicators

	if		arg2,=,2,mm_ret_deaq
	decrement		arg2,1
	if_dt		dp,dmin1.loop

dmin1.p:
	jump		mm_dt1.p

mod:						" builtin 35
	dt_jump		(mod_ii,mod_ri,mod_di,mod_ci,mod_ir,mod_rr,mod_dr,mod_cr,mod_id,mod_rd,mod_dd,mod_cd,mod_ic,mod_rc,mod_dc,mod_cc,mod_e2,mod_e1,mod_e2,mod_e1)

mod_ii:
	jump		mod.1

mod_ir:
	s_call		builtin_2args_ir
	jump		amod.1

mod_ri:
	s_call		builtin_2args_ri
	jump		amod.1

mod_id:
	s_call		builtin_2args_id
	jump		dmod.1

mod_di:
	s_call		builtin_2args_di
	jump		dmod.1

mod_rr:
	jump		amod.1

mod_dd:
	jump		dmod.1

mod_rd:
	jump		rdmod.1

mod_dr:
	jump		dmod.1

mod_ic:
	jump		bu_dt6.p

mod_ci:
	jump		bu_dt5.p

mod_rc:
	jump		bu_dt6.p

mod_cr:
	jump		bu_dt5.p

mod_dc:
	jump		bu_dt6.p

mod_cd:
	jump		bu_dt5.p

mod_cc:
	jump		bu_dt5.p

mod_e1:
	jump		bu_dt5.p

mod_e2:
	jump		bu_dt6.p

mod.1:
	load		q,arg5
	div		arg6
	emit_inst		1
	lrs		36
	return		q

amod:						" builtin 36
	swap		arg5
	unless_dt		real,amod.p
	swap		arg5
	unless_dt		real,amod.p

amod.1:
	load		eaq,arg5
	bump		arg6
	load_pr		pr2,arg6
	use_eaq
	tsx0		pr0|fort_modfl
	drop		arg6
	free_regs
	return		eaq

dmod:						" builtin 37
	swap		arg5
	unless_dt		dp,dmod.p
	swap		arg5
	unless_dt		dp,dmod.p

dmod.1:
	load		deaq,arg5
dmod.2:
	use_eaq
	bump		arg6
	load_pr		pr2,arg6
	tsx0		pr0|fort_dmod
	drop		arg6
	free_regs
	return		deaq

rdmod.1:
	load		eaq,arg5
	jump		dmod.2

amod.p:
dmod.p:
	jump		bu_dt6.p

sign:						" builtin 38
	dt_jump		(sign_ii,sign_ri,sign_di,sign_ci,sign_ir,sign_rr,sign_dr,sign_cr,sign_id,sign_rd,sign_dd,sign_cd,sign_ic,sign_rc,sign_dc,sign_cc,sign_e2,sign_e1,sign_e2,sign_e1)

isign:						" builtin 39
	swap		arg5
	unless_dt		int,isign.p
	swap		arg5
	unless_dt		int,isign.p

sign_ii:
	bump		arg6
	load_pr		pr2,arg6
	load_for_test	q,arg5
	use_eaq		protect_indicators
	tsx0		pr0|sign_fx
	drop		arg6
	free_regs
	return		q

sign_ir:
	s_call		builtin_2args_ir
	jump		sign.1

sign_ri:
	s_call		builtin_2args_ri
	jump		sign.1

sign_id:
	s_call		builtin_2args_id
	jump		dsign.1

sign_di:
	s_call		builtin_2args_di
	jump		dsign.1

sign_rr:
	jump		sign.1

sign_dd:
	jump		dsign.1

sign_rd:
	jump		rdsign.1

sign_dr:
	jump		dsign.1

sign_ic:
	jump		bu_dt6.p

sign_ci:
	jump		bu_dt5.p

sign_rc:
	jump		bu_dt6.p

sign_cr:
	jump		bu_dt5.p

sign_dc:
	jump		bu_dt6.p

sign_cd:
	jump		bu_dt5.p

sign_cc:
	jump		bu_dt5.p

sign_e1:
	jump		bu_dt5.p

sign_e2:
	jump		bu_dt6.p

sign.1:
	bump		arg6
	load_pr		pr2,arg6
	load_for_test	eaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|sign_fl
	drop		arg6
	free_regs
	return		eaq

dsign:						" builtin 40
	swap		arg5
	unless_dt		dp,dsign.p
	swap		arg5
	unless_dt		dp,dsign.p

dsign.1:
	bump		arg6
	load_pr		pr2,arg6
	load_for_test	deaq,arg5
dsign.2:
	use_eaq		protect_indicators
	tsx0		pr0|sign_fl
	drop		arg6
	free_regs
	return		deaq

rdsign.1:
	bump		arg6
	load_pr		pr2,arg6
	load_for_test	eaq,arg5
	jump		dsign.2

isign.p:
dsign.p:
	jump		bu_dt6.p

builtin_2args_ii:
	swap		op2

	if_optype		constant,conv_bu_ii.1

	push_temp		real

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_real
	in_reg		eaq,op1
	swap		op2
	pop		op1
	swap		op2
	jump		builtin_2args_ii.1

conv_bu_ii.1:
	convert_constant	real

	swap		op2

builtin_2args_ii.1:
	if_optype		constant,conv_bu_ii.2

	push_temp		real

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_real
	in_reg		eaq,op1
	swap		op2
	pop		op1
	s_return

conv_bu_ii.2:
	convert_constant	real

	s_return

builtin_2args_ir:
	swap		op2

	if_optype		constant,conv_bu_ir

	push_temp		real

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_real
	in_reg		eaq,op1
	swap		op2
	pop		op1
	swap		op2
	s_return

conv_bu_ir:
	convert_constant	real

	swap		op2
	s_return

builtin_2args_ri:
	if_optype		constant,conv_bu_ri

	push_temp		real

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_real
	in_reg		eaq,op1
	swap		op2
	pop		op1
	s_return

conv_bu_ri:
	convert_constant	real

	s_return

builtin_2args_id:
	swap		op2

	if_optype		constant,conv_bu_id

	push_temp		dp

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_double
	in_reg		deaq,op1
	swap		op2
	pop		op1
	swap		op2
	s_return

conv_bu_id:
	convert_constant	dp

	swap		op2
	s_return

builtin_2args_di:
	if_optype		constant,conv_bu_di

	push_temp		dp

	load		q,op2
	use_eaq
	tsx0		pr0|integer_to_double
	in_reg		deaq,op1
	swap		op2
	pop		op1
	s_return

conv_bu_di:
	convert_constant	dp

	s_return

sin:						" builtin 41
	dt_jump1		op1,(sin_i,sin.1,dsin.1,csin.1,wrong_type.p,wrong_type.p,wrong_type.p)

sin.1:
	load		eaq,arg5
	jump		sin.2

sin_i:
	s_call		cv_load.ir

sin.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|sin_
	free_regs
	return		eaq

dsin:						" builtin 42
	unless_dt		dp,dsin.p
dsin.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dsin_
	free_regs
	return		deaq

csin:						" builtin 43
	unless_dt		cmpx,csin.p
csin.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|csin_
	ldaq		pr6|temp_pt
	free_regs
	return		aq

dsin.p:
csin.p:
	jump		bu_dt5.p

sqrt:						" builtin 44
	dt_jump1  	op1,(sqrt_i,sqrt.1,dsqrt.1,csqrt.1,wrong_type.p,wrong_type.p,wrong_type.p)

sqrt.1:
	load		eaq,arg5
	jump		sqrt.2

sqrt_i:
	s_call		cv_load.ir

sqrt.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|sqrt_
	free_regs
	return		eaq

dsqrt:						" builtin 45
	unless_dt		dp,dsqrt.p
dsqrt.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dsqrt_
	free_regs
	return		deaq

csqrt:						" builtin 46
	unless_dt		cmpx,csqrt.p
csqrt.1:
	load		aq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|csqrt_
	ldaq		pr6|temp_pt
	free_regs
	return		aq

dsqrt.p:
csqrt.p:
	jump		bu_dt5.p

tanh:						" builtin 47
	dt_jump1		arg5,(tanh.int,tanh.real,tanh.dp,tanh.p,tanh.p,tanh.p,tanh.p)

tanh.int:
	s_call		cv_load.ir
	jump		tanh.1

tanh.real:
	load		eaq,arg5

tanh.1:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|tanh_
	fld		pr6|temp_pt
	free_regs
	return		eaq

tanh.dp:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dtanh_
	dfld		pr6|temp_pt
	free_regs
	return		deaq


dtanh:						" builtin 77
	unless_dt		dp,dtanh.p
	jump		tanh.dp


tanh.p:
dtanh.p:
	jump		bu_dt5.p

sinh:						" builtin 74
	dt_jump1		arg5,(sinh.int,sinh.real,sinh.dp,sinh.p,sinh.p,sinh.p,sinh.p)

sinh.int:
	s_call		cv_load.ir
	jump		sinh.1

sinh.real:
	load		eaq,arg5

sinh.1:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|sinh_
	fld		pr6|temp_pt
	free_regs
	return		eaq

sinh.dp:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dsinh_
	dfld		pr6|temp_pt
	free_regs
	return		deaq


dsinh:						" builtin 76
	unless_dt		dp,dsinh.p
	jump		sinh.dp


sinh.p:
dsinh.p:
	jump		bu_dt5.p

cosh:						" builtin 73
	dt_jump1		arg5,(cosh.int,cosh.real,cosh.dp,cosh.p,cosh.p,cosh.p,cosh.p)

cosh.int:
	s_call		cv_load.ir
	jump		cosh.1

cosh.real:
	load		eaq,arg5

cosh.1:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|cosh_
	fld		pr6|temp_pt
	free_regs
	return		eaq

cosh.dp:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dcosh_
	dfld		pr6|temp_pt
	free_regs
	return		deaq


dcosh:						" builtin 75
	unless_dt		dp,dcosh.p
	jump		cosh.dp


cosh.p:
dcosh.p:
	jump		bu_dt5.p

int_builtin:					" builtin 48
	dt_jump1		arg5,(int_builtin.int,int_builtin.real,int_builtin.dp,int_builtin.cmpx,int.p,int.p,int_builtin.tl)

int_builtin.int:
	load		q,arg5
	return		q

int_builtin.real:
	s_call		cv_load.ri
	return		q

int_builtin.dp:
	s_call		cv_load.di
	return		q

int_builtin.cmpx:
	s_call		cv_load.ri
	return		q

int_builtin.tl:
	load		q,arg5
	return		q


ifix:						" builtin 52
	unless_dt		real,ifix.p
	jump		int_builtin.real


idint:						" builtin 50
	unless_dt		dp,idint.p
	jump		int_builtin.dp


int.p:
ifix.p:
idint.p:
	jump		bu_dt5.p

aint:						" builtin 49
	dt_jump1		arg5,(aint.int,aint.real,aint.dp,aint.p,aint.p,aint.p,aint.p)

aint.int:
	s_call		cv_load.ir
	return		eaq

aint.real:
	load_for_test	eaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|trunc_fl
	return		eaq

aint.dp:
	load_for_test	deaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|trunc_fl
	return		deaq


dint:						" builtin 78
	unless_dt		dp,dint.p
	jump		aint.dp


aint.p:
dint.p:
	jump		bu_dt5.p

anint:						" builtin 79
	dt_jump1		arg5,(anint.int,anint.real,anint.dp,anint.p,anint.p,anint.p,anint.p)

anint.int:
	s_call		cv_load.ir
	return		eaq

anint.real:
	load_for_test	eaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|nearest_whole_number
	return		eaq

anint.dp:
	load_for_test	deaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|nearest_whole_number
	return		deaq


dnint:						" builtin 80
	unless_dt		dp,dnint.p
	jump		anint.dp


anint.p:
dnint.p:
	jump		bu_dt5.p

nint:						" builtin 81
	dt_jump1		arg5,(nint.int,nint.real,nint.dp,nint.p,nint.p,nint.p,nint.p)

nint.int:
	load		q,arg5
	return		q

nint.real:
	load_for_test	eaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|nearest_integer
	return		q

nint.dp:
	load_for_test	deaq,arg5
	use_eaq		protect_indicators
	tsx0		pr0|nearest_integer
	return		q


idnint:						" builtin 82
	unless_dt		dp,idnint.p
	jump		nint.dp


nint.p:
idnint.p:
	jump		bu_dt5.p

real_builtin:					" builtin 54
	dt_jump1		arg5,(real_builtin.int,real_builtin.real,real_builtin.dp,real_builtin.cmpx,real.p,real.p,real.p)

real_builtin.int:
	s_call		cv_load.ir
	return		eaq

real_builtin.real:
	load		eaq,arg5
	return		eaq

real_builtin.dp:
	load		deaq,arg5
	emit_inst		1
	frd		0
	return		eaq

real_builtin.cmpx:
	load		eaq,arg5
	return		eaq


float:						" builtin 51
	unless_dt		int,float.p
	jump		real_builtin.int


sngl:						" builtin 53
	unless_dt		dp,sngl.p
	jump		real_builtin.dp


real.p:
float.p:
sngl.p:
	jump		bu_dt5.p

aimag:						" builtin 55
	unless_dt		cmpx,aimag.p

	load		ieaq,arg5
	return		eaq

aimag.p:
	jump		bu_dt5.p

dble:						" builtin 56
	dt_jump1		arg5,(dble.int,dble.real,dble.dp,dble.cmpx,dble.p,dble.p,dble.p)

dble.int:
	s_call		cv_load.id
	return		deaq

dble.real:
	load		eaq,arg5
	return		deaq

dble.dp:
	load		deaq,arg5
	return		deaq

dble.cmpx:
	load		eaq,arg5
	return		deaq

dble.p:
	jump		bu_dt5.p

cmplx:						" builtin 57
	if		arg2,=,1,cmplx.one
	if		arg2,=,2,cmplx.two

cmplx.one:
	dt_jump1		arg5,(cmplx.one.int,cmplx.one.real,cmplx.one.dp,cmplx.one.cmpx,cmplx.one.p,cmplx.one.p,cmplx.one.p)

cmplx.one.int:
	s_call		cv_load.ir
	jump		cmplx.one.join

cmplx.one.real:
	load		eaq,arg5
	jump		cmplx.one.join

cmplx.one.dp:
	load		deaq,arg5
	emit_inst		1
	frd		0
	jump		cmplx.one.join

cmplx.one.cmpx:
	load		aq,arg5
	return		aq

cmplx.one.join:
	push_output
	store		eaq,op1,no_update
	bump		op1
	fld		=0.0,du
	fst		op1+1
	return		op1

cmplx.one.p:
	jump		bu_dt5.p

cmplx.two:
	dt_jump		(cmplx.two.ii,cmplx.two.ri,cmplx.two.di,cmplx.two.e1,cmplx.two.ir,cmplx.two.rr,cmplx.two.dr,cmplx.two.e1,cmplx.two.id,cmplx.two.rd,cmplx.two.dd,cmplx.two.e1,cmplx.two.e2,cmplx.two.e2,cmplx.two.e2,cmplx.two.e1,cmplx.two.e2,cmplx.two.e1,cmplx.two.e2,cmplx.two.e1)

cmplx.two.ii:
	push_output
	if_eaq		q,arg6,cmplx.two.ii.1
	swap		arg5
	s_call		cv_load.ir
	swap		arg5
	store		eaq,op1,no_update
	swap		arg6
	s_call		cv_load.ir
	swap		arg6
	in_reg		ieaq,op1
	return		op1

cmplx.two.ii.1:
	bump		arg6
	swap		arg6
	s_call		cv_load.ir
	swap		arg6
	store		ieaq,op1,no_update
	swap		arg5
	s_call		cv_load.ir
	swap		arg5
	in_reg		eaq,op1
	return		op1

cmplx.two.rr:
	push_output
	if_eaq		eaq,arg6,cmplx.two.rr.1
	load		eaq,arg5
	store		eaq,op1,no_update
	fld		arg6
	in_reg		ieaq,op1
	return		op1

cmplx.two.rr.1:
	store		ieaq,op1,no_update
	fld		arg5
	in_reg		eaq,op1
	return		op1

cmplx.two.dd:
	push_output
	if_eaq		deaq,arg6,cmplx.two.dd.1
	load		deaq,arg5
	emit_inst		1
	frd		0
	store		eaq,op1,no_update
	dfld		arg6
	emit_inst		1
	frd		0
	in_reg		ieaq,op1
	return		op1

cmplx.two.dd.1:
	emit_inst		1
	frd		0
	store		ieaq,op1,no_update
	dfld		arg5
	emit_inst		1
	frd		0
	in_reg		eaq,op1
	return		op1

cmplx.two.e1:
	jump		bu_dt5.p

cmplx.two.e2:
	jump		bu_dt6.p

cmplx.two.ri:
cmplx.two.di:
cmplx.two.ir:
cmplx.two.dr:
cmplx.two.id:
cmplx.two.rd:
	error		314,arg1

conjg:						" builtin 58
	bump		arg5
	unless_dt		cmpx,conjg.p

	push_output
	bump		op1

	if_eaq		ieaq,arg5,conjg.1

	load		eaq,arg5
	store		eaq,op1,no_update
	fld		arg5+1
	emit_inst		1
	fneg
	in_reg		ieaq,op1

	return		op1

conjg.1:
	emit_inst		1
	fneg
	store		ieaq,op1,no_update
	fld		arg5
	in_reg		eaq,op1

	return		op1

conjg.p:
	jump		bu_dt5.p

tan:						" builtin 59
	dt_jump1		op1,(tan_i,tan.1,dtan.1,bu_dt5.p,wrong_type.p,wrong_type.p,wrong_type.p)

tan.1:
	load		eaq,arg5
	jump		tan.2

tan_i:
	s_call		cv_load.ir

tan.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|tan_
	free_regs
	return		eaq

dtan:						" builtin 60
	unless_dt		dp,bu_dt5.p
dtan.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dtan_
	free_regs
	return		deaq

asin:						" builtin 61
	dt_jump1		op1,(asin_i,asin.1,dasin.1,bu_dt5.p,wrong_type.p,wrong_type.p,wrong_type.p)

asin.1:
	load		eaq,arg5
	jump		asin.2

asin_i:
	s_call		cv_load.ir

asin.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|asin_
	free_regs
	return		eaq

dasin:						" builtin 62
	unless_dt		dp,bu_dt5.p
dasin.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dasin_
	free_regs
	return		deaq

acos:						" builtin 63
	dt_jump1		op1,(acos_i,acos.1,dacos.1,bu_dt5.p,wrong_type.p,wrong_type.p,wrong_type.p)

acos.1:
	load		eaq,arg5
	jump		acos.2

acos_i:
	s_call		cv_load.ir

acos.2:
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|acos_
	free_regs
	return		eaq

dacos:						" builtin 64
	unless_dt		dp,bu_dt5.p
dacos.1:
	load		deaq,arg5
	push_temp		32
	load_pr		pr2,op1
	use_eaq
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)
	tsp3		pr0|dacos_
	free_regs
	return		deaq

char_builtin:					" builtin 65
	unless_dt		int,bu_dt5.p

	if_optype		constant,char.constant

	push_output

	load		q,op2

	emit_inst		1
	qls		27

	bump		op1,1

	stq		op1

	return		op1

char.constant:
	int_to_char1
	return		op1

ichar:						" builtin 66
	unless_dt		char,bu_dt5.p

	if_optype		constant,ichar.constant

	push_output

	if_aligned	op2,ichar.aligned

	emit_eis
	mrl		(pr),(pr),fill(0)
	desc9a		op2,1
	desc9a		op1,4

	return		op1

ichar.aligned:
	ldq		op2

	emit_inst		1
	qrl		27

	return		q

ichar.constant:
	char1_to_int
	return		op1

index:						" builtin 67
	unless_dt		char,bu_dt5.p
	swap		op2
	unless_dt		char,bu_dt5.p

	push_length	op2
	if		op1,=,1,index.1
	if		op1,=,2,index.2

	" Length of second string is not known to be 1 or 2

	push_length	op2

	load_pr		pr2,op3
	load		q,op1
	use_a
	tsx0		pr0|set_cs_eis

	free_regs

	load_pr		pr2,op4
	load		q,op2
	use_eaq
	tsx0		pr0|index_cs_eis

	free_regs

	return		q

index.1:

	" Length of second string is known to be 1

	emit_eis
	scm		(pr),(pr),mask(0)
	desc9a		op2
	desc9a		op3,1

	arg		pr6|double_temp

	ldq		pr6|double_temp
	ttf		2,ic
	lcq		1,dl
	adq		1,dl

	return		q

index.2:

	" Length of second string is known to be 2

	emit_eis
	scd		(pr),(pr)
	desc9a		op2
	desc9a		op3,2

	arg		pr6|double_temp

	ldq		pr6|double_temp
	ttf		2,ic
	lcq		1,dl
	adq		1,dl

	return		q

len:						" builtin 68
	unless_dt		char,bu_dt5.p
	push_length	op1
	return		op1

lge:						" builtin 69
	unless_dt		char,bu_dt5.p
	swap		op2
	unless_dt		char,bu_dt5.p

	use_ind

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		op1
	desc9a		op2

	return		trc

lgt:						" builtin 70
	unless_dt		char,bu_dt5.p
	swap		op2
	unless_dt		char,bu_dt5.p

	use_ind

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		op2
	desc9a		op1

	return		tnc

lle:						" builtin 71
	unless_dt		char,bu_dt5.p
	swap		op2
	unless_dt		char,bu_dt5.p

	use_ind

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		op2
	desc9a		op1

	return		trc

llt:						" builtin 72
	unless_dt		char,bu_dt5.p
	swap		op2
	unless_dt		char,bu_dt5.p

	use_ind

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		op1
	desc9a		op2

	return		tnc

dprod:						" builtin 83
	swap		arg5
	unless_dt		real,dprod.p
	swap		arg5
	unless_dt		real,dprod.p

	load_top		eaq
	fmp		op2
	return		deaq

dprod.p:
	jump		bu_dt6.p

and.tl:						" builtin 84
	unless		arg2,>,1,wrong_number.p
	unless_one_word_dt	op1,mm_dt1.p
	load_top		tq
	copy		op2

and.tl.loop:
	unless_one_word_dt	op1,mm_dt1.p
	anq		op1
	pop		op1
	if		arg2,=,2,and.tl.r
	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		and.tl.loop

and.tl.r:
	jump		mm_ret_tq

bool.tl:						" builtin 85
	unless_one_word_dt	arg5,bu_dt5.p
	load		tq,arg5
	jump		mm_ret_tq

compl.tl:						" builtin 86
	unless_one_word_dt	arg5,bu_dt5.p
	use_eaq
	lcq		1,dl
	erq		arg5
	jump		mm_ret_tq

fld.tl:						" builtin 87
	rhs_fld
	jump		mm_ret_tq

ilr.tl:						" builtin 88
	dt_jump1		arg5,(ilr.1,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,ilr.1)

ilr.1:
	dt_jump1		arg6,(ilr.2,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p)

ilr.2:
	load		q,arg5
	load		ia,arg6
	qlr		0,al
	jump		mm_ret_q

ils.tl:						" builtin 89
	dt_jump1		arg5,(ils.1,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,ils.1)

ils.1:
	dt_jump1		arg6,(ils.2,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p)

ils.2:
	load		q,arg5
	load		ia,arg6
	qls		0,al
	jump		mm_ret_q

irl.tl:						" builtin 90
	dt_jump1		arg5,(irl.1,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,irl.1)

irl.1:
	dt_jump1		arg6,(irl.2,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p)

irl.2:
	load		q,arg5
	load		ia,arg6
	qrl		0,al
	jump		mm_ret_q

irs.tl:						" builtin 91
	dt_jump1		arg5,(irs.1,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,bu_dt5.p,irs.1)

irs.1:
	dt_jump1		arg6,(irs.2,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p,bu_dt6.p)

irs.2:
	load		q,arg5
	load		ia,arg6
	qrs		0,al
	jump		mm_ret_q

or.tl:						" builtin 92
	unless		arg2,>,1,wrong_number.p
	unless_one_word_dt	op1,mm_dt1.p
	load_top		tq
	copy		op2

or.tl.loop:
	unless_one_word_dt	op1,mm_dt1.p
	orq		op1
	pop		op1
	if		arg2,=,2,or.tl.r
	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		or.tl.loop

or.tl.r:
	jump		mm_ret_tq

xor.tl:						" builtin 93
	unless		arg2,>,1,wrong_number.p
	unless_one_word_dt	op1,mm_dt1.p
	load_top		tq
	copy		op2

xor.tl.loop:
	unless_one_word_dt	op1,mm_dt1.p
	erq		op1
	pop		op1
	if		arg2,=,2,xor.tl.r
	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		xor.tl.loop

xor.tl.r:
	jump		mm_ret_tq

bu_dt5.p:
	error		321,arg1,arg5

bu_dt6.p:
	error		321,arg1,arg6

mm_dt1.p:
	error		321,arg1,op1

mm_dt2.p:
	error		321,arg1,op2

"		Errors common to all relational operators.
logical_op1:
	error		339,op1

logical_op2:
	error		339,op2

typeless_op1:
	error		362,op1

typeless_op2:
	error		362,op2

invalid_opnd:
	error		340,op2

not_scalar:
	error		340,op1
"
"		Begin relational operators.
"
less:	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(less_ii,less_ri,less_di,less_ci,less_ir,less_rr,less_dr,less_cr,less_id,less_rd,less_dd,less_cd,less_ic,less_rc,less_dc,less_cc,less_e2,less_e1,less_tl,less_tl)

less_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,less_ii.global
	if_global_ind_var	arg2,less_ii.global.1

	if_eaq		q,arg2,less_ii.1

	load		q,arg1
	compare		q,arg2
	return		tmi

less_ii.1:
	compare		q,arg1
	return		tpnz

less_ii.global:
	compare_index
	if_fb17		arg1,less_ii.global.fb17
	return		tnc
less_ii.global.fb17:
	return		tmi

less_ii.global.1:
	swap		arg1
	compare_index
	if_fb17		arg1,less_ii.global.1.fb17
	return		j_g_s
less_ii.global.1.fb17:
	return		tpnz

less_ir:
	swap		arg1

	s_call		cv_load.ir
	compare		eaq,arg1
	return		tmi

less_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tpnz

less_id:
	swap		arg1

	s_call		cv_load.id
	compare		deaq,arg1
	return		tmi

less_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tpnz

less_rr:
	if_eaq		eaq,arg2,less_rr.1

	load		eaq,arg1
	compare		eaq,arg2
	return		tmi

less_rr.1:
	compare		eaq,arg1
	return		tpnz

less_dd:
	if_eaq		deaq,arg2,less_dd.1

	load		deaq,arg1
	compare		deaq,arg2
	return		tmi

less_dd.1:
	compare		deaq,arg1
	return		tpnz

less_rd:
	if_eaq		deaq,arg2,less_rd.1

	load		eaq,arg1
	compare		deaq,arg2
	return		tmi

less_rd.1:
	compare		eaq,arg1
	return		tpnz

less_dr:
	if_eaq		eaq,arg2,less_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tmi

less_dr.1:
	compare		deaq,arg1
	return		tpnz

less_ic:
	error		323,arg2

less_ci:
	error		323,arg1

less_rc:
	error		323,arg2

less_cr:
	error		323,arg1

less_dc:
	error		312,arg1,arg2

less_cd:
	error		311,arg1,arg2

less_cc:
	error		328,arg1,arg2

less_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(less_ih,less_rh,less_dh,less_ch,logical_op2,less_hh,less_th)

less_ih:
less_rh:
less_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg2
	cmpa		arg1
	return		tnc

less_dh:
less_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg2
	cmpaq		arg1
	return		tnc

less_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg1
	desc9a		arg2

	return		tnc

less_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(less_hi,less_hr,less_hd,less_hc,logical_op1,less_hh,less_ht)

less_hi:
less_hr:
less_ht:
	pad_char_const_to_word	arg2

	load		a,arg2
	cmpa		arg1
	return		tnc

less_hd:
less_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg2
	cmpaq		arg1
	return		tnc

less_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(less_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,less_tl.1)

less_tl.1:
	if_eaq		tq,arg2,less_tl.2

	load		tq,arg1
	compare		tq,arg2
	return		tmi

less_tl.2:
	compare		tq,arg1
	return		tpnz


less_or_equal:
	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(less_or_equal_ii,less_or_equal_ri,less_or_equal_di,less_or_equal_ci,less_or_equal_ir,less_or_equal_rr,less_or_equal_dr,less_or_equal_cr,less_or_equal_id,less_or_equal_rd,less_or_equal_dd,less_or_equal_cd,less_or_equal_ic,less_or_equal_rc,less_or_equal_dc,less_or_equal_cc,less_or_equal_e2,less_or_equal_e1,less_or_equal_tl,less_or_equal_tl)

less_or_equal_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,less_or_equal_ii.global
	if_global_ind_var	arg2,less_or_equal_ii.global.1

	if_eaq		q,arg2,less_or_equal_ii.1

	load		q,arg1
	compare		q,arg2
	return		tmoz

less_or_equal_ii.1:
	compare		q,arg1
	return		tpl

less_or_equal_ii.global:
	compare_index
	if_fb17		arg1,less_or_equal_ii.global.fb17
	return		j_le_s
less_or_equal_ii.global.fb17:
	return		tmoz

less_or_equal_ii.global.1:
	swap		arg1
	compare_index
	if_fb17		arg1,less_or_equal_ii.global.1.fb17
	return		trc
less_or_equal_ii.global.1.fb17:
	return		tpl

less_or_equal_ir:
	swap		arg1

	s_call		cv_load.ir
	compare		eaq,arg1
	return		tmoz

less_or_equal_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tpl

less_or_equal_id:
	swap		arg1

	s_call		cv_load.id
	compare		deaq,arg1
	return		tmoz

less_or_equal_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tpl

less_or_equal_rr:
	if_eaq		eaq,arg2,less_or_equal_rr.1

	load		eaq,arg1
	compare		eaq,arg2
	return		tmoz

less_or_equal_rr.1:
	compare		eaq,arg1
	return		tpl

less_or_equal_dd:
	if_eaq		deaq,arg2,less_or_equal_dd.1

	load		deaq,arg1
	compare		deaq,arg2
	return		tmoz

less_or_equal_dd.1:
	compare		deaq,arg1
	return		tpl

less_or_equal_rd:
	if_eaq		deaq,arg2,less_or_equal_rd.1

	load		eaq,arg1
	compare		deaq,arg2
	return		tmoz

less_or_equal_rd.1:
	compare		eaq,arg1
	return		tpl

less_or_equal_dr:
	if_eaq		eaq,arg2,less_or_equal_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tmoz

less_or_equal_dr.1:
	compare		deaq,arg1
	return		tpl

less_or_equal_ic:
	error		323,arg2

less_or_equal_ci:
	error		323,arg1

less_or_equal_rc:
	error		323,arg2

less_or_equal_cr:
	error		323,arg1

less_or_equal_dc:
	error		312,arg1,arg2

less_or_equal_cd:
	error		311,arg1,arg2

less_or_equal_cc:
	error		328,arg1,arg2

less_or_equal_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(less_or_equal_ih,less_or_equal_rh,less_or_equal_dh,less_or_equal_ch,logical_op2,less_or_equal_hh,less_or_equal_th)

less_or_equal_ih:
less_or_equal_rh:
less_or_equal_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg1
	cmpa		arg2
	return		trc

less_or_equal_dh:
less_or_equal_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg1
	cmpaq		arg2
	return		trc

less_or_equal_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg2
	desc9a		arg1

	return		trc

less_or_equal_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(less_or_equal_hi,less_or_equal_hr,less_or_equal_hd,less_or_equal_hc,logical_op1,less_or_equal_hh,less_or_equal_ht)

less_or_equal_hi:
less_or_equal_hr:
less_or_equal_ht:
	pad_char_const_to_word	arg2

	load		a,arg1
	cmpa		arg2
	return		trc

less_or_equal_hd:
less_or_equal_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg1
	cmpaq		arg2
	return		trc

less_or_equal_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(less_or_equal_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,less_or_equal_tl.1)

less_or_equal_tl.1:
	if_eaq		tq,arg2,less_or_equal_tl.2

	load		tq,arg1
	compare		tq,arg2
	return		tmoz

less_or_equal_tl.2:
	compare		tq,arg1
	return		tpl

equal:	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(equal_ii,equal_ri,equal_di,equal_ci,equal_ir,equal_rr,equal_dr,equal_cr,equal_id,equal_rd,equal_dd,equal_cd,equal_ic,equal_rc,equal_dc,equal_cc,equal_e2,equal_e1,equal_tl,equal_tl)

equal_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,equal_ii.global
	if_global_ind_var	arg2,equal_ii.global.1

	load_top		q
	compare		q,arg1
	return		tze

equal_ii.global.1:
	swap		arg1

equal_ii.global:
	compare_index
	return		tze

equal_ir:
	swap		arg1

equal_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tze

equal_id:
	swap		arg1

equal_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tze

equal_rr:
	load_top		eaq
	compare		eaq,arg1
	return		tze

equal_dd:
	load_top		deaq
	compare		deaq,arg1
	return		tze

equal_rd:
	swap		arg1

equal_dr:
	if_eaq		eaq,arg2,equal_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tze

equal_dr.1:
	compare		deaq,arg1
	return		tze

equal_ic:
	error		323,arg2

equal_ci:
	error		323,arg1

equal_rc:
	error		323,arg2

equal_cr:
	error		323,arg1

equal_dc:
	error		312,arg1,arg2

equal_cd:
	error		311,arg1,arg2

equal_cc:
	load_top		aq
	cmpaq		arg1
	return		tze

equal_e2:
	if_dt		char,equal_ah
	swap		arg1	" top is logical, so swap and test

	if_dt		logical,equal_ll
	error		313,op1

equal_ll:
	load_top		a
	compare		a,arg1
	return		tze

equal_ah:
	dt_jump1		arg1,(equal_ih,equal_rh,equal_dh,equal_ch,logical_op2,equal_hh,equal_th)

equal_ih:
equal_rh:
equal_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load_top		a
	cmpa		arg1
	return		tze

equal_dh:
equal_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load_top		aq
	cmpaq		arg1
	return		tze

equal_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg1
	desc9a		arg2

	return		tze

equal_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(equal_hi,equal_hr,equal_hd,equal_hc,logical_op1,equal_hh,equal_ht)

equal_hi:
equal_hr:
equal_ht:
	pad_char_const_to_word	arg2

	load_top		a
	cmpa		arg1
	return		tze

equal_hd:
equal_hc:
	pad_char_const_to_dw	arg2

	load_top		aq
	cmpaq		arg1
	return		tze

equal_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(equal_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,equal_tl.1)

equal_tl.1:
	load_top		tq
	compare		tq,arg1
	return		tze

not_equal:
	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(not_equal_ii,not_equal_ri,not_equal_di,not_equal_ci,not_equal_ir,not_equal_rr,not_equal_dr,not_equal_cr,not_equal_id,not_equal_rd,not_equal_dd,not_equal_cd,not_equal_ic,not_equal_rc,not_equal_dc,not_equal_cc,not_equal_e2,not_equal_e1,not_equal_tl,not_equal_tl)

not_equal_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,not_equal_ii.global
	if_global_ind_var	arg2,not_equal_ii.global.1

	load_top		q
	compare		q,arg1
	return		tnz

not_equal_ii.global.1:
	swap		arg1

not_equal_ii.global:
	compare_index
	return		tnz

not_equal_ir:
	swap		arg1

not_equal_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tnz

not_equal_id:
	swap		arg1

not_equal_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tnz

not_equal_rr:
	load_top		eaq
	compare		eaq,arg1
	return		tnz

not_equal_dd:
	load_top		deaq
	compare		deaq,arg1
	return		tnz

not_equal_rd:
	swap		arg1

not_equal_dr:
	if_eaq		eaq,arg2,not_equal_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tnz

not_equal_dr.1:
	compare		deaq,arg1
	return		tnz

not_equal_ic:
	error		323,arg2

not_equal_ci:
	error		323,arg1

not_equal_rc:
	error		323,arg2

not_equal_cr:
	error		323,arg1

not_equal_dc:
	error		312,arg1,arg2

not_equal_cd:
	error		311,arg1,arg2

not_equal_cc:
	load_top		aq
	cmpaq		arg1
	return		tnz

not_equal_e2:
	if_dt		char,not_equal_ah
	swap		arg1	" top is logical, so swap and test other

	if_dt		logical,not_equal_ll
	error		313,op1

not_equal_ll:
	load_top		a
	compare		a,arg1
	return		tnz

not_equal_ah:
	dt_jump1		arg1,(not_equal_ih,not_equal_rh,not_equal_dh,not_equal_ch,logical_op2,not_equal_hh,not_equal_th)

not_equal_ih:
not_equal_rh:
not_equal_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load_top		a
	cmpa		arg1
	return		tnz

not_equal_dh:
not_equal_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load_top		aq
	cmpaq		arg1
	return		tnz

not_equal_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg1
	desc9a		arg2

	return		tnz

not_equal_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(not_equal_hi,not_equal_hr,not_equal_hd,not_equal_hc,logical_op1,not_equal_hh,not_equal_ht)

not_equal_hi:
not_equal_hr:
not_equal_ht:
	pad_char_const_to_word	arg2

	load_top		a
	cmpa		arg1
	return		tnz

not_equal_hd:
not_equal_hc:
	pad_char_const_to_dw	arg2

	load_top		aq
	cmpaq		arg1
	return		tnz

not_equal_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(not_equal_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,not_equal_tl.1)

not_equal_tl.1:
	load_top		tq
	compare		tq,arg1
	return		tnz

greater_or_equal:
	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(greater_or_equal_ii,greater_or_equal_ri,greater_or_equal_di,greater_or_equal_ci,greater_or_equal_ir,greater_or_equal_rr,greater_or_equal_dr,greater_or_equal_cr,greater_or_equal_id,greater_or_equal_rd,greater_or_equal_dd,greater_or_equal_cd,greater_or_equal_ic,greater_or_equal_rc,greater_or_equal_dc,greater_or_equal_cc,greater_or_equal_e2,greater_or_equal_e1,greater_or_equal_tl,greater_or_equal_tl)

greater_or_equal_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,greater_or_equal_ii.global
	if_global_ind_var	arg2,greater_or_equal_ii.global.1

	if_eaq		q,arg2,greater_or_equal_ii.1

	load		q,arg1
	compare		q,arg2
	return		tpl

greater_or_equal_ii.1:
	compare		q,arg1
	return		tmoz

greater_or_equal_ii.global:
	compare_index
	if_fb17		arg1,greater_or_equal_ii.global.fb17
	return		trc
greater_or_equal_ii.global.fb17:
	return		tpl

greater_or_equal_ii.global.1:
	swap		arg1
	compare_index
	if_fb17		arg1,greater_or_equal_ii.glob.1.fb17
	return		j_le_s
greater_or_equal_ii.glob.1.fb17:	"ALM won't handle symbols longer than 32 chars
	return		tmoz

greater_or_equal_ir:
	swap		arg1

	s_call		cv_load.ir
	compare		eaq,arg1
	return		tpl

greater_or_equal_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tmoz

greater_or_equal_id:
	swap		arg1

	s_call		cv_load.id
	compare		deaq,arg1
	return		tpl

greater_or_equal_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tmoz

greater_or_equal_rr:
	if_eaq		eaq,arg2,greater_or_equal_rr.1

	load		eaq,arg1
	compare		eaq,arg2
	return		tpl

greater_or_equal_rr.1:
	compare		eaq,arg1
	return		tmoz

greater_or_equal_dd:
	if_eaq		deaq,arg2,greater_or_equal_dd.1

	load		deaq,arg1
	compare		deaq,arg2
	return		tpl

greater_or_equal_dd.1:
	compare		deaq,arg1
	return		tmoz

greater_or_equal_rd:
	if_eaq		deaq,arg2,greater_or_equal_rd.1

	load		eaq,arg1
	compare		deaq,arg2
	return		tpl

greater_or_equal_rd.1:
	compare		eaq,arg1
	return		tmoz

greater_or_equal_dr:
	if_eaq		eaq,arg2,greater_or_equal_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tpl

greater_or_equal_dr.1:
	compare		deaq,arg1
	return		tmoz

greater_or_equal_ic:
	error		323,arg2

greater_or_equal_ci:
	error		323,arg1

greater_or_equal_rc:
	error		323,arg2

greater_or_equal_cr:
	error		323,arg1

greater_or_equal_dc:
	error		312,arg1,arg2

greater_or_equal_cd:
	error		311,arg1,arg2

greater_or_equal_cc:
	error		328,arg1,arg2

greater_or_equal_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(greater_or_equal_ih,greater_or_equal_rh,greater_or_equal_dh,greater_or_equal_ch,logical_op2,greater_or_equal_hh,greater_or_equal_th)

greater_or_equal_ih:
greater_or_equal_rh:
greater_or_equal_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg2
	cmpa		arg1
	return		trc

greater_or_equal_dh:
greater_or_equal_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg2
	cmpaq		arg1
	return		trc

greater_or_equal_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg1
	desc9a		arg2

	return		trc

greater_or_equal_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(greater_or_equal_hi,greater_or_equal_hr,greater_or_equal_hd,greater_or_equal_hc,logical_op1,greater_or_equal_hh,greater_or_equal_ht)

greater_or_equal_hi:
greater_or_equal_hr:
greater_or_equal_ht:
	pad_char_const_to_word	arg2

	load		a,arg2
	cmpa		arg1
	return		trc

greater_or_equal_hd:
greater_or_equal_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg2
	cmpaq		arg1
	return		trc

greater_or_equal_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(greater_or_equal_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,greater_or_equal_tl.1)

greater_or_equal_tl.1:
	if_eaq		tq,arg2,greater_or_equal_tl.2

	load		tq,arg1
	compare		tq,arg2
	return		tpl

greater_or_equal_tl.2:
	compare		tq,arg1
	return		tmoz

greater:	func		2

	refresh_regs_if_next_is_jump

	dt_jump		(greater_ii,greater_ri,greater_di,greater_ci,greater_ir,greater_rr,greater_dr,greater_cr,greater_id,greater_rd,greater_dd,greater_cd,greater_ic,greater_rc,greater_dc,greater_cc,greater_e2,greater_e1,greater_tl,greater_tl)

greater_ii:
	note_eligible_ind_var_use
	if_global_ind_var	arg1,greater_ii.global
	if_global_ind_var	arg2,greater_ii.global.1

	if_eaq		q,arg2,greater_ii.1

	load		q,arg1
	compare		q,arg2
	return		tpnz

greater_ii.1:
	compare		q,arg1
	return		tmi

greater_ii.global:
	compare_index
	if_fb17		arg1,greater_ii.global.fb17
	return		j_g_s
greater_ii.global.fb17:
	return		tpnz

greater_ii.global.1:
	swap		arg1
	compare_index
	if_fb17		arg1,greater_ii.global.1.fb17
	return		tnc
greater_ii.global.1.fb17:
	return		tmi

greater_ir:
	swap		arg1

	s_call		cv_load.ir
	compare		eaq,arg1
	return		tpnz

greater_ri:
	s_call		cv_load.ir
	compare		eaq,arg1
	return		tmi

greater_id:
	swap		arg1

	s_call		cv_load.id
	compare		deaq,arg1
	return		tpnz

greater_di:
	s_call		cv_load.id
	compare		deaq,arg1
	return		tmi

greater_rr:
	if_eaq		eaq,arg2,greater_rr.1

	load		eaq,arg1
	compare		eaq,arg2
	return		tpnz

greater_rr.1:
	compare		eaq,arg1
	return		tmi

greater_dd:
	if_eaq		deaq,arg2,greater_dd.1

	load		deaq,arg1
	compare		deaq,arg2
	return		tpnz

greater_dd.1:
	compare		deaq,arg1
	return		tmi

greater_rd:
	if_eaq		deaq,arg2,greater_rd.1

	load		eaq,arg1
	compare		deaq,arg2
	return		tpnz

greater_rd.1:
	compare		eaq,arg1
	return		tmi

greater_dr:
	if_eaq		eaq,arg2,greater_dr.1

	load		deaq,arg1
	compare		eaq,arg2
	return		tpnz

greater_dr.1:
	compare		deaq,arg1
	return		tmi

greater_ic:
	error		323,arg2

greater_ci:
	error		323,arg1

greater_rc:
	error		323,arg2

greater_cr:
	error		323,arg1

greater_dc:
	error		312,arg1,arg2

greater_cd:
	error		311,arg1,arg2

greater_cc:
	error		328,arg1,arg2

greater_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(greater_ih,greater_rh,greater_dh,greater_ch,logical_op2,greater_hh,greater_th)

greater_ih:
greater_rh:
greater_th:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg1
	cmpa		arg2
	return		tnc

greater_dh:
greater_ch:
	unless_optype	constant,invalid_opnd

	swap		arg1
	unless_optype	(variable,array_ref,temp),not_scalar

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg1
	cmpaq		arg2
	return		tnc

greater_hh:
	use_eaq

	emit_eis
	cmpc		(pr),(pr),fill(040)
	desc9a		arg2
	desc9a		arg1

	return		tnc

greater_e1:
	unless_optype	(variable,array_ref,temp),not_scalar

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(greater_hi,greater_hr,greater_hd,greater_hc,logical_op1,greater_hh,greater_ht)

greater_hi:
greater_hr:
greater_ht:
	pad_char_const_to_word	arg2

	load		a,arg1
	cmpa		arg2
	return		tnc

greater_hd:
greater_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg1
	cmpaq		arg2
	return		tnc

greater_tl:
	unless_dt		(int,typeless),typeless_op1
	dt_jump1		op2,(greater_tl.1,typeless_op2,typeless_op2,typeless_op2,typeless_op2,typeless_op2,greater_tl.1)

greater_tl.1:
	if_eaq		tq,arg2,greater_tl.2

	load		tq,arg1
	compare		tq,arg2
	return		tpnz

greater_tl.2:
	compare		tq,arg1
	return		tmi

or:	func		2

	unless_dt		logical,or_e2
	swap		arg1
	unless_dt		logical,or_e1

	load_top		a
	ora		arg1
	return		a

or_e1:
	error		313,arg1

or_e2:
	error		313,arg2

and:	func		2

	unless_dt		logical,and_e2
	swap		arg1
	unless_dt		logical,and_e1

	load_top		a
	ana		arg1
	return		a

and_e1:
	error		313,arg1

and_e2:
	error		313,arg2

not:	func		1

	unless_dt		logical,not.e

	if_eaq		ind,op1,not_ind

	load		a,op1
	era		=o400000,du
	return		a

not_ind:
	ind_jump		(not_tze,not_tnz,not_tmi,not_tpl,not_tmoz,not_tpnz,not_tnc,not_trc,not_j_le_s,not_j_g_s)

not_tze:
	return		tnz

not_tnz:
	return		tze

not_tmi:
	return		tpl

not_tpl:
	return		tmi

not_tmoz:
	return		tpnz

not_tpnz:
	return		tmoz

not_tnc:
	return		trc

not_trc:
	return		tnc

not_j_le_s:
	return		j_g_s

not_j_g_s:
	return		j_le_s

not.e:
	error		313,op1

equiv:	func		2

	unless_dt		logical,equiv.p
	swap		arg1
	unless_dt		logical,equiv.p

	refresh_regs_if_next_is_jump

	load_top		a
	compare		a,arg1
	return		tze


not_equiv:
	func		2

	unless_dt		logical,not_equiv.p
	swap		arg1
	unless_dt		logical,not_equiv.p

	refresh_regs_if_next_is_jump

	load_top		a
	compare		a,arg1
	return		tnz


equiv.p:
not_equiv.p:
	error		313,op1

jump:	proc		1

	if_next_statement	arg1,jump_is_nop
	shorten_stack
	refresh_regs
	save_state	arg1,discard
	tra		arg1

jump_is_nop:
	return

jump_false:
	proc		2

	swap		op2

	unless_dt		logical,jump_false.p

	if_optype		constant,jump_false_const
	if_eaq		ind,op1,jump_false_ind

	shorten_stack
	refresh_regs

	load_for_test	a,op1

jump_false_using_a:
	save_state	arg1
	tze		arg1
	return

jump_false_const:
	unless_zero	op1,jump_false_is_nop

	shorten_stack
	refresh_regs
	save_state	arg1
	tra		arg1

jump_false_is_nop:
	return

jump_false_ind:
	unless_optype	temp,jump_false_using_ind " not a temp, so only used once
	push_ref_count	arg2		" if value is to be used again, put it in A
	unless		op1,>,0,jump_false_using_ind " last ref so dont change it
	ind_to_a				" forces value to A
	shorten_stack	protect_indicators
	refresh_regs	protect_indicators
	jump		jump_false_using_a

jump_false_using_ind:
	shorten_stack	protect_indicators
	refresh_regs	protect_indicators
	save_state	arg1

	ind_jump		(jump_false_tze,jump_false_tnz,jump_false_tmi,jump_false_tpl,jump_false_tmoz,jump_false_tpnz,jump_false_tnc,jump_false_trc,jump_false_j_le_s,jump_false_j_g_s)

jump_false_tze:
	tnz		arg1
	return

jump_false_tnz:
	tze		arg1
	return

jump_false_tmi:
	tpl		arg1
	return

jump_false_tpl:
	tmi		arg1
	return

jump_false_tmoz:
	tpnz		arg1
	return

jump_false_tpnz:
	tmoz		arg1
	return

jump_false_tnc:
	trc		arg1
	return

jump_false_trc:
	tnc		arg1
	return

jump_false_j_le_s:
	tze		2,ic
	trc		arg1
	return

jump_false_j_g_s:
	tnc		arg1
	tze		arg1
	return

jump_false.p:
	print		324,op1
	return



jump_true:
	proc		2

	swap		op2

	unless_dt		logical,jump_false.p

	if_optype		constant,jump_true_const
	if_eaq		ind,op1,jump_true_ind

	shorten_stack
	refresh_regs

	load_for_test	a,op1

jump_true_using_a:
	save_state	arg1
	tnz		arg1
	return

jump_true_const:
	if_zero		op1,jump_true_is_nop

	shorten_stack
	refresh_regs
	save_state	arg1
	tra		arg1

jump_true_is_nop:
	return

jump_true_ind:
	unless_optype	temp,jump_true_using_ind " not a temp, so only used once
	push_ref_count	arg2		" if value is to be used again, put it in A
	unless		op1,>,0,jump_true_using_ind " last ref so dont change it
	ind_to_a				" forces value to A
	shorten_stack	protect_indicators
	refresh_regs	protect_indicators
	jump		jump_true_using_a

jump_true_using_ind:
	shorten_stack	protect_indicators
	refresh_regs	protect_indicators
	save_state	arg1
	ind_jump		(jump_false_tnz,jump_false_tze,jump_false_tpl,jump_false_tmi,jump_false_tpnz,jump_false_tmoz,jump_false_trc,jump_false_tnc,jump_false_j_g_s,jump_false_j_le_s)

jump_arithmetic:
	proc		4

	shorten_stack
	refresh_regs

	swap	arg1	" optimize for consants
	if_optype	constant,jump_arith_const
	swap	arg1
	
	dt_jump1		arg1,(jump_arithmetic_i,jump_arithmetic_r,jump_arithmetic_d,jump_arithmetic.e,jump_arithmetic.e,jump_arithmetic.e,jump_arithmetic.e)

jump_arithmetic_d:
	unless_eaq	deaq,arg1,jump_arithmetic_r.1
	if_ind		deaq,jump_arithmetic.01
	fcmp		=0.0,du
	set_inds_valid	deaq
	jump		jump_arithmetic.01

jump_arithmetic_i:
	unless_global_ind_var	arg1,jump_arithmetic_i.check_eaq
	test_index
	jump		jump_arithmetic.01

jump_arithmetic_i.check_eaq:
	unless_eaq	q,arg1,jump_arithmetic_i.1
	if_ind		q,jump_arithmetic.01
	cmpq		0,dl
	set_inds_valid	q
	jump		jump_arithmetic.01

jump_arithmetic_i.1:
	szn		arg1
	jump		jump_arithmetic.01

jump_arithmetic_r:

	unless_eaq	eaq,arg1,jump_arithmetic_r.1
	if_ind		eaq,jump_arithmetic.01
	fcmp		=0.0,du
	set_inds_valid	eaq
	jump		jump_arithmetic.01

jump_arithmetic_r.1:
	use_ind
	use_eaq			" so we dont have to invent use_eaq protect_indicators
	fszn		arg1

jump_arithmetic.01:
	swap		arg3			" order is now 1 3 2
	if		arg2,=,op1,jump_arith_12	" 1 & 2 are the same label
	swap		arg3			" order is now 1 2 3
	if		arg2,=,op1,jump_arith_13	" 1 & 3 are the same label
	if		arg3,=,op1,jump_arith_23	" 2 & 3 are the same label

"				All labels are different
"
	if_next_statement	arg2,jump_arith_1next	" 1st label is next statement
	if_next_statement	arg3,jump_arith_2next	" 2nd label is next statement
	if_next_statement	arg4,jump_arith_3next	" 3rd label is next statement

	save_state	arg2			" all labels are different and none
	tmi		arg2			" is next statement
	save_state	arg3
	tze		arg3

jump_arith_all:					" all labels are the same but not
	save_state	arg4,discard		" the next statement
	tra		arg4
	return

jump_arith_1next:					" all labels are different and 1st
	save_state	arg3			" is next statement
	tze		arg3

jump_arith_to3:					" 1 & 2 are the next statement, but
	save_state	arg4			" 3 is not
	tpnz		arg4
	return

jump_arith_2next:					" all labels are different and 2nd
	save_state	arg4			" is next_statement
	tpnz		arg4

jump_arith_to1:					" 2 & 3 are the next statement, but
	save_state	arg2			" 1 is not
	tmi		arg2
	return

jump_arith_3next:					" all labels are different and 3rd
	save_state	arg2			" is next statement
	tmi		arg2

jump_arith_to2:					" 1 & 3 are the next statement, but
	save_state	arg3			" 2 is not
	tze		arg3
	return

jump_arith_12:					" order is now 1 3 2
	swap		arg3			" restore order to 1 2 3
	unless		arg2,=,op1,jump_arith_12.c	" compare 1 and 3
	unless_next_statement	arg2,jump_arith_all
	return					" all jump to next statement

jump_arith_12.c:
	if_next_statement	arg2,jump_arith_to3

	save_state	arg2
	tmoz		arg2
	unless_next_statement	arg4,jump_arith_all
	return

jump_arith_13:
	if_next_statement	arg2,jump_arith_to2

	save_state	arg2
	tnz		arg2
	if_next_statement	arg3,jump_arith_return

	save_state	arg3,discard
	tra		arg3
	return

jump_arith_23:
	if_next_statement	arg3,jump_arith_to1

	save_state	arg3
	tpl		arg3

	if_next_statement	arg2,jump_arith_return

	save_state	arg2,discard
	tra		arg2
	return


jump_arith_const:
	if_zero		op1,jump_arith_const2
	if_negative	op1,jump_arith_const1
	swap		arg1
	if_next_statement	arg4,jump_arith_return
	tra		arg4		" simple transfer
	return

jump_arith_const1:
	swap		arg1
	if_next_statement	arg2,jump_arith_return
	tra		arg2
	return

jump_arith_const2:
	swap		arg1
	if_next_statement	arg3,jump_arith_return
	tra		arg3
	return
	
jump_arith_return:
	return

jump_arithmetic.e:
	error		325,op1

jump_computed:
	proc		1		" <count>
"					Rest of operands are: label list, expre

	shorten_stack
	refresh_regs

	if		arg1,<,1,jc_list.p

	push_label		" arg2 - label to skip goto, expre out-of-range
	push_label		" arg3 - address of transfer vector

jump_computed.get_operands:		" loop to pick up label list and jump expression
	push_operand	jump_computed.stack_ready
	jump		jump_computed.get_operands

jump_computed.stack_ready:		" <# lbls> <skip lbl> <vect lbl> <lbl list> <expre>
	dt_jump1		op1,(jump_computed_i,jump_computed_r,jump_computed_d,jump_computed_r,jump_computed.p,jump_computed.p,jump_computed.p)

jump_computed_i:
	load		q,op1
	jump		jc_transfer

jump_computed_r:
	s_call		cv_load.ri
	jump		jc_transfer

jump_computed_d:
	s_call		cv_load.di

jc_transfer:

	use_eaq		protect_indicators		" save all temps before transfer

	increment		arg1,1	" adjust count so that compare is against
"				   arg1+1 and so that loops exclude <count copy>

	compare		q,arg1

	pop		op1		" expre no longer needed

	copy		arg1	" <# lbls> <skip lbl> <vect lbl> <lbl list> <count>

jc_save_state:
	copy		op1
	copy		opv
	save_state	op1
	pop		op1
	decrement		op1,1		" arg1 is saved for the next loop
	if		op1,>,1,jc_save_state

	tnc		arg3
	force_ql			"forces last inst to be tnc  arg3,ql

	label		arg3	" define beginning of transfer vector
	tra		arg2	" first word in transfer vector

jc_labels:
	copy		arg1

	copy		opv
	tra		op1
	pop		op1

	decrement		arg1,1
	if		arg1,>,1,jc_labels

jc_ret:
	label		arg2	" define skip label after computed goto code
	return

jc_list.p:
	print		327

	jump		jc_ret

jump_computed.p:
	print		326,arg1
	return

jump_assigned:
	proc		1

	shorten_stack
	refresh_regs

	unless_dt		int,jump_assigned.e

	unless_array	jump_assigned.1

	print		300,op1

jump_assigned.1:
	use_eaq			" save all temps now

	ldx0		arg1

	tra		0,0
	discard_state
	return

jump_assigned.e:
	print		301,op1
	return

assign_label:
	proc		1

	push_output
	unless_dt		int,assign_label.e
	unless_array	assign_label.1

	print		300,op1

assign_label.1:
	swap		arg1
	if_optype		rel_constant,assign_label.2

	" The label is on a format statement.

	load_pr		pr2,arg2
	sprp2		arg1
	flush_ref		arg1
	free_regs
	return

	" The label is on an executable statement.

assign_label.2:
	eax0		arg2
	stx0		arg1
	flush_ref		arg1
	return

assign_label.e:
	print		301,op1
	return

read:	proc		2

	swap		arg1

	unless_dt		int,read.p

	swap		arg1
	load		q,arg1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_read
	free_regs
	return

read.p:
	print		302,op1
	return

write:	proc		2

	swap		arg1

	unless_dt		int,write.p

	swap		arg1
	load		q,arg1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_write
	free_regs
	return

write.p:
	print		302,op1
	return

format:	proc		1

	if_dt		char,format_c
	unless_dt		int,format.pp
	if_array		format_c

	" Must be an integer variable defined with a format value in an
	" ASSIGN statement.  The variable will contain a packed pointer
	" which locates the format string.

	reserve_regs	pr2
	lprp2		arg1
	push_builtin	ps
	spri2		op1+format_slot
	free_regs
	return

format.pp:
	error		329,arg1

format.pv:
	error		358,arg1

format_c:
	if_VLA		arg1,format.pv	" cannot be a Very Large Array
	load_pr		pr2,arg1
	push_builtin	ps
	spri2		op1+format_slot
	free_regs
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

end_label:
	proc		1
	load_pr		pr5,arg1
	push_builtin	ps
	spri5		op1+end_label_slot
	free_regs
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

error_label:
	proc		1

	load_pr		pr5,arg1
	push_builtin	ps
	spri5		op1+error_label_slot
	free_regs
	return

read_scalar:
	proc		0

	push_output
	flush_ref		arg1
	jump		scalar_common

write_scalar:
	proc		1

scalar_common:

	use_eaq

	bump		arg1
	load_pr		pr2,arg1

	dt_jump1		op1,(xs_i,xs_r,xs_d,xs_c,xs_l,xs_h,xs_t)

xs_i:
xs_t:
	lda		=1b18,du		=o400000
	jump		xs_transfer

xs_r:
	lda		=1b19,du		=o200000
	jump		xs_transfer

xs_d:
	lda		=1b20,du		=o100000
	jump		xs_transfer

xs_c:
	lda		=1b21,du		=o040000
	jump		xs_transfer

xs_l:
	lda		=1b22,du		=o020000
	jump		xs_transfer

xs_h:
	push_length	arg1

	bump		op1
	lda		op1

	emit_inst		1
	als		4

	ora		4096,du		=o010000

xs_transfer:
	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_scalar_xmit
	free_regs
	drop		arg1
	return

read_array:
	proc		0

	push_output
	flush_ref		op1
	jump		array_common

write_array:
	proc		1

array_common:

	dt_jump1		op1,(xa_i,xa_r,xa_d,xa_c,xa_l,xa_h,xa_t)

xa_i:
xa_t:
	if_VLA		op1,xa_i_VLA
	lda		=65b24,du		=o404000
	jump		xa_transfer

xa_i_VLA:
	lda		=o406000,du
	jump		xa_transfer

xa_r:
	if_VLA		op1,xa_r_VLA
	lda		=33b24,du		=o204000
	jump		xa_transfer

xa_r_VLA:
	lda		=o206000,du
	jump		xa_transfer

xa_d:
	if_VLA		op1,xa_d_VLA
	lda		=17b24,du		=o104000
	jump		xa_transfer

xa_d_VLA:
	lda		=o106000,du
	jump		xa_transfer

xa_c:
	if_VLA		op1,xa_c_VLA
	lda		=9b24,du		=o044000
	jump		xa_transfer

xa_c_VLA:
	lda		=o046000,du
	jump		xa_transfer

xa_l:
	if_VLA		op1,xa_l_VLA
	lda		=5b24,du		=o024000
	jump		xa_transfer

xa_l_VLA:
	lda		=o026000,du
	jump		xa_transfer

xa_h:
	push_length	arg1

	bump		op1
	lda		op1

	emit_inst		1
	als		4

	ora		6144,du		=o014000

xa_transfer:
	push_array_size	arg1
	bump		arg1
	load_pr		pr2,arg1
	ldq		op1

	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_array_xmit
	free_regs
	drop		arg1
	return

read_vector:
	proc		1

	push_output
	flush_ref		op1
	swap		arg1		"make consistent with write_vector
	jump		vector_common

write_vector:
	proc		2

vector_common:
	bump		arg1

	load_pr		pr2,arg1

	load		q,arg2		" collapsed implied loop provides the count

	swap		arg1		"Note arguments remain swapped

	dt_jump1		op1,(xv_i,xv_r,xv_d,xv_c,xv_l,xv_h,xv_t)

xv_i:
xv_t:
	if_VLA		op1,xv_i_VLA
	lda		=65b24,du		=o404000
	jump		xv_transfer

xv_i_VLA:
	lda		=o406000,du
	jump		xv_transfer

xv_r:
	if_VLA		op1,xv_r_VLA
	lda		=33b24,du		=o204000
	jump		xv_transfer

xv_r_VLA:
	lda		=o206000,du
	jump		xv_transfer

xv_d:
	if_VLA		op1,xv_d_VLA
	lda		=17b24,du		=o104000
	jump		xv_transfer

xv_d_VLA:
	lda		=o106000,du
	jump		xv_transfer

xv_c:
	if_VLA		op1,xv_c_VLA
	lda		=9b24,du		=o044000
	jump		xv_transfer

xv_c_VLA:
	lda		=o046000,du
	jump		xv_transfer

xv_l:
	if_VLA		op1,xv_l_VLA
	lda		=5b24,du		=o024000
	jump		xv_transfer

xv_l_VLA:
	lda		=o026000,du
	jump		xv_transfer

xv_h:
	push_length	arg2

	bump		op1
	lda		op1

	emit_inst		1
	als		4

	ora		6144,du		=o014000
	pop		op1

xv_transfer:

	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_array_xmit
	free_regs
	drop		op1
	return

endfile:	proc		2

	swap		arg1
	unless_dt		int,endfile.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

endfile.p:
	print		302,op1
	return

rewind:	proc		2

	swap		arg1
	unless_dt		int,rewind.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

rewind.p:
	print		302,op1
	return

backspace:
	proc		2

	swap		arg1
	unless_dt		int,backspace.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

backspace.p:
	print		302,op1
	return

margin:	proc		2

	unless_dt		int,margin2.p
	swap		arg1
	unless_dt		int,margin1.p
	swap		arg1

	load		q,arg1
	push_builtin	ps
	lda		arg2
	sta		op1+margin_slot
	lda		=3b27,du		=o001400
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

margin1.p:
	print		302,op1
	return

margin2.p:
	print		331,op1
	return

openfile:	proc		3

	swap		arg1
	unless_dt		int,openfile1.p
	swap		arg1
	swap		arg2
	unless_dt		char,openfile2.p
	if_array		openfile2.p
	swap		arg2
	unless_dt		char,openfile3.p
	if_array		openfile3.p

	push_length	arg2
	push_builtin	ps
	load_pr		pr2,arg2
	spri2		op1+file_name_slot
	load_pr		pr2,arg3
	spri2		op1+file_type_slot
	lda		op2
	sta		op1+string_length_slot
	lda		=5b28,du		=o001200
	load		q,arg1
	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

openfile1.p:
	print		302,op1
	return

openfile2.p:
	print		332,op1
	return

openfile3.p:
	print		333,op1
	return

open:
close:
	proc		4

"			arg1 - file number expre. must be integer
"			arg2 - job_bits const generated by compiler.
"			arg3 - open/close stmnt const generated by compiler.
"			arg4 - A count. Number of fields that follow. (This count is never used.
"				In fact, it is overwritten by the ps_area_ptr builtin.)
"			arg5 to argN - Pairs of values. They are processed top down and then
"				popped off the stack.
"			     op2 - A value. See individual field (below) for data type, etc.
"			     op1 - A count. Implementation defined index value for the field.

	use_eaq
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_get_area_ptr	" returns ptr in PS.buffer_p
	free_regs

"		Make the ps_area_ptr builtin arg4. Pop original arg4.

	pop		op1
	push_builtin	ps_area_ptr

	lda		arg3		" fields-specified bit string
	emit_inst		1
	eax1		0		" index value for fields-specified bit string

	load_pr_value	pr3,arg4		" load pr3
	tsx0		pr0|ftn_open_element

"		Note - This loop is order sensitive. As it processes a pair of values on the stack,
"			they are popped. The loop terminates when arg4 is the top of the stack.

open_loop:
	push_operand	open_return	" if no more, then done
	push_operand	open_loop.e	" if no more, then error

	jump_indexed	op1,(opencase1,opencase2,opencase3,opencase4,opencase5,opencase6,opencase7,opencase8,opencase9,opencase10,opencase11,opencase12,opencase13,opencase14)

opencase1:		" status
opencase2:		" io switch
opencase3:		" attach
opencase4:		" file
opencase5:		" mode
opencase6:		" access
opencase7:		" form
opencase13:		" blank
	swap		op2			" check data type
	unless_dt		char,open_loop1.p
	push_length	op1
	load_pr		pr2,op2			" point to string
	load_pr_value	pr3,arg4			" reloads pr3 only if necessary
	load		q,op1			" load string length
	eax1		op3			" load index value into xr

	tsx0		pr0|ftn_open_element
	free_regs
	pop		op3			" pop all three things
	jump		open_loop

opencase8:		" recl
	swap		op2			" check data type
	unless_dt		int,open_loop2.p

	load		q,op1			" load the value

	load_pr_value	pr3,arg4			" reloads pr3 only if necessary

	eax1		op2			" load index value into xr

	tsx0		pr0|ftn_open_element
	pop		op2			" pop value and index
	jump		open_loop

opencase9:		" binary
opencase10:		" prompt
opencase11:		" carriage
opencase12:		" defer
	swap		op2			" check data type

	unless_dt		logical,open_loop3.p

	load		a,op1

	load_pr_value	pr3,arg4			" reloads pr3 only if necessary

	eax1		op2			" load index value into xr

	tsx0		pr0|ftn_open_element
	pop		op2			" pop value and index
	jump		open_loop

opencase14:		" unit
	swap		op2
	swap		arg1
	pop		op2
	jump		open_loop

open_loop.e:
	print		349
	return

open_loop1.p:
	print		351,op1
	pop		op2
	jump		open_loop

open_loop2.p:
	print		352,op1
	pop		op2
	jump		open_loop

open_loop3.p:
	print		353,op1
	pop		op2
	jump		open_loop

open_return:
	swap		arg1			" get file number expre.
	unless_dt		int,open.p		" must be integer
	load		q,op1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

open.p:
	print		302,op1
	return

inquire:
	proc		3

	" arg1 - job bits
	" arg2 - fields specified mask
	" arg3 - field count

	" First get pointer to work area.

	use_eaq
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_get_area_ptr
	free_regs

	pop		op1		" Pop field count
	push_builtin	ps_area_ptr	" This becomes arg3

	" Next emit fields-specified mask.

	lda		arg2		" The mask
	emit_inst		1
	eax1		0		" The field index

	load_pr_value	pr3,arg3		" Load pr3 with area pointer
	tsx0		pr0|ftn_inquire_element

	" Loop over the remaining operand pairs, of the form (datum, index).
	" As each pair is processed, it is popped from the stack.

inquire_loop:
	push_operand	inquire_return	" Done if no more opnds
	push_operand	inquire_loop.e	" Error if no more opnds

	jump_indexed	op1,(inquire_case_1,inquire_case_2,inquire_case_3,inquire_case_4,inquire_case_5,inquire_case_6,inquire_case_7,inquire_case_8,inquire_case_9,inquire_case_10,inquire_case_11,inquire_case_12,inquire_case_13,inquire_case_14,inquire_case_15,inquire_case_16,inquire_case_17,inquire_case_18,inquire_case_19,inquire_case_20,inquire_case_21,inquire_case_22,inquire_case_23,inquire_case_24,inquire_case_25,inquire_case_26)


inquire_case_4:		" file
inquire_case_6:		" access
inquire_case_7:		" form
inquire_case_13:		" blank
inquire_case_21:		" name
inquire_case_22:		" sequential
inquire_case_23:		" formatted
inquire_case_24:		" unformatted
inquire_case_26:		" direct

	" First check data type.

	swap		op2
	unless_dt		char,inquire_loop.not_char

	" Load pointer to string in pr2, length of string in Q.

	push_length	op1
	load_pr		pr2,op2
	load		q,op1

	load_pr_value	pr3,arg3		" Reload pr3 if necessary
	eax1		op3		" Load field index
	tsx0		pr0|ftn_inquire_element
	free_regs

	pop		op3		" Pop all three operands
	jump		inquire_loop


inquire_case_8:		" recl
inquire_case_19:		" number
inquire_case_25:		" nextrec

	" First check data type.

	swap		op2
	unless_dt		int,inquire_loop.not_int

	load_pr		pr2,op1		" Load pointer to datum

	load_pr_value	pr3,arg3		" Reload pr3 if necessary
	eax1		op2		" Load field index
	tsx0		pr0|ftn_inquire_element
	free_regs

	pop		op2		" Pop both operands
	jump		inquire_loop


inquire_case_14:		" unit

	" First check data type.

	swap		op2
	unless_dt		int,inquire_loop.not_int

	load		q,op1		" Load unit number in Q

	load_pr_value	pr3,arg3		" Reload pr3 if necessary
	eax1		op2		" Load field index
	tsx0		pr0|ftn_inquire_element

	pop		op2		" Pop both operands
	jump		inquire_loop


inquire_case_17:		" exist
inquire_case_18:		" opened
inquire_case_20:		" named

	" First check data type.

	swap		op2
	unless_dt		logical,inquire_loop.not_logical

	load_pr		pr2,op1		" Load pointer to datum

	load_pr_value	pr3,arg3		" Reload pr3 if necessary
	eax1		op2		" Load field index
	tsx0		pr0|ftn_inquire_element
	free_regs

	pop		op2		" Pop both operands
	jump		inquire_loop


inquire_case_1:		" Invalid inquire fields
inquire_case_2:
inquire_case_3:
inquire_case_5:
inquire_case_9:
inquire_case_10:
inquire_case_11:
inquire_case_12:
inquire_case_15:
inquire_case_16:
	print		357,op1
	return


inquire_loop.e:
	print		356
	return


inquire_loop.not_char:
	print		351,op1
	pop		op2
	jump		inquire_loop


inquire_loop.not_int:
	print		352,op1
	pop		op2
	jump		inquire_loop


inquire_loop.not_logical:
	print		353,op1
	pop		op2
	jump		inquire_loop


inquire_return:
	push_count	0		" Dummy unit number
	load		q,op1		" Get unit in Q
	lda		arg1		" Get job bits in A
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

closefile:
	proc		1

	unless_dt		int,closefile.p

	load		q,arg1
	lda		=3b28,du		=o000600
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	return

closefile.p:
	print		302,arg1
	return

iostat:
	proc		0

	push_output
	unless_dt		int,iostat.p

	push_builtin	ps
	load_pr		pr2,arg1
	spri2		op1+iostat_slot
	free_regs

	return

iostat.p:
	print		350,op1
	return

record_number:
	proc		1

	unless_dt		int,record_number.p

	load		q,arg1
	push_builtin	ps
	stq		op1+record_number_slot
	return

record_number.p:
	print		304,arg1
	return

encode_string:
	proc		0
	push_output
	jump		string_common

decode_string:
string:
	proc		1

string_common:
	unless_dt		logical,string_c

	print		305,arg1

string_c:
	load_pr		pr2,arg1
	push_builtin	ps
	spri2		op1+string_slot
	free_regs
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

string_length:
	proc		1

	load		q,arg1
	push_builtin	ps
	stq		op1+string_length_slot
	return

write_internal_file:
	proc		0

	push_output
	jump		internal_file_common


read_internal_file:
	proc		1


internal_file_common:
	unless_dt		char,internal_file.p

	push_builtin	ps

	load_pr		pr2,arg1
	spri2		arg2+string_slot

	push_length	arg1
	bump		op1
	load		q,op1
	stq		arg2+string_length_slot
	pop		op1

	swap		arg1
	if_array		internal_file.array

	stz		arg1+buffer_size_slot
	jump		internal_file.ret

internal_file.array:
	push_array_size	op1
	load		q,op1
	stq		arg1+buffer_size_slot

internal_file.ret:
	free_regs
	return


internal_file.p:
	error		303

terminate:
	proc		0

	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_terminate
	free_regs
	return

return:	proc		0

	unless_main	quick_return

	tra	pr0|fortran_end

	discard_state
	return

quick_return:
	push_builtin entry_info

	rtcd		op1

	discard_state
	return

pause:	proc		1

	push_length	arg1
	if		op1,=,0,short_pause

	load_pr		pr2,arg1
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)

pause.1:
	tsx0		pr0|fortran_pause
	free_regs
	return

short_pause:
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)
	jump		pause.1

stop:	proc		1

	push_length	arg1
	if		op1,=,0,short_stop

	load_pr		pr2,arg1
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)

stop.1:
	tsx0		pr0|fortran_stop
	discard_state
	return

short_stop:
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)
	jump		stop.1

func_ref:	func		2

	s_call		evaluate_arglist

	push_output
	bump		op1
	set_in_storage	op1

	increment		arg2,1	function result becomes last arg

	unless_dt		char,func_join
	push_length	op1
	unless_optype	count,func_ref.star_extent
	pop		op1

	s_call		descriptor_check

func_join:

	s_call		make_call

	return		op2		arglist temp is now op1

func_ref.star_extent:
	error		355,arg1

main:	proc		2

	emit_entry_defs
	emit_data		1
	oct		000000300000	" revision_1, entry_defs

	s_call		make_entry
	s_call		prepare_for_namelists
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

subr:	proc		2

	emit_entry_defs
	emit_data		1
	oct		000000300000	" revision_1, entry_defs

	s_call		make_entry
	s_call		make_quick_entry
	s_call		prepare_for_namelists
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

func:	proc		2

	emit_entry_defs
	emit_data		1
	oct		000000320000	" revision_1, entry_defs, func

	s_call		make_entry
	s_call		make_quick_entry
	s_call		prepare_for_namelists
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

block_data:
	proc		0

	return

make_entry:
	assign_entry	arg1

	emit_inst		1
	eax7		0

	epp2		pr7|stack_header.pl1_operators_ptr,*

	if_needs_descriptors arg1,make_et_desc
	tsp2		pr2|ext_entry
	jump		make_et_join

make_et_desc:
	tsp2		pr2|ext_entry_desc

make_et_join:
	copy		arg2
	multiply		op1,2
	zero		op1
	pop		op1

	emit_data		1
	zero

	emit_profile_entry		" if we will do long_profile set it up

	unless_hfp	make_et_init_auto
	tsx0		pr0|enter_HFP_mode

make_et_init_auto:
	call		init_auto

	unless_cleanup	make_et_no_cleanup	"no cleanup needed

	tsx0		pr0|fort_cleanup
	emit_cleanup_args

make_et_no_cleanup:
	push_builtin	null
	push_builtin	ps

	if		op2,=,op1,pop_ps

	load_pr		pr2,op1
	spri2		pr6|ps_ptr
	spri6		pr2|0
	free_regs

pop_ps:	pop		op2
	unless_storage_created make_et_descp		is there external storage?
	reserve_regs	all			calling external routines
	tsx0		pr0|fort_storage		request storage create/init
	emit_storage_args
	free_regs

make_et_descp:

	epp1		pr6|stack_frame.arg_ptr,*

	unless_needs_descriptors arg1,make_et_ret

	epp3		pr6|descriptor_ptr,*	Load desc ptr

make_et_ret:
	s_return

prepare_for_namelists:
	unless_namelist_used  pfn_ret

	push_builtin	star_symbol
	push_builtin	ps

	load_pr		pr2,op2
	spri2		op1+2

	set_runtime_block_loc

	adwp2		0,du
	spri2		op1+4

	free_regs
	pop		op2

pfn_ret:

	s_return

init_auto:
	proc		0

	push_builtin	auto_overlay

	push_length	op1

	if		op1,=,0,init_return

	push_builtin	auto_template

	emit_eis

	mlr		(pr),(pr),fill(0)
	desc9a		op1
	desc9a		op3

init_return:
	return

make_quick_entry:
	copy		arg1	Copy original symbol for entry
	get_quick_label	arg1	replace arg1 with label for quick entry pt

"If storage space needs to be created then we substitute fort_return_mac for
"return_op to get the storage released at the end of the external call.

	unless_cleanup	mqe_no_storage
	epp2		pr0|fort_return_mac
	jump		mqe_end_storage

mqe_no_storage:
	epp2		pr0|return_op

mqe_end_storage:

	label		arg1
	push_builtin	entry_info

	spri2		op1
	spri1		op1+2	Store arg pointer
	arg_ptr_in_pr1		Update machine state

	unless_needs_descriptors op2,mqe_no_desc
	spri3		op1+4	Store descriptor pointer
	desc_ptr_in_pr3		Update machine state

mqe_no_desc:
	swap		op2	Get original entry symbol on top
	pop		op1	Pop it off

	s_return

process_param_list:
	proc		1

ppl.loop:
	push_operand	ppl.done
	jump		ppl.loop

ppl.done:
	check_parameters
	return

descriptor_check:

	" Subroutine to check to see whether or not descriptors might be
	" required for a subroutine call or function reference.  In ansi66
	" mode, we print a message warning the user that descriptors might
	" be necessary.  In ansi77 mode, we go ahead and cause descriptors
	" to be used (silently).  In either mode, if the called subprogram
	" is local to this compilation, then it will already have been taken
	" care of by the storage allocator.

	" Called from func_ref (to check the function return value of
	" character valued functions) and from evaluate_arglist.

	" Assumes that arg1 is the external symbol.

	if_local		arg1,descriptor_check.return
	if_needs_descriptors arg1,descriptor_check.return
	if_ansi77		descriptor_check.set

	" Print a warning that this call might need descriptors

	print		348,arg1
	jump		descriptor_check.return

descriptor_check.set:

	" Cause descriptors to be generated for this call

	set_needs_descriptors		" arg1 implied

descriptor_check.return:
	s_return

increment_polish:
	proc		0

	skip_data

	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

label_operator:
	proc		1

	label		arg1

	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

stat:	proc		0

	shorten_stack

	stat

	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

call:	proc		2

"
	s_call		evaluate_arglist
	s_call		make_call

	return

evaluate_arglist:
	push_operand	check_args
	if_optype		bif,conv_bif
	if_optype		external,conv_external

	unless_dt		char,evaluate_arglist

	" If argument is of data type character, check to see if we should
	" warn the user about descriptors or just use them.

	s_call		descriptor_check

	jump		evaluate_arglist

conv_bif:
	call		cv_bif_to_external
	jump		evaluate_arglist

conv_external:
	if_parameter	op1,evaluate_arglist " parameters already are external variables

	call		make_external_variable
	jump		evaluate_arglist

check_args:
	check_arg_list
	s_return

cv_bif_to_external:
	func		1

	push_bif_index	arg1	" get index into big table
"				now get offset into vector
	push_count_indexed	op1,(38,39,40,19,2,12,21,3,13,4,14,5,15,7,17,23,41,42,43,1,11,20,0,0,0,0,0,0,0,0,0,0,0,0,57,58,10,44,45,46,6,16,22,9,18,24,8,0,47,0,0,0,0,0,48,0,0,49,26,27,28,29,30,31,0,0,32,50,0,0,0,0,36,34,37,35,33,51,52,53,54,55,56,0,0,0,0,59,60,61,62,0,0)

	if		op1,=,0,not_external_bif

	reserve_regs	(x2,pr2,pr4)
	eax2		op1
	tsx0		pr0|get_math_entry

	jump		ext_join

not_external_bif:
	error		461,arg1

make_external_variable:
	func		1

	load_pr		pr2,arg1

ext_join:
	push_builtin	null_ptr
	push_temp		4
	bump		op1
	bump		op1

	spri2		op1
	load		aq,op2
	staq		op1+2

	free_regs
	return		op1

make_call:
	copy		arg2		get nargs

	unless_needs_descriptors	arg1,inc_for_hdr
	multiply		op1,2

inc_for_hdr:
	increment		op1,1		(for header)

	unless_parameter	arg1,double_count
	increment		op1,1		for display pointer

double_count:
	multiply		op1,2		double to get size of temp

	if_local		arg1,local_call

	push_temp		var

	bump_args

	store_arg_addrs

	make_descriptors

	use_eaq				" any temps that need to be saved...
	reserve_regs	indices		... must be saved now
	free_regs				we still might need xregs for > 16K addressing

	eax1		op1

	copy		arg2
	multiply		op1,2048
	fld		op1
	pop		op1

	load_pr		pr2,arg1

	reserve_regs	all		all regs may be used by the call programs

	if_parameter	arg1,call_variable

	if_needs_descriptors	arg1,call_ext_desc

	tsx0		pr0|call_ext_out
	jump		call_join

call_ext_desc:
	tsx0		pr0|call_ext_out_desc
	jump		call_join

call_variable:
	if_needs_descriptors	arg1,call_variable_desc

	tsx0		pr0|call_var
	jump		call_join

call_variable_desc:
	tsx0		pr0|call_var_desc

call_join:
	free_regs
	free_temp		op1		" free argument list temporary
	free_descriptors
	drop_args
	s_return


local_call:
	bump_args

	if_constant_addrs	use_itp

	push_temp		var

	store_arg_addrs

	make_descriptors

	use_eaq

	copy		arg2
	multiply		op1,2048
	fld		op1
	pop		op1

	staq		op1
	load_pr		pr1,op1

	unless_needs_descriptors arg1,lc_no_desc

	lda		pr1|0	Get 2*nargs in au
	epp3		pr1|2,au	Load descriptor pointer

lc_no_desc:
	get_quick_label	arg1	replace external ref with label for quick entry point

	reserve_regs	all-pr4

	tsp2		arg1

	free_regs
 	free_temp		op1		" free argument list temporary
	free_descriptors
	drop_args
	s_return

use_itp:
	gen_itp_list		replaces top of stack with constant arg list
	use_eaq
	load_pr		pr1,op1

	unless_needs_descriptors arg1,itp_no_desc

	lda		pr1|0	Get 2*nargs in au
	epp3		pr1|2,au	Load descriptor pointer

itp_no_desc:
	get_quick_label	arg1	replace external ref with label for quick entry point
	reserve_regs	all-pr4
	tsp2		arg1
	free_regs
	free_descriptors
	drop_args
	s_return

chain:	proc		3

	swap		arg1

	if_dt		char,chain2
	unless_dt		int,chain_path.p
	unless_array	chain_path.p

chain2:
	swap		arg1

	swap		arg2

	if_dt		char,chain3
	unless_dt		int,chain_sys.p
	unless_array	chain_sys.p

chain3:
	swap		arg2

	copy		arg3
	increment		op1,47
	push_temp		var

chain_fill:
	use_eaq

	ldq		arg3
	stq		op1

	emit_eis
	mlr		(pr),(pr)
	desc9a		arg1,168
	desc9a		op1+1,168

	ldaq		arg2
	staq		op1+45

	load_pr		pr2,op1
	emit_inst		1
	eax0		0

chain_next_file:

	push_operand	chain_ret
	ldq		op1
	stq		op2+47,0
	pop		op1
	eax0		1,0
	jump		chain_next_file

chain_ret:
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)

	tsx0		pr0|fortran_chain
	free_regs
	free_temp		op2		" free arglist temp
	reset_eaq

	return

chain_path.p:
	print		335,op1
	return

chain_sys.p:
	print		336,op1
	return

endunit:	proc		0

	end_unit
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

non_executable:
	proc		0
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

no_op:	proc		0
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

form_VLA_packed_ptr:
	func		1
	load		q,arg1
	div		pr0|VLA_words_per_seg
	emit_inst		2
	als		18
	llr		18
	return		q

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

opt_subscript:
	proc		3

	optimized_subscript
	return

left_shift:
	func		2

	load		q,arg1
	qls		arg2

	return		q

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

right_shift:
	func		2

	load		q,arg1
	qrs		arg2

	return		q

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

store_zero:
	proc		0

	push_output

	stz		arg1
	flush_ref		arg1

	return

storage_add:
	proc		1

	push_output

	note_eligible_ind_var_use

	if_global		arg2,storage_add.global

	load		q,arg1
	asq		arg2
	flush_ref		arg2

	return

storage_add.global:
	increment_index
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

storage_sub:
	proc		1

	push_output

	load		q,arg1
	ssq		arg2
	flush_ref		arg2

	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

neg_storage_add:
	proc		1

	push_output

	note_eligible_ind_var_use

	if_global		arg2,neg_storage_add.global

	lcq		arg1
	asq		arg2
	flush_ref		arg2

	return

neg_storage_add.global:
	decrement_index
	return

storage_add_one:
	proc		0

	push_output

	note_eligible_ind_var_use

	if_global		arg1,storage_add_one.global


	aos		op1
	flush_ref		op1

	return

storage_add_one.global:
	push_builtin	one
	swap		arg1
	increment_index
	return

read_namelist:
write_namelist:
namelist:	proc		1

	push_builtin	ps
	load_pr		pr2,arg1
	spri2		op1+namelist_slot

	free_regs
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

sub_index:
	func		1
	if_eaq		q,arg1,subscript_in_q	" easy, subscript is already in q
	push_output

	sub_index					" loads op1 into any xr, sets
						" output.value_in.x
	return		op1

subscript_in_q:
	return		q

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

loop_end:
	proc		var

	drop_all_counts
	return

cat:	func		var

	pop		arg1
	set_next_operand	1

	push_operand_count
	decrement		arg1,1

	" arg1 is now the number of strings to be moved.  Push all operands
	" next, so start_cat can look at them.

cat.push_all_operands:
	push_operand	cat.all_operands_pushed
	jump		cat.push_all_operands

cat.all_operands_pushed:
	start_cat		cat.dont_move_op1

	" Move all operands, starting with the first one.  Get the result
	" temp (which was pushed by start_cat) on the stack as arg1.  Get
	" the count of operands to move on the stack as arg2.

	swap		arg2
	pop		arg3
	swap		arg1
	set_next_operand	1
	jump		cat.process_next_operand

cat.dont_move_op1:

	" Move all operands EXCEPT the first one.  Get the result temp on
	" the stack as arg1.  Get the first operand on the top of the
	" stack for data type checking and address manipulation.  Get the
	" count of operands to move on the stack as arg2.

	swap		arg3
	pop		arg4
	swap		arg1
	swap		arg2
	unless_dt		char,cat.bad_data_type
	set_next_operand	2
	decrement		arg2,1
	jump		cat.adjust_result_address

cat.process_next_operand:

	" Get the next operand on top of the stack, check its data type,
	" and emit code to move it to the end of the result temp.

	push_operand
	unless_dt		char,cat.bad_data_type

	emit_eis		equal_lengths
	mlr		(pr),(pr),fill(040)
	desc9a		op1
	desc9a		arg1

	" If that was the last operand to be moved, quit.

	decrement		arg2,1
	if		arg2,=,0,cat.moved_last_operand

cat.adjust_result_address:
	continue_cat
	jump		cat.process_next_operand

cat.moved_last_operand:

	" All operands have been moved.  Clean up, and return the temp.

	finish_cat
	return		arg1

cat.bad_data_type:
	error		354,op1

lhs_fld:
	proc		3

	push_output
	swap		arg3		"put the stack in expected order
	lhs_fld
          return

lhs_.p1:
	error		359,arg1

lhs_.p2:
	error		359,arg2

lhs_.p3:
	error		360,arg3

lhs_.p4:
	error		361

load_xreg:
	proc		2

	load_xreg
	return

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *

load_preg:
	proc		1

	load_preg

	return

do:	error	330,ascii,do
jump_logical:
	error	330,ascii,jump_logical
xmit_scalar:
	error	330,ascii,xmit_scalar
xmit_array:
	error	330,ascii,xmit_array
xmit_vector:
	error	330,ascii,xmit_vector
sf_def:	error	330,ascii,sf_def
sf:	error	330,ascii,sf
item:	error	330,ascii,item
exit:	error	330,ascii,exit
eol:	error	330,ascii,eol
subscript:
	error	330,ascii,subscript
substr:	error	330,ascii,substr
block_if:	error	330,ascii,block_if
else_if:	error	330,ascii,else_if
else:	error	330,ascii,else

	end




		    fort_optimizer.pl1              11/10/88  1423.8r w 11/10/88  1336.7     2338209



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



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7442), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 488.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */
fort_optimizer:
     procedure (pt1);

/****^
Written:	24 January 1978 by Richard A. Barnes

Modified: 16 Apr 86, AFG - 488: Set "used" bit for symbols used as variable
	offsets in folded array_ref's.
Modified: 18 Sep 84, HH - 441: Temporarily bypass bug by disabling 'constant_assign'.
Modified: 22 Jun 84, MM - Install typeless functions support.
Modified: 28 Mar 84, HH - Install HFP support.
Modified: 27 Jul 83, HH - 391: Fix substrings of 'constant_value' variables.
Modified:	17 Jun 83, HH - 383: Add support for 'process_param_list_op'.
Modified: 31 Jan 83: HH - Install LA/VLA support.
Modified: 20 Dec 1982, 359: TO - read_namelist needs processing in
	     'optimize_flow_unit' to give its namelist variables a 'set'
	     context.
Modified: 29 May 1982, TO - 'build_flow_units' was not calling
	     'connect_jump_assigned' unless both an 'assign' and a 'goto'
	     were seen.  It should have been either.
Modified: 13 April 1982, TO - Modify message 384 call to include range of 
	lines which are being removed.
Modified: 15 March 1981, HH - Fix bug 263:  make 'constant_expression' trap
          arithmetic exceptions during constant folding.
Modified: 28 October 1981, CRD - Support for the inquire statement.
Modified: 20 October 1981, CRD - Internal files.
Modified: 3 September 1981, CRD - Fix bug 337.  Changed reduce not to drop ref
	counts when unthreading, but rather have reduce_strength do it later.
	If the expression is freed in the interim, the reference counts will
	not have been spuriously decremented.
Modified: 2 September 1981, CRD - Fix bug 334 by eliminating special case for
	equal_op and not_equal_op in analyze_loop_index_values.  The special
	case was apparently added (by RAB on 1 December 1979) to improve
	object code, but it also introduces a bug.  Since no one remembers
	the intent of the special case, it is being removed at the risk of
	losing some optimization.
Modified: 31 August 1981, CRD - Change make_jump_to to insert another
	opt_statement, so that derive_insert_for_bt does not use the
	previous flow unit by mistake.
Modified: 31 July 1981, CRD - Remove optimize_jump.  Logic will be placed in
	cg macros, to avoid problems with discarded machine states.
Modified: 28 July 1981, CRD - Change handling of assing_label operator in
	build_flow_units -- operand is not always an executable label.
Modified: 14 July 1981, CRD - Fix bug in which reduce_strength uses the wrong
	induction variable when eliminating sub_index operators.
Modified: 12 May 1981, CRD - Add equiv_op, not_equiv_op.
Modified: 13 April 1981, CRD - Fix unreported bug in which opt_subscripts are
	not properly reduced to constants if the constant is a result of
	folding and there is no sub_index operator.
Modified: 25 February 1981, CRD - Minor auditing changes.
Modified: 21 January 1981, CRD - Remove the pseudo-recursive free_expression
	subroutine introduced in the fix to bug 271.  Fix bug 271 instead by
	freeing the operator associated with a strength reduction frame if
	its output has a zero reference count.  This fixes bug 304.
Modified: 5 January 1981, CRD - Remove some invalid PL/I in
	constant_expression and constant_assign.
Modified: 17 December 1980, CRD - Fix bug 280.  This was motivated
	by the addition of block IF statements.
Modified: 11 December 1980, CRD - Fix bug 299.  New back targets
	created by the optimizer did not have flow_unit.has_label
	set.
Modified: 9 December 1980, CRD to extend arrays for new block_if,
	else_if, and else operators.
Modified: 1 December 1980, CRD to fix a bug in index_value_analysis
	in which the input to an increment operator was not
	disqualified if the output was not eligible.
Modified: 25 November 1980, CRD to fix a bug in process_frozen_for_do
	in which the assignment was erroneously eliminated if the
	rhs was a symbol whose sets were moved out of the loop.
Modified: 24 November 1980, CRD to permit constant_expression to fold
	relational operators, and to add optimize_jump.
Modified: 8 October 1980 by CRD to fix bugs 262 and 264.  The special
	handling of "symbol = constant" is now done by
	constant_assign.  Character constants are now treated
	properly.
Modified: 1 October 1980 by CRD to add free_expression, and to change
	reduce_strength to call it when an equivalent induction
	variable has been found.
Modified: 16 September 1980 by CRD to properly free operators that
	are unthreaded by reduce and whose operators are in loop
	end lists.
Modified: 16 September 1980 by CRD to change search_for_equivalent to
	not use the global variable which, and to change
	record_secondaries to not record symbols with coordinate 0.
Modified: 28 July 1980 by CRD to fix use_inputs not to replace the
	first operand of an opt_subscript operator with a constant,
	and to make it set the allocate bit for the constant node.
Modified: 22 July 1980 by CRD to fix optimize_flow_unit not to
	replace the first operand of an opt_subscript operator with
	a constant.
Modified: 18 June 1980 by CRD to make constant_expression work on
	sub_index operators that are not offsets of opt_subscript
	operators.
Modified: 16 June 1980 by CRD to fix bug 261 (machine state not
	cleared before loop entry flow units).
Modified:	14 March 1980 by RAB to add case to try to calculate range
	by considering vars that assign to the var in question.
	Also unreferenced vars in fort_optimizer were cleaned out,
	and print_hash_bucket_meters was moved to after the include
	files.
Modified:	17 February 1980 to make hash use addition rather than
	exclusive or to derive mod_2_sum.
Modified:	13 February 1980 by RAB to allow for optional metering of
	the primary list hash buckets.
Modified:	9 February 1980 by RAB to change index_value_analysis to
	allow induction variables that are busy_on_exit from a loop
	to be kept in an index register if they are known to be
	non-negative.
Modified:	2 February 1980 by RAB to recognize LHS of assignment of
	form i = j as possible induction variable.  Add ass_chain.
Modified:	31 January 1980 by RAB to add is_suitable_loop_exit to improve
	check made in calculate_range_for_counter.
Modified:	26 January 1980 by RAB to add calculate_range_for_counter and to
	fix minor glitch in remove_dead_assignments.
Modified:	9 January 1980 by RAB - to fix bug caused when flow_unit.n_in_loop_end
	exceeds 127 -- reference counts get left too high because size condition
	occurs on operator.number.
Modified:	30 December 1979 by RAB to turn on the induction variable
	bit for all new induction variables found by add_potential_induction_var.
Modified:	27 December 1979 by RAB to allow induction variables that
	are incremented by a non_constant to be kept in an index
	register as long as they are not used in a comparison for
	other than equality.
Modified:	18 December 1979 by RAB to complete register optimizer
	changes and to pool free lists by size for those containing
	items of size 2 - 4.
Modified:	1 December 1979 by RAB to not bother calculating range info
	for induction vars involved in equals or not_equals comparisons
	and to require that induction_vars involved in jump_arithmetic
	be fixed bin(17) in order to be kept in an index register.
Modified:	24 September 1979 by RAB to improve fix to bug 237.
Modified:	20 September 1979 by RAB to add index_value_analysis for register optimizer.
Modified:	17 September 1979 by RAB - to make first set of changes in
	preparation for register optimization.
Modified:	13 September 1979 by RAB - to fix bug 237 in which the optimizer
	does not realize that real and complex variables may be equivalenced
	together and be simultaneously defined.  This is the only case
	of mixed data type aliasing in the language.
Modified:	1 September 1979 by RAB - to fix 234 in which the optimizer
	mistakenly assumes that the encode statements completely sets
	its target buffer, and so will mistakenly remove preceding
	assignments to the buffer if it is not referenced in between.
Modified:	14 August 1979 by RAB - to implement most of Fortran 77 char mode.
	Data flow analysis has been greatly simplified by using flow_unit.always_completely_set.
	flow_unit.dim_or_alias_or_not_set has been removed along with various masks.
Modified:	13 August 1979 by RAB to change last_assigned_op from 95 to 97.  This
	adds cat_op and substr_op but does not completely implement substr_op.
Modified:	4 July 1979 by RAB to fix 218 in which the loop_end_chains were
	not necessarily built after the bodies of all contained loops.
	This was fixed by moving loop_end_chain info from loop node
	to flow_unit node, by making sure loop.last_unit was good
	for all contained loops as well as for this loop, and
	by placing in loop_end list for the current loop all
	temps used_across_loops in the bt_list that are already
	in a loop_end list for an inner loop.
Modified:	28 June 1979 by RAB - to speed up compute_busy_on_exit with
	flow_unit.dim_or_alias_or_not_set.
Modified:	27 June 1979 by RAB - to optimize goto a goto statement.
Modified:	20 June 1979 by RAB to fix 214 in which the optimizer
	builds incorrect flow information for err=, end=, and
	assigned goto's.
Modified:	20 June 1979 by RAB to improve the busy_on_exit algorithm
	so that dimensioned static variables are not considered
	busy_on_exit from a subprogram unless they are used
	in the subprogram.
Modified:	20 June 1979 by RAB to improve the busy_on_exit algorithm so that
	scalar static variables are not considered busy_on_exit from a
	subprogram unless they might be used in a future invocation of the
	subprogram before they are set.
Modified:	2 June 1979 by RAB to greatly speed up intersection by
	use of flow_unit.is_active_operator -> obits and
	operator.coordinate
Modified:	27 May 1979 by RAB to diagnose a loop without an exit
Modified: 25 May 1979 by RAB to fix bug in redirect_edge
Modified:	19 May 1979 by RAB to improve remove_loop
Modified:	16 May 1979 by RAB to initialize loop.has_side_effects
Modified:	8 April 1979 by RAB to make minor improvements in strength
	reduction and to note why commoning MUST occur while
	candidates for strength reduction are being found
Modified:	26 March 1979 by RAB to recompute usage information before
	removing dead assignments
Modified:	1 March 1979 by RAB to remove all assignment made dead
	by constant propagation.
Modified:	10 December 1978 by RAB - to change named constant test
	from symbol.initialed to symbol.initial ^= 0 because of
	parse's special handling of zero.
Modified: 06 December 1978 by PES - for %options and %globals.
Modified: 25 October 1978 by PES- for large common and arrays.
Modified:	27 September 1978 by RAB to improve fix to 187
Modified:	23 September 1978 by RAB to fix 187
	(back_target not necessarily before every flow_unit in a loop)
****/

dcl  pt1 pointer;					/* ptr to shared_globals */

dcl  adam_loop pointer;				/* ptr to non_iterative loop representing the subprogram */
dcl  alias_mask bit (7) aligned internal static options (constant) initial ((7)"1"b);
dcl  aliasable_mask (0:7) bit (max_sym) aligned based (aliasable_mask_p);
dcl  aliasable_mask_p pointer;			/* ptr to aliasable_mask */
dcl  assignment_class fixed binary (18) internal static initial (4);
dcl  always_safe_to_move_class fixed binary (18);		/* ops in this and lower classes may be moved from
						   nonarticulation blocks */
dcl  cannot_fault_class fixed binary (18) internal static initial (1);
dcl  cs pointer;					/* ptr to cur_subprogram */
dcl  consolidating bit (1) aligned;			/* "1"b -- consolidate_subprogram running */
dcl  do_timings bit (1) aligned;			/* "1"b -- timing info shd be printed */
dcl  entry_unit pointer;				/* ptr to dummy entry flow unit */
dcl  exit_unit pointer;				/* ptr to dummy exit flow unit */
dcl  flow_unit_vector_p pointer;			/* ptr to flow_unit_vector */
dcl  free (2:4) pointer;				/* ptr to free lists by size */
dcl  freefu pointer;				/* ptr to free list of flow_units */
dcl  freei pointer;					/* ptr to free list of input_to nodes */
dcl  freep pointer;					/* ptr to list of partially freed primaries */
dcl  freep_tail pointer;				/* ptr to end of list of partially freed primaries */
dcl  freesrv pointer;				/* ptr to chain of free strength reduction variable nodes */
dcl  full_strength_reduction bit (1) aligned;		/* ON if we should include induction vars updated by
						   nonincrements */
dcl  function_class fixed binary (18) static initial (6);
dcl  hash_mask bit (4297) aligned;			/* mask used to speed up search for expressions available
						   for commoning */
dcl  highest_reducible_class fixed binary (18) internal static initial (4);
dcl  i fixed binary (18);
dcl  init_frame pointer;				/* ptr to initial frame used in reduce_strength */
dcl  init_lp_frame pointer;				/* ptr to initial frame used in optimize_subprogram */
dcl  integer_scalar_mask bit (max_sym) aligned based (integer_scalar_mask_p);
dcl  integer_scalar_mask_p pointer;			/* -> integer_scalar_mask */
dcl  loop_entry_list pointer;				/* ptr to chain of loop entry units */
dcl  loop_vector_p pointer;				/* ptr to loop vector */
dcl  max_flow_units fixed binary (18);			/* length of flow_unit_vector */
dcl  max_operands fixed binary;			/* maximum value of operator.number */
dcl  max_operators fixed binary (18);			/* length of obits */
dcl  max_sym fixed binary (18);			/* maximum length of bit vectors */
dcl  meter_hash_buckets bit (1) aligned;
dcl  n_flow_units fixed binary (18);			/* number of flow units created */
dcl  n_loops fixed binary (18);			/* number of loops created */
dcl  n_operators fixed binary (18);			/* number of operators given coordinates in obits */
dcl  n_sym fixed binary (18);				/* number of symbols in bit vectors */
dcl  need_consolidation_pass bit (1) aligned;		/* "1"b -- reoptimize after all other optimizations done */
dcl  non_auto_mask bit (max_sym) aligned based (non_auto_mask_p);
dcl  non_auto_mask_p pointer;				/* -> non_auto_mask */
dcl  one fixed binary (18);				/* operand for integer constant 1 */
dcl  onep pointer;					/* ptr to one */
dcl  operand_base pointer;				/* ptr to operand region */
dcl  operand_max_len fixed binary (19);			/* maximum length of operand region */
dcl  opt_base pointer;				/* ptr to optimizer's region */
dcl  opt_max_len fixed binary (19);			/* maximum length of optimizer's region */
dcl  polish_base pointer;				/* ptr to polish region */
dcl  polish_max_len fixed binary (19);			/* maximum length of polish region */
dcl  quad_max_len fixed binary (19);			/* maximum length of quad (tuple) region */
dcl  quadruple_base pointer;				/* ptr to quad (tuple) region */
dcl  s_list pointer;				/* ptr to secondary list */
dcl  scan_bits_p pointer;				/* ptr to scan_bits */
dcl  scan_vector_p pointer;				/* ptr to scan_vector */
dcl  shared_struc_ptr pointer;			/* ptr to shared_globals */
dcl  state_discarded bit (1) aligned;			/* "1"b -- no current machine state */
dcl  temp_bits_p pointer;				/* ptr to temp_bits */
dcl  unlikely_to_fault_class fixed binary (18) internal static initial (2);
dcl  zero fixed binary (18);				/* operand for integer constant 0 */

	/* experiments seem to show that 11 is the best hash_table size,
	   although 23 looks good in some cases. */

dcl  1 bt_list_st (0:10) automatic aligned,		/* hash table for back target's primary list */
       2 bt_list pointer unaligned;

dcl  1 p_list_st (0:10) automatic aligned,		/* hash table for primary list */
       2 p_list pointer unaligned;

dcl  hash_counter (0:10) fixed binary;			/* used for metering p_list & bt_list. */

dcl  (
     full_optimization initial (1),
     common_only initial (2)
     ) fixed binary (18) internal static options (constant);

dcl  (
     complete_fu initial (1),
     partial_fu initial (2)
     ) fixed binary (18) internal static options (constant);

	/* op_class:
	   0	invalid
	   1	reducible, no chance of exception
	   2	reducible, small chance of exception
	   3	reducible, large chance of exception
	   4	reducible assignment
	   5	irreducible assignment
	   6	call or func_ref
	   7	entry point
	   8	jump
	   9	jump_arithmetic
	   10	jump_computed
	   11	jump_assigned
	   12	jump_true, jump_false
	   13	return, stop
	   14	error_label, end_label
	   15	irreducible, no special case
	   16	assign_label
	   17	end_unit
	   18	read_namelist
	   19	write_namelist
	   20	non_executable, no_op
	   21	irreducible, partially sets
	   22	inquire
	*/

dcl  op_class (109) fixed binary internal static initial (4, 2, 2, 2, 3, 3, 2, 1, 1, 1,
						/* 1 - 10 */
	1, 1, 1, 1, 1, 1, 8, 0, 9, 10,		/* 11 - 20 */
	11, 16, 15, 15, 15, 14, 14, 15, 15, 15,		/* 21 - 30 */
	(10) 15,					/* 31 - 40 */
	13, 15, 13, 0, 0, 0, 0, 3, 0, 0,		/* 41 - 50 */
	0, 6, 7, 0, 7, 7, 7, 0, 0, 6,			/* 51 - 60 */
	15, 17, 21, 21, 1, 1, 1, 1, 4, 5,		/* 61 - 70 */
	5, 5, 5, 0, 15, 15, 15, 2, 1, 1,		/* 71 - 80 */
	1, 15, 15, 15, 15, 15, 15, 12, 12, 1,		/* 81 - 90 */
	15, 18, 19, 15, 21, 1, 3, 0, 0, 0,		/* 91 - 100 */
	0, 0, 1, 1, 15, 21, 22, 7, 5);		/* 101 - 109 */

	/* xop_class:
	   1	opt_subscript
	   2	incrementing
	   3	relational
	   4	jump_arithmetic
	   5	assign
	   6	write_namelist
	   7	most operators
	   8	cat
	*/

dcl  xop_class (109) fixed binary internal static initial (5, 7, 7, 7, 7, 7, 7, 3, 3, 3,
						/* 1 - 10 */
	3, 3, 3, 7, 7, 7, 7, 7, 4, 7,			/* 11 - 20 */
	(10) 7,					/* 21 - 30 */
	(10) 7,					/* 31 - 40 */
	(10) 7,					/* 41 - 50 */
	(10) 7,					/* 51 - 60 */
	7, 7, 7, 7, 7, 1, 7, 7, 7, 2,			/* 61 - 70 */
	7, 2, 2, 7, 7, 7, 7, 7, 7, 7,			/* 71 - 80 */
	(10) 7,					/* 81 - 90 */
	7, 7, 6, 7, 7, 8, 7, 7, 7, 7,			/* 91 - 100 */
	7, 7, 7, 7, 7, 7, 7, 7, 7);			/* 101 - 109 */

dcl  scan_bits bit (max_flow_units) aligned based (scan_bits_p);
						/* bit string used in scanning flow units */
dcl  temp_bits bit (max_sym) aligned based (temp_bits_p);	/* bit string used in busy_on_exit calculation */


dcl  1 flow_unit_vector_st based (flow_unit_vector_p) aligned,
       2 flow_unit_vector (max_flow_units) pointer unaligned;
						/* vector of flow_units in ascending order by level number */

dcl  1 loop_vector_st based (loop_vector_p) aligned,
       2 loop_vector (n_loops) pointer unaligned;		/* vector of loops in descending order by nesting depth
						   and front to back */

dcl  1 scan_vector_st aligned based (scan_vector_p),
       2 scan_vector (max_flow_units) pointer unaligned;	/* vector used in scanning flow_units */

dcl  bits bit (max_sym) aligned based;			/* one bit per symbol */
dcl  dbits bit (max_flow_units) aligned based;		/* one bit per flow_unit */
dcl  lbits bit (n_loops) aligned based;			/* one bit per loop */
dcl  obits bit (max_operators) aligned based;		/* one bit per operator */

dcl  opt (0:opt_max_len - 1) fixed binary (35) aligned based (opt_base);

dcl  rands (0:operand_max_len - 1) fixed binary (18) aligned based (operand_base);

dcl  polish (0:polish_max_len - 1) fixed binary (18) aligned based (polish_base);

dcl  quad (0:quad_max_len - 1) fixed binary (18) aligned based (quadruple_base);

dcl  1 secondary based aligned,			/* must be same size as primary */
       2 next pointer unaligned,			/* must overlay primary.next */
       2 last pointer unaligned,			/* must overlay primary.last */
       2 symbol pointer unaligned,
       2 primary pointer unaligned;

dcl  1 sr_cand based aligned,				/* strength reduction candidate node */
       2 next pointer unaligned,
       2 operator pointer unaligned,			/* strength reduction candidate */
       2 which fixed binary (18),			/* operand number of induction variable */
       2 statement pointer unaligned;			/* opt_statement in which operator appeared */

dcl  1 sr_var based aligned,				/* strength reduction variable node */
       2 next pointer unaligned,
       2 variable fixed binary (18),			/* newly created variable */
       2 all_constant bit (1) aligned,			/* all terms of initialization code are constant */
       2 sign_differs bit (1) aligned,			/* sign of increment differs from sign of original */
       2 sign_unknown bit (1) aligned,			/* sign of increment has unknown relationship to
						   sign of original */
       2 updated_by pointer unaligned,			/* -> operator updating its value inside the loop */
       2 used_in pointer unaligned,			/* -> mask indicating in which loops this has been used */
       2 ninst fixed binary (18),			/* number of tuples in initializing code */
       2 tuple (8) structure aligned,
         3 operator pointer unaligned,
         3 which fixed binary (18);

dcl  1 incr based aligned,				/* increment node */
       2 next pointer unaligned,
       2 value pointer unaligned,			/* -> increment operator */
       2 statement pointer unaligned,			/* -> increment statement */
       2 var_chain pointer unaligned;			/* -> chain of new induction vars */

dcl  1 dead_assign_cand based aligned,			/* dead assignment candidate node */
       2 next pointer unaligned,
       2 variable fixed binary (18),
       2 flow_unit pointer unaligned;

dcl  1 equiv_array based aligned,			/* equivalenced array info -- must be same size as INPUT_TO */
       2 next pointer unaligned,
       2 lowest fixed binary (18),
       2 highest fixed binary (18);

dcl  1 lp_frame based aligned,
       2 next pointer unaligned,
       2 back pointer unaligned,
       2 data structure aligned,
         3 this_fu pointer unaligned,
         3 last_fu pointer unaligned,
         3 next_lp pointer unaligned,
         3 hold_p_list pointer unaligned,
         3 hold_bt_list pointer unaligned,
         3 hold_incr_chain pointer unaligned,
         3 hold_sr_chain pointer unaligned,
         3 hold_sr_tail pointer unaligned,
         3 hold_ass_chain pointer unaligned,
         3 resume_st fixed binary (18),
         3 first_jump_target pointer unaligned;

dcl  section (10) character (25) varying internal static options (constant)
	initial ("assign_symbol_coordinates", "build_flow_units", "flow_analysis", "optimize_loop", "reduce_strength",
	"replace_tests", "remove_dead_assignments", "consolidate_subprogram", "recompute_usage", "index_value_analysis")
	;

dcl  1 timing_info aligned,
       2 last_vcpu fixed binary (71),
       2 last_pf fixed binary (18),
       2 last_section fixed binary (18),
       2 entry (10) aligned,
         3 vcpu fixed binary (18),
         3 pf fixed binary (18);

dcl  total_pf fixed binary (18);
dcl  total_vcpu float binary;
dcl  tx float binary;
dcl  (max_n_sym, max_n_loops, max_n_flow_units) fixed binary (18);

dcl  ioa_ entry options (variable);

dcl  (abs, addr, bit, char, dim, divide, fixed, float, hbound, length, ltrim, max, min, mod, null, rel, round, size,
     string, substr, sum, unspec) builtin;

%include fort_opt_nodes;
%include fort_nodes;
%include fort_system_constants;

dcl  1 shared_globals structure aligned based (shared_struc_ptr),
%include fort_shared_vars;
%include fort_options;

	if hbound (op_class, 1) ^= last_assigned_op | hbound (xop_class, 1) ^= last_assigned_op
	then do;
	     call print_message (382, "The size of the op_class array", "last_assigned_op");
	     return;
	     end;

	shared_struc_ptr = pt1;

	operand_max_len = shared_globals.operand_max_len;
	quad_max_len = shared_globals.quad_max_len;
	opt_max_len = shared_globals.opt_max_len;
	polish_max_len = shared_globals.polish_max_len;

	operand_base = shared_globals.operand_base;
	quadruple_base = shared_globals.quadruple_base;
	opt_base = shared_globals.opt_base;
	polish_base = shared_globals.polish_base;

	max_operands = 10b ** length (unspec (null -> operator.number)) - 1;

	meter_hash_buckets = "0"b;

	consolidating = "0"b;

	p_list (*) = null;
	bt_list (*) = null;

	hash_mask = "0"b;

	free (*) = null;

	s_list, freei, freep, freep_tail, freesrv, init_frame, loop_entry_list, entry_unit, exit_unit, adam_loop,
	     freefu, init_lp_frame = null;

	n_loops = 0;

	timing_info.last_section = 0;
	max_n_sym, max_n_loops, max_n_flow_units = 0;

	allocate_symbol_name = 0;

	zero = 0;
	zero = create_constant (int_mode, unspec (zero));

	one = 1;
	one = create_constant (int_mode, unspec (one));
	onep = addr (rands (one));

	full_strength_reduction = "1"b;

	/* MAIN OPTIMIZATION LOOP */

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));

	     need_consolidation_pass = cs -> subprogram.options.consolidate;

	     if cs -> subprogram.options.ignore_articulation_blocks
	     then always_safe_to_move_class = unlikely_to_fault_class;
	     else always_safe_to_move_class = cannot_fault_class;

	     do_timings = cs -> subprogram.options.time_optimizer;

	     call timer (1);

	     call assign_symbol_coordinates;

	     call timer (2);

	     call build_flow_units;

	     call timer (3);

	     call flow_analysis;

	     call timer (4);

	     call optimize_subprogram;

	     call timer (10);

	     call index_value_analysis;

	     max_n_sym = max (max_n_sym, n_sym);
	     max_n_loops = max (max_n_loops, n_loops);
	     max_n_flow_units = max (max_n_flow_units, n_flow_units);

	     end;

	call timer (0);

	if do_timings
	then do;
	     total_vcpu = float (sum (timing_info.vcpu (*)));
	     total_pf = sum (timing_info.pf (*));

	     call ioa_ ("Section                         CPU    %   Pages");

	     do i = 1 to hbound (section, 1);
		tx = float (timing_info.vcpu (i));
		call ioa_ ("^27a^9.3f^6.1f^6d", section (i), tx / 1.0e6, 100e0 * tx / total_vcpu, timing_info.pf (i));
		end;

	     call ioa_ ("TOTAL                      ^9.3f      ^6d", total_vcpu / 1.0e6, total_pf);
	     call ioa_ ("^/max(symbols):^-^d^/max(loops):^-^d^/max(flow_units):^-^d", max_n_sym, max_n_loops,
		max_n_flow_units);

	     end;

	shared_globals.free (*) = free (*);
	shared_globals.freei = freei;

	return;

timer:
     procedure (i);

	/* timing routine */

dcl  i fixed binary (18);

dcl  vcpu fixed binary (71);
dcl  (pf, last, dummy) fixed binary (18);
dcl  cpu_time_and_paging_ entry (fixed bin (18), fixed bin (71), fixed bin (18));

	if ^do_timings
	then return;

	if timing_info.last_section = 0
	then do;
	     call cpu_time_and_paging_ (timing_info.last_pf, timing_info.last_vcpu, dummy);
	     timing_info.vcpu (*) = 0;
	     timing_info.pf (*) = 0;
	     end;

	else do;
	     call cpu_time_and_paging_ (pf, vcpu, dummy);
	     last = timing_info.last_section;
	     timing_info.vcpu (last) = timing_info.vcpu (last) + (vcpu - timing_info.last_vcpu);
	     timing_info.pf (last) = timing_info.pf (last) + (pf - timing_info.last_pf);
	     timing_info.last_vcpu = vcpu;
	     timing_info.last_pf = pf;
	     end;

	timing_info.last_section = i;

     end timer;

assign_symbol_coordinates:
     procedure ();

	/* assigns coordinates to the symbols for use with the bit masks */

dcl  (s, h, ea, equiv_array_chain, equiv_array_tail) pointer;
dcl  (i, hdr, sym) fixed binary (18);
dcl  has_parameters bit (1) aligned;

dcl  1 initial aligned based,
       2 next fixed binary (18),
       2 limit fixed binary (18),
       2 value fixed binary (18);

	has_parameters = cs -> subprogram.has_parameters;
	equiv_array_chain, equiv_array_tail = null;

	/* symbols in common whose space is not overlapped by that of other symbols
	   get unique coordinates */

	/* loop to turn on in_equiv_stmnt for all symbols in common that might be overlapped
	   by equivalenced arrays */

	do hdr = cs -> subprogram.common_chain repeat h -> header.next_header while (hdr > 0);
	     h = addr (rands (hdr));

	     do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
		s = addr (rands (sym));

		if s -> symbol.in_equiv_stmnt & s -> symbol.dimensioned
		then do;
		     ea = create_input_to ();

		     ea -> equiv_array.next = equiv_array_chain;
		     equiv_array_chain = ea;
		     if equiv_array_tail = null
		     then equiv_array_tail = ea;

		     ea -> equiv_array.lowest = s -> symbol.offset;
		     ea -> equiv_array.highest =
			s -> symbol.offset + addr (rands (s -> symbol.dimension)) -> dimension.array_size - 1;
		     end;
		end;

	     if equiv_array_chain ^= null
	     then do;
		do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
		     s = addr (rands (sym));

		     do ea = equiv_array_chain repeat ea -> equiv_array.next
			while (^s -> symbol.in_equiv_stmnt & ea ^= null);

			if s -> symbol.offset >= ea -> equiv_array.lowest
			     & s -> symbol.offset <= ea -> equiv_array.highest
			then s -> symbol.in_equiv_stmnt = "1"b;
			end;
		     end;

		equiv_array_tail -> equiv_array.next = freei;
		freei = equiv_array_chain;
		equiv_array_chain, equiv_array_tail = null;
		end;
	     end;

	/* assign coordinates to all non constant referenced symbols.  Parameters
	   and equivalenced symbols get coordinates depending on their data_type. */

	if last_assigned_mode ^= length (alias_mask) | last_assigned_mode ^= hbound (aliasable_mask, 1)
	then do;
	     call print_message (382, "last_assigned_mode", "length(alias_mask)");
	     return;
	     end;

	n_sym = last_assigned_mode;
	do sym = cs -> subprogram.first_symbol repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));

	     s -> symbol.secondary = null;

	     if s -> symbol.allocate & ^s -> symbol.constant & ^s -> symbol.named_constant & ^s -> symbol.builtin
		& ^s -> symbol.stmnt_func & ^s -> symbol.namelist
	     then do;
		if s -> symbol.in_equiv_stmnt | s -> symbol.parameter | (s -> symbol.in_common & has_parameters)
		then s -> symbol.aliasable = "1"b;

		if (s -> symbol.static | s -> symbol.automatic) & s -> symbol.initial ^= 0 & ^s -> symbol.set
		     & ^s -> symbol.passed_as_arg & ^s -> symbol.aliasable & ^s -> symbol.dimensioned
		then do;

		     /* convert the symbol into a named constant */

		     s -> symbol.automatic, s -> symbol.static = "0"b;
		     s -> symbol.named_constant = "1"b;
		     s -> symbol.initial = addr (polish (s -> symbol.initial)) -> initial.value;
		     end;

		else if ^s -> symbol.parameter & ^s -> symbol.in_equiv_stmnt
		then do;
		     n_sym = n_sym + 1;
		     s -> symbol.coordinate = n_sym;
		     end;
		else s -> symbol.coordinate = s -> symbol.data_type;
		end;
	     end;

	/* allow room for creation of more symbols (use a min of 288 until we have a way to
	   recycle str_red-created vars) */

	max_sym, cs -> subprogram.max_sym = max (36 * divide (n_sym + 89, 36, 17, 0), 288);

	/* Set up aliasable_mask's, non_auto_mask, and integer_scalar_mask.	*/

	non_auto_mask_p = get_opt_space (size (non_auto_mask));
	non_auto_mask = alias_mask;

	integer_scalar_mask_p = get_opt_space (size (integer_scalar_mask));

	aliasable_mask_p = get_opt_space (size (aliasable_mask));
	aliasable_mask (0) = alias_mask;

	do i = 1 to length (alias_mask);
	     substr (aliasable_mask (i), i, 1) = "1"b;
	     end;

	do sym = cs -> subprogram.first_symbol repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));

	     if s -> symbol.coordinate > length (alias_mask)
	     then do;
		i = s -> symbol.coordinate;

		if ^s -> symbol.automatic
		then substr (non_auto_mask, i, 1) = "1"b;

		if s -> symbol.data_type = int_mode & ^s -> symbol.dimensioned
		then substr (integer_scalar_mask, i, 1) = "1"b;

		if s -> symbol.in_common
		then do;
		     substr (aliasable_mask (s -> symbol.data_type), i, 1) = "1"b;
		     substr (aliasable_mask (0), i, 1) = "1"b;
		     end;
		end;

	     end;

     end assign_symbol_coordinates;

build_flow_units:
     procedure ();

	/* builds flow_units and collects variable usage information */

dcl  need_new_unit bit (1) aligned;
dcl  (lp, o, p, st, cur_unit) pointer;
dcl  (op, next_statement, op_code, ipol) fixed binary (17);
dcl  i fixed binary (18);
dcl  chaining_input bit (1) aligned;

dcl  (jump_assigned_list, jump_assigned_target_list) pointer;

	/* initialize */

	chaining_input = "1"b;
	max_flow_units, n_operators, n_loops = 0;

	jump_assigned_list, jump_assigned_target_list = null;

	state_discarded = "1"b;
	need_new_unit = "1"b;			/* need a new unit to represent top of the program */
	adam_loop = create_loop (null);
	cur_unit, entry_unit = create_flow_unit ();
	entry_unit -> flow_unit.processed = "1"b;
	entry_unit -> flow_unit.position, entry_unit -> flow_unit.number = 1;
	exit_unit = create_flow_unit ();

	/* loop through the statement chain to get flow information */

	do cur_statement = cs -> subprogram.first_quad repeat next_statement while (cur_statement > 0);
	     st = addr (quad (cur_statement));
	     next_statement = fixed (st -> opt_statement.next, 18);

	     if st -> opt_statement.label ^= 0
	     then if addr (rands (st -> opt_statement.label)) -> label.executable
		then if addr (rands (st -> opt_statement.label)) -> label.referenced_executable
						/* must be a jump target */
		     then need_new_unit = "1"b;

	     if need_new_unit & st -> opt_statement.put_in_map
						/* put_in_map means executable */
	     then call change_cur_unit;

	     /* process this statement's operators getting usage and flow information */

	     do op = st -> opt_statement.first_operator repeat o -> operator.next while (op ^= next_statement);
		o = addr (quad (op));
		op_code = o -> operator.op_code;
		go to action (op_class (op_code));

action (1):					/* reducible */
action (2):					/* .. */
action (3):					/* .. */
action (4):					/* assignment */
action (5):					/* .. */
		n_operators = n_operators + 1;
		o -> operator.coordinate = n_operators;

		call use_inputs;
		call set ((o -> operator.output), 0, "1"b);
		go to step;

action (6):					/* call & func_ref */
		call process_call;
		go to step;

action (7):					/* entry points */
		/*** We won't create a flow_unit here because one has already been
		     created before the statement loop because we are either at the top
		     of the program, or are after an unconditional jump or return.
		***/
		call link (entry_unit, cur_unit);
		cur_unit -> flow_unit.entry_pt = "1"b;
		go to step;

action (8):					/* jump */
		call link_to_target (o -> operand (1));
		state_discarded = "1"b;
		need_new_unit = "1"b;

		if addr (rands (o -> operand (1))) -> label.statement = next_statement
		then do;

		     /* special case:  go to next_statement */

		     o -> operator.op_code = no_op;
		     o -> operator.number = 0;
		     end;

		go to step;

action (9):					/* jump_arithmetic */
		call use_inputs;
		do i = 2 to 4;
		     call link_to_target (o -> operand (i));
		     end;
		state_discarded = "1"b;
		need_new_unit = "1"b;
		go to step;

action (10):					/* jump_computed */
		call use_inputs;
		do i = 1 to o -> operator.operand (1) + bias;
		     call link_to_target (o -> operator.operand (i + 1));
		     end;
		need_new_unit = "1"b;
		go to step;

action (11):					/* jump_assigned */
		call use_inputs;
		call add_to_jump_assigned_list;
		state_discarded = "1"b;
		need_new_unit = "1"b;
		go to step;

action (12):					/* jump_true, jump_false */
		call use_inputs;
		call link_to_target (o -> operand (2));
		need_new_unit = "1"b;
		go to step;

action (13):					/* return, stop */
		call use_inputs;			/* in case of stop n */
		call link (cur_unit, exit_unit);
		state_discarded = "1"b;
		need_new_unit = "1"b;
		go to step;

action (14):					/* error_label, end_label */
		call link_to_target (o -> operand (1));
		call link_entry_to_target;
		addr (rands (o -> operand (1))) -> label.restore_prs = "1"b;
		need_new_unit = "1"b;
		go to step;

action (15):					/* irreducible */
		cur_unit -> flow_unit.has_side_effects = "1"b;

		call use_inputs;
		call set ((o -> operator.output), 0, "1"b);
		go to step;

action (16):					/* assign_label */
		call set ((o -> operator.output), 0, "1"b);
		if addr (rands (o -> operator.operand (1))) -> node.node_type = label_node
		then do;
		     call link_entry_to_target ();
		     call add_to_jump_assigned_target_list ();
		     end;
		go to step;

action (17):					/* end_unit */
		st -> opt_statement.flow_unit = exit_unit;
		call change_cur_unit;
		go to step;

action (18):					/* read_namelist */
		cur_unit -> flow_unit.has_side_effects = "1"b;

		ipol = addr (rands (o -> operand (1))) -> symbol.initial;
		do i = 1 to polish (ipol);
		     call set ((polish (ipol + i)), 0, "0"b);
		     end;
		go to step;

action (19):					/* write_name_list */
		cur_unit -> flow_unit.has_side_effects = "1"b;

		ipol = addr (rands (o -> operand (1))) -> symbol.initial;
		do i = 1 to polish (ipol);
		     call use_symbol (addr (rands (polish (ipol + i))));
		     end;
		go to step;

action (20):					/* non_executable, no_op */
		go to step;

action (21):					/* irreducible, partially sets */
		cur_unit -> flow_unit.has_side_effects = "1"b;

		call use_inputs;
		call set ((o -> operator.output), 0, "0"b);

		go to step;

action (22):					/* inquire */
		cur_unit -> flow_unit.has_side_effects = "1"b;

		do i = 1 to 3;
		     call use_one_input (i);
		     end;

		do i = 4 to o -> operator.number by 2;
		     if o -> operator.operand (i + 1) + bias = 4
						/* filename */
			| o -> operator.operand (i + 1) + bias = 14
						/* unit */
		     then call use_one_input (i);
		     else call set ((o -> operator.operand (i)), i, "0"b);
		     end;

		go to step;

action (0):					/* unexpected operators */
		call print_message (383, op_code - bias);

step:
		end;

	     st -> opt_statement.flow_unit = cur_unit;
	     cur_unit -> flow_unit.last_statement = cur_statement;
	     end;

	/* connect all flow_units ending in jump_assigned operators with
	   all possible targets */


	/* connect_jump_assigneds if EITHER we had an assign or a jump_assigned_list */

	if jump_assigned_list ^= null | jump_assigned_target_list ^= null
	then call connect_jump_assigneds;

	/* set n_flow_units */

	n_flow_units = exit_unit -> flow_unit.number;

	/* allocate dominated_by bit vectors */

	max_flow_units = 36 * divide (n_flow_units + 55, 36, 17, 0);

	do p = entry_unit repeat p -> flow_unit.next while (p ^= null);
	     p -> flow_unit.dominated_by = get_opt_space (size (dbits));
	     end;

	/* seg max_operators */

	max_operators, cs -> subprogram.max_operators = 36 * divide (n_operators + n_operators + 35, 36, 17);

	/* allocate bit vectors in loop node */

	adam_loop -> loop.is_member = get_opt_space (size (dbits));
	adam_loop -> loop.is_exit = get_opt_space (size (dbits));
	adam_loop -> loop.articulation_blocks = get_opt_space (size (dbits));

	return;

recompute_usage:
     entry;

	/* recompute_usage completely recomputes all flow_unit & loop usage bits after
	   most optimizations have been performed. */

	chaining_input = "0"b;

	/* zero out loop usage bits */

	do i = 1 to n_loops;
	     lp = loop_vector (i);
	     lp -> loop.used -> bits, lp -> loop.set -> bits, lp -> loop.busy_on_exit -> bits,
		lp -> loop.set_multiple -> bits = "0"b;
	     end;

	/* zero out all flow_unit usage bits */

	do cur_unit = exit_unit repeat cur_unit -> flow_unit.back while (cur_unit ^= null);
	     cur_unit -> flow_unit.used -> bits, cur_unit -> flow_unit.set -> bits,
		cur_unit -> flow_unit.busy_on_entry -> bits, cur_unit -> flow_unit.set_multiple -> bits,
		cur_unit -> flow_unit.busy_on_exit -> bits, cur_unit -> flow_unit.always_completely_set -> bits =
		"0"b;
	     end;

	/* scan through the quads picking up new usage info */

	do cur_statement = cs -> subprogram.first_quad repeat next_statement while (cur_statement > 0);
	     st = addr (quad (cur_statement));
	     next_statement = fixed (st -> opt_statement.next, 18);
	     cur_unit = st -> opt_statement.flow_unit;

	     /* process the statement's operators */

	     do op = st -> opt_statement.first_operator repeat o -> operator.next while (op ^= next_statement);
		o = addr (quad (op));
		op_code = o -> operator.op_code;
		go to reaction (op_class (op_code));

reaction (1):					/* reducible */
reaction (2):					/* .. */
reaction (3):					/* .. */
reaction (4):					/* assignment */
reaction (15):					/* irreducible */
		call use_inputs;
		call set ((o -> operator.output), 0, "1"b);
		go to restep;

reaction (5):					/* increment */
		call use_inputs;

		p = addr (rands (o -> operator.output));
		if p -> node.node_type = array_ref_node
		then p = addr (rands (p -> array_ref.parent));

		call use_symbol (p);
		call set ((o -> operator.output), 0, "1"b);
		go to restep;

reaction (6):					/* call & func_ref */
		call process_call;
		go to restep;

reaction (9):					/* jump_arithmetic */
reaction (10):					/* jump_computed */
reaction (11):					/* jump_assigned */
reaction (12):					/* jump_true, jump_false */
reaction (13):					/* return, stop */
		call use_inputs;
		go to restep;

reaction (16):					/* assign_label */
		call set ((o -> operator.output), 0, "1"b);
		go to restep;

reaction (18):					/* read_namelist */
		ipol = addr (rands (o -> operand (1))) -> symbol.initial;
		do i = 1 to polish (ipol);
		     call set ((polish (ipol + i)), 0, "0"b);
		     end;
		go to restep;

reaction (19):					/* write_namelist */
		ipol = addr (rands (o -> operand (1))) -> symbol.initial;
		do i = 1 to polish (ipol);
		     call use_symbol (addr (rands (polish (ipol + i))));
		     end;
		go to restep;

reaction (21):					/* irreducible, partially sets */
		call use_inputs;
		call set ((o -> operator.output), 0, "0"b);

		go to restep;

reaction (22):					/* inquire */
		do i = 1 to 3;
		     call use_one_input (i);
		     end;

		do i = 4 to o -> operator.number by 2;
		     if o -> operator.operand (i + 1) + bias = 4
						/* filename */
			| o -> operator.operand (i + 1) + bias = 14
						/* unit */
		     then call use_one_input (i);
		     else call set ((o -> operator.operand (i)), i, "0"b);
		     end;

		go to restep;

reaction (0):					/* unexpected operators */
		call print_message (383, op_code - bias);

reaction (7):					/* entry points */
reaction (8):					/* jump */
reaction (14):					/* error_label, end_label */
reaction (17):					/* end_unit */
reaction (20):					/* non_executable, no_op */
restep:
		end;
	     end;

	/* complete data flow analysis */

	call analyze_data_flow;

	return;

use_inputs:
     procedure ();

	/* marks all input operands as used */
	/* also chains temps & array_refs to their uses */

dcl  i fixed binary (18);

	do i = 1 to o -> operator.number;
	     call use_one_input (i);
	     end;

     end use_inputs;

use_one_input:
     procedure (iop);

	/* Marks the specified operand as used. */

dcl  (iop, i, opnd) fixed binary (18);
dcl  p pointer;					/* pointer to the node to "use" */
dcl  s pointer;					/* pointer to array_ref symbol nodes */
dcl  q pointer;					/* pointer to opt_subscript quad */

	i = iop;
	opnd = o -> operator.operand (i);

	if opnd > 0
	then do;
	     p = addr (rands (opnd));

	     if p -> node.node_type = symbol_node
	     then do;
		if p -> symbol.named_constant
		then do;

		     /* turn named constant into a constant */

		     if op_code = opt_subscript_op & i = 1
		     then addr (rands (p -> symbol.initial)) -> node.allocate = "1"b;
		     else o -> operator.operand (i) = p -> symbol.initial;

		     /* if constant is input to opt_subscript_op,
		        combine variable & constant offset */

		     if op_code = opt_subscript_op & i = 3
		     then call make_constant_opt_subscript (o);
		     end;

		else if i ^= 1 | op_code ^= opt_subscript_op
		then call use_symbol (p);
		end;

	     else if p -> node.node_type = temporary_node & chaining_input
	     then call chain_input (p, o, i);

	     else if p -> node.node_type = array_ref_node
	     then do;
		if chaining_input
		then call chain_input (p, o, i);

		/* get address of quad which produced the array_ref node */
		q = addr (quad (p -> array_ref.output_by));

		/* get address of variable offset if it exists */
		if q -> operator.operand (3) ^= 0
		then do;
		     s = addr (rands (q -> operator.operand (3)));

		     /* use temporary offset if it is a symbol */
		     if s -> node.node_type = symbol_node
		     then call use_symbol (s);
		     end;

		/* use array which is the parent of the array ref */
		s = addr (rands (p -> array_ref.parent));
		call use_symbol (s);
		end;
	     end;

     end use_one_input;

use_symbol:
     procedure (s);

dcl  s pointer;					/* symbol */
dcl  (c, dt, other_dt) fixed binary (18);

	if s -> symbol.coordinate > 0
	then do;
	     c = s -> symbol.coordinate;

	     substr (cur_unit -> flow_unit.used -> bits, c, 1) = "1"b;
	     if ^substr (cur_unit -> flow_unit.always_completely_set -> bits, c, 1)
	     then substr (cur_unit -> flow_unit.busy_on_entry -> bits, c, 1) = "1"b;

	     if s -> symbol.aliasable
	     then do;
		dt = s -> symbol.data_type;

		if s -> symbol.parameter
		then do;
		     cur_unit -> flow_unit.used -> bits = cur_unit -> flow_unit.used -> bits | aliasable_mask (dt);
		     cur_unit -> flow_unit.busy_on_entry -> bits =
			cur_unit -> flow_unit.busy_on_entry -> bits
			| (aliasable_mask (dt) & ^cur_unit -> flow_unit.always_completely_set -> bits);
		     end;

		else if c > length (alias_mask)
		then do;

		     /* the variable is in common */

		     substr (cur_unit -> flow_unit.used -> bits, dt, 1) = "1"b;
		     substr (cur_unit -> flow_unit.busy_on_entry -> bits, dt, 1) = "1"b;
		     end;

		else do;

		     /* the symbol is equivalenced.  Deal with the fact that
		        a real variable may be equivalenced with a complex
		        variable, and both may be simultaneously defined. */

		     if dt = real_mode
		     then other_dt = cmpx_mode;

		     else if dt = cmpx_mode
		     then other_dt = real_mode;

		     else other_dt = 0;

		     if other_dt > 0
		     then do;
			substr (cur_unit -> flow_unit.used -> bits, other_dt, 1) = "1"b;
			substr (cur_unit -> flow_unit.busy_on_entry -> bits, other_dt, 1) = "1"b;
			end;
		     end;
		end;
	     end;

     end use_symbol;

set:
     procedure (opnd, iop, always_sets);

	/* turns on set & set_multiple bits for opnd */

dcl  opnd fixed binary (18),				/* operand being set */
     iop fixed binary (18),				/* which operand of the operator (0 is output) */
     always_sets bit (1) aligned;			/* guarantees variable is set, and, if the
						   operand if a symbol node, that the whole
						   variable is set.	*/

dcl  (i, dt, other_dt) fixed binary (18);
dcl  always_completely_sets bit (1) aligned;		/* guarantees entire generation of variable is set */
dcl  p pointer;

	if opnd > 0
	then do;
	     always_completely_sets = always_sets;

	     p = addr (rands (opnd));

	     if p -> node.node_type = array_ref_node
	     then do;
		if op_code ^= opt_subscript_op
		then do;
		     always_completely_sets = "0"b;	/* sets only one array element or a substring */
		     if iop = 0 & chaining_input
		     then call chain_input (p, o, 0);
		     p = addr (rands (p -> array_ref.parent));
		     end;
		end;

	     if p -> node.node_type = symbol_node
	     then do;
		i = p -> symbol.coordinate;
		if i > 0
		then do;
		     if substr (cur_unit -> flow_unit.set -> bits, i, 1)
		     then substr (cur_unit -> flow_unit.set_multiple -> bits, i, 1) = "1"b;
		     else substr (cur_unit -> flow_unit.set -> bits, i, 1) = "1"b;

		     if p -> symbol.aliasable
		     then do;
			dt = p -> symbol.data_type;

			if p -> symbol.parameter
			then do;
			     cur_unit -> flow_unit.set_multiple -> bits =
				cur_unit -> flow_unit.set_multiple -> bits
				| (cur_unit -> flow_unit.set -> bits & aliasable_mask (dt));
			     cur_unit -> flow_unit.set -> bits =
				cur_unit -> flow_unit.set -> bits | aliasable_mask (dt);
			     always_completely_sets = "0"b;
						/* several variables share this coordinate */
			     end;

			else if i > length (alias_mask)
			then if substr (cur_unit -> flow_unit.set -> bits, dt, 1)
			     then substr (cur_unit -> flow_unit.set_multiple -> bits, dt, 1) = "1"b;
			     else substr (cur_unit -> flow_unit.set -> bits, dt, 1) = "1"b;

			else do;

			     /* equivalenced variables */

			     always_completely_sets = "0"b;
						/* several variables share this coordinate */

			     /* real and complex vars may be equivalenced
			        and simultaneously defined */

			     if dt = real_mode
			     then other_dt = cmpx_mode;

			     else if dt = cmpx_mode
			     then other_dt = real_mode;

			     else other_dt = 0;

			     if other_dt > 0
			     then if substr (cur_unit -> flow_unit.set -> bits, other_dt, 1)
				then substr (cur_unit -> flow_unit.set_multiple -> bits, other_dt, 1) = "1"b;
				else substr (cur_unit -> flow_unit.set -> bits, other_dt, 1) = "1"b;
			     end;
			end;

		     if always_completely_sets
		     then substr (cur_unit -> flow_unit.always_completely_set -> bits, i, 1) = "1"b;
		     end;
		end;
	     end;

     end set;

process_call:
     procedure ();

dcl  i fixed binary (18);

	call use_inputs;

	/* set the arguments */

	do i = 3 to o -> operator.number;
	     call set ((o -> operator.operand (i)), i, "0"b);
	     end;

	/* use & set all aliasables */

	cur_unit -> flow_unit.used -> bits = cur_unit -> flow_unit.used -> bits | aliasable_mask (0);
	cur_unit -> flow_unit.busy_on_entry -> bits =
	     cur_unit -> flow_unit.busy_on_entry -> bits
	     | (aliasable_mask (0) & ^cur_unit -> flow_unit.always_completely_set -> bits);
	cur_unit -> flow_unit.set_multiple -> bits =
	     cur_unit -> flow_unit.set_multiple -> bits | (cur_unit -> flow_unit.set -> bits & aliasable_mask (0));
	cur_unit -> flow_unit.set -> bits = cur_unit -> flow_unit.set -> bits | aliasable_mask (0);

	/* set the output */

	call set ((o -> operator.output), 0, "1"b);

	cur_unit -> flow_unit.has_side_effects = "1"b;

     end process_call;

change_cur_unit:
     procedure ();

	/* makes a new flow_unit the current unit and chains it in */

dcl  next_unit pointer;

	need_new_unit = "0"b;

	if st -> opt_statement.flow_unit ^= null
	then next_unit = st -> opt_statement.flow_unit;
	else next_unit = create_flow_unit ();

	next_unit -> flow_unit.position, next_unit -> flow_unit.number = cur_unit -> flow_unit.number + 1;
	next_unit -> flow_unit.first_statement = cur_statement;

	cur_unit -> flow_unit.next = next_unit;
	next_unit -> flow_unit.back = cur_unit;

	if ^state_discarded
	then do;
	     cur_unit -> flow_unit.falls_through = "1"b;
	     call link (cur_unit, next_unit);
	     end;
	else state_discarded = "0"b;

	cur_unit = next_unit;
	st -> opt_statement.flow_unit = cur_unit;

     end change_cur_unit;

link_to_target:
     procedure (lab);

	/* links cur_unit to the flow_unit designated by the label lab */

dcl  lab fixed binary (18);				/* label of target (input/output) */

dcl  target_statement fixed binary (18);
dcl  (target, target_unit) pointer;

	call get_final_target (lab, target_statement, target);

	if target -> opt_statement.flow_unit = null
	then do;
	     target_unit = create_flow_unit ();
	     target -> opt_statement.flow_unit = target_unit;
	     end;
	else target_unit = target -> opt_statement.flow_unit;

	target_unit -> flow_unit.has_label = "1"b;

	call link (cur_unit, target_unit);

	if next_statement = target_statement
	then cur_unit -> flow_unit.falls_through = "1"b;

     end link_to_target;

get_final_target:
     procedure (lab, target_statement, target);

	/* gets final target of jump.  This optimizes a goto a goto statement */

dcl  lab fixed binary (18),				/* label referenced in the jump (input/output) */
     target_statement fixed binary (18),		/* statement labelled by lab(output) */
     target pointer;				/* .. (output) */

dcl  try_to_optimize bit (1) aligned;
dcl  i fixed binary;
dcl  o pointer;

	i = 1;
	try_to_optimize = "1"b;

	do while (try_to_optimize);
	     target_statement = addr (rands (lab)) -> label.statement;
	     target = addr (quad (target_statement));

	     do o = addr (quad (target -> opt_statement.first_operator)) repeat addr (quad (o -> operator.next))
		while (o -> operator.op_code = no_op | o -> operator.op_code = non_executable);
		end;

	     if o -> operator.op_code = jump_op & i < 10
	     then do;
		lab = o -> operand (1);

		/* Set removable to prevent warning 384 */

		target -> opt_statement.removable = "1"b;
		end;
	     else try_to_optimize = "0"b;

	     i = i + 1;
	     end;

     end get_final_target;

link_entry_to_target:
     procedure ();

	/* links entry unit to target unit which is operator.operand(1) */

dcl  (target, target_st) pointer;

	target_st = addr (quad (addr (rands (o -> operand (1))) -> label.statement));

	if target_st -> opt_statement.flow_unit ^= null
	then target = target_st -> opt_statement.flow_unit;
	else do;
	     target = create_flow_unit ();
	     target_st -> opt_statement.flow_unit = target;
	     end;

	target -> flow_unit.has_label = "1"b;
	target_st -> opt_statement.referenced_by_assign = "1"b;

	call link (entry_unit, target);

     end link_entry_to_target;

add_to_jump_assigned_list:
     procedure ();

dcl  c pointer;

	c = create_chain ();

	c -> chain.value = cur_unit;
	c -> chain.next = jump_assigned_list;
	jump_assigned_list = c;

     end add_to_jump_assigned_list;

add_to_jump_assigned_target_list:
     procedure ();

dcl  (target, target_st, c, sym) pointer;

	target_st = addr (quad (addr (rands (o -> operand (1))) -> label.statement));
	target = target_st -> opt_statement.flow_unit;

	sym = addr (rands (o -> operator.output));

	if sym -> symbol.secondary = null
	then do;
	     c = create_chain ();

	     c -> chain.value = sym;
	     c -> chain.next = jump_assigned_target_list;
	     jump_assigned_target_list = c;
	     end;

	c = create_chain ();

	c -> chain.value = target;
	c -> chain.next = sym -> symbol.secondary;
	sym -> symbol.secondary = c;

     end add_to_jump_assigned_target_list;

connect_jump_assigneds:
     procedure ();

dcl  (c_source, c_target, source, st, o, sym, last, last_c) pointer;

	last = null;

	do c_source = jump_assigned_list repeat c_source -> chain.next while (c_source ^= null);

	     source = c_source -> chain.value;

	     st = addr (quad (source -> flow_unit.last_statement));
	     st = addr (quad (fixed (st -> opt_statement.next, 18)));
	     o = addr (quad (st -> opt_statement.prev_operator));
	     sym = addr (rands (o -> operand (1)));

	     do c_target = sym -> symbol.secondary repeat c_target -> chain.next while (c_target ^= null);
		call link (source, (c_target -> chain.value));
		end;

	     last = c_source;
	     end;

	if last ^= null
	then do;
	     last -> chain.next = free (size (chain));
	     free (size (chain)) = jump_assigned_list;
	     jump_assigned_list = null;
	     end;

	last_c = null;

	do c_target = jump_assigned_target_list repeat c_target -> chain.next while (c_target ^= null);

	     last_c = c_target;
	     sym = c_target -> chain.value;

	     do last = sym -> symbol.secondary repeat last -> chain.next while (last -> chain.next ^= null);
		end;

	     last -> chain.next = free (size (chain));
	     free (size (chain)) = sym -> symbol.secondary;
	     sym -> symbol.secondary = null;
	     end;

	if last_c ^= null
	then do;
	     last_c -> chain.next = free (size (chain));
	     free (size (chain)) = jump_assigned_target_list;
	     jump_assigned_target_list = null;
	     end;

     end connect_jump_assigneds;

     end build_flow_units;

link:
     procedure (from_unit, to_unit);

	/* builds an edge between from_unit and to_unit */

dcl  (from_unit, to_unit) pointer;

dcl  (e, q) pointer;

	e = get_opt_space (size (edge));

	e -> edge.from.back = null;
	e -> edge.to.back = null;

	e -> edge.from.value = from_unit;
	e -> edge.to.value = to_unit;

	e -> edge.from.next, q = to_unit -> flow_unit.predecessors;
	to_unit -> flow_unit.predecessors = e;
	if q ^= null
	then q -> edge.from.back = e;

	e -> edge.to.next, q = from_unit -> flow_unit.successors;
	from_unit -> flow_unit.successors = e;
	if q ^= null
	then q -> edge.to.back = e;

     end link;

make_constant_opt_subscript:
     procedure (p_o);

dcl  (o, p_o) pointer;				/* points at operator */
dcl  (c2, c3) fixed binary (18);

	o = p_o;
	unspec (c2) = addr (rands (o -> operator.operand (2))) -> constant.value;
	unspec (c3) = addr (rands (o -> operator.operand (3))) -> constant.value;
	o -> operator.operand (2) = create_integer_constant (c2 + c3);
	o -> operator.operand (3) = 0;

     end make_constant_opt_subscript;

flow_analysis:
     procedure ();

dcl  (c, e, exit, lastc, lp, p, q) pointer;
dcl  (i, lvec, pnum, qnum) fixed binary (18);
dcl  found bit (1) aligned;

	/* BACK DOMINATOR ALGORITHM */

	/* Assign level numbers.  The level number represents the minimum
	   distance from the entry_unit.  */

	flow_unit_vector_p = get_opt_space (size (flow_unit_vector_st));
	flow_unit_vector (1) = entry_unit;
	entry_unit -> flow_unit.level_number = 0;
	lvec = 1;

	do i = 1 by 1 while (i <= lvec);
	     p = flow_unit_vector (i);
	     qnum = p -> flow_unit.level_number + 1;

	     do e = p -> flow_unit.successors repeat e -> edge.to.next while (e ^= null);
		q = e -> edge.to.value;
		if q -> flow_unit.level_number = 0
		then do;
		     q -> flow_unit.level_number = qnum;
		     lvec = lvec + 1;
		     flow_unit_vector (lvec) = q;
		     if q -> flow_unit.predecessors -> edge.from.next = null
						/* check for only one predecessor */
		     then q -> flow_unit.dominator = p;
		     end;
		end;
	     end;

	if lvec ^= n_flow_units
	then do;
	     call detach_flow_units;
	     n_flow_units = lvec;
	     end;

	/* Determine back dominators.  a is the back dominator of b if a is the closest unit to
	   b that must be executed before b is executed.	*/

	begin;

dcl  scan_vector (n_flow_units) pointer unaligned;
dcl  scan_bits bit (n_flow_units) aligned;

dcl  (i, j, lvec, lowest_level, our_level) fixed binary (18);
dcl  (e, p, q, bd, lowest_fu) pointer;

	     do i = 2 to n_flow_units;
		p = flow_unit_vector (i);

		if p -> flow_unit.dominator ^= null
		then bd = p -> flow_unit.dominator;

		else do;

		     /* we want to initialize scan_bits with dominated_by bits from and the bit for
		        the predecessor with lowest level number */

		     our_level = p -> flow_unit.level_number;
		     lowest_level = n_flow_units;
		     lowest_fu = null;

		     do e = p -> flow_unit.predecessors repeat e -> edge.from.next while (e ^= null);
			q = e -> edge.from.value;
			if q -> flow_unit.level_number < lowest_level
			then do;
			     lowest_level = q -> flow_unit.level_number;
			     lowest_fu = q;
			     end;
			end;

		     scan_bits = lowest_fu -> flow_unit.dominated_by -> dbits;
		     substr (scan_bits, lowest_fu -> flow_unit.number, 1) = "1"b;

		     /* scan all backward paths to find intersection furthest back from p,
		        that is, with the lowest level number */

		     lowest_level = n_flow_units;
		     lowest_fu = null;
		     scan_vector (1) = p;
		     lvec = 1;

		     do j = 1 by 1 while (j <= lvec);
			q = scan_vector (j);

			if q -> flow_unit.level_number < our_level
			then call process ((q -> flow_unit.dominator));

			else do e = q -> flow_unit.predecessors repeat e -> edge.from.next while (e ^= null);
				call process ((e -> edge.from.value));
				end;
			end;

		     p -> flow_unit.dominator, bd = lowest_fu;
		     end;

		p -> flow_unit.dominated_by -> dbits = bd -> flow_unit.dominated_by -> dbits;
		substr (p -> flow_unit.dominated_by -> dbits, bd -> flow_unit.number, 1) = "1"b;
		end;

process:
     procedure (fu);

dcl  fu pointer;					/* flow_unit being scanned */

	if substr (scan_bits, fu -> flow_unit.number, 1)
	then do;
	     if fu -> flow_unit.level_number < lowest_level
	     then do;
		lowest_level = fu -> flow_unit.level_number;
		lowest_fu = fu;
		end;
	     end;
	else do;
	     substr (scan_bits, fu -> flow_unit.number, 1) = "1"b;
	     lvec = lvec + 1;
	     scan_vector (lvec) = fu;
	     end;

     end process;

	end /* back dominator begin block */;

	/* FIND LOOP ENTRY UNITS */

	loop_entry_list = null;

	/* order of processing of flow_units is important */

	do i = n_flow_units by -1 to 3;
	     p = flow_unit_vector (i);
	     pnum = p -> flow_unit.number;
	     found = "0"b;

	     /* a loop entry unit either dominates one of its predecessors or is its own predecessor */

	     do e = p -> flow_unit.predecessors repeat e -> edge.from.next while (^found & e ^= null);
		q = e -> edge.from.value;
		if p = q | substr (q -> flow_unit.dominated_by -> dbits, pnum, 1)
		then found = "1"b;
		end;

	     if found
	     then do;

		if ^addr (quad (p -> flow_unit.first_statement)) -> opt_statement.referenced_by_assign
		then do;

		     /* we have a legitimate loop entry unit */

		     c = create_chain ();
		     c -> chain.next = loop_entry_list;
		     loop_entry_list = c;
		     c -> chain.value = p;
		     p -> flow_unit.loop_entry = "1"b;
		     end;
		end;
	     end;

	/* ASSIGN ALL FLOW UNITS TO LOOPS */

	scan_vector_p = get_opt_space (size (scan_vector_st));
	scan_bits_p = get_opt_space (size (scan_bits));
	lastc = null;

	do c = loop_entry_list repeat c -> chain.next while (c ^= null);
	     p = c -> chain.value;
	     pnum = p -> flow_unit.number;

	     /* Create a loop node.  Assign a provisional back_target. */

	     lp = create_loop ((p -> flow_unit.loop));
	     p -> flow_unit.loop = lp;
	     lp -> loop.entry_unit = p;
	     lp -> loop.back_target = p -> flow_unit.dominator;

	     /* Scan back from the loop entry unit on all paths that don't reach the back target
	        (without retouching the entry unit) and contain flow_units dominated by the loop
	        entry unit to get loop members.  */

	     scan_bits = "0"b;
	     lvec = 1;
	     substr (scan_bits, pnum, 1) = "1"b;
	     scan_vector (1) = p;

	     do i = 1 by 1 while (i <= lvec);
		do e = scan_vector (i) -> flow_unit.predecessors repeat e -> edge.from.next while (e ^= null);
		     q = e -> edge.from.value;

		     if (i ^= 1
			| q ^= lp -> loop.back_target & substr (q -> flow_unit.dominated_by -> dbits, pnum, 1))
			& ^substr (scan_bits, q -> flow_unit.number, 1)
		     then do;
			lvec = lvec + 1;
			scan_vector (lvec) = q;
			substr (scan_bits, q -> flow_unit.number, 1) = "1"b;
			q -> flow_unit.loop = lp;
			end;
		     end;
		end;

	     lastc = c;
	     end;

	if loop_entry_list ^= null
	then do;

	     /* free loop_entry_list */

	     lastc -> chain.next = free (size (chain));
	     free (size (chain)) = loop_entry_list;
	     loop_entry_list = null;
	     end;

	/* MAKE A VECTOR OF LOOPS IN DESCENDING ORDER OF NESTING DEPTH AND FROM FRONT TO BACK */

	cs -> subprogram.n_loops = n_loops;
	cs -> subprogram.loop_vector_p, loop_vector_p = get_opt_space (size (loop_vector_st));
	lvec = n_loops;

	loop_vector (lvec) = adam_loop;

	adam_loop -> loop.number = lvec;
	adam_loop -> loop.ancestors_and_me = get_opt_space (size (lbits));
	substr (adam_loop -> loop.ancestors_and_me -> lbits, lvec, 1) = "1"b;

	do i = n_loops to 1 by -1;
	     lp = loop_vector (i);

	     do p = lp -> loop.last_son repeat p -> loop.prev_brother while (p ^= null);
		lvec = lvec - 1;

		loop_vector (lvec) = p;

		p -> loop.number = lvec;
		p -> loop.ancestors_and_me = get_opt_space (size (lbits));
		p -> loop.ancestors_and_me -> lbits = lp -> loop.ancestors_and_me -> lbits;
		substr (p -> loop.ancestors_and_me -> lbits, lvec, 1) = "1"b;
		end;

	     end;

	/* ASSIGN REAL BACK TARGETS (fixes bug 187) */

	/* find earliest flow_unit for each loop */

	do p = exit_unit -> flow_unit.back repeat p -> flow_unit.back while (p ^= null);
	     p -> flow_unit.loop -> loop.first_unit = p;
	     end;

	/* find last flow_unit for each loop */

	do p = entry_unit -> flow_unit.next repeat p -> flow_unit.next while (p ^= null);
	     p -> flow_unit.loop -> loop.last_unit = p;
	     end;

	/* refine first_unit and last_unit to account for contained loops */

	do i = 1 to n_loops - 1;
	     lp = loop_vector (i);

	     do p = lp -> loop.son repeat p -> loop.brother while (p ^= null);
		if lp -> loop.first_unit -> flow_unit.position > p -> loop.first_unit -> flow_unit.position
		then lp -> loop.first_unit = p -> loop.first_unit;

		if lp -> loop.last_unit -> flow_unit.position < p -> loop.last_unit -> flow_unit.position
		then lp -> loop.last_unit = p -> loop.last_unit;
		end;

	     end;

	/* Now make sure each loop has a suitable back_target.
	   A suitable back_target has one successor and
	   physically appears before any flow_unit in the loop.
	   The latter is necessary because the code generator
	   makes one linear pass over the program.  We scan from
	   outside-in so that inner back targets are closest to
	   their loops */

	do i = n_loops - 1 to 1 by -1;
	     lp = loop_vector (i);
	     p = lp -> loop.entry_unit;
	     q = p -> flow_unit.dominator;

	     if q -> flow_unit.successors -> edge.to.next ^= null
		| q -> flow_unit.position > lp -> loop.first_unit -> flow_unit.position
	     then q = create_new_back_target (p, (lp -> loop.first_unit));

	     lp -> loop.back_target = q;
	     q -> flow_unit.is_back_target = "1"b;
	     end;

	/* CHAIN FLOW_UNITS BELONGING TO EACH LOOP.
	   Note that all flow_units must now have been created so that we can properly determine the exit paths. */

	do p = exit_unit repeat p -> flow_unit.back while (p ^= null);
	     pnum = p -> flow_unit.number;
	     lp = p -> flow_unit.loop;
	     substr (lp -> loop.is_member -> dbits, p -> flow_unit.number, 1) = "1"b;
	     p -> flow_unit.next_in_loop = lp -> loop.members;
	     lp -> loop.members = p;

	     /* check if this is an exit unit (used to determine articulation blocks) */

	     if lp -> loop.depth > 0
	     then do e = p -> flow_unit.successors repeat e -> edge.to.next while (e ^= null);
		     q = e -> edge.to.value -> flow_unit.loop;

		     /* if we have an exit unit, mark it in this loop and in intervening loops */

		     if lp -> loop.depth > q -> loop.depth
		     then do exit = lp repeat exit -> loop.father while (exit ^= q);
			     c = create_chain ();
			     c -> chain.value = e;
			     c -> chain.next = exit -> loop.exits;
			     exit -> loop.exits = c;
			     substr (exit -> loop.is_exit -> dbits, pnum, 1) = "1"b;
			     end;
		     end;
	     end;

	/* DETERMINE ARTICULATION BLOCKS */

	do i = 1 to n_loops - 1;
	     lp = loop_vector (i);
	     lp -> loop.articulation_blocks -> dbits = lp -> loop.is_member -> dbits;

	     do c = lp -> loop.exits repeat c -> chain.next while (c ^= null);
		p = c -> chain.value -> edge.from.value;
		scan_bits = p -> flow_unit.dominated_by -> dbits;
		substr (scan_bits, p -> flow_unit.number, 1) = "1"b;
		lp -> loop.articulation_blocks -> dbits = lp -> loop.articulation_blocks -> dbits & scan_bits;
		end;
	     end;

	/* allocate temp_bits */

	temp_bits_p = get_opt_space (size (temp_bits));

	/* COMPLETE DATA_FLOW ANALYSIS */

	call analyze_data_flow;

	return;

create_new_back_target:
     procedure (pt, p_ins) returns (pointer);

dcl  (p, pt) pointer;				/* ptr to loop entry unit */
dcl  (ins, p_ins) pointer;				/* ptr to earliest flow_unit in loop */

dcl  (e, q, fu, next_edge, pr, qst, o) pointer;
dcl  (j, qlabel, pnum, old_label, qpos) fixed binary (18);


	/* this routine creates a new flow_unit (with statement & label) to be a
	   back target for the loop entry unit p and splices it in */

	p = pt;
	ins = p_ins;
	pnum = p -> flow_unit.number;

	q = insert_flow_unit_before (ins, qlabel, qst);

	q -> flow_unit.level_number = p -> flow_unit.level_number;
	q -> flow_unit.dominator = p -> flow_unit.dominator;
	q -> flow_unit.dominated_by -> dbits = p -> flow_unit.dominated_by -> dbits;
	p -> flow_unit.dominator = q;
	q -> flow_unit.loop = p -> flow_unit.loop -> loop.father;

	do j = n_flow_units by -1 to 1 while (flow_unit_vector (j) ^= p);
	     flow_unit_vector (j), fu = flow_unit_vector (j - 1);
	     if substr (fu -> flow_unit.dominated_by -> dbits, pnum, 1)
	     then substr (fu -> flow_unit.dominated_by -> dbits, n_flow_units, 1) = "1"b;
	     end;

	flow_unit_vector (j) = q;

	qpos = q -> flow_unit.position;

	old_label = addr (quad (p -> flow_unit.first_statement)) -> opt_statement.label;

	q -> flow_unit.falls_through = p = ins;

	if ^q -> flow_unit.falls_through
	then call make_jump_to (old_label, q);

	/* redirect edges from outside the loop to the new back target */

	do e = p -> flow_unit.predecessors repeat next_edge while (e ^= null);
	     next_edge = e -> edge.from.next;
	     pr = e -> edge.from.value;

	     if pr ^= p & ^substr (pr -> flow_unit.dominated_by -> dbits, pnum, 1)
	     then do;

		/* pr is a flow_unit outside of the loop headed by p */

		/* set the reference_backwards bit , if necessary */

		if pr -> flow_unit.position > qpos
		then qst -> opt_statement.referenced_backwards = "1"b;

		/* change this edge to point to the new flow unit */

		call redirect_edge (e, q);

		/* now change the jump_x operator, if any, to jump to the right place */

		if old_label > 0
		then do;
		     o = addr (quad (pr -> flow_unit.last_statement));
		     o = addr (quad (fixed (o -> opt_statement.next, 18)));
		     o = addr (quad (o -> opt_statement.prev_operator));

		     if o -> operator.op_code = jump_op
		     then o -> operand (1) = qlabel;

		     else if o -> operator.op_code = jump_true_op | o -> operator.op_code = jump_false_op
		     then do;
			if o -> operand (2) = old_label
			then o -> operand (2) = qlabel;

			if pr -> flow_unit.next = p
			then call splice_in_another_fu (pr, q, qlabel);
			end;

		     else if o -> operator.op_code = jump_arithmetic_op
		     then do j = 2 to 4;
			     if o -> operand (j) = old_label
			     then o -> operand (j) = qlabel;
			     end;

		     else if o -> operator.op_code = jump_computed_op
		     then do;
			do j = 1 to o -> operand (1) + bias;
			     if o -> operand (j + 1) = old_label
			     then o -> operand (j + 1) = qlabel;
			     end;

			if pr -> flow_unit.next = p
			then call splice_in_another_fu (pr, q, qlabel);
			end;

		     else				/* it was a fall through */
			if pr -> flow_unit.next ^= q
		     then do;
			pr -> flow_unit.falls_through = "0"b;
			pr -> flow_unit.last_statement = insert_statement_after ((pr -> flow_unit.last_statement));
			call make_jump_to (qlabel, pr);
			end;
		     end;
		end;
	     end;

	/* link the new back target to the loop entry unit */

	call link (q, p);

	return (q);

insert_flow_unit_before:
     procedure (p_ins, new_label, new_stm) returns (pointer);

dcl  (p_ins, ins) pointer;				/* -> flow_unit before which we insert the new flow_unit */
dcl  new_label fixed binary (18);			/* label for new flow_unit (output) */
dcl  new_stm pointer;				/* -> stm for new flow_unit (output) */

dcl  (fu, q, qst) pointer;
dcl  (q_statement, qlabel) fixed binary (18);

	ins = p_ins;

	q = create_flow_unit ();

	if n_flow_units >= max_flow_units
	then do;
	     cur_statement = ins -> flow_unit.back -> flow_unit.last_statement;
	     call print_message (388);
	     stop;
	     end;

	n_flow_units = n_flow_units + 1;
	q -> flow_unit.number = n_flow_units;
	q -> flow_unit.position = ins -> flow_unit.position;
	q -> flow_unit.back = ins -> flow_unit.back;
	q -> flow_unit.next = ins;
	ins -> flow_unit.back = q;
	q -> flow_unit.back -> flow_unit.next = q;

	do fu = ins repeat fu -> flow_unit.next while (fu ^= null);
	     fu -> flow_unit.position = fu -> flow_unit.position + 1;
	     end;

	q_statement = insert_statement_after ((q -> flow_unit.back -> flow_unit.last_statement));
	q -> flow_unit.first_statement = q_statement;
	q -> flow_unit.last_statement = q_statement;

	qst = addr (quad (q_statement));
	qst -> opt_statement.flow_unit = q;

	qlabel = create_label (q_statement);
	q -> flow_unit.has_label = "1"b;

	new_label = qlabel;
	new_stm = qst;
	return (q);

     end insert_flow_unit_before;

redirect_edge:
     procedure (e, new_target);

dcl  e pointer,					/* -> edge whose target is changed */
     new_target pointer;				/* -> new target unit */

dcl  (e1, next_edge, old_target) pointer;

	next_edge = e -> edge.from.next;
	old_target = e -> edge.to.value;

	if e -> edge.from.back = null
	then old_target -> flow_unit.predecessors = next_edge;
	else e -> edge.from.back -> edge.from.next = next_edge;
	if next_edge ^= null
	then next_edge -> edge.from.back = e -> edge.from.back;

	e -> edge.to.value = new_target;
	e -> edge.from.next, e1 = new_target -> flow_unit.predecessors;
	e -> edge.from.back = null;
	new_target -> flow_unit.predecessors = e;
	if e1 ^= null
	then e1 -> edge.from.back = e;

     end redirect_edge;

make_jump_to:
     procedure (tlabel, fu);

dcl  tlabel fixed binary (18),			/* target label of jump */
     fu pointer;					/* -> flow_unit in which jump is inserted */

dcl  (j_operator, j_statement) fixed binary (18);

	j_statement, fu -> flow_unit.last_statement = insert_statement_after ((fu -> flow_unit.last_statement));
	j_operator = insert_operator_after (jump_op, 1, j_statement);
	addr (quad (j_operator)) -> operand (1) = tlabel;

     end make_jump_to;

splice_in_another_fu:
     procedure (pr, bt, btlabel);

dcl  pr pointer,					/* -> flow_unit that falls thru */
     bt pointer,					/* -> flow_unit we will build jump to (new back target) */
     btlabel fixed binary (18);			/* label on bt */

dcl  q pointer;
dcl  (j, useless) fixed binary (18);
dcl  useless_ptr pointer;

	q = insert_flow_unit_before ((pr -> flow_unit.next), useless, useless_ptr);

	q -> flow_unit.level_number = bt -> flow_unit.level_number;
	q -> flow_unit.dominator = pr;
	q -> flow_unit.dominated_by -> dbits = pr -> flow_unit.dominated_by -> dbits;
	substr (q -> flow_unit.dominated_by -> dbits, pr -> flow_unit.number, 1) = "1"b;
	q -> flow_unit.loop = bt -> flow_unit.loop;

	do j = n_flow_units by -1 to 1 while (flow_unit_vector (j) ^= bt);
	     flow_unit_vector (j) = flow_unit_vector (j - 1);
	     end;

	flow_unit_vector (j) = q;

	call make_jump_to ((btlabel), q);

	/* redirect edges */

	call redirect_edge (e, q);

	call link (q, bt);

     end splice_in_another_fu;

     end create_new_back_target;

detach_flow_units:
     procedure ();

	/* detaches unreachable flow_units */

dcl  (lst, nst, p, qst, st, last_o, next_fu) pointer;
dcl  (q_statement, last_statement, next_statement, last_operator) fixed binary (18);

	do p = entry_unit -> flow_unit.next repeat next_fu while (p ^= exit_unit);
	     next_fu = p -> flow_unit.next;

	     if p -> flow_unit.level_number = 0
	     then do;
		cur_statement = p -> flow_unit.first_statement;
		st = addr (quad (cur_statement));

		/* unthread the statement/operator chain */

		q_statement = p -> flow_unit.last_statement;
		qst = addr (quad (q_statement));
		next_statement = fixed (qst -> opt_statement.next, 18);
		nst = addr (quad (next_statement));
		last_statement = fixed (st -> opt_statement.back, 18);
		lst = addr (quad (last_statement));
		last_operator = st -> opt_statement.prev_operator;
		last_o = addr (quad (last_operator));

		/* Print warning if this is a real statement */

		if ^st -> opt_statement.removable
		then call print_message (384, fixed (st -> opt_statement.source_id.line, 14, 0) - bias,
			fixed (qst -> opt_statement.source_id.line, 14, 0) - bias);

		lst -> opt_statement.next = qst -> opt_statement.next;
		last_o -> operator.next = next_statement;
		nst -> opt_statement.back = st -> opt_statement.back;
		nst -> opt_statement.prev_operator = last_operator;

		/* detach and unthread the flow_unit */

		call detach_flow_unit (p);
		end;
	     end;

     end detach_flow_units;

     end flow_analysis;

detach_flow_unit:
     procedure (pt);

	/* detaches a flow_unit from its edges and unthreads a flow_unit from the
	   flow_unit chain */

dcl  (p, pt) pointer;

	p = pt;

	/* detach all edges connected to this flow_unit */

	do while (p -> flow_unit.predecessors ^= null);
	     call unlink ((p -> flow_unit.predecessors));
	     end;

	do while (p -> flow_unit.successors ^= null);
	     call unlink ((p -> flow_unit.successors));
	     end;

	/* unthread the flow_unit */

	call unthread_flow_unit (p);

     end detach_flow_unit;

unlink:
     procedure (e);

	/* unlinks an edge between 2 flow_units */

dcl  e pointer;					/* -> edge to be unlinked */

dcl  (from_unit, to_unit) pointer;

	from_unit = e -> edge.from.value;
	to_unit = e -> edge.to.value;

	if e -> edge.from.back ^= null
	then e -> edge.from.back -> edge.from.next = e -> edge.from.next;
	else to_unit -> flow_unit.predecessors = e -> edge.from.next;
	if e -> edge.from.next ^= null
	then e -> edge.from.next -> edge.from.back = e -> edge.from.back;

	if e -> edge.to.back ^= null
	then e -> edge.to.back -> edge.to.next = e -> edge.to.next;
	else from_unit -> flow_unit.successors = e -> edge.to.next;
	if e -> edge.to.next ^= null
	then e -> edge.to.next -> edge.to.back = e -> edge.to.back;

     end unlink;

analyze_data_flow:
     procedure ();

	/* Calls subroutines to do data flow analysis . */

	call summarize_loop_usage;

	call compute_busy_on_exit;

	call summarize_loop_busy_on_exit;

     end analyze_data_flow;

compute_busy_on_exit:
     procedure ();

	/* computes busy_on_exit information */

dcl  (i, j, lvec) fixed binary;
dcl  (bd, e, fu, p, q) pointer;

	/* initialize exit_unit to show that all aliasable vars are busy_on_entry */

	exit_unit -> flow_unit.busy_on_entry -> bits = aliasable_mask (0);

	/* process each flow_unit in descending order by level number,
	   propagating information backwards to its dominator */

retry:
	do i = n_flow_units to 2 by -1;
	     p = flow_unit_vector (i);
	     bd = p -> flow_unit.dominator;

	     scan_vector (1) = p;
	     j = 0;
	     lvec = 1;

	     do while (j ^= lvec);
		j = j + 1;
		if j > n_flow_units
		then j = 1;

		fu = scan_vector (j);
		fu -> flow_unit.in_queue = "0"b;

		do e = fu -> flow_unit.predecessors repeat e -> edge.from.next while (e ^= null);
		     q = e -> edge.from.value;
		     q -> flow_unit.busy_on_exit -> bits =
			q -> flow_unit.busy_on_exit -> bits | fu -> flow_unit.busy_on_entry -> bits;

		     temp_bits =
			q -> flow_unit.busy_on_entry -> bits
			| (q -> flow_unit.busy_on_exit -> bits & ^q -> flow_unit.always_completely_set -> bits);

		     if temp_bits ^= q -> flow_unit.busy_on_entry -> bits
		     then do;
			q -> flow_unit.busy_on_entry -> bits = temp_bits;
			if q ^= bd & ^q -> flow_unit.in_queue
			then do;
			     lvec = lvec + 1;
			     if lvec > n_flow_units
			     then lvec = 1;
			     scan_vector (lvec) = q;
			     q -> flow_unit.in_queue = "1"b;
			     end;
			end;
		     end;
		end;
	     end;


	/* decide whether we have to make another pass because some static
	   variables are busy on entry to the program but were not considered
	   busy_on_exit from the program */

	temp_bits =
	     exit_unit -> flow_unit.busy_on_entry -> bits
	     | (entry_unit -> flow_unit.busy_on_entry -> bits & non_auto_mask);

	if temp_bits ^= exit_unit -> flow_unit.busy_on_entry -> bits
	then do;
	     exit_unit -> flow_unit.busy_on_entry -> bits = temp_bits;
	     go to retry;
	     end;


     end compute_busy_on_exit;

summarize_loop_usage:
     procedure ();

	/* build up loop usage information by collecting from member flow_units and
	   propagating upwards to containing loops */

dcl  i fixed binary;
dcl  (lp, p) pointer;

	do i = 1 to n_loops;
	     lp = loop_vector (i);

	     do p = lp -> loop.members repeat p -> flow_unit.next_in_loop while (p ^= null);
		lp -> loop.set_multiple -> bits =
		     lp -> loop.set_multiple -> bits
		     | ((lp -> loop.set -> bits & p -> flow_unit.set -> bits) | p -> flow_unit.set_multiple -> bits);
		lp -> loop.set -> bits = lp -> loop.set -> bits | p -> flow_unit.set -> bits;
		lp -> loop.used -> bits = lp -> loop.used -> bits | p -> flow_unit.used -> bits;
		lp -> loop.has_side_effects = lp -> loop.has_side_effects | p -> flow_unit.has_side_effects;
		end;

	     do p = lp -> loop.son repeat p -> loop.brother while (p ^= null);
		lp -> loop.set_multiple -> bits =
		     lp -> loop.set_multiple -> bits
		     | ((lp -> loop.set -> bits & p -> loop.set -> bits) | p -> loop.set_multiple -> bits);
		lp -> loop.set -> bits = lp -> loop.set -> bits | p -> loop.set -> bits;
		lp -> loop.used -> bits = lp -> loop.used -> bits | p -> loop.used -> bits;
		lp -> loop.has_side_effects = lp -> loop.has_side_effects | p -> loop.has_side_effects;
		end;
	     end;

     end summarize_loop_usage;

summarize_loop_busy_on_exit:
     procedure ();

	/* summarize busy_on_exit info by using busy_on_entry of loop exit targets */

dcl  i fixed binary;
dcl  (c, lp) pointer;

	do i = 1 to n_loops;
	     lp = loop_vector (i);

	     do c = lp -> loop.exits repeat c -> chain.next while (c ^= null);
		lp -> loop.busy_on_exit -> bits =
		     lp -> loop.busy_on_exit -> bits
		     | c -> chain.value -> edge.to.value -> flow_unit.busy_on_entry -> bits;
		end;
	     end;

     end summarize_loop_busy_on_exit;

create_label:
     procedure (q_statement) returns (fixed binary (18));

	/* creates a label for a statement */

dcl  q_statement fixed binary (18);			/* stmt to which label is to be attached */

dcl  qlabel fixed binary (18);
dcl  qlab pointer;

	qlabel = create_node (label_node, size (label));
	qlab = addr (rands (qlabel));

	addr (quad (q_statement)) -> opt_statement.label = qlabel;
	qlab -> label.statement = q_statement;
	qlab -> label.operand_type = rel_constant;
	qlab -> label.referenced, qlab -> label.referenced_executable = "1"b;
	addr (rands (cs -> subprogram.last_label)) -> label.next_label = qlabel;
	cs -> subprogram.last_label = qlabel;

	return (qlabel);

     end create_label;

unthread_flow_unit:
     procedure (fu);

dcl  fu pointer;					/* -> flow_unit to be unthreaded */

	fu -> flow_unit.back -> flow_unit.next = fu -> flow_unit.next;
	fu -> flow_unit.next -> flow_unit.back = fu -> flow_unit.back;

	fu -> flow_unit.next = freefu;
	freefu = fu;

	fu -> flow_unit.removed = "1"b;

     end unthread_flow_unit;

insert_statement_after:
     procedure (last_statement) returns (fixed binary (18));

	/* used by create_new_back_target and move to insert a new opt_statement node after an existing one.
	   There must be a statement already after the existing one for this to work */

dcl  last_statement fixed binary (18);

dcl  (our_statement, next_statement) fixed binary (18);
dcl  (next_operator, last_operator) fixed binary (18);
dcl  (lastp, ourp, nextp, nextop, lastop) pointer;

	/* get an opt_statement node */

	our_statement = get_quad_space (size (opt_statement));
	ourp = addr (quad (our_statement));

	/* initialize the node */

	unspec (ourp -> opt_statement) = "0"b;
	ourp -> opt_statement.op_code = stat_op;
	ourp -> opt_statement.location = (18)"1"b;
	ourp -> opt_statement.put_in_map = "1"b;
	ourp -> opt_statement.operator_list = null;

	/* get last and next statement pointers */

	lastp = addr (quad (last_statement));
	next_statement = fixed (lastp -> opt_statement.next, 18);
	nextp = addr (quad (next_statement));

	/* get next and last operator pointers */

	next_operator = next_statement;
	nextop = nextp;
	last_operator = nextp -> opt_statement.prev_operator;
	lastop = addr (quad (last_operator));

	/* thread in our opt_statement */

	ourp -> opt_statement.next = bit (next_statement, 18);
	ourp -> opt_statement.back = bit (last_statement, 18);
	lastp -> opt_statement.next = bit (our_statement, 18);
	nextp -> opt_statement.back = bit (our_statement, 18);
	ourp -> opt_statement.first_operator = next_operator;
	ourp -> opt_statement.prev_operator = last_operator;
	nextop -> operator.back = our_statement;
	lastop -> operator.next = our_statement;

	/* use lastp's source_id and flow_unit */

	unspec (ourp -> opt_statement.source_id) = unspec (lastp -> opt_statement.source_id);
	ourp -> opt_statement.flow_unit = lastp -> opt_statement.flow_unit;

	return (our_statement);

     end insert_statement_after;

insert_operator_after:
     procedure (op_code, number, last_operator) returns (fixed binary (18));

dcl  op_code fixed binary (18),
     number fixed binary (18),
     last_operator fixed binary (18);

dcl  (o, next_o, last_o) pointer;
dcl  op fixed binary (18);

	/* allocate the space */

	n_operands = number;
	op = get_quad_space (size (operator));
	o = addr (quad (op));

	/* initialize the space */

	o -> operator.op_code = op_code;
	o -> operator.number = n_operands;
	o -> operator.assigns_constant_to_symbol = "0"b;
	o -> operator.freed = "0"b;
	o -> operator.primary = null;

	/* if the operator is reducible, assign it a coordinate */

	if op_class (op_code) <= highest_reducible_class
	then do;
	     n_operators = n_operators + 1;

	     if n_operators <= max_operators
	     then o -> operator.coordinate = n_operators;
	     else do;
		call print_message (390);
		stop;
		end;
	     end;

	/* insert the operator */

	last_o = addr (quad (last_operator));
	next_o = addr (quad (last_o -> operator.next));
	o -> operator.next = last_o -> operator.next;
	o -> operator.back = last_operator;
	last_o -> operator.next = op;
	next_o -> operator.back = op;

	return (op);

     end insert_operator_after;

create_flow_unit:
     procedure () returns (pointer);

dcl  p pointer;
dcl  1 fort_node_templates_$flow_unit_template ext static aligned like flow_unit;


	/* allocates flow unit */

	if freefu = null
	then p = get_opt_space (size (flow_unit));
	else do;
	     p = freefu;
	     freefu = freefu -> flow_unit.next;
	     end;

	p -> flow_unit = fort_node_templates_$flow_unit_template;

	p -> flow_unit.loop = adam_loop;
	p -> flow_unit.set = get_opt_space (size (bits));
	p -> flow_unit.used = get_opt_space (size (bits));
	p -> flow_unit.busy_on_entry = get_opt_space (size (bits));
	p -> flow_unit.set_multiple = get_opt_space (size (bits));
	p -> flow_unit.busy_on_exit = get_opt_space (size (bits));
	p -> flow_unit.always_completely_set = get_opt_space (size (bits));
	if max_flow_units > 0
	then p -> flow_unit.dominated_by = get_opt_space (size (dbits));

	return (p);

     end create_flow_unit;

create_loop:
     procedure (dad) returns (pointer);

dcl  dad pointer;					/* ptr to containing loop */

dcl  (p, prev) pointer;

	p = get_opt_space (size (loop));

	if dad ^= null
	then do;

	     /* derive information from containing loop */

	     p -> loop.father = dad;
	     p -> loop.prev_brother, prev = dad -> loop.last_son;
	     dad -> loop.last_son = p;
	     if prev ^= null
	     then prev -> loop.brother = p;
	     else dad -> loop.son = p;
	     p -> loop.depth = dad -> loop.depth + 1;
	     p -> loop.is_member = get_opt_space (size (dbits));
	     p -> loop.is_exit = get_opt_space (size (dbits));
	     p -> loop.articulation_blocks = get_opt_space (size (dbits));
	     p -> loop.induction_var = get_opt_space (size (bits));
	     p -> loop.may_keep_in_xr = get_opt_space (size (bits));
	     p -> loop.computed = get_opt_space (size (obits));
	     end;

	else do;

	     /* initialize information for adam_loop */

	     p -> loop.father, p -> loop.prev_brother, p -> loop.is_member, p -> loop.is_exit,
		p -> loop.articulation_blocks, p -> loop.induction_var, p -> loop.may_keep_in_xr, p -> loop.computed =
		null;
	     p -> loop.depth = 0;
	     end;

	p -> loop.xregs_used, p -> loop.pregs_used, p -> loop.number = 0;

	p -> loop.has_side_effects = "0"b;

	p -> loop.ancestors_and_me, p -> loop.brother, p -> loop.son, p -> loop.last_son, p -> loop.entry_unit,
	     p -> loop.exits, p -> loop.back_target, p -> loop.first_unit, p -> loop.last_unit, p -> loop.members,
	     p -> loop.global_xr_items, p -> loop.global_pr_items, p -> loop.range_list, p -> loop.msp,
	     p -> loop.eligible_ind_var_op_var, p -> loop.left_shift_chain = null;

	p -> loop.used = get_opt_space (size (bits));
	p -> loop.set = get_opt_space (size (bits));
	p -> loop.set_multiple = get_opt_space (size (bits));
	p -> loop.busy_on_exit = get_opt_space (size (bits));

	n_loops = n_loops + 1;

	return (p);

     end create_loop;

optimize_subprogram:
     procedure ();

	/* optimize_subprogram has a choice of 2 different optimization algorithms.  In the first algortihm, loops are
	   processed inside-out, front to back (in other words, bottom-up).  After all loops except the non-iterative
	   outer loop are processed, the whole program is passed over for a consoldation pass to remove common
	   subexpressions that were made removable by earlier optimizations.  In the second algorithm, loops are
	   processed top-down recursively.  After an inner loop is processed, all expressions moved out of that
	   loop are processed to see if they can be further moved, commoned, etc.

	   NOTE:  Commoning MUST occur in the same pass that candidates for strength
	   reduction are found because otherwise candidates for common
	   expressions may be found so far apart that inefficient init
	   code may be produced.  By commoning at the same time, fewer
	   candidates are found, thus init code will be better. */

	/* GLOBAL VARS */

dcl  our_depth fixed binary (18);
dcl  (fu, lp, bt, lpf) pointer;
dcl  (sr_chain, sr_tail, incr_chain, ass_chain, da_chain) pointer;
dcl  free_var_list pointer;
dcl  used_invariant_symbol bit (1) aligned;
dcl  doing_loop bit (1) aligned;

	/* LOCAL VARS */

dcl  (i, j, k, new_statement, op, opt_mode) fixed binary (18);
dcl  (stm, q, t, o, c, lastc) pointer;
dcl  srvp pointer;

	/* initialize */

	da_chain, free_var_list = null;

	if need_consolidation_pass
	then do;
	     incr_chain, sr_chain, sr_tail, ass_chain = null;

	     do i = 1 to n_loops - 1;
		lp = loop_vector (i);
		call optimize_loop (lp);
		end;

	     call consolidate_subprogram;
	     end;

	else call process_loops_top_down;

	/* recompute all usage bits */

	call timer (9);

	call recompute_usage;

	/* remove dead assignments */

	if da_chain ^= null
	then do;
	     call timer (7);
	     call remove_dead_assignments;
	     end;

	call timer (4);

	/* convert the loop_end_chains into operators and operands */

	do i = 2 to n_flow_units;			/* want to look at detached as well as attached units */
	     fu = flow_unit_vector (i);
	     if fu -> flow_unit.n_in_loop_end > 0
	     then do;
		new_statement = insert_statement_after ((fu -> flow_unit.last_statement));
		addr (quad (new_statement)) -> opt_statement.put_in_map = "0"b;
						/* no code */
		j = fu -> flow_unit.n_in_loop_end;
		k = 0;

		do c = fu -> flow_unit.loop_end_chain repeat c -> lchain.next while (c ^= null);
		     if k <= 0
		     then do;
			k = min (j, max_operands);
			op = insert_operator_after (loop_end_op, k, new_statement);
			o = addr (quad (op));
			end;
		     lastc = c;
		     o -> operand (k) = c -> lchain.value;
		     k = k - 1;
		     j = j - 1;
		     end;

		lastc -> lchain.next = free (size (chain));
		free (size (chain)) = fu -> flow_unit.loop_end_chain;

		fu -> flow_unit.last_statement = new_statement;

		fu -> flow_unit.n_in_loop_end = 0;
		fu -> flow_unit.loop_end_chain = null;
		end;
	     end;

	/* free all sr_var nodes */

	do srvp = free_var_list repeat q while (srvp ^= null);
	     if srvp -> sr_var.used_in -> lbits
	     then do;
		q = addr (rands (srvp -> sr_var.variable));
		q -> symbol.allocate, q -> symbol.referenced, q -> symbol.set = "1"b;
		end;
	     q = srvp -> sr_var.next;
	     srvp -> sr_var.next = freesrv;
	     freesrv = srvp;
	     end;

	free_var_list = null;

optimize_loop:
     procedure (p_lp);

	/* optimizes loops for the bottom-up algorithm */

dcl  (lp, p_lp) pointer;				/* ptr to loop */

dcl  (last_fu, next_lp) pointer;

	/* initialize */

	lp = p_lp;

	state_discarded = "1"b;
	our_depth = lp -> loop.depth;
	bt = lp -> loop.back_target;
	doing_loop = "1"b;

	call derive_insert_for_bt (bt);

	/* We now mask out the used bits of invariant symbols.  process_moved_descendants
	   will turn on the bits of those invariant symbols containing uses not actually
	   moved out of the loop. */

	lp -> loop.used -> bits = lp -> loop.used -> bits & lp -> loop.set -> bits;

	/* process the loop */

	last_fu, next_lp = null;

	do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null);
	     if last_fu ^= fu -> flow_unit.back
	     then do;

		/* we have passed over flow_units from other loops */

		if ^fu -> flow_unit.back -> flow_unit.falls_through
		then state_discarded = "1"b;
		else if ^state_discarded
		then if next_lp ^= fu -> flow_unit.back -> flow_unit.loop
		     then state_discarded = "1"b;
		end;

	     if fu -> flow_unit.loop_entry
	     then call clear ("0"b);			/* Leave hash index intact */

	     call optimize_flow_unit (fu, full_optimization, complete_fu, our_depth);

	     if fu -> flow_unit.next_in_loop ^= fu -> flow_unit.next
	     then do;

		/* we are about to pass over flow_units from other loops */

		if ^fu -> flow_unit.falls_through
		then state_discarded = "1"b;
		else do;
		     next_lp = fu -> flow_unit.next -> flow_unit.loop;

		     if our_depth < next_lp -> loop.depth
		     then call set_loop_variants (next_lp);
		     else do;
			call process_jump_target ((fu -> flow_unit.next -> flow_unit.first_statement));
			state_discarded = "1"b;
			end;
		     end;
		end;

	     last_fu = fu;
	     end;

	call finish_loop;

	call clear ("1"b);

     end optimize_loop;

consolidate_subprogram:
     procedure ();

	/* runs the consolidation pass for the bottom-up algorithm */

	/* uses optimize_subprogram's variables */

	call timer (8);

	consolidating = "1"b;

	/* remove all vestiges of the previous optimizations' effects from the opt_statement nodes */

	do fu = exit_unit -> flow_unit.back repeat fu -> flow_unit.back while (fu ^= entry_unit);
	     stm = addr (quad (fu -> flow_unit.first_statement));
	     if stm -> opt_statement.has_operator_list
	     then do;
		if stm -> opt_statement.operator_list ^= null
		then do;

		     /* release useless primaries on operator_list */

		     t = stm -> opt_statement.operator_list;
		     do q = t repeat t while (q ^= null);
			call release_node (q, t, 0);
			end;
		     stm -> opt_statement.operator_list = null;
		     end;

		fu -> flow_unit.is_active_operator -> obits = "0"b;
		stm -> opt_statement.has_operator_list = "0"b;
		end;

	     fu -> flow_unit.processed = "0"b;
	     end;

	/* Pass over all the flow_units. */

	do fu = entry_unit -> flow_unit.next repeat fu -> flow_unit.next while (fu ^= exit_unit);
	     lp = fu -> flow_unit.loop;
	     if lp = adam_loop
	     then opt_mode = full_optimization;
	     else opt_mode = common_only;
	     our_depth = lp -> loop.depth;

	     call optimize_flow_unit (fu, opt_mode, complete_fu, our_depth);
	     end;

	if meter_hash_buckets
	then call print_hash_bucket_meters;

	call clear ("1"b);

	consolidating = "0"b;

     end consolidate_subprogram;

process_loops_top_down:
     procedure ();

	/* this routine does top - down processing of loops */

	/* uses declaration in optimize_subprogram */

	/* begin processing of loops */

	if init_lp_frame = null
	then init_lp_frame, lpf = create_lp_frame (null);
	else lpf = init_lp_frame;

	lp = adam_loop;
	call start_loop;

	/* These nested loops simulate a recursive walk of the loop tree */

	do while (lp ^= null);

	     do while (lpf -> lp_frame.this_fu ^= null);
		fu = lpf -> lp_frame.this_fu;
		lpf -> lp_frame.this_fu = fu -> flow_unit.next_in_loop;

		if lpf -> lp_frame.last_fu ^= fu -> flow_unit.back
		then do;

		     /* we have passed over flow_units from other loops */

		     if ^fu -> flow_unit.back -> flow_unit.falls_through
		     then state_discarded = "1"b;
		     else if ^state_discarded
		     then if lpf -> lp_frame.next_lp ^= fu -> flow_unit.back -> flow_unit.loop
			then state_discarded = "1"b;
		     end;

		call optimize_flow_unit (fu, full_optimization, complete_fu, our_depth);

		if fu -> flow_unit.is_back_target
		then do;

		     /* we have a back target, so we now process inner loop */

		     call push_loop;
		     call start_loop;
		     end;

		else do;
		     if fu -> flow_unit.next_in_loop ^= fu -> flow_unit.next
		     then do;

			/* we are about to pass over flow_units from other loops */

			if ^fu -> flow_unit.falls_through
			then state_discarded = "1"b;
			else do;
			     lpf -> lp_frame.next_lp = fu -> flow_unit.next -> flow_unit.loop;

			     if our_depth < lpf -> lp_frame.next_lp -> loop.depth
			     then call set_loop_variants ((lpf -> lp_frame.next_lp));
			     else do;
				call process_jump_target ((fu -> flow_unit.next -> flow_unit.first_statement));
				state_discarded = "1"b;
				end;
			     end;
			end;

		     lpf -> lp_frame.last_fu = fu;
		     end;
		end;

	     /* processing of flow_units in this loop is done, we now wind up processing of the loop */

	     if doing_loop
	     then call finish_loop;

	     call clear ("1"b);

	     /* now pop the loop so we can resume processing of outer loop */

	     call pop_loop;

	     end;


     end process_loops_top_down;

start_loop:
     procedure ();

	/* initializes processing of a loop for the top-down algorithm */

	state_discarded = "1"b;
	our_depth = lp -> loop.depth;
	bt = lp -> loop.back_target;
	doing_loop = bt ^= null;
	incr_chain, sr_chain, sr_tail, ass_chain = null;
	lpf -> lp_frame.this_fu = lp -> loop.members;
	lpf -> lp_frame.last_fu, lpf -> lp_frame.next_lp = null;

     end start_loop;

finish_loop:
     procedure ();

dcl  (c, o, p, q, outp) pointer;
dcl  i fixed binary (18);
dcl  exit_target pointer unaligned;
dcl  has_multiple_exits bit (1) aligned;

	/* Because of the refinement of the used bits, we have to OR in the used
	   bits of inner loops, which have, of course, already been completely processed. */

	do p = lp -> loop.son repeat p -> loop.brother while (p ^= null);
	     lp -> loop.used -> bits = lp -> loop.used -> bits | p -> loop.used -> bits;
	     end;

	/* OR back target's primaries into entry unit */

	if ^need_consolidation_pass
	then call union ((lp -> loop.entry_unit), bt_list_st);

	/* DO STRENGTH REDUCTION */

	call timer (5);

	call reduce_strength (lp);

	call timer (4);

	/* Optionally, print out metering information on the primary lists. */

	if meter_hash_buckets
	then call print_hash_bucket_meters;

	/* Free all primaries in the back target.

	   For each temporary (or array_ref) in the bt_list
	   that still has used_across_loops bit on and is already
	   in a loop_end list for an inner loop, put the temp in
	   the loop_end list for this loop.  This fixes bug 218.	*/

	do i = 0 to hbound (bt_list, 1);

	     do p = bt_list (i) repeat q while (p ^= null);
		q = p -> primary.next;

		o = p -> primary.expression;
		outp = addr (rands (o -> operator.output));
		if outp -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
		then if outp -> temporary.used_across_loops
		     then if outp -> temporary.loop_end_fu_pos > 0
			     & outp -> temporary.loop_end_fu_pos < lp -> loop.last_unit -> flow_unit.position
			then call put_in_loop_end (outp, lp);

		call release_primary (p);
		end;

	     end;

	/* consider removing loop */

	if ^lp -> loop.has_side_effects
	then if (lp -> loop.set -> bits & lp -> loop.busy_on_exit -> bits) = "0"b
	     then do;

		/* loop must have only 1 exit target */

		if lp -> loop.exits = null
		then do;
		     call print_message (389);	/* loop has no exit */
		     return;
		     end;

		exit_target = lp -> loop.exits -> chain.value -> edge.to.value;
		has_multiple_exits = "0"b;

		do c = lp -> loop.exits -> chain.next repeat c -> chain.next while (c ^= null & ^has_multiple_exits);
		     if exit_target ^= c -> chain.value -> edge.to.value
		     then has_multiple_exits = "1"b;
		     end;

		if ^has_multiple_exits
		then call remove_loop (lp);
		end;

     end finish_loop;

push_loop:
     procedure ();

	/* prepares for processing of inner loop for the top-down algorithm */

dcl  i fixed binary (18);
dcl  (o, p, q, hold_list, outp, next_lp, last_p) pointer;

	/* save the present machine state so we can resume it later */

	hold_list = null;

	do i = 0 to hbound (p_list, 1);
	     do p = p_list (i) repeat p -> primary.next while (p ^= null);
		q = create_o_node (hold_list, 0);
		q -> primary.data = p -> primary.data;
		end;
	     end;

	lpf -> lp_frame.hold_p_list = hold_list;

	hold_list = null;

	do i = 0 to hbound (bt_list, 1);
	     do p = bt_list (i) repeat p -> primary.next while (p ^= null);
		q = create_o_node (hold_list, 0);
		q -> primary.data = p -> primary.data;
		end;
	     end;

	lpf -> lp_frame.hold_bt_list = hold_list;

	/* save strength reduction candidate state */

	lpf -> lp_frame.hold_incr_chain = incr_chain;
	lpf -> lp_frame.hold_sr_chain = sr_chain;
	lpf -> lp_frame.hold_sr_tail = sr_tail;
	lpf -> lp_frame.hold_ass_chain = ass_chain;

	/* now set the loop variants for the new loop */

	next_lp = fu -> flow_unit.successors -> edge.to.value -> flow_unit.loop;
	call set_loop_variants (next_lp);

	/* add p_list onto bt_list & null out p_list */

	do i = 0 to hbound (p_list, 1);
	     last_p = null;

	     do p = p_list (i) repeat p -> primary.next while (p ^= null);
		o = p -> primary.expression;
		outp = addr (rands (o -> operator.output));
		if outp -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
		then outp -> temporary.invariant = "1"b;
		last_p = p;
		end;

	     if last_p ^= null
	     then do;
		last_p -> primary.next = bt_list (i);
		if bt_list (i) ^= null
		then bt_list (i) -> primary.last = last_p;
		bt_list (i) = p_list (i);
		bt_list (i) -> primary.last = addr (bt_list (i));
		p_list (i) = null;
		end;
	     end;

	/* we can now detach secondaries (except for constant assignments), since only loop invariants are left */

	call detach_secondaries ("0"b);

	/* fill in insert_* fields in back target of next_lp */

	bt = fu;

	call derive_insert_for_bt (bt);

	/* build a new opt_statement node to mark place we should resume operation in pop_loop */

	call insert_stm_in_back_target (bt, addr (quad (bt -> flow_unit.insert_statement)));

	lpf -> lp_frame.resume_st = bt -> flow_unit.insert_statement;

	/* UPDATE lp */

	lp = next_lp;

	if lpf -> lp_frame.next = null
	then lpf = create_lp_frame (lpf);
	else lpf = lpf -> lp_frame.next;

	/* We now mask out the used bits of invariant symbols.  process_moved_descendants
	   will turn on the bits of those invariant symbols whose uses are not moved
	   out of the loop. */

	lp -> loop.used -> bits = lp -> loop.used -> bits & lp -> loop.set -> bits;

     end push_loop;

pop_loop:
     procedure ();

	/* prepares to resume processing of an outer loop after the inner loop is completed.  All
	   expressions moved to the outer loop are now processed.  */

dcl  (hold_has_label, hold_has_operator_list, hold_entry_pt, possibly_found) bit (1) aligned;
dcl  (p, q, hold_list, new, stm, o, outp, c, last_c, old_lp) pointer;
dcl  (hash_index, hold_first_statement) fixed binary (18);

	fu = lp -> loop.back_target;

	/* RESTORE lp */

	old_lp = lp;
	lp = lp -> loop.father;
	lpf = lpf -> lp_frame.back;

	if lp = null
	then return;

	/* restore machine state */

	hold_list = lpf -> lp_frame.hold_p_list;
	lpf -> lp_frame.hold_p_list = null;

	do p = hold_list repeat q while (p ^= null);
	     q = p -> primary.next;
	     o = p -> primary.expression;

	     if ^o -> operator.freed
	     then do;
		outp = addr (rands (o -> operator.output));
		if outp -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
		then outp -> temporary.invariant = "0"b;

		hash_index = hash (o, possibly_found);
		new = create_primary (p_list_st (hash_index));
		new -> primary.data = p -> primary.data;
		o -> operator.primary = new;
		call record_secondaries (o, 0);
		end;

	     call release_node (p, hold_list, 0);
	     end;

	hold_list = lpf -> lp_frame.hold_bt_list;
	lpf -> lp_frame.hold_bt_list = null;

	do p = hold_list repeat q while (p ^= null);
	     q = p -> primary.next;
	     o = p -> primary.expression;

	     if ^o -> operator.freed
	     then do;
		hash_index = hash (o, possibly_found);
		new = create_primary (bt_list_st (hash_index));
		new -> primary.data = p -> primary.data;
		o -> operator.primary = new;
		if o -> operator.assigns_constant_to_symbol
		then call record_secondaries (o, -1);
		end;

	     call release_node (p, hold_list, 0);
	     end;

	state_discarded = "0"b;

	/* restore strength reduction candidate state */

	incr_chain = lpf -> lp_frame.hold_incr_chain;
	sr_chain = lpf -> lp_frame.hold_sr_chain;
	sr_tail = lpf -> lp_frame.hold_sr_tail;
	ass_chain = lpf -> lp_frame.hold_ass_chain;

	/* restore other global vars */

	our_depth = lp -> loop.depth;
	bt = lp -> loop.back_target;
	doing_loop = bt ^= null;

	/* process new operators that have been moved up from the inner loop.
	   This will be done by fooling optimize_flow_unit into doing it.  */

	hold_first_statement = fu -> flow_unit.first_statement;
	fu -> flow_unit.first_statement = lpf -> lp_frame.resume_st;
	stm = addr (quad (fu -> flow_unit.first_statement));
	hold_has_operator_list = stm -> opt_statement.has_operator_list;
	stm -> opt_statement.has_operator_list = "0"b;
	hold_has_label = fu -> flow_unit.has_label;
	fu -> flow_unit.has_label = "0"b;
	hold_entry_pt = fu -> flow_unit.entry_pt;
	fu -> flow_unit.entry_pt = "0"b;

	call optimize_flow_unit (fu, full_optimization, partial_fu, our_depth);

	fu -> flow_unit.entry_pt = hold_entry_pt;
	fu -> flow_unit.has_label = hold_has_label;
	stm -> opt_statement.has_operator_list = hold_has_operator_list;
	fu -> flow_unit.first_statement = hold_first_statement;

	/* union new p_list with jump_targets first referenced by inner loop */

	if lpf -> lp_frame.first_jump_target ^= null
	then do;
	     call set_loop_variants (old_lp);

	     last_c = null;
	     do c = lpf -> lp_frame.first_jump_target repeat c -> chain.next while (c ^= null);
		call union ((c -> chain.value), p_list_st);
		last_c = c;
		end;

	     last_c -> chain.next = free (size (chain));
	     free (size (chain)) = lpf -> lp_frame.first_jump_target;
	     lpf -> lp_frame.first_jump_target = null;
	     end;

     end pop_loop;

create_lp_frame:
     procedure (last_p) returns (pointer);

	/* creates lp_frame to help in recursive processing of loops */

dcl  last_p pointer;				/* -> lp_frame we are to connect to the new one */

dcl  p pointer;

	p = get_opt_space (size (lp_frame));

	p -> lp_frame.next = null;
	p -> lp_frame.back = last_p;
	if last_p ^= null
	then last_p -> lp_frame.next = p;
	p -> lp_frame.first_jump_target = null;

	return (p);

     end create_lp_frame;

optimize_flow_unit:
     procedure (p_fu, mode, how_much, p_our_depth);

	/* optimize_flow_unit implements an optimization algorithm that has been developed (with many improvements) from
	   the algorithm used by the Multics PL/I common subexpression optimizer (as of 1977).  The two primary lists,
	   p_list and bt_list, are lists of expressions available for commoning; bt_list is the list of expressions
	   originating outside of the loop.  The secondary list, s_list, is a list of variables upon which the exprs
	   in the p_list depend.  When a variable in s_list is set, all expressions in the p_list depending on that
	   variable are removed.  No expressions are removed from bt_list since they are loop invariant.  bt_list
	   is only used if mode = full_optimization.  */

dcl  (fu, p_fu) pointer;				/* flow_unit being optimized */
dcl  mode fixed binary (18);				/* full_optimization, common_only */
dcl  how_much fixed binary (18);			/* complete_fu, partial_fu */
dcl  (our_depth, p_our_depth) fixed binary (18);		/* flow_unit's nesting depth */

dcl  ipol fixed bin (18);				/* polish index for read_namelist */
dcl  (bt, o, outp, p, q, stm, lp) pointer;
dcl  (bd_level_number, coord, i, next_op, next_statement, next_unit_statement, op_code, opnd, outp_node_type, hash_index)
	fixed binary (18);
dcl  (invariant, is_articulation_block, used_across_loops, reducible, all_constant, have_sr_candidate,
     doing_full_optimization, succeeded, optimizing_loop, possibly_found, constant_assignment) bit (1) aligned;

	fu = p_fu;
	doing_full_optimization = mode = full_optimization;
	our_depth = p_our_depth;

	if fu -> flow_unit.first_statement = 0
	then return;

	stm = addr (quad (fu -> flow_unit.first_statement));

	/* process possible label or operator_list starting the flow unit */

	if fu -> flow_unit.has_label | stm -> opt_statement.has_operator_list
	then do;

	     if state_discarded
	     then do;
		call intersection (stm, 1);
		call intersection (stm, 3);
		end;

	     if stm -> opt_statement.referenced_backwards & ^stm -> opt_statement.referenced_by_assign
	     then do;
		call set_loop_variants ((fu -> flow_unit.loop));

		/* determine level number of most recently processed back dominator */

		do p = fu -> flow_unit.dominator repeat p -> flow_unit.dominator while (^p -> flow_unit.processed);
		     end;

		bd_level_number = p -> flow_unit.level_number;

		/* remove computations first evaluated in a flow unit of higher level number */

		do i = 0 to hbound (p_list, 1);
		     p = p_list (i);
		     do while (p ^= null);
			if p -> primary.flow_unit -> flow_unit.level_number > bd_level_number
			then do;
			     q = p -> primary.next;
			     call release_primary (p);
			     p = q;
			     end;
			else p = p -> primary.next;
			end;
		     end;

		if state_discarded
		then call intersection (stm, 2);
		end;

	     if ^state_discarded
	     then do;
		call intersection (stm, 1);
		call intersection (stm, 2);
		end;

	     if ^fu -> flow_unit.loop_entry
	     then call trim_operator_list (stm);

	     state_discarded = "0"b;

	     end;

	/* initialize for optimization loop */

	lp = fu -> flow_unit.loop;
	is_articulation_block = substr (lp -> loop.articulation_blocks -> dbits, fu -> flow_unit.number, 1);
	bt = lp -> loop.back_target;
	if fu -> flow_unit.next ^= null
	then next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement;
	else next_unit_statement = 0;

	/* mask out used bits for invariant symbols as process_moved_descendants will recalculate these bits */

	if doing_full_optimization & bt ^= null
	then do;
	     if how_much = complete_fu
	     then fu -> flow_unit.used -> bits = fu -> flow_unit.used -> bits & lp -> loop.set -> bits;
	     optimizing_loop = "1"b;
	     end;
	else optimizing_loop = "0"b;

	/* optimization loop */

	do cur_statement = fu -> flow_unit.first_statement repeat next_statement
	     while (cur_statement ^= next_unit_statement);
	     stm = addr (quad (cur_statement));
	     next_statement = fixed (stm -> opt_statement.next, 18);

	     do op = stm -> opt_statement.first_operator repeat next_op while (op ^= next_statement);
		o = addr (quad (op));
		op_code = o -> operator.op_code;
		next_op = o -> operator.next;
		if o -> operator.output > 0
		then do;
		     outp = addr (rands (o -> operator.output));
		     outp_node_type = outp -> node.node_type;
		     end;
		else do;
		     outp = null;
		     outp_node_type = 0b;
		     end;

		/* determine reducibility and moveability of operands */

		constant_assignment, have_sr_candidate, used_invariant_symbol, used_across_loops = "0"b;
		all_constant = "1"b;
		reducible = "1"b;
		invariant = optimizing_loop;

		do i = 1 to o -> operator.number;
		     opnd = o -> operand (i);

		     if opnd > 0
		     then do;
			p = addr (rands (opnd));

			if p -> node.node_type = constant_node
			then do;
			     if op_code = opt_subscript_op & i = 3
			     then call make_constant_opt_subscript (o);
			     else if have_identity (o, i)
			     then go to step;
			     end;

			else if p -> node.node_type = array_ref_node
			then do;
			     used_across_loops = used_across_loops | p -> array_ref.used_across_loops;
			     if p -> array_ref.irreducible
			     then reducible = "0"b;
			     invariant = invariant & p -> array_ref.invariant;
			     p = addr (rands (p -> array_ref.parent));
			     all_constant = "0"b;
			     coord = p -> symbol.coordinate;
			     if coord > 0
			     then if substr (lp -> loop.set -> bits, coord, 1)
				then invariant = "0"b;
				else used_invariant_symbol = optimizing_loop;
			     p -> symbol.has_constant_value = "0"b;
						/* Optimizer botches substring whose parent has constant value. */
			     end;

			else if p -> node.node_type = symbol_node
			then do;
			     if p -> symbol.has_constant_value & (op_code ^= call_op) & (op_code ^= func_ref_op)
				& (op_code ^= opt_subscript_op | i ^= 1)
			     then do;
				o -> operand (i) =
				     p -> symbol.secondary -> secondary.primary -> chain.value
				     -> primary.expression -> operand (1);

				if op_code = opt_subscript_op & i = 3
				then call make_constant_opt_subscript (o);
				else if have_identity (o, i)
				then go to step;
				end;

			     else do;
				all_constant = "0"b;

				if i ^= 1 | op_code ^= opt_subscript_op
				then do;
				     coord = p -> symbol.coordinate;
				     if coord > 0
				     then if substr (lp -> loop.set -> bits, coord, 1)
					then invariant = "0"b;
					else used_invariant_symbol = optimizing_loop;
				     end;
				end;
			     end;

			else if p -> node.node_type = temporary_node
			then do;
			     if p -> temporary.frozen_for_do
			     then call process_frozen_for_do (p);

			     else do;
				all_constant = "0"b;
				used_across_loops = used_across_loops | p -> temporary.used_across_loops;
				if p -> temporary.irreducible
				then reducible = "0"b;
				invariant = invariant & p -> temporary.invariant;
				end;
			     end;
			end;
		     end;

		if outp_node_type = array_ref_node
		then do;
		     if outp -> array_ref.irreducible
		     then reducible = "0"b;
		     used_across_loops = used_across_loops | outp -> array_ref.used_across_loops;
		     end;

		else if outp_node_type = temporary_node
		then if outp -> temporary.frozen_for_do
		     then if addr (rands (o -> operand (1))) -> node.node_type ^= array_ref_node
			then invariant = "0"b;
			else ;
		     else ;

		else if all_constant & op_code = assign_op
		then constant_assignment = constant_assign (o);

		if reducible & op_class (op_code) <= highest_reducible_class
		then do;

		     /* handle reducible operators */

		     if outp_node_type = temporary_node | op_code = opt_subscript_op
		     then outp -> temporary.used_across_loops, outp -> temporary.invariant = "0"b;

		     /* search current machine state for equivalent expression */

		     hash_index = hash (o, possibly_found);

		     if possibly_found
		     then do;
			do p = p_list (hash_index) repeat p -> primary.next while (p ^= null);
			     q = p -> primary.expression;
			     if compare_expression (o, q)
			     then do;
				call common (o, q, succeeded);
				if succeeded
				then go to step;
				end;
			     end;

			/* search back target for equivalent expression */

			if invariant
			then do p = bt_list (hash_index) repeat p -> primary.next while (p ^= null);
				q = p -> primary.expression;
				if compare_expression (o, q)
				then do;
				     call common (o, q, succeeded);
				     go to step;
				     end;
				end;
			end;

		     /* attempt to fold the operation if all operands are constants */

		     if all_constant & op_class (op_code) < assignment_class
		     then if constant_expression (o)
			then go to step;

		     /* try to move the expression */

		     if invariant & (is_articulation_block | op_class (op_code) <= always_safe_to_move_class)
		     then do;
			p = outp;

			/* check the output operand for suitability */

			if outp_node_type ^= temporary_node
			then do;
			     if outp_node_type = array_ref_node & op_code ^= opt_subscript_op
			     then do;
				invariant = invariant & p -> array_ref.invariant;
				if invariant
				then p = addr (rands (p -> array_ref.parent));
				end;

			     if p -> node.node_type = symbol_node
			     then do;
				coord = p -> symbol.coordinate;
				if substr (bt -> flow_unit.busy_on_exit -> bits, coord, 1)
				     | substr (lp -> loop.set_multiple -> bits, coord, 1)
				then invariant = "0"b;
				end;
			     end;

			if invariant
			then do;

			     /* We can move it! */

			     call move (o, stm, fu, bt);

			     /* add the operator to the back target's machine state */

			     p = create_primary (bt_list_st (hash_index));
			     p -> primary.expression = o;
			     p -> primary.flow_unit = bt;
			     o -> operator.primary = p;

			     if constant_assignment
			     then do;
				o -> operator.assigns_constant_to_symbol = "1"b;
				call record_secondaries (o, -1);
				end;

			     go to step;
			     end;
			end;

		     /* not moved or commoned, add the expression to the primary list,
		        process set contexts, and process moved descendants */

		     p = create_primary (p_list_st (hash_index));
		     p -> primary.expression = o;
		     p -> primary.flow_unit = fu;
		     o -> operator.primary = p;
		     call record_secondaries (o, 1);	/* record input operands as secondaries */

		     if outp_node_type ^= temporary_node & op_code ^= opt_subscript_op
		     then do;
			call set (outp);

			if o -> operator.primary ^= null
						/* the primary could have been removed if the target */
			then do;			/* also appeared on the right hand side. */
			     if constant_assignment
			     then do;
				o -> operator.assigns_constant_to_symbol = "1"b;
				if doing_full_optimization & ^outp -> symbol.aliasable
				then call chain_dac ((o -> operator.output), fu);
				end;

			     call record_secondaries (o, -1);
						/* record output operand as secondary */
			     end;
			end;

		     /* look for add, subtract, multiply, or increment by a loop invariant */

		     if doing_full_optimization & outp -> node.data_type = int_mode
		     then if (op_code = mult_op | op_code = add_op | op_code = sub_op) & optimizing_loop
			then have_sr_candidate = check_str_reducibility ();
			else if op_code = assign_op
			then call check_increment;

		     if ^have_sr_candidate & (used_across_loops | used_invariant_symbol)
		     then call process_moved_descendants (o, fu);
		     end;

		else do;

		     /* irreducible operators (and operands) */

		     if used_across_loops | used_invariant_symbol
		     then call process_moved_descendants (o, fu);

		     if outp_node_type ^= 0b & outp_node_type ^= temporary_node & op_code ^= opt_subscript_op
		     then call set (outp);

		     /* handle special cases */

		     go to case (op_class (op_code));

case (4):						/* assignment */
		     if doing_full_optimization & outp -> node.data_type = int_mode & op_code = assign_op
		     then call check_increment;
		     go to join;

case (6):						/* call & func_ref */
		     do i = 3 to o -> operator.number;
			call set (addr (rands (o -> operand (i))));
			end;

		     call set_externals;
		     go to join;

case (7):						/* entry points */
		     call clear ("1"b);
		     state_discarded = "0"b;
		     go to join;

case (8):						/* jump */
		     call process_jump_label ((o -> operand (1)));
		     state_discarded = "1"b;
		     go to join;

case (9):						/* jump_arithmetic */
		     do i = 2 to 4;
			call process_jump_label ((o -> operand (i)));
			end;
		     state_discarded = "1"b;
		     go to join;

case (10):					/* jump_computed */
		     do i = 1 to o -> operand (1) + bias;
			call process_jump_label ((o -> operand (i + 1)));
			end;
		     go to join;

case (11):					/* jump_assigned */
case (13):					/* return, stop */
		     state_discarded = "1"b;
		     go to join;

case (12):					/* jump_true, jump_false */
		     call process_jump_label ((o -> operand (2)));
		     go to join;

case (18):					/* read_namelist */
		     ipol = addr (rands (o -> operand (1))) -> symbol.initial;
		     do i = 1 to polish (ipol);
			call set (addr (rands (polish (ipol + i))));
			end;
		     goto join;

case (1):						/* reducible */
case (2):						/* .. */
case (3):						/* .. */
case (5):						/* assignment */
case (14):					/* error_label, end_label */
case (15):					/* irreducible */
case (16):					/* assign_label */
case (17):					/* end_unit */
case (19):					/* write_namelist */
case (20):					/* non_executable, no_op */
case (21):					/* irreducible, partially sets */
case (22):					/* inquire */
join:
		     if outp_node_type = temporary_node | op_code = opt_subscript_op
		     then outp -> temporary.irreducible = "1"b;
		     end;

step:
		end;

	     end;

	fu -> flow_unit.processed = "1"b;

compare_expression:
     procedure (pa, pb) returns (bit (1) aligned);

dcl  (pa, pb) pointer;

dcl  (a, b, r1, r2) pointer;
dcl  i fixed binary (18);

	a = pa;
	b = pb;

	/* Although it is inelegant, we compare operand(1) outside the loop
	   for  speed.  This is valid because all reducible operators must
	   have at least one input operand. */

	if a -> operand (1) ^= b -> operand (1)
	then go to fail;

	if a -> operator.op_code ^= b -> operator.op_code
	then go to fail;

	if a -> operator.number ^= b -> operator.number
	then go to fail;

	do i = 2 to a -> operator.number;
	     if a -> operand (i) ^= b -> operand (i)
	     then go to fail;
	     end;

	if a -> operator.output ^= b -> operator.output
	then do;
	     r1 = addr (rands (a -> operator.output));
	     r2 = addr (rands (b -> operator.output));
	     if r1 -> node.node_type ^= r2 -> node.node_type
	     then go to fail;
	     if r1 -> node.node_type ^= temporary_node
	     then if b -> operator.op_code ^= opt_subscript_op
		then go to fail;
	     end;

	return ("1"b);

fail:
	return ("0"b);

     end compare_expression;

common:
     procedure (p_old, p_new, succeeded);

	/* removes common (or redundant) expressions */

dcl  (p_old, old) pointer,				/* ptr to operator to be commoned (input) */
     (p_new, new) pointer,				/* ptr to operator already in machine state (input) */
     succeeded bit (1) aligned;			/* "1"b if commoning succeeds (output) */

dcl  (old_outp, new_outp, old_startp, new_fu) pointer;
dcl  (new_out, old_out, i) fixed binary (18);

	old = p_old;
	new = p_new;

	/* replace instances of old's output with new's output */

	old_out = old -> operator.output;
	new_out = new -> operator.output;
	new_outp = addr (rands (new_out));
	old_outp = addr (rands (old_out));

	/* if loop nesting depths of new and old differ, then appropriate action must be taken */

	new_fu = new -> operator.primary -> primary.flow_unit;

	if new_fu -> flow_unit.loop ^= fu -> flow_unit.loop
	then if new_fu -> flow_unit.loop -> loop.depth <= our_depth
	     then do;
		if doing_full_optimization
		then new_outp -> temporary.invariant = "1"b;
		new_outp -> temporary.used_across_loops = "1"b;
		end;

	     else do;

		/* we will allow commoning from inside to ouside only if inner temp has high ref count */

		if new_outp -> node.node_type = temporary_node
		then if new_outp -> temporary.ref_count = 1
		     then do;
			succeeded = "0"b;
			return;
			end;

		new -> operator.primary -> primary.flow_unit = fu;
		end;

	succeeded = "1"b;

	/* Do actual commoning */

	if old_outp -> node.node_type = temporary_node | old -> operator.op_code = opt_subscript_op
	then do;
	     if old_outp -> temporary.ref_count > 0
	     then do;
		new_outp -> temporary.ref_count = new_outp -> temporary.ref_count + old_outp -> temporary.ref_count;
		old_outp -> temporary.ref_count = 0;
		old_startp = addr (polish (old_outp -> temporary.start_input_to));

		call replace_inputs (old_startp, new_out);

		addr (polish (new_outp -> temporary.end_input_to)) -> input_to.next = old_startp;
		new_outp -> temporary.end_input_to = old_outp -> temporary.end_input_to;
		end;
	     end;

	else do;
	     if old_outp -> node.node_type = array_ref_node
	     then do;				/* ref_count will be decremented by free_operator (disconnect_temporary) */
		old_outp = addr (rands (old_outp -> array_ref.parent));
		end;

	     /* old_outp is now a symbol,  so update busy_on_exit */

	     if fu ^= new_fu
	     then do;
		i = old_outp -> symbol.coordinate;
		substr (new_fu -> flow_unit.busy_on_exit -> bits, i, 1) =
		     substr (new_fu -> flow_unit.busy_on_exit -> bits, i, 1)
		     | (substr (fu -> flow_unit.busy_on_exit -> bits, i, 1)
		     | substr (fu -> flow_unit.used -> bits, i, 1));
		end;
	     end;

	/* decrement ref counts of inputs and free the operator */

	call decrement_input_ref_counts (old);

	call free_operator (old);

     end common;

have_identity:
     procedure (o, i) returns (bit (1) aligned);

	/* this routine looks for adds or subtracts of zero or multiplies by one.  These should only have
	   been produced by the optimizer during strength reduction + constant_expression.  This has the problem
	   of not setting the used bits for symbols replacing the temporary so that the effect must be locally
	   restricted.  */

dcl  o pointer,					/* -> operator being checked */
     i fixed binary (18);				/* index of operand having a constant value */

dcl  other fixed binary (18);
dcl  (otherp, inp) pointer;

	if o -> operand (i) = one & op_code = mult_op
	     | o -> operand (i) = zero & (op_code = add_op | (op_code = sub_op & i = 2))
	then do;
	     other = o -> operand (3 - i);
	     otherp = addr (rands (other));
	     inp = addr (polish (outp -> temporary.start_input_to));

	     call replace_inputs (inp, other);

	     if otherp -> node.node_type = temporary_node | otherp -> node.node_type = array_ref_node
	     then do;
		otherp -> temporary.ref_count = otherp -> temporary.ref_count - 1 + outp -> temporary.ref_count;
		addr (polish (otherp -> temporary.end_input_to)) -> input_to.next = inp;
		otherp -> temporary.end_input_to = outp -> temporary.end_input_to;
		end;

	     call free_operator (o);

	     return ("1"b);
	     end;

	else return ("0"b);

     end have_identity;

check_str_reducibility:
     procedure () returns (bit (1) aligned);

	/* this routine chains together all multiplies, adds, and subtracts by a loop
	   invariant of a simple integer variable as long as they are not increments or decrements */

dcl  (p, next_op) pointer;
dcl  i fixed binary (18);
dcl  is_loop_invariant (2) bit (1) aligned;

	if op_code ^= mult_op
	then do;
	     next_op = addr (polish (outp -> temporary.start_input_to)) -> input_to.operator;
	     if next_op -> operator.op_code = assign_op
	     then if next_op -> operator.output = o -> operand (1) | next_op -> operator.output = o -> operand (2)
		then return ("0"b);
	     end;

	is_loop_invariant (1), is_loop_invariant (2) = "0"b;

	do i = 1 to 2;
	     p = addr (rands (o -> operand (i)));

	     if p -> node.node_type = array_ref_node
	     then return ("0"b);

	     else if p -> node.node_type = constant_node
	     then is_loop_invariant (i) = "1"b;

	     else if p -> node.node_type = temporary_node
	     then if p -> temporary.invariant
		then is_loop_invariant (i) = "1"b;
		else return ("0"b);

	     else if ^substr (lp -> loop.set -> bits, p -> symbol.coordinate, 1)
	     then is_loop_invariant (i) = "1"b;
	     else if p -> symbol.aliasable | p -> symbol.dimensioned
		| substr (lp -> loop.set_multiple -> bits, p -> symbol.coordinate, 1)
	     then return ("0"b);

	     end;

	/* if both or neither are loop invariant, then give up */

	if is_loop_invariant (1) = is_loop_invariant (2)
	then return ("0"b);

	if is_loop_invariant (1)
	then i = 2;
	else i = 1;

	/* chain this on sr_chain */

	call chain_sr_cand (o, i, stm);

	return ("1"b);

     end check_str_reducibility;

check_increment:
     procedure ();

	/* this routine optimizes incrementing and decrementing of an integer variable by replacing the 2 operations
	   with a "to_storage" op.  It then chains operators that update induction variables. */

dcl  (oexpr, inp, incrp) pointer;
dcl  (target, i, op_code, input) fixed binary (18);
dcl  is_temp_or_array_ref bit (1) aligned;

	input = o -> operand (1);
	inp = addr (rands (input));

	if inp -> node.node_type ^= temporary_node
	then do;
	     if bt ^= null & inp -> node.node_type = symbol_node & outp_node_type = symbol_node
		& full_strength_reduction
	     then do;

		/* The assignment is of the form i = j.  If both variables
		   could be induction variables, then chain the assignment
		   on ass_chain.  Obviously, if RHS is known to be an
		   induction variable, we can chain directly on incr_chain. */

		if ^outp -> symbol.aliasable & ^substr (lp -> loop.set_multiple -> bits, outp -> symbol.coordinate, 1)
		then if substr (lp -> loop.induction_var -> bits, inp -> symbol.coordinate, 1)
		     then do;
			substr (lp -> loop.induction_var -> bits, outp -> symbol.coordinate, 1) = "1"b;
			call chain_incr (o, stm, incr_chain);
			end;
		     else if ^inp -> symbol.aliasable & substr (lp -> loop.set -> bits, inp -> symbol.coordinate, 1)
			& ^substr (lp -> loop.set_multiple -> bits, inp -> symbol.coordinate, 1)
		     then call chain_incr (o, stm, ass_chain);
		end;

	     return;
	     end;

	/* See if this operation is an incrementing or decrementing of an integer. */

	oexpr = addr (quad (inp -> temporary.output_by));
	op_code = oexpr -> operator.op_code;

	if op_code ^= add_op & op_code ^= sub_op
	then return;

	target = o -> operator.output;

	do i = 1 to 2 while (oexpr -> operand (i) ^= target);
	     end;

	if i > 2
	then return;

	/* we have an optimizable incrementing or decrementing.  Make the new operator. */

	incrp = addr (rands (oexpr -> operand (3 - i)));
	is_temp_or_array_ref = incrp -> node.node_type = array_ref_node | incrp -> node.node_type = temporary_node;

	if op_code = add_op
	then if incrp = onep
	     then do;
		o -> operator.op_code = storage_add_one_op;
		o -> operator.number = 0;
		end;
	     else do;
		o -> operator.op_code = storage_add_op;
		o -> operand (1) = oexpr -> operand (3 - i);
		end;

	else do;
	     o -> operand (1) = oexpr -> operand (3 - i);
	     if i = 1
	     then o -> operator.op_code = neg_storage_add_op;
	     else o -> operator.op_code = storage_sub_op;
	     end;

	/* now adjust ref counts */

	if inp -> temporary.ref_count <= 1
	then do;
	     if outp_node_type = array_ref_node
	     then outp -> array_ref.ref_count = outp -> array_ref.ref_count - 1;

	     call free_operator (oexpr);
	     end;

	else do;
	     call disconnect_temporary (inp, o);
	     if is_temp_or_array_ref
	     then incrp -> temporary.ref_count = incrp -> temporary.ref_count + 1;
	     end;

	/* adjust the input chains */

	if is_temp_or_array_ref
	then call chain_input (incrp, o, 1);

	/* see if this incrementing should go on the incr_chain. */

	if o -> operator.op_code = storage_sub_op | bt = null
	then return;

	/* the target must be a simple integer, set only once in the loop */

	if outp_node_type = array_ref_node
	then return;

	if outp -> symbol.aliasable | substr (lp -> loop.set_multiple -> bits, outp -> symbol.coordinate, 1)
	then return;

	/* the increment must be loop invariant and not an array element */

	if incrp -> node.node_type = array_ref_node
	then return;

	else if incrp -> node.node_type = symbol_node
	then if incrp -> symbol.aliasable | substr (lp -> loop.set -> bits, incrp -> symbol.coordinate, 1)
	     then return;
	     else ;

	else if incrp -> node.node_type = temporary_node
	then if incrp -> temporary.invariant
	     then if addr (quad (incrp -> temporary.output_by)) -> operator.primary -> primary.flow_unit
		     -> flow_unit.loop = lp
		then return;
		else ;
	     else return;

	/* We have found an induction variable, mark and chain it. */

	substr (lp -> loop.induction_var -> bits, outp -> symbol.coordinate, 1) = "1"b;

	call chain_incr (o, stm, incr_chain);

     end check_increment;

process_frozen_for_do:
     procedure (pt);

	/* either sets appropriate bits for temp used to freeze do increment or limit, or replaces it with a symbol */

dcl  (p, pt) pointer;				/* -> temporary with frozen_for_do bit on */

dcl  (assp, s) pointer;
dcl  hash_index fixed binary (18);
dcl  possibly_found bit (1) aligned;

	p = pt;

	/* get ptr to operator producing this temp  (it must be assign_op) */

	assp = addr (quad (p -> temporary.output_by));

	/* if rhs is invariant symbol or constant, then we will replace the temp */

	s = addr (rands (assp -> operand (1)));

	if s -> node.node_type = constant_node
	then do;
	     call replace_lhs_with_rhs;
	     return;
	     end;

	if s -> node.node_type = symbol_node
	then if ^substr (lp -> loop.set -> bits, s -> symbol.coordinate, 1)
	     then if bt ^= null ()
		then if ^substr (bt -> flow_unit.set -> bits, s -> symbol.coordinate, 1)
		     then do;
			call replace_lhs_with_rhs;

			used_invariant_symbol = "1"b;
			all_constant = "0"b;

			return;
			end;

	all_constant, p -> temporary.irreducible, p -> temporary.frozen_for_do = "0"b;

	/* following code should be executed only if we're in a real loop */

	if bt ^= null
	then do;
	     p -> temporary.invariant, p -> temporary.used_across_loops, used_across_loops = "1"b;


	     /* we have to make sure there is a primary for assp so that
	        process_moved_descendants will work */

	     if assp -> operator.primary = null
	     then do;
		hash_index = hash (assp, possibly_found);
		p = create_primary (bt_list_st (hash_index));
		p -> primary.expression = assp;
		p -> primary.flow_unit = bt;
		assp -> operator.primary = p;
		end;
	     end;

replace_lhs_with_rhs:
     procedure ();

	call replace_inputs (addr (polish (p -> temporary.start_input_to)), (assp -> operand (1)));
	call free_operator (assp);

     end replace_lhs_with_rhs;

     end process_frozen_for_do;

     end optimize_flow_unit;

decrement_input_ref_counts:
     procedure (p_o);

	/* decrements input operand ref_counts */

dcl  (i, opnd) fixed binary (18);
dcl  (p_o, o, p) pointer;

	o = p_o;

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then do;
		p = addr (rands (opnd));
		if p -> node.node_type = temporary_node | p -> node.node_type = array_ref_node
		then p -> temporary.ref_count = p -> temporary.ref_count - 1;
		end;
	     end;

     end decrement_input_ref_counts;

chain_sr_cand:
     procedure (o, i, stm);

	/* adds a new sr_cand to the tail of the sr_chain */

dcl  o pointer,
     i fixed binary (18),
     stm pointer;

dcl  src pointer;

	if free (size (sr_cand)) = null
	then src = get_opt_space (size (sr_cand));
	else do;
	     src = free (size (sr_cand));
	     free (size (sr_cand)) = free (size (sr_cand)) -> sr_cand.next;
	     end;

	src -> sr_cand.operator = o;
	src -> sr_cand.which = i;
	src -> sr_cand.statement = stm;
	src -> sr_cand.next = null;

	if sr_tail = null
	then sr_chain = src;
	else sr_tail -> sr_cand.next = src;

	sr_tail = src;

     end chain_sr_cand;

chain_incr:
     procedure (o, stm, incr_chain);

	/* chain incr node on incr_chain */

dcl  (o, stm, incr_chain) pointer;

dcl  c pointer;

	if free (size (incr)) = null
	then c = get_opt_space (size (incr));
	else do;
	     c = free (size (incr));
	     free (size (incr)) = free (size (incr)) -> incr.next;
	     end;

	c -> incr.value = o;
	c -> incr.statement = stm;
	c -> incr.var_chain = null;
	c -> incr.next = incr_chain;
	incr_chain = c;

     end chain_incr;

replace_inputs:
     procedure (p_inp, p_new_out);

dcl  p_inp pointer;					/* beginning of inputs chain to be processed */
dcl  (new_out, p_new_out) fixed binary (18);		/* operand that replaces present output */

dcl  inp pointer;

	new_out = p_new_out;

	do inp = p_inp repeat inp -> input_to.next while (inp ^= null);
	     if inp -> input_to.which > 0
	     then inp -> input_to.operator -> operator.operand (inp -> input_to.which) = new_out;
	     else if inp -> input_to.which = 0
	     then inp -> input_to.operator -> operator.output = new_out;
	     else inp -> input_to.operator -> lchain.value = new_out;
	     end;

     end replace_inputs;

set:
     procedure (pt);

	/* set is called whenever a variable is seen to be set */

dcl  (p, pt, q, secp) pointer;
dcl  dt fixed binary (4);

	p = pt;
	if p -> node.node_type = array_ref_node
	then p = addr (rands (p -> array_ref.parent));

	if p -> node.node_type = symbol_node
	then do;
	     if ^p -> symbol.aliasable
	     then do;
		secp = p -> symbol.secondary;
		if secp ^= null
		then do;
		     call free_them (secp);
		     call release_node (secp, s_list, 2);
		     end;
		return;
		end;

	     if p -> symbol.parameter
	     then do;
		dt = p -> symbol.data_type;

		secp = s_list;
		do while (secp ^= null);
		     q = secp -> secondary.symbol;
		     if (q -> symbol.parameter | q -> symbol.in_common) & q -> symbol.data_type = dt
		     then call free_secondary (secp);
		     else secp = secp -> secondary.next;
		     end;

		return;
		end;

	     if ^p -> symbol.in_equiv_stmnt
	     then do;

		/* must be in common, but not equivalenced */

		dt = p -> symbol.data_type;

		secp = s_list;
		do while (secp ^= null);
		     q = secp -> secondary.symbol;
		     if q = p | (q -> symbol.parameter & q -> symbol.data_type = dt)
		     then call free_secondary (secp);
		     else secp = secp -> secondary.next;
		     end;

		return;
		end;

	     /* must be equivalenced */

	     dt = p -> symbol.data_type;

	     call set_equivalences (p, dt);		/* set our symbol and possible aliases */

	     /* reals and complex vars may be equivalenced together and
	        be defined at the same time */

	     if dt = real_mode
	     then call set_equivalences (p, cmpx_mode);

	     else if dt = cmpx_mode
	     then call set_equivalences (p, real_mode);

	     return;
	     end;

     end set;

set_externals:
     procedure ();

dcl  (s, secp) pointer;

	secp = s_list;
	do while (secp ^= null);
	     s = secp -> secondary.symbol;
	     if s -> symbol.parameter | s -> symbol.in_common
	     then call free_secondary (secp);
	     else secp = secp -> secondary.next;
	     end;

     end set_externals;

set_equivalences:
     procedure (pt, p_dt);

dcl  (pt, p) pointer,				/* points to equivalenced symbol that was set */
     (p_dt, dt) fixed binary (4);			/* data_type of equivalenced symbols to be set */

dcl  (q, secp) pointer;
dcl  (head, off) fixed binary (18);
dcl  delta fixed binary (1);

	p = pt;
	dt = p_dt;
	head = p -> symbol.parent;
	off = p -> symbol.offset;

	delta = fixed (p -> symbol.data_type ^= dt, 1);

	secp = s_list;
	do while (secp ^= null);
	     q = secp -> secondary.symbol;
	     if q -> symbol.aliasable & q -> symbol.data_type = dt
		& ((q -> symbol.parameter & p -> symbol.in_common)
		| (q -> symbol.parent = head & q -> symbol.in_equiv_stmnt
		& (q -> symbol.dimensioned | p -> symbol.dimensioned | abs (q -> symbol.offset - off) <= delta)))
	     then call free_secondary (secp);
	     else secp = secp -> secondary.next;
	     end;

     end set_equivalences;

free_secondary:
     procedure (p_secp);

dcl  (p_secp, secp) pointer;

	secp = p_secp;
	p_secp = secp -> secondary.next;
	call free_them (secp);
	call release_node (secp, s_list, 2);

     end free_secondary;

set_loop_variants:
     procedure (p_lp);

dcl  (lp, p_lp, secp, s) pointer;

	lp = p_lp;
	secp = s_list;
	do while (secp ^= null);
	     s = secp -> secondary.symbol;
	     if substr (lp -> loop.set -> bits, s -> symbol.coordinate, 1)
	     then call free_secondary (secp);
	     else secp = secp -> secondary.next;
	     end;

     end set_loop_variants;

free_them:
     procedure (p_secp);

dcl  (p_secp, secp) pointer;

dcl  (o, outp, p, c, inp, lastc) pointer;
dcl  (j, lvec) fixed binary (18);
dcl  queue (256) pointer unaligned;

	lastc = null;
	secp = p_secp;

	do c = secp -> secondary.primary repeat c -> chain.next while (c ^= null);
	     p = c -> chain.value;
	     if p -> primary.expression ^= null
	     then do;
		o = p -> primary.expression;
		o -> operator.primary = null;
		queue (1) = o;
		j = 0;
		lvec = 1;
		call release_primary (p);

		/* use a queue to avoid recursive walk */

		do while (j ^= lvec);
		     j = j + 1;
		     if j > hbound (queue, 1)
		     then j = 1;

		     o = queue (j);
		     outp = addr (rands (o -> operator.output));

		     if outp -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
		     then if outp -> temporary.start_input_to > 0
			then do inp = addr (polish (outp -> temporary.start_input_to))
				repeat inp -> input_to.next while (inp ^= null);
				o = inp -> input_to.operator;

				if inp -> input_to.which >= 0
						/* must be an operator */
				then if o -> operator.primary ^= null
				     then do;
					p = o -> operator.primary;
					o -> operator.primary = null;

					lvec = lvec + 1;
					if lvec > hbound (queue, 1)
					then lvec = 1;
					if lvec ^= j
					then queue (lvec) = o;
					else call print_message (414, "The set queue", hbound (queue, 1) - bias)
						;

					call release_primary (p);
					end;
				end;
		     end;
		end;
	     lastc = c;
	     end;

	if lastc ^= null
	then do;
	     lastc -> chain.next = free (size (chain));
	     free (size (chain)) = secp -> secondary.primary;
	     end;

     end free_them;

record_secondaries:
     procedure (p_o, p_code);

dcl  (p_o, o) pointer,				/* ptr to operator node whose operands are being recorded */
     (p_code, code) fixed binary (18);			/* setting of code is:
						   -1	record output only
						   0	record all operands
						   +1	record input only	*/

dcl  i fixed binary (18);
dcl  have_opt_subscript bit (1) aligned;

	o = p_o;
	have_opt_subscript = o -> operator.op_code = opt_subscript_op;
	code = p_code;

	if code >= 0
	then do i = 1 to o -> operator.number;
		if ^have_opt_subscript | i ^= 1
		then call record ((o -> operand (i)));
		end;

	if code <= 0
	then if ^have_opt_subscript
	     then do;
		i = o -> operator.output;
		if o -> operator.assigns_constant_to_symbol
		then addr (rands (i)) -> symbol.has_constant_value = "1"b;

		call record (i);
		end;

record:
     procedure (opnd);

dcl  opnd fixed binary (18);

dcl  (s, secp, c) pointer;

	if opnd > 0
	then do;
	     s = addr (rands (opnd));

	     if s -> node.node_type = array_ref_node
	     then s = addr (rands (s -> array_ref.parent));

	     if s -> node.node_type = symbol_node
	     then if s -> symbol.coordinate > 0
		then do;
		     if s -> symbol.secondary = null
		     then do;
			secp = create_o_node (s_list, 2);
			secp -> secondary.symbol = s;
			secp -> secondary.primary = null;
			s -> symbol.secondary = secp;
			end;
		     else secp = s -> symbol.secondary;

		     c = create_chain ();
		     c -> chain.value = o -> operator.primary;
		     c -> chain.next = secp -> secondary.primary;
		     secp -> secondary.primary = c;
		     end;
	     end;

     end record;

     end record_secondaries;

process_jump_label:
     procedure (lab);

dcl  lab fixed binary (18);				/* operand number of label */

dcl  (stm, q, t, new, target_fu, target_lp, c, last, p, pf, target_optr) pointer;
dcl  i fixed binary (18);

	stm = addr (quad (addr (rands (lab)) -> label.statement));
	go to join;

process_jump_target:
     entry (stmnt);

dcl  stmnt fixed binary (18);				/* offset in quad of statement */

	stm = addr (quad (stmnt));

join:
	target_fu = stm -> opt_statement.flow_unit;

	if target_fu -> flow_unit.position > fu -> flow_unit.position & ^stm -> opt_statement.referenced_by_assign
	then if stm -> opt_statement.has_operator_list
	     then call intersection (stm, 2);
	     else do;

		/* this is the first forward jump to the target to be processed, so create an operator list */

		if target_fu -> flow_unit.is_active_operator = null
		then target_fu -> flow_unit.is_active_operator = get_opt_space (size (obits));
		target_optr = target_fu -> flow_unit.is_active_operator;

		t = null;

		do i = 0 to hbound (p_list, 1);
		     do q = p_list (i) repeat q -> primary.next while (q ^= null);
			new = create_o_node (t, 0);
			new -> primary.data = q -> primary.data;
			substr (target_optr -> obits, q -> primary.expression -> operator.coordinate, 1) = "1"b;
			end;
		     end;

		/* if going to an outer loop, stick the bt_list in too */

		if ^need_consolidation_pass & our_depth > target_fu -> flow_unit.loop -> loop.depth
		then do;
		     do i = 0 to hbound (bt_list, 1);
			do q = bt_list (i) repeat q -> primary.next while (q ^= null);
			     new = create_o_node (t, 0);
			     new -> primary.data = q -> primary.data;
			     substr (target_optr -> obits, q -> primary.expression -> operator.coordinate, 1) =
				"1"b;
			     end;
			end;

		     /* Add this target to the chain of targets to be processed when the loop is done.
		        Anything added to bt_list will then be added to the target's operator_list. */

		     target_lp = target_fu -> flow_unit.loop;
		     last = null;
		     pf = lpf -> lp_frame.back;

		     do p = lp -> loop.father repeat p -> loop.father while (last ^= target_lp);
			c = create_chain ();
			c -> chain.value = target_fu;
			c -> chain.next = pf -> lp_frame.first_jump_target;
			pf -> lp_frame.first_jump_target = c;
			pf = pf -> lp_frame.back;
			last = p;
			end;
		     end;

		if t ^= null
		then stm -> opt_statement.operator_list = t;
		stm -> opt_statement.has_operator_list = "1"b;
		end;

     end process_jump_label;

intersection:
     procedure (p_state, p_i);

	/* this routine gets the intersection of the p_list and the primary list attached to the statement node.
	   If i = 2 the statement node list is replaced by the intersection.
	   If i = 1, the primary list p_list is replaced by the  intersection.
	   If i = 3, the primary list p_list is replaced by the union of p_list and the statement node list. */

dcl  (p_state, state, o, p, st_list, t, next_p, obptr) pointer;
dcl  (i, p_i, j) fixed binary (18);
dcl  possibly_found bit (1) aligned;

	state = p_state;
	i = p_i;

	if i = 1 & state -> opt_statement.referenced_by_assign
	then do;
	     call clear ("1"b);
	     return;
	     end;

	if ^state -> opt_statement.has_operator_list
	then return;

	st_list = state -> opt_statement.operator_list;

	obptr = state -> opt_statement.flow_unit -> flow_unit.is_active_operator;

	if i = 1
	then do;
	     do j = 0 to hbound (p_list, 1);
		do p = p_list (j) repeat next_p while (p ^= null);
		     next_p = p -> primary.next;

		     if ^substr (obptr -> obits, p -> primary.expression -> operator.coordinate, 1)
		     then call release_primary (p);

		     end;
		end;

	     return;
	     end;

	p = st_list;

	do while (p ^= null);
	     next_p = p -> primary.next;

	     /* we can use operator.primary to determine if an operator
	        is in the primary list! */

	     if p -> primary.expression -> operator.primary ^= null
	     then go to next;

	     /* this element is not common to both lists */

	     go to case (i);

case (2):
	     substr (obptr -> obits, p -> primary.expression -> operator.coordinate, 1) = "0"b;
	     call release_node (p, st_list, 0);
	     go to end_case;

case (3):
	     o = p -> primary.expression;

	     if ^o -> operator.freed			/* op must not be freed */
	     then do;
		j = hash (o, possibly_found);
		t = create_primary (p_list_st (j));
		t -> primary.data = p -> primary.data;
		o -> operator.primary = t;
		call record_secondaries (o, 0);
		end;

end_case:
next:
	     p = next_p;
	     end;

	if i = 2
	then state -> opt_statement.operator_list = st_list;

     end intersection;

union:
     procedure (fu, p_list_st);

	/* this routine replaces the primary list hanging off the first statement of the given flow unit with the
	   union of that list and the given primary list */

dcl  fu pointer,					/* given flow_unit */
     1 p_list_st (0:10) aligned,			/* given primary list */
       2 p_list pointer unaligned;

dcl  (stm, st_list, p, q, t, obptr) pointer;
dcl  i fixed binary (18);

	stm = addr (quad (fu -> flow_unit.first_statement));
	if stm -> opt_statement.referenced_by_assign
	then return;

	if fu -> flow_unit.is_active_operator = null
	then fu -> flow_unit.is_active_operator = get_opt_space (size (obits));
	obptr = fu -> flow_unit.is_active_operator;

	if stm -> opt_statement.operator_list = null
	then do;
	     st_list = null;
	     do i = 0 to hbound (p_list, 1);
		do q = p_list (i) repeat q -> primary.next while (q ^= null);
		     p = create_o_node (st_list, 0);
		     p -> primary.data = q -> primary.data;
		     substr (obptr -> obits, p -> primary.expression -> operator.coordinate, 1) = "1"b;
		     end;
		end;
	     stm -> opt_statement.operator_list = st_list;
	     end;

	else do;
	     st_list = stm -> opt_statement.operator_list;

	     do i = 0 to hbound (p_list, 1);
		do p = p_list (i) repeat p -> primary.next while (p ^= null);
		     if ^substr (obptr -> obits, p -> primary.expression -> operator.coordinate, 1)
		     then do;
			substr (obptr -> obits, p -> primary.expression -> operator.coordinate, 1) = "1"b;
			t = create_o_node (st_list, 0);
			t -> primary.data = p -> primary.data;
			end;
		     end;
		end;

	     stm -> opt_statement.operator_list = st_list;
	     end;

	stm -> opt_statement.has_operator_list = "1"b;

     end union;

trim_operator_list:
     procedure (stm);

	/* this routine is called after all intersections on a statement have been processed.
	   It releases those primaries not needed for the code generator. */

dcl  stm pointer;					/* -> opt_statement whose operator_list is to be trimmed */

dcl  (p, q, st_list) pointer;
dcl  our_depth fixed binary (18);

	if stm -> opt_statement.operator_list ^= null
	then do;
	     our_depth = lp -> loop.depth;
	     st_list = stm -> opt_statement.operator_list;

	     do p = st_list repeat q while (p ^= null);
		q = p -> primary.next;
		if our_depth > p -> primary.flow_unit -> flow_unit.loop -> loop.depth
		then call release_node (p, st_list, 0);
		end;

	     stm -> opt_statement.operator_list = st_list;
	     end;

     end trim_operator_list;

clear:
     procedure (zero_hash_mask);

	/* this routine releases all primaries on p_list and releases all secondaries.  bt_list is left unchanged. */

dcl  zero_hash_mask bit (1) aligned;
dcl  (p, q) pointer;
dcl  i fixed binary (18);

	do i = 0 to hbound (p_list, 1);
	     do p = p_list (i) repeat q while (p ^= null);
		q = p -> primary.next;
		call release_primary (p);
		end;
	     end;

	if zero_hash_mask
	then hash_mask = "0"b;

	call detach_secondaries ("1"b);

     end clear;

detach_secondaries:
     procedure (p_detach_constant_assignments);

	/* this routine releases all secondaries */

dcl  (detach_constant_assignments, p_detach_constant_assignments) bit (1) aligned;

dcl  (p, q, c, lastc) pointer;

	detach_constant_assignments = p_detach_constant_assignments;

	do p = s_list repeat q while (p ^= null);
	     q = p -> secondary.next;

	     if detach_constant_assignments | ^p -> secondary.symbol -> symbol.has_constant_value
	     then do;
		lastc = null;
		do c = p -> secondary.primary repeat c -> chain.next while (c ^= null);
		     lastc = c;
		     end;

		if lastc ^= null
		then do;
		     lastc -> chain.next = free (size (chain));
		     free (size (chain)) = p -> secondary.primary;
		     end;

		call release_node (p, s_list, 2);
		end;
	     end;

	/* put free primaries on the free list.  It is safe to do this because no more secondaries exist
	   that point to the free primaries.	*/

	if freep_tail ^= null
	then do;
	     freep_tail -> primary.next = free (size (primary));
	     free (size (primary)) = freep;
	     freep_tail, freep = null;
	     end;

     end detach_secondaries;

release_node:
     procedure (pt, list_head, i);

	/* these routines are utility routines to create and free nodes.   i = 0 for statement list primary nodes.
	   i = 1 for p_list or bt_list primary nodes (no longer implemented here).  i = 2 for secondary nodes.  */

dcl  (p, pt, list_head) pointer;
dcl  i fixed binary (18);

	p = pt;

	if p -> primary.next ^= null
	then p -> primary.next -> primary.last = p -> primary.last;
	if p -> primary.last = null
	then list_head = p -> primary.next;
	else p -> primary.last -> primary.next = p -> primary.next;

	if i = 2					/* secondary node */
	then do;
	     p -> secondary.symbol -> symbol.secondary = null;
	     p -> secondary.symbol -> symbol.has_constant_value = "0"b;
	     end;

	p -> primary.next = free (size (primary));
	free (size (primary)) = p;

	p -> primary.last = null;

     end release_node;

create_o_node:
     procedure (list_head, i) returns (pointer);

dcl  (list_head, p) pointer;
dcl  i fixed binary (18);

	if free (size (primary)) = null
	then p = get_opt_space (size (primary));
	else do;
	     p = free (size (primary));
	     free (size (primary)) = free (size (primary)) -> primary.next;
	     end;

	p -> primary.last = null;
	p -> primary.next = list_head;
	if list_head ^= null
	then list_head -> primary.last = p;
	list_head = p;
	return (p);

     end create_o_node;

release_primary:
     procedure (pt);

	/* these routines are utility routines to create and free primary nodes for the hash lists:
	   p_list & bt_list.  They take advantage of the fact that primary.next is the first
	   word of the primary node. */

dcl  (p, pt, o) pointer;

	p = pt;

	if p -> primary.next ^= null
	then p -> primary.next -> primary.last = p -> primary.last;
	p -> primary.last -> primary.next = p -> primary.next;

	if freep = null
	then freep_tail = p;

	o = p -> primary.expression;
	o -> operator.primary = null;
	if o -> operator.assigns_constant_to_symbol
	then addr (rands (o -> operator.output)) -> symbol.has_constant_value = "0"b;

	p -> primary.expression = null;
	p -> primary.next = freep;
	freep = p;

	p -> primary.last = null;

     end release_primary;

create_primary:
     procedure (list_head_st) returns (pointer);

dcl  1 list_head_st aligned,
       2 list_head pointer unaligned;

dcl  p pointer;

	if free (size (primary)) = null
	then p = get_opt_space (size (primary));
	else do;
	     p = free (size (primary));
	     free (size (primary)) = free (size (primary)) -> primary.next;
	     end;

	p -> primary.last = addr (list_head);
	p -> primary.next = list_head;
	if list_head ^= null
	then list_head -> primary.last = p;
	list_head = p;

	return (p);

     end create_primary;

hash:
     procedure (p_o, possibly_found) returns (fixed binary (18)) irreducible;

	/* function to provide a hash_index for an operator to speed up searching of
	   a primary list */

dcl  (o, p_o) pointer,				/* operator for which hash function
						   is calculated (input) */
     possibly_found bit (1) aligned;			/* "1"b if hash_mask is ON for this
						   operator (output) */

dcl  mod_2_sum fixed binary (34);
dcl  (i, hash_mask_index) fixed binary (18);

	o = p_o;

	mod_2_sum = o -> operator.op_code;
	do i = 1 to o -> operator.number;
	     mod_2_sum = mod_2_sum + o -> operand (i);
	     end;

	hash_mask_index = mod (mod_2_sum, length (hash_mask));

	possibly_found = substr (hash_mask, hash_mask_index + 1, 1);
	substr (hash_mask, hash_mask_index + 1, 1) = "1"b;

	return (mod (mod_2_sum, dim (p_list, 1)));

     end hash;

move:
     procedure (p_o, p_stm, p_fu, p_bt);

dcl  (o, p_o) pointer,				/* -> operator to be moved */
     (stm, p_stm) pointer,				/* -> stm from which o is moved */
     (fu, p_fu) pointer,				/* -> flow_unit from which o is moved */
     (bt, p_bt) pointer;				/* -> flow_unit to which o is moved (back_target) */

dcl  (c, i, opnd, op, outp_node_type, op_code) fixed binary (18);
dcl  (o_before, o_after, p, outp) pointer;

	o = p_o;
	stm = p_stm;
	fu = p_fu;
	bt = p_bt;

	if unspec (addr (quad (bt -> flow_unit.insert_statement)) -> opt_statement.source_id)
	     ^= unspec (stm -> opt_statement.source_id)
	then call insert_stm_in_back_target (bt, stm);

	call unthread (o);

	/* insert o (op) in the back target */

	o_before = addr (quad (bt -> flow_unit.insert_operator));
	o_after = addr (quad (o_before -> operator.next));
	o -> operator.back = bt -> flow_unit.insert_operator;
	o -> operator.next = o_before -> operator.next;
	op = fixed (rel (o), 18);
	o_before -> operator.next = op;
	o_after -> operator.back = op;
	bt -> flow_unit.insert_operator = op;

	/* change bit vectors that are referenced later */

	op_code = o -> operator.op_code;
	p, outp = addr (rands (o -> operator.output));
	outp_node_type = outp -> node.node_type;

	if outp_node_type = array_ref_node
	then if op_code ^= opt_subscript_op
	     then p = addr (rands (p -> array_ref.parent));

	if p -> node.node_type = symbol_node
	then do;
	     c = p -> symbol.coordinate;
	     if ^substr (bt -> flow_unit.set -> bits, c, 1)
	     then substr (bt -> flow_unit.set -> bits, c, 1) = "1"b;
	     else substr (bt -> flow_unit.set_multiple -> bits, c, 1) = "1"b;
	     substr (lp -> loop.set -> bits, c, 1) = "0"b;
	     substr (fu -> flow_unit.set -> bits, c, 1) = "0"b;
	     substr (bt -> flow_unit.busy_on_exit -> bits, c, 1) =
		substr (fu -> flow_unit.busy_on_exit -> bits, c, 1) | substr (fu -> flow_unit.used -> bits, c, 1);
	     end;

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then do;
		p = addr (rands (opnd));

		if p -> node.node_type = symbol_node & (i ^= 1 | op_code ^= opt_subscript_op)
		     & p -> symbol.coordinate > 0
		then do;
		     c = p -> symbol.coordinate;
		     substr (bt -> flow_unit.used -> bits, c, 1) = "1"b;
		     end;

		else if p -> node.node_type = array_ref_node
		then do;
		     p = addr (rands (p -> array_ref.parent));
		     c = p -> symbol.coordinate;
		     substr (bt -> flow_unit.used -> bits, c, 1) = "1"b;
		     end;
		end;
	     end;

	/* show that this operator is invariant and was used across loops */

	if outp_node_type = temporary_node | op_code = opt_subscript_op
	then do;
	     outp -> temporary.invariant = "1"b;
	     outp -> temporary.used_across_loops = "1"b;
	     end;

     end move;

insert_stm_in_back_target:
     procedure (bt, stm);

dcl  bt pointer,					/* -> back target where new statement is to be inserted */
     stm pointer;					/* -> stm from which the statement_id is copied */

dcl  new_statement fixed binary (18);
dcl  (new_stm, first_stm) pointer;

	/* make a statement that indicates "moved" code */

	new_statement = insert_statement_after ((bt -> flow_unit.insert_statement));
	new_stm = addr (quad (new_statement));

	if unspec (new_stm -> opt_statement.source_id) ^= unspec (stm -> opt_statement.source_id)
	then do;
	     new_stm -> opt_statement.moved = "1"b;
	     unspec (new_stm -> opt_statement.source_id) = unspec (stm -> opt_statement.source_id);
	     end;
	else new_stm -> opt_statement.moved = stm -> opt_statement.moved;

	if bt -> flow_unit.falls_through
	then bt -> flow_unit.last_statement = new_statement;
	else if bt -> flow_unit.first_statement = bt -> flow_unit.last_statement
	then do;
	     first_stm = addr (quad (bt -> flow_unit.first_statement));
	     bt -> flow_unit.first_statement = new_statement;
	     new_stm -> opt_statement.flow_unit = bt;
	     new_stm -> opt_statement.has_operator_list = first_stm -> opt_statement.has_operator_list;
	     first_stm -> opt_statement.has_operator_list = "0"b;
	     new_stm -> opt_statement.operator_list = first_stm -> opt_statement.operator_list;
	     first_stm -> opt_statement.operator_list = null;
	     if first_stm -> opt_statement.label ^= 0
	     then do;
		new_stm -> opt_statement.label = first_stm -> opt_statement.label;
		addr (rands (first_stm -> opt_statement.label)) -> label.statement = new_statement;
		first_stm -> opt_statement.label = 0;
		new_stm -> opt_statement.referenced_backwards = first_stm -> opt_statement.referenced_backwards;
		first_stm -> opt_statement.referenced_backwards = "0"b;
		new_stm -> opt_statement.referenced_by_assign = first_stm -> opt_statement.referenced_by_assign;
		first_stm -> opt_statement.referenced_by_assign = "0"b;
		end;
	     end;

	bt -> flow_unit.insert_statement = new_statement;
	bt -> flow_unit.insert_operator = new_statement;

     end insert_stm_in_back_target;

free_operator:
     procedure (p_o);

	/* frees an operator node and its associated output.  The operator may NOT
	   be reused because of potential references to it by input_to nodes, but its output may be reused. */

dcl  (o, p_o) pointer;				/* -> operator node */

dcl  (t, pr) pointer;
dcl  temp fixed binary (18);

	o = p_o;

	/* if the operator still has a primary, release it. */

	if o -> operator.primary ^= null
	then do;
	     pr = o -> operator.primary;
	     call release_primary (pr);
	     end;

	/* free the output if it is a temp or the operator is opt_subscript.
	   Note that temps & array_refs are the same size and that array_refs
	   will not be "created" after fort_converter. */

	temp = o -> operator.output;
	if temp > 0
	then do;
	     t = addr (rands (temp));

	     if t -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
	     then do;
		t -> temporary.next = next_free_temp;
		next_free_temp = temp;
		end;

	     else if t -> node.node_type = array_ref_node
	     then call disconnect_temporary (t, o);
	     end;

	/* mark the operator so it will be obvious that it has been freed */

	o -> operator.output = 0;
	o -> operator.freed = "1"b;

	/* unthread the operator */

	call unthread (o);

     end free_operator;

process_moved_descendants:
     procedure (p_o, fu);

	/* This routine ensures that expressions that have been moved out of a loop or commoned with expressions
	   outside a loop stay active throughout the loop.  The reference count of each such expression is
	   incremented by one and it is hung off a loop_end_chain which appears at the end of the loop.
	   This routine also refines the used strings.	*/

dcl  (o, p_o) pointer;				/* -> operator whose descendants are used across loops
						   or are invariant symbols */
dcl  fu pointer;					/* -> flow_unit being processed */

dcl  (i, c, opnd, op_code) fixed binary (18);
dcl  (outp, p) pointer;

	o = p_o;
	op_code = o -> operator.op_code;

	opnd = o -> operator.output;
	if opnd > 0
	then do;
	     outp = addr (rands (opnd));
	     if outp -> node.node_type = array_ref_node & op_code ^= opt_subscript_op
	     then if outp -> array_ref.used_across_loops
		then call put_in_a_loop_end (outp);
	     end;

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then do;
		p = addr (rands (opnd));

		if p -> node.node_type = temporary_node
		then if p -> temporary.used_across_loops
		     then call put_in_a_loop_end (p);
		     else ;

		else do;
		     if p -> node.node_type = array_ref_node
		     then do;
			if p -> array_ref.used_across_loops
			then call put_in_a_loop_end (p);
			p = addr (rands (p -> array_ref.parent));
			end;

		     if used_invariant_symbol
			& (p -> node.node_type = symbol_node & (i ^= 1 | op_code ^= opt_subscript_op))
		     then do;
			c = p -> symbol.coordinate;
			if c ^= 0
			then do;
			     substr (lp -> loop.used -> bits, c, 1) = "1"b;
			     substr (fu -> flow_unit.used -> bits, c, 1) = "1"b;
			     end;
			end;
		     end;
		end;
	     end;

put_in_a_loop_end:
     procedure (pt);

dcl  (p, pt, lp_evaluated, lp_to_put, q) pointer;
dcl  max_fu_pos fixed binary (18);

	p = pt;

	/* figure out in which containing loop's end chain this temp or array_ref should go.
	   This is complicated by the possibility of extended range loops.  We therefore find
	   the loop whose last statement is furthest down in the program. */

	lp_evaluated =
	     addr (quad (p -> temporary.output_by)) -> operator.primary -> primary.flow_unit -> flow_unit.loop;
	max_fu_pos = 0;

	do q = lp repeat q -> loop.father
	     while (^substr (lp_evaluated -> loop.ancestors_and_me -> lbits, q -> loop.number, 1));
	     if q -> loop.last_unit -> flow_unit.position > max_fu_pos
	     then do;
		max_fu_pos = q -> loop.last_unit -> flow_unit.position;
		lp_to_put = q;
		end;
	     end;

	/* unless this operand is in a loop end chain after this one, stich it in */

	if max_fu_pos > p -> temporary.loop_end_fu_pos
	then call put_in_loop_end (p, lp_to_put);

	p -> temporary.used_across_loops = "0"b;

     end put_in_a_loop_end;

     end process_moved_descendants;

constant_expression:
     procedure (p_o) returns (bit (1) aligned);

	/* this routine attempts to fold constant expressions */

dcl  (o, p_o) pointer;				/* ptr to operator with possible constant operands */

dcl  (
     p (2),
     inp,
     outp,
     q,
     start_inp
     ) pointer;
dcl  (opnd, i, op_code) fixed binary (18);

dcl  data_type (2) fixed bin (4);
dcl  max_data_type fixed bin (4);
dcl  result bit (72) aligned;
dcl  source (2) bit (72);

dcl  01 source_as_int (2) based (addr (source)),
       02 int_source fixed bin (18),
       02 pad bit (36);

dcl  error_condition char (16),
     literal_expression char (33 + 4 + 33) varying,
     literal_operand char (33) varying,
     literal_operator (2:13) char (4) varying static options (constant)
	init ("+", "-", "*", "/", "**", "-", ".lt.", ".le.", ".eq.", ".ne.", ".ge.", ".gt.");

dcl  error condition,
     fixedoverflow condition,
     overflow condition,
     size condition,
     underflow condition,
     zerodivide condition;

	/* initialize */

	o = p_o;

	/* make sure operands fit in our arrays */

	if o -> operator.number > hbound (p, 1)
	then return ("0"b);

	outp = addr (rands (o -> operator.output));

	/* see if all operands are constant and collect their values */

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then do;
		p (i) = addr (rands (opnd));

		if p (i) -> node.node_type = constant_node
		then do;
		     data_type (i) = p (i) -> constant.data_type;
		     source (i) = p (i) -> constant.value;
		     end;

		else return ("0"b);
		end;
	     end;

	/*  Catch arithmetic errors in the folding.  */

	on error goto error_condition_detected;
	on fixedoverflow goto fixedoverflow_condition_detected;
	on overflow goto overflow_condition_detected;
	on size goto size_condition_detected;
	on underflow goto underflow_condition_detected;
	on zerodivide goto zerodivide_condition_detected;

	op_code = o -> operator.op_code;

	/* dispatch on op_code */

	go to case (op_code);

case (1):						/* assign  - handled by constant_assign */
case (14):					/* or */
case (15):					/* and */
case (16):					/* not */
case (17):					/* jump */
case (18):					/* jump_logical */
case (19):					/* jump_arithmetic */
case (20):					/* jump_computed */
case (21):					/* jump_assigned */
case (22):					/* assign_label */
case (23):					/* read */
case (24):					/* write */
case (25):					/* format */
case (26):					/* end_label */
case (27):					/* error_label */
case (28):					/* xmit_scalar */
case (29):					/* xmit_array */
case (30):					/* xmit_vector */
case (31):					/* endfile */
case (32):					/* rewind */
case (33):					/* backspace */
case (34):					/* margin */
case (35):					/* openfile */
case (36):					/* closefile */
case (37):					/* record_number */
case (38):					/* string */
case (39):					/* string_length */
case (40):					/* terminate */
case (41):					/* return */
case (42):					/* pause */
case (43):					/* stop */
case (44):					/* item */
case (45):					/* exit */
case (46):					/* eol */
case (47):					/* do */
case (48):					/* builtin */
case (49):					/* sf */
case (50):					/* sf_def */
case (51):					/* subscript */
case (52):					/* func_ref */
case (53):					/* block_data */
case (54):					/* increment_polish */
case (55):					/* main */
case (56):					/* func */
case (57):					/* subr */
case (58):					/* stat */
case (59):					/* label */
case (60):					/* call */
case (61):					/* chain */
case (62):					/* endunit */
case (63):					/* non_executable */
case (64):					/* no */
case (65):					/* indirect_scan */
case (66):					/* opt_subscript */
case (67):					/* left_shift */
case (68):					/* right_shift */
case (69):					/* store_zero */
case (70):					/* storage_add */
case (71):					/* storage_sub */
case (72):					/* neg_storage_add */
case (73):					/* storage_add_one */
case (74):					/* namelist */
case (75):					/* open */
case (76):					/* close */
case (77):					/* iostat */
case (82):					/* read_scalar */
case (83):					/* read_array */
case (84):					/* read_vector */
case (85):					/* write_scalar */
case (86):					/* write_array */
case (87):					/* write_vector */
case (88):					/* jump_true */
case (89):					/* jump_false */
case (91):					/* loop_end */
case (92):					/* read_namelist */
case (93):					/* write_namelist */
case (94):					/* decode_string */
case (95):					/* encode_string */
case (96):					/* cat */
case (97):					/* substr */
case (98):					/* load_xreg */
case (99):					/* load_preg */
case (100):					/* block_if */
case (101):					/* else_if */
case (102):					/* else */
case (103):					/* equiv */
case (104):					/* not_equiv */
case (105):					/* read_internal_file */
case (106):					/* write_internal_file */
case (107):					/* inquire */
case (108):					/* process_param_list */
	return ("0"b);


case (2):						/* add */
case (3):						/* sub */
case (4):						/* mult */
case (5):						/* div */
case (6):						/* exponentiation */
	max_data_type = max (data_type (1), data_type (2));
	if data_type (1) ^= max_data_type
	then source (1) = conv_round (max_data_type, data_type (1)) (source (1), 0);
	else if data_type (2) ^= max_data_type
	then source (2) = conv_round (max_data_type, data_type (2)) (source (2), 0);
	result = binop_round (max_data_type, max_data_type) (op_code - 1, source (1), source (2), 0);
	goto join;

case (7):						/* negate */
	result = negate_round (data_type (1)) (op_code - 1, source (1), ""b, 0);
	goto join;

case (8):						/* less */
case (9):						/* less_or_equal */
case (10):					/* equal */
case (11):					/* not_equal */
case (12):					/* greater_or_equal */
case (13):					/* greater */
	result = comp_parm (data_type (1), data_type (2)) ((op_code), source (1), source (2), 0);
	goto join;

case (78):					/* convert_to_int */
case (79):					/* convert_to_real */
case (80):					/* convert_to_dp */
case (81):					/* convert_to_cmpx */
	result = conv_round (op_code - 77, data_type (1)) (source (1), 0);
	goto join;

case (90):					/* sub_index */
						/* ** If the sub_index is used as the variable offset of an
						   opt_subscript operator, then combine the variable offset which
						   happens to be constant and the real constant offset.  If the
						   sub_index is used for a length (for a substring reference or
						   concatenation operator) simply replace the output of the
						   sub_index with the constant.
						   ** */
	opnd = create_integer_constant (int_source (1));

	start_inp = addr (polish (outp -> temporary.start_input_to));

	do inp = start_inp repeat inp -> input_to.next while (inp ^= null);
	     q = inp -> input_to.operator;
	     if inp -> input_to.which > 0
	     then do;
		if q -> operator.op_code = opt_subscript_op & inp -> input_to.which = 3
		then do;
		     unspec (i) = addr (rands (q -> operator.operand (2))) -> constant.value;
(size):
		     q -> operator.operand (2) = create_integer_constant (i + int_source (1));
		     q -> operator.operand (3) = 0;
		     end;
		else q -> operand (inp -> input_to.which) = opnd;
		end;
	     else q -> lchain.value = o -> operand (1);
	     end;

	go to done;

join:
	opnd = create_constant ((outp -> temporary.data_type), result);

	start_inp = addr (polish (outp -> temporary.start_input_to));

	call replace_inputs (start_inp, opnd);

done:						/* free the input chain */
	addr (polish (outp -> temporary.end_input_to)) -> input_to.next = freei;
	freei = start_inp;

	/* free the operator */

	call free_operator (o);

	return ("1"b);


	/*  An arithmetic error occurred during folding.  Set 'literal_expression'   */
	/*  to the literal form of the constant expression that was being folded,    */
	/*  then issue an error message indicating the error and showing the value   */
	/*  of 'literal_expression'.  Return 'false' to the caller to indicate that  */
	/*  the expression was not folded.                                           */

arithmetic_error_detected:
	if o -> operator.number = 2
	then do;					/*  Synthesize binary expression.  */
	     literal_operand = literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     if substr (literal_operand, 1, 1) = "-"
	     then do;
		literal_expression = "(";
		literal_expression = literal_expression || literal_operand;
		literal_expression = literal_expression || ")";
		end;
	     else literal_expression = literal_operand;
	     if op_code >= lbound (literal_operator, 1) & op_code <= hbound (literal_operator, 1)
	     then literal_expression = literal_expression || literal_operator (op_code);
	     else literal_expression = literal_expression || "?";
	     literal_operand = literal_value (p (2) -> constant.data_type, p (2) -> constant.value);
	     if substr (literal_operand, 1, 1) = "-"
	     then do;
		literal_expression = literal_expression || "(";
		literal_expression = literal_expression || literal_operand;
		literal_expression = literal_expression || ")";
		end;
	     else literal_expression = literal_expression || literal_operand;
	     end;
	else if op_code = negate_op
	then do;
	     literal_expression = "-";
	     literal_operand = literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     if substr (literal_operand, 1, 1) = "-"
	     then do;
		literal_expression = literal_expression || "(";
		literal_expression = literal_expression || literal_operand;
		literal_expression = literal_expression || ")";
		end;
	     else literal_expression = literal_expression || literal_operand;
	     end;
	else if op_code = convert_to_int_op
	then do;
	     literal_expression = "int(";
	     literal_expression =
		literal_expression || literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     literal_expression = literal_expression || ")";
	     end;
	else if op_code = convert_to_real_op
	then do;
	     literal_expression = "real(";
	     literal_expression =
		literal_expression || literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     literal_expression = literal_expression || ")";
	     end;
	else if op_code = convert_to_dp_op
	then do;
	     literal_expression = "dble(";
	     literal_expression =
		literal_expression || literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     literal_expression = literal_expression || ")";
	     end;
	else if op_code = convert_to_cmpx_op
	then do;
	     literal_expression = "cmplx(";
	     literal_expression =
		literal_expression || literal_value (p (1) -> constant.data_type, p (1) -> constant.value);
	     literal_expression = literal_expression || ")";
	     end;
	else if op_code = sub_index_op
	then do;
	     literal_expression = literal_value ((int_mode), unspec (i));
	     literal_expression = literal_expression || "+";
	     literal_expression = literal_value ((int_mode), unspec (int_source (1)));
	     end;
	else literal_expression = "?";
	call print_message (174, error_condition, "constant expression: " || literal_expression);
	return ("0"b);

error_condition_detected:
	error_condition = "error";
	goto arithmetic_error_detected;

fixedoverflow_condition_detected:
	error_condition = "fixedoverflow";
	goto arithmetic_error_detected;

overflow_condition_detected:
	error_condition = "overflow";
	goto arithmetic_error_detected;

size_condition_detected:
	error_condition = "size";
	goto arithmetic_error_detected;

underflow_condition_detected:
	error_condition = "underflow";
	goto arithmetic_error_detected;

zerodivide_condition_detected:
	error_condition = "zerodivide";
	goto arithmetic_error_detected;

literal_value:
     proc (data_type, bit_value) recursive returns (char (35) varying);

	/*  Function:  to return the literal value of a FORTRAN numeric datum.       */

	/*  Arguments:                                                               */
	/*                                                                           */
	/*  data_type  (Input)                                                       */
	/*     is the type of the datum:  'int_mode', 'real_mode', 'dp_mode' or      */
	/*     'cmpx_mode'.                                                          */
	/*                                                                           */
	/*  bit_value  (Input)                                                       */
	/*     is the bit string representing the value of the datum.                */

	/*  Notes:                                                                   */
	/*                                                                           */
	/*  (1) The result is set to "?" if an invalid data type is specified.       */

dcl  data_type fixed bin (4) unsigned unaligned,
     bit_value bit (72) aligned;

dcl  assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));

dcl  imag builtin,
     real builtin;

dcl  Packed fixed bin (1) static options (constant) init (1),
     Unpacked fixed bin (1) static options (constant) init (0);

dcl  descriptor_type fixed bin,
     dp_picture pic "-9v.999999999999999999es999",
     idx_of_e fixed bin,
     int_value fixed bin (35),
     real_picture pic "-9v.99999999es999",
     result char (35) varying;
%include std_descriptor_types;


	if data_type = cmpx_mode
	then do;
	     result = "(";
	     result = result || literal_value ((real_mode), substr (bit_value, 1, 36));
	     result = result || ",";
	     result = result || literal_value ((real_mode), substr (bit_value, 37, 36));
	     result = result || ")";
	     end;
	else if data_type = dp_mode
	then do;
	     if cs -> subprogram.hfp
	     then descriptor_type = real_flt_hex_2_dtype;
	     else descriptor_type = real_flt_bin_2_dtype;
	     call assign_ (addr (dp_picture), 2 * char_dtype + Packed, length (dp_picture), addr (bit_value),
		2 * descriptor_type + Unpacked, 63);
	     idx_of_e = index (dp_picture, "e");
	     result = rtrim (rtrim (ltrim (substr (dp_picture, 1, idx_of_e - 1)), "0"), ".");
	     result = result || "D";
	     result = result || substr (dp_picture, idx_of_e + 1, 1);
	     result = result || ltrim (substr (dp_picture, idx_of_e + 2, 2), "0");
	     result = result || substr (dp_picture, idx_of_e + 3, 1);
	     end;
	else if data_type = int_mode
	then do;
	     unspec (int_value) = substr (bit_value, 1, 36);
	     result = ltrim (char (int_value));
	     end;
	else if data_type = real_mode
	then do;
	     if cs -> subprogram.hfp
	     then descriptor_type = real_flt_hex_1_dtype;
	     else descriptor_type = real_flt_bin_1_dtype;
	     call assign_ (addr (real_picture), 2 * char_dtype + Packed, length (real_picture), addr (bit_value),
		2 * descriptor_type + Unpacked, 27);
	     idx_of_e = index (real_picture, "e");
	     result = rtrim (rtrim (ltrim (substr (real_picture, 1, idx_of_e - 1)), "0"), ".");
	     result = result || "E";
	     result = result || substr (real_picture, idx_of_e + 1, 1);
	     result = result || ltrim (substr (real_picture, idx_of_e + 2, 2), "0");
	     result = result || substr (real_picture, idx_of_e + 3, 1);
	     end;
	else result = "?";
	return (result);
     end literal_value;

     end constant_expression;

constant_assign:
     procedure (p_o) returns (bit (1) aligned);

	/* This routine does special processing for assigments of constants to
	   symbols.  The constant right hand side must be converted to the data type
	   of the left hand side so that subsequent uses of the constant in place of
	   the symbol come out with the right value and the right data type.  If the
	   assign operator passed in does assign a constant to a symbol, "1"b is
	   returned. As there are no typeless constants, there is no code to support
	   data type 7. */

dcl  p_o pointer;					/* Pointer to assign operator */

dcl  (o, inp, outp) pointer;
dcl  (in_dt, out_dt) fixed binary (4);

dcl  target bit (72) aligned;				/* Value of constant */

dcl  char4_target character (4);
dcl  char8_target character (8);


	return ("0"b);				/* Temporarily disable 'constant_assign' to bypass bug 441. */
ignore_this_procedure:
	o = p_o;
	inp = addr (rands (o -> operator.operand (1)));
	outp = addr (rands (o -> operator.output));

	in_dt = inp -> node.data_type;
	out_dt = outp -> node.data_type;

	/* Dispatch on data types of LHS and RHS */

	go to conv (6 * (out_dt - 1) + in_dt);

conv (2):						/* int = real */
conv (3):						/* int = dp */
conv (4):						/* int = cmpx */
conv (7):						/* real = int */
conv (9):						/* real = dp */
conv (10):					/* real = cmpx */
conv (13):					/* dp = int */
conv (14):					/* dp = real */
conv (16):					/* dp = cmpx */
conv (19):					/* cmpx = int */
conv (20):					/* cmpx = real */
conv (21):					/* cmpx = dp */
	target = conv_round (out_dt, in_dt) ((inp -> constant.value), 0);
	goto change_constant;

conv (6):						/* int = char */
conv (12):					/* real = char */
conv (30):					/* logical = char */
	char4_target = inp -> char_constant.value;
	target = unspec (char4_target);
	goto change_constant;

conv (18):					/* dp = char */
conv (24):					/* cmpx = char */
	char8_target = inp -> char_constant.value;
	target = unspec (char8_target);
	goto change_constant;

conv (36):					/* char = char */
	if outp -> node.node_type = symbol_node
	then if outp -> symbol.v_length = 0
	     then do;
		o -> operator.operand (1) =
		     create_char_constant (char (inp -> char_constant.value, outp -> symbol.char_size + 1));
		return ("1"b);
		end;
	return ("0"b);


change_constant:
	o -> operator.operand (1) = create_constant (out_dt, target);


conv (1):						/* int = int */
conv (8):						/* real = real */
conv (15):					/* dp = dp */
conv (22):					/* cmpx = cmpx */
conv (29):					/* logical = logical */
	return (outp -> node.node_type = symbol_node);


conv (5):						/* int = logical */
conv (11):					/* real = logical */
conv (17):					/* dp = logical */
conv (23):					/* cmpx = logical */
conv (25):					/* logical = int */
conv (26):					/* logical = real */
conv (27):					/* logical = dp */
conv (28):					/* logical = cmpx */
conv (31):					/* char = int */
conv (32):					/* char = real */
conv (33):					/* char = dp */
conv (34):					/* char = cmpx */
conv (35):					/* char = logical */
	return ("0"b);

     end constant_assign;

reduce_strength:
     procedure (p_lp);

	/* routine to do strength reduction */

dcl  (lp, p_lp) pointer;				/* loop in which strength reduction is to be done */

dcl  (srp, incrp, src, incrc, cur_frame, cur_o, inp, o, bt, assp, outp, deltap, stm, fu, srvp, p, last, varp, new_incrp,
     q) pointer;
dcl  (i, induction_var, coord, op_code, number, new_increment, delta, which, insert_delta, variable, assignment, j,
     insert_new) fixed binary (18);
dcl  (inc_found, inc_found_before) bit (1) aligned;
dcl  induction_busy_on_exit bit (1) aligned;		/* "1"b -- induction var is busy_on_exit from lp */
dcl  have_test_replacement_candidate bit (1) aligned;
dcl  found_new_induction_variable bit (1) aligned;
dcl  induction_boe_from_bt bit (1) aligned;
dcl  update_insert_operator bit (1) aligned;

dcl  1 sr_frame based aligned,			/* stack frame used in strength reduction */
       2 prev pointer unaligned,
       2 next pointer unaligned,
       2 data structure aligned,
         3 operator pointer unaligned,			/* operator being reduced */
         3 inp pointer unaligned,			/* input to be processed */
         3 delta fixed binary (18),			/* increment to associate with this operator */
         3 init fixed binary (18),			/* last operator used in initializing expression */
         3 variable fixed binary (18),			/* new variable (if nonzero) made for this operator */
         3 ninst fixed binary (18),			/* number of tuples to generate this result */
         3 all_constant bit (1) aligned,		/* ON if all opnds except orig ind var are constant */
         3 which fixed binary (18),			/* which operand was previous operator */
         3 sign bit (1) aligned,			/* sign of the increment */
         3 sign_unknown bit (1) aligned;		/* sign of increment unknown */

	lp = p_lp;
	bt = lp -> loop.back_target;

	inc_found_before, have_test_replacement_candidate = "0"b;

retry:
	found_new_induction_variable = "0"b;

	/* See if we can find additional induction variables updated by stmts
	   of the form i = j. */

	if full_strength_reduction
	then call find_new_induction_vars_on_ass_chain (lp);

	/* loop through the candidates for strength reduction */

	do src = sr_chain repeat src -> sr_cand.next while (src ^= null);
	     srp = src -> sr_cand.operator;
	     which = src -> sr_cand.which;
	     if which = 0
	     then go to step;
	     if srp -> operator.freed
	     then go to step;
	     stm = src -> sr_cand.statement;
	     fu = stm -> opt_statement.flow_unit;

	     induction_var = srp -> operand (which);

	     /* see if this candidate involves a legitimate induction variable */

	     inc_found = "0"b;
	     incrc = incr_chain;

	     do while (incrc ^= null & ^inc_found);
		incrp = incrc -> incr.value;
		if induction_var = incrp -> operator.output
		then inc_found = "1"b;
		else incrc = incrc -> incr.next;
		end;

	     if inc_found
	     then do;

		/* the following code is the main logic of strength reduction.  It will
		   make one or more new induction variables to replace uses of this expression
		   or expressions containing this expression that also involve loop invariants */

		/* remember the busyness_on_exit of this induction variable */

		induction_busy_on_exit =
		     substr (lp -> loop.busy_on_exit -> bits, addr (rands (induction_var)) -> symbol.coordinate, 1);

		induction_boe_from_bt =
		     substr (bt -> flow_unit.busy_on_exit -> bits, addr (rands (induction_var)) -> symbol.coordinate,
		     1);

		if ^inc_found_before
		then do;

		     /* initialize for inserting delta */

		     if ^bt -> flow_unit.falls_through
		     then if bt -> flow_unit.first_statement = bt -> flow_unit.last_statement
			then call insert_stm_in_back_target (bt, stm);
		     insert_delta = bt -> flow_unit.insert_operator;
		     bt -> flow_unit.insert_operator = insert_operator_after (no_op, 0, insert_delta);
		     inc_found_before = "1"b;
		     end;

		/* create an initial frame to represent the induction variable */

		if init_frame ^= null
		then cur_frame = init_frame;
		else init_frame, cur_frame = create_sr_frame (null);

		cur_frame -> sr_frame.all_constant = "1"b;
		cur_frame -> sr_frame.ninst = 0;

		cur_frame -> sr_frame.sign = "0"b;
		cur_frame -> sr_frame.sign_unknown = "0"b;

		if incrp -> operator.op_code = assign_op
		then cur_frame -> sr_frame.delta = 0;

		else if incrp -> operator.op_code = storage_add_one_op
		then cur_frame -> sr_frame.delta = one;

		else do;
		     if incrp -> operator.op_code = neg_storage_add_op
		     then cur_frame -> sr_frame.sign = "1"b;
		     cur_frame -> sr_frame.delta = incrp -> operand (1);
		     end;

		/* build a frame for our candidate */

		call reduce (srp, which);


		/* this set of loops processes all expressions containing our candidate */

		do while (cur_frame ^= init_frame);

		     do while (cur_frame -> sr_frame.inp ^= null);
			inp = cur_frame -> sr_frame.inp;
			cur_frame -> sr_frame.inp = inp -> input_to.next;

			o = inp -> input_to.operator;
			which = inp -> input_to.which;

			if which > 0		/* must be an operator */
			then if ^o -> operator.freed	/* must not have been freed */
			     then if is_reducible (o, which)
				then call reduce (o, which);

				else do;
				     if cur_frame -> sr_frame.variable = 0
				     then do;

					/* we have a non-reducible operator, so, unless an equivalent already
					   exists, we must create and initialize a new induction variable to
					   substitute for the reducible code that has been processed.	*/

					variable = search_for_equivalent (/* cur_frame, incrc */);

					outp = addr (rands (cur_frame -> sr_frame.operator -> operator.output));
					inp = addr (polish (outp -> temporary.start_input_to));

					if variable = 0
					then do;
					     srvp = create_var (lp);

					     variable = srvp -> sr_var.variable;

					     outp -> temporary.start_input_to, outp -> temporary.end_input_to =
						0;

					     if induction_boe_from_bt
					     then do;
						outp -> temporary.ref_count = 1;

						/* build initializing code */

						update_insert_operator =
						     cur_frame -> sr_frame.init
						     = bt -> flow_unit.insert_operator;

						assignment =
						     insert_operator_after (assign_op, 1,
						     (cur_frame -> sr_frame.init));

						if update_insert_operator
						then bt -> flow_unit.insert_operator = assignment;

						assp = addr (quad (assignment));
						assp -> operator.output = variable;
						assp -> operand (1) =
						     cur_frame -> sr_frame.operator -> operator.output;

						call chain_input (outp, assp, 1);
						end;

					     else outp -> temporary.ref_count = 0;

					     /* Note:  following code sets usage and busy_on_exit bits needed by
					        this pass of the optimizer.  Recompute_usage will do a better
					        job for later.	*/

					     varp = addr (rands (variable));
					     coord = varp -> symbol.coordinate;
					     substr (bt -> flow_unit.set -> bits, coord, 1) =
						induction_boe_from_bt;
					     substr (bt -> flow_unit.busy_on_exit -> bits, coord, 1) =
						induction_boe_from_bt;
					     substr (lp -> loop.used -> bits, coord, 1) = "1"b;
					     substr (lp -> loop.set -> bits, coord, 1) = "1"b;
					     substr (lp -> loop.induction_var -> bits, coord, 1) = "1"b;

					     do p = lp -> loop.father repeat p -> loop.father while (p ^= null);
						substr (p -> loop.used -> bits, coord, 1) = "1"b;
						if induction_boe_from_bt
						     | substr (p -> loop.set -> bits, coord, 1)
						then substr (p -> loop.set_multiple -> bits, coord, 1) = "1"b;
						substr (p -> loop.set -> bits, coord, 1) = "1"b;
						end;

					     /* build incrementing or updating code */

					     insert_new = fixed (rel (incrp), 18);
					     delta = cur_frame -> sr_frame.delta;

					     if delta = 0
					     then do;

						/* original induction var not updated by increment */

						number = 1;
						op_code = assign_op;
						delta = incrp -> operand (1);
						last = init_frame;

						do p = init_frame -> sr_frame.next
						     repeat p -> sr_frame.next while (last ^= cur_frame);
						     q = p -> sr_frame.operator;
						     j = p -> sr_frame.which;

						     insert_new =
							insert_operator_after ((q -> operator.op_code), 2,
							(insert_new));

						     call connect_expression (delta, insert_new, j);
						     call connect_expression ((q -> operand (3 - j)),
							insert_new, 3 - j);

						     delta, addr (quad (insert_new)) -> operator.output =
							create_integer_temporary (insert_new);

						     if last = init_frame
						     then call chain_sr_cand (addr (quad (insert_new)), j,
							     (incrc -> incr.statement));

						     last = p;
						     end;
						end;

					     else do;
						number = 1;
						if cur_frame -> sr_frame.sign
						then op_code = neg_storage_add_op;
						else if delta = one
						then do;
						     op_code = storage_add_one_op;
						     number = 0;
						     end;
						else op_code = storage_add_op;
						end;

					     new_increment =
						insert_operator_after (op_code, number, insert_new);

					     new_incrp = addr (quad (new_increment));
					     new_incrp -> operator.output = variable;

					     if number > 0
					     then do;
						call connect_expression (delta, new_increment, 1);

						/* if this is a temp, add to loop end chain */

						if op_code ^= assign_op
						then do;
						     deltap = addr (rands (delta));
						     if deltap -> node.node_type = temporary_node
						     then if deltap -> temporary.loop_end_fu_pos = 0
							then call put_in_loop_end (deltap, lp);
						     end;
						end;

					     /* remember the new induction variable for
					        commoning and test replacement */

					     /* fill in the sr_var node */

					     srvp -> sr_var.next = incrc -> incr.var_chain;
					     incrc -> incr.var_chain = srvp;

					     /* fill in information */

					     srvp -> sr_var.all_constant = cur_frame -> sr_frame.all_constant;
					     srvp -> sr_var.sign_differs =
						init_frame -> sr_frame.sign ^= cur_frame -> sr_frame.sign;
					     srvp -> sr_var.sign_unknown = cur_frame -> sr_frame.sign_unknown;
					     srvp -> sr_var.updated_by = new_incrp;

					     if varp -> symbol.secondary ^= null
					     then do;
						call free_them ((varp -> symbol.secondary));
						call release_node ((varp -> symbol.secondary), s_list, 2);
						end;
					     varp -> symbol.secondary = srvp;

					     srvp -> sr_var.ninst = cur_frame -> sr_frame.ninst;
					     if srvp -> sr_var.ninst <= hbound (srvp -> sr_var.tuple, 1)
					     then do;
						if ^induction_busy_on_exit
						then have_test_replacement_candidate = "1"b;
						p = cur_frame;
						do i = srvp -> sr_var.ninst to 1 by -1;
						     srvp -> sr_var (i).operator = p -> sr_frame.operator;
						     srvp -> sr_var (i).which = p -> sr_frame.which;
						     p = p -> sr_frame.prev;
						     end;
						end;
					     end;

					else do;

					     /* An equivalent variable exists;
					        just free the operator. */

					     cur_o = cur_frame -> sr_frame.operator;
					     if fixed (rel (cur_o), 18) = bt -> flow_unit.insert_operator
					     then bt -> flow_unit.insert_operator = cur_o -> operator.back;

					     call decrement_input_ref_counts (cur_o);
					     call free_operator (cur_o);

					     end;

					call replace_inputs (inp, variable);

					cur_frame -> sr_frame.variable = variable;
					end;

				     if o -> operator.op_code = assign_op
				     then if full_strength_reduction
					then if output_is_new_induction_var (o)
					     then call add_new_induction_var (o);
					     else ;
					else ;

				     else if o -> operator.op_code = sub_index_op
				     then do;

					/* we don't need sub_index since opnd2 is now a variable */

					outp = addr (rands (o -> operator.output));
					inp = addr (polish (outp -> temporary.start_input_to));
					call replace_inputs (inp, cur_frame -> sr_frame.variable);
					call free_operator (o);
					end;
				     end;
			end;

		     cur_o = cur_frame -> sr_frame.operator;
		     if ^cur_o -> operator.freed
		     then do;
			outp = addr (rands (cur_o -> operator.output));

			if ^induction_boe_from_bt
			then do;

			     /* This operator was unthreaded by reduce;
			        finish freeing it now.  If the output has a
			        nonzero ref_count, it had better only be in
			        loop end lists. */

			     call decrement_input_ref_counts (cur_o);

			     if outp -> temporary.ref_count > 0
			     then do;

				/* Walk the input_to list. */

				do inp = addr (polish (outp -> temporary.start_input_to))
				     repeat (inp -> input_to.next) while (inp ^= null ());
				     if inp -> input_to.which >= 0
				     then if ^inp -> input_to.operator -> operator.freed
					then call print_message (391);
						/* Fatal */
					else ;
				     else inp -> input_to.operator -> lchain.value = 0;
				     end;
				end;

			     outp -> temporary.next = next_free_temp;
			     next_free_temp = cur_o -> operator.output;
			     cur_o -> operator.output = 0;
						/* mark as free */
			     cur_o -> operator.freed = "1"b;
			     end;

			else if outp -> temporary.ref_count = 0
			then do;

			     /* The output of this operator was input
			        only to an expression for which there
			        was already an equivalent induction
			        variable. */

			     if fixed (rel (cur_o), 18) = bt -> flow_unit.insert_operator
			     then bt -> flow_unit.insert_operator = cur_o -> operator.back;

			     call decrement_input_ref_counts (cur_o);
			     call free_operator (cur_o);

			     end;
			end;

		     cur_frame = cur_frame -> sr_frame.prev;
		     end;

		/* mark successful candidate */

		src -> sr_cand.which = 0;
		end;

step:
	     end;


	if found_new_induction_variable
	then go to retry;


finish:						/* Do test replacement */
	if have_test_replacement_candidate
	then do;
	     call timer (6);
	     call replace_tests;
	     end;

	/* free the chains */

	last = null;
	do incrc = incr_chain repeat incrc -> incr.next while (incrc ^= null);

	     /* remember which new induction vars were used in this loop and surrounding loops */

	     do srvp = incrc -> incr.var_chain repeat p while (srvp ^= null);
		addr (rands (srvp -> sr_var.variable)) -> symbol.secondary = null;
		i = addr (rands (srvp -> sr_var.variable)) -> symbol.coordinate;
		if substr (lp -> loop.used -> bits, i, 1) | substr (bt -> flow_unit.used -> bits, i, 1)
		then srvp -> sr_var.used_in -> lbits =
			srvp -> sr_var.used_in -> lbits | lp -> loop.ancestors_and_me -> lbits;
		p = srvp -> sr_var.next;
		srvp -> sr_var.next = free_var_list;
		free_var_list = srvp;
		end;

	     incrc -> incr.var_chain = null;
	     last = incrc;
	     end;

	if sr_chain ^= null
	then do;

	     /* do loop end processing for the unsuccessful candidates */

	     do src = sr_chain repeat src -> sr_cand.next while (src ^= null);
		if src -> sr_cand.which ^= 0
		then do;
		     stm = src -> sr_cand.statement;
		     srp = src -> sr_cand.operator;
		     fu = stm -> opt_statement.flow_unit;
		     used_invariant_symbol = "1"b;	/* for safety's sake */
		     call process_moved_descendants (srp, fu);
		     end;
		end;

	     sr_tail -> sr_cand.next = free (size (sr_cand));
	     free (size (sr_cand)) = sr_chain;
	     end;

	if incr_chain ^= null
	then do;
	     last -> incr.next = free (size (incr));
	     free (size (incr)) = incr_chain;
	     end;

	last = null;
	do incrc = ass_chain repeat incrc -> incr.next while (incrc ^= null);
	     last = incrc;
	     end;

	if last ^= null
	then do;
	     last -> incr.next = free (size (incr));
	     free (size (incr)) = ass_chain;
	     end;

	incr_chain, sr_chain, sr_tail, ass_chain = null;

	return;

is_reducible:
     procedure (o, which) returns (bit (1) aligned);

	/* decides if an expression is a candidate for strength reduction */

dcl  o pointer,					/* pts to candidate operator */
     which fixed binary (18);				/* operand number of induction variable */


	if o -> operator.op_code = add_op | o -> operator.op_code = sub_op | o -> operator.op_code = mult_op
	then return (is_invariant ((o -> operand (3 - which))));

	return ("0"b);

     end is_reducible;

is_invariant:
     procedure (opnd) returns (bit (1) aligned);

dcl  opnd fixed binary (18);

dcl  p pointer;

	p = addr (rands (opnd));

	if p -> node.node_type = array_ref_node
	then return ("0"b);

	else if p -> node.node_type = constant_node
	then return ("1"b);

	else if p -> node.node_type = temporary_node
	then return (p -> temporary.invariant);

	else return (^substr (lp -> loop.set -> bits, p -> symbol.coordinate, 1));

     end is_invariant;

reduce:
     procedure (p_o, p_which);

	/* builds an sr_frame to hold info about this operator, moves initializing code to back target, and derives
	   delta for incrementing */

dcl  (o, p_o) pointer,				/* points at operator to be reduced */
     (which, p_which) fixed binary (18);		/* operand number of induction variable */

dcl  (next_frame, outp, deltap, p, p1, p2) pointer;
dcl  i fixed binary (18);
dcl  factor fixed binary (18);
dcl  (cvalue1, cvalue2) fixed binary (18);

	o = p_o;
	which = p_which;

	if induction_boe_from_bt
	then do;

	     /* move this expression to the back target as initialization code.  Turn off bits set by move so
	        as not to confuse optimizer later */

	     call move (o, stm, fu, bt);
	     outp = addr (rands (o -> operator.output));
	     outp -> temporary.invariant, outp -> temporary.used_across_loops = "0"b;
	     end;

	else do;

	     /* Don't need initializaton code, so unthread the operator.  It
	        will be be freed later by reduce_strength when its sr_frame
	        is popped. */

	     call unthread (o);
	     end;

	/* build a new sr_frame */

	if cur_frame -> sr_frame.next ^= null
	then next_frame = cur_frame -> sr_frame.next;
	else next_frame = create_sr_frame (cur_frame);

	next_frame -> sr_frame.operator = o;
	next_frame -> sr_frame.variable = 0;
	next_frame -> sr_frame.which = which;
	next_frame -> sr_frame.inp = addr (polish (addr (rands (o -> operator.output)) -> temporary.start_input_to));
	next_frame -> sr_frame.ninst = cur_frame -> sr_frame.ninst + 1;
	next_frame -> sr_frame.init = bt -> flow_unit.insert_operator;

	p2 = addr (rands (o -> operand (3 - which)));
	next_frame -> sr_frame.all_constant =
	     cur_frame -> sr_frame.all_constant & (p2 -> node.node_type = constant_node);

	/* calculate delta and sign for new frame.  Put operations for delta in back target */

	next_frame -> sr_frame.sign = cur_frame -> sr_frame.sign;
	next_frame -> sr_frame.sign_unknown = cur_frame -> sr_frame.sign_unknown;

	if cur_frame -> sr_frame.delta = 0		/* induction var updated by assignment */
	then next_frame -> sr_frame.delta = 0;

	else if o -> operator.op_code = mult_op
	then do;
	     factor = o -> operand (3 - which);

	     if p2 -> node.node_type ^= constant_node
	     then next_frame -> sr_frame.sign_unknown = "1"b;
	     else do;
		unspec (cvalue2) = p2 -> constant.value;
		if cvalue2 < 0
		then do;
		     factor = create_integer_constant (-cvalue2);
		     p2 = addr (rands (factor));
		     next_frame -> sr_frame.sign = ^next_frame -> sr_frame.sign;
		     end;
		end;

	     if cur_frame -> sr_frame.delta = one
	     then next_frame -> sr_frame.delta = factor;

	     else do;
		p1 = addr (rands (cur_frame -> sr_frame.delta));

		if p1 -> node.node_type = constant_node & p2 -> node.node_type = constant_node
		then do;
		     unspec (cvalue1) = p1 -> constant.value;
		     unspec (cvalue2) = p2 -> constant.value;
		     next_frame -> sr_frame.delta = create_integer_constant (cvalue1 * cvalue2);
		     end;
		else do;
		     insert_delta = insert_operator_after (mult_op, 2, (insert_delta));
		     deltap = addr (quad (insert_delta));
		     next_frame -> sr_frame.delta, deltap -> operator.output =
			create_integer_temporary (insert_delta);

		     call connect_expression ((cur_frame -> sr_frame.delta), insert_delta, which);
		     call connect_expression (factor, insert_delta, 3 - which);

		     /* set appropriate used bits in back target */

		     do i = 1 to 2;
			p = addr (rands (deltap -> operand (i)));
			if p -> node.node_type = symbol_node
			then substr (bt -> flow_unit.used -> bits, p -> symbol.coordinate, 1) = "1"b;
			end;
		     end;
		end;
	     end;

	else do;

	     /* we have + or -, delta is unchanged, but the sign may change if we have c - i */

	     if o -> operator.op_code = sub_op & which = 2
	     then next_frame -> sr_frame.sign = ^next_frame -> sr_frame.sign;

	     next_frame -> sr_frame.delta = cur_frame -> sr_frame.delta;
	     end;

	/* make the new frame our current frame */

	cur_frame = next_frame;

     end reduce;

search_for_equivalent:
     procedure (/* cur_frame, incrc */) returns (fixed binary (18));

	/* searches for new induction variable that would be equivalent to the one we
	   would have to create for this sr_frame */

dcl  (srvp, p, o1, o2) pointer;
dcl  (i, ninst, which) fixed binary (18);
dcl  inequality_found bit (1) aligned;

	ninst = cur_frame -> sr_frame.ninst;
	if ninst <= hbound (srvp -> sr_var.tuple, 1)
	then do srvp = incrc -> incr.var_chain repeat srvp -> sr_var.next while (srvp ^= null);
		if ninst = srvp -> sr_var.ninst
		then do;
		     inequality_found = "0"b;
		     p = cur_frame;
		     do i = ninst to 1 by -1 while (^inequality_found);
			if p -> sr_frame.operator ^= srvp -> sr_var.operator (i)
			then do;
			     inequality_found = "1"b;
			     if p -> sr_frame.which = srvp -> sr_var.which (i)
			     then do;
				which = p -> sr_frame.which;
				o1 = p -> sr_frame.operator;
				o2 = srvp -> sr_var.operator (i);
				if o1 -> operator.op_code = o2 -> operator.op_code
				then if o1 -> operand (3 - which) = o2 -> operand (3 - which)
				     then inequality_found = "0"b;
				end;
			     end;
			p = p -> sr_frame.prev;
			end;

		     if ^inequality_found
		     then return (srvp -> sr_var.variable);
		     end;
		end;

	return (0);

     end search_for_equivalent;

create_sr_frame:
     procedure (last_frame) returns (pointer);

	/* creates strength_reduction frame used by reduce_strength to effect tree
	   search for uses of reducible expression */

dcl  last_frame pointer;				/* points to frame we are to connect to the new one */

dcl  new_frame pointer;

	new_frame = get_opt_space (size (sr_frame));

	new_frame -> sr_frame.next = null;
	new_frame -> sr_frame.prev = last_frame;
	if last_frame ^= null
	then last_frame -> sr_frame.next = new_frame;

	return (new_frame);

     end create_sr_frame;

create_var:
     procedure (lp) returns (pointer);

	/* creates automatic integer variable for use as a strength reduction induction variable */

dcl  lp pointer;

dcl  (var, lp_num) fixed binary (18);
dcl  (p, last, srvp) pointer;

	lp_num = lp -> loop.number;

	/* See if there is already a suitable induction variable.  It must already be used in this loop. */

	last = null;
	do srvp = free_var_list repeat srvp -> sr_var.next while (srvp ^= null);
	     if ^substr (srvp -> sr_var.used_in -> lbits, lp_num, 1)
	     then do;
		if last ^= null
		then last -> sr_var.next = srvp -> sr_var.next;
		else free_var_list = srvp -> sr_var.next;
		return (srvp);
		end;
	     last = srvp;
	     end;

	/* we need a brand new variable */

	srvp = create_sr_var_node ();
	srvp -> sr_var.used_in = get_opt_space (size (lbits));

	/* create and initialize the symbol node */

	var = create_node (symbol_node, size (symbol));
	srvp -> sr_var.variable = var;
	p = addr (rands (var));

	p -> symbol.data_type = int_mode;
	p -> symbol.element_size = data_type_size (int_mode);
	p -> symbol.operand_type = variable_type;
	p -> symbol.by_compiler = "1"b;
	p -> symbol.integer, p -> symbol.automatic = "1"b;
	p -> symbol.new_induction_var = "1"b;

	p -> symbol.secondary = null;

	/* connect the node to the symbol chain */

	addr (rands (cs -> subprogram.last_symbol)) -> symbol.next_symbol = var;
	cs -> subprogram.last_symbol = var;

	/* assign a coordinate to the symbol */

	n_sym = n_sym + 1;
	if n_sym > max_sym
	then do;

	     /* FATAL ERROR because we have already moved code on the assumption of the success of create_var */

	     call print_message (385);
	     return (null);
	     end;

	p -> symbol.coordinate = n_sym;

	substr (integer_scalar_mask, n_sym, 1) = "1"b;

	return (srvp);

     end create_var;

create_sr_var_node:
     procedure () returns (pointer);

dcl  srvp pointer;

	if freesrv = null
	then srvp = get_opt_space (size (sr_var));
	else do;
	     srvp = freesrv;
	     freesrv = freesrv -> sr_var.next;
	     end;

	return (srvp);

     end create_sr_var_node;

output_is_new_induction_var:
     procedure (o) returns (bit (1) aligned);

dcl  o pointer;					/* -> assign op whose output is being examined */

dcl  s pointer;

	/* Since the RHS of o is a new induction variable, if the LHS is a
	   simple integer set only once in the loop, then it too is an inductioon
	   variable. */

	s = addr (rands (o -> operator.output));

	if s -> node.node_type = symbol_node
	then if s -> symbol.data_type = int_mode
	     then if ^s -> symbol.aliasable & ^s -> symbol.new_induction_var
		then if ^substr (lp -> loop.set_multiple -> bits, s -> symbol.coordinate, 1)
		     then return ("1"b);

	return ("0"b);

     end output_is_new_induction_var;

add_new_induction_var:
     procedure (p_o);

dcl  (o, p_o) pointer;				/* -> assignment producing new induction var */

dcl  (left, right, srvp) pointer;

	found_new_induction_variable = "1"b;

	o = p_o;

	left = addr (rands (o -> operator.output));
	right = addr (rands (o -> operator.operand (1)));

	/* we need to mark used bits for right in all flow_units
	   so that used_in_loop will look for us */

	call force_used_in_loop (lp, (right -> symbol.coordinate));

	/* chain incr nodes first for right, then for left */

	srvp = right -> symbol.secondary;
	call chain_incr ((srvp -> sr_var.updated_by), (incrc -> incr.statement), incr_chain);
	call chain_incr (o, stm, incr_chain);

	/* turn on the induction_var bit in lp, so we know about this variable */

	substr (lp -> loop.induction_var -> bits, left -> symbol.coordinate, 1) = "1"b;

     end add_new_induction_var;

find_new_induction_vars_on_ass_chain:
     procedure (p_lp);

dcl  (lp, p_lp) pointer;				/* -> loop node */

dcl  (c, next, prev) pointer;
dcl  (o, left, right) pointer;
dcl  changed bit (1) aligned;

	/* ass_chain chains assignments of the form i = j, where both i and
	   j are simple integers assigned only ince in lp.  If j is an
	   induction variable, then so is i. */

	lp = p_lp;

	changed = "1"b;

	do while (changed);
	     changed = "0"b;
	     prev = null;

	     do c = ass_chain repeat next while (c ^= null);
		next = c -> incr.next;
		o = c -> incr.value;
		left = addr (rands (o -> operator.output));
		right = addr (rands (o -> operand (1)));

		if substr (lp -> loop.induction_var -> bits, right -> symbol.coordinate, 1)
		then do;

		     /* left can now be made an induction variable. */

		     changed = "1"b;
		     substr (lp -> loop.induction_var -> bits, left -> symbol.coordinate, 1) = "1"b;

		     /* Rethread this operation onto incr_chain. */

		     if prev ^= null
		     then prev -> incr.next = c -> incr.next;
		     else ass_chain = c -> incr.next;
		     c -> incr.next = incr_chain;
		     incr_chain = c;
		     end;

		else prev = c;
		end;
	     end;

     end find_new_induction_vars_on_ass_chain;

force_used_in_loop:
     procedure (lp, coord);

	/* forces used bit on in all flow_units and all loops contained in lp */

dcl  lp pointer,
     coord fixed binary (18);

dcl  (adam, p) pointer;
dcl  c fixed binary (18);

	adam = lp;
	c = coord;

	call force_loop (adam);

	if adam -> loop.son = null
	then return;

	/* simulate recursive walk */

	p = adam -> loop.son;

	do while ("1"b);
	     call force_loop (p);

	     if p -> loop.son ^= null
	     then p = p -> loop.son;

	     else do;
		do while (p -> loop.brother = null);
		     p = p -> loop.father;
		     if p = adam
		     then return;
		     end;

		p = p -> loop.brother;
		end;
	     end;

force_loop:
     procedure (lp);

dcl  (lp, fu) pointer;

	substr (lp -> loop.used -> bits, c, 1) = "1"b;

	do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null);
	     substr (fu -> flow_unit.used -> bits, c, 1) = "1"b;
	     end;

     end force_loop;

     end force_used_in_loop;

replace_tests:
     procedure ();

	/* This program attempts to eliminate induction variables that are only used to increment themselves,
	   or are only used to increment themselves and in one end_of_loop test */

dcl  (incrc, incrp, indp, o, fu) pointer;
dcl  (induction_var, n_uses, st_found, which, code) fixed binary (18);

	do incrc = incr_chain repeat incrc -> incr.next while (incrc ^= null);
	     incrp = incrc -> incr.value;
	     induction_var = incrp -> operator.output;
	     indp = addr (rands (induction_var));

	     if incrc -> incr.var_chain ^= null
		& ^substr (lp -> loop.busy_on_exit -> bits, indp -> symbol.coordinate, 1)
	     then do;
		n_uses = used_in_loop (induction_var, lp, o, st_found, fu);

		if n_uses = 0
		then call eliminate_increment;

		else if n_uses = 1
		then do;

		     /* We have a use other than the increment.  It must be as the operand
		        of a relational operator in the test ending an exit flow unit */

		     if substr (lp -> loop.is_exit -> dbits, fu -> flow_unit.number, 1)
			& st_found = fu -> flow_unit.last_statement & o -> operator.op_code >= less_op
			& o -> operator.op_code <= greater_op
		     then do;

			/* see if other operand is a loop constant */

			if o -> operand (1) = induction_var
			then which = 1;
			else which = 2;

			if is_invariant ((o -> operand (3 - which)))
			then do;
			     call change_test (code);
			     if code = 0
			     then call eliminate_increment;
			     end;
			end;
		     end;
		end;
	     end;

change_test:
     procedure (code);

dcl  code fixed binary (18);				/* (output) */

dcl  (srvp, p, invp, q) pointer;
dcl  (min_ninst, invariant_opnd, i, last_temp, input, j) fixed binary (18);
dcl  found_all_constant bit (1) aligned;
dcl  reverse_rel_op (8:13) fixed binary (18) internal static initial (13, 12, 10, 11, 9, 8);

	/* first, we must find a good new induction variable to use */

	found_all_constant = "0"b;
	min_ninst = 1000;
	srvp = null;

	do p = incrc -> incr.var_chain repeat p -> sr_var.next while (p ^= null);
	     if ^p -> sr_var.sign_unknown
		& substr (lp -> loop.used -> bits, addr (rands (p -> sr_var.variable)) -> symbol.coordinate, 1)
	     then if p -> sr_var.all_constant & ^found_all_constant
		then do;
		     found_all_constant = "1"b;
		     min_ninst = p -> sr_var.ninst;
		     srvp = p;
		     end;

		else if p -> sr_var.ninst < min_ninst & p -> sr_var.all_constant = found_all_constant
		then do;
		     min_ninst = p -> sr_var.ninst;
		     srvp = p;
		     end;
	     end;

	if min_ninst > hbound (srvp -> sr_var.tuple, 1)
	then do;

	     /* we can't change the test */

	     code = 1;
	     return;
	     end;

	else code = 0;

	/* srvp now points at the sr_var node we will use.  If the loop invariant
	   is a temporary, disconnect it from this operator */

	invariant_opnd = o -> operand (3 - which);
	invp = addr (rands (invariant_opnd));

	if invp -> node.node_type = temporary_node
	then call disconnect_temporary (invp, o);

	else if invp -> node.node_type = symbol_node
	then substr (bt -> flow_unit.used -> bits, invp -> symbol.coordinate, 1) = "1"b;

	/* build up the new expression that will be tested against */

	do i = 1 to min_ninst;
	     q = srvp -> sr_var.operator (i);
	     j = srvp -> sr_var.which (i);

	     insert_delta = insert_operator_after ((q -> operator.op_code), 2, (insert_delta));

	     if i = 1
	     then input = invariant_opnd;
	     else input = last_temp;

	     call connect_expression (input, insert_delta, j);
	     call connect_expression ((q -> operand (3 - j)), insert_delta, 3 - j);

	     last_temp, addr (quad (insert_delta)) -> operator.output = create_integer_temporary (insert_delta);
	     end;

	call connect_expression (last_temp, fixed (rel (o), 18), 3 - which);
	o -> operand (which) = srvp -> sr_var.variable;

	if srvp -> sr_var.sign_differs
	then o -> operator.op_code = reverse_rel_op (o -> operator.op_code);

	call put_in_loop_end (addr (rands (last_temp)), lp);

	substr (fu -> flow_unit.used -> bits, indp -> symbol.coordinate, 1) = "0"b;
	substr (fu -> flow_unit.used -> bits, addr (rands (srvp -> sr_var.variable)) -> symbol.coordinate, 1) = "1"b;

     end change_test;

eliminate_increment:
     procedure ();

dcl  p pointer;

	/* if the value the induction variable was incremented by was a temporary, disconnect it */

	if incrp -> operator.number > 0
	then do;
	     p = addr (rands (incrp -> operand (1)));
	     if p -> node.node_type = temporary_node
	     then call disconnect_temporary (p, incrp);
	     end;

	/* unthread the operator */

	call unthread (incrp);

	/* update various usage bits */

	substr (lp -> loop.used -> bits, indp -> symbol.coordinate, 1) = "0"b;
	substr (lp -> loop.set -> bits, indp -> symbol.coordinate, 1) = "0"b;
	substr (bt -> flow_unit.busy_on_exit -> bits, indp -> symbol.coordinate, 1) = "0"b;

	/* Can't propagate resetting of busy_on_exit any further since used bit has been turned on in
	   back target by strength reduction. */

     end eliminate_increment;

     end replace_tests;

     end reduce_strength;

used_in_loop:
     procedure (p_induction_var, p_adam, p_o, p_st_found, p_fu) returns (fixed binary (18));

	/* counts non-incremental uses of induction variable in a loop; stops if more than one use found. */

dcl  (induction_var, p_induction_var) fixed binary (18),	/* induction variable (input) */
     (p_adam, adam) pointer,				/* -> loop to be searched (input) */
     p_o pointer,					/* -> operator in which use found (output) */
     p_st_found fixed binary (18),			/* offset of stmt in which use found (output) */
     p_fu pointer;					/* -> flow_unit in which use found (output) */
						/*  returns:
						   0 -- no use found
						   1 -- one use found
						   2 -- many uses found	*/
dcl  (coord, n_uses) fixed binary (18);
dcl  p pointer;
dcl  ind_used bit (1) aligned;

	adam = p_adam;
	induction_var = p_induction_var;
	coord = addr (rands (induction_var)) -> symbol.coordinate;
	n_uses = 0;

	call process_flow_units (adam);

	if n_uses > 1 | adam -> loop.son = null
	then return (n_uses);

	/* simulate recursive tree walk */

	p = adam -> loop.son;

	do while ("1"b);
	     ind_used = substr (p -> loop.used -> bits, coord, 1);

	     if ind_used
	     then do;
		call process_flow_units (p);
		if n_uses > 1
		then return (n_uses);
		end;

	     if ind_used & p -> loop.son ^= null
	     then p = p -> loop.son;

	     else do;
		do while (p -> loop.brother = null);
		     p = p -> loop.father;
		     if p = adam
		     then return (n_uses);
		     end;

		p = p -> loop.brother;
		end;
	     end;

process_flow_units:
     procedure (lp);

dcl  lp pointer;					/* -> loop to be scanned */

dcl  (o, stm, fu) pointer;
dcl  (next_statement, next_unit_statement, op, i) fixed binary (18);

	do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null);
	     if substr (fu -> flow_unit.used -> bits, coord, 1)
	     then do;

		/* turn off used bit util we are sure that the var is used */

		substr (fu -> flow_unit.used -> bits, coord, 1) = "0"b;

		/* loop through the statements */

		if fu -> flow_unit.next ^= null
		then next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement;
		else next_unit_statement = 0;

		do cur_statement = fu -> flow_unit.first_statement repeat next_statement
		     while (cur_statement ^= next_unit_statement);

		     stm = addr (quad (cur_statement));
		     next_statement = fixed (stm -> opt_statement.next, 18);

		     do op = stm -> opt_statement.first_operator repeat o -> operator.next
			while (op ^= next_statement);

			o = addr (quad (op));

			do i = 1 to o -> operator.number;
			     if o -> operand (i) = induction_var
			     then do;
				n_uses = n_uses + 1;
				substr (fu -> flow_unit.used -> bits, coord, 1) = "1"b;
				if n_uses > 1
				then return;
				p_o = o;
				p_st_found = cur_statement;
				p_fu = fu;
				end;
			     end;

			if o -> operator.op_code = write_namelist_op
			then if in_namelist (o, induction_var)
			     then do;
				n_uses = 2;
				substr (fu -> flow_unit.used -> bits, coord, 1) = "1"b;
				return;
				end;
			end;
		     end;
		end;
	     end;

     end process_flow_units;

     end used_in_loop;

chain_dac:
     procedure (var, fu);

	/* chains dead_assign_cand nodes for later processing */

dcl  var fixed binary (18),				/* variable to be removed later */
     fu pointer;					/* -> flow_unit from which var shd be removed */

dcl  p pointer;

	p = create_da_node ();
	p -> dead_assign_cand.next = da_chain;
	da_chain = p;
	p -> dead_assign_cand.variable = var;
	p -> dead_assign_cand.flow_unit = fu;

     end chain_dac;

create_da_node:
     procedure () returns (pointer);

dcl  p pointer;

	if free (size (dead_assign_cand)) = null
	then p = get_opt_space (size (dead_assign_cand));
	else do;
	     p = free (size (dead_assign_cand));
	     free (size (dead_assign_cand)) = free (size (dead_assign_cand)) -> dead_assign_cand.next;
	     end;

	return (p);

     end create_da_node;

remove_dead_assignments:
     procedure ();

	/* This routine removes assignments made dead by the combination of strength reduction, test replacement, and
	   constant propagation. */

dcl  (dac, fu, last, o, varp) pointer;
dcl  (back, c, first_statement, i, op, variable) fixed binary (18);
dcl  in_common bit (1) aligned;

	/* This program assumes that an assignment will not be dead unless the right hand side is a constant,
	   since unless this is so, the init code for new induction variables will reference the old
	   induction variable.  Although all vars added to da_chain were not busy_on_exit from their
	   flow_units when added, they may be now, so that we must perform the check again inside
	   the loop.	*/

	last = null;

	do dac = da_chain repeat dac -> dead_assign_cand.next while (dac ^= null);
	     variable = dac -> dead_assign_cand.variable;
	     varp = addr (rands (variable));
	     c = varp -> symbol.coordinate;
	     in_common = varp -> symbol.in_common;
	     fu = dac -> dead_assign_cand.flow_unit;

	     if ^fu -> flow_unit.removed & substr (fu -> flow_unit.set -> bits, c, 1)
		& ^substr (fu -> flow_unit.busy_on_exit -> bits, c, 1)
	     then do;

		/* refresh insert_operator field since previous optimizations may have killed it */

		call derive_insert_for_bt (fu);

		/* loop backwards through operators looking for uses and sets */

		first_statement = fu -> flow_unit.first_statement;

		do op = fu -> flow_unit.insert_operator repeat back while (op ^= first_statement);
		     o = addr (quad (op));
		     back = o -> operator.back;

		     /* special handling for namelist and common */

		     if o -> operator.op_code = read_namelist_op | o -> operator.op_code = write_namelist_op
		     then if in_namelist (o, variable)
			then go to step;
			else ;
		     else if in_common
		     then if o -> operator.op_code = func_ref_op | o -> operator.op_code = call_op
			then go to step;

		     /* look for uses */

		     do i = 1 to o -> operator.number;
			if o -> operand (i) = variable
			then go to step;
			end;

		     /* look for set */

		     if o -> operator.output = variable & o -> operator.op_code ^= stat_op
		     then do;
			if op_class (o -> operator.op_code) >= function_class
			then go to step;

			call unthread (o);

			if ^substr (fu -> flow_unit.set_multiple -> bits, c, 1)
			then do;
			     substr (fu -> flow_unit.set -> bits, c, 1) = "0"b;
			     go to step;
			     end;
			end;
		     end;

		substr (fu -> flow_unit.set -> bits, c, 1) = "0"b;
		substr (fu -> flow_unit.set_multiple -> bits, c, 1) = "0"b;
		substr (fu -> flow_unit.used -> bits, c, 1) = "0"b;
		end;

step:
	     last = dac;
	     end;

	last -> dead_assign_cand.next = free (size (dead_assign_cand));
	free (size (dead_assign_cand)) = da_chain;
	da_chain = null;

     end remove_dead_assignments;

create_integer_temporary:
     procedure (op) returns (fixed binary (18));

dcl  op fixed binary (18);				/* operator producing the temp */

dcl  t pointer;
dcl  temp fixed binary (18);

	/* allocate the space */

	if next_free_temp = 0
	then do;
	     temp = create_node (temporary_node, size (temporary));
	     t = addr (rands (temp));
	     end;

	else do;
	     temp = next_free_temp;
	     t = addr (rands (temp));
	     next_free_temp = t -> temporary.next;
	     unspec (t -> temporary) = "0"b;
	     t -> temporary.node_type = temporary_node;
	     end;

	/* fill in the data */

	t -> temporary.data_type = int_mode;
	t -> temporary.operand_type = temp_type;
	t -> temporary.size = 1;
	t -> temporary.output_by = op;
	t -> temporary.not_in_storage = "1"b;

	return (temp);

     end create_integer_temporary;

remove_loop:
     procedure (lp);

	/* removes "useless" loops */

dcl  lp pointer;					/* -> loop to be removed */

dcl  (adam, p, bt, bd, bdl, exit_target, jop, jst) pointer;
dcl  finished bit (1) aligned;
dcl  (j_operator, j_statement) fixed binary (18);

	adam = lp;

	/* print warning since this could be unexpected if the user was trying
	   to save data between invocations with automatic variables */

	cur_statement = adam -> loop.entry_unit -> flow_unit.first_statement;
	call print_message (387);

	bt = adam -> loop.back_target;

	/* propagate busy_on_exit from loop to back_target */

	bt -> flow_unit.busy_on_exit -> bits = adam -> loop.busy_on_exit -> bits;

	/* Remove all operations from the loop. */

	call remove_units_from_loop (adam);

	/* process all of adam's descendants */

	if adam -> loop.son ^= null
	then do;
	     p = adam -> loop.son;
	     finished = "0"b;

	     do while (^finished);
		call remove_units_from_loop (p);

		if p -> loop.son ^= null
		then p = p -> loop.son;

		else do;
		     do while (p -> loop.brother = null & ^finished);
			p = p -> loop.father;
			if p = adam
			then finished = "1"b;
			end;

		     p = p -> loop.brother;
		     end;
		end;
	     end;

	/* attach back target directly to the exit target of the loop */

	exit_target = adam -> loop.exits -> chain.value -> edge.to.value;

	if bt -> flow_unit.falls_through
	then do;
	     if bt -> flow_unit.next ^= exit_target
	     then do;

		/* need a jump to the exit_target */

		j_operator, bt -> flow_unit.insert_operator =
		     insert_operator_after (jump_op, 1, (bt -> flow_unit.insert_operator));
		addr (quad (j_operator)) -> operand (1) = get_flow_unit_label (exit_target);
		end;
	     end;

	else do;
	     j_statement = bt -> flow_unit.last_statement;
	     jst = addr (quad (j_statement));
	     j_operator = jst -> opt_statement.first_operator;
	     jop = addr (quad (j_operator));

	     if bt -> flow_unit.next ^= exit_target
	     then jop -> operand (1) = get_flow_unit_label (exit_target);
	     else call free_operator (jop);
	     end;

	call link (bt, exit_target);

	/* if the exit_target's back dominator was in one of the removed
	   loops, the adam loop's back target becomes the new back
	   dominator */

	bd = exit_target -> flow_unit.dominator;
	bdl = bd -> flow_unit.loop;
	if substr (bdl -> loop.ancestors_and_me -> lbits, adam -> loop.number, 1)
	then exit_target -> flow_unit.dominator = bt;

	return;

get_flow_unit_label:
     procedure (fu) returns (fixed binary (18));

dcl  fu pointer;					/* -> flow_unit whose label is to be returned */

dcl  (f_label, f_statement) fixed binary (18);

	f_statement = fu -> flow_unit.first_statement;
	f_label = addr (quad (f_statement)) -> opt_statement.label;
	if f_label = 0
	then f_label = create_label (f_statement);

	return (f_label);

     end get_flow_unit_label;

remove_units_from_loop:
     procedure (lp);

dcl  lp pointer;					/* -> loop whose flow_units are to be removed */

dcl  (fu, first_fu, o, stm) pointer;
dcl  (op, next_op, next_statement, next_unit_statement) fixed binary (18);

	first_fu = lp -> loop.members;
	lp -> loop.members = null;

	do fu = first_fu repeat fu -> flow_unit.next_in_loop while (fu ^= null);
	     next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement;

	     do cur_statement = fu -> flow_unit.first_statement repeat next_statement
		while (cur_statement ^= next_unit_statement);
		stm = addr (quad (cur_statement));
		next_statement = fixed (stm -> opt_statement.next, 18);

		do op = stm -> opt_statement.first_operator repeat next_op while (op ^= next_statement);
		     o = addr (quad (op));
		     next_op = o -> operator.next;
		     call remove_operator (o);
		     end;

		stm -> opt_statement.label = 0;
		stm -> opt_statement.flow_unit = bt;
		if stm -> opt_statement.moved
		then call free_statement (stm);
		end;

	     fu -> flow_unit.used -> bits, fu -> flow_unit.busy_on_entry -> bits, fu -> flow_unit.busy_on_exit -> bits,
		fu -> flow_unit.always_completely_set -> bits, fu -> flow_unit.set -> bits,
		fu -> flow_unit.set_multiple -> bits = "0"b;

	     /* detach the flow_unit */

	     call detach_flow_unit (fu);
	     end;

	lp -> loop.used -> bits, lp -> loop.set -> bits, lp -> loop.set_multiple -> bits = "0"b;

remove_operator:
     procedure (p_o);

dcl  (o, p_o) pointer;				/* -> operator to be removed from loop */

dcl  (p, outp) pointer;
dcl  (i, opnd) fixed binary (18);

	o = p_o;

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then do;
		p = addr (rands (opnd));

		if p -> node.node_type = array_ref_node
		then p -> array_ref.ref_count = p -> array_ref.ref_count - 1;

		else if p -> node.node_type = temporary_node
		then p -> temporary.ref_count = p -> temporary.ref_count - 1;
		end;
	     end;

	if o -> operator.output > 0
	then do;
	     outp = addr (rands (o -> operator.output));

	     if outp -> node.node_type = temporary_node | o -> operator.op_code = opt_subscript_op
	     then call replace_inputs (addr (polish (outp -> temporary.start_input_to)), 0);
	     end;

	call free_operator (o);

     end remove_operator;

     end remove_units_from_loop;

     end remove_loop;

free_statement:
     procedure (stm);

dcl  stm pointer;					/* -> opt_statement to be unthreaded */

dcl  (next_statement, last_statement) fixed binary (18);
dcl  (nst, lst) pointer;

	next_statement = fixed (stm -> opt_statement.next, 18);
	nst = addr (quad (next_statement));
	last_statement = fixed (stm -> opt_statement.back, 18);
	lst = addr (quad (last_statement));

	lst -> opt_statement.next = stm -> opt_statement.next;
	nst -> opt_statement.back = stm -> opt_statement.back;

	call unthread (stm);

     end free_statement;

     end optimize_subprogram;

create_integer_constant:
     procedure (value) returns (fixed binary (18));

dcl  value fixed binary (18);

	if value = 1
	then return (one);
	else return (create_constant (int_mode, unspec (value)));

     end create_integer_constant;

index_value_analysis:
     procedure ();

	/* index_value_analysis:

	   determines which induction variables may be kept in an index register throughout a loop.
	   To be eligible , an induction variable must not be busy_on_exit from a loop, must
	   not be compared with anything unless we can determine its range, must not be assigned to
	   an ineligible variable, and must not be used except as an offset or length, and in assignment
	   or comparison contexts.

	   This roiutine also sets ref_count_copy for temporary and array_ref nodes and computes loop.computed,
	   a bit string identifying operators that compute their values within a loop.
	*/

dcl  i fixed binary;


	do i = 1 to n_loops;
	     call analyze_loop_index_values ((loop_vector (i)), i ^= n_loops);
	     end;

	return;

analyze_loop_index_values:
     procedure (p_lp, p_do_analysis);

dcl  (p_lp, lp) pointer,				/* -> loop to be analyzed */
     (p_do_analysis, do_analysis) bit (1) aligned;

dcl  (
     fu,
     o,
     opnd (2),
     outp,
     p,
     stm
     ) pointer;
dcl  (i, op_code) fixed binary;
dcl  (ipol, next_statement, op, next_unit_statement) fixed binary (18);
dcl  int_image fixed binary (35) aligned based;
dcl  (assignment_list, comparison_list, eligible_ind_var_op_var_list, busy_on_exit_list) pointer;

	/* INITIALIZE */

	lp = p_lp;
	do_analysis = p_do_analysis;
	assignment_list, comparison_list, eligible_ind_var_op_var_list, busy_on_exit_list = null;

	/* Initialize loop.may_keep_in_xr with information from inner loops.
	   We gather information about induction vars AND invariants to propagate
	   upwards.  Invariants may be kept in xrs despite context
	   as long as context info is propagated upwards to loops where the vars
	   may not be invariant.	*/

	if do_analysis
	then do;
	     lp -> loop.may_keep_in_xr -> bits =
		lp -> loop.induction_var -> bits | (integer_scalar_mask & ^lp -> loop.set -> bits);

	     do p = lp -> loop.son repeat p -> loop.brother while (p ^= null);
		lp -> loop.may_keep_in_xr -> bits =
		     lp -> loop.may_keep_in_xr -> bits & p -> loop.may_keep_in_xr -> bits;
		p -> loop.may_keep_in_xr -> bits =
		     p -> loop.may_keep_in_xr -> bits | (integer_scalar_mask & ^p -> loop.set -> bits);
		lp -> loop.computed -> obits = lp -> loop.computed -> obits | p -> loop.computed -> obits;
		end;
	     end;

	else do p = lp -> loop.son repeat p -> loop.brother while (p ^= null);
		p -> loop.may_keep_in_xr -> bits =
		     p -> loop.may_keep_in_xr -> bits | (integer_scalar_mask & ^p -> loop.set -> bits);
		end;

	/* Process all operators immediately contained in this loop. */

	do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null);
	     if fu -> flow_unit.next ^= null
	     then next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement;
	     else next_unit_statement = 0;

	     if fu -> flow_unit.first_statement ^= 0
	     then do cur_statement = fu -> flow_unit.first_statement repeat next_statement
		     while (cur_statement ^= next_unit_statement);
		     stm = addr (quad (cur_statement));
		     next_statement = fixed (stm -> opt_statement.next, 18);

		     do op = stm -> opt_statement.first_operator repeat o -> operator.next
			while (op ^= next_statement);
			o = addr (quad (op));
			op_code = o -> operator.op_code;

			if o -> operator.output > 0
			then do;
			     outp = addr (rands (o -> operator.output));

			     if outp -> node.node_type = temporary_node | op_code = opt_subscript_op
			     then outp -> temporary.ref_count_copy = outp -> temporary.ref_count;
			     end;

			if do_analysis
			then do;
			     if o -> operator.coordinate > 0
			     then substr (lp -> loop.computed -> obits, o -> operator.coordinate, 1) = "1"b;

			     go to case (xop_class (op_code));

case (1):						/* opt_subscript */
			     if o -> operand (3) > 0
			     then do;
				if outp -> array_ref.large_offset
				then call disqualify (addr (rands (o -> operand (3))));
				end;

			     go to case_end;

case (2):						/* incrementing */
			     if o -> operator.number > 0
			     then do;
				p = addr (rands (o -> operand (1)));

				if p -> node.node_type ^= constant_node
				then if ^invariant (p)
				     then call disqualify (p);
				     else if eligible (outp)
				     then do;
					call chain_it (o, eligible_ind_var_op_var_list);
					call check_busy_on_exit (outp);
					outp -> symbol.secondary = null;
					end;
				     else call disqualify (p);

				else if eligible (outp)
				then do;
				     if op_code = neg_storage_add_op
				     then p = addr (
					     rands (
					     create_integer_constant (-addr (p -> constant.value) -> int_image))
					     );
				     outp -> symbol.secondary = p;
				     call check_busy_on_exit (outp);
				     end;
				end;

			     else if eligible (outp)
			     then do;
				outp -> symbol.secondary = onep;
				call check_busy_on_exit (outp);
				end;

			     go to case_end;

case (3):						/* relational */
			     opnd (1) = addr (rands (o -> operand (1)));
			     opnd (2) = addr (rands (o -> operand (2)));

			     do i = 1 to 2;
				if ^invariant (opnd (i))
				then do;
				     call disqualify (opnd (3 - i));

				     if eligible (opnd (i))
				     then if invariant (opnd (3 - i))
					then call chain_it (o, comparison_list);
				     end;
				end;

			     go to case_end;

case (4):						/* jump_arithmetic */
			     p = addr (rands (o -> operand (1)));

			     if eligible (p)
			     then if ^invariant (p)
				then call chain_it (o, comparison_list);
				else call disqualify (p);

			     go to case_end;

case (5):						/* assign */
			     p = addr (rands (o -> operand (1)));

			     if ^eligible (outp)
			     then call disqualify (p);
			     else do;
				if eligible (p)
				then do;
				     call chain_it (o, assignment_list);
				     call check_busy_on_exit (outp);
				     end;
				outp -> symbol.secondary = null;
				end;

			     go to case_end;

case (6):						/* write_namelist */
			     ipol = addr (rands (o -> operand (1))) -> symbol.initial;
			     do i = 1 to polish (ipol);
				call disqualify (addr (rands (polish (ipol + i))));
				end;

			     go to case_end;

case (7):						/* most_operators */
			     call disqualify_inputs;
			     go to case_end;

case (8):						/* cat */
case_end:
			     end;
			end;
		     end;
	     end;

	/* process comparison and assignment lists */

	call process_assignment_list ("0"b);

	call process_comparison_list;

	call process_busy_on_exit_list;

	call process_assignment_list ("1"b);

	lp -> loop.eligible_ind_var_op_var = eligible_ind_var_op_var_list;

	return;

invariant:
     procedure (p) returns (bit (1) aligned);

dcl  p pointer;					/* -> operand */

dcl  o pointer;

	if p -> node.node_type = constant_node
	then return ("1"b);

	else if p -> node.node_type = symbol_node
	then return (^substr (lp -> loop.set -> bits, p -> symbol.coordinate, 1));

	else if p -> node.node_type = temporary_node
	then do;
	     o = addr (quad (p -> temporary.output_by));
	     if o -> operator.coordinate > 0
	     then return (^substr (lp -> loop.computed -> obits, o -> operator.coordinate, 1));
	     end;

	return ("0"b);

     end invariant;

check_busy_on_exit:
     procedure (p);

dcl  p pointer;					/* -> induction variable */

	/* If p is busy_on_exit from lp, we have to chain it for later
	   checking to see if it is non-negative so that it may be easily
	   updated from an xreg. */

	if substr (lp -> loop.busy_on_exit -> bits, p -> symbol.coordinate, 1)
	then call chain_it (p, busy_on_exit_list);

     end check_busy_on_exit;

eligible:
     procedure (p) returns (bit (1) aligned);

	/* determines if an operand is eligible to be kept in an index register */

dcl  p pointer;					/* -> operand */

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then return (substr (lp -> loop.may_keep_in_xr -> bits, p -> symbol.coordinate, 1));

	return ("0"b);

     end eligible;

disqualify_inputs:
     procedure ();

dcl  (i, opnd) fixed binary;

	do i = 1 to o -> operator.number;
	     opnd = o -> operand (i);
	     if opnd > 0
	     then call disqualify (addr (rands (opnd)));
	     end;

     end disqualify_inputs;

disqualify:
     procedure (p);

	/* Makes an operand ineligible to be kept in an index register */

dcl  p pointer;					/* -> operand */

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then substr (lp -> loop.may_keep_in_xr -> bits, p -> symbol.coordinate, 1) = "0"b;

     end disqualify;

chain_it:
     procedure (o, list_head);

dcl  o pointer,					/* -> item to be chained */
     list_head pointer;				/* head of chain */

dcl  c pointer;

	c = create_chain ();
	c -> chain.value = o;
	c -> chain.next = list_head;
	list_head = c;

     end chain_it;

process_comparison_list:
     procedure ();

	/* Attempts to get range information for all comparisons on the list. */

dcl  (bt, c, exit_c, exit_fu, last_c, orig_o, p, prev_fu, r) pointer;
dcl  op_code fixed binary;
dcl  have_eligible_variable bit (1) aligned;
dcl  which fixed binary;

dcl  1 range_bits automatic like range.range_bits unaligned;

dcl  max_integer fixed binary (35) internal static initial (011111111111111111111111111111111111b);

	bt = lp -> loop.back_target;
	last_c = null;

	do c = comparison_list repeat c -> chain.next while (c ^= null);
	     last_c = c;
	     orig_o = c -> chain.value;
	     op_code = orig_o -> operator.op_code;

	     p = addr (rands (orig_o -> operand (1)));
	     which = 1;
	     have_eligible_variable = eligible (p);

	     if ^have_eligible_variable & orig_o -> operator.op_code ^= jump_arithmetic_op
	     then do;
		p = addr (rands (orig_o -> operand (2)));
		which = 2;
		have_eligible_variable = eligible (p);
		end;

	     if have_eligible_variable
	     then do;
		string (range_bits) = try_to_calculate_range (p);

		if string (range_bits)
		then do;
		     r = find_range (p, lp, "1"b);
		     string (r -> range.bits) = string (r -> range.bits) & string (range_bits);

		     if string (r -> range.bits) = "0"b | (op_code = jump_arithmetic_op & ^r -> range.fb17)
		     then call disqualify (p);
		     else if op_code ^= jump_arithmetic_op
		     then if addr (rands (orig_o -> operand (3 - which))) -> node.node_type ^= constant_node
			then call chain_it (orig_o, eligible_ind_var_op_var_list);
		     end;

		else call disqualify (p);
		end;
	     end;

	if last_c ^= null
	then do;
	     last_c -> chain.next = free (size (chain));
	     free (size (chain)) = comparison_list;
	     end;

	return;

	/* Attempts to get range info for those vars busy_on_exit from the loop. */

process_busy_on_exit_list:
     entry;

	bt = lp -> loop.back_target;
	last_c = null;
	op_code = 0;

	do c = busy_on_exit_list repeat c -> chain.next while (c ^= null);
	     last_c = c;
	     p = c -> chain.value;

	     if eligible (p)
	     then do;
		r = find_range (p, lp, "1"b);

		prev_fu = null;

		do exit_c = lp -> loop.exits repeat exit_c -> chain.next while (exit_c ^= null & r -> range.fb18_uns);
		     exit_fu = exit_c -> chain.value -> edge.from.value;

		     if exit_fu ^= prev_fu
		     then do;
			prev_fu = exit_fu;
			call derive_insert_for_bt (exit_fu);
			orig_o = addr (quad (exit_fu -> flow_unit.insert_operator));

			string (range_bits) = try_to_calculate_range (p);

			string (r -> range.bits) = string (r -> range.bits) & string (range_bits);
			end;
		     end;

		if ^r -> range.fb18_uns
		then call disqualify (p);
		end;
	     end;

	if last_c ^= null
	then do;
	     last_c -> chain.next = free (size (chain));
	     free (size (chain)) = busy_on_exit_list;
	     end;

	return;

try_to_calculate_range:
     procedure (pt) returns (bit (2) aligned);

dcl  (p, pt) pointer;				/* -> var whose range is being calculated */

dcl  ac pointer;
dcl  var fixed binary (18);

dcl  1 range_bits automatic like range.range_bits unaligned;

	p = pt;

	string (range_bits) = calculate_range_by_subscripts (p);

	/* if we haven't found a range, use vars we assign to or from */

	var = fixed (rel (p), 18);

	do ac = assignment_list repeat ac -> chain.next while (string (range_bits) = "0"b & ac ^= null);
	     if ac -> chain.value -> operand (1) = var
	     then string (range_bits) =
		     calculate_range_by_subscripts (addr (rands (ac -> chain.value -> operator.output)));

	     else if ac -> chain.value -> operator.output = var
	     then string (range_bits) =
		     calculate_range_by_subscripts (addr (rands (ac -> chain.value -> operator.operand (1))));
	     end;

	/* If we still haven't found a range, see if we are in
	   lock step with another induction variable whose range
	   is knowable. */

	if string (range_bits) = "00"b
	then string (range_bits) = calculate_range_for_counter (p);

	return (string (range_bits));

     end try_to_calculate_range;

calculate_range_by_subscripts:
     procedure (pt) returns (bit (2) aligned);

dcl  (p, pt) pointer;				/* var whose range is being calculated */

dcl  1 range_bits automatic like range.range_bits unaligned;
dcl  (fu, o, s) pointer;
dcl  (first_statement, op, n, var) fixed binary (18);
dcl  (upper_bound, lower_bound, increment) fixed binary (35);
dcl  constant_offset fixed binary (24);
dcl  max_size fixed binary (24);

	/* This code attempts to calculate a variable's range by assuming
	   that an array or string must not be referenced outside its
	   generation of storage, i.e., subscriptrange, stringrange, and
	   stringsize must not occur! */

	p = pt;
	o = orig_o;

	upper_bound = max_integer;
	lower_bound = -upper_bound;

	if p -> symbol.secondary ^= null
	then do;
	     increment = addr (p -> symbol.secondary -> constant.value) -> int_image;
	     var = fixed (rel (p), 18);

	     do fu = null repeat fu -> flow_unit.dominator while (fu ^= bt);
		if fu ^= null
		then do;
		     first_statement = fu -> flow_unit.first_statement;
		     op = fu -> flow_unit.next -> flow_unit.first_statement;
		     o = addr (quad (op));
		     end;
		else first_statement = 0;

		do op = o -> operator.back repeat o -> operator.back while (op ^= first_statement);
		     o = addr (quad (op));
		     n = o -> operator.number;

		     if o -> operator.op_code = stat_op
		     then if fu = null
			then do;
			     fu = o -> opt_statement.flow_unit;
			     first_statement = fu -> flow_unit.first_statement;
			     if op = first_statement
			     then o = addr (quad (o -> operator.next));
			     end;
			else ;

		     else if o -> operator.op_code = opt_subscript_op
		     then do;
			s = addr (rands (o -> operand (1)));

			if n >= 4
			then if o -> operand (4) = var
			     then do;
				lower_bound = max (lower_bound, 1);
				if ^s -> symbol.variable_extents
				then max_size = s -> symbol.char_size + 1;
				else max_size = max_char_length;
				upper_bound = min (upper_bound, max_size);
				end;

			if o -> operand (3) = var
			then do;
			     constant_offset =
				addr (addr (rands (o -> operand (2))) -> constant.value) -> int_image;

			     lower_bound = max (lower_bound, min (increment, 0) - constant_offset);

			     max_size = get_max_size (s);

			     upper_bound = min (upper_bound, max_size - constant_offset + max (increment, 0) - 1);
			     end;
			end;

		     else if o -> operator.op_code = cat_op
		     then if o -> operand (n) = var
			then do;
			     lower_bound = max (lower_bound, 1);
			     upper_bound = min (upper_bound, max_char_length);
			     end;
		     end;
		end;
	     end;

	string (range_bits) = "0"b;
	if lower_bound >= -131072 & upper_bound < 131072
	then range_bits.fb17 = "1"b;
	if lower_bound >= 0 & upper_bound < 262144
	then range_bits.fb18_uns = "1"b;

	return (string (range_bits));

     end calculate_range_by_subscripts;

get_max_size:
     procedure (s) returns (fixed binary (24));

dcl  s pointer;					/* -> symbol node */

dcl  sys_info$max_seg_size fixed bin (18) ext;

dcl  d pointer;
dcl  max_chars fixed bin (21);
dcl  max_words fixed bin (24);
dcl  max_size fixed binary (24);

	/* returns maximum size of an array */

	max_chars = sys_info$max_seg_size * chars_per_word;
	if s -> symbol.VLA
	then max_words = max_fixed_bin_24;
	else max_words = sys_info$max_seg_size;

	if s -> symbol.dimension > 0
	then do;
	     d = addr (rands (s -> symbol.dimension));

	     if s -> symbol.variable_extents | s -> symbol.star_extents
		| (s -> symbol.parameter & d -> dimension.element_count <= 1)
	     then if s -> symbol.units = char_units
		then max_size = max_chars;
		else max_size = max_words;
	     else max_size = d -> dimension.array_size;
	     end;

	else if s -> symbol.variable_extents
	then if s -> symbol.units = char_units
	     then max_size = max_chars;
	     else max_size = max_words;
	else max_size = s -> symbol.element_size;

	return (max_size);

     end get_max_size;

calculate_range_for_counter:
     procedure (pt) returns (bit (2) aligned);

dcl  (p, pt) pointer;				/* var whose range is being calculated */

dcl  1 range_bits automatic like range.range_bits unaligned;

dcl  (c, const_p, fu, last_c, o, s, u) pointer;
dcl  (first_statement, op, var) fixed binary (18);
dcl  (upper_bound, lower_bound, bound) fixed binary (35);
dcl  (starting_value, other_value) fixed binary (35);
dcl  found bit (1) aligned;
dcl  (opt_subscript_chain, update_chain) pointer;
dcl  (increment, other_increment) fixed binary (18);

	/* This code hopes that our variable is in lock step with another
	   variable that is referencing a string or array.  If so, and if
	   our starting value is known, we can deduce a maximum number
	   of iterations for our variable and thus figure out the other
	   bound.  If our comparand is constant, and the op_code is proper,
	   the job is even easier. */

	p = pt;
	string (range_bits) = "0"b;

	if p -> symbol.secondary ^= null
	then do;
	     increment = addr (p -> symbol.secondary -> constant.value) -> int_image;
	     call get_starting_value (p, starting_value, found);

	     if found
	     then do;
		if increment > 0
		then do;
		     upper_bound = max_integer;
		     lower_bound = starting_value;
		     end;
		else do;
		     upper_bound = starting_value;
		     lower_bound = -max_integer;
		     end;

		/* If comparand is constant, we can deduce range quickly.
		   We assume the bottom of a do-loop ends with a jump_false_op. */

		if op_code ^= 0 & op_code ^= jump_arithmetic_op
		then if addr (rands (orig_o -> operand (3 - which))) -> node.node_type = constant_node
		     then if is_suitable_loop_exit (orig_o, p, lp)
			then do;
			     other_value =
				addr (addr (rands (orig_o -> operand (3 - which))) -> constant.value)
				-> int_image;
			     if increment > 0 & op_code = greater_op
			     then upper_bound = max (other_value + increment, lower_bound);
			     else if increment < 0 & op_code = less_op
			     then lower_bound = min (other_value + increment, upper_bound);
			     end;

		if upper_bound = max_integer | lower_bound = -max_integer
		then do;

		     /* We have to do it the hard way. */

		     opt_subscript_chain, update_chain = null;
		     o = orig_o;

		     do fu = null repeat fu -> flow_unit.dominator while (fu ^= bt);
			if fu ^= null
			then do;
			     first_statement = fu -> flow_unit.first_statement;
			     op = fu -> flow_unit.next -> flow_unit.first_statement;
			     o = addr (quad (op));
			     end;
			else first_statement = 0;

			do op = o -> operator.back repeat o -> operator.back while (op ^= first_statement);
			     o = addr (quad (op));

			     if o -> operator.op_code = stat_op
			     then if fu = null
				then do;
				     fu = o -> opt_statement.flow_unit;
				     first_statement = fu -> flow_unit.first_statement;
				     if op = first_statement
				     then o = addr (quad (o -> operator.next));
				     end;
				else ;

			     else if o -> operator.op_code = opt_subscript_op
			     then if o -> operand (3) > 0
				then do;
				     s = addr (rands (o -> operand (3)));
				     if s -> node.node_type = symbol_node
				     then if substr (lp -> loop.induction_var -> bits, s -> symbol.coordinate, 1)
					then call chain_it (o, opt_subscript_chain);
				     end;
				else ;

			     else if o -> operator.output > 0
			     then do;
				s = addr (rands (o -> operator.output));
				if s -> node.node_type = symbol_node
				then if substr (lp -> loop.induction_var -> bits, s -> symbol.coordinate, 1)
				     then call chain_it (o, update_chain);
				end;
			     end;
			end;

		     /* Process opt_subscript_chain. */

		     last_c = null;
		     do c = opt_subscript_chain repeat c -> chain.next while (c ^= null);
			last_c = c;
			o = c -> chain.value;
			var = o -> operand (3);
			found = "0"b;

			do u = update_chain repeat u -> chain.next while (^found & u ^= null);
			     if u -> chain.value -> operator.output = var
			     then found = "1"b;
			     end;

			if found
			then do;
			     const_p = addr (rands (var)) -> symbol.secondary;
			     if const_p ^= null
			     then other_increment = abs (addr (const_p -> constant.value) -> int_image);
			     else other_increment = 1;

			     bound = starting_value
				+ increment
				*
				divide (get_max_size (addr (rands (o -> operand (1)))) + other_increment - 1,
				other_increment, 24, 0);

			     if increment > 0
			     then upper_bound = min (upper_bound, bound);
			     else lower_bound = max (lower_bound, bound);
			     end;
			end;

		     if last_c ^= null
		     then do;
			last_c -> chain.next = free (size (chain));
			free (size (chain)) = opt_subscript_chain;
			end;

		     last_c = null;
		     do c = update_chain repeat c -> chain.next while (c ^= null);
			last_c = c;
			end;

		     if last_c ^= null
		     then do;
			last_c -> chain.next = free (size (chain));
			free (size (chain)) = update_chain;
			end;
		     end;

		if lower_bound >= -131072 & upper_bound < 131072
		then range_bits.fb17 = "1"b;
		if lower_bound >= 0 & upper_bound < 262144
		then range_bits.fb18_uns = "1"b;
		end;
	     end;

	return (string (range_bits));

     end calculate_range_for_counter;

get_starting_value:
     procedure (pt, starting_value, found);

dcl  (p, pt) pointer,				/* var whose starting value is needed */
     starting_value fixed binary (35),			/* answer (output) */
     found bit (1) aligned;				/* "1"b - starting value is valid (output) */

dcl  (first_statement, i, op, var) fixed binary (18);
dcl  o pointer;
dcl  in_common bit (1) aligned;

	/* Looks for starting value of an induction variable.  We only search back target. */

	p = pt;
	found = "0"b;

	if substr (bt -> flow_unit.set -> bits, p -> symbol.coordinate, 1)
	then do;
	     var = fixed (rel (p), 18);
	     in_common = p -> symbol.in_common;

	     /* refresh insert_operator field */

	     call derive_insert_for_bt (bt);

	     /* Loop back through operators looking for an assignment to var. */

	     first_statement = bt -> flow_unit.first_statement;

	     do op = bt -> flow_unit.insert_operator repeat o -> operator.back while (op ^= first_statement);
		o = addr (quad (op));

		if o -> operator.op_code = read_namelist_op
		then if in_namelist (o, var)
		     then return;
		     else ;

		else if o -> operator.op_code = call_op | o -> operator.op_code = func_ref_op
		then do;
		     if in_common | o -> operator.output = var
		     then return;

		     do i = 1 to o -> operator.number;
			if o -> operand (i) = var
			then return;
			end;
		     end;

		else if o -> operator.output = var
		then do;
		     if o -> operator.op_code = assign_op
		     then if addr (rands (o -> operand (1))) -> node.node_type = constant_node
			then do;
			     starting_value = addr (addr (rands (o -> operand (1))) -> constant.value) -> int_image;
			     found = "1"b;
			     end;
		     return;
		     end;
		end;
	     end;

     end get_starting_value;

is_suitable_loop_exit:
     procedure (p_o, var_p, p_lp) returns (bit (1) aligned);

dcl  (orig_o, p_o) pointer,				/* -> relational op that may be input to
						   a jump_false_op whose fall_through
						   exits the loop */
     var_p pointer,					/* induction variable */
     (lp, p_lp) pointer;				/* loop */

dcl  (fu, inp, jop, lab, o, outp, stm) pointer;
dcl  (first_statement, op, var) fixed binary (18);
dcl  found bit (1) aligned;

	/* Sees if the relational op that we are looking at is an
	   input to a jump_false_op whose fall_through exits the loop,
	   whose target is within the loop, and which must be
	   executed when the induction variable is updated. */

	orig_o = p_o;
	lp = p_lp;

	/* The update of the induction variable must be in the same
	   flow_unit as that of the test so that the test is not
	   bypassed whenever the variable is updated. */

	var = fixed (rel (var_p), 18);
	fu = null;
	first_statement = 0;
	found = "0"b;

	do op = orig_o -> operator.back repeat o -> operator.back while (^found & op ^= first_statement | fu = null);
	     o = addr (quad (op));

	     if o -> operator.op_code = stat_op
	     then if fu = null
		then do;
		     fu = o -> opt_statement.flow_unit;
		     first_statement = fu -> flow_unit.first_statement;
		     if op = first_statement
		     then o = addr (quad (o -> operator.next));
		     end;
		else ;

	     else if o -> operator.output = var
	     then found = "1"b;
	     end;

	if ^found
	then return ("0"b);

	/* Examine all operators that orig_o is input to */

	outp = addr (rands (orig_o -> operator.output));
	do inp = addr (polish (outp -> temporary.start_input_to)) repeat inp -> input_to.next while (inp ^= null);
	     if inp -> input_to.which > 0
	     then do;
		jop = inp -> input_to.operator;

		/* op_code for bottom of a do_loop is jump_false_op */
		if jop -> operator.op_code ^= jump_false_op
		then return ("0"b);

		/* target must be within loop */

		lab = addr (rands (jop -> operand (2)));
		stm = addr (quad (lab -> label.statement));
		if stm -> opt_statement.flow_unit -> flow_unit.loop ^= lp
		then return ("0"b);

		/* fall_through must exit the loop */

		if fu -> flow_unit.next -> flow_unit.loop -> loop.depth >= lp -> loop.depth
		then return ("0"b);
		end;
	     end;

	return ("1"b);

     end is_suitable_loop_exit;

     end process_comparison_list;

find_range:
     procedure (pt, plp, create_it) returns (pointer);

	/* Finds range data for a variable or, optionally, creates the data */

dcl  (p, pt) pointer,				/* -> symbol whose range data is needed */
     (lp, plp) pointer,				/* -> loop whose list is searched */
     create_it bit (1) aligned;

dcl  r pointer;

	p = pt;
	lp = plp;

	do r = lp -> loop.range_list repeat r -> range.next while (r ^= null);
	     if r -> range.variable = p
	     then return (r);
	     end;

	if create_it
	then do;
	     r = create_range (p, lp);
	     string (r -> range.bits) = "11"b;
	     end;

	return (r);

     end find_range;

create_range:
     procedure (p, lp) returns (pointer);

dcl  p pointer,					/* -> symbol for whom a range node is being created */
     lp pointer;					/* -> loop whose list is being added to */

dcl  r pointer;

	r = get_opt_space (size (range));
	r -> range.variable = p;
	r -> range.next = lp -> loop.range_list;
	lp -> loop.range_list = r;

	return (r);

     end create_range;

process_assignment_list:
     procedure (free_assignment_list);

	/* eligible vars may only assign to eligible vars */

dcl  free_assignment_list bit (1) aligned;

dcl  (c, inp, last_c, next_c, o, outp, rin, rout) pointer;
dcl  change_occurred bit (1) aligned;

	change_occurred = "1"b;

	do while (change_occurred);
	     change_occurred = "0"b;
	     last_c = null;

	     do c = assignment_list repeat next_c while (c ^= null);
		next_c = c -> chain.next;
		o = c -> chain.value;
		inp = addr (rands (o -> operand (1)));
		outp = addr (rands (o -> operator.output));

		if ^eligible (inp)
		then call remove (c, last_c);

		else if ^eligible (outp)
		then do;
		     call remove (c, last_c);
		     substr (lp -> loop.may_keep_in_xr -> bits, inp -> symbol.coordinate, 1) = "0"b;
		     change_occurred = "1"b;
		     end;

		else do;
		     last_c = c;

		     /* propagate range information */

		     rout = find_range (outp, lp, "0"b);
		     if rout ^= null
		     then do;
			rin = find_range (inp, lp, "0"b);
			if rin = null
			then do;
			     change_occurred = "1"b;
			     rin = create_range (inp, lp);
			     string (rin -> range.bits) = string (rout -> range.bits);
			     end;
			end;

		     /* propagate increment information */

		     if outp -> symbol.secondary = null & inp -> symbol.secondary ^= null
		     then do;
			outp -> symbol.secondary = inp -> symbol.secondary;
			change_occurred = "1"b;
			end;
		     end;
		end;
	     end;

	if free_assignment_list & last_c ^= null
	then do;
	     last_c -> chain.next = free (size (chain));
	     free (size (chain)) = assignment_list;
	     end;

	return;

remove:
     procedure (c, last_c);

dcl  c pointer,					/* assignment list item being removed */
     last_c pointer;				/* previous list item */

	if last_c ^= null
	then last_c -> chain.next = c -> chain.next;
	else assignment_list = c -> chain.next;

	c -> chain.next = free (size (chain));
	free (size (chain)) = c;

     end remove;

     end process_assignment_list;

     end analyze_loop_index_values;

     end index_value_analysis;

%include fort_opt_utilities;

%include fort_utilities;

print_hash_bucket_meters:
     procedure ();

dcl  i fixed binary;
dcl  p pointer;

	do i = 0 to hbound (p_list, 1);
	     hash_counter (i) = 0;
	     do p = p_list (i) repeat p -> primary.next while (p ^= null);
		hash_counter (i) = hash_counter (i) + 1;
		end;
	     end;

	call ioa_ ("p_list:  ^(^4d^3x^)", hash_counter);

	do i = 0 to hbound (bt_list, 1);
	     hash_counter (i) = 0;
	     do p = bt_list (i) repeat p -> primary.next while (p ^= null);
		hash_counter (i) = hash_counter (i) + 1;
		end;
	     end;

	call ioa_ ("bt_list: ^(^4d^3x^)", hash_counter);

     end print_hash_bucket_meters;

     end fort_optimizer;




		    fort_optimizing_cg.pl1          05/30/90  1552.3rew 05/30/90  1534.7     3715794



/****^  *********************************************************
        *                                                       *
        * Copyright, (C) BULL HN Information Systems Inc., 1990 *
        *                                                       *
        * Copyright, (C) Honeywell Limited, 1983                *
        *                                                       *
        * Copyright (c) 1972 by Massachusetts Institute of      *
        * Technology and Honeywell Information Systems, Inc.    *
        *                                                       *
        ********************************************************* */




/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bugs 430, 449, 452, 455, 460, 463, and 492.
  2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bugs 411, 425, and 473.
  3) change(86-10-17,Ginter), approve(86-10-17,MCR7556), audit(86-10-22,Huen),
     install(86-11-13,MR12.0-1216):
     Fixed fortran bugs 496 and 502.
  4) change(90-04-27,Huen), approve(90-04-27,MCR8155), audit(90-05-16,Gray),
     install(90-05-30,MR12.4-1011):
     ft_508 : Generate correct code for index intrinsic on a substring of a
     static character variable.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */
fort_optimizing_cg:
     procedure (p1, p2);

dcl  (p1, p2, shared_struc_ptr, cg_struc_ptr) pointer;
dcl  (object_base, operand_base, polish_base, relocation_base, quadruple_base, opt_base) pointer;
dcl  (object_max_len, operand_max_len, polish_max_len, opt_max_len) fixed binary (19);

%include fort_nodes;
%include fort_opt_nodes;

%include fort_listing_nodes;

%include fort_system_constants;

dcl  1 shared_globals structure aligned based (shared_struc_ptr),
%include fort_shared_vars;

%include fort_options;

dcl  1 cg_globals structure aligned based (cg_struc_ptr),
%include fort_cg_vars;

%include definition;
%include segname_def;

dcl  1 symtab_parameters structure aligned,
%include fort_symtab_parms;
%include long_profile;

dcl  fort_make_symbol_section entry (ptr, ptr, ptr, fixed bin (18), fixed bin (18));


	shared_struc_ptr = p1;
	cg_struc_ptr = p2;
	object_max_len = shared_globals.object_max_len;
	operand_max_len = shared_globals.operand_max_len;
	polish_max_len = shared_globals.polish_max_len;
	opt_max_len = shared_globals.opt_max_len;


	object_base = shared_globals.object_base;
	operand_base = shared_globals.operand_base;
	polish_base = shared_globals.polish_base;
	relocation_base = shared_globals.relocation_base;
	quadruple_base = shared_globals.quadruple_base;
	opt_base = shared_globals.opt_base;


	call code_generator;

%include fort_utilities;

code_generator:
     procedure ();

/****^ Written: 1 February 1976 by Richard A. Barnes


Modified: 31 Mar 90, SH - 508: When necessary, reset pr4 to linkage ptr.  
          Avoid inserting an instruction in the middle of the scm arg sequence
          for index intrinsic when pr4 is valid. Also, remove "restore_prs".
Modified: 16 Oct 86, AG - 502a:  Change make_symbol_descriptor so it always
	generates correctly formatted char (*) descriptors.  Change
	make_entry_descriptor so it never "adjusts" incorrectly formatted
	char (*) descriptors.  Change get_param_char_size so that it always
	expects correctly formatted char (*) descriptors.
Modified: 22 Sep 86, AG - 502:  Set descriptor size field to "1"b only for
	character *(*) variables in make_entry_descriptor.
Modified: 22 Sep 86, AG - 496a:  Oops -- forgot that array symbols can
	be accessed directly in "call" statements.  Explicitly check
	for symbol.dimensioned when restoring symbol.address.offset.
Modified: 04 Sep 86, AG - 496:  For non-array symbols in very large common,
	use symbol.addr_hold instead of symbol.address.offset to hold the
	offset in the linkage section of the pointer to the symbol.  Too
	much code counts on symbol.address.offset holding the offset from
	the pointer of the symbol (always 0).  Also made create_storage_entry
	save info in a_name about symbols used in create_entry structures.
Modified: 08 Jul 86, AG - 449.a: Use "anq/stq" instructions rather than "orsq"
	to update length field in character* (*) dummy arg descriptors.
Modified: 19 Feb 86, BW & AG - 473.a: Flag error if passing VLA type arguments
	to non-VLA type arguments in the same compilation unit.
Modified: 03 Feb 86, SH - 425: Passing hollerith (i.e. character) constant
	data types as arguments to other data types will no longer
	produce error 401 (inconsistent argument types).
Modified: 29 Oct 85, BW - 411: Make sure common block units are the same when
	comparing maximum lengths.
Modified: 08 Aug 85, BW - 430: Prevent emission of deallocation code for auto-
	matic LA's and VLA's when they don't exist in the compilation unit.
Modified: 02 Aug 85, BW - 463: Remove code for action (56) since the macros
          no longer require this action after the bug fix.
Modified: 04 Jul 85, BW - 460: Fix addressing of complex number arrays.
Modified: 21 May 85, BW - 455: Ensure auto ptrs to parameters are allocated
          on even word boundaries.
Modified: 24 Apr 85, MM - 449: Create the routine 'make_entry_descriptor' as
	'make_symbol_descriptor' can't be used by the code that makes
	entrys.
Modified: 30 Jan 85, MM - 447: Allow base_man_load_any_pr to set the bit
	address_in_base for VLA elements.
Modified: 19 Oct 84, MM - 443: Fix list_init_ array initialization.
Modified: 22 Aug 84, HH - 439: 'make_symbol_descriptor' sets lower bound to
	-2**35 if lower bound is constant but upper bound is not.
Modified: 22 Jun 84, MM - Install typeless functions support.
Modified: 09 Apr 84, MM - 417: character elements are incorrectly assumed to
	be word aligned in ansi77 mode if lower bound of array is 0.
Modified: 04 Apr 84, HH - 416: 'add' and 'sub' need to support -ve constants.
Modified: 28 Mar 84, HH: Install HFP support.
Modified: 13 Mar 84, HH - 415: Incorrect relocation information generated for
		entry point declarations.
Modified: 26 Jan 84, TO: 414 - Fix bug in char(*) sizing introduced by entry
	definition code.  We need to emit an extra constant word for char(*)
	descriptors, rather than mangle the real word that ORQ will refer to.
Modified: 19 Sep 83, RG & MM - 242/370: Use entry-defined arg_desc if one exists.
Modified: 27 Jul 83, HH - 371: 'mult' needs to support -ve constants.
Modified:	17 Jun 83, HH - 383: Simplify input to 'check_parameters'.
Modified:  8 June 83, TO: 382 - Fix size of entry_info (builtin(8)) to
	correspond to reality (it is 7 words long).
	Update documentation of builtin (8).
Modified:  8 June 83, TO: 381 - Fix register reservation mask for shorten_stack
	renamed from reserve_pr1_mask (which reserved pr0 instead) to
	shorten_stack_mask which reserves pr1, x1.
Modified:	14 April 83, RG: 377 - Fix flush_ref to use flag 'in_equiv_stmnt'
	not 'aliasable'.
Modified: 14 April 83, TO - fix 'make_create_entry' to correctly address
	'create_entry.next' when setting 't' relocation.
Modified:  5 April 83, TO - fix 'check_parameters' to ensure parameter is
	a symbol and not a return constant.
Modified:  5 April 83, TO - fix list_template_init of common bugs.
Modified:  5 April 83, TO - fix 'allocate', 'free' bug in VLA common
	cleanup, have cleanup done by common cleanup routine.  Chain headers
	were being free'd twice, and cleanup during processing was
	inconsistent.
Modified: 31 March 1983, TO: 374 - Fix bug in large_address array_ref in
	finish_subscript in which the constant offset of the array_ref
	backs up before the 16K bound, leaving array_ref base wrong and
	large_address flag off preventing re-calc of base in 
	m_a_check_large_address.
Modified: 31 Jan 83, TO & HH: Install LA/VLA support.
Modified: 10 January  1982, TO - Add 'emit_entry_def (simple (56)) operation
	from macros to create an entry definition entry.  Added code to
	gen_entry_defs to copy text position of definition to table.  Added
	code to 'check_parameters' (simple (15)) to fill in descriptors.
Modified: 31 December 1982, TO: 367 - Cause allocation of named constants if
	we want a symbol_table.
Modified: 22 Dec 82, TO - 358:  use 'lock_base' in 'load_preg' to correct 
	running out of pointer registers.
Modified: 18 Dec 82, TO - Add '-long_profile' support.
Modified: 17 Nov 82, HH - 361:  'get_format_var' operator no longer exists.
Modified: 05 August 1982, HH - Fix bug 357:  Pad char constants with spaces
	rather than NUL's.
Modified: 16 July, 1982, TO - fix bug introduced in fix of bug345.  We
	     incorrectly mixed the index of the global and free register in
	     "base_man_load_large_base".
Modified: 21 May 1982, TO - Fix bug in check_arg_list where 'n' is used in
	     place of 'num_args'.
Modified: 20 May 1982, TO - Fix bug where virtual_origin automatic is not
          allocated for star_extent array in 'get_array_size'.
Modified: 20 May 1982, TO - Fix descriptor bug where char*(*) multiplier is
	only calculated for last dimension, leaving an unprobe-able, and at
	times (dims>2) unrunnable binary.
Modified: 20 May 1982, TO - Fix probe bug where char*(*) multiplier calculated
	for descriptor in bits is used for probe runtime_symbol in chars.
	This causes an extended descriptor to be allocated in the stack and
	the intermediate character multiplier to be stored in the extended
	area to be picked up by runtime_symbol.bound(n).multiplier.
Modified:  9 May 1982, TO - Fix (if unless)_negative to know about other than
	integer.
Modified:  7 May 1982, TO - Fix use of EAQ register and move_logical_to_a.
	previously move_logical_to_a used and reset A, but didn't consider
	those things in EAQ, which subsiquently got lost and not stored.
Modified:  5 May 1982, TO - Allocate char_star_function return_value.
Modified:  5 May 1982, TO - Add action (74) (if unless)_char_star_function.
Modified:  5 May 1982, TO - Add action (75) (if unless)_check_multiply.
Modified: 26 April 1982    , TO  - fix navytest3 bug.  Cause flush_ref to
	remove ALL equivalenced refs in this chain.
Modified: 26 April 1982    , TO  - fix navytest16 bug in optimized_subscript.
	char_num of array base was not added to calculated character number.
Modified: 15 April 1982    , TO  - Implement extended information for stack and
	linkage overflow message (error 414).
Modified: 12 April 1982    , TO  - Fix bug 344, stack_indirect in set_itp_addr.
Modified: 05 April 1982    , TO  - Fix register reservation in argument and descriptor processing.
Modified: 15 September 1981, CRD - Change check_comparisons_and_increments to
	put left shift on operator list of loop entry statement if back
	target does not fall through.
Modified: 17 June 1981, CRD - Fix bug 322.
Modified: 12 May 1981, CRD - Add equiv_op, not_equiv_op.
Modified: 23 April 1981, CRD - Fix bug 319.
Modified: 20 April 1981, CRD - Fix bug 316.
Modified: 19 March 1981, CRD - Fix bug 311.
Modified: 12 March 1981, CRD - Implement assumed size arrays.
Modified: 27 February 1981, CRD - Implement array lower bounds ^= 1.
Modified: 9 December 1980, CRD - Change upper bound of
	operator_table array to 102 for block_if, else_if, and
	else operators.
Modified: 25 November 1980, CRD - Improve fix to bug 289.
Modified: 19 November 1980, CRD - Fix bug in which star extent arrays
	did not have their virtual_origin and array_size symbols
	set properly unless the first dimension was variable.
	Also fixed bug in which an attempt to use an ITP argument
	list was made when passing descriptors.
Modified: 31 October 1980, CRD - Change propagate_and_eliminate_assignment
	not to eliminate assignments if the RHS is a symbol and is
	subsequently set in the flow unit.  This fixes bug 289.
Modified: 22 October 1980, CRD - Change load to call move_logical_to_a
	unless the Q is being loaded.  This fixes bug 288.
Modified: 6 October 1980, CRD - Change flush_ref to restore the
	address of aligned character strings.  This fixes bug 282.
	Also some changes mandated by audit.  Also moved symbolic
	names of instructions in single_inst array to the include
	file fort_single_inst_names.incl.pl1.
Modified: 24 September 1980, CRD - Add pointer register 1 to the pool
	of registers available for addressing, etc.
Modified: 24 September 1980, CRD - Change desc_ptr_in_base to be a
	simple macro (desc_ptr_in_pr3), and add arg_ptr_in_pr1.
Modified: 23 September 1980, CRD - Make refresh_regs refresh pointer
	registers with zero offsets first.
Modified: 16 September 1980, CRD - Remove code in optimized_subscript
	which bumped ref counts of length and offset temporaries.
	Also changed drop_count to ignore operand offsets <= 0.
Modified: 15 August 1980, CRD - Fix large address bug in
	continue_cat.
Modified: 13 August 1980, CRD - Catch negative length substrings.
Modified: 12 August 1980, CRD - Fix bug in (if unless)_ansi77.
Modified: 30 July 1980, CRD - Add code to avoid redundant virtual
	origin computation.
Modified: 28 July 1980, CRD - Change optimized_subscript to deal
	with named constants.  Also change convention for detecting
	unprocessed array_ref nodes to use array_ref.has_address.
Modified: 22 July 1980, CRD - Fix bug in optimized_subscript.
Modified: 16 July 1980, CRD - Add (if unless)_variable_arglist macro.
Modified: 15 July 1980, CRD - Changes for generating descriptors
	on calls - copy needs_descriptors bit from entry_point
	symbol to external symbol in assign_storage, and add
	set_needs_descriptors macro.
Modified: 23 June 1980, CRD - Add (if unless)_ansi77.
Modified: 17 June 1980, CRD - Change assign_address_to_temp to copy
	over length information, and to properly extract addresses
	for dynamic temporaries.
Modified: 21 April 1980, CRD - Implement concatenation.
Modified: 18 April 1980, RAB - fix an ureported bug in which load_preg
	loads a global value into a register that should have been
	avoided.
Modified:	18 March 1980, RAB - fix a bug in which
	check_comparisons_and_increments was calling connect_expression with
	the order of the last 2 arguments reversed.  This caused a strange
	instability in temporary allocation, although the code was correct.
Modified:	9 March 1980, RAB - fix a bug in reset_scan: the processing
	that occurs if we have passed over flow_units from other
	loops should occur before we check to see if this loop is
	finished.
Modified:	9 March 1980, RAB - fix several bugs:  make free_temp
	zero temporary.globally_assigned; have reset_scan not
	call save_state if the statement is referenced by assign
	or referenced backwards; have reset_scan discard the
	machine_state at the end of the loop.
Modified:	7 March 1980, RAB - fix a bug in load_preg.  It
	should worry about avoiding prs in next_lp not cur_lp.
Modified:	6 March 1980, RAB - fix a bug in merge_state.  In order
	to refresh the global bits when the state is discarded,
	merge_state should call refresh_global_bits rather than
	enter_loop, since lp_msp might be null.
Modified:	24 February 1980, RAB - add floating_power_of_two
Modified: 15 February 1980, CRD - change return macro to allow
	returning operands other than temporaries.
Modified:	9 February 1980, RAB - allow variables busy_on_exit from a
	loop to be kept in an index register.
Modified: 8 February 1980, CRD - Add char1_to_int, int_to_char1,
	and (if unless)_aligned macros; fix text_ref to work
	with char constants; and change the return macro to
	convert counts to integer constants.
Modified: 3 February 1980, CRD - add code to support star extent
	character strings, to support Fortran entries which require
	descriptors, and to implement substrings.
Modified:	30 January 1980, RAB - to fix a bug in which an empty
	globally assigned register was erroneously loaded with
	a local value.  The fix involved adding an argument to
	get_free_reg to distinguish between a register preselected
	because it was globally assigned the desired item and
	a register preselected because it was empty.
Modified:	27 January 1980, RAB - add force_ql macro to improve jump_computed
	code.
Modified:	8 January 1980, RAB -alter reset_subprogram to reset temporaries in
	ALL loops.
Modified:	8 January 1980, RAB - fix reference count bugs in gen_itp_list and
	base_man_load_pr.
Modified:	2 January 1980, RAB - fix a bunch of bugs.
Modified:	1 January 1980, RAB - added propagate_and_eliminate_assignment.
	Also, loop.all_xrs_globally_assigned.
Modified:	28 December 1979, RAB - made changes to prevent trouble if
	more than one register were locked for arguments to pl1_operators;
	implemented refresh_regs_if_next_is_jump macro to allow
	refresh_regs before relational operator; implemented
	note_eligible_ind_var_use to allow the counting of an
	incrementing or comparison as an index register use during
	analysis; made changes to allow all registers of a class
	to be globally assigned if there are no local uses and
	there are enough registers to assign all global items; and
	made changes to force doubleword alignment for all innermost
	loops.  Also, removed reset_regs.
Modified:	22 December 1979, RAB - make round of bugfixes to register optimizer.
Modified:	18 December 1979, RAB - make bulk of changes to implement
	the REGISTER OPTIMIZER!!
Modified:	1 December 1979, RAB - change ERROR to not push an error
	operand for the scan frame as this is wrong for the
	optimizing cg.
Modified:	30 November 1979, RAB - to add second set of changes for
	the register optimizer.
Modified:	3 November 1979, RAB - to add first set of changes for
	the register optimizer.
Modified: 31 October 1979, CRD - fix bugs caught by audit, and add
	code to get_param_array_size to fill in descriptors for
	packed character string correctly.
Modified: 29 October 1979, CRD - add register reservation for the
	A and Q for EIS instruction offsets.
Modified: 25 October 1979, CRD - invent make_both_addressable, and
	change emit_eis to call it.  Invent eaq_man_load_a_or_q,
	and change m_a to call it.  Invent a new eaq name, in_ia,
	for integers in the A register.
Modified: 23 October 1979, CRD - assorted changes to allow the code
	generator to be compiled with subscriptrange enabled; and a
	bug fix to allow the load macro to handle counts properly.
Modified: 17 October 1979, CRD - changes due to audit and enlightenment.
Modified:	5 October 1979, CRD - change EAQ management to consider
	the EAQ to be four registers.
Modified: 20 September 1979, CRD - added code in base_man_load_pr
	to load addresses of unaligned character strings.
Modified: 19 September 1979, CRD - change register reservation to
	use logic planned for register optimizer.
Modified: 12 September 1979, CRD - change large address scheme to
	use full 32K addressing capability of 15 bit offset.
Modified: 5 September 1979, CRD - make changes to storage allocator
	for ANSI 77 character mode.
Modified: 28 August 1979, CRD - fix bug 233 (%options round and
	%options truncate in the same compilation don't work).
Modified: 24 August 1979, CRD - fix bug 232, in which descriptors
	are copied onto the stack incorrectly due to the data_type
	field of symbols created by the CG not being set.
Modified: 23 August 1979, CRD - move code to build runtime symbol
	table to separate external procedure, fort_make_symbol_table.
Modified:	6 August 1979, RAB - fix 230 (FATAL ERROR 418 in free_regs for large stackframes)
Modified: 25 July 1979, CRD - rearrange more simple macro
	instructions to have opcodes in the left half.
Modified: 24 July 1979, CRD - fix bug 229, in which parent chain
	of runtime symbol table was being built incorrectly.
Modified: 23 July 1979, CRD - compress the opcodes for certain
	if/unless macro pairs into a single opcode by using
	macro_cond_inst.if_test.
Modified: 23 July 1979, CRD - put op codes of simple macro
	instructions in the left half of the instruction word.
Modified: 16 July 1979, CRD - changes parallel to those made to
	ext_code_generator in fixing bug 225.
Modified:	11 June 1979, RAB fix bug 209 (temp space not being reused)
Modified:	2 May 1979, RAB - (1) Change scheme for addresses >= 16K to use ptr
	regs instead of xregs; (2) Change action of OPT_SUBSCRIPT to NEVER
	create temps  (xr_man now calls a subroutine of m_a to get the
	address of nonaddressable operands) fixing bug 203; and (3) Change 
	get_free_reg to get usage counts of temps by following input_to chain
	and adding ref_counts of array_refs.
Modified:	17 January 1979, RAB - to speed up reg management by using
	machine_state.value_in_xr.
Modified:	5 January 1979, RAB - to make get_free_reg use ref_counts
	in deciding which register to flush, and to improve the
	> 16k case for array elements.
Modified: 6 December 1978, PES - for %options and %global.
Modified:	4 December 1978, RAB - for option to initialize auto storage to zero
Modified: 01 December 1978, RAB - Improve handling of round before compare.
Modified: 30 November 1978, PES - Key rounding off of fortran_options.
Modified:	19 November 1978, RAB - Centralize control of rounding
	by use of eaq.rounded.
Modified: 25 October 1978, PES -Changes for larger common blocks and arrays.
Modified:	11 October 1978, RAB - Fix bug 184 in which bad code is
	produced if an increment causes an address to cross a 16K
	boundary.  Also checks were put in for invalid data_type
	and operand_type fields and for uninitialized
	array_ref nodes.
Modified: 12 Sept 1978, PES - Move PS from static to automatic storage, to fix
	bug 182 in which fortran_io_ fails in the event of a segment loop,
	e.g. a subr in segment <a> calls a subr in segment <b>, which in
	turn calls another subr in segment <a>.
Modified: 06 Sept 1978, PES - Fix (masked) bug which might cause a register not
	to be reloaded before being used as an index, even if the value has
	been changed in storage.  This bug is in a currently unused block of
	code, but future changes could cause it to surface.
Modified: 27 July 1978, PES - Fix bug in handling of nested subscripts; fix bug
	in setting of symbol.simple for parameters.
Modified: 23 June 1978, DSL - Fixes generated by audit. Allocate ps as first
	thing in static in order to prevent problems if ps overlaps 16K
	boundary; some speed up changes; add machine state ref count
	(temporary.ms_ref_count) to handle temp node's second purpose, place
	holding in machine states; temporary's storage is freed when normal
	ref count is zero; temporary is only freed if ms_ref_count is zero
	too. Fix ref count bug in emit_eis; set symbol.element_size for
	descriptors generated by code generator.

	* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Rewritten starting 9 November 1977 by David S. Levin to create the optimizing code generator.

	* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Modified: 4 November 1977, DSL - Use maximum length when allocating common
	blocks.
Modified:	31 October 1977, RAB - Fix bug 129 where large virtual origins get
	bad code. Also, implement DL modification for negative constants.
Modified:	6 October 1977, DSL - Fix bug in subscripting code for the following:
	array i(3,3),j(3); i(j(l), l) = m(l)
Modified: 30 August 1977, DSL - coordinated change with listing generator to
	mark entry "data" words; base_man_load_pr_value fails to set reloc
	info and symbol info; multiply macro does not check for product >
	bias. Fix "load" to set proper ref count for complex vars.
	NOTE -- in this compilation the value of bias changed from 65536 to
	131072.
Modified: 21 July 1977, DSL - fix bug in itp list reloc info.
Modified: 14 July 1977 by DSL - 1) add new builtin, ps_area_ptr, for open and
	close; 2) add new macro load_pr_value, to load a pr with the contents
	of a location; 3) give relocation info for automatic storage template
	(bug fix).
Modified: 5 July 1977 by DSL - 1) fort_system_constants.incl.pl1 change;
	2) print message for multiple initialization of a single common
	block. 3)  Change if_ind and unless_ind to always work even if the
	eaq appears empty, fixing 108. THIS CONFLICTS WITH PUBLISHED
	DOCUMENTATION !!!
Modified: 26 May 1977 by DSL to always generate ERROR operand if an error
	occurs in a function frame; THIS CHANGE EXACTLY CONFLICTS WITH THE
	ORIGINAL DOCUMENTATION OF THE MACRO LANGUAGE. Refer to code for
	action 66 (error) for complete details.
Modified:	3 May 1977 by RAB for store macro.
Modified: 28 April 1977 by DSL - for new fort_system_constants.incl.pl1
Modified: 28 March 1977 by DSL for new stmnt label handling; interface with new
	node formats; recompile because of PL/I bug 1599 (in compile_link for
	A$B common names).
Modified: Feb 1977 by GDC for the optimizer
Modified: 31 Jan 1977 by DSL to allow type-3 links for common block names of
	the form a$.
Modified: 9 Dec 1976 by DSL to reference fort_version_info$version_name
Modified: 7 Dec 1976 by RAB to fix bugs in make_symbol_table
Modified:	22 Nov 1976 by RAB to add -profile
Modified:	November 1976 by David Levin to add make_symbol_table
Modified:	19 Oct 1976 by RAB for ok_lists and runtime symbol table hooks
Modified:	14 Oct 1976 by RAB for relocation bits
Modified:	7 Oct 1976 by RAB for optional descriptors
Modified:	30 Sept 1976 by RAB for object listings and local object, operand,
	and polish bases
Modified:	5 July 1976 by RAB for addrs >= 16K

END Modifications */

dcl  first_frame ptr;

dcl  next_free_ms ptr;				/* free chain of machine state nodes in the operand region */

dcl  cleanup_body_address fixed bin (18) unsigned;
dcl  alloc_auto_cleanup bit (1) aligned;

dcl  (c, lib_pt, p) ptr;

dcl  (n, text_pos, link_pos, def_pos, sym_pos, begin_links, linkrel, defrel, symrel, lib_pos, last_pos, profile_start,
     profile_pos) fixed bin (18);

dcl  (begin_external_list, end_external_list) fixed bin (18);

dcl  begin_forward_refs fixed bin (18);

dcl  (first_namelist, last_namelist) fixed bin (18);
dcl  (first_header, last_header) ptr init (null ());	/* header chain */

dcl  (link_base, def_base, lib_list_ptr, a_base, parm_desc_ptrsp) ptr;
dcl  (link_reloc_base, def_reloc_base, lib_reloc_ptr) ptr;


dcl  free (2:4) ptr;				/* free chains of optimizer nodes */
dcl  freei ptr;					/* .. */

dcl  (generate_long_profile, generate_profile, generate_symtab, assembly_list, do_rounding, init_auto_to_zero)
	bit (1) aligned;

dcl  builtins (0:11) fixed bin (18);			/* format: off */
/* builtins are:
   0:  zero	     integer zero constant
   1:  one	     integer one constant
   2:  ps		     symbol for fortran I/O arglist
   3:  auto_template     Initialization template for auto storage
   4:  auto_overlay	     array reference overlay of automatic storage
   5:  null_ptr	     initialized to a null pointer value
   6:  null	     value of 0 as a null
   7:  two	     integer two constant
   8:  entry_info	     place to store quick proc info
	word 0 - Return address pointer (ITS).
	word 2 - Argument pointer (ITS).
	word 4 - Descriptor pointer (ITS).
	word 6 - Permanent Stack extension value (18-bit offset, 1 word).
   9:  star_symbol	     <*symbol>|0
  10:  ps_area_ptr	     symbol for ps.buffer_p
  11:  desc_overlay	     symbol for accessing a descriptor
*/
/* format: on */

dcl  image (amt) fixed bin (18) aligned based;
dcl  char_image char (4 * amt) aligned based;
dcl  (zero_def, last_def, seg_def) bit (18) aligned;
dcl  def_pool (20) fixed bin (18);

dcl  (amt, con, i, j, lib) fixed bin (18);

dcl  rands (0:operand_max_len - 1) fixed bin (18) aligned based (operand_base);

dcl  polish (0:polish_max_len - 1) fixed bin (18) aligned based (polish_base);

dcl  a_name (0:261119 - 2 * (number_of_lines + 1)) fixed bin (18) aligned based (a_base);

dcl  quad (0:quad_max_len - 1) fixed bin (18) aligned based (quadruple_base);

dcl  opt (0:opt_max_len - 1) fixed bin (35) aligned based (opt_base);

dcl  1 external_list based (polish_base) aligned,
       2 ext_ref (0:polish_max_len - 1) ptr unal;

dcl  last_auto_loc fixed bin (18);

dcl  linkage_pad fixed bin (18);			/* linkage pad of LA and VLA pointers */
dcl  first_auto_var_loc fixed bin (18);
dcl  free_temps (3) fixed bin (18);
dcl  auto_template fixed bin (18);

dcl  (hold_text_pos, hold_last_auto_loc) fixed bin (18);

dcl  1 text_halfs (0:262143) aligned based (object_base),
       2 left fixed bin (17) unal,
       2 right fixed bin (17) unal;

dcl  1 reloc_halfs (0:262143) aligned based (relocation_base),
       2 left bit (18) unal,
       2 right bit (18) unal;

dcl  reloc (0:3) bit (36) aligned based;

dcl  1 forward_refs (0:next_free_polish - 1) based (polish_base) aligned,
       2 instruction fixed bin (17) unal,
       2 operand fixed bin (18) unsigned unal;

dcl  vsegname char (32) varying defined (objectname);

dcl  1 saved_lib_list aligned based (lib_list_ptr),
       2 nlibs fixed bin (18),
       2 names (n refer (nlibs)),
         3 offset bit (18) unal,
         3 lng fixed bin (17) unal;

dcl  1 saved_lib_reloc_list aligned based (lib_reloc_ptr),
       2 mlibs fixed bin (18),
       2 names (n),
         3 reloc bit (18) unal,
         3 pad bit (18) unal;

dcl  1 parm_desc_ptrs aligned based (parm_desc_ptrsp),
       2 n_args fixed bin (18) unaligned unsigned,
       2 descriptor_relp (0 refer (parm_desc_ptrs.n_args)) fixed bin (18) unsigned unaligned;


dcl  segname char (32) aligned;

dcl  bases (0:7) bit (3) aligned internal static options (constant)
	initial ("0"b3, "4"b3, "1"b3, "2"b3, "3"b3, "5"b3, "7"b3, "6"b3);

dcl  (
     ap defined (bases (0)),
     ab defined (bases (2)),
     bp defined (bases (3)),
     bb defined (bases (4)),
     lp defined (bases (1)),
     lb defined (bases (5)),
     sp defined (bases (7)),
     sb defined (bases (6))
     ) bit (3) aligned;

dcl  which_base (0:7) fixed binary (3) internal static options (constant) initial (0, 2, 3, 4, 1, 5, 7, 6);

dcl  (
     INDEX init (1),
     BASE init (2)
     ) fixed bin int static options (constant);

dcl  (
     DU_mod initial ("03"b3),
     DL_mod initial ("07"b3),
     AL_mod initial ("05"b3),
     AU_mod initial ("01"b3),
     QL_mod initial ("06"b3),
     QU_mod initial ("02"b3),
     X0_mod initial ("10"b3),
     X1_mod initial ("11"b3),
     RI_mod initial ("20"b3),
     ITP_mod initial ("41"b3),
     FT2_mod initial ("46"b3)
     ) bit (6) aligned internal static options (constant);

dcl  01 descriptor_type_word (0:1, 7) aligned,
       02 flag bit (1) unaligned init ((14) ("1"b)),
       02 type fixed bin (6) unsigned unaligned
	  init (ft_integer_dtype, ft_real_dtype, ft_double_dtype, ft_complex_dtype, ft_logical_dtype, ft_char_dtype,
	  ft_external_dtype, ft_integer_dtype, ft_hex_real_dtype, ft_hex_double_dtype, ft_hex_complex_dtype,
	  ft_logical_dtype, ft_char_dtype, ft_external_dtype),
       02 packed bit (1) unaligned init ((14) ("0"b)),
       02 number_dims fixed bin (3) unaligned init ((14) 0),
       02 size fixed bin (23) unaligned init ((2) (35, 27, 63, 27, 1, 0, 0));
dcl  fptype fixed bin (1) init (bin (shared_globals.hfp, 1));

dcl  ext_base_on bit (36) aligned internal static options (constant) initial ("000000000100"b3);

dcl  max_address_offset fixed bin (14) static options (constant) init (16383);
dcl  max_linkage_size fixed binary (18) internal static options (constant) initial (131071);
dcl  max_stack_size fixed bin (18) int static init (62000) options (constant);

dcl  (abs, addr, addrel, bin, binary, bit, bool, byte, char, cleanup, copy,
     currentsize, divide, fixed, hbound, index, lbound, ltrim, max, min, mod,
     null, ptr, rank, rel, reverse, size, string, substr, unspec, verify) builtin;

%include linkdcl;
%include object_map;
%include relbts;
%include reloc_lower;
%include its;
%include profile_entry;
%include fortran_storage;
%include std_descriptor_types;

	/* initialize */

	cur_statement = -1;				/* Until a st node exists, there is no st text for errors */
	allocate_symbol_name = 0;			/* no names for symbols created by code generator */
	unspec (def_pool) = "0"b;
	first_frame = null;
	next_free_ms = null;
	auto_template = 0;
	unspec (builtins) = "0"b;
	text_pos, link_pos, def_pos, sym_pos, lib_pos, profile_start = 0;
	first_namelist, last_namelist = 0;
	free_temps (1), free_temps (2), free_temps (3) = 0;
	segname = vsegname;

	free (*) = shared_globals.free (*);
	freei = shared_globals.freei;

	assembly_list = shared_globals.options.list;
	if assembly_list
	then a_base = addr (source_list (number_of_lines + 2));
	else a_base = null;

	/* allocate all constants passed as arg */

	call alloc_constants (first_dw_constant, 2);
	call alloc_constants (first_word_constant, 1);
	call alloc_char_constants (first_char_constant);

	/* allocate storage */

	begin_external_list = next_free_polish;

	call assign_storage;

	/*  set up for interpreting */

	end_external_list = next_free_polish;

	/* Perform Register Usage Analysis and Global Register Allocation by
	   running a special pass of the interpreter. */

	call save_before_analysis;

	call interpreter ("1"b);

	call restore_after_analysis;

	if error_level >= unrecoverable_error
	then return;

	begin_forward_refs = next_free_polish;

	/* interpret for code generation */

	call interpreter ("0"b);

	last_pos = text_pos;

	/* allocate all constants  that need storage */

	text_pos = text_pos + mod (text_pos, 2);

	call alloc_char_constants (first_block_constant);
	call alloc_constants (first_dw_constant, 2);
	call alloc_constants (first_word_constant, 1);
	call alloc_char_constants (first_char_constant);

	/*  resolve all forward references */

	do i = begin_forward_refs to hbound (forward_refs, 1);
	     j = forward_refs (i).instruction;
	     text_halfs (j).left = text_halfs (j).left + addr (rands (forward_refs (i).operand)) -> label.location;
	     end;

	/* free up space so name_assign can use */

	next_free_polish = begin_forward_refs;

	/* allocate library structure */

	if first_lib_name ^= 0
	then do;
	     lib_pos = text_pos;
	     lib_list_ptr = addrel (object_base, lib_pos);
	     lib_reloc_ptr = addrel (relocation_base, lib_pos);
	     n = num_of_lib_names;
	     saved_lib_list.nlibs = n;
	     text_pos = text_pos + size (saved_lib_list);

	     i = 1;
	     do lib = first_lib_name repeat lib_pt -> library.next_library_node while (lib > 0);
		lib_pt = addr (rands (lib));
		c = addr (rands (lib_pt -> library.character_operand));
		saved_lib_list.offset (i) = unspec (c -> char_constant.location);
		saved_lib_list.lng (i) = c -> char_constant.length;
		saved_lib_reloc_list.reloc (i) = rc_t;
		i = i + 1;
		end;
	     end;

	/* initialize static */

	linkrel = divide (text_pos + 1, 2, 17, 0) * 2;
	link_base = addrel (object_base, linkrel);
	link_reloc_base = addrel (relocation_base, linkrel);

	call initialize_static;

	/* generate links */

	defrel = link_pos + linkrel;
	def_base = addrel (object_base, defrel);
	def_reloc_base = addrel (relocation_base, defrel);

	call init_linkage;
	call gen_linkage;

	/* generate entry definitions */

	call gen_entry_defs;

	/* generate library definition */

	if lib_pos ^= 0
	then call generate_definition ("library_list_", 0, bit (lib_pos, 18));

	/* free up space for make symbol_table that is no longer used */

	next_free_polish = begin_forward_refs;

	/* generate symbol section */

	symrel = divide (defrel + def_pos + 1, 2, 17, 0) * 2;

	symtab_parameters.link_base_ptr = link_base;
	symtab_parameters.link_reloc_base_ptr = link_reloc_base;
	symtab_parameters.def_reloc_base_ptr = def_reloc_base;
	symtab_parameters.current_text_offset = text_pos;
	symtab_parameters.current_def_offset = def_pos;
	symtab_parameters.current_link_offset = link_pos;
	symtab_parameters.final_text_offset = last_pos;
	symtab_parameters.profile_offset = profile_start;
	symtab_parameters.star_symbol_link = builtins (9);
	symtab_parameters.first_namelist_symbol = first_namelist;

	call fort_make_symbol_section (shared_struc_ptr, cg_struc_ptr, addr (symtab_parameters), symrel, sym_pos);

	/* finish up the object segment by filling in the
	   standard object map */

	n = divide (symrel + sym_pos + 1, 2, 17, 0) * 2;
	p = addrel (object_base, n);

	p -> object_map.decl_vers = object_map_version_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);
	p -> object_map.static_offset = bit (fixed (linkrel + size (virgin_linkage_header), 18), 18);
	p -> object_map.static_length = bit (fixed (begin_links - size (virgin_linkage_header), 18), 18);
	p -> object_map.symbol_offset = bit (symrel, 18);
	p -> object_map.symbol_length = bit (sym_pos, 18);

	p -> object_map.format.separate_static = "0"b;

	p -> object_map.format.relocatable = shared_globals.options.relocatable;

	p -> object_map.format.procedure, p -> object_map.format.standard = "1"b;

	addrel (p, size (p -> object_map)) -> map_ptr = bit (n, 18);

	/* set next_free_object  and  return */

	next_free_object = n + size (p -> object_map) + 1;
	return;

get_subr_options:
     procedure (cs);

	/* Sets various global flags to correspond to the options in
	   effect for the given program unit. */

dcl  cs pointer;					/* Pointer to subprogram node */

	do_rounding = cs -> subprogram.options.do_rounding;
	init_auto_to_zero = cs -> subprogram.options.auto_zero;
	generate_profile = cs -> subprogram.options.profile;
	generate_long_profile = cs -> subprogram.options.long_profile;
	generate_symtab = cs -> subprogram.options.table | shared_globals.options.namelist_used;

	return;

     end get_subr_options;

/**** CONSTANT ALLOCATION ****/

alloc_constants:
     procedure (start, amt);

	/* Allocates constants in the text section */

dcl  (amt, n) fixed binary;
dcl  start fixed binary (18);

	n = amt;

	do con = start repeat c -> constant.next_constant while (con > 0);
	     c = addr (rands (con));
	     if ^c -> constant.allocated
	     then if c -> constant.allocate | c -> constant.passed_as_arg
		then do;
		     c -> constant.location = text_pos;
		     addrel (object_base, text_pos) -> image = addr (c -> constant.value) -> image;
		     text_pos = text_pos + n;
		     c -> constant.allocated = "1"b;
		     end;
	     end;

     end alloc_constants;

alloc_char_constants:
     procedure (start);

	/* Allocates character constants in the text section */

dcl  start fixed binary (18);
dcl  relocate_itp bit (1) aligned;

	relocate_itp = start = first_block_constant;

	do con = start repeat c -> char_constant.next_constant while (con > 0);
	     c = addr (rands (con));
	     if ^c -> char_constant.allocated
	     then if c -> char_constant.allocate | c -> char_constant.passed_as_arg
		then do;
		     if c -> char_constant.length = chars_per_dw
						/* a double word constant */
		     then text_pos = text_pos + mod (text_pos, 2);
						/* get even address */

		     amt = divide (c -> char_constant.length + chars_per_word - 1, chars_per_word, 17, 0);
		     c -> char_constant.location = text_pos;
		     addrel (object_base, text_pos) -> char_image = c -> char_constant.value;
		     if relocate_itp
		     then call relocate_itp_list;
		     text_pos = text_pos + amt;
		     c -> char_constant.allocated = "1"b;
		     end;
	     end;

     end alloc_char_constants;

relocate_itp_list:
     procedure ();

	/* Generates relocation bits for an itp argument list */

dcl  q pointer;
dcl  rscan fixed binary (18);

	do rscan = text_pos + 2 to text_pos + amt - 1 by 2;
	     q = addrel (object_base, rscan);

	     if q -> itp.itp_mod = ITP_mod		/* ITP word */
	     then if q -> itp.pr_no = lp
		then reloc_halfs (rscan + 1).left = rc_is18;
		else ;
	     else if q -> itp.itp_mod = "00"b3		/* ordinary indirect word */
	     then reloc_halfs (rscan).left = rc_t;
	     end;

     end relocate_itp_list;

assign_address_offset:
     procedure (p, inc, size, units);

	/* This procedure sets node.address.offset and node.location
	   from node.location and the offset increment inc. */

dcl  p pointer;					/* Node pointer */
dcl  inc fixed binary (18);				/* Offset increment */
dcl  size fixed binary (18);				/* Size of datum */
dcl  units fixed binary (3);				/* Units of size */

	call set_address_offset ((p), (p -> node.location + inc), (size), (units));

     end assign_address_offset;

set_address_offset:
     procedure (p, off, size, units);

	/* Sets p -> node.address.offset and p -> node.location to
	   the correct values for the offset off. */

dcl  p pointer;
dcl  (off, loc, offset) fixed binary (18);
dcl  size fixed binary (18);
dcl  units fixed binary (3);

	offset = off;

	if abs (offset) + get_size_in_words ((size), (units)) - 1 >= 16384
	then do;
	     loc = offset;
	     p -> node.large_address = "1"b;
	     p -> node.is_addressable = "0"b;
	     offset = mod (offset + 16384, 32768) - 16384;
	     p -> node.location = loc - offset;
	     end;

	p -> node.address.offset = offset;

     end set_address_offset;

get_size_in_words:
     procedure (size, units) returns (fixed binary (18));

	/* Converts a size in the specified units to word units */

dcl  size fixed binary (18);
dcl  (units, u) fixed binary (3);

dcl  factor (0:3) fixed binary (18) internal static options (constant) initial (1, 36, 4, 2);

	u = mod (units, 4);

	if u = word_units
	then return (size);				/* For speed */

	return (divide (size + factor (u) - 1, factor (u), 18, 0));

     end get_size_in_words;

get_size_in_bits:
     procedure (size, units) returns (fixed binary (18));

	/* Converts a size in the specified units to bits */

dcl  size fixed binary (18);
dcl  (units, u) fixed binary (3);

dcl  factor (0:3) fixed binary (18) internal static options (constant) initial (36, 1, 9, 18);

	u = mod (units, 4);
	return (size * factor (u));

     end get_size_in_bits;

save_before_analysis:
     procedure ();

	/* Saves vars neded for code generation. */

	hold_last_auto_loc = last_auto_loc;
	hold_text_pos = text_pos;

     end save_before_analysis;

restore_after_analysis:
     procedure ();

dcl  (cs, s) pointer;
dcl  sym fixed binary (18);

	/* Restores labels and entry points */

	do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));
	     s -> symbol.allocated = "0"b;
	     if s -> symbol.initial ^= 0
	     then addr (rands (s -> symbol.initial)) -> label.allocated = "0"b;
	     end;

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));
	     do sym = cs -> subprogram.first_label repeat s -> label.next_label while (sym > 0);
		s = addr (rands (sym));
		s -> label.allocated = "0"b;
		end;
	     end;

	/* Restore saved values. */

	if generate_long_profile
	then profile_pos = size (long_profile_header);
	else profile_pos = profile_start;
	text_pos = hold_text_pos;
	last_auto_loc = hold_last_auto_loc;

     end restore_after_analysis;

assign_storage:
     procedure ();

	/* STORAGE ALLOCATOR

	   subprogram.storage_info is organized into 17 buckets to aid in
	   storage allocation.   The buckets are assigned as follows:

	   1	auto	double	init
	   2	auto	single	init
	   3	auto	double
	   4	auto	single
	   5	static	double	init
	   6	static	single	init
	   7	static	double
	   8	static	single
	   9	common & external constants
	   10	parameters
	   11	others
	   12	not allocated
	   13	Large Array Automatic
	   14	Large Array Static
	   15	Very Large Array Automatic
	   16	Very Large Array Static
	   17	Very Large Array Common
	*/

dcl  (cs, h, os, clp, psp, psap, s, ssp) pointer;
dcl  (hdr, sym, i, vsize, other_sym) fixed binary (18);
dcl  loc fixed binary (18);
dcl  not_found bit (1) aligned;
dcl  alloc_ps bit (1) aligned;

%include relocation_bits;

	/* 78.06.12 The parse now sets the following fields formerly set by the storage allocator.
	   Note that these fields are only set for those variables that need them:

	   symbol.data_type
	   symbol.element_size
	   symbol.auto		} One of these is set but only if the symbol
	   symbol.static		} is a variable without a storage class
	*/

	last_auto_loc = first_auto_loc;

	/* link_pos is the current offset of linkage entries from the end of static
	   for the duration of external assignement.  Then it transforms to be the
	   current address in the linkage section of relocation of static.
	   linkage_pad is the space which is occupied by the
	   LA and VLA base pointers for static variables.  linkage_pad delineates a
	   section which is within static, but which is not filled with normal variables. */

	linkage_pad = 0;

	Area_create_first, Area_init_first = -1;	/* flag off */

	alloc_ps, alloc_auto_cleanup = "0"b;

	/* setup for cleanup of VLA common processing lists */

	on cleanup call cleanup_VLA_common;

	/* allocate entry points */

	do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));

	     s -> symbol.operand_type = entry_type;
	     s -> symbol.hash_chain = 0;
	     s -> symbol.is_addressable = "1"b;
	     s -> symbol.reloc = rc_t;

	     /* associate a quick entry point with a subprogram entry pt */

	     if s -> symbol.name ^= main_entry_point_name
	     then s -> symbol.initial = create_rel_constant (null);
	     end;

	/* do allocation for each subprogram */

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));
	     call get_subr_options (cs);

	     /* see if ps needed */

	     alloc_ps = alloc_ps | cs -> subprogram.need_PS;

	     /* allocate labels */

	     do sym = cs -> subprogram.first_label repeat s -> label.next_label while (sym > 0);
		s = addr (rands (sym));
		s -> label.is_addressable = "1"b;
		s -> label.reloc = rc_t;
		end;

	     /* initialize storage info */

	     unspec (cs -> subprogram.storage_info) = "0"b;

	     /* Allocate vars in LA chain */

	     hdr = cs -> subprogram.LA_chain;
	     do while (hdr > 0);
		h = addr (rands (hdr));
		if h -> header.allocate
		then do;
		     h -> header.needs_pointer = "1"b;
		     unspec (h -> header.address) = ext_base_on;
		     h -> header.allocated = "1"b;

		     call alloc_members;

		     h -> header.reloc = RI_mod;

		     /* Allocate the unpacked pointer storage in either static or automatic */

		     if h -> header.static
		     then do;
			i = 14;			/* LA static */
			if mod (linkage_pad + size (virgin_linkage_header), 2) ^= 0
			then linkage_pad = linkage_pad + 1;
			h -> header.location = linkage_pad + size (virgin_linkage_header);
			h -> header.base = lp;
			linkage_pad = linkage_pad + 2;/* assign double word */
			end;
		     else do;
			i = 13;			/* LA auto */
			if mod (last_auto_loc, 2) ^= 0
			then last_auto_loc = last_auto_loc + 1;
						/* even word aligned */

			h -> header.location = last_auto_loc;
			h -> header.base = sp;
			last_auto_loc = last_auto_loc + 2;
			end;


		     call create_storage_entry (h);

		     /* relocate members of Large Arrays */

		     do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
			s = addr (rands (sym));
			call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units));
			end;

		     if h -> header.initialed
		     then call list_initialize (addrel (object_base, text_pos), hdr, text_pos);

		     /* thread the block on the LA lists */

		     if cs -> subprogram.storage_info.last (i) = 0
		     then cs -> subprogram.storage_info.first (i) = hdr;
		     else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr;
		     cs -> subprogram.storage_info.last (i) = hdr;

		     end;

		/* on to the next header */

		hdr = h -> header.next_header;
		h -> header.next_header = 0;
		end;

	     /* Allocate vars in VLA chain */

	     hdr = cs -> subprogram.VLA_chain;
	     do while (hdr > 0);
		h = addr (rands (hdr));
		if h -> header.allocate
		then do;
		     h -> header.allocated = "1"b;
		     h -> header.needs_pointer = "1"b;
		     unspec (h -> header.address) = ext_base_on;
		     if h -> header.automatic
		     then h -> header.address.base = sp;
		     else do;
			h -> header.address.base = lp;
			h -> header.reloc = rc_is15;
			end;

		     call alloc_members;

		     /*  Allocate the base addressor.  */

		     s = addr (rands (h -> header.VLA_base_addressor));
		     s -> symbol.is_addressable = "1"b;
		     s -> symbol.allocated = "1"b;
		     s -> symbol.address = h -> header.address;
		     s -> symbol.reloc = h -> header.reloc;

		     if h -> header.in_common
		     then do;
			i = 17;			/* VLA common */
			call note_VLA_common (h);
			end;
		     else do;

			/* Allocate the addressor storage in either static or automatic */

			if h -> header.static
			then do;
			     i = 16;		/* VLA static */
			     h -> header.location, h -> header.address.offset =
				linkage_pad + size (virgin_linkage_header);
			     linkage_pad = linkage_pad + 1;
						/* space for base addressor */
			     end;
			else do;
			     i = 15;		/* VLA auto */

			     h -> header.location, h -> header.address.offset = last_auto_loc;
			     last_auto_loc = last_auto_loc + 1;
						/* space for base addressor */
			     end;
			call set_address_offset (s, (h -> header.location), 1, word_units);
			call create_storage_entry (h);
			if h -> header.initialed
			then call list_initialize (addrel (object_base, text_pos), hdr, text_pos);
			end;

		     /* thread the block on the VLA lists */

		     if cs -> subprogram.storage_info.last (i) = 0
		     then cs -> subprogram.storage_info.first (i) = hdr;
		     else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr;
		     cs -> subprogram.storage_info.last (i) = hdr;

		     end;

		/* on to the next header */

		hdr = h -> header.next_header;
		h -> header.next_header = 0;
		end;

	     /* Allocate vars in common chain */

	     hdr = cs -> subprogram.common_chain;
	     do while (hdr > 0);
		h = addr (rands (hdr));
		if h -> header.allocate
		then do;
		     h -> header.needs_pointer = "1"b;
		     unspec (h -> header.address) = ext_base_on;
		     h -> header.allocated = "1"b;

		     call alloc_members;

		     h -> header.location = alloc_external (h);

		     /* thread the block on the linkage list */

		     if cs -> subprogram.storage_info.last (9) = 0
		     then cs -> subprogram.storage_info.first (9) = hdr;
		     else addr (rands (cs -> subprogram.storage_info.last (9))) -> header.next_header = hdr;
		     cs -> subprogram.storage_info.last (9) = hdr;

		     end;

		/* on to the next header */

		hdr = h -> header.next_header;
		h -> header.next_header = 0;
		end;

	     /* Allocate other equivalence blocks */

	     hdr = cs -> subprogram.equiv_chain;
	     do while (hdr > 0);
		h = addr (rands (hdr));
		if h -> header.allocate
		then do;

		     /* get subclass of equivalence group */

		     if h -> header.even
		     then i = 1;
		     else i = 2;
		     if ^h -> header.initialed
		     then i = i + 2;
		     if h -> header.static
		     then i = i + 4;

		     /* allocate */

		     if h -> header.odd
		     then if mod (cs -> subprogram.next_loc (i), 2) = 0
			then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + 1;

		     loc = cs -> subprogram.next_loc (i);
		     cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + h -> header.length;
		     if mod (i, 2) ^= 0
		     then cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + mod (h -> header.length, 2);


		     unspec (h -> header.address) = ext_base_on;
		     h -> header.location = loc;
		     if h -> header.static
		     then do;
			h -> header.base = lp;
			h -> header.reloc = rc_is15;
			end;
		     else h -> header.base = sp;
		     h -> header.is_addressable = "1"b;
		     h -> header.allocated = "1"b;

		     /* allocate elements of equiv chain */

		     call alloc_members;
		     end;

		else i = 12;

		/* thread the header in */

		if cs -> subprogram.storage_info.last (i) = 0
		then cs -> subprogram.storage_info.first (i) = hdr;
		else addr (rands (cs -> subprogram.storage_info.last (i))) -> header.next_header = hdr;
		cs -> subprogram.storage_info.last (i) = hdr;

		hdr = h -> header.next_header;
		h -> header.next_header = 0;
		end;

	     /* Allocate non-equivalenced symbols */

	     sym = cs -> subprogram.first_symbol;
	     do while (sym > 0);
		s = addr (rands (sym));
		if ^s -> symbol.allocated
		then do;
		     if s -> symbol.parameter
		     then s -> symbol.hash_chain = 0;	/* Required by 'make_symbol_descriptor'. */

		     /* Fix up request for 'PARAMETER' variables fully probe-able by allocating if
		        we want a symbol table. */

		     if s -> symbol.named_constant & cs -> subprogram.options.table
		     then do;
			s -> symbol.allocate = "1"b;
			addr (rands (s -> symbol.initial)) -> node.allocate = "1"b;
			end;

		     if s -> symbol.allocate
		     then do;
			unspec (s -> symbol.address) = "0"b;

			s -> symbol.hash_chain = 0;

			if s -> symbol.stmnt_func
			then do;
			     s -> symbol.operand_type = statement_function;
			     i = 11;
			     end;
			else if s -> symbol.builtin
			then do;
			     s -> symbol.operand_type = bif;
			     i = 11;
			     end;
			else if s -> symbol.named_constant
			then i = 11;
			else if s -> symbol.namelist
			then do;
			     s -> label.location = text_pos;
			     s -> symbol.is_addressable = "1"b;
			     s -> symbol.reloc = rc_t;

			     vsize = divide (polish (s -> symbol.initial) + 4, 2, 17, 0);
			     text_pos = text_pos + vsize;

			     if last_namelist = 0
			     then first_namelist = sym;
			     else addr (rands (last_namelist)) -> symbol.next_member = sym;
			     last_namelist = sym;

			     i = 11;
			     end;
			else if s -> symbol.parameter | s -> symbol.stack_indirect
			then do;
			     i = 10;
			     if s -> symbol.external
			     then s -> symbol.operand_type = external;
			     else s -> symbol.operand_type = variable_type;

			     if s -> symbol.VLA
			     then do;

				/*  Allocate the base addressor of the VLA.  */
				other_sym = addr (rands (s -> symbol.dimension)) -> dimension.VLA_base_addressor;
				os = addr (rands (other_sym));
				os -> symbol.is_addressable = "1"b;
				os -> symbol.allocated = "1"b;
				unspec (os -> symbol.address) = ext_base_on;
				os -> symbol.address.base = sp;
				os -> symbol.address.offset = last_auto_loc;
				if ^VLA_is_256K
				then last_auto_loc = last_auto_loc + 1;

				/*  Allocate the packed ptr to the VLA.  */
				if last_auto_loc > max_address_offset
				then call print_message (414, "The location of a VLA parameter base pointer",
					max_address_offset - bias);
				s -> symbol.needs_pointer = "1"b;
				s -> symbol.address.base = sp;
				s -> symbol.address.offset = last_auto_loc;
				last_auto_loc = last_auto_loc + 1;
				s -> symbol.location = s -> symbol.location * 2;
				end;

			     else if s -> symbol.stack_indirect
			     then do;

				/* multiple positions -- we need an auto
				   ptr to point at the parameter */

				if mod (last_auto_loc, 2) ^= 0
				then last_auto_loc = last_auto_loc + 1;
						/* even word aligned */
				s -> symbol.location = last_auto_loc;
				last_auto_loc = last_auto_loc + 2;
				if last_auto_loc > max_stack_size
				then call print_message (414,
					"in making multiple position parameter temporary the stack frame",
					max_stack_size - bias);
				end;

			     else			/*  the actual ptr location is twice the parameter number */
				s -> symbol.location = s -> symbol.location * 2;

			     /* set up address field */

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

			     if s -> symbol.dimensioned
			     then do;
				s -> symbol.needs_pointer = "1"b;
				vsize = get_array_size (s);
				end;
			     else if s -> symbol.data_type = cmpx_mode
			     then s -> symbol.needs_pointer = "1"b;
			     else if s -> symbol.data_type = char_mode
			     then do;
				s -> symbol.needs_pointer = "1"b;
				if s -> symbol.variable_extents | s -> symbol.star_extents
				then if s -> symbol.needs_descriptors | s -> symbol.passed_as_arg
					| s -> symbol.put_in_symtab | shared_globals.options.table
				     then vsize = make_symbol_descriptor (fixed (rel (s), 18));
				end;
			     else do;
				if ^s -> symbol.VLA
				then do;
				     s -> symbol.address.offset = s -> symbol.location;
				     s -> symbol.tag = RI_mod;
						/* RI */
				     end;
				else s -> symbol.tag = rc_a;
						/* stack */
				if s -> symbol.stack_indirect
				then do;
				     s -> symbol.address.base = sp;
				     s -> symbol.is_addressable = "1"b;
				     end;
				end;
			     end;
			else if s -> symbol.external
			then do;

			     /* function or subroutine reference */

			     s -> symbol.operand_type = external;

			     /* check if name is on subprogram in this compilation */

			     not_found = "1"b;
			     other_sym = first_entry_name;
			     do while (other_sym > 0 & not_found);
				os = addr (rands (other_sym));
				if s -> symbol.name = os -> symbol.name
				then not_found = "0"b;
				else other_sym = os -> symbol.next_symbol;
				end;

			     if not_found
			     then do;
				s -> symbol.ext_base = "1"b;
				s -> symbol.base = lp;
				s -> symbol.location = alloc_external (s);
				s -> symbol.tag = RI_mod;
						/* RI */
				s -> symbol.reloc = rc_lp15;
				s -> symbol.is_addressable = "1"b;
				end;

			     else do;
				s -> symbol.is_addressable = "0"b;
				s -> symbol.reloc = rc_t;
				s -> symbol.initial = other_sym;
				s -> symbol.needs_descriptors = os -> symbol.needs_descriptors;
				end;

			     i = 9;
			     end;
			else do;

			     /* data type and storage class (must be auto or static) assigned by the parse */

			     s -> symbol.operand_type = variable_type;

			     if s -> symbol.dimensioned
			     then vsize = get_array_size (s);
			     else vsize = get_size_in_words ((s -> symbol.element_size), (s -> symbol.units));

			     /* get subclass */

			     if data_type_size (s -> symbol.data_type) = 2
			     then i = 1;
			     else i = 2;
			     if ^s -> symbol.initialed
			     then i = i + 2;
			     if s -> symbol.static
			     then i = i + 4;

			     /* allocate */

			     loc = cs -> subprogram.next_loc (i);
			     cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + vsize;

			     /* set up addressing */

			     if s -> symbol.static
			     then do;
				s -> symbol.base = lp;
				s -> symbol.reloc = rc_is15;
				end;
			     else s -> symbol.base = sp;
			     s -> symbol.location = loc;
			     s -> symbol.ext_base = "1"b;

			     s -> symbol.is_addressable = "1"b;
			     end;

			/* set allocated bit */

			s -> symbol.allocated = "1"b;
			end;

		     else i = 12;

		     /* thread symbol into new list */

		     if cs -> subprogram.storage_info.last (i) = 0
		     then cs -> subprogram.storage_info.first (i) = sym;
		     else addr (rands (cs -> subprogram.storage_info.last (i))) -> symbol.next_symbol = sym;
		     cs -> subprogram.storage_info.last (i) = sym;
		     end;

		sym = s -> symbol.next_symbol;
		s -> symbol.next_symbol = 0;
		end;

	     end;

	/* Allocate <*symbol>|0 link, if necessary */

	if generate_symtab
	then do;

	     /* compile_link depends on symbol.name_length being 0 */

	     builtins (9) = create_node (symbol_node, size (symbol));
	     ssp = addr (rands (builtins (9)));
	     ssp -> symbol.operand_type = dummy;
	     ssp -> symbol.by_compiler = "1"b;
	     ssp -> symbol.external, ssp -> symbol.allocate, ssp -> symbol.allocated, ssp -> symbol.is_addressable,
		ssp -> symbol.ext_base = "1"b;
	     ssp -> symbol.base = lp;
	     ssp -> symbol.tag = RI_mod;		/* RI */
	     ssp -> symbol.reloc = rc_lp15;
	     ssp -> symbol.location = alloc_external (ssp);
	     end;
	else builtins (9) = 0;

	/* If a ps is needed, allocate it first to prevent problems with 16K boundary.
	   ps must be in automatic storage because namelist, err=, and end= require current stack
	   ptr to be in ps at all times, even after return from a->b->a segment flow.  */

	if alloc_ps
	then do;
	     builtins (2) = create_node (symbol_node, size (symbol));
	     psp = addr (rands (builtins (2)));
	     psp -> symbol.operand_type = dummy;
	     psp -> symbol.by_compiler = "1"b;
	     psp -> symbol.automatic, psp -> symbol.allocate, psp -> symbol.allocated, psp -> symbol.is_addressable,
		psp -> symbol.ext_base = "1"b;
	     psp -> symbol.base = sp;
	     psp -> symbol.reloc = rc_a;
	     last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2;
						/* EVEN WORD NEEDED */
	     call assign_address_offset (psp, last_auto_loc, 48, word_units);
	     last_auto_loc = last_auto_loc + 48;
	     if last_auto_loc > max_stack_size
	     then call print_message (414, "in making parameter storage for IO the stack frame", max_stack_size - bias);

	     /*	Build a symbol that overlays the PS at the field buffer_p (offset 20b3). This symbol
	        is used to load the value of this pointer by the object segment. */

	     builtins (10) = create_node (symbol_node, size (symbol));
	     psap = addr (rands (builtins (10)));
	     psap -> symbol = psp -> symbol;		/* use PS symbol as template to create this one */
	     psap -> symbol.address.offset = psap -> symbol.address.offset + 16;
						/* = 20b3 */
	     end;

	else builtins (2), builtins (10) = 0;

	/* If a cleanup body is needed, allocate it.  */

	if alloc_auto_cleanup
	then do;
	     cleanup_body_address = create_node (symbol_node, size (symbol));
	     clp = addr (rands (cleanup_body_address));
	     clp -> symbol.operand_type = dummy;
	     clp -> symbol.by_compiler = "1"b;
	     clp -> symbol.automatic, clp -> symbol.allocate, clp -> symbol.allocated, clp -> symbol.is_addressable,
		clp -> symbol.ext_base = "1"b;
	     clp -> symbol.base = sp;
	     clp -> symbol.reloc = rc_a;
	     last_auto_loc = divide (last_auto_loc + 1, 2, 17, 0) * 2;
						/* EVEN WORD NEEDED */
	     call assign_address_offset (clp, last_auto_loc, 8, word_units);
	     cleanup_body_address = last_auto_loc;
	     last_auto_loc = last_auto_loc + 8;
	     if last_auto_loc > max_stack_size
	     then call print_message (414, "in making cleanup body the stack frame", max_stack_size - bias);
	     end;
	else cleanup_body_address = 0;

	/* Allocate space for all VLA COMMON */

	call allocate_VLA_common;

	/* All subprograms done, relocate auto & static items */

	link_pos = divide (size (virgin_linkage_header) + linkage_pad + 1, 2, 18, 0) * 2;
	first_auto_var_loc = last_auto_loc;

	/* now relocate all other static and auto items */

	call relocate (1, last_auto_loc, max_stack_size, "stack frame");
	call relocate (5, link_pos, max_linkage_size, "linkage section");

	/* allocate profile space, if -profile */

	if generate_profile
	then do;
	     profile_start, profile_pos = link_pos;
	     if generate_long_profile
	     then do;
		profile_pos = size (long_profile_header);
		link_pos = link_pos + size (long_profile_header) + size (long_profile_entry) * (profile_size + 1);
		end;
	     else link_pos = link_pos + size (profile_entry) * (profile_size + 1);

	     link_pos = link_pos + mod (link_pos, 2);
	     if link_pos > max_linkage_size
	     then call print_message (414, "when allocating PROFILE information the linkage section",
		     char (max_linkage_size));
	     end;

	/* Finally, relocate common + external refs */

	begin_links = link_pos;

	do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0);
	     cs = addr (rands (cur_subprogram));
	     call get_subr_options (cs);

	     /* relocate external refs for VLA common */

	     do hdr = cs -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));
		h -> node.location = h -> node.location + link_pos;
		end;

	     /* relocate common and external */
	     do hdr = cs -> subprogram.storage_info.first (9) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));

		if h -> node.node_type = header_node
		then do;
		     h -> node.location = h -> node.location + link_pos;
		     do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
			s = addr (rands (sym));
			call assign_address_offset (s, 0, (s -> symbol.element_size), (s -> symbol.units));
			end;
		     end;

		else do;
		     if h -> symbol.initial = 0
		     then call assign_address_offset (h, link_pos, 2, word_units);
		     else h -> symbol.allocated = "0"b;
		     end;
		end;


	     end;


	/* Relocate the link pointer in the 'create_entry' for common. */

	call VLA_reloc_common_link;


	if generate_symtab
	then call assign_address_offset (ssp, link_pos, 2, word_units);

	link_pos = link_pos + (next_free_polish - begin_external_list) - ((next_free_polish - begin_external_list) / 3);
						/* i.e., two words per link */
	if link_pos > max_linkage_size
	then call print_message (414,
		"after allocating SYMTAB space for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name
		|| " the linkage section", char (max_linkage_size));

	return;

alloc_external:
     procedure (pt) returns (fixed binary (18));

	/* Searches the external_list to see if a common block or
	   external reference has already been allocated before
	   allocating a new link to it.

	   The current implementation for the external list consists of
	   three items per external variable. The first item is a pointer
	   to a symbol node (for external entry points) or a pointer to
	   a header node (for common blocks). The second item is only
	   used for common blocks and specifies the (maximum) length for
	   the common block.  The third item is also only used for common
	   block and indicates the units (words or characters of the
	   maximum length. */

dcl  (p, pt) pointer;
dcl  loc fixed binary (18);
dcl  i fixed binary (18);
dcl  ceil builtin;
dcl  header_length fixed binary (24);

	p = pt;

	if p -> node.node_type = symbol_node
	then do i = begin_external_list to next_free_polish - 1 by 3;
		if ext_ref (i) -> node.node_type = symbol_node
		then if p -> symbol.name = ext_ref (i) -> symbol.name
		     then return (ext_ref (i) -> symbol.location);
		end;

	else do i = begin_external_list to next_free_polish - 1 by 3;
		if ext_ref (i) -> node.node_type = header_node
		then if p -> header.block_name = ext_ref (i) -> header.block_name
		     then do;
			loc = ext_ref (i) -> header.location;

			if p -> header.block_name = blank_common_name
			then do;
			     if p -> header.units = polish (i + 2)
			     then header_length = p -> header.length;
			     else if polish (i + 2) = word_units
			     then header_length = ceil (p -> header.length / 4);
			     else header_length = p -> header.length * 4;
						/* change to character units */
			     if header_length > polish (i + 1)
						/* current max length */
			     then polish (i + 1) = header_length;
						/* update max length for unlabelled common */
			     end;
			else do;
			     if p -> header.units = polish (i + 2)
			     then header_length = p -> header.length;
			     else if polish (i + 2) = word_units
			     then header_length = ceil (p -> header.length / 4);
			     else header_length = p -> header.length * 4;
						/* change to character units */
			     if header_length > polish (i + 1)
						/* current max length for block */
			     then do;
				polish (i + 1) = header_length;
						/* update length for common block */
				if polish (i + 2) = word_units
				then call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)),
					"words");
				else call print_message (426, fixed (rel (p), 18), ltrim (char (header_length)),
					"characters");
				end;
			     else if header_length < polish (i + 1)
						/* check for different length */
			     then call print_message (434, fixed (rel (p), 18));

			     if p -> header.initialed
			     then if ext_ref (i) -> header.initialed
				then call print_message (432, fixed (rel (p), 18));
				else ext_ref (i) = p;
			     end;

			return (loc);
			end;
		end;

	/* allocate new entry in external list */

	if next_free_polish + 2 < polish_max_len
	then do;
	     ext_ref (next_free_polish) = p;

	     if p -> node.node_type = header_node	/* for common blocks, save block length */
	     then do;
		polish (next_free_polish + 1) = p -> header.length;
		polish (next_free_polish + 2) = p -> header.units;
		end;
	     next_free_polish = next_free_polish + 3;

	     loc = link_pos;
	     link_pos = link_pos + 2;
	     if link_pos > max_linkage_size
	     then call print_message (414, "linkage section", char (max_linkage_size));

	     return (loc);
	     end;

	else call print_message (407, "polish region", char (polish_max_len));

     end alloc_external;

alloc_members:
     procedure ();

	/* Allocates members of common blocks and equivalence groups. */

	do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
	     s = addr (rands (sym));
	     substr (string (s -> symbol.storage_class), 1, 3) = string (h -> header.storage_class);
	     unspec (s -> symbol.address) = unspec (h -> header.address);
	     s -> symbol.reloc = h -> header.reloc;
	     if s -> symbol.units = char_units
	     then do;
		s -> symbol.location = h -> header.location + divide (s -> symbol.offset, chars_per_word, 18, 0);
		s -> symbol.address.char_num = mod (s -> symbol.offset, chars_per_word);
		end;
	     else s -> symbol.location = h -> header.location + s -> symbol.offset;
	     s -> symbol.operand_type = variable_type;
	     string (s -> symbol.addressing_bits) = string (h -> header.addressing_bits);
	     s -> symbol.hash_chain = 0;
	     if s -> symbol.dimensioned
	     then vsize = get_array_size (s);
	     end;

     end alloc_members;

create_storage_entry:
     proc (h);

	/* Purpose:  Create a creation list entry in the text section, and link it to
	   the last such entry.  Information required is taken from the chain
	   header supplied. */


dcl  h ptr;					/* Incoming header pointer */

dcl  cur_pos fixed bin (18) unsigned;			/* current position in text section */
dcl  listp ptr;
dcl  i fixed bin;


dcl  (currentsize, length) builtin;

	call make_create_entry (h);

	if h -> header.VLA				/* setup pointers */
	then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
		s = addr (rands (sym));
		if s -> symbol.offset = 0 & VLA_is_256K
		then call set_address_offset (s, (h -> header.location), 1, word_units);
		else do;
		     listp -> create_entry.pointer_count = listp -> create_entry.pointer_count + 1;
		     call set_address_offset (s, h -> header.location + listp -> create_entry.pointer_count, 1,
			word_units);
		     listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count).offset =
			s -> symbol.offset;
		     if h -> header.static
		     then linkage_pad = linkage_pad + 1;
		     else last_auto_loc = last_auto_loc + 1;

		     /* save the symbol name for the listing */
		     if assembly_list
		     then do;
			cur_pos =
			     fixed (
			     rel (
			     addr (listp -> create_entry.pointer_offsets (listp -> create_entry.pointer_count))));
			a_name (cur_pos) = fixed (rel (s));
			end;
		     end;
		end;

	/* increment past all information */

	text_pos = text_pos + currentsize (listp -> create_entry);
	return;

note_VLA_common:
     entry (h);


	/* Take note of common blocks in VLA common, and combine them into single
	   composite representations for each common of every definition of that
	   common.  This means determining the maximum length, the number of unique
	   offsets into the common (to build pointer information), and any init
	   information. */

dcl  chain_head ptr;				/* head of current chain */
dcl  hdr ptr;					/* current entry node */
dcl  looping bit (1);				/* scanning chain */
dcl  s ptr;					/* current symbol */
dcl  sym fixed bin (18);				/* current symbol node */
dcl  this_chain ptr;				/* last header of current chain */


	/* entry for headers and symbols. */

dcl  1 entry based (hdr),
       2 next ptr,					/* next entry in header list */
       2 chain ptr,					/* next entry in chain */
       2 node ptr,					/* pointer node in rands */
       2 header bit (1) unaligned,			/* node is a header */
       2 offset fixed bin (35) unsigned unaligned;	/* symbol offset */

	if first_header = null ()			/* no list */
	then goto create_header;

	/* find header chain. */

	do hdr = first_header repeat entry.next while (hdr ^= null ());
	     if entry.node -> header.block_name = h -> header.block_name
	     then goto add_header;			/* in right chain */
	     end /* do hdr */;

	/* at this point we don't have the right chain, but we do have a list */

	if hdr = null ()
	then do;

create_header:
	     call make_entry;
	     if first_header = null ()		/* chain to list */
	     then first_header = hdr;
	     else last_header -> entry.next = hdr;
	     last_header = hdr;
	     end;
	else do;					/* cannot enter through the do, it is just for blocking */

	     /* form maximum length */

add_header:
	     chain_head = hdr;
	     if h -> header.length ^= entry.node -> header.length
	     then do;

		/* form maximum common block lengths */

		if h -> header.block_name ^= blank_common_name
		then if h -> header.length > entry.node -> header.length
		     then call print_message (426, fixed (rel (h), 18), ltrim (char (h -> header.length)));
		     else call print_message (434, fixed (rel (h), 18));

		if h -> header.length > entry.node -> header.length
		then h -> header.length = entry.node -> header.length;
		end;


	     /* find end of headers in chain list. */

	     do hdr = chain_head repeat entry.chain while (entry.chain -> entry.header = "1"b);
		end;				/* leave hdr pointing at last header of chain */

	     /* Link new entry into chain as last header in header portion of chain */

	     this_chain = hdr;
	     call make_entry;
	     entry.chain = this_chain -> entry.chain;
	     this_chain -> entry.chain = hdr;
	     end;


	/* Add list of symbols to chain.  Last header of chain is at 'hdr' */
	/* This leaves a list sorted by symbol offset. */

add_symbols:
	chain_head = hdr;
	do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
	     s = addr (rands (sym));

	     /* add total if chain is empty of symbols. */

	     this_chain = chain_head;
	     if this_chain -> entry.chain ^= null ()
	     then do;
		looping = "1"b;
		do while (looping);
		     this_chain = this_chain -> entry.chain;
		     if this_chain -> entry.chain = null ()
		     then looping = "0"b;
		     else if this_chain -> entry.chain -> entry.offset > s -> symbol.offset
		     then looping = "0"b;
		     end;
		end;

	     /* hdr points at add_point to chain */

	     call make_entry;
	     entry.offset = s -> symbol.offset;
	     entry.chain = this_chain -> entry.chain;
	     entry.node = s;
	     entry.header = "0"b;
	     this_chain -> entry.chain = hdr;
	     end /* do sym */;
	return;

	/*	   Assign Storage to VLA common. */
allocate_VLA_common:
     entry;

	/* Assign storage address and storage creation information.  This is done
	   by scanning the finalized lists and copying the maximum length through all
	   headers for the multiple uses of that common, then creating a storage
	   creation entry for the common, and then assigning a pointer location
	   to each unique offset, and copying that pointer location into the symbols
	   mapped into that unique offset.  At the same point a storage creation
	   pointer is created and assigned that offset.  Initialization information
	   is picked up in a separate pass through the symbols. */

dcl  common_length fixed bin (35);			/* common_length of the common block */
dcl  current_offset fixed bin (35);			/* current symbol offset processing */
dcl  location fixed bin (18);				/* location of packed pointers */

	/* scan commons */

	do chain_head = first_header repeat chain_head while (chain_head ^= null ());

	     /* pick up the maximum length and propagate it through the multiple copies of headers */

	     common_length = chain_head -> entry.node -> header.length;

	     /* 'header.location' is the normal location in which the
	        external link would be found and will be later relocated
	        and external reference made. */

	     /* At this point header.location is the pointer to the first PP. */

	     /* NOTE - you will see the strange construction 'copy ("0"b, 18 - length (x)) || x'
	        in setting 'reloc_halfs' in this code.  This is because of the use to two
	        different definitions for 'rc_t' and 'rc_lp18', one for 6-bits and the
	        other for 18-bits.  Why they have the same name I do not know, but I do know
	        that the binder is very unhappy to receive a 6-bit relocation value left
	        adjusted in an 18-bit field, hence the padding.  If some turkey changes the
	        definition in the future, and I get the 18-bitter, it will still work. */

	     location, chain_head -> entry.node -> header.location = linkage_pad + size (virgin_linkage_header);
	     linkage_pad = linkage_pad + 1;		/*  space for base addressor  */
	     call make_create_entry (chain_head -> entry.node);
	     chain_head -> entry.node -> header.location, listp -> create_entry.common_link =
		alloc_external (chain_head -> entry.node);
	     reloc_halfs (text_pos + 3).left = copy ("0"b, 18 - length (rc_lp18)) || rc_lp18;
	     call set_address_offset (addr (rands (chain_head -> entry.node -> header.VLA_base_addressor)), (location),
		1, word_units);

	     do hdr = chain_head -> entry.chain repeat entry.chain while (entry.header = "1"b);
		entry.node -> header.length = common_length;
		entry.node -> header.location = alloc_external (entry.node);
		call set_address_offset (addr (rands (entry.node -> header.VLA_base_addressor)), (location), 1,
		     word_units);
		end;

	     if VLA_is_256K
	     then current_offset = 0;			/*  Base addressor is a packed ptr to offset 0.  */
	     else current_offset = -1;		/*  Base addressor is logical address of offset 0.  */
	     i = 0;				/* current pointer */
	     do hdr = hdr repeat entry.chain while (hdr ^= null ());
		s = entry.node;
		if s -> symbol.offset ^= current_offset
		then i = i + 1;			/* count unique pointer */
		call set_address_offset (s, location + i, 1, word_units);

		/* Save a copy of the offset information */
		s -> symbol.addr_hold = substr (unspec (s -> symbol.address), 1, 18);

		/* create a pointer for all but possibly the first unique entry */

		if s -> symbol.offset ^= current_offset
		then do;
		     current_offset = s -> symbol.offset;
		     listp -> create_entry.pointer_count = i;
		     listp -> create_entry.pointer_offsets (i).offset = s -> symbol.offset;
		     linkage_pad = linkage_pad + 1;

		     /* save the symbol name for the listing */
		     if assembly_list
		     then do;
			cur_pos = fixed (rel (addr (listp -> create_entry.pointer_offsets (i))));
			a_name (cur_pos) = fixed (rel (s));
			end;
		     end /* do */;
		end /* do hdr */;

	     text_pos = text_pos + currentsize (listp -> create_entry);

	     chain_head = chain_head -> entry.next;
	     end /* do chain_head */;

	call cleanup_VLA_common;			/* Use common cleanup */
	return;

	/* Entry to relocate the link relative offset left in the create_entry for
	   common VLA, to become a true linkage section offset. */

VLA_reloc_common_link:
     entry;


	looping = "1"b;				/* loop through list */

	location = Area_create_first;
	if Area_create_first ^= -1
	then do while (looping = "1"b);
		listp = addrel (object_base, location);
		if listp -> create_entry.common
		then listp -> create_entry.common_link = listp -> create_entry.common_link + link_pos;
		location = listp -> create_entry.next;
		if location = 0
		then looping = "0"b;
		end;
	return;



cleanup_VLA_common:
     entry;

	/* Cleanup vla common allocation lists when cleanup encountered. */

	if first_header = null ()
	then return;

	do first_header = first_header repeat first_header while (first_header ^= null ());
	     chain_head = first_header;
	     first_header = first_header -> entry.next;
	     do this_chain = chain_head repeat this_chain while (this_chain ^= null ());
		hdr = this_chain;
		this_chain = entry.chain;
		free entry;
		end /* do this_chain */;
	     end /* do first_header */;

	return /* cleanup_VLA_common */;


	/* create an entry for a header/symbol */
make_entry:
     proc;

	allocate entry;
	entry.node = h;
	entry.chain, entry.next = null ();
	entry.offset = 0;
	entry.header = "1"b;
	return;
     end make_entry;				/*						   Make the basic creation list entry. */
make_create_entry:
     proc (h);

dcl  h ptr;
dcl  i fixed bin (18);				/* index in text */
dcl  last_listp ptr;				/* -> last create_entry */

	listp = addrel (object_base, text_pos);

	/* Set location of base pointer in section and set relocation of pointer */

	listp -> create_entry.location = h -> header.location;
	if h -> header.static | h -> header.in_common
	then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_is15)) || rc_is15;
	else if h -> header.automatic
	then reloc_halfs (text_pos).left = copy ("0"b, 18 - length (rc_a)) || rc_a;

	listp -> create_entry.auto = h -> header.automatic;
	listp -> create_entry.static = h -> header.static;
	listp -> create_entry.common = h -> header.in_common;
	listp -> create_entry.LA = h -> header.LA;
	listp -> create_entry.VLA = h -> header.VLA;
	listp -> create_entry.K256 = VLA_is_256K;
	listp -> create_entry.init = h -> header.initialed;
	listp -> create_entry.length = h -> header.length;
	listp -> create_entry.next = 0;
	listp -> create_entry.name_length = h -> header.name_length;
	if listp -> create_entry.name_length ^= 0
	then listp -> create_entry.block_name = h -> header.block_name;

	listp -> create_entry.pointer_count = 0;

	if h -> header.automatic
	then alloc_auto_cleanup = "1"b;		/* cleanup automatic LA's and VLA's */

	if Area_create_first < 0			/* flagged empty */
	then Area_create_first = text_pos;
	else do;

	     /* Link previous entry to this one and set relocation too. */

	     last_listp = addrel (object_base, Area_create_last);
	     last_listp -> create_entry.next = text_pos;
	     i = fixed (rel (addr (last_listp -> create_entry.next)), 18, 0) - fixed (rel (object_base), 18, 0);
	     reloc_halfs (i).left = copy ("0"b, 18 - length (rc_t)) || rc_t;
	     end;
	Area_create_last = text_pos;

     end make_create_entry;
     end create_storage_entry;

relocate:
     procedure (which, locn, limit, section_name);

	/* Relocates items in each bucket. */

dcl  which fixed binary (18),
     locn fixed binary (18),
     limit fixed binary (18),				/* limit of section */
     section_name char (*);				/* name of section */

dcl  (i, loc, start) fixed binary (18);

	loc = locn;

	do start = which to which + 2 by 2;
	     do cur_subprogram = first_subprogram repeat cs -> subprogram.next_subprogram while (cur_subprogram > 0);
		cs = addr (rands (cur_subprogram));
		call get_subr_options (cs);

		do i = start to start + 1;
		     cs -> subprogram.next_loc (i) = cs -> subprogram.next_loc (i) + loc;

		     do hdr = cs -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0);
			h = addr (rands (hdr));

			if h -> node.node_type = header_node
			then do;
			     call assign_address_offset (h, loc, 1, word_units);
			     do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
				s = addr (rands (sym));
				call relocate_error (s);
				call assign_address_offset (s, loc, (s -> symbol.element_size),
				     (s -> symbol.units));
				end;
			     end;

			else do;
			     call relocate_error (h);
			     call assign_address_offset (h, loc, (h -> symbol.element_size), (h -> symbol.units));
			     end;
			end;

		     loc = cs -> subprogram.next_loc (i);
		     end;

		loc = loc + mod (loc, 2);
		end;
	     end;

	locn = loc;

	/* Test if variable will fit within region. */

relocate_error:
     proc (s);

dcl  s ptr;					/* pointer to node */
dcl  next_loc fixed bin (18);

	if s -> node.next ^= 0
	then next_loc = addr (rands (s -> node.next)) -> node.location;
	else next_loc = cs -> subprogram.next_loc (i) - loc;

	if loc + next_loc > limit
	then call print_message (414,
		"with relocation of " || s -> symbol.name || " in "
		|| addr (rands (cs -> subprogram.symbol)) -> symbol.name || " the " || section_name,
		ltrim (char (limit)));
     end relocate_error;
     end relocate;

get_array_size:
     procedure (pt) returns (fixed binary (18));

	/* Calculates the size of an array, and computes its virtual
	   origin if constant. */

dcl  (pt, s, d) pointer;
dcl  (cm, i, n, v) fixed binary (18);
dcl  ndims fixed binary (3);
dcl  constant_vo bit (1) aligned;

	n = 0;
	s = pt;
	d = addr (rands (s -> symbol.dimension));

	if ^s -> symbol.variable_extents & ^s -> symbol.star_extents
	then do;
	     d -> dimension.array_size = d -> dimension.element_count * s -> symbol.element_size;
	     d -> dimension.has_array_size = "1"b;
	     n = get_size_in_words ((d -> dimension.array_size), (s -> symbol.units));

	     /* calculate virtual origin */

	     v = 0;
	     cm = s -> symbol.element_size;
	     do i = 1 to d -> dimension.number_of_dims;
		v = v + cm * d -> dimension.lower_bound (i);
		cm = cm * d -> dimension.size (i);
		end;

	     d -> dimension.virtual_origin = v;
	     d -> dimension.has_virtual_origin = "1"b;
	     end;

	else do;

	     /* Make a descriptor for the array */

	     if s -> symbol.needs_descriptors | s -> symbol.put_in_symtab | shared_globals.options.table
	     then i = make_symbol_descriptor (fixed (rel (s), 18));

	     /* Allocate a symbol for the array size */

	     if ^d -> dimension.has_array_size
	     then do;
		d -> dimension.array_size = create_automatic_integer (cs);
		d -> dimension.has_array_size = "1"b;
		d -> dimension.variable_array_size = "1"b;
		end;

	     ndims = d -> dimension.number_of_dims;

	     /* Allocate a virtual origin symbol if necessary */

	     if ^d -> dimension.has_virtual_origin
	     then do;
		constant_vo = ^d -> dimension.v_bound (ndims).lower;
		do i = 1 to ndims - 1 while (constant_vo);
		     constant_vo = (string (d -> dimension.v_bound (i)) = "00"b);
		     end;
		if ^constant_vo | s -> symbol.star_extents
						/* either case requires vo */
		then do;
		     d -> dimension.virtual_origin = create_automatic_integer (cs);
		     d -> dimension.has_virtual_origin = "1"b;
		     d -> dimension.variable_virtual_origin = "1"b;
		     end;
		end;

	     /* Allocate symbols for dimension.size (*) */

	     if ^d -> dimension.has_dim_sizes
	     then do;
		do i = 1 to ndims - binary (d -> dimension.assumed_size, 1);
		     if string (d -> dimension.v_bound (i)) = "00"b
		     then d -> dimension.size (i) =
			     d -> dimension.upper_bound (i) - d -> dimension.lower_bound (i) + 1;
		     else if ^d -> dimension.v_bound (i).lower & d -> dimension.lower_bound (i) = 1
		     then d -> dimension.size (i) = d -> dimension.upper_bound (i);
		     else d -> dimension.size (i) = create_automatic_integer (cs);
		     end;
		d -> dimension.has_dim_sizes = "1"b;
		end;

	     end;

	return (n);

     end get_array_size;

     end assign_storage;

create_automatic_integer:
     procedure (cs) returns (fixed binary (18));

	/* Creates an automatic integer variable. */

dcl  sym fixed binary (18);
dcl  s pointer;
dcl  cs pointer;

	sym = create_node (symbol_node, size (symbol));
	s = addr (rands (sym));
	s -> symbol.data_type = int_mode;
	s -> symbol.by_compiler, s -> symbol.integer, s -> symbol.allocate, s -> symbol.automatic = "1"b;
	s -> symbol.element_size = 1;
	s -> symbol.units = word_units;

	addr (rands (cs -> subprogram.last_symbol)) -> node.next = sym;
	cs -> subprogram.last_symbol = sym;

	return (sym);

     end create_automatic_integer;

/**** CREATE_REL_CONSTANT ****/

create_rel_constant:
     procedure (cs) returns (fixed binary (18));

	/* Creates a rel_constant */

dcl  cs pointer;					/* current subprogram node */

dcl  var fixed binary (18);
dcl  p pointer;

%include relocation_bits;

	var = create_node (label_node, size (label));
	p = addr (rands (var));

	p -> label.operand_type = rel_constant;
	p -> label.reloc = rc_t;
	p -> label.referenced, p -> label.referenced_executable, p -> label.is_addressable = "1"b;

	if cs ^= null
	then do;
	     if cs -> subprogram.last_label = 0
	     then cs -> subprogram.first_label = var;
	     else addr (rands (cs -> subprogram.last_label)) -> label.next_label = var;
	     cs -> subprogram.last_label = var;
	     end;

	return (var);

     end create_rel_constant;

interpreter:
     procedure (p_analyzing);

	/* Written by R. A. Barnes 1 January 1976 */

dcl  (analyzing, p_analyzing) bit (1) aligned;		/* "1"b - Performing Register Usage Analysis
						   ``           and Global Register Allocation. */

dcl  base fixed bin (18);				/* subscript of arg1 */
dcl  top fixed bin (18);				/* subscript of op1 */

dcl  cur_frame ptr;					/* ptr to current procedure frame */
dcl  mac_base ptr;					/* ptr to base of macro segment */

dcl  cs ptr;					/* ptr to current subprogram node */
dcl  statement_ptr ptr;				/* ptr to current opt_statement node */
dcl  quad_ptr ptr;					/* ptr to current operator node */

dcl  cur_lp ptr;					/* ptr to current loop node */
dcl  fu ptr;					/* ptr to current flow_unit */
dcl  lp_msp ptr;					/* cur_lp -> loop.msp (mach state template) */

dcl  next_lp ptr;					/* ptr to loop we are about to enter */

dcl  imac fixed bin (18);				/* index into fort_opt_macros_ */
dcl  iquad fixed bin (18);				/* index into quadruples */
dcl  next_operand fixed bin (18);			/* Index to get next "scanned" operand. */

dcl  left fixed bin (18);				/* left half of macro instructiin */
dcl  mopnd fixed bin (18);				/* operand index in macro instruction */
dcl  mop fixed bin (18);

dcl  next_free_opt_ms ptr;				/* free chain of machine_state nodes in opt region */

dcl  avail_pregs fixed bin (4);			/* number of ptr registers in the pool */
dcl  avail_xregs fixed bin (4);			/* number of index registers in the pool */

dcl  desc_temp_chain fixed binary (18) unsigned;
dcl  op_code fixed bin (18);

dcl  discard fixed bin (18);
dcl  (i, k, n, op1, op2, next_base, relation, scan_proc, skip, temp, zarg, desc, eaq_name, sym) fixed bin (18);
dcl  regno fixed bin (3);
dcl  (cdt, dt, dt1, dt2) fixed bin (4);
dcl  xr fixed bin (3);
dcl  char1 character (1);

dcl  (p, st, lbl, s) ptr;
dcl  (b1, b2, err_flag, state_discarded) bit (1) aligned;
dcl  bit3 bit (3) aligned;
dcl  bit6 bit (6) aligned;

dcl  from_base_man bit (1) aligned;			/* "1"b if base_man_load_pr is active */

dcl  stack (300) fixed bin (18);

dcl  computed_virtual_origin (25) fixed binary (18);
dcl  virtual_origin_count fixed binary (17);

dcl  i_loop fixed bin;				/* index of loop being analyzed */
dcl  loop_vector_p ptr;				/* -> loop_vector */
dcl  n_loops fixed bin (18);				/* number of loops in loop_vector */
dcl  max_operators fixed bin (18);			/* length(obits) */
dcl  max_sym fixed bin (18);				/* length(bits) */

dcl  (
     fort_opt_macros_$first_scan,
     fort_opt_macros_$abort_list,
     fort_opt_macros_$error_macro
     ) bit (36) aligned ext static;

dcl  1 fort_opt_macros_$interpreter_macros (4) aligned ext static,
       2 entry fixed bin (17) unal,
       2 pad fixed bin (17) unal;

dcl  1 fort_opt_macros_$operator_table (109) aligned ext static,
       2 entry fixed bin (17) unal,
       2 pad fixed bin (17) unal;

dcl  1 fort_instruction_info_$fort_instruction_info_ (0:1023) aligned ext static,
       2 alters unaligned structure,
         3 A bit (1),
         3 Q bit (1),
         3 indicators bit (1),
         3 PR (6) bit (1),
         3 XR bit (8),				/* can't use (0:7) because of PL/I ERROR 338 */
         3 pad1 bit (1),
       2 directable bit (1) unaligned,
       2 pad2 bit (17) unaligned;

dcl  (
     variable_count init (-1),
     not_given init (-2)
     ) fixed bin (18) int static options (constant);

dcl  ERROR fixed bin (18) int static options (constant) init (-1);
						/* ERROR operand */

dcl  mask_left bit (36) aligned int static options (constant) init ("000000777777"b3);

dcl  (
     first_base initial (2),
     last_base initial (6),
     escape_index initial (1),
     first_index initial (2),
     last_index initial (7),
     linkage_ptr initial (36),
     arg_ptr initial (26),
     descriptor_ptr initial (34)
     ) fixed binary (18) internal static options (constant);

dcl  1 fort_opt_macros_$single_inst (158) aligned ext static like machine_instruction;

%include fort_single_inst_names;

dcl  dt_from_reg (20) fixed bin (4) int static options (constant)
	init (1, 5, 4, 2, 3, 2, 2, 1, 7, 0, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5);

dcl  eaq_name_to_reg (20) fixed bin internal static options (constant)
	init (2, 1, 3, 3, 3, 3, 2, 1, 2, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4);

dcl  (
     A initial (1),
     Q initial (2),
     EAQ initial (3),
     IND initial (4)
     ) fixed bin (18) internal static options (constant);

dcl  (
     in_q init (1),					/* integer value in the Q */
     in_a init (2),					/* logical value in the A */
     in_aq init (3),				/* complex value in the AQ */
     in_eaq init (4),				/* real value in the EAQ */
     in_deaq init (5),				/* dp value in the EAQ */
     in_ieaq init (6),				/* imag value in EAQ */
     in_iq init (7),				/* second word of doubleword in Q */
     in_ia init (8),				/* integer value in the A */
     in_tq init (9),				/* typeless value in the Q */
     in_ind init (10),				/* wildcard for logical value in IND */
     tze init (11),					/* .eq. */
     tnz init (12),					/* .ne. */
     tmi init (13),					/* .lt. */
     tpl init (14),					/* .ge. */
     tmoz init (15),				/* .le. */
     tpnz init (16),				/* .gt. */
     tnc init (17),					/* j_l_s */
     trc init (18),					/* j_ge_s */
     j_le_s init (19),				/* j_le_s */
     j_g_s init (20)				/* j_g_s */
     ) fixed bin (18) int static options (constant);

dcl  (						/* op_base equ 361 */
     VLA_words_per_seg initial (361 - 476),		/* SPECIAL conversion */
     allocate_char_string initial (361 + 0),
     reallocate_char_string initial (361 + 29),
     alloc_auto_adj initial (361 + 72),
     shorten_stack initial (361 + 163),
     long_profile initial (361 + 426),
     shorten_stack_protect_ind initial (361 + 451)
     ) fixed binary (14) internal static options (constant);

dcl  shorten_stack_mask bit (14) aligned internal static options (constant) initial ("01000000010000"b);
						/* Reserve pr1,x1 */

dcl  highest_ind_state fixed bin options (constant) int static init (19);

dcl  zero_for_dt (0:7) fixed bin (18);

dcl  function fixed bin (18) int static init (13) options (constant);

dcl  (
     check_subscript init (1),
     subscript_mpy init (2),
     move_eis init (3),
     check_stringrange init (4)
     ) fixed bin (18) int static options (constant);

dcl  entry_info_size fixed bin (18) int static init (7) options (constant);

dcl  descriptor_mask_addr bit (36) aligned internal static options (constant) initial ("000250000100"b3);
						/* pr0|168 = 000077777777 */

dcl  (result, source) bit (72) aligned;

dcl  based_integer fixed bin (35) based;

dcl  1 inst_address aligned like symbol.address;

dcl  1 saved_cat_address aligned like node.address automatic;
dcl  cat_offset_temp fixed binary (18);

dcl  char_temp char (8);

dcl  1 base_man_args,
       2 code fixed bin (18),
       2 variable fixed bin (18),
       2 offset fixed bin (18);

dcl  hold_pr_locks (6) bit (1) aligned;

dcl  1 loop_vector_st based (loop_vector_p) aligned,
       2 loop_vector (n_loops) pointer unaligned;

dcl  bits bit (max_sym) based aligned;			/* symbol bits */
dcl  obits bit (max_operators) based aligned;		/* operator bits */


dcl  int_image fixed bin (35) based;
dcl  real_image float bin (27) based;
dcl  dp_image float bin (63) based;
dcl  cmpx_image complex float bin (27) based;
dcl  bit_image bit (72) aligned based;

dcl  ind_word bit (36) aligned based;

dcl  1 current_ms like machine_state aligned;

dcl  1 loop_state based (lp_msp) aligned like machine_state;

dcl  1 proc_frame based (cur_frame) aligned,
       2 node_type fixed bin (4) unal,
       2 flags structure unaligned,
         3 func bit (1),
         3 scan_interpreter_frame,
	 4 interpreter_called bit (1) unal,
	 4 scan_called bit (1) unal,
         3 pad bit (28) unal,
       2 prev ptr unal,
       2 next ptr unal,
       2 return fixed bin (18),
       2 base fixed bin (18),
       2 error_label fixed bin (18),
       2 interpreter_return label local,
       2 nshort fixed bin (18),
       2 short (3) fixed bin (18);

	/* BEGIN Register Analysis Database */

dcl  1 ptr_data,
       2 local fixed bin,
       2 locked fixed bin,
       2 max_local fixed bin,
       2 max_locked fixed bin,
       2 n_global fixed bin,
       2 item_st structure aligned,
         3 item (100) ptr unaligned;

dcl  last_pr_locked_for_pl1_ops_arg fixed bin (3);

dcl  1 index_data like ptr_data;

dcl  ptr_hash_table (0:210) fixed bin (18);

	/* END Register Analysis Database */

dcl  1 hast based (addr (macro_instruction (imac))),
       2 instruction_word bit (36) aligned,
       2 half_array (100) fixed bin (17) unaligned;

dcl  1 macro_instruction (0:262143) based (mac_base) aligned,
       2 left fixed bin (17) unal,			/* left half - label or integer */
       2 operand fixed bin (3) unal,
       2 eaq_name fixed bin (5) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 machine_instruction (0:262143) based (mac_base) aligned,
       2 operand fixed bin (3) unal,
       2 increment fixed bin (13) unal,
       2 op_code bit (10) unal,
       2 inhibit bit (1) unal,
       2 ext_base_and_tag unal,
         3 ext_base bit (1) unal,
         3 tag bit (6) unal;

dcl  1 macro_dt_inst (0:262143) based (mac_base) aligned,
       2 number fixed bin (17) unal,
       2 data_type fixed bin (9) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 macro_bits_inst (0:262143) based (mac_base) aligned,
       2 left fixed bin (17) unal,
       2 bits bit (10) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 macro_if_inst (0:262143) based (mac_base) aligned,
       2 left fixed bin (17) unal,
       2 operand fixed bin (3) unal,
       2 relation bit (3) unal,
       2 with fixed bin (2) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 macro_regs_inst (0:262143) based (mac_base) aligned,
       2 regs bit (18) unal,
       2 pad bit (10) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 macro_cond_inst (0:262143) based (mac_base) aligned,
       2 left bit (18) unal,
       2 operand bit (4) unal,
       2 pad bit (5) unal,
       2 if_test bit (1) unal,
       2 inhibit bit (1) unal,
       2 op_code bit (7) unal;

dcl  1 instruction (0:262143) aligned based (object_base),
       2 base bit (3) unal,
       2 offset fixed bin (14) unal,
       2 op bit (10) unal,
       2 inhibit bit (1) unal,
       2 ext_base_and_tag unal,
         3 ext_base bit (1) unal,
         3 tag bit (6) unal;

dcl  text_word (0:262143) bit (36) aligned based (object_base);

dcl  1 reloc (0:262143) aligned based (relocation_base),
       2 skip1 bit (12) unal,
       2 left_rel bit (6) unal,
       2 skip2 bit (12) unal,
       2 right_rel bit (6) unal;

dcl  1 half based aligned,
       2 left fixed bin (17) unal,
       2 right fixed bin (17) unal;

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 (254) like itp aligned;		/* Big enough for 127 args
						   and descriptors */

dcl  1 entry_descriptor aligned,
       2 type_bits bit (12) unaligned,
       2 char_size bit (24) unaligned;

dcl  1 floating_value auto aligned,
       2 exponent fixed binary (7) unaligned,
       2 mantissa bit (64) unaligned;

dcl  mantissa_of_power_of_fpbase bit (64);

dcl  (length, mod) builtin;

%include relocation_bits;

	/* copy in parameter and set up */

	analyzing = p_analyzing;

	if analyzing
	then do;
	     unspec (ptr_hash_table), unspec (ptr_data), unspec (index_data) = "0"b;
	     last_pr_locked_for_pl1_ops_arg = 0;
	     avail_pregs = last_base - first_base + 1;
	     avail_xregs = last_index - first_index + 1;
	     end;

	/* initialize cur_subprogram and friend */

	cur_subprogram = first_subprogram;

	cur_statement = -1;

	/* initialize constant builtins */

	builtins (0) = create_integer_constant (0);
	builtins (1) = create_integer_constant (1);
	builtins (5) = create_constant (dp_mode, unspec (null));
	builtins (6) = 0;
	builtins (7) = create_integer_constant (2);

	/* initialize array of zero constants */

	zero_for_dt (0) = ERROR;			/* for invalid register states */
	zero_for_dt (1) = builtins (0);		/* integer */
	addr (result) -> real_image = 0.0;
	zero_for_dt (2) = create_constant (real_mode, result);
						/* real */
	addr (result) -> dp_image = 0.0;
	zero_for_dt (3) = create_constant (dp_mode, result);
						/* double precision */
	addr (result) -> cmpx_image = 0.0;
	zero_for_dt (4) = create_constant (cmpx_mode, result);
						/* complex */
	result = "0"b;
	zero_for_dt (5) = create_constant (logical_mode, result);
						/* logical */
	zero_for_dt (6) = ERROR;			/* character */
	zero_for_dt (7) = builtins (0);		/* typeless */

	/* initialize automatic vars for this program */

	call initialize_auto;

	/* initialize builtins for auto template and overlay */

	char_constant_length = 0;			/* do not allocate the value field */

	if builtins (3) = 0
	then do;
	     builtins (3) = create_node (char_constant_node, size (char_constant));
	     p = addr (rands (builtins (3)));
	     p -> char_constant.operand_type = constant_type;
	     p -> char_constant.data_type = char_mode;
	     p -> char_constant.is_addressable, p -> char_constant.allocated = "1"b;
	     p -> char_constant.reloc = rc_t;
	     p -> char_constant.length =
		chars_per_word * (addr (rands (last_subprogram)) -> subprogram.next_loc (2) - first_auto_var_loc);
	     p -> char_constant.no_value_stored = "1"b;	/* value is already in the text */
	     end;
	else p = addr (rands (builtins (3)));

	p -> char_constant.location = auto_template;

	if builtins (4) = 0
	then do;
	     builtins (4) = create_node (array_ref_node, size (array_ref));
	     p = addr (rands (builtins (4)));
	     p -> array_ref.operand_type = array_ref_type;
	     p -> array_ref.data_type = char_mode;
	     p -> array_ref.is_addressable, p -> array_ref.allocated, p -> array_ref.ext_base = "1"b;
	     p -> array_ref.base = sp;
	     p -> array_ref.address.offset = first_auto_var_loc;
	     end;
	else p = addr (rands (builtins (4)));
	if init_auto_to_zero
	then p -> array_ref.length = chars_per_word * (last_auto_loc - first_auto_var_loc);
	else p -> array_ref.length = addr (rands (builtins (3))) -> char_constant.length;
	p -> array_ref.ref_count = 131071;		/* prevent deletion */

	if builtins (8) = 0
	then do;
	     builtins (8) = create_node (symbol_node, size (symbol));
	     p = addr (rands (builtins (8)));
	     p -> symbol.operand_type = dummy;
	     p -> symbol.by_compiler = "1"b;
	     p -> symbol.allocated, p -> symbol.is_addressable, p -> symbol.ext_base = "1"b;
	     p -> symbol.base = sp;
	     end;

	if builtins (11) = 0
	then do;
	     builtins (11) = create_node (symbol_node, size (symbol));
	     p = addr (rands (builtins (11)));
	     p -> symbol.operand_type = variable_type;
	     p -> symbol.data_type = int_mode;
	     p -> symbol.by_compiler = "1"b;
	     p -> symbol.needs_pointer = "1"b;
	     p -> symbol.descriptor = "1"b;
	     p -> symbol.address.ext_base = "1"b;
	     end;

	/* perform other initializations */

	desc_temp_chain = 0;
	state_discarded = "1"b;
	unspec (current_ms) = "0"b;
	from_base_man = "0"b;
	next_free_opt_ms = null;
	if shared_globals.hfp
	then mantissa_of_power_of_fpbase = "00001"b;
	else mantissa_of_power_of_fpbase = "01"b;

	/* initialize scanners */

	mac_base = ptr (addr (fort_opt_macros_$first_scan), 0);
	imac = fixed (rel (addr (fort_opt_macros_$first_scan)), 18) - 1;

	/* get first procedure frame and initialize operand stack */

	if first_frame = null
	then do;
	     cur_frame = null;

	     cur_frame, first_frame = create_proc_frame ();
	     end;

	else cur_frame = first_frame;

	base, top = 0;

	/* set up for subprogram */

	call start_subprogram;

	/* MAIN LOOP! */

	do while ("1"b);

	     imac = imac + 1;

	     /* look at next instruction */

loop:
	     if ^macro_instruction (imac).inhibit
	     then do;

		/* have machine instruction */

		call emit_inst;
		go to step;
		end;

	     /* have macro instruction */

	     mopnd = macro_instruction (imac).operand;
	     left = macro_instruction (imac).left;
	     mop = fixed (macro_instruction (imac).op_code, 7);

	     go to action (mop);

action (1):					/* copy */
	     op1 = stack (get_operand (mopnd));
	     call copy (op1);
	     go to step;

action (2):					/* swap */
	     op1 = get_operand (mopnd);

	     k = stack (top);
	     stack (top) = stack (op1);
	     stack (op1) = k;

	     go to step;

action (3):					/* pop */
	     op1 = get_operand (mopnd);
	     call pop (op1);
	     go to step;

action (4):					/* push_temp */
	     dt = macro_dt_inst (imac).data_type;

	     if dt ^= 0
	     then call push (assign_temp (dt));

	     else do;

		/* have block of words */

		if left < 0
		then do;

		     /* have count */

		     b1 = "1"b;			/* have count */
		     left = stack (top) + bias;
		     top = top - 1;
		     end;
		else b1 = "0"b;			/* don't have count */

		call push (assign_block (left));

		/* if "push_temp var" then ref_count is infinite 78.03.29 */

		if b1				/* ref_count for var length temp is infinite 78.03.28 */
		then if analyzing
		     then addr (rands (stack (top))) -> temporary.ref_count_copy = 131071;
		     else addr (rands (stack (top))) -> temporary.ref_count = 131071;
		end;

	     go to step;

action (6):					/* dispatch for simple macro instructions */
	     go to simple (left);

simple (1):					/* push_label */
simple (2):					/* push_rel_constant */
	     call push (create_rel_constant (cs));
	     go to step;

action (8):					/* push_constant */
	     dt = macro_dt_inst (imac).data_type;

	     if dt ^= 0
	     then do;
		call push (create_constant (dt, addr (machine_instruction (imac + 1)) -> bit_image));
		imac = imac + data_type_size (dt);
		end;

	     else do;
		if left < 0
		then do;
		     left = stack (top) + bias;
		     top = top - 1;
		     end;
		call print_message (427, "push_constant_block");
		end;

	     go to step;

action (9):					/* convert_constant */
	     source = addr (rands (stack (top))) -> constant.value;
	     cdt = addr (rands (stack (top))) -> constant.data_type;
	     dt = macro_dt_inst (imac).data_type;
	     result = conv_round (dt, cdt) ((source), 0);
	     stack (top) = create_constant (dt, result);
	     go to step;

action (54):					/* push_count */
	     call push (left - bias);
	     go to step;

action (10):					/* push_count_indexed */
	     op1 = get_operand (mopnd);
	     i = stack (op1) + bias;

	     if i <= 0 | i > left
	     then call print_message (402, "push_count_indexed");

	     call push (half_array (i) - bias);

	     imac = imac + divide (left + 1, 2, 17, 0);
	     go to step;

action (11):					/* push_builtin */
	     call push ((builtins (left)));
	     go to step;

action (14):					/* call without error exit */
action (70):					/* call with error exit */
	     if mop = 14
	     then call setup_call (left, imac, 0, 0);
	     else do;
		imac = imac + 1;
		call setup_call (left, imac, (macro_instruction (imac).left), 0);
		end;

	     imac = left;
	     go to step;

action (15):					/* return */
	     if left = 0
	     then do;

		/* should be a proc invocation */

		if proc_frame.func
		then call print_message (403);

		call pop (base);
		end;

	     else do;

		/* should be a func invocation */

		if ^proc_frame.func
		then call print_message (404);

		i = macro_instruction (imac).eaq_name;
		if i = 0
		then do;

		     /* return operand name */

		     if proc_frame.scan_called
		     then do;

			/* When returning a temporary to the scan frame,
			   copy the attributes of the returned temporary
			   to the output temporary.  When returning a
			   non-temporary to the scan frame, replace
			   instances of the output temporary by the
			   returned operand. */

			op1 = stack (get_operand (mopnd));

			if op1 < 0		/* a count */
			then op1 = create_integer_constant (op1 + bias);

			if addr (rands (op1)) -> node.node_type ^= temporary_node
			then if op1 ^= quad_ptr -> operator.output
			     then if addr (rands (quad_ptr -> operator.output)) -> node.node_type = temporary_node
				then call replace_inputs ((quad_ptr -> operator.output), op1);
				else call print_message (465);
			     else ;		/* Just pop */
			else if op1 ^= quad_ptr -> operator.output
			then do;
			     k = quad_ptr -> operator.output;

			     /* Copy relevant attributes from specified operand to output temporary of
			        current operator. */

			     call assign_address_to_temp (k, op1);

			     /* change occurances of op1 in machine state to k */

			     if addr (rands (op1)) -> temporary.value_in.eaq
			     then do;
				do regno = 1 to hbound (current_ms.eaq, 1);
						/* A, Q, EAQ, IND */
				     do i = 1 to current_ms.eaq (regno).number;
					if current_ms.eaq (regno).variable (i) = op1
					then current_ms.eaq (regno).variable (i) = k;
					end;
				     end;

				addr (rands (op1)) -> temporary.value_in.eaq = "0"b;
				addr (rands (k)) -> temporary.value_in.eaq = "1"b;
				end;

			     if addr (rands (op1)) -> temporary.value_in.x
			     then do;
				do i = first_index to last_index;
				     if current_ms.index_regs (i).type = 1
				     then if current_ms.index_regs (i).variable = op1
					then current_ms.index_regs (i).variable = k;
				     end;

				addr (rands (op1)) -> temporary.value_in.x = "0"b;
				addr (rands (k)) -> temporary.value_in.x = "1"b;
				end;

			     if addr (rands (op1)) -> temporary.address_in_base
			     then do;
				do i = first_base to last_base;
				     if current_ms.base_regs (i).type = 1
				     then if current_ms.base_regs (i).variable = op1
					then current_ms.base_regs (i).variable = k;
				     end;

				addr (rands (op1)) -> temporary.address_in_base = "0"b;
				addr (rands (k)) -> temporary.address_in_base = "1"b;
				end;

			     if current_ms.last_dynamic_temp = op1
			     then current_ms.last_dynamic_temp = k;

			     end;

			else call assign_address_to_temp (op1, 0);

			call pop (base);
			end;

		     else do;			/* Not the scan frame. */
			op1 = get_operand (mopnd);
			k = stack (op1);
			stack (op1) = stack (base);
			if k < 0
			then stack (base) = create_integer_constant (k + bias);
			else stack (base) = k;

			call pop (base + 1);
			end;
		     end;

		else do;

		     /* return eaq_name */

		     call pop (base);

		     dt = dt_from_reg (i);

		     if proc_frame.scan_called
		     then do;
			temp = quad_ptr -> operator.output;

			call assign_address_to_temp (temp, 0);
			end;

		     else do;
			temp = assign_temp (dt);

			call push (temp);
			end;

		     /* Note:  return eaq_name should not be used to evaluate
		        a function such as min or max since the indicators
		        do not reflect the sign of the result.	*/

		     call in_reg (temp, i);
		     if i < in_ind
		     then current_ms.indicators_valid = eaq_name_to_reg (i);

		     end;
		end;

	     p = cur_frame;

	     call pop_frame;

	     /* now, actually return */

	     imac = p -> proc_frame.return;

	     if p -> proc_frame.interpreter_called
	     then do;
		go to p -> proc_frame.interpreter_return;
		end;

	     go to step;

action (16):					/* jump */
	     imac = left;
	     go to loop;

action (17):					/* scan */
rescan:
	     quad_ptr = addr (quad (iquad));
	     iquad = quad_ptr -> operator.next;
	     op_code = quad_ptr -> operator.op_code;
	     scan_proc = fort_opt_macros_$operator_table (op_code).entry;

	     err_flag = quad_ptr -> operator.output = ERROR;
						/* To check for ERROR operands */

	     next_operand = macro_dt_inst (scan_proc).data_type;
	     if next_operand = variable_count
	     then next_operand = quad_ptr -> operator.number;

	     do i = 1 by 1 while (i <= next_operand);
		if quad_ptr -> operator.operand (i) = ERROR
		then err_flag = "1"b;
		call push ((quad_ptr -> operator.operand (i)));
		end;

	     next_base = get_nextbase (scan_proc, next_operand);

	     if err_flag
	     then do;

operand_is_ERROR:
		call pop (next_base);

		if fixed (macro_instruction (scan_proc).op_code, 7) = function
		then call push (ERROR);

		i = macro_instruction (scan_proc).left;
		if i = 0
		then go to rescan;

		call setup_call (i, imac - 1, left, 0);
		imac = i;
		end;

	     else do;
		call setup_call (scan_proc, imac - 1, left, next_base);
		imac = scan_proc;
		end;

	     proc_frame.scan_called = "1"b;
	     go to step;

action (19):					/* s_call */
	     proc_frame.nshort = proc_frame.nshort + 1;
	     if proc_frame.nshort > hbound (proc_frame.short, 1)
	     then call print_message (407, "s_call stack", hbound (proc_frame.short, 1) - bias);
	     else proc_frame.short (proc_frame.nshort) = imac;
	     imac = left;
	     go to loop;

simple (3):					/* s_return */
	     if proc_frame.nshort < 0
	     then call print_message (408);
	     else do;
		imac = proc_frame.short (proc_frame.nshort);
		proc_frame.nshort = proc_frame.nshort - 1;
		end;

	     go to step;

action (21):					/* if_dt */
	     b2 = "1"b;
	     go to dt_join;

action (22):					/* unless_dt */
	     b2 = "0"b;

dt_join:
	     i = addr (rands (stack (top))) -> symbol.data_type;

	     if i <= 0 | i > length (macro_bits_inst (imac).bits)
	     then call print_message (445, stack (top), "data_type");
	     else b1 = substr (macro_bits_inst (imac).bits, i, 1);

	     go to if_join;

action (23):					/* if_optype */
	     b2 = "1"b;
	     go to optype_join;

action (24):					/* unless_optype */
	     b2 = "0"b;

optype_join:
	     if stack (top) > 0			/* item can be operand or count */
	     then do;
		i = addr (rands (stack (top))) -> symbol.operand_type;
						/* an operand */

		if i <= 0 | i > length (macro_bits_inst (imac).bits)
		then do;
		     call print_message (445, stack (top), "operand_type");
		     stop;
		     end;
		end;

	     else i = count_type;			/* a count */

	     b1 = substr (macro_bits_inst (imac).bits, i, 1);

	     go to if_join;

action (25):					/* (if unless)_array */
	     b2 = macro_cond_inst (imac).if_test;
	     p = addr (rands (stack (top)));
	     if p -> node.node_type = symbol_node
	     then b1 = p -> symbol.dimensioned;
	     else b1 = "0"b;
	     go to if_join;

action (26):					/* (if unless)_aligned */
	     b2 = macro_cond_inst (imac).if_test;
	     p = addr (rands (stack (get_operand (mopnd))));

	     if p -> node.units = char_units
	     then do;
		if p -> node.node_type = symbol_node
		then if p -> symbol.parameter
		     then b1 = "0"b;
		     else b1 = (p -> symbol.address.char_num = 0);

		else if p -> node.node_type = array_ref_node
		then if addr (rands (p -> array_ref.parent)) -> symbol.parameter
		     then b1 = "0"b;
		     else b1 = (p -> array_ref.address.char_num = 0 & ^cs -> subprogram.options.ansi_77);

		else b1 = (p -> node.address.char_num = 0);
		end;
	     else b1 = "1"b;

	     go to if_join;

action (27):					/* if_eaq */
	     b2 = "1"b;
	     go to eaq_join;

action (28):					/* unless_eaq */
	     b2 = "0"b;

eaq_join:
	     op1 = stack (get_operand (mopnd));

	     if addr (rands (op1)) -> node.value_in.eaq
	     then do;
		eaq_name = get_eaq_name (op1);
		if macro_instruction (imac).eaq_name = in_ind
		then b1 = (eaq_name > in_ind);
		else b1 = (eaq_name = macro_instruction (imac).eaq_name);
		end;

	     else b1 = "0"b;			/* op1 not in any eaq register */


	     /* Modified 2/2/78 to drop ref count if the argument is in the eaq. */

	     if b1
	     then call drop_count (op1, 1);

	     go to if_join;

action (29):					/* dt_jump */
	     dt1 = addr (rands (stack (top))) -> symbol.data_type;
	     dt2 = addr (rands (stack (top - 1))) -> symbol.data_type;

	     if dt1 <= 0
	     then call print_message (445, stack (top), "data_type");

	     else if dt1 = typeless_mode
	     then i = 19;

	     else if dt1 > cmpx_mode
	     then i = 17;

	     else if dt2 <= 0
	     then call print_message (445, stack (top - 1), "data_type");

	     else if dt2 = typeless_mode
	     then i = 20;

	     else if dt2 > cmpx_mode
	     then i = 18;

	     else i = 4 * (dt1 - 1) + dt2;

	     imac = half_array (i);
	     go to loop;

action (124):					/* dt_jump1 */
	     dt = addr (rands (stack (get_operand (mopnd)))) -> symbol.data_type;

	     if dt <= 0 | dt > last_assigned_mode
	     then do;
		call print_message (445, stack (get_operand (mopnd)), "data_type");
		stop;
		end;

	     imac = half_array (dt);
	     goto loop;

action (30):					/* ind_jump */
	     if current_ms.eaq (IND).name < tze
	     then call print_message (409);
	     else imac = half_array (current_ms.eaq (IND).name - tze + 1);

	     go to loop;

action (72):					/* if_ind */
	     b2 = "1"b;
	     go to ind_join;

action (73):					/* unless_ind */
	     b2 = "0"b;

ind_join:
	     if current_ms.eaq (IND).name >= in_ind & current_ms.eaq (IND).number > 0
	     then call print_message (410);

	     eaq_name = macro_instruction (imac).eaq_name;
	     regno = eaq_name_to_reg (eaq_name);
	     b1 = (current_ms.indicators_valid = regno);
	     go to if_join;

action (81):					/* (if unless)_parameter */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = get_operand (mopnd);
	     b1 = addr (rands (stack (op1))) -> symbol.parameter;
	     go to if_join;

action (82):					/* (if unless)_global */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));
	     b1 = addr (rands (op1)) -> node.globally_assigned;
	     go to if_join;

action (83):					/* (if unless)_induction_var */
	     b2 = macro_cond_inst (imac).if_test;
	     p = addr (rands (stack (get_operand (mopnd))));
	     b1 = is_induction_var (p);
	     go to if_join;

action (84):					/* (if unless)_fb17 */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));
	     p = find_range (addr (rands (op1)), cur_lp);
	     b1 = p -> range.fb17;
	     go to if_join;

action (85):					/* (if unless)_negative */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = get_operand (mopnd);
	     b1 = check_negative (stack (op1));
	     go to if_join;

action (86):					/* (if unless)_global_ind_var */
	     b2 = macro_cond_inst (imac).if_test;
	     p = addr (rands (stack (get_operand (mopnd))));
	     b1 = "0"b;
	     if p -> node.globally_assigned
	     then if is_induction_var (p)
		then b1 = "1"b;
	     go to if_join;

action (87):					/* (if unless)_local */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));
	     b1 = addr (rands (op1)) -> symbol.external & addr (rands (op1)) -> symbol.initial > 0;
	     go to if_join;

action (89):					/* (if unless)_main */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.subprogram_type = main_program;
	     go to if_join;

action (95):					/* (if unless)_needs_descriptors */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));
	     b1 = addr (rands (op1)) -> symbol.needs_descriptors;
	     go to if_join;

action (99):					/* (if unless)_namelist_used */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.namelist_used;
	     go to if_join;

action (118):					/* (if unless)_zero */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = check_zero ((stack (get_operand (mopnd))));
	     goto if_join;

action (101):					/* if_next_statement */
	     b2 = "1"b;
	     goto next_stmnt_join;

action (102):					/* unless_next_statement */
	     b2 = "0"b;

next_stmnt_join:
	     b1 = "0"b;				/* target is not next statement */
	     op1 = fixed (statement_ptr -> opt_statement.next, 18);

	     do while (op1 > 0);			/* find next executable st */
		if addr (quad (op1)) -> opt_statement.put_in_map
						/* an executable statement */
		then do;				/* return "1"b if lbl on next st */
		     b1 = addr (rands (stack (get_operand (mopnd)))) -> label.statement = op1;
		     goto if_join;
		     end;
		op1 = fixed (addr (quad (op1)) -> opt_statement.next, 18);
		end;
	     goto if_join;				/* no next st, no match */

action (31):					/* if */
	     b2 = "1"b;
	     go to unless_join;

action (32):					/* unless */
	     b2 = "0"b;

unless_join:
	     op1 = get_operand (mopnd);
	     op1 = stack (op1) + bias;

	     op2 = macro_if_inst (imac).with;
	     if op2 = 3
	     then op2 = stack (top) + bias;

	     relation = fixed (macro_if_inst (imac).relation, 3);
	     go to comp (relation);

comp (0):
	     b1 = op1 < op2;
	     go to if_join;

comp (1):
	     b1 = op1 > op2;
	     go to if_join;

comp (2):
	     b1 = op1 = op2;
	     go to if_join;

comp (3):
	     b1 = op1 ^= op2;
	     go to if_join;

comp (4):
	     b1 = op1 <= op2;
	     go to if_join;

comp (5):
	     b1 = op1 >= op2;

if_join:
	     if b1 = b2
	     then do;
		imac = left;
		go to loop;
		end;

	     go to step;

action (33):					/* jump_indexed */
	     op1 = get_operand (mopnd);
	     i = stack (op1) + bias;

	     if i <= 0 | i > left
	     then call print_message (402, "jump_indexed");
	     else imac = half_array (i);

	     go to loop;

action (34):					/* emit_inst & emit_data */
	     if mopnd = 0				/*  =0 is emit_data */
	     then do imac = imac + 1 to imac + left;
		     text_word (text_pos) = unspec (machine_instruction (imac));
		     text_pos = text_pos + 1;
		     end;
	     else do imac = imac + 1 to imac + left;	/* ^=0 is emit_inst */
		     call check_machine_state (fixed (machine_instruction (imac).op_code, 10), 0);
		     text_word (text_pos) = unspec (machine_instruction (imac));
		     text_pos = text_pos + 1;
		     end;
	     go to loop;

action (78):					/* assign_entry */
	     state_discarded = "0"b;

action (36):					/* rel_con */
	     call alloc_relcon ((stack (get_operand (mopnd))), text_pos);
	     goto step;

action (35):					/* label */
	     call alloc_label ((stack (get_operand (mopnd))), text_pos);
	     goto step;

action (37):					/* set_rel_constant */
	     call alloc_relcon ((stack (get_operand (mopnd))), stack (top) + bias);
	     top = top - 1;
	     go to step;

action (38):					/* add_to_address */
	     if left = 0
	     then do;
		if ^analyzing
		then instruction (text_pos - 1).offset = instruction (text_pos - 1).offset + stack (top) + bias;
		top = top - 1;
		end;

	     else do;
		op1 = get_operand (mopnd);

		if ^analyzing
		then do;
		     p = addr (rands (stack (op1)));

		     if p -> label.operand_type ^= rel_constant
		     then call print_message (411, stack (op1));

		     i = p -> label.location + stack (top - 1) + bias;
		     instruction (i).offset = instruction (i).offset + stack (top) + bias;
		     end;

		top = top - 2;
		end;

	     go to step;

action (39):					/* free_temp */
	     p = addr (rands (stack (get_operand (mopnd))));
	     if analyzing
	     then p -> temporary.ref_count_copy = 0;
	     else p -> temporary.ref_count = 0;
	     call free_temp (p);
	     go to step;

action (40):					/* reserve_regs */
	     call reserve_regs ((macro_regs_inst (imac).regs));
	     go to step;

action (41):					/* load_pr */
	     op1 = stack (get_operand (mopnd));

	     if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node
	     then a_name (text_pos) = op1;

	     call base_man_load_pr (op1, left, "1"b);
	     go to step;

action (112):					/* load_pr_value */
	     op1 = stack (get_operand (mopnd));

	     if assembly_list & addr (rands (op1)) -> node.node_type = symbol_node
	     then a_name (text_pos) = op1;

	     call base_man_load_pr_value (op1, left);
	     go to step;

simple (49):					/* desc_ptr_in_pr3 */
	     current_ms.base_regs (which_base (3)).type = 9;
	     current_ms.base_regs (which_base (3)).used = text_pos;
	     current_ms.base_regs (which_base (3)).variable = 0;
	     current_ms.base_regs (which_base (3)).offset = 0;
	     go to step;

simple (50):					/* arg_ptr_in_pr1 */
	     current_ms.base_regs (which_base (1)).type = 5;
	     current_ms.base_regs (which_base (1)).used = text_pos;
	     current_ms.base_regs (which_base (1)).variable = 0;
	     current_ms.base_regs (which_base (1)).offset = 0;
	     go to step;

simple (4):					/* free_regs */
	     call free_regs;
	     go to step;

action (44):					/* make_addressable */
action (71):
	     op1 = get_operand (mopnd);
	     call m_a (addr (rands (stack (op1))));

	     if mop = 71
	     then do;
		op2 = get_operand ((machine_instruction (imac).operand));
		call m_a (addr (rands (stack (op2))));
		end;

	     go to step;

action (42):					/* use_a */
	     call use_eaq (0, A, left);
	     go to step;

action (43):					/* use_q */
	     call use_eaq (0, Q, left);
	     go to step;

action (45):					/* use_eaq */
	     call use_eaq (0, EAQ, left);
	     go to step;

action (46):					/* load */
	     op1 = stack (get_operand (mopnd));

	     if op1 < 0				/* a count */
	     then op1 = create_integer_constant (op1 + bias);

	     call load (op1, (macro_instruction (imac).eaq_name));
	     go to step;

action (47):					/* load_top */
	     eaq_name = macro_instruction (imac).eaq_name;/* copy in case imac is changed */
	     temp = 0;				/* swap flag */

	     /* If both operands are in the eaq, and we are loading a
	        logical into the A, get any logical that might be in the
	        indicators into the A first.  This is a kludge, but it
	        prevents useless stores in some cases. */

	     if eaq_name = in_a
	     then if current_ms.eaq (IND).number > 0
		then if addr (rands (stack (top))) -> node.value_in.eaq
		     then if addr (rands (stack (top - 1))) -> node.value_in.eaq
			then call move_logical_to_a ();

	     /* If both operands are in the eaq, check the eaq names
	        and swap if the top operand is the wrong name but the
	        lower one is the right name. */

	     if addr (rands (stack (top))) -> node.value_in.eaq
	     then if addr (rands (stack (top - 1))) -> node.value_in.eaq
		then if get_eaq_name (stack (top)) ^= eaq_name
		     then if get_eaq_name (stack (top - 1)) = eaq_name
			then temp = 1;

	     /* If the top operand is not in the eaq, and the lower one is
	        or the top operand is constant, swap the operands. */

	     if ^addr (rands (stack (top))) -> node.value_in.eaq
	     then if addr (rands (stack (top - 1))) -> node.value_in.eaq
		     | addr (rands (stack (top))) -> node.node_type = constant_node
		     | addr (rands (stack (top))) -> node.node_type = char_constant_node
		then temp = 1;

	     if temp > 0
	     then do;
		k = stack (top - 1);
		stack (top - 1) = stack (top);
		stack (top) = k;

		/* If operands are swapped and a label is given, transfer to that label. */

		if left > 0
		then imac = left - 1;
		end;

	     call load ((stack (top)), eaq_name);

	     go to step;

action (113):					/* load_for_test */
	     op1 = stack (get_operand (mopnd));
	     op2 = macro_instruction (imac).eaq_name;
	     regno = eaq_name_to_reg (op2);

	     call load (op1, op2);

	     /* if indicators are invalid, set them with a compare */

	     if current_ms.indicators_valid ^= regno
	     then do;
		call emit_single ((compare_inst (op2)), (zero_for_dt (dt_from_reg (op2))));
		current_ms.indicators_valid = regno;
		end;
	     goto step;

action (111):					/* store */
	     op1 = stack (get_operand (mopnd));
	     call store (op1, (macro_instruction (imac).eaq_name), left);
	     go to step;

action (48):					/* in_reg */
	     op1 = stack (get_operand (mopnd));
	     call in_reg (op1, (macro_instruction (imac).eaq_name));
	     go to step;

action (49):					/* refresh_regs */
	     call refresh_regs (left);
	     go to step;

simple (6):					/* reset_eaq */
	     call reset_eaq (EAQ);
	     call reset_eaq (IND);
	     go to step;

simple (7):					/* use_ind */
	     call use_ind;
	     go to step;

simple (33):					/* ind_to_a */
	     call move_logical_to_a ();
	     go to step;

action (20):					/* set_inds_valid */
	     eaq_name = macro_instruction (imac).eaq_name;
	     current_ms.indicators_valid = eaq_name_to_reg (eaq_name);
	     go to step;

action (51):					/* increment */
	     op1 = get_operand (mopnd);
	     stack (op1) = stack (op1) + left;
	     go to step;

action (52):					/* decrement */
	     op1 = get_operand (mopnd);
	     stack (op1) = stack (op1) - left;
	     go to step;

action (53):					/* multiply */
	     op1 = get_operand (mopnd);

	     k = (stack (op1) + bias) * left;		/* form product */
	     if k >= bias
	     then call print_message (433, stack (op1), left - bias);
						/* product is too large to be count */
	     else stack (op1) = k - bias;		/* product ok */
	     go to step;

action (55):					/* push_bif_index */
	     op1 = get_operand (mopnd);
	     i = addr (rands (stack (op1))) -> symbol.char_size - bias;
	     call push (i);
	     go to step;

simple (21):					/* optimized_subscript */
	     call optimized_subscript (quad_ptr);
	     goto step;

action (64):					/* push_array_size */
	     op1 = get_operand (mopnd);
	     p = addr (rands (stack (op1)));
	     p = addr (rands (p -> symbol.dimension));

	     if p -> dimension.variable_array_size
	     then op1 = p -> dimension.array_size;
	     else op1 = create_integer_constant ((p -> dimension.array_size));

	     call push (op1);
	     go to step;

action (65):					/* print */
	     call setup_message_structure;
	     call print_message_op;
	     go to step;

action (66):					/* error */
	     if left ^= 0
	     then do;
		call setup_message_structure;
		call print_message_op;
		end;

	     do while (proc_frame.error_label = 0);
		cur_frame = proc_frame.prev;
		end;

	     /* In order to prevent errors later on, all operators to which this one is an input are
	        marked as receiving an ERROR operand. */

	     call replace_inputs ((quad_ptr -> operator.output), ERROR);

	     call pop (proc_frame.base);

	     p = cur_frame;

	     call pop_frame;

	     if ^p -> proc_frame.interpreter_called
	     then do;
		imac = p -> proc_frame.error_label;
		go to loop;
		end;

	     else do;
		imac = p -> proc_frame.return;
		go to p -> proc_frame.interpreter_return;
		end;

action (68):					/* push_length */
	     op1 = get_operand (mopnd);
	     p = addr (rands (stack (op1)));
	     call push (get_char_size (p));
	     go to step;

action (7):					/* emit_eis */
	     call emit_eis;
	     go to step;

simple (13):					/* end_unit */
	     if top ^= 0 | base > 1
	     then call print_message (425);

	     call leave_loop (lp_msp);

	     if analyzing & n_loops > 1
	     then do;
		call process_loop_end_lists;
		call reset_subprogram;
		end;

	     cur_subprogram = cs -> subprogram.next_subprogram;
	     if cur_subprogram = 0
	     then return;

	     call cleanup_loop_state_nodes;

	     call start_subprogram;
	     go to step;

action (76):					/* make_io_desc */
	     result = macro_regs_inst (imac).regs | bit (fixed (stack (top) + bias, 36), 36);
	     stack (top) = create_constant (int_mode, result);
	     go to step;

action (77):					/* (if unless)_one_word_dt */
	     b2 = macro_cond_inst (imac).if_test;
	     p = addr (rands (stack (get_operand (mopnd))));
	     if (p -> node.data_type = int_mode) | (p -> node.data_type = real_mode)
		| (p -> node.data_type = typeless_mode)
	     then b1 = "1"b;
	     else if (p -> node.data_type = char_mode)
	     then if (p -> node.node_type = symbol_node)
		then b1 = p -> symbol.char_size = 3 & ^p -> symbol.aliasable;
		else if (p -> node.node_type = char_constant_node)
		then b1 = p -> char_constant.length = 4;
		else b1 = "0"b;
	     else b1 = "0"b;
	     goto if_join;

simple (14):					/* stat */
	     cur_statement = fixed (rel (quad_ptr), 18);
	     statement_ptr = quad_ptr;

	     if fu ^= statement_ptr -> opt_statement.flow_unit
	     then do;

		/* changing flow_units - refresh the globally assigned registers */

		if fu ^= null
		then call refresh_regs (0);

		if analyzing & fu ^= null
		then call reset_scan (cur_statement, statement_ptr, iquad, fu, cur_lp);

		else do;
		     fu = statement_ptr -> opt_statement.flow_unit;

		     if fu -> flow_unit.loop ^= cur_lp
		     then do;

			/* changing loops - reset machine states accordingly */

			cur_lp = fu -> flow_unit.loop;
			call leave_loop (lp_msp);
			call enter_loop (cur_lp, lp_msp);
			end;
		     end;
		end;

	     if statement_ptr -> opt_statement.label ^= 0
	     then do;
		call alloc_label ((statement_ptr -> opt_statement.label), text_pos);
		end;

	     statement_ptr -> opt_statement.location = bit (text_pos, 18);

	     if generate_profile
	     then if statement_ptr -> opt_statement.put_in_profile
		then call build_profile_entry;
	     go to step;

simple (15):					/* check_parameters */
	     /*** Expects:

		count of parameters
		param1
		param2
		.
		.
		.
		paramn ***/
	     zarg = base;
	     n = stack (zarg) + bias;
	     virtual_origin_count = 0;

	     /* Perform entry descriptor processing to fill in arguments. */
	     /* We will put the node offset to the descriptor into the text section.
	        gen_entry_defs will later fill in the true text offset from the allocated
	        nodes. */
	     /* NOTE. We depend upon parm_desc_ptrsp being left set to the descriptor
	        block.  This is a relatively safe assumption however. */

	     do i = 1 to n;
		parm_desc_ptrs.descriptor_relp (i) = make_entry_descriptor ((stack (zarg + i)));

		k = fixed (rel (addr (parm_desc_ptrs.descriptor_relp (i))));
		if mod (i, 2) = 0
		then reloc (k).left_rel = rc_t;
		else reloc (k).right_rel = rc_t;
		end;

	     /* Next store pointers to multi-position parameters, and VLA
	        parameters. */

	     do i = 1 to n;
		p = addr (rands (stack (zarg + i)));

		if assembly_list & p -> node.node_type = symbol_node
		then a_name (text_pos) = stack (zarg + i);

		if p -> node.node_type = symbol_node
		then if p -> symbol.VLA
		     then do;

			/* Store pointers to Very Large Array parameters in the
			   VLA pointer blocks.  */

			bit3 = base_man_load_any_pr (2, 2 * i, 0);
			sym = addr (rands (p -> symbol.dimension)) -> dimension.VLA_base_addressor;
			s = addr (rands (sym));
			if VLA_is_256K
			then call emit_c_a_var ((store_packed_base (which_base (fixed (bit3, 3)))), s);
			else do;			/* 255K addressing */
			     if assembly_list
			     then a_name (text_pos) = fixed (rel (p));
			     unspec (inst_address) = "0"b;
			     inst_address.base = bit3;
			     inst_address.ext_base = "1"b;
			     call emit_c_a ((epaq), unspec (inst_address));
			     call emit_single ((qrl), 18 - bias);
			     call emit_c_a_var ((stq), s);
			     call emit_single ((lrl), 54 - bias);
			     inst_address.base = "000"b;
			     inst_address.offset = VLA_words_per_seg;
			     call emit_c_a ((mpy), unspec (inst_address));
			     call emit_c_a_var ((asq), s);
			     if assembly_list
			     then a_name (text_pos) = fixed (rel (p));
			     call emit_c_a ((store_packed_base (which_base (fixed (bit3, 3)))),
				c_a ((p -> symbol.address.offset), 6));
			     end;
			end;

		     else if p -> symbol.stack_indirect
		     then do;
			bit3 = base_man_load_any_pr (2, 2 * i, 0);
			if assembly_list & p -> node.node_type = symbol_node
			then a_name (text_pos) = stack (zarg + i);
			call emit_c_a ((store_base (which_base (fixed (bit3, 3)))), c_a ((p -> symbol.location), 6))
			     ;
			end;
		end;

	     /* Next store length of star extent character strings */

	     do i = 1 to n;
		p = addr (rands (stack (zarg + i)));

		if p -> node.node_type = symbol_node
		then if p -> symbol.v_length ^= 0
		     then do;
			if assembly_list & p -> node.node_type = symbol_node
			then a_name (text_pos) = stack (zarg + i);
			call get_param_char_size (p, i);
			end;
		end;

	     /* Finally compute bounds, etc. of variable extent arrays */

	     do i = 1 to n;
		p = addr (rands (stack (zarg + i)));
		if p -> node.node_type = symbol_node
		then if p -> symbol.dimensioned
		     then if p -> symbol.variable_extents | p -> symbol.star_extents
			then if p -> symbol.allocate
			     then do;
				if assembly_list & p -> node.node_type = symbol_node
				then a_name (text_pos) = stack (zarg + i);
				call get_param_array_size (p);
				end;
		end;

	     /* Last but not least emit code for star extent function allocation. */

	     if cs -> subprogram.star_extent_function
	     then do;
		p = addr (rands (cs -> subprogram.first_symbol));

		/* THIS DEPENDS UPON return_value BEING THE FIRST DEFINED SYMBOL IN THE FUNCTION. */

		call emit_single ((load_inst (in_q)), (p -> symbol.v_length));
		call emit_single ((adfx1), 3 - bias);	/* adq 3 */
		call emit_single ((qrs), 2 - bias);	/* qrs 2 */
		call flush_base (which_base (2));
		call emit_operator_call ((alloc_auto_adj));
		call emit_c_a ((store_base (which_base (2))), c_a ((p -> symbol.location), 6));

		/* If the return_value_param has a descriptor, copy to our descriptor. */

		if addr (rands (stack (zarg + n))) -> symbol.hash_chain ^= 0 & p -> symbol.hash_chain ^= 0
		then do;
		     call emit_single ((load_inst (in_q)), (addr (rands (stack (zarg + n))) -> symbol.hash_chain));
		     call emit_single ((store_inst (in_q)), (p -> symbol.hash_chain));
		     end;
		call reset_eaq (Q);
		end;

	     go to step;

action (80):					/* push_char_temp */
	     if left < 0
	     then do;

		/* have count */

		left = stack (top) + bias;
		top = top - 1;
		end;

	     call push (assign_char_temp (left));
	     go to step;

simple (16):					/* check_arg_list */
	     call check_arg_list;
	     go to step;

simple (17):					/* store_arg_addrs */
	     /*** Expects:

		external reference
		number of arguments
		arg1
		arg2
		.
		.
		.
		argn
		arglist temp ***/
	     zarg = base + 1;
	     n = stack (zarg) + bias;
	     temp = stack (zarg + n + 1);

	     do i = 1 to n;				/* Modification to reserve base register used for source, so that "m_a" will
						   not re-use it if > 16K addresses are present in the store. */

		k = get_free_reg (current_ms.base_regs, first_base, last_base, 0, 0);
		call base_man_load_pr ((stack (zarg + i)), k, "0"b);
		current_ms.base_regs (k).reserved = "1"b;
						/* Protect Register */

		if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node
		then a_name (text_pos) = stack (zarg + i);

		call emit_single_with_inc (store_base (k), temp, 2 * i);
		current_ms.base_regs (k).reserved = "0"b;
						/* Release base */
		end;

	     go to step;

action (91):					/* (if unless)_constant_addrs */
	     b2 = macro_cond_inst (imac).if_test;
	     zarg = base + 1;
	     n = stack (zarg) + bias;
	     b1 = n <= hbound (itp_list, 1);

	     /* If descriptors must be supplied with this call, we cannot use
	        an ITP argument list.  This is because the constant nodes for
	        the argument list and the descriptors will not be allocated
	        until later, and we must know the addresses now. */

	     /* If we have a VLA parameter then we MUST make a correct
	        pointer to it, since we cannot indirect through the stack
	        or the linkage section through a packed pointer. */

	     if addr (rands (stack (base))) -> symbol.needs_descriptors
	     then b1 = "0"b;

	     do i = 1 to n while (b1);
		p = addr (rands (stack (zarg + i)));

		if assembly_list & p -> node.node_type = symbol_node
		then a_name (text_pos) = stack (zarg + i);

		if p -> node.node_type = symbol_node & p -> symbol.VLA
		then b1 = "0"b;			/* VLA is non-constant */

		if ^p -> node.is_addressable | ^p -> node.allocated
		     | p -> node.ext_base & ^(p -> node.base = sp | p -> node.base = lp)
		then b1 = "0"b;
		end;

	     go to if_join;

action (93):					/* get_quick_label */
	     op1 = get_operand (mopnd);
	     k = stack (op1);
	     if addr (rands (k)) -> symbol.external
	     then k = addr (rands (k)) -> symbol.initial;
	     stack (op1) = addr (rands (k)) -> symbol.initial;
	     go to step;

simple (18):					/* gen_itp_list */
	     unspec (arg_list.header) = "0"b;
	     zarg = base + 1;
	     n = stack (zarg) + bias;
	     arg_list.arg_count = 2 * n;

	     do i = 1 to n;
		p = addr (rands (stack (zarg + i)));
		call set_itp_addr (p, i);
		call drop_count ((stack (zarg + i)), 1);
		end;

	     stack (top) = create_constant_block (addr (arg_list), 2 * n + 2);
	     go to step;

simple (19):					/* make_descriptors */
	     if addr (rands (stack (base))) -> symbol.needs_descriptors
	     then do;
		zarg = base + 1;
		n = stack (zarg) + bias;
		temp = stack (zarg + n + 1);

		skip = 2 * n;
		if addr (rands (stack (base))) -> symbol.parameter
		then skip = skip + 2;

		do i = 1 to n;
		     desc = make_descriptor ((stack (zarg + i)));
						/* Modification to reserve base register in case "emit_single_with_inc" causes
						   long (>16K) addressing and "m_a" requires extra pointer. */

		     k = get_free_reg (current_ms.base_regs, first_base, last_base, 0, 0);

		     if assembly_list & addr (rands (stack (zarg + i))) -> node.node_type = symbol_node
		     then a_name (text_pos) = stack (zarg + i);

		     call base_man_load_pr (desc, k, "0"b);
		     current_ms.base_regs (k).reserved = "1"b;
						/* Protect Register */
		     call emit_single_with_inc (store_base (k), temp, skip + 2 * i);
		     current_ms.base_regs (k).reserved = "0"b;
						/* Release base */
		     end;

		end;

	     go to step;

simple (42):					/* free_descriptors */
	     do while (desc_temp_chain ^= 0);
		p = addr (rands (desc_temp_chain));
		desc_temp_chain = p -> temporary.next;
		call free_temp (p);
		end;

	     go to step;

simple (20):					/* set_runtime_block_loc */
	     addr (rands (stack (base))) -> symbol.hash_chain = text_pos;
	     go to step;

action (104):					/* push_operand */
	     next_operand = next_operand + 1;

	     if next_operand > quad_ptr -> operator.number
	     then do;
		imac = left;
		goto loop;
		end;

	     if quad_ptr -> operator.operand (next_operand) = ERROR
	     then goto operand_is_ERROR;

	     call push ((quad_ptr -> operator.operand (next_operand)));
	     goto step;

action (105):					/* compare */
	     op1 = stack (get_operand (mopnd));
	     b1 = check_zero (op1);
	     eaq_name = macro_instruction (imac).eaq_name;
	     regno = eaq_name_to_reg (eaq_name);

	     /* Force temps in any eaq register to storage before eaq state
	        is destroyed or branch is taken.  Do NOT remove this stmt
	        without checking min/max/dim code */

	     call save_eaq_temps (op1, EAQ, 0);

	     if current_ms.indicators_valid ^= regno | ^b1
	     then do;

		if do_rounding & ^current_ms.rounded
		then if (eaq_name = in_eaq) | (eaq_name = in_deaq)
		     then if (eaq_name = current_ms.eaq (regno).name) | (eaq_name ^= in_deaq)
			     | (current_ms.eaq (regno).name = 0)
			then do;
			     if current_ms.eaq (regno).name ^= 0
			     then i = round_inst (current_ms.eaq (regno).name);
			     else i = round_inst (eaq_name);
			     call emit_zero (i);
			     current_ms.rounded = "1"b;
			     end;

		call emit_single ((compare_inst (eaq_name)), op1);

		if b1
		then current_ms.indicators_valid = regno;
		else current_ms.indicators_valid = 0;

		end;

	     goto step;

simple (22):					/* sub_index */
	     op1 = quad_ptr -> operator.operand (1);	/* subscript expression */
	     op2 = quad_ptr -> operator.output;

	     p = addr (rands (op1));
	     if ^p -> node.is_addressable
	     then call m_a (p);

	     xr = fixed (substr (xr_man_load_any_xr (p), 4, 3), 3);
						/* get index reg no */
	     call drop_count (op1, 1);
	     p -> node.value_in.x = "0"b;

	     call xr_man_update_xr (op2, xr);
	     goto step;

simple (32):					/* drop_all_counts */
	     do i = top - quad_ptr -> operator.number + 1 to top;
		call drop_count ((stack (i)), 1);
		end;
	     goto step;

action (109):					/* flush_ref */
	     op1 = stack (get_operand (mopnd));
	     call flush_ref (op1);
	     goto step;

action (110):					/* save_state */
	     op1 = stack (get_operand (mopnd));
	     lbl = addr (rands (op1));

	     if left >= 2
	     then discard = left;
	     else discard = 0;

	     if ^lbl -> label.allocated		/* i.e., this is a forward reference */
	     then if ^addr (quad (lbl -> label.statement)) -> opt_statement.referenced_by_assign
		then do;
		     st = addr (quad (lbl -> label.statement));

		     /* If target has an operator list, insure that all temporaries on that list that
		        are in registers but not in storage are stored. */

		     do p = st -> opt_statement.operator_list repeat p -> primary.next while (p ^= null);

			k = p -> primary.expression -> operator.output;
			if k > 0			/* Might be ERROR or 0 if temp was freed */
			then if addr (rands (k)) -> node.not_in_storage
			     then if addr (rands (k)) -> temporary.value_in.eaq
				then do;		/* Value in eaq */

				     eaq_name = get_eaq_name (k);

				     if eaq_name > in_ind
				     then do;
					call move_logical_to_a ();
					eaq_name = in_a;
					end;

				     if ^do_rounding | current_ms.rounded
				     then i = store_no_round_inst (eaq_name);
				     else i = store_inst (eaq_name);

				     call emit_temp_store (i, k);

				     end;

				else if addr (rands (k)) -> temporary.value_in.x
				then do;		/* Value in an index reg. */
				     do i = first_index to last_index
					while (current_ms.index_regs (i).type ^= 1
					| current_ms.index_regs (i).variable ^= k);
					end;
				     call emit_temp_store (sxl0 + i, k);
				     end;
			end;			/* loop thru operator list */

		     /* Now save the state at the target, but only if target is not backward ref. */

		     if ^st -> opt_statement.referenced_backwards
		     then call save_state (op1);

		     end;				/* code to process target label */

	     if discard = 0
	     then goto step;			/* simple(23), discard_state, must follow. */

simple (23):					/* discard_state */
						/* Must immediately follow action(110), save_state */
	     call discard_state;
	     goto step;

action (114):					/* set_in_storage */
	     op1 = stack (get_operand (mopnd));
	     addr (rands (op1)) -> node.not_in_storage = "0"b;
	     goto step;

action (115):					/* bump */
	     call bump_count ((stack (get_operand (mopnd))), left);
	     goto step;

action (116):					/* drop */
	     call drop_count ((stack (get_operand (mopnd))), left);
	     goto step;

simple (24):					/* push_output */
	     op1 = quad_ptr -> operator.output;
	     if addr (rands (op1)) -> node.node_type = temporary_node
	     then call assign_address_to_temp (op1, 0);
	     call push (op1);
	     goto step;

action (121):					/* push_ref_count */
	     call push (get_ref_count (addr (rands (stack (get_operand (mopnd))))) - bias);
	     goto step;

simple (25):					/* bump_args */
	     do i = base + 2 to base + 2 + stack (base + 1) + bias - 1;
		op1 = stack (i);
		if op1 > 0
		then if addr (rands (op1)) -> node.node_type = temporary_node
		     then call bump_count (op1, 1);
		end;
	     goto step;

simple (26):					/* drop_args */
	     do i = base + 2 to base + 2 + stack (base + 1) + bias - 1;
		op1 = stack (i);
		if op1 > 0
		then if addr (rands (op1)) -> node.node_type = temporary_node
		     then call drop_count (op1, 1);
		end;
	     goto step;

action (123):					/* float_power_of_fpbase */
	     op1 = get_operand (mopnd);
	     p = addr (rands (stack (op1)));

	     /* If we have a floating power of fpbase > -127, then replace operand
	        with proper exponent for ADE instruction. */

	     if p -> node.node_type = constant_node
	     then if p -> constant.data_type = real_mode | p -> constant.data_type = dp_mode
		then do;
		     unspec (floating_value) = p -> constant.value;

		     if floating_value.mantissa = mantissa_of_power_of_fpbase & floating_value.exponent > -127
		     then do;
			floating_value.mantissa = "0"b;
			floating_value.exponent = floating_value.exponent - 1;
			if macro_instruction (imac).eaq_name ^= 0
			then floating_value.exponent = -floating_value.exponent;
			stack (op1) = create_constant (real_mode, unspec (floating_value));
			imac = left;
			go to loop;
			end;
		     end;

	     go to step;

action (125):					/* pad_char_const_to_word */
	     op1 = get_operand (mopnd);

	     if addr (rands (stack (op1))) -> char_constant.length = chars_per_word
	     then goto step;

	     else if addr (rands (stack (op1))) -> char_constant.length > chars_per_word
	     then call print_message (443, chars_per_word - bias, (stack (op1)));

	     substr (char_temp, 1, chars_per_word) = addr (rands (stack (op1))) -> char_constant.value;
	     stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_word));
	     goto step;

action (126):					/* pad_char_const_to_dw */
	     op1 = get_operand (mopnd);

	     if addr (rands (stack (op1))) -> char_constant.length = chars_per_dw
	     then goto step;

	     else if addr (rands (stack (op1))) -> char_constant.length > chars_per_dw
	     then call print_message (443, chars_per_dw - bias, (stack (op1)));

	     substr (char_temp, 1, chars_per_dw) = addr (rands (stack (op1))) -> char_constant.value;
	     stack (op1) = create_char_constant (substr (char_temp, 1, chars_per_dw));
	     goto step;

action (127):					/* power_of_two */
	     op1 = get_operand (mopnd);
	     p = addr (rands (stack (op1)));

	     /* If power of two then replace operand with power of two and jump to address. */

	     if p -> node.node_type ^= constant_node
	     then goto step;

	     if p -> constant.data_type ^= int_mode
	     then goto step;

	     if addr (p -> constant.value) -> int_image <= 0
	     then goto step;

	     i = index (p -> constant.value, "1"b);	/* find high-order bit */

	     if substr (p -> constant.value, i + 1, 36 - i) = "0"b
						/* all other bits are zero */
	     then do;
		stack (op1) = (36 - i) - bias;	/* Replace power of two with count. */

		imac = left;			/* set transfer location. */
		goto loop;
		end;
	     goto step;

simple (29):					/* set_rounded */
	     current_ms.rounded = "1"b;
	     go to step;

action (108):					/* round */
	     if do_rounding & ^current_ms.rounded
	     then do;
		eaq_name = macro_instruction (imac).eaq_name;
		call emit_zero ((round_inst (eaq_name)));
		current_ms.rounded = "1"b;
		current_ms.indicators_valid = eaq_name_to_reg (eaq_name);
		end;

	     go to step;

simple (30):					/* load_xreg */
	     next_lp = fu -> flow_unit.successors -> edge.to.value -> flow_unit.loop;

	     /* This assigns an index register to stack(base) over the loop
	        nest following this flow_unit.  We attempt to avoid x6 because
	        that register is modified by I/O operations.  Note
	        that stack(top) is actually loaded. */

	     if ^next_lp -> loop.all_xrs_globally_assigned
	     then do;
		b1 = current_ms.index_regs (6).reserved;
		if ^current_ms.index_regs (6).global
		then current_ms.index_regs (6).reserved = "1"b;
		end;

	     if analyzing | stack (base) = stack (top)
	     then do;
		p = addr (rands (stack (base)));
		bit6 = xr_man_load_any_xr (p);
		regno = fixed (substr (bit6, 4, 3), 3);

		/* Deal with strange case of induction var busy_on_exit
		   from loop, but which might not be initialized on entry
		   to the loop. */

		if p -> node.node_type = symbol_node
		then do;
		     i = p -> symbol.coordinate;
		     if substr (next_lp -> loop.induction_var -> bits, i, 1)
			& substr (next_lp -> loop.busy_on_exit -> bits, i, 1)
		     then if ^definitely_initialized (i, fu)
			then do;
			     call emit_temp_store (stz, (stack (base)));
			     if substr (fu -> flow_unit.busy_on_exit -> bits, i, 1)
			     then call emit_temp_store (sxl0 + regno, (stack (base)));
			     end;
		     end;
		end;

	     else do;
		call flush_ref ((stack (base)));
		regno = get_free_reg (current_ms.index_regs, first_index, last_index, 0, 0);
		call xr_man_load_xr (addr (rands (stack (top))), regno, (stack (base)));
		if next_lp -> loop.erases.xr (regno)
		then call emit_temp_store (sxl0 + regno, (stack (base)));
		end;

	     if ^next_lp -> loop.all_xrs_globally_assigned
	     then current_ms.index_regs (6).reserved = b1;

	     call drop_count ((stack (top)), 1);
	     call drop_count ((stack (base)), 1);

	     current_ms.index_regs (regno).reserved = "1"b;

	     if ^analyzing
	     then call assign_register (next_lp, INDEX, regno, 1, (stack (base)), 0);
	     go to step;

simple (31):					/* load_preg */
	     next_lp = fu -> flow_unit.successors -> edge.to.value -> flow_unit.loop;
	     p = addr (rands (stack (top)));

	     /* This assigns a base register to stack(top) over the loop nest
	        following this flow_unit. */

	     base_man_args.code = p -> pointer.code;
	     base_man_args.variable = p -> pointer.variable;
	     base_man_args.offset = p -> pointer.offset;

	     if string (next_lp -> loop.avoid_pr)
	     then call avoid_prs (string (next_lp -> loop.avoid_pr));

	     bit3 = base_man_dispatch (base_man_args.code, base_man_args.variable, base_man_args.offset);
	     regno = which_base (fixed (bit3, 3));

	     if next_lp -> loop.avoid_pr (regno)
	     then do;

		/* This register was supposed to have been avoided.
		   Erase and try again!! */

		call flush_base (regno);
		current_ms.base_regs (regno).type = -1;
		bit3 = base_man_dispatch (base_man_args.code, base_man_args.variable, base_man_args.offset);
		regno = which_base (fixed (bit3, 3));
		end;

	     if string (next_lp -> loop.avoid_pr)
	     then call restore_pr_locks;

	     /* Fix for bug 358.  Correctly lock a base reserved by a 'load_preg'.
	        by not doing this the count of ptr_data.max_locked, and ptr_data.locked is
	        too low and we have a good chance of running out of registers. */

	     call lock_base (regno);

	     if ^analyzing
	     then call assign_register (next_lp, BASE, regno, base_man_args.code, base_man_args.variable,
		     base_man_args.offset);
	     go to step;

simple (34):					/* assign_index */
	     call assign_index ((stack (base)), (stack (base + 1)));
	     go to step;

simple (35):					/* compare_index */
	     call compare_index ((stack (base)), (stack (base + 1)));
	     go to step;

simple (36):					/* test_index */
	     call compare_index ((stack (base)), builtins (0));
	     go to step;

simple (37):					/* increment_index */
	     call increment_index ((stack (base + 1)), (stack (base)), +1);
	     go to step;

simple (38):					/* decrement_index */
	     call increment_index ((stack (base + 1)), (stack (base)), -1);
	     go to step;

simple (40):					/* refresh_regs_if_next_is_jump */
	     /*** This code attempts to eliminate flushing of indicators by
		refresh_regs before a conditional jump at the end of a flow_unit. ***/
	     if lp_msp ^= null
	     then if addr (quad (iquad)) -> operator.operand (1) = quad_ptr -> operator.output
		then if addr (quad (iquad)) -> operator.op_code = jump_true_op
			| addr (quad (iquad)) -> operator.op_code = jump_false_op
		     then call refresh_regs (0);

	     go to step;

simple (41):					/* note_eligible_ind_var_use */
	     /*** If an eligible induction variable appears in an incrementing
		or comparison context and index registers are not erased in this
		loop, then the use should be recorded in the global database. ***/
	     if analyzing
	     then if substr (string (cur_lp -> loop.erases.xr), 3) ^= "111111"b
		then do i = base by 1 while (i <= top);
			if stack (i) > 0
			then do;
			     p = addr (rands (stack (i)));
			     if is_induction_var (p)
			     then if eligible (p)
				then call add_global_index (p);
			     end;
			end;

	     go to step;

simple (43):					/* force_ql */
	     if ^analyzing
	     then instruction (text_pos - 1).tag = QL_mod;

	     go to step;

simple (44):					/* int_to_char1 */
	     p = addr (rands (stack (top)));
	     if p -> node.node_type = constant_node & p -> node.data_type = int_mode
	     then do;
		char1 = byte (addr (p -> constant.value) -> int_image);
		call push (create_char_constant (char1));
		end;
	     else call print_message (462);

	     go to step;

simple (45):					/* char1_to_int */
	     p = addr (rands (stack (top)));
	     if p -> node.node_type = char_constant_node
	     then do;
		temp = rank (substr (p -> char_constant.value, 1, 1));
		call push (create_integer_constant ((temp)));
		end;
	     else call print_message (463);

	     go to step;

action (59):					/* set_next_operand */
	     next_operand = left - 1;
	     go to step;


action (57):					/* start_cat */
	     call start_cat (b1);
	     if b1
	     then do;				/* Skip first mlr */
		imac = left;
		go to loop;
		end;
	     else go to step;

simple (46):					/* continue_cat */
	     call continue_cat ();
	     go to step;

simple (47):					/* finish_cat */
	     call finish_cat ();
	     go to step;

action (58):					/* shorten_stack */
	     if current_ms.stack_extended
	     then do;
		call reserve_regs (shorten_stack_mask);
		if left > 0			/* Protect indicators? */
		then call emit_operator_call (shorten_stack_protect_ind);
		else do;
		     call use_ind ();
		     call emit_operator_call (shorten_stack);
		     end;

		current_ms.stack_extended = "0"b;
		current_ms.last_dynamic_temp = 0;

		call free_regs ();
		end;

	     go to step;

simple (27):					/* push_operand_count */
	     call push (quad_ptr -> operator.number - bias);
	     go to step;

action (60):					/* (if unless)_ansi77 */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.options.ansi_77;
	     go to if_join;

simple (48):					/* set_needs_descriptors */
	     addr (rands (stack (base))) -> symbol.needs_descriptors = "1"b;
	     go to step;

action (69):					/* (if unless)_variable_arglist */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));
	     b1 = addr (rands (op1)) -> symbol.variable_arglist;
	     go to if_join;

action (74):					/* (if unless)_char_star_function */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.star_extent_function;
	     go to if_join;

action (75):					/* (if unless)_check_multiply */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.options.check_multiply;
	     go to if_join;


action (79):					/* (if unless)_storage_created */
	     b2 = macro_cond_inst (imac).if_test;
	     if Area_create_first >= 0
	     then b1 = "1"b;
	     else b1 = "0"b;
	     go to if_join;

action (88):					/* (if unless)_VLA */
	     b2 = macro_cond_inst (imac).if_test;
	     op1 = stack (get_operand (mopnd));

	     /* Only VLA if it is a symbol, which is VLA. */

	     if addr (rands (op1)) -> node.node_type = symbol_node
	     then b1 = addr (rands (op1)) -> symbol.VLA;
	     else b1 = "0"b;
	     go to if_join;

action (90):					/* (if unless)_cleanup */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = alloc_auto_cleanup;
	     go to if_join;


simple (52):					/* emit_cleanup_args */
	     text_halfs (text_pos).left = cleanup_body_address;
	     if assembly_list
	     then a_name (text_pos) = -1;		/* tell listing generator this is not an inst */
	     text_pos = text_pos + 1;
	     go to step;


simple (53):					/* emit_storage_args */
	     if Area_create_first < 0			/* See if storage */
	     then do;
		text_halfs (text_pos).left = fixed ("777777"b3, 18);
		reloc (text_pos).left_rel = rc_a;	/* leave absolute */
		end;
	     else do;
		text_halfs (text_pos).left = Area_create_first;
		reloc (text_pos).left_rel = rc_t;	/* relocate in text */
		end;

	     if Area_init_first < 0			/* See if initialization */
	     then do;
		text_halfs (text_pos).right = fixed ("777777"b3, 18);
		reloc (text_pos).right_rel = rc_a;	/* leave absolute */
		end;
	     else do;
		text_halfs (text_pos).right = Area_init_first;
		reloc (text_pos).right_rel = rc_t;	/* relocate in text */
		end;

	     if assembly_list
	     then a_name (text_pos) = -1;		/* list in octal */

	     text_pos = text_pos + 1;
	     goto step;


simple (54):					/* emit_profile_entry */
	     if ^(generate_profile & generate_long_profile)
	     then goto step;

	     call emit_profile_dummy;
	     call emit_profile_dummy;

	     call emit_profile_control;
	     call emit_profile_control;

	     call emit_profile_dummy;

	     goto step;


emit_profile_dummy:
     proc;

	/* emit a long_profile reference to long_profile_header.dummy */

	call emit_operator_call (long_profile);
	text_halfs (text_pos).left = profile_start;
	reloc (text_pos).left_rel = rc_is18;

	/* emit relative offset from long_profile_header to dummy entry */

	text_halfs (text_pos).right = 5;		/* dummy offset */
	reloc (text_pos).right_rel = rc_a;
	text_pos = text_pos + 1;
	return;
     end emit_profile_dummy;


emit_profile_control:
     proc;

	/* emit a long_profile reference to long_profile_header.control */

	call emit_operator_call (long_profile);
	text_halfs (text_pos).left = profile_start;
	reloc (text_pos).left_rel = rc_is18;

	/* emit relative offset from long_profile_header to control entry */

	text_halfs (text_pos).right = 9;		/* control offset */
	reloc (text_pos).right_rel = rc_a;
	text_pos = text_pos + 1;
	return;
     end emit_profile_control;

simple (56):					/* emit_entry_defs */
	     /*** Expects:

		entry label
		count of parameters


		Make pointer to descriptor area we will build later.

		We will allocate space to put the node offset to the
		descriptor in the text section. This will later be filled
		by 'check_parameters' to hold the index of the constant
		node, then gen_entry_defs will later fill in the true text
		offset from the allocated nodes.

		This code is split into the three sections, this,
		check_parameters, and gen_entry_defs, since at this point
		we need to reserve space, but have not yet seen the quads
		or polish defining the parameters. At check parameters we
		put in the node offset to the descriptor, since it may not
		have been allocated, and forward refs only relocate the
		left half of an instruction. Finally at gen_entry_defs time
		we convert the node index to a text offset because all text
		allocations have been made at that time. ***/
	     zarg = base + 2;
	     n = stack (base + 1) + bias;

	     parm_desc_ptrsp = addr (text_word (text_pos));
	     parm_desc_ptrs.n_args = n;
	     k = text_pos;

	     /* Skip allocated area, and setup descr_relp_offset */

	     text_pos = text_pos + divide (n, 2, 18) + 1;
	     text_halfs (text_pos).left = k;
	     text_halfs (text_pos).right = 0;

	     reloc (text_pos).left_rel = rc_t;
	     reloc (text_pos).right_rel = rc_a;
	     text_pos = text_pos + 1;
	     go to step;

simple (57):					/* rhs_fld */
	     call rhs_fld;
	     goto step;

simple (58):					/* lhs_fld */
	     call lhs_fld;
	     goto step;

action (92):					/* (if unless)_hfp */
	     b2 = macro_cond_inst (imac).if_test;
	     b1 = cs -> subprogram.options.hfp;
	     goto if_join;

	     /* These macro opcodes are unused, or (if named) are used only by the
	        non-optimizing code generator. */

simple (5):					/* reset_regs */
simple (8):					/* start_subscript */
simple (9):					/* next_subscript */
simple (10):					/* finish_suscript */
simple (11):					/* subscript_error */
simple (12):					/* s_func_finish */
simple (28):					/* skip_data */
simple (39):					/* make_substring */
simple (51):
	     call print_message (436, left - bias);
	     goto step;

action (5):					/* push_variable */
action (18):					/* exit */
action (50):					/* push_sf_arg_count */
action (56):					/* (if unless)_saving_stack_extent */
action (61):					/* s_func_label */
action (62):					/* push_s_func_label */
action (63):					/* push_s_func_var */
action (94):
action (96):
action (97):
action (98):
action (100):
action (103):
action (106):
action (107):
action (117):
action (119):
action (120):
action (122):
	     call print_message (436, mop - bias);
	     goto step;

	     /* THESE SHOULD NOT EXECUTE */
action (0):					/* undefined */
action (12):					/* func */
action (13):					/* proc */
action (67):					/* used by rest_of_error */
	     call print_message (413);

step:
	     end;

/**** STACK FRAME MANIPULATION ****/

push:
     procedure (i);

	/* Pushes an item onto the operand stack */

dcl  i fixed binary (18);

	top = top + 1;

	if top > hbound (stack, 1)
	then do;
	     call print_message (407, "operand stack", hbound (stack, 1) - bias);
	     return;
	     end;

	stack (top) = i;

     end push;

copy:
     procedure (opnd);

	/* Copies an operand onto the top of the stack */

dcl  (opnd, op) fixed binary (18);

	op = opnd;

	call push (op);

     end copy;

pop:
     procedure (thru);

	/* Pops the stack through thru -- top becomes thru - 1 */

dcl  thru fixed binary (18);				/* pop through thru */

	top = thru - 1;

     end pop;

pop_frame:
     procedure ();

	/* Pops a procedure frame */

	cur_frame = cur_frame -> proc_frame.prev;
	base = cur_frame -> proc_frame.base;

     end pop_frame;

get_operand:
     procedure (opnd) returns (fixed binary (18));

	/* Takes an operand number as specified in a macro and returns
	   the corresponding operand stacksubscript. */

dcl  opnd fixed binary (18);				/* Operand number specified in macro */

dcl  i fixed binary (18);

	if opnd < 0
	then return (top + opnd + 1);			/* opn */
	else if opnd > 0
	then return (base + opnd - 1);		/* argn */
	else do;

	     /* opv */

	     i = stack (top) + bias;
	     top = top - 1;
	     return (top - i + 1);
	     end;

     end get_operand;

interpreter_proc:
     procedure (mac_num, ret_lab);

	/* Calls an interpreter macro procedure.  ret_lab must
	   be set to the label of the stmt immediately following
	   the call to interpreter_proc.

	   Note that this scheme is really an attempt to escape the
	   necessity for recursion in invoking interpreter macro
	   procedures.  To be truly safe, this should have recursively
	   invoked the entire interpreter.  For this scheme to work,
	   all procedures between the caller and the interpreter MUST
	   be quick, and none of them (including the caller) must be
	   invoked during the processing of the interpreter macro
	   procedure.  This is necessary to ensure that no local
	   variables are destroyed.  Obviously a procedure is safe if
	   its last statement results in a call to interpreter_proc;
	   the interesting cases arise when some other statement in
	   a procedure directly or indirectly invokes interpreter_proc.

	   Of course, this is illegal PL/I. */

dcl  mac_num fixed binary (18),			/* Macro number of interpreter procedure */
     ret_lab label local;				/* Label to return to */

dcl  macro_proc fixed binary (18);

	macro_proc = fort_opt_macros_$interpreter_macros (mac_num).entry;

	call setup_call (macro_proc, imac, imac, 0);

	proc_frame.interpreter_called = "1"b;
	proc_frame.interpreter_return = ret_lab;

	imac = macro_proc;
	go to step;

     end interpreter_proc;

setup_call:
     procedure (macro_proc, return, error_exit, nb);

	/* Pushes a new procedure frame and sets it up for a call */

dcl  macro_proc fixed binary (18),			/* Procedure being called */
     return fixed binary (18),			/* Location from which the call is being made */
     error_exit fixed binary (18),			/* Location to jump to if errors occur */
     nb fixed binary (18);				/* Presupplied next_base if ^= 0 */

dcl  (mac_proc, next_base) fixed binary (18);

	mac_proc = macro_proc;

	if nb = 0
	then next_base = get_nextbase (mac_proc, not_given);
	else next_base = nb;

	/* get next procedure frame */

	if cur_frame -> proc_frame.next ^= null
	then cur_frame = cur_frame -> proc_frame.next;
	else cur_frame = create_proc_frame ();

	/* initialize next procedure frame */

	string (proc_frame.flags) = "0"b;

	if fixed (macro_instruction (mac_proc).op_code, 7) = function
	then proc_frame.func = "1"b;

	proc_frame.return = return;
	proc_frame.error_label = error_exit;
	base, proc_frame.base = next_base;
	proc_frame.nshort = 0;

     end setup_call;

create_proc_frame:
     procedure () returns (pointer);

	/* Allocates a procedure frame in the operand region */

dcl  p pointer;

	if mod (next_free_operand, 2) ^= 0
	then do;
	     rands (next_free_operand) = 0;		/* for debugging */
	     next_free_operand = next_free_operand + 1;
	     end;


	p = addr (rands (next_free_operand));
	next_free_operand = next_free_operand + size (proc_frame);

	if next_free_operand >= operand_max_len
	then do;
	     call print_message (407, "operand region", char (operand_max_len));
						/* FATAL */
	     return (null);				/* should never be executed */
	     end;

	if cur_frame ^= null
	then cur_frame -> proc_frame.next = p;

	unspec (p -> proc_frame) = "0"b;
	p -> proc_frame.prev = cur_frame;
	p -> proc_frame.next = null;
	return (p);

     end create_proc_frame;

get_nextbase:
     procedure (macro_proc, args) returns (fixed binary (18));

	/* Calculates base of new stack frame */

dcl  macro_proc fixed binary (18);			/* Proc being called */

dcl  (args, nargs) fixed binary (18);

	nargs = args;

	if nargs = not_given
	then nargs = macro_dt_inst (macro_proc).data_type;

	if nargs = variable_count
	then if mop = 17				/* scan macro */
	     then nargs = quad_ptr -> operator.number;
	     else call print_message (437);		/* must be scan frame */
	else if mop = 17				/* scan macro */
	then if nargs > quad_ptr -> operator.number	/* for DEBUGGING */
	     then call print_message (438, nargs - bias, quad_ptr -> operator.number - bias);
						/* for DEBUGGING */
	return (top - nargs + 1);

     end get_nextbase;

/**** TEMPORARY MANAGEMENT ****/

assign_temp:
     procedure (data_type) returns (fixed binary (18));

	/* Assigns a temporary of a specific data type */

dcl  data_type fixed binary (4);

dcl  (clength, dt, size, temp) fixed binary (18);

	dt = data_type;
	size = data_type_size (dt);
	go to join;


assign_char_temp:
     entry (char_length) returns (fixed binary (18));

	/* Assigns a character temporary */

dcl  char_length fixed binary (18);

	dt = char_mode;
	clength = char_length;
	size = divide (clength + chars_per_word - 1, chars_per_word, 17, 0);
	go to join;


assign_block:
     entry (block_size) returns (fixed binary (18));

	/* Assigns a doubleword aligned block */

dcl  block_size fixed binary (18);

	size = block_size;
	size = size + mod (size, 2);
	dt = 0;

join:
	temp = get_temp (size);
	addr (rands (temp)) -> temporary.data_type = dt;
	if analyzing
	then addr (rands (temp)) -> temporary.ref_count_copy = 1;
	else addr (rands (temp)) -> temporary.ref_count = 1;
	addr (rands (temp)) -> temporary.dont_update = "0"b;
	addr (rands (temp)) -> temporary.used_as_subscript = "0"b;
	addr (rands (temp)) -> temporary.units = word_units;

	if dt = char_mode
	then do;
	     addr (rands (temp)) -> temporary.length = clength;
	     if cs -> subprogram.options.ansi_77
	     then addr (rands (temp)) -> temporary.units = char_units;
	     end;

	return (temp);

get_temp:
     procedure (amount) returns (fixed binary (18));

	/* Finds a free temporary of the desired size */

dcl  (amt, amount, i, prev, temp) fixed binary (18);

	amt = amount;

	if amt <= 2
	then do;
	     i = amt;
	     temp = free_temps (i);

	     if temp ^= 0
	     then do;
		free_temps (i) = addr (rands (temp)) -> temporary.next;
		return (temp);
		end;
	     end;

	else do;
	     i = 3;
	     prev = 0;
	     temp = free_temps (3);

	     do while (temp ^= 0);

		if addr (rands (temp)) -> temporary.size >= amt
		then do;
		     if prev = 0
		     then free_temps (3) = addr (rands (temp)) -> temporary.next;
		     else addr (rands (prev)) -> temporary.next = addr (rands (temp)) -> temporary.next;
		     return (temp);
		     end;

		prev = temp;
		temp = addr (rands (temp)) -> temporary.next;
		end;
	     end;

	if i > 1
	then if mod (last_auto_loc, 2) ^= 0
	     then do;

		/* force doubleword alignment */

		temp = create_temp (1);
		addr (rands (temp)) -> temporary.next = free_temps (1);
		free_temps (1) = temp;
		end;

	return (create_temp (amt));

     end get_temp;

     end assign_temp;

get_temp_node:
     procedure () returns (fixed binary (18));

	/* Gets a temp node off the free chain or allocates a new one. */

dcl  size builtin;
dcl  temp fixed binary (18);

	if next_free_temp = 0
	then temp = create_node (temporary_node, size (temporary));
	else do;
	     temp = next_free_temp;
	     next_free_temp = addr (rands (temp)) -> temporary.next;

	     unspec (addr (rands (temp)) -> temporary) = "0"b;
	     addr (rands (temp)) -> temporary.node_type = temporary_node;
	     end;

	return (temp);

     end get_temp_node;

create_temp:
     procedure (amount) returns (fixed binary (18));

	/* Creates a new temporary, possibly reusing a discarded
	   temporary node. */

dcl  (amount, op_type, temp) fixed binary (18);
dcl  amt fixed binary (18);
dcl  loc fixed binary (18);
dcl  p pointer;

	temp = get_temp_node ();
	op_type = temp_type;
	amt = amount;
	loc = last_auto_loc;

	if loc + amt > max_stack_size
	then call print_message (414, "in making a temporary the stack frame", max_stack_size - bias);
	else last_auto_loc = loc + amt;

	p = addr (rands (temp));

	p -> temporary.operand_type = op_type;
	string (p -> temporary.addressing_bits), string (p -> temporary.bits) = "0"b;

	p -> temporary.is_addressable, p -> temporary.allocate, p -> temporary.allocated = "1"b;

	unspec (p -> temporary.address) = ext_base_on;
	p -> temporary.base = sp;

	if op_type = temp_type
	then do;
	     p -> temporary.size = amt;
	     p -> temporary.not_in_storage = "1"b;
	     end;

	p -> temporary.next = 0;

	p -> temporary.units = word_units;

	call set_address_offset (p, loc, amt, word_units);

	return (temp);

     end create_temp;

assign_address_to_temp:
     procedure (a_temp, a_new);

	/* Assigns address to temp from second arg, or
	   insures that first arg has an address. In the
	   latter case, the second arg must be zero. */

dcl  a_temp fixed binary (18);			/* Temp that may need an address */
dcl  a_new fixed binary (18);				/* Temp that provides an address */

dcl  (temp, new) fixed binary (18);
dcl  (temp_pt, new_pt) pointer;

	temp = a_temp;
	temp_pt = addr (rands (temp));
	new = a_new;
	new_pt = addr (rands (new));

	/* Make sure we are not processing temp with ref_count of 0 */

	if get_ref_count (temp_pt) = 0
	then do;
	     if ^analyzing
	     then call print_message (454, temp);
	     return;
	     end;

	/* if temp has address, return; in this case, arg 2 must be zero */

	if unspec (temp_pt -> temporary.address) ^= "0"b
	then do;
	     if new ^= 0 & ^analyzing
	     then do;
		call print_message (442);
		call free_temp (new_pt);
		end;
	     return;
	     end;

	/* get address if not provided by caller */

	if new = 0
	then do;
	     if temp_pt -> temporary.data_type = char_mode
	     then new = assign_char_temp ((temp_pt -> temporary.length));
	     else new = assign_temp ((temp_pt -> temporary.data_type));
	     new_pt = addr (rands (new));
	     end;

	/* copy address over to target temp */

	string (temp_pt -> temporary.addressing_bits) =
	     string (temp_pt -> temporary.addressing_bits) | string (new_pt -> temporary.addressing_bits);
	if new_pt -> temporary.stack_indirect		/* Dynamic temp */
	then temp_pt -> temporary.addr_hold = new_pt -> temporary.addr_hold;

	temp_pt -> temporary.address = new_pt -> temporary.address;

	temp_pt -> temporary.location = new_pt -> temporary.location;
	temp_pt -> temporary.dont_update = "0"b;	/* because analysis may have left this on */

	/* copy size over to target temp */

	temp_pt -> temporary.size = new_pt -> temporary.size;
	if temp_pt -> temporary.data_type = char_mode
	then do;
	     temp_pt -> temporary.variable_length = new_pt -> temporary.variable_length;
	     temp_pt -> temporary.length = new_pt -> temporary.length;
	     new_pt -> temporary.variable_length = "0"b;
	     new_pt -> temporary.length = 0;
	     end;

	/* take address from source temp, then free it */

	unspec (new_pt -> temporary.address) = "0"b;
	call free_temp (new_pt);

     end assign_address_to_temp;

free_temp:
     procedure (temp_ptr);

	/* Procedure to free a temporary.  If the temporary has
	   variable length, the reference count of the associated
	   length temporary is decremented, and that temporary is
	   freed if necessary. */

dcl  temp_ptr pointer;				/* Pointer to temp node */

dcl  (tp, ltp) pointer;				/* To temp, length temp */
dcl  count fixed binary (18);				/* Reference count */

	tp = temp_ptr;

	if tp -> temporary.variable_length
	then do;

	     /* Must deal with associated length temporary */

	     ltp = addr (rands (tp -> temporary.length));
	     if ltp -> node.node_type = temporary_node
	     then do;
		if analyzing
		then count, ltp -> temporary.ref_count_copy = ltp -> temporary.ref_count_copy - 1;
		else count, ltp -> temporary.ref_count = ltp -> temporary.ref_count - 1;
		if count <= 0
		then call free_one_temp (ltp);
		tp -> temporary.length = 0;
		tp -> temporary.variable_length = "0"b;
		end;
	     end;

	call free_one_temp (tp);

     end free_temp;

free_one_temp:
     procedure (temp_ptr);

	/* This procedure flushes a temporary from the machine state
	   and threads it onto the appropriate free list. */

dcl  temp_ptr pointer;				/* Pointer to temp node */

dcl  tp pointer;					/* To temp node */
dcl  (temp, prev_temp, this_temp) fixed binary (18);
dcl  temp_size fixed binary (18);

	tp = temp_ptr;
	temp = fixed (rel (tp), 18);

	if tp -> temporary.ms_ref_count < 0 | tp -> temporary.ref_count < 0 | tp -> temporary.ref_count_copy < 0
	then do;
	     call print_message (415, temp);
	     return;
	     end;

	if unspec (tp -> temporary.address) = "0"b
	then do;

	     /* This temp has no address; it was either used as a
	        place holder or to give another temp an address. */

	     if tp -> temporary.ms_ref_count > 0	/* temp is still a place holder */
		| tp -> temporary.output_by ^= 0	/* temp will be reused in CG pass */
	     then return;
	     tp -> temporary.next = next_free_temp;
	     next_free_temp = temp;
	     return;
	     end;

	tp -> temporary.not_in_storage = "1"b;
	tp -> temporary.dont_update = "1"b;
	tp -> temporary.globally_assigned = "0"b;

	temp_size = tp -> temporary.size;

	call flush_ref (temp);
	call flush_addr (temp);
	call disconnect_temp (tp);

	/* If the machine state ref count is > 0, the temp cannot be
	   freed but its storage can be freed. To free the storage,
	   allocate a new temp and give it the storage; then put the new
	   temp on the free list.  During the analysis pass, temporaries
	   that are connected to operators cannot be freed because they
	   will be needed by the CG pass. */

	if tp -> temporary.ms_ref_count > 0 | tp -> temporary.output_by > 0
	then do;
	     this_temp = get_temp_node ();

	     addr (rands (this_temp)) -> temporary = tp -> temporary;
	     unspec (tp -> temporary.address) = "0"b;

	     temp = this_temp;
	     tp = addr (rands (this_temp));
	     tp -> temporary.output_by = 0;
	     end;

	if tp -> temporary.stack_indirect
	then do;

	     /* Restore the address of a dynamic temporary */

	     unspec (tp -> temporary.address) = tp -> temporary.addr_hold;
	     tp -> temporary.address.ext_base = "1"b;
	     tp -> temporary.needs_pointer = "0"b;
	     tp -> temporary.is_addressable = ^tp -> temporary.large_address;
	     tp -> temporary.stack_indirect = "0"b;
	     end;

	/* One and two word temps have their own free lists */

	if temp_size < 3
	then do;
	     call thread_temp (temp, temp_size, 0);
	     return;
	     end;

	/* Larger temps go on the third free list, sorted by size */

	prev_temp = 0;
	this_temp = free_temps (3);
	do while (this_temp ^= 0);

	     if temp_size <= addr (rands (this_temp)) -> temporary.size
	     then do;
		call thread_temp (temp, 3, prev_temp);
		return;
		end;

	     prev_temp = this_temp;
	     this_temp = addr (rands (this_temp)) -> temporary.next;

	     end;

	/* Temp is larger than any on the free list. */

	call thread_temp (temp, 3, prev_temp);

     end free_one_temp;

thread_temp:
     procedure (temp, chain, prev);

	/* Threads temp onto the free list specified by chain after
	   the temp prev. */

dcl  (temp, chain, prev) fixed binary (18);

	if prev = 0
	then do;

	     /* Put temp at beginning of free list */

	     addr (rands (temp)) -> temporary.next = free_temps (chain);
	     free_temps (chain) = temp;
	     end;

	else do;
	     addr (rands (temp)) -> temporary.next = addr (rands (prev)) -> temporary.next;
	     addr (rands (prev)) -> temporary.next = temp;
	     end;

     end thread_temp;

disconnect_temp:
     procedure (p);

	/* Disconnects temp or array_ref from operator that produced it */

dcl  p pointer;

dcl  o pointer;

	if ^analyzing & p -> temporary.output_by > 0
	then do;
	     o = addr (quad (p -> temporary.output_by));
	     o -> operator.output = 0;
	     p -> temporary.output_by = 0;
	     end;

     end disconnect_temp;

/**** DYNAMIC TEMPORARY MANAGEMENT ****/

assign_dynamic_temp:
     procedure () returns (fixed binary (18));

	/* This procedure allocates and initializes a dynamic
	   character temporary, but emits no code.  Dynamic temps
	   are implemented as two word temporaries which hold a
	   pointer to the actual stack extension. */

dcl  t fixed binary (18);				/* Two word temp */
dcl  p pointer;					/* Pointer to it */

	t = assign_block (2);
	p = addr (rands (t));

	p -> temporary.data_type = char_mode;
	p -> temporary.stack_indirect = "1"b;
	p -> temporary.needs_pointer = "1"b;
	p -> temporary.is_addressable = "0"b;

	p -> temporary.addr_hold = substr (unspec (p -> temporary.address), 1, 18);
	p -> temporary.reloc_hold = p -> temporary.reloc;

	unspec (p -> temporary.address) = ext_base_on;
	p -> temporary.reloc = rc_a;

	return (t);

     end assign_dynamic_temp;

allocate_dynamic_temp:
     procedure (temp, tv_offset);

	/* Emits code to extend the stack for a dynamic temporary.
	   The parameter tv_offset should be set to either
	   allocate_char_string or reallocate_char_string. */

dcl  temp fixed binary (18);				/* Temporary node */
dcl  tv_offset fixed binary (14);			/* Operator offset */

dcl  p pointer;

	p = addr (rands (temp));

	call bump_count ((p -> temporary.length), 1);
	call load ((p -> temporary.length), in_q);
	call use_eaq (0, EAQ, 0);
	call flush_base (which_base (2));
	call emit_operator_call ((tv_offset));

	current_ms.stack_extended = "1"b;
	current_ms.address_in_base = "1"b;
	p -> temporary.address_in_base = "1"b;
	p -> temporary.address.base = bases (which_base (2));

	cur_lp -> loop.avoid_pr (which_base (2)) = "1"b;

	current_ms.last_dynamic_temp = temp;

	current_ms.base_regs (which_base (2)).variable = temp;
	current_ms.base_regs (which_base (2)).type = 1;
	current_ms.base_regs (which_base (2)).used = text_pos;
	current_ms.base_regs (which_base (2)).offset = 0;

     end allocate_dynamic_temp;

/**** EMISSION OF OBJECT CODE ****/

emit_inst:
     procedure ();

	/* Emits an instruction of object code */

dcl  (inc, rand) fixed binary (18);

	if string (machine_instruction (imac).ext_base_and_tag) ^= "0"b
	then do;
	     call check_machine_state (fixed (machine_instruction (imac).op_code, 10), 0);
	     text_word (text_pos) = unspec (machine_instruction (imac));
	     end;

	else do;

	     /* have an operand */

	     inc = machine_instruction (imac).increment;
	     rand = get_operand ((machine_instruction (imac).operand));

	     call put_word ((machine_instruction (imac)), (stack (rand)), inc);
	     end;

	text_pos = text_pos + 1;

     end emit_inst;

emit_single:
     procedure (mac_num, rand);

	/* Emits an instruction from a table of single instructions */

dcl  mac_num fixed binary (18),			/* Single instruction number */
     rand fixed binary (18);				/* Operand for the inst */
dcl  inc fixed binary (18);

	inc = fort_opt_macros_$single_inst (mac_num).increment;

	call put_word ((fort_opt_macros_$single_inst (mac_num)), (rand), inc);

	text_pos = text_pos + 1;
	return;


emit_single_with_inc:
     entry (mac_num, rand, incr);

	/* Emits an instruction with a specified address increment */

dcl  incr fixed binary (18);

	inc = incr;


	call put_word ((fort_opt_macros_$single_inst (mac_num)), (rand), inc);

	text_pos = text_pos + 1;

     end emit_single;

emit_with_tag:
     procedure (mac_num, address, tag);

	/* Emits an instruction with a constant address and a tag field */

dcl  mac_num fixed binary (18),
     address fixed binary (18),
     tag bit (6) aligned;

dcl  1 inst like machine_instruction aligned;

	text_word (text_pos) = unspec (fort_opt_macros_$single_inst (mac_num)) & mask_left;
	instruction (text_pos).tag = tag;
	text_halfs (text_pos).left = address;
	text_pos = text_pos + 1;
	return;
     end emit_with_tag;

emit_zero:
     procedure (mac_num);

	/* Emits an instruction without operands */

dcl  mac_num fixed binary (18);

	if analyzing
	then return;

	text_word (text_pos) = unspec (fort_opt_macros_$single_inst (mac_num));
	text_pos = text_pos + 1;

     end emit_zero;

emit_c_a:
     procedure (mac_num, address);

	/* Emits an instruction given an address probably supplied by c_a */

dcl  mac_num fixed binary (18);			/* Single instruction number */
dcl  address bit (36) aligned;

	if analyzing
	then return;

	text_word (text_pos) = (unspec (fort_opt_macros_$single_inst (mac_num)) & mask_left) | address;

	if fort_opt_macros_$single_inst (mac_num).increment ^= 0
	then if instruction (text_pos).ext_base
	     then instruction (text_pos).offset =
		     instruction (text_pos).offset + fort_opt_macros_$single_inst (mac_num).increment;
	     else text_halfs (text_pos).left =
		     text_halfs (text_pos).left + fort_opt_macros_$single_inst (mac_num).increment;

	text_pos = text_pos + 1;

     end emit_c_a;

emit_c_a_var:
     procedure (mac_num, var_ptr);

	/* Emits an instruction and reloc and listing info given an operand whose address
	   must already be filled in so that m_a need not be called. */

dcl  mac_num fixed binary (18);			/* Single instruction number */
dcl  var_ptr pointer;				/* Pointer to node for operand */

	if analyzing
	then return;

	reloc (text_pos).left_rel = var_ptr -> node.reloc;

	if assembly_list
	then if var_ptr -> node.node_type = array_ref_node
	     then a_name (text_pos) = var_ptr -> array_ref.parent;
	     else a_name (text_pos) = binary (rel (var_ptr), 18, 0);

	call emit_c_a ((mac_num), unspec (var_ptr -> node.address));

     end emit_c_a_var;

emit_c_a_const:
     procedure (mac_num, c_off);

	/* Emits an instruction referencing a constant */

dcl  mac_num fixed binary (18);			/* Instruction template offset */
dcl  c_off fixed binary (18);				/* Const node offset to be used */
dcl  const pointer;
dcl  1 inst like machine_instruction aligned;

	if analyzing
	then return;

	inst = fort_opt_macros_$single_inst (mac_num);
	const = addr (rands (c_off));

	text_word (text_pos) = (unspec (inst) & mask_left) | unspec (const -> constant.address);

	reloc (text_pos).left_rel = const -> constant.reloc;

	call text_ref (const, (inst.increment), fixed (inst.op_code, 10), 0);

	text_pos = text_pos + 1;

     end emit_c_a_const;

emit_temp_store:
     procedure (mac_no, temp);

	/* Emits code to store a temporary, indicators are not affected */

dcl  mac_no fixed binary (18);			/* Mac num of inst to store temp */
dcl  temp fixed binary (18);				/* Node to be stored */

dcl  mac_num fixed binary (18);
dcl  p pointer;

	mac_num = mac_no;
	p = addr (rands (temp));

	if ^p -> node.is_addressable
	then call m_a_except_xreg (p);

	call emit_c_a_var (mac_num, p);
	p -> node.not_in_storage = "0"b;

     end emit_temp_store;

emit_operator_call:
     procedure (tv_offset);

	/* Emits an instruction of the form tsx0 pr0|tv_offset. */

dcl  tv_offset fixed binary (14);
dcl  1 inst aligned like instruction;

	if analyzing
	then return;

	unspec (inst) = ext_base_on;
	inst.offset = tv_offset;
	inst.op = "1110000000"b;			/* 700 (0) - tsx0 */

	text_word (text_pos) = unspec (inst);
	text_pos = text_pos + 1;

     end emit_operator_call;

put_word:
     procedure (inst, p_rand, inc);

	/* Uses inst as a template to put out an instruction with
	   rand as an operand and inc as the increment */

dcl  1 inst like machine_instruction parameter aligned,
     p_rand fixed binary (18),
     inc fixed binary (18);

dcl  p pointer;

dcl  rand fixed binary (18);
dcl  mop fixed binary (18);
dcl  decrement_address bit (1);

	mop = fixed (inst.op_code, 10);

	rand = p_rand;

	if rand < 0
	then do;
	     if fort_instruction_info_$fort_instruction_info_ (mop).A
		| fort_instruction_info_$fort_instruction_info_ (mop).Q
		| fort_instruction_info_$fort_instruction_info_ (mop).indicators
	     then call check_machine_state (mop, 0);

	     if analyzing
	     then return;

	     /* have a count, make it the address */

	     text_word (text_pos) = unspec (inst) & mask_left;

	     /* use direct modifier if possible */

	     if directable (mop)
	     then instruction (text_pos).tag = DL_mod;	/* dl */

	     text_halfs (text_pos).left = rand + bias + inc;
	     return;
	     end;

	p = addr (rands (rand));

	if ^p -> node.is_addressable
	then do;
	     if inc ^= 0
	     then do;
		if p -> node.node_type = array_ref_node
		then if ^p -> array_ref.has_address
		     then if analyzing
			then call optimized_subscript (addr (quad (p -> array_ref.output_by)));
			else do;
			     call print_message (446, fixed (rel (p), 18));
			     stop;
			     end;

		if p -> node.address.ext_base
		then do;
		     call increment_address (p, (inc));
		     decrement_address = "1"b;
		     end;
		end;
	     call m_a (p);
	     end;
	else decrement_address = "0"b;

	if fort_instruction_info_$fort_instruction_info_ (mop).A
	     | fort_instruction_info_$fort_instruction_info_ (mop).Q
	     | fort_instruction_info_$fort_instruction_info_ (mop).indicators
	then call check_machine_state (mop, rand);

	if analyzing
	then do;
	     if decrement_address
	     then call increment_address (p, -inc);
	     call drop_count (rand, 1);
	     return;
	     end;

	text_word (text_pos) = (unspec (inst) & mask_left) | unspec (p -> node.address);

	reloc (text_pos).left_rel = p -> node.reloc;

	if assembly_list
	then if p -> node.node_type = array_ref_node
	     then a_name (text_pos) = p -> array_ref.parent;
	     else a_name (text_pos) = rand;

	if substr (unspec (p -> node.address), 30, 7) = "0000000"b
	then call text_ref (p, (inc), mop, 0);
	else if inc ^= 0
	then if instruction (text_pos).ext_base
	     then if decrement_address
		then call increment_address (p, -inc);
		else instruction (text_pos).offset = instruction (text_pos).offset + inc;
	     else text_halfs (text_pos).left = text_halfs (text_pos).left + inc;

	call drop_count (rand, 1);

     end put_word;

check_machine_state:
     procedure (inst_op_code, sym);

	/* Checks if inst to be emitted modifies machine state, if so use_eaq or use_ind is called */

dcl  inst_op_code fixed binary (18);			/* Op code of instr to be emitted */
dcl  sym fixed binary (18);				/* Variable currently in q or zero */
dcl  opc fixed binary (18);
dcl  s fixed binary (18);
dcl  reg fixed binary (18);
dcl  (
     fstr initial (624),
     dfstr initial (628)
     ) fixed binary internal static;

	opc = inst_op_code;
	s = sym;

	if fort_instruction_info_$fort_instruction_info_ (opc).A & fort_instruction_info_$fort_instruction_info_ (opc).Q
	then reg = EAQ;

	else if fort_instruction_info_$fort_instruction_info_ (opc).A
	then reg = A;

	else if fort_instruction_info_$fort_instruction_info_ (opc).Q
	then reg = Q;

	else reg = 0;

	if reg > 0
	then call use_eaq (s, reg, 0);

	if fort_instruction_info_$fort_instruction_info_ (opc).indicators
	then if reg > 0
	     then current_ms.indicators_valid = reg;

	     else if fort_instruction_info_$fort_instruction_info_ (opc).XR
	     then current_ms.indicators_valid =
		     index (fort_instruction_info_$fort_instruction_info_ (opc).XR, "1"b) + highest_ind_state;

	     else if opc = fstr & current_ms.eaq (EAQ).name = in_eaq | opc = dfstr & current_ms.eaq (EAQ).name = in_deaq
	     then current_ms.indicators_valid = EAQ;

	     else call use_ind ();

     end check_machine_state;

text_ref:
     procedure (pt, inc, mop, desc_no);

	/* Handles reference to the text section */

dcl  pt pointer;					/* Points to addressed node */
dcl  inc fixed binary (18);				/* Address increment */
dcl  mop fixed binary (18);				/* Instruction opcode */
dcl  desc_no fixed binary (18);			/* EIS descriptor number, or 0 */

dcl  temp fixed binary (18);
dcl  (p, q) pointer;
dcl  use_dl bit (1) aligned;
dcl  value bit (36) aligned;

dcl  (
     ldq initial ("236"b3),
     lcq initial ("336"b3),
     adq initial ("076"b3),
     sbq initial ("176"b3)
     ) bit (10) aligned internal static options (constant);

dcl  mf (0:2) fixed binary (6) internal static options (constant) initial (31, 31, 13);
						/* Location of MF within instruction */


	p = pt;

	q = null ();
	if p -> node.node_type = constant_node
	then q = addr (p -> constant.value);
	else if p -> node.node_type = char_constant_node
	then do;
	     value = unspec (p -> char_constant.value);
	     q = addr (value);
	     end;

	if q ^= null ()
	then if inc = 0
	     then if directable (mop)
		then do;

		     /* Attempt to use DL modification for any constant,
		        unless it is an operand of an EIS instruction. */

		     if (q -> half.left = 0) & (desc_no = 0)
		     then do;
			text_halfs (text_pos).left = q -> half.right;
			instruction (text_pos).tag = DL_mod;
						/* dl */
			reloc (text_pos).left_rel = rc_a;
			return;
			end;

		     /* Attempt to use DU modification for any constant,
		        unless it is the first operand of an EIS instruction. */

		     if (q -> half.right = 0) & (desc_no ^= 1)
		     then do;
			text_halfs (text_pos).left = q -> half.left;
			substr (text_word (text_pos - desc_no), mf (desc_no), 6) = DU_mod;
			reloc (text_pos).left_rel = rc_a;
			return;
			end;

		     if q -> int_image < 0
		     then do;

			/* attempt to optimize negative constants */

			temp = -q -> int_image;
			q = addr (temp);

			if q -> half.left = 0
			then do;
			     use_dl = "1"b;

			     if instruction (text_pos).op = ldq
			     then instruction (text_pos).op = lcq;

			     else if instruction (text_pos).op = adq
			     then instruction (text_pos).op = sbq;

			     else if instruction (text_pos).op = sbq
			     then instruction (text_pos).op = adq;

			     else if instruction (text_pos).op = lcq
			     then instruction (text_pos).op = ldq;

			     else use_dl = "0"b;

			     if use_dl
			     then do;
				text_halfs (text_pos).left = q -> half.right;
				instruction (text_pos).tag = DL_mod;
				reloc (text_pos).left_rel = rc_a;
				return;
				end;
			     end;
			end;
		     end;

	p -> node.allocate = "1"b;

	if ^p -> node.allocated
	then do;
	     text_halfs (text_pos).left = inc;

	     /* add this forward reference to a list of forward refs */

	     if next_free_polish >= polish_max_len
	     then call print_message (407, "polish region", char (polish_max_len));

	     if p -> node.operand_type = external
	     then p = addr (rands (p -> symbol.initial));

	     next_free_polish = next_free_polish + 1;

	     forward_refs (next_free_polish - 1).operand = fixed (rel (p), 18);
	     forward_refs (next_free_polish - 1).instruction = text_pos;

	     end;

	else if inc ^= 0
	then text_halfs (text_pos).left = text_halfs (text_pos).left + inc;

	/* try to use a direct modifier with a rel_constant */

	if p -> node.operand_type = rel_constant
	then if directable (mop)
	     then instruction (text_pos).tag = DL_mod;	/* dl */

     end text_ref;

emit_eis:
     procedure ();

	/* Emits a single EIS instruction, presently assumed to
	   be 1 instruction word + 2 descriptor words.  Only
	   desc9a is allowed for now.  An example follows:

	   emit_eis

	   mlr	(pr),(pr),fill(040)
	   desc9a	op1
	   desc9a	arg2+3

	   If the length field is omitted, which is the usual
	   case, the interpreter supplies it.  The interpreter
	   supplies the Modification Fields.  All operands are
	   assumed to be character strings.  If the equal_lengths
	   keyword is given, the length of the second operand is
	   taken to be identical to the length of the first. */

dcl  arg (2) pointer;
dcl  op (2) fixed binary (18);
dcl  len (2) fixed binary (18);
dcl  lreg (2) bit (6) aligned;
dcl  inc (2) fixed binary (18);
dcl  opcode bit (10) aligned;

dcl  1 descriptor (0:262143) based (object_base) aligned,
       2 word_address bit (18) unaligned,
       2 char bit (2) unaligned,
       2 bit bit (4) unaligned,
       2 length bit (12) unaligned;

dcl  mf (3) fixed binary (6) internal static options (constant) initial (30, 12, 3);

dcl  (
     cmpc initial ("0010001101"b),			/* 106 (1) */
     scm initial ("0010101001"b),			/* 124 (1) */
     scd initial ("0010100001"b)
     )						/* 120 (1) */
	bit (10) aligned internal static options (constant);

dcl  (i, inst_pos) fixed binary (18);

dcl  bit builtin;

	imac = imac + 1;				/* point at the instruction */

	/* pick up the operands and address increments */

	do i = 1 to 2;
	     op (i) = stack (get_operand ((machine_instruction (imac + i).operand)));
	     arg (i) = addr (rands (op (i)));
	     inc (i) = machine_instruction (imac + i).increment;
	     lreg (i) = "00"b3;
	     end;

	/* Make operands addressable, reserving registers as needed */

	call make_both_addressable (arg, inc);

	/* Get lengths of operands, reserving registers as needed */

	call get_eis_length (1);			/* Get length of 1st opnd */

	if left > 0				/* Equal lengths? */
	then if mac_base -> descriptor (imac + 2).length = "000"b3
	     then do;

		/* Copy length info from 1st opnd to 2nd */

		len (2) = len (1);
		lreg (2) = lreg (1);
		end;

	     else call print_message (466);

	else call get_eis_length (2);			/* Get length for opnd 2 */

	/* Move in the instruction word */

	inst_pos = text_pos;
	text_word (text_pos) = unspec (machine_instruction (imac));
	opcode = machine_instruction (imac).op_code;

	/* fill in the descriptors and modification fields */

	do i = 1 to 2;
	     imac = imac + 1;
	     text_pos = text_pos + 1;

	     substr (text_word (inst_pos), mf (i), 7) = substr (unspec (arg (i) -> node.address), 30, 7);

	     if lreg (i)
	     then substr (text_word (inst_pos), mf (i) + 1, 1) = "1"b;

	     /* Fill in address of descriptor, including char and bit offsets */

	     substr (unspec (descriptor (text_pos)), 1, 24) = substr (unspec (arg (i) -> node.address), 1, 20);

	     if lreg (i)
	     then descriptor (text_pos).length = (6)"0"b || lreg (i);
	     else descriptor (text_pos).length = bit (fixed (len (i), 12), 12);

	     if ^analyzing
	     then reloc (text_pos).left_rel = arg (i) -> node.reloc;

	     if assembly_list & ^analyzing
	     then if arg (i) -> node.node_type = array_ref_node
		then a_name (text_pos) = arg (i) -> array_ref.parent;
		else a_name (text_pos) = op (i);

	     if substr (unspec (arg (i) -> node.address), 30, 7) = "0"b & ^analyzing
	     then call text_ref (arg (i), inc (i), fixed (opcode, 10), i);
	     else if inc (i) ^= 0
	     then if arg (i) -> node.ext_base
		then if ^arg (i) -> node.is_addressable
		     then call increment_address (arg (i), -inc (i));
		     else instruction (text_pos).offset = instruction (text_pos).offset + inc (i);
		else text_halfs (text_pos).left = text_halfs (text_pos).left + inc (i);

	     /* If the output of this EIS instruction (its second
	        operand) is a temporary, do not drop its reference
	        count.  Note that the cmpc, scd, and scm instructions
	        have no outputs in this sense. */

	     if i = 1				/* Always drop 1st operand */
		| arg (i) -> node.node_type = array_ref_node
						/* Always drop array refs */
		| opcode = cmpc			/* Has no output */
		| opcode = scd			/* Has no output */
		| opcode = scm			/* Has no output */
	     then call drop_count ((op (i)), 1);

	     end;

	text_pos = text_pos + 1;

	/* Free regs used by addresses and lengths of EIS operands */

	call free_regs ();

	return;

get_eis_length:
     procedure (opno);

	/* Internal procedure to emit_eis.  Computes the length of the
	   specified operand of the EIS instruction, setting len and
	   lreg. */

dcl  (opno, i) fixed binary;				/* Operand number */
dcl  csize fixed binary (18);				/* Character size of opnd */

	i = opno;

	if mac_base -> descriptor (imac + i).length = "000"b3
	then do;

	     /* Length not given, figure it out */

	     csize = get_char_size ((arg (i)));
	     if csize < 0
	     then len (i) = csize + bias;
	     else do;
		if addr (rands (csize)) -> node.value_in.eaq
		then lreg (i) = eaq_man_load_a_or_q (addr (rands (csize)));
		else lreg (i) = xr_man_load_any_xr (addr (rands (csize)));
		len (i) = 0;
		end;
	     end;

	else len (i) = fixed (mac_base -> descriptor (imac + i).length, 12);

	/* If constant length will not fit in 12 bits, put it in an index register */

	if len (i) > 4095
	then lreg (i) = xr_man_load_const (len (i));

	/* Reserve the register used for length */

	call lock_tag_register ((lreg (i)));

     end get_eis_length;

     end emit_eis;

/**** ADDRESSING SECTION ****/

m_a:
     procedure (pt);

	/* make_addressable */

dcl  (p, pt, s, v) pointer;
dcl  off fixed binary (18);

	p = pt;

	if p -> node.is_addressable
	then return;

	if p -> node.address_in_base
	then do;
	     p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0);
	     return;
	     end;

	if p -> node.node_type = array_ref_node
	then do;
	     s = addr (rands (p -> array_ref.parent));
	     if ^p -> array_ref.has_address
	     then if analyzing
		then call optimized_subscript (addr (quad (p -> array_ref.output_by)));
		else do;
		     call print_message (446, fixed (rel (p), 18));
		     stop;
		     end;

	     if p -> array_ref.variable_offset
	     then do;
		off = p -> array_ref.v_offset;
		v = addr (rands (off));
		if p -> array_ref.large_offset | (^analyzing & v -> node.value_in.eaq)
		then do;

		     /* Process array-ref of VLA.  'v' is the total Packed Pointer.  If it is in
		        the Q or A register then we leave it and will later use epp,easp, else if
		        it is in storage then we can use an lprp. */

		     if ^s -> symbol.VLA
		     then p -> array_ref.address.tag = eaq_man_load_a_or_q (v);
		     end;
		else p -> array_ref.address.tag = xr_man_load_any_xr (v);
		end;

	     end;

	call m_a_except_xreg (p);

	if p -> node.data_type = char_mode & p -> node.units ^= char_units
	then do;
	     if ^from_base_man
	     then if p -> node.address.tag
		then do;
		     p -> node.addr_hold = substr (unspec (p -> node.address), 1, 18);
		     p -> node.reloc_hold = p -> node.reloc;
		     p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17), 0);
		     p -> node.address.offset = 0;
		     p -> node.address.tag = "0"b;
		     p -> node.reloc = rc_a;
		     end;
	     end;

     end m_a;

m_a_except_xreg:
     procedure (pt);

	/* make_addressable, but don't call xr_man and don't do special aligned character addressing */

dcl  (p, pt) pointer;				/* Node to be made addressable */
dcl  p1 pointer;					/* Node to get addressing info from */
dcl  (i, offset) fixed binary (18);

	p = pt;

	if p -> node.node_type = array_ref_node
	then p1 = addr (rands (p -> array_ref.parent));
	else do;
	     p1 = p;
	     if analyzing
	     then if unspec (p -> node.address) = "0"b
		then if p -> node.node_type = temporary_node
		     then call assign_address_to_temp (fixed (rel (p), 18), 0);
	     end;

	if p1 -> node.needs_pointer
	then do;

	     if last_pr_locked_for_pl1_ops_arg > 0
	     then cur_lp -> loop.avoid_pr (last_pr_locked_for_pl1_ops_arg) = "1"b;

	     /* prevent a multi-position VLA parameter from missing VLA processing. */

	     if p1 -> node.stack_indirect & ^(p1 -> node.node_type = symbol_node & p1 -> symbol.VLA)
	     then do;
		i = 4;
		if p1 -> node.node_type = temporary_node
		then do;
		     offset = fixed (substr (p1 -> node.addr_hold, 4, 15), 15);
		     if offset >= 16384
		     then offset = offset - 32768;
		     if p1 -> temporary.large_address
		     then offset = offset + p1 -> temporary.location;
		     p -> temporary.address.base = base_man_load_any_pr (i, offset, 0);
		     return;
		     end;
		end;

	     /* Must be a symbol node */

	     else if p1 -> symbol.VLA
	     then do;
		p -> node.address.base = base_man_load_any_pr (1, fixed (rel (p), 17, 0), 0);
		return;
		end;				/* we are pointer at our pointer */
	     else if p1 -> symbol.LA
	     then do;
		if p1 -> symbol.static
		then i = 11;			/* static indirect */
		else i = 4;			/* stack */
		p1 = addr (rands (p1 -> symbol.parent));
		end;
	     else if p1 -> symbol.in_common
	     then do;
		i = 3;
		p1 = addr (rands (p1 -> symbol.parent));
		end;
	     else if p1 -> symbol.parameter
	     then i = 2;
	     else if p1 -> symbol.descriptor
	     then i = 10;
	     else do;
		call print_message (417, fixed (rel (p), 18));
		return;
		end;

	     if ^p -> symbol.large_address
	     then p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), 0);
	     else p -> symbol.address.base = base_man_load_any_pr (i, (p1 -> node.location), (p -> symbol.location));
	     end;

	else if p1 -> node.node_type = symbol_node
	then do;
	     if p1 -> symbol.external & p1 -> symbol.initial ^= 0
	     then do;

		/* have an  external subr or func reference
		   that is really local */

		p1 = addr (rands (p1 -> symbol.initial));

		if p1 -> symbol.allocated & ^analyzing
		then do;
		     unspec (p -> symbol.address) = unspec (p1 -> symbol.address);
		     p -> symbol.allocated, p -> symbol.is_addressable = "1"b;
		     end;
		end;

	     else if p1 -> symbol.parameter
	     then p -> node.address.base = base_man_load_arg_ptr ();

	     else call m_a_check_large_address (p, p1);
	     end;

	else call m_a_check_large_address (p, p1);

     end m_a_except_xreg;

m_a_check_large_address:
     procedure (pt, pt1);

	/* Handles large addresses */

dcl  (pt, p, pt1, p1) pointer;
dcl  usual_base bit (3) aligned;
dcl  i fixed binary (18);

	p = pt;
	p1 = pt1;

	if p -> node.large_address
	then do;

	     /* have abs(address) >= 16K */

	     if last_pr_locked_for_pl1_ops_arg > 0
	     then cur_lp -> loop.avoid_pr (last_pr_locked_for_pl1_ops_arg) = "1"b;

	     usual_base = sp;
	     if p1 -> node.node_type = symbol_node
	     then if p1 -> symbol.static | p1 -> symbol.external
		then usual_base = lp;

	     i = p -> node.location;

	     if i ^= 0
	     then p -> node.address.base = base_man_load_large_base (i, usual_base);

	     else p -> node.address.base = usual_base;

	     end;

     end m_a_check_large_address;

increment_address:
     procedure (p, inc);

	/* Applies increment to address of node */

dcl  p pointer,
     inc fixed binary (18);

dcl  (loc, offset) fixed binary (18);

	if ^p -> node.large_address
	then p -> node.address.offset = p -> node.address.offset + inc;

	else do;
	     loc, offset = p -> node.address.offset + p -> node.location + inc;
	     offset = mod (offset + 16384, 32768) - 16384;
	     p -> node.location = loc - offset;
	     p -> node.address.offset = offset;
	     end;

     end increment_address;

c_a:
     procedure (c, code) returns (bit (36) aligned);

	/* Fabricates a constant address to be used with emit_c_a */

dcl  (c, n, code) fixed binary (18);

dcl  1 inst_address aligned like symbol.address;

	n = c;
	unspec (inst_address) = "0"b;
	go to sw (code);

sw (1):						/* n,ql */
	inst_address.tag = QL_mod;
	go to exit;

sw (5):						/* location n in the linkage section */
	inst_address.base = lp;
	go to set_ext_base;

sw (6):						/* location n in the stack */
	inst_address.base = sp;
	go to set_ext_base;

sw (3):						/* location n indirect in linkage section */
sw (11):						/* location n indirect in static section */
	inst_address.base = lp;
	go to indirect;

sw (4):						/* location n indirect in stack */
	inst_address.base = sp;

indirect:
	inst_address.tag = inst_address.tag | "010000"b;

set_ext_base:
	inst_address.ext_base = "1"b;

	if n >= 16384
	then do;
	     n = mod (n + 16384, 32768) - 16384;
	     inst_address.base = base_man_load_large_base (c - n, (inst_address.base));
	     end;

exit:
	inst_address.offset = n;
	return (unspec (inst_address));

     end c_a;

c_a_18:
     procedure (n, code) returns (bit (36) aligned);

	/* Fabricates a constant address with 18 bit offset field for use with emit_c_a */

dcl  n fixed binary (18),				/* Offset */
     code fixed binary (18);				/* 1 = DU */

dcl  1 inst_address aligned,
       2 offset fixed binary (17) unaligned,
       2 op_code bit (10) unaligned,
       2 inhibit bit (1) unaligned,
       2 ext_base bit (1) unaligned,
       2 tag bit (6) unaligned;

	unspec (inst_address) = "0"b;

	inst_address.offset = n;

	if code = 1
	then inst_address.tag = DU_mod;

	return (unspec (inst_address));

     end c_a_18;

c_a_tag:
     procedure (n) returns (bit (36) aligned);

	/* Fabricates a constant address with a specified tag */

dcl  n fixed binary (3);
dcl  1 inst_address aligned like symbol.address;

	unspec (inst_address) = "0"b;
	inst_address.tag = "001"b || bit (n, 3);
	return (unspec (inst_address));

     end c_a_tag;

make_both_addressable:
     procedure (arg, inc);

	/* Makes two operands simultaneously addressable by reserving
	   registers as it goes. */

dcl  arg (2) pointer;
dcl  inc (2) fixed binary (18);
dcl  (i, reg) fixed binary (3);
dcl  p pointer;

	do i = 1 to 2;

	     p = arg (i);

	     if ^p -> node.is_addressable
	     then do;

		if inc (i) ^= 0
		then do;
		     if p -> node.node_type = array_ref_node
		     then if ^p -> array_ref.has_address
			then if analyzing
			     then call optimized_subscript (addr (quad (p -> array_ref.output_by)));
			     else do;
				call print_message (446, fixed (rel (p), 18));
				stop;
				end;
		     if p -> node.address.ext_base
		     then call increment_address (p, (inc (i)));
		     end;

		call m_a (p);

		/* Reserve any XRs or EAQ registers used */

		call lock_tag_register ((p -> node.address.tag));

		/* Reserved any base registers used */

		if p -> node.address.ext_base
		then do;
		     reg = which_base (fixed (p -> node.address.base, 3));
		     call lock_base (reg);
		     end;

		end;

	     end;

     end make_both_addressable;

/**** POINTER REGISTER MANAGEMENT ****/

	/* The contents of the pointer registers are determined by the
	   value of the type field as follows:
	   (v = variable field)

	   -1		UNKNOWN
	   0		EMPTY
	   1		address of operand specified by v (usually an aligned char-string)
	   2		ptr to loc v in arg list
	   3		ptr thru link with offset v
	   4		ptr at stack offset v
	   5		arg list ptr
	   6		linkage ptr
	   7		value of operand specified by v
	   8		stack ptr
	   9		ptr to arg descriptor list
	   10		ptr to loc v in desc list
	   11		ptr thru static with offset v
	*/

base_man_load_any_pr:
     procedure (code, num, offset) returns (bit (3) aligned);

dcl  (n, code) fixed binary (18),			/* type of operation */
     (v, num) fixed binary (18),			/* location of ptr to be loaded */
     (off, offset) fixed binary (18);			/* offset to be added to pointer */

dcl  VLA bit (1);					/* True if VLA */
dcl  s ptr;

dcl  (i, j, k) fixed binary (3);
dcl  address bit (36) aligned;
dcl  diff fixed binary (18);

	n = code;
	v = num;
	diff, off = offset;

	if analyzing
	then if n ^= 1
	     then call add_global_ptr (n, v, off);

	j, k = 0;

	do i = first_base to last_base;
	     if current_ms.base_regs (i).type = 0
	     then k = i;
	     else if current_ms.base_regs (i).type = n
	     then if current_ms.base_regs (i).variable = v
		then if current_ms.base_regs (i).offset = off
		     then do;
			current_ms.base_regs (i).used = text_pos;
			return (bases (i));
			end;
		     else j = i;
	     end;

	if j > 0
	then do;

	     /* we've got the right storage area, but the wrong offset */

	     diff = off - current_ms.base_regs (j).offset;
	     address = c_a (0, 6);
	     substr (address, 1, 3) = bases (j);

	     i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k);

	     call flush_base (i);

	     call emit_c_a ((load_base (i)), address);
	     end;

	else if n = 1
	then do;
	     s = addr (rands (v));
	     if s -> node.node_type = symbol_node
	     then VLA = s -> symbol.VLA;
	     else if s -> node.node_type = array_ref_node
	     then VLA = addr (rands (s -> array_ref.parent)) -> symbol.VLA;
	     else VLA = "0"b;
	     s -> node.address_in_base = "1"b;
	     current_ms.address_in_base = "1"b;

	     i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k);

	     call flush_base (i);

	     /* A very large reference can be of two types:
	        1. array-reference.  in this case the vsum of the reference is in memory
	        and is the total addressor needed by lprp.
	        2. normal-reference. in this case the address in the symbol node is
	        sufficient to address directly a base to the variable for
	        lprp.
	     */

	     if VLA
	     then call base_man_load_VLA (v, i);
	     else call emit_c_a_var ((load_base (i)), addr (rands (v)));

	     if analyzing
	     then call add_local_ptr;
	     end;

	else if n = 2 | n = 10
	then do;
	     address = c_a (v, 4);
	     if n = 2
	     then substr (address, 1, 3) = base_man_load_arg_ptr ();
	     else substr (address, 1, 3) = base_man_load_desc_ptr ();

	     i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), 0);

	     call flush_base (i);

	     call emit_c_a ((load_base (i)), address);
	     end;

	else do;
	     address = c_a (v, n);

	     if v >= 16384
	     then k = 0;				/* base_regs state was changed. */

	     i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (n, v, off), k);

	     call flush_base (i);

	     if ^analyzing
	     then if n = 3				/* linkage indirect */
		then reloc (text_pos).left_rel = rc_lp15;
		else if n = 11			/* static indirect */
		then reloc (text_pos).left_rel = rc_is15;

	     call emit_c_a ((load_base (i)), address);
	     end;

	if diff ^= 0
	then call emit_c_a ((add_base (i)), c_a_18 (diff, 1));

	current_ms.base_regs (i).type = n;
	current_ms.base_regs (i).variable = v;
	current_ms.base_regs (i).offset = off;
	current_ms.base_regs (i).used = text_pos;
	return (bases (i));

     end base_man_load_any_pr;

base_man_load_VLA:
     proc (opnd, which);

dcl  opnd fixed bin (18),
     which fixed bin (3);

dcl  llr_18_instruction bit (36) aligned static options (constant) init ("00002277700"b3);

dcl  offset fixed bin (18),
     p ptr,
     storage_class fixed bin (18),
     v ptr,
     v_offset fixed bin (18);

	p = addr (rands (opnd));
	if p -> node.node_type = array_ref_node
	then do;
	     v_offset = p -> array_ref.v_offset;
	     v = addr (rands (v_offset));
	     if ^v -> node.not_in_storage
	     then call emit_c_a_var (load_packed_base (which), v);
	     else if get_eaq_name (v_offset) ^= in_q & ^analyzing
	     then call print_message (440, "addressing a VLA element");
						/*  Addressor must be in Q if not in storage.  */
	     else if text_word (max (0, text_pos - 1)) = llr_18_instruction
	     then do;				/*  We just expanded a 'form_VLA_packed_ptr' macro.  */
		text_pos = text_pos - 2;		/*  Backup to 'div pr0|VLA_words_per_seg'.  */
		call emit_c_a (load_base (which), (30)"0"b || AL_mod);
		call emit_c_a (load_segment_num (which), (30)"0"b || QL_mod);
		if get_ref_count (p) > 1 | get_ref_count (v) > 1
		then call emit_temp_store (store_packed_base (which), v_offset);
		else v -> temporary.not_in_storage = "0"b;
						/*  A small lie to prevent storing of the subscript.  */
		end;
	     else if get_ref_count (p) > 1 | get_ref_count (v) > 1
	     then do;
		call emit_temp_store (store_inst (get_eaq_name (v_offset)), v_offset);
		call emit_c_a_var (load_packed_base (which), v);
		end;
	     else do;
		call emit_c_a (load_base (which), (30)"0"b || QL_mod);
		call emit_c_a (load_segment_num (which), (30)"0"b || QU_mod);
		v -> temporary.not_in_storage = "0"b;	/*  A small lie to prevent storing of the subscript.  */
		end;
	     end;
	else if p -> node.node_type = symbol_node
	then do;

	     /* for non-dimensioned symbols, use the saved offset information. */
	     if ^p -> symbol.dimensioned
	     then substr (unspec (p -> symbol.address), 1, 18) = p -> symbol.addr_hold;
	     offset = p -> symbol.address.offset;
	     if p -> symbol.large_address
	     then offset = offset + p -> symbol.location;
	     if p -> symbol.in_common | p -> symbol.static
	     then storage_class = 5;
	     else storage_class = 6;
	     if assembly_list
	     then a_name (text_pos) = opnd;
	     reloc (text_pos).left_rel = p -> symbol.reloc;
	     call emit_c_a (load_packed_base (which), c_a (offset, storage_class));

	     /* Zero the offset in non-dimensioned symbols since all
	        references through the pointer just created must be
	        prN|0 references. */
	     if ^p -> symbol.dimensioned
	     then p -> symbol.address.offset = 0;
	     end;
	else call print_message (470, opnd, "base_man_load_VLA");
     end base_man_load_VLA;

flush_base:
     procedure (i);

	/* Empties a pointer register prior to reuse. */

dcl  i fixed binary (3);				/* base reg to flush */
dcl  p pointer;

	if current_ms.base_regs (i).type = 1
	then do;
	     p = addr (rands (current_ms.base_regs (i).variable));
	     p -> node.address_in_base = "0"b;

	     if p -> node.stack_indirect
	     then if p -> node.node_type = temporary_node
		then if p -> temporary.not_in_storage
		     then do;

			/* Store pointer to dynamic temp */

			call base_man_store_temp (p, (i));
			ptr_data.local = ptr_data.local - 1;
			return;
			end;

	     /* Restore address of aligned character string */

	     substr (unspec (p -> node.address), 1, 18) = p -> node.addr_hold;
	     p -> node.reloc = p -> node.reloc_hold;
	     ptr_data.local = ptr_data.local - 1;
	     end;

	else if current_ms.base_regs (i).type = 7
	then ptr_data.local = ptr_data.local - 1;

     end flush_base;

base_man_load_pr:
     procedure (opnd, which, lock_it);

	/* Loads the address of an operand into the
	   specified register and reserves the register
	   if asked to do so */

dcl  opnd fixed binary (18),				/* Index of operand */
     which fixed binary (18),				/* Register to use */
     lock_it bit (1) aligned;

dcl  i fixed binary (3);
dcl  op fixed binary (18);
dcl  p pointer;
dcl  1 inst_address aligned like node.address;
dcl  tag_hold bit (6) aligned;
dcl  char_num_hold fixed binary (2) aligned;
dcl  VLA bit (1);

	from_base_man = "1"b;

	i = which;
	op = opnd;
	p = addr (rands (op));

	/* force addressability so we can look at the address */

	if p -> node.node_type = symbol_node
	then VLA = p -> symbol.VLA;
	else if p -> node.node_type = array_ref_node
	then VLA = addr (rands (p -> array_ref.parent)) -> symbol.VLA;
	else VLA = "0"b;

	if ^p -> node.is_addressable & ^VLA		/* VLA is always addressable */
	then call m_a (p);

	if p -> node.units = char_units
	then do;

	     /* Tag specifies a character offset in a register.  Save
	        the tag, so epp does not use it, and deal with it
	        manually below. Do the same for char_num. */

	     tag_hold = p -> node.address.tag;
	     p -> node.address.tag = "00"b3;
	     char_num_hold = p -> node.address.char_num;
	     p -> node.address.char_num = 0;
	     end;

	call flush_base (i);

	/* If we are dealing in char_units, then we want to avoid
	   calling m_a and setting node.address.tag.  Therefore,
	   we use emit_c_a_var instead of emit_single. */

	if p -> node.address.base ^= bases (i) | ^p -> node.address.ext_base | p -> node.address.offset ^= 0
	     | p -> node.address.tag ^= "00"b3
	then if p -> node.units = char_units		/* characters cannot be VLA's so no code here. */
	     then do;
		call emit_c_a_var ((load_base (i)), p);
		call drop_count (op, 1);
		end;
	     else if VLA
	     then call base_man_load_VLA (op, i);
	     else call emit_single ((load_base (i)), op);
	else call drop_count (op, 1);

	if p -> node.units = char_units
	then do;

	     /* Handle character offsets */

	     unspec (inst_address) = ext_base_on;	/* Initialize address for a9bd instructions */
	     inst_address.base = bases (i);

	     if char_num_hold ^= 0
	     then if tag_hold & "001000"b
		then do;

		     /* Have constant offset + offset in XR */

		     inst_address.tag = xr_man_add_const (binary (substr (tag_hold, 4, 3), 3), (char_num_hold));
		     call emit_c_a (a9bd, unspec (inst_address));
		     end;

		else if tag_hold ^= "00"b3
		then do;

		     /* have constant offset + offset not in XR */

		     inst_address.tag = xr_man_load_const ((char_num_hold));
		     call emit_c_a (a9bd, unspec (inst_address));
		     inst_address.tag = tag_hold;
		     call emit_c_a (a9bd, unspec (inst_address));
		     end;

		else do;

		     /* Constant offset only */

		     inst_address.tag = xr_man_load_const ((char_num_hold));
		     call emit_c_a (a9bd, unspec (inst_address));
		     end;

	     else if tag_hold ^= "00"b3
	     then do;

		/* Variable offset only */

		inst_address.tag = tag_hold;
		call emit_c_a (a9bd, unspec (inst_address));
		end;

	     p -> node.address.tag = tag_hold;		/* Restore original tag */
	     p -> node.address.char_num = char_num_hold;	/* and char_num */

	     end;

	current_ms.base_regs (i).variable = op;		/* debugging */
	current_ms.base_regs (i).offset = 0;
	current_ms.base_regs (i).used = text_pos;

	if lock_it
	then do;
	     current_ms.base_regs (i).type = -1;	/* unknown value */
	     call lock_base (i);
	     if analyzing & i >= first_base & i <= last_base
	     then last_pr_locked_for_pl1_ops_arg = i;
	     end;
	else current_ms.base_regs (i).type = 0;		/* empty */

	if analyzing
	then do;
	     cur_lp -> loop.erases.pr (i) = "1"b;
	     ptr_data.max_local = max (ptr_data.max_local, ptr_data.local + 1);
	     end;

	from_base_man = "0"b;

     end base_man_load_pr;

base_man_load_pr_value:
     procedure (opnd, which);

	/* Loads the value of an operand into the specified register */

dcl  opnd fixed binary (18),				/* Index of operand */
     which fixed binary (18);				/* Register to use */

dcl  i fixed binary (3);
dcl  op fixed binary (18);
dcl  p pointer;

	op = opnd;
	p = addr (rands (op));
	i = which;

	/* load value if it is not loaded already */

	if current_ms.base_regs (i).type ^= 7 | current_ms.base_regs (i).variable ^= op
	     | current_ms.base_regs (i).offset ^= 0
	then do;

	     /*  force addressability so we can look at the address */

	     if ^p -> node.is_addressable
	     then call m_a (p);

	     call flush_base (i);

	     if substr (p -> node.address.tag, 1, 2)	/* node addr already has a modifier */
	     then call print_message (416, op);		/* illegal address field */

	     substr (p -> node.address.tag, 1, 2) = "01"b;/* RI */

	     call emit_c_a_var ((load_base (i)), p);

	     substr (p -> node.address.tag, 1, 2) = "00"b;/* restore tag */

	     current_ms.base_regs (i).type = 7;		/* value of op in pr */
	     current_ms.base_regs (i).variable = op;	/* debugging */
	     current_ms.base_regs (i).offset = 0;

	     if analyzing
	     then do;
		cur_lp -> loop.erases.pr (i) = "1"b;
		call add_local_ptr;
		end;
	     end;

	current_ms.base_regs (i).used = text_pos;

     end base_man_load_pr_value;

base_man_load_large_base:
     procedure (offset, base) returns (bit (3) aligned);

	/* Loads pointer register with contents(base) + offset.
	   This routine is used to deal with address offsets >= 16K. */

dcl  (off, offset) fixed binary (18),
     base bit (3) aligned;				/* MUST BE sp or lp */

dcl  (i, k) fixed binary (3);
dcl  code fixed binary (18);
dcl  1 inst_address aligned like symbol.address;

	off = offset;

	if base = lp
	then code = 6;
	else code = 8;

	if analyzing
	then call add_global_ptr (code, 0, off);

	i = 0;

	do k = first_base to last_base;
	     if current_ms.base_regs (k).type = 0 & ^current_ms.base_regs (k).reserved
	     then i = k;
	     else if current_ms.base_regs (k).type = code & current_ms.base_regs (k).offset = off
	     then do;
		current_ms.base_regs (k).used = text_pos;
		return (bases (k));
		end;
	     end;

	/* At this stage "i" is the free register.  The following code assumes that
	   "k" is the global register.  (bug fix 82-08-16) TO. */

	/* Here we go through a long chain of finding potential free registers.  The
	   reason for this is that we may be within a loop and have to take one of the
	   globally assigned registers. */

	k = find_global_base (code, 0, off);		/* See if we are already assigned. */
	if i = 0 & k = 0
	then do;
	     do i = last_base to first_base by -1 while (k = 0);
						/* Find loc v in arg list */

		/* Scan order chosen to pick out globally assigned registers in order of least use. */

		if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 2
		then k = i;
		end;

	     do i = last_base to first_base by -1 while (k = 0);
						/* Find link with offset v */
		if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 3
		then k = i;
		end;

	     do i = last_base to first_base by -1 while (k = 0);
						/* Find ptr at stack offset v */
		if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 4
		then k = i;
		end;

	     do i = last_base to first_base by -1 while (k = 0);
						/* Find operand spec by v */
		if ^current_ms.base_regs (i).reserved & current_ms.base_regs (i).type = 7
		then k = i;
		end;

	     end;
	else if k = 0
	then k = i;				/* Use global register */

	i = get_free_reg (current_ms.base_regs, first_base, last_base, k, k);

	call flush_base (i);

	unspec (inst_address) = ext_base_on;
	inst_address.base = base;

	call emit_c_a ((load_base (i)), unspec (inst_address));
	call emit_c_a ((add_base (i)), c_a_18 (off, 1));

	if current_ms.base_regs (i).type ^= code	/* If we stole one */
	then current_ms.base_regs (i).global = "0"b;

	current_ms.base_regs (i).type = code;
	current_ms.base_regs (i).variable = 0;
	current_ms.base_regs (i).offset = off;
	current_ms.base_regs (i).used = text_pos;

	return (bases (i));

     end base_man_load_large_base;

base_man_load_large_base_no_flush:
     procedure (offset, base, which) returns (bit (3) aligned);

	/* Analogous to base_man_load_large_base, except that the
	   register to load is specified and flush_base is not called,
	   to avoid recursion. */

dcl  offset fixed binary (18);
dcl  base bit (3) aligned;
dcl  which fixed binary (3);

dcl  1 inst_address like node.address;

	unspec (inst_address) = ext_base_on;
	inst_address.base = base;

	call emit_c_a ((load_base (which)), unspec (inst_address));
	call emit_c_a ((add_base (which)), c_a_18 ((offset), 1));

	if base = sp
	then current_ms.base_regs (which).type = 8;
	else current_ms.base_regs (which).type = 6;
	current_ms.base_regs (which).variable = 0;
	current_ms.base_regs (which).offset = offset;
	current_ms.base_regs (which).used = text_pos;

	return (bases (which));

     end base_man_load_large_base_no_flush;

base_man_load_arg_ptr:
     procedure () returns (bit (3) aligned);

	/* Loads a pointer register with a pointer to the argument list. */

dcl  (i, k) fixed binary (3);
dcl  n fixed binary (18);

	if analyzing
	then call add_global_ptr (5, 0, 0);

	k = 0;

	do i = first_base to last_base;
	     if current_ms.base_regs (i).type = 0
	     then k = i;
	     else if current_ms.base_regs (i).type = 5
	     then do;
		current_ms.base_regs (i).used = text_pos;
		return (bases (i));
		end;
	     end;

	i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (5, 0, 0), k);
	call flush_base (i);

	if cs -> subprogram.subprogram_type = main_program
	then n = arg_ptr;
	else n = cs -> subprogram.entry_info + 2;

	call emit_c_a ((load_base (i)), c_a (n, 4));

	current_ms.base_regs (i).type = 5;
	current_ms.base_regs (i).variable = 0;
	current_ms.base_regs (i).used = text_pos;
	current_ms.base_regs (i).offset = 0;

	return (bases (i));

     end base_man_load_arg_ptr;

base_man_load_desc_ptr:
     procedure () returns (bit (3) aligned);

	/* Loads a pointer register with a pointer to the argument
	   descriptor list. */

dcl  (i, k) fixed binary (3);
dcl  n fixed binary (18);

	if analyzing
	then call add_global_ptr (9, 0, 0);

	k = 0;

	do i = first_base to last_base;
	     if current_ms.base_regs (i).type = 0
	     then k = i;
	     else if current_ms.base_regs (i).type = 9
	     then do;
		current_ms.base_regs (i).used = text_pos;
		return (bases (i));
		end;
	     end;

	i = get_free_reg (current_ms.base_regs, first_base, last_base, find_global_base (9, 0, 0), k);
	call flush_base (i);

	if cs -> subprogram.subprogram_type = main_program
	then n = descriptor_ptr;
	else n = cs -> subprogram.entry_info + 4;

	call emit_c_a ((load_base (i)), c_a (n, 4));

	current_ms.base_regs (i).type = 9;
	current_ms.base_regs (i).variable = 0;
	current_ms.base_regs (i).used = text_pos;
	current_ms.base_regs (i).offset = 0;

	return (bases (i));

     end base_man_load_desc_ptr;

base_man_store_temp:
     procedure (temp_ptr, which);

	/* Emits code to store a pointer temporary.  Note that since
	   this routine is called from flush_base, we must be careful
	   to not use any pointer registers which might require flushing
	   (to avoid recursion). */

dcl  (temp_ptr, tp) pointer;
dcl  (which, temp_reg) fixed binary (3);

dcl  1 inst_address like node.address;
dcl  (large_base_reg, i, free_reg) fixed binary (3);
dcl  was_reserved bit (1) aligned;

	tp = temp_ptr;
	temp_reg = which;

	unspec (inst_address) = tp -> temporary.addr_hold;
	inst_address.ext_base = "1"b;

	/* If the temp is simply addressible, just store it */

	if ^tp -> temporary.large_address
	then do;
	     call emit_c_a ((store_base (temp_reg)), unspec (inst_address));
	     return;
	     end;

	/* See if there is a pointer register which already points to
	   the correct region for the large address. */

	free_reg, large_base_reg = 0;
	do i = first_base to last_base while (large_base_reg = 0);
	     if current_ms.base_regs (i).type = 0
	     then free_reg = i;
	     else if current_ms.base_regs (i).type = 8 & current_ms.base_regs (i).offset = tp -> temporary.location
	     then large_base_reg = i;
	     end;

	/* If there is no such pointer register, see if there is one
	   globally assigned. */

	if large_base_reg = 0
	then large_base_reg = find_global_base (8, 0, (tp -> temporary.location));

	/* If we have found a register to use, use it. */

	if large_base_reg > 0
	then do;
	     current_ms.base_regs (large_base_reg).used = text_pos;
	     inst_address.base = bases (large_base_reg);
	     call emit_c_a ((store_base (temp_reg)), unspec (inst_address));
	     return;
	     end;

	/* Try to get an empty register, or any register which does not
	   require flushing.  Avoid the register we are trying to store
	   by pretending it is reserved for the moment. */

	was_reserved = current_ms.base_regs (temp_reg).reserved;
	current_ms.base_regs (temp_reg).reserved = "1"b;
	i = get_free_reg (current_ms.base_regs, first_base, last_base, 0, free_reg);
	current_ms.base_regs (temp_reg).reserved = was_reserved;

	if current_ms.base_regs (i).type ^= 1 & current_ms.base_regs (i).type ^= 7
	then do;
	     inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i);
	     call emit_c_a ((store_base (temp_reg)), unspec (inst_address));
	     return;
	     end;

	/* Try to use pr4 as a last resort */

	i = which_base (4);

	if current_ms.base_regs (i).reserved
	then call print_message (467);		/* Sigh */

	inst_address.base = base_man_load_large_base_no_flush ((tp -> temporary.location), sp, i);
	call emit_c_a ((store_base (temp_reg)), unspec (inst_address));

	call emit_zero (getlp);			/* Restore pr4 */

     end base_man_store_temp;

find_global_base:
     procedure (p_code, p_var, p_off) returns (fixed binary (3));

	/* Searches for base register globally assigned to code,var,off.
	   If found, returns the register, otherwise, 0. */

dcl  (code, p_code) fixed binary (18),			/* Type of item */
     (var, p_var) fixed binary (18),			/* Operand offset */
     (off, p_off) fixed binary (18);			/* Offset to be added to ptr */

dcl  i fixed binary;

	if lp_msp ^= null
	then do;
	     code = p_code;
	     var = p_var;
	     off = p_off;

	     do i = first_base to last_base;
		if loop_state.base_regs (i).type = code
		then if loop_state.base_regs (i).variable = var
		     then if loop_state.base_regs (i).offset = off
			then if ^current_ms.base_regs (i).reserved
			     then return (i);
			     else call print_message (453);
		end;
	     end;

	return (0);

     end find_global_base;

lock_base:
     procedure (reg);

	/* Locks a base register for use in addressing */

dcl  reg fixed binary (3);

	if analyzing & ^current_ms.base_regs (reg).reserved & reg >= first_base & reg <= last_base
	then do;
	     ptr_data.locked = ptr_data.locked + 1;
	     ptr_data.max_locked = max (ptr_data.max_locked, ptr_data.locked);
	     end;

	/* Bug 508: If pr4 found to be empty, reset it to linkage ptr */

	if reg = which_base (4) & current_ms.base_regs (reg).type = 0
	then current_ms.base_regs (reg).type = 6;     /* linkage_ptr */

	current_ms.base_regs (reg).reserved = "1"b;

     end lock_base;

base_man_dispatch:
     procedure (p_code, p_var, p_off) returns (bit (3) aligned);

	/* Calls the proper base_man routine depending on args */

dcl  (code, p_code) fixed binary (18),
     (var, p_var) fixed binary (18),
     (off, p_off) fixed binary (18);

dcl  base bit (3) aligned;

	code = p_code;
	var = p_var;
	off = p_off;

	if code = 6 | code = 8
	then do;
	     if code = 6
	     then base = lp;
	     else base = sp;
	     base = base_man_load_large_base (off, base);
	     end;

	else if code = 5
	then base = base_man_load_arg_ptr ();

	else if code = 9
	then base = base_man_load_desc_ptr ();

	else base = base_man_load_any_pr (code, var, off);

	return (base);

     end base_man_dispatch;

avoid_prs:
     procedure (p_which);

	/* Marks the specified base registers reserved so they are not used for global items. */

dcl  (which, p_which) bit (6) aligned;			/* "1"b for each register to avoid */

dcl  i fixed binary (3);

	which = p_which;

	do i = first_base to last_base;
	     hold_pr_locks (i) = current_ms.base_regs (i).reserved;
	     if substr (which, i, 1)
	     then current_ms.base_regs (i).reserved = "1"b;
	     end;

     end avoid_prs;

restore_pr_locks:
     procedure ();

	/* Restores state of base register reservations after avoid_prs */

dcl  i fixed binary (3);

	do i = first_base to last_base;
	     current_ms.base_regs (i).reserved = hold_pr_locks (i);
	     end;

     end restore_pr_locks;

add_local_ptr:
     procedure ();

	/* Maintains statistics on local pointer use */

	ptr_data.local = ptr_data.local + 1;
	ptr_data.max_local = max (ptr_data.max_local, ptr_data.local);

     end add_local_ptr;

add_global_ptr:
     procedure (code, num, offset);

	/* Adds one to usage count of pointer node for this loop */

dcl  (code, num, offset) fixed binary (18);

dcl  p pointer;

	p = find_ptr ((code), (num), (offset));

	if p -> pointer.count = 0
	then do;
	     if ptr_data.n_global >= hbound (ptr_data.item, 1)
	     then do;
		call print_message (451, "pointer");
		return;
		end;

	     ptr_data.n_global = ptr_data.n_global + 1;
	     ptr_data.item (ptr_data.n_global) = p;
	     end;

	p -> pointer.count = p -> pointer.count + 1;

     end add_global_ptr;

find_ptr:
     procedure (p_code, p_num, p_offset) returns (pointer);

	/* Finds a pointer node in the hash_table.  If not found, inserts it.  */

dcl  (code, p_code) fixed binary (18),
     (num, p_num) fixed binary (18),
     (offset, p_offset) fixed binary (18);

dcl  node_ptr pointer;
dcl  node_offset fixed binary (18);

dcl  hash_index fixed binary;
dcl  mod_2_sum bit (36) aligned;
dcl  dim builtin;

	code = p_code;
	num = p_num;
	offset = p_offset;

	/* Form hash_index. */

	mod_2_sum = bool (bool (unspec (code), unspec (num), "0110"b), unspec (offset), "0110"b);
	hash_index = mod (binary (mod_2_sum, 35), dim (ptr_hash_table, 1));

	/* Search the hash table for the pointer node */

	do node_offset = ptr_hash_table (hash_index) repeat node_ptr -> pointer.hash_chain while (node_offset > 0);

	     node_ptr = addr (rands (node_offset));

	     if node_ptr -> pointer.variable = num
	     then if node_ptr -> pointer.code = code
		then if node_ptr -> pointer.offset = offset
		     then return (node_ptr);
	     end;

	/* Create on since we didn't find one. */

	node_offset = create_node (pointer_node, size (pointer));
	node_ptr = addr (rands (node_offset));


	node_ptr -> pointer.code = code;
	node_ptr -> pointer.variable = num;
	node_ptr -> pointer.offset = offset;

	/* Insert it in ptr_hash_table. */

	node_ptr -> pointer.hash_chain = ptr_hash_table (hash_index);
	ptr_hash_table (hash_index) = node_offset;

	return (node_ptr);

     end find_ptr;

/**** GET_FREE_REG ****/

get_free_reg:
     procedure (regs, first, last, global_reg, empty_reg) returns (fixed binary (3));

	/* Implements register searching algorithm */

dcl  1 regs (0:7) aligned like machine_state.base_regs,
     (first, last) fixed binary (18),			/* Limits of search */
     global_reg fixed binary (3),			/* Register preselected because it is globally assigned to the desired item */
     empty_reg fixed binary (3);			/* Register preselected because it is empty */

dcl  (i, j, count, lused, lowest_count) fixed binary (18);

	if global_reg > 0
	then return (global_reg);

	if empty_reg > 0
	then if ^regs (empty_reg).reserved & ^regs (empty_reg).global
	     then return (empty_reg);

	j = -1;
	lowest_count = max_fixed_bin_18;

	do i = first to last;
	     if ^regs (i).reserved & ^regs (i).global
	     then do;
		if regs (i).type = 0
		then return (i);

		if regs (i).type = 1
		then count = get_usage_count (addr (rands (regs (i).variable)));
		else count = 1;

		if count < lowest_count
		then do;
		     lowest_count = count;
		     lused = regs (i).used;
		     j = i;
		     end;

		else if count = lowest_count
		then if regs (i).used < lused
		     then do;
			lused = regs (i).used;
			j = i;
			end;

		end;

	     end;

	if j < 0
	then call print_message (418);
	else return (j);

     end get_free_reg;

get_usage_count:
     procedure (pt) returns (fixed binary (18));

	/* Gets effective usage count of an operand.  For temps that
	   are offsets of array_refs, the sum of the ref_counts of all
	   array_refs that a temp is used by is a better figure for
	   its usage count than its ref count.  */

dcl  (p, pt) pointer;

dcl  (inp, o, outp) pointer;
dcl  count fixed binary (18);

	p = pt;

	if p -> node.node_type = temporary_node
	then do;

	     /* operand is probably variable offset of array_refs.
	        To find real number of times needed in an xreg, get
	        sum of ref_counts of array_refs. */

	     if p -> temporary.start_input_to = 0 | ^p -> temporary.used_as_subscript
	     then return (get_ref_count (p));

	     count = 0;

	     do inp = addr (polish (p -> temporary.start_input_to)) repeat inp -> input_to.next while (inp ^= null);
		if inp -> input_to.which > 0
		then do;
		     o = inp -> input_to.operator;
		     if o -> operator.output > 0
		     then do;
			outp = addr (rands (o -> operator.output));
			count = count + get_ref_count (outp);
			end;
		     end;
		end;

	     return (count);
	     end;

	else if p -> node.node_type = array_ref_node
	then return (get_ref_count (p));

	else return (1);

     end get_usage_count;

/**** INDEX REGISTER MANAGEMENT ****/

	/* The contents of the index registers are determined by the
	   value of the type field as follows:
	   (v = variable field)

	   -1		UNKNOWN
	   0		EMPTY
	   1		value v
	   2		constant value c
	*/

xr_man_load_any_xr:
     procedure (pt) returns (bit (6) aligned);

dcl  pt pointer;					/* Points at value to be loaded */

dcl  p pointer;
dcl  v fixed binary (18);
dcl  i fixed binary (3);
dcl  have_eligible bit (1) aligned;

	p = pt;
	v = fixed (rel (p), 18);

	if analyzing
	then do;
	     have_eligible = eligible (p);
	     if have_eligible
	     then call add_global_index (p);
	     end;

	if p -> node.value_in.x
	then do;
	     do i = first_index to last_index;
		if current_ms.index_regs (i).type = 1
		then if current_ms.index_regs (i).variable = v
		     then do;
			current_ms.index_regs (i).used = text_pos;
			return ("001"b || bit (i, 3));
			end;
		end;
	     call print_message (430, v);
	     return ("00"b3);
	     end;

	i = get_free_reg (current_ms.index_regs, first_index, last_index, find_global_index (v), 0);

	call flush_xr (i);

	call use_ind;

	if p -> node.value_in.eaq
	then call emit_c_a (eax0 + i, c_a (0, 1));

	else do;
	     if p -> node.not_in_storage & ^analyzing
	     then do;
		call print_message (419, v);
		stop;
		end;

	     if ^p -> node.is_addressable
	     then call m_a_except_xreg (p);

	     call emit_c_a_var (lxl0 + i, p);
	     end;

	current_ms.indicators_valid = i + highest_ind_state + 1;

	call xr_man_update_xr (v, i);

	if analyzing
	then if ^have_eligible
	     then call add_local_index;

	return ("001"b || bit (i, 3));

     end xr_man_load_any_xr;

flush_xr:
     procedure (which);

	/* Empties an index register prior to reuse */

dcl  which fixed binary (3);				/* Index reg to flush */
dcl  i fixed binary (18);
dcl  p pointer;

	if current_ms.index_regs (which).type ^= 1
	then do;
	     if analyzing & current_ms.index_regs (which).type ^= 0
	     then index_data.local = index_data.local - 1;
	     return;
	     end;

	i = which;

	p = addr (rands (current_ms.index_regs (i).variable));
	p -> node.value_in.x = "0"b;

	/* the value has not been previously stored, so do so */

	if p -> temporary.not_in_storage
	then call emit_temp_store (sxl0 + i, (current_ms.index_regs (i).variable));

	if analyzing
	then if ^eligible (p)
	     then index_data.local = index_data.local - 1;

     end flush_xr;

xr_man_load_const:
     procedure (csize) returns (bit (6) aligned);

	/* Loads a constant into any index register */

dcl  csize fixed binary (18);				/* Size to be loaded */

dcl  (i, k) fixed binary (3);
dcl  c fixed binary (18);

	c = csize;

	if const_in_xr (c, first_index, k)
	then do;
	     current_ms.index_regs (k).used = text_pos;
	     return ("001"b || bit (binary (k, 3), 3));
	     end;

	i = get_free_reg (current_ms.index_regs, first_index, last_index, 0, k);

	call flush_xr (i);

	call use_ind;

	call emit_c_a (eax0 + i, c_a_18 (c, 0));

	current_ms.indicators_valid = i + highest_ind_state + 1;

	current_ms.index_regs (i).type = 2;
	current_ms.index_regs (i).variable = c;
	current_ms.index_regs (i).used = text_pos;

	if analyzing
	then call add_local_index;

	return ("001"b || bit (i, 3));

     end xr_man_load_const;

xr_man_update_xr:
     procedure (ref, ip);

	/* Updates index register machine state */

dcl  ref fixed binary (18);
dcl  (ip, i) fixed binary (3);
dcl  rp pointer;

	rp = addr (rands (ref));
	i = ip;

	if ^rp -> node.dont_update
	then do;
	     current_ms.value_in_xr = "1"b;
	     current_ms.index_regs (i).type = 1;
	     current_ms.index_regs (i).variable = ref;
	     rp -> node.value_in.x = "1"b;
	     end;
	else current_ms.index_regs (i).type = 0;

	current_ms.index_regs (i).used = text_pos;

     end xr_man_update_xr;

const_in_xr:
     procedure (value, first_xr, reg) returns (bit (1) aligned);

	/* Searches x-regs for particular const value or first empty x-reg */

dcl  value fixed binary (18);				/* offset of const node */
dcl  first_xr fixed binary (18);			/* first xr to search */
dcl  reg fixed binary (3);				/* xr that contains const or is empty */
dcl  (i, c) fixed binary (18);

	c = value;
	reg = 0;

	do i = first_xr to last_index;
	     if current_ms.index_regs (i).type = 0
	     then reg = i;
	     else if current_ms.index_regs (i).type = 2
	     then if current_ms.index_regs (i).variable = c
		then do;
		     reg = i;
		     return ("1"b);			/* const in xr */
		     end;
	     end;

	return ("0"b);				/* const not in xr */

     end const_in_xr;

xr_man_add_const:
     procedure (which, csize) returns (bit (6) aligned);

	/* Adds a constant to the value in an index register */

dcl  which fixed binary (3);
dcl  csize fixed binary (18);

dcl  (i, c) fixed binary (18);
dcl  j fixed binary (3);
dcl  address bit (36) aligned;


	i = which;
	c = csize;
	address = (36)"0"b;
	substr (address, 1, 18) = bit (c, 18);		/* Set offset portion */
	substr (address, 31, 6) = bit (fixed (i + 8, 6), 6);
						/* Set tag portion */

	j = get_free_reg (current_ms.index_regs, first_index, last_index, 0, 0);

	call flush_xr (j);
	call use_ind ();
	call emit_c_a (eax0 + j, address);		/* Emit eaxm_ const,n */

	/* Although the index register we just loaded is not really empty,
	   we will say it is because xr_man does not have the notion
	   of a variable plus a constant in a register.  This will only work
	   if the next instruction emitted uses the index register and
	   does not call for some other index register to be loaded. */

	current_ms.indicators_valid = j + highest_ind_state + 1;

	current_ms.index_regs (j).type = 0;		/* Empty */
	current_ms.index_regs (j).variable = 0;
	current_ms.index_regs (j).used = text_pos;

	if analyzing
	then index_data.max_local = max (index_data.max_local, index_data.local + 1);

	return (bit (fixed (j + 8, 6), 6));		/* Return XR modifier */

     end xr_man_add_const;

find_global_index:
     procedure (var) returns (fixed binary (3));

	/* Searches for a register globally assigned to var.  Returns 0 if not found. */

dcl  (v, var) fixed binary (18);

dcl  i fixed binary;

	v = var;

	if addr (rands (v)) -> node.globally_assigned
	then do i = first_index to last_index;
		if loop_state.index_regs (i).type = 1
		then if loop_state.index_regs (i).variable = v
		     then if ^current_ms.index_regs (i).reserved
			then return (i);
			else call print_message (453);
		end;

	return (0);

     end find_global_index;

xr_man_load_xr:
     procedure (p_load_p, p_xr, p_update_opnd);

	/* Loads operand into specified index register and updates
	   machine state with another operand. */

dcl  (load_p, p_load_p) pointer,			/* -> opnd to be loaded */
     (xr, p_xr) fixed binary (3),			/* Xreg to load into */
     (update_opnd, p_update_opnd) fixed binary (18);	/* Opnd to be added to state */

dcl  i fixed binary (3);
dcl  load_opnd fixed binary (18);

	load_p = p_load_p;
	load_opnd = fixed (rel (load_p), 18);
	xr = p_xr;
	update_opnd = p_update_opnd;

	call flush_xr (xr);

	call use_ind;

	if load_p -> node.value_in.x
	then do;
	     i = fixed (substr (xr_man_load_any_xr (load_p), 4, 3), 3);

	     call emit_c_a (eax0 + xr, c_a_tag (i));
	     current_ms.indicators_valid = xr + highest_ind_state + 1;
	     end;

	else do;
	     if load_p -> node.not_in_storage & ^analyzing
	     then do;
		call print_message (419, load_opnd);
		stop;
		end;

	     call emit_single (lxl0 + xr, load_opnd);
	     end;

	call xr_man_update_xr (update_opnd, xr);

     end xr_man_load_xr;

lock_index:
     procedure (reg);

	/* Locks an index register for use in addressing */

dcl  reg fixed binary (3);

	if analyzing & ^current_ms.index_regs (reg).reserved
	then do;
	     index_data.locked = index_data.locked + 1;
	     index_data.max_locked = max (index_data.max_locked, index_data.locked);
	     end;

	current_ms.index_regs (reg).reserved = "1"b;

     end lock_index;

eligible:
     procedure (p) returns (bit (1) aligned);

	/* Determines if an operand may be globally assigned to an
	   index register. */

dcl  p pointer;					/* -> operand node */

dcl  o pointer;

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then return (substr (cur_lp -> loop.may_keep_in_xr -> bits, p -> symbol.coordinate, 1));
	     else ;

	else if p -> node.node_type = temporary_node
	then do;
	     o = addr (quad (p -> temporary.output_by));
	     if o -> operator.coordinate > 0
	     then return (^substr (cur_lp -> loop.computed -> obits, o -> operator.coordinate, 1));
	     end;

	return ("0"b);

     end eligible;

add_global_index:
     procedure (p);

	/* Adds one to loop_ref_count to opnd for this loop */

dcl  p pointer;					/* -> symbol or temporary */

	if p -> node.loop_ref_count = 0
	then do;
	     if index_data.n_global >= hbound (index_data.item, 1)
	     then do;
		call print_message (451, "index");
		return;
		end;

	     index_data.n_global = index_data.n_global + 1;
	     index_data.item (index_data.n_global) = p;
	     end;

	p -> node.loop_ref_count = p -> node.loop_ref_count + 1;

     end add_global_index;

add_local_index:
     procedure ();

	/* Updates local index statistics */

	index_data.local = index_data.local + 1;
	index_data.max_local = max (index_data.max_local, index_data.local);

     end add_local_index;

/**** NON-ADDRESSING INDEX REGISTER OPERATIONS ****/

assign_index:
     procedure (p_dest, p_source);

	/* Effects an assignment via an index register. */

dcl  (dest, p_dest) fixed binary (18),			/* destination */
     (source, p_source) fixed binary (18);

dcl  xr fixed binary (3);

dcl  (source_p, dest_p) pointer;
dcl  p pointer;

	dest = p_dest;
	dest_p = addr (rands (dest));
	source = p_source;
	source_p = addr (rands (source));

	if string (dest_p -> symbol.value_in)
	then call flush_ref (dest);

	if dest_p -> symbol.globally_assigned
	then do;

	     /* destination will be in an index register */

	     xr = find_global_index (dest);

	     call xr_man_load_xr (source_p, xr, dest);

	     /* If the xr is erased in this loop, or if the variable is
	        busy_on_exit from this loop, we must save a copy in storage. */

	     if cur_lp -> loop.erases.xr (xr)
		| substr (cur_lp -> loop.busy_on_exit -> bits, dest_p -> symbol.coordinate, 1)
	     then call emit_temp_store (sxl0 + xr, dest);
	     end;

	else do;

	     /* destination is not kept in an index register */

	     xr = fixed (substr (xr_man_load_any_xr (source_p), 4, 3), 3);

	     p = find_range (dest_p, cur_lp);

	     if p = null
	     then call emit_temp_store (sxl0 + xr, dest);

	     else if p -> range.fb18_uns
	     then do;
		call emit_temp_store (stz, dest);
		call emit_temp_store (sxl0 + xr, dest);
		end;

	     else do;
		call use_eaq (0, Q, 0);

		call emit_c_a (eaq, c_a_tag (xr));
		call emit_c_a (qrs, c_a_18 (18, 0));

		current_ms.indicators_valid = Q;

		call store (dest, in_q, 0);
		end;
	     end;

     end assign_index;

compare_index:
     procedure (p_induction_var, p_invariant);

	/* Compares an induction variable in an index register against
	   a loop invariant in storage */

dcl  (induction_var, p_induction_var) fixed binary (18),
     (invariant, p_invariant) fixed binary (18);

dcl  (indp, invp) pointer;

dcl  have_zero bit (1) aligned;
dcl  regno fixed binary (3);

	induction_var = p_induction_var;
	indp = addr (rands (induction_var));
	invariant = p_invariant;
	invp = addr (rands (invariant));

	/* Process the invariant.  If it is a constant, make a new one
	   by shifting left 18 bits.  Also, find out if it is zero.
	   Variable comparands have already been left shifted. */

	have_zero = "0"b;
	if invp -> node.node_type = constant_node
	then if addr (invp -> constant.value) -> int_image = 0
	     then have_zero = "1"b;
	     else invariant = create_constant (int_mode, substr (invp -> constant.value, 19));

	/* Find the register for the induction variable, and do the
	   comparison, if necessary. */

	regno = fixed (substr (xr_man_load_any_xr (indp), 4, 3), 3);

	if ^have_zero | current_ms.indicators_valid ^= regno + highest_ind_state + 1
	then do;
	     call emit_single (cmpx0 + regno, invariant);

	     if have_zero
	     then current_ms.indicators_valid = regno + highest_ind_state + 1;
	     else current_ms.indicators_valid = 0;
	     end;

     end compare_index;

increment_index:
     procedure (p_induction_var, p_value, sign);

	/* Increments an induction variable in an index register by a value */

dcl  (induction_var, p_induction_var) fixed binary (18),
     (value, p_value) fixed binary (18),
     sign fixed binary;

dcl  regno fixed binary (3);

dcl  mac fixed binary (18);

dcl  indp pointer;

	/* copy arguments and if the value is a constant, shift it by 18 bits */

	induction_var = p_induction_var;
	indp = addr (rands (induction_var));

	if addr (rands (p_value)) -> node.node_type = constant_node
	then value = create_constant (int_mode, substr (addr (rands (p_value)) -> constant.value, 19));
	else value = p_value;

	/* find the induction variable */

	regno = fixed (substr (xr_man_load_any_xr (indp), 4, 3), 3);

	/* increment it */

	if sign < 0
	then mac = sblx0 + regno;
	else mac = adlx0 + regno;

	call emit_single (mac, value);

	/* save the result, if necessary */

	if cur_lp -> loop.erases.xr (regno) | substr (cur_lp -> loop.busy_on_exit -> bits, indp -> symbol.coordinate, 1)
	then call emit_temp_store (sxl0 + regno, induction_var);

     end increment_index;

/**** GENERAL REGISTER MANAGEMENT ****/

reserve_regs:
     procedure (what);

	/* Reserves index and base registers */

dcl  (what, reserve) bit (14) aligned;			/* Mask specifying which regs to reserve */
dcl  i fixed binary (18);
dcl  j fixed binary (3);
dcl  length builtin;

	reserve = what;

	if analyzing
	then string (cur_lp -> loop.erases) = string (cur_lp -> loop.erases) | reserve;

	do i = 1 to length (reserve);
	     if substr (reserve, i, 1)
	     then if i <= 8
		then do;
		     j = i - 1;
		     call flush_xr (j);
		     current_ms.index_regs (j).reserved = "1"b;
		     current_ms.index_regs (j).type = -1;
						/* Unknown value */
		     end;
		else do;
		     j = i - 8;
		     call flush_base (j);
		     current_ms.base_regs (j).reserved = "1"b;
		     current_ms.base_regs (j).type = -1;/* Unknown value */
		     current_ms.base_regs (j).variable = 0;
						/* debugging */
		     current_ms.base_regs (j).offset = 0;
		     end;
	     end;

     end reserve_regs;

free_regs:
     procedure ();

dcl  i fixed binary (18);

	/* Frees all reserved registers (index, base, and eaq)
	   reloading pr4 if necessary */

	last_pr_locked_for_pl1_ops_arg, index_data.locked, ptr_data.locked = 0;

	current_ms.eaq (*).reserved = "0"b;

	do i = escape_index to last_index;
	     if current_ms.index_regs (i).reserved
	     then do;
		current_ms.index_regs (i).reserved = "0"b;
		if current_ms.index_regs (i).type < 0	/* Unknown? */
		then current_ms.index_regs (i).type = 0;
		end;
	     end;

	do i = first_base to last_base;		/* Normal bases */
	     if current_ms.base_regs (i).reserved
	     then do;
		current_ms.base_regs (i).reserved = "0"b;
		if current_ms.base_regs (i).type < 0	/* Unknown? */
		then current_ms.base_regs (i).type = 0;
		end;
	     end;

          /* Bug 508: Reload pr4 with linkage ptr value only if necessary */

	i = which_base (4);
	if current_ms.base_regs (i).reserved & current_ms.base_regs (i).type ^= 6
	then do;
	     call emit_zero (getlp);                         /* Emit code to restore pr4 */
	     current_ms.base_regs (i).type = 6; /* Linkage_ptr */
     	     end;

	current_ms.base_regs (i).reserved = "0"b;

     end free_regs;

flush_ref:
     procedure (index);

	/* Flush complex reference.  This is an aliased reference.  Here we find the
	   parent header node and scan through the equivalenced list to find another
	   node which has "value_in.eaq" set.  Cause that node to be flushed too. */

dcl  (index, i) fixed binary (18);
dcl  p ptr;


	call flush_simple_ref (index);		/* Flush primary */
	p = addr (rands (index));
	if p -> node.node_type = symbol_node
	then if (p -> symbol.in_equiv_stmnt) & (p -> symbol.parent ^= 0)
	     then do;
		p = addr (rands (p -> symbol.parent));	/* point to list */
		do i = p -> header.first_element repeat p -> symbol.next_member while (i ^= 0);
		     p = addr (rands (i));
		     if p -> symbol.value_in.eaq
		     then call flush_simple_ref (i);
		     end;
		end;



flush_simple_ref:
     procedure (temp_index);

	/* Removes an item from the machine state */

dcl  (temp, temp_index) fixed binary (18);
dcl  p pointer;
dcl  (i, r) fixed binary (18);

	temp = temp_index;

	p = addr (rands (temp));

	if p -> node.value_in.eaq
	then do;
	     do r = 1 to hbound (current_ms.eaq, 1);	/* A, Q, EAQ, IND */
		do i = 1 by 1 while (i <= current_ms.eaq (r).number);
		     if current_ms.eaq (r).variable (i) = temp
		     then do;
			do i = i + 1 by 1 while (i <= current_ms.eaq (r).number);
			     current_ms.eaq (r).variable (i - 1) = current_ms.eaq (r).variable (i);
			     end;

			current_ms.eaq (r).number = current_ms.eaq (r).number - 1;

			/* eaq.name is not set to zero here because the jump_true and
			   jump_false macro procedures use an if_eaq macro, which drops
			   the reference count if the value is in the eaq, followed by an
			   ind_jump macro which requires that eaq.name be one of the
			   indicators substates.  Since if_eaq could drop the reference
			   count to 0, flush_ref could be called and the temporary could
			   be removed from the machine state.  However, eaq.name must be
			   preserved for subsequent use by ind_jump. */

			end;
		     end;
		end;
	     end;

	if p -> node.value_in.x
	then do i = first_index repeat i + 1 while (i <= last_index);
		if current_ms.index_regs (i).type = 1
		then if current_ms.index_regs (i).variable = temp
		     then do;
			current_ms.index_regs (i).type = 0;
			if analyzing
			then if ^eligible (p)
			     then index_data.local = index_data.local - 1;
			end;
		end;

	string (p -> node.value_in) = "0"b;

     end flush_simple_ref;
     end flush_ref;

flush_addr:
     procedure (temp_index);

	/* Removes the address of an item from the machine state */

dcl  (temp, temp_index) fixed binary (18);
dcl  p pointer;
dcl  i fixed binary (18);

	temp = temp_index;
	p = addr (rands (temp));

	if p -> node.address_in_base
	then do;
	     do i = first_base repeat i + 1 while (i <= last_base);
		if current_ms.base_regs (i).type = 1
		then if current_ms.base_regs (i).variable = temp
		     then do;
			current_ms.base_regs (i).type = 0;
			if analyzing
			then do;
			     ptr_data.local = ptr_data.local - 1;
			     if p -> node.data_type = char_mode & p -> node.units ^= char_units
			     then do;

				/* Restore address of aligned character string */

				substr (unspec (p -> node.address), 1, 18) = p -> node.addr_hold;
				p -> node.reloc = p -> node.reloc_hold;
				end;
			     end;
			end;
		end;
	     p -> node.address_in_base = "0"b;
	     end;

     end flush_addr;

lock_tag_register:
     procedure (tag);

	/* Reserves the register specified by the address tag */

dcl  (tag, t) bit (6) aligned;

	t = tag;

	if substr (t, 3, 1)				/* XR modification */
	then call lock_index (fixed (t, 6) - 8);
	else if t = QL_mod
	then call lock_eaq (Q);
	else if t = AL_mod
	then call lock_eaq (A);

     end lock_tag_register;

/**** EAQ MANAGEMENT ****/

eaq_man_load_a_or_q:
     procedure (pt) returns (bit (6) aligned);

	/* Loads an integer value into the A or Q. */

dcl  (pt, p) pointer;
dcl  v fixed binary (18);
dcl  name fixed binary (18);

	p = pt;
	v = fixed (rel (p), 18);

	/* If the operand is already in the A or Q, no need to load it */

	if p -> node.value_in.eaq
	then do;
	     name = get_eaq_name (v);
	     if name = in_q
	     then return (QL_mod);
	     else if name = in_ia
	     then return (AL_mod);
	     end;

	/* Must load the operand.  If one of the A or Q is reserved, we must
	   load the other one.  If neither is reserved, we favor the Q. */

	if current_ms.eaq (A).reserved & current_ms.eaq (Q).reserved
	then call print_message (449);		/* Oops */

	if current_ms.eaq (A).reserved
	then name = in_q;
	else if current_ms.eaq (Q).reserved
	then name = in_ia;
	else if current_ms.eaq (Q).number > 0 & current_ms.eaq (A).number = 0 & current_ms.eaq (IND).number = 0
	then name = in_ia;
	else name = in_q;

	call use_eaq (v, name, 0);

	if ^p -> node.is_addressable
	then call m_a_except_xreg (p);

	call emit_c_a_var (load_inst (name), p);

	current_ms.indicators_valid = eaq_name_to_reg (name);

	call in_reg (v, name);

	if name = in_q
	then return (QL_mod);
	else return (AL_mod);

     end eaq_man_load_a_or_q;

get_eaq_name:
     procedure (opnd) returns (fixed binary (18));

	/* Search the eaq state for opnd and return its eaq name */

dcl  (op, opnd) fixed binary (18);
dcl  (r, v) fixed binary (18);

	op = opnd;

	if ^addr (rands (op)) -> node.value_in.eaq
	then return (0);				/* Don't even look */

	do r = 1 to hbound (current_ms.eaq, 1);

	     do v = 1 to current_ms.eaq (r).number;

		if current_ms.eaq (r).variable (v) = op
		then return (current_ms.eaq (r).name);

		end;

	     end;

	/* If we get here, the node has value_in.eaq on but the operand
	   is not in the eaq. */

	call print_message (450);
	return (0);

     end get_eaq_name;

in_reg:
     procedure (v, name);

	/* Puts an operand in an eaq register */

dcl  (var, v) fixed binary (18),
     name fixed binary (18),
     (i, n, regno) fixed binary (18);

	var = v;

	if addr (rands (var)) -> node.dont_update
	then return;

	regno = eaq_name_to_reg (name);

	if current_ms.eaq (regno).name > 0 & current_ms.eaq (regno).name ^= name
	then call use_eaq (0, (regno), 0);

	current_ms.eaq (regno).name = name;

	if name = in_ind
	then do;
	     call print_message (420, var);
	     return;
	     end;

	addr (rands (var)) -> node.value_in.eaq = "1"b;

	if current_ms.eaq (regno).number < hbound (current_ms.eaq.variable, 2)
	then do;
	     n, current_ms.eaq (regno).number = current_ms.eaq (regno).number + 1;
	     current_ms.eaq (regno).variable (n) = var;
	     return;
	     end;

	do i = 1 to hbound (current_ms.eaq.variable, 2);	/* Guaranteed to be an opening */

	     if addr (rands (current_ms.eaq (regno).variable (i))) -> node.node_type ^= temporary_node
	     then do;
		addr (rands (current_ms.eaq (regno).variable (i))) -> node.value_in.eaq = "0"b;
		current_ms.eaq (regno).variable (i) = var;
		return;
		end;
	     end;

	call print_message (448);

     end in_reg;

use_eaq:
     procedure (array_sym, reg_number, protect_ind);

	/* Stores values of all temps currently in eaq and required later on.
	   The eaq is then emptied. */

dcl  array_sym fixed binary (18);
dcl  reg_number fixed binary (18);
dcl  protect_ind fixed binary (18);

	call save_eaq_temps ((array_sym), (reg_number), (protect_ind));
	call reset_eaq ((reg_number));

     end use_eaq;

save_eaq_temps:
     procedure (array_sym, reg_no, protect_ind);

	/* Stores temp values for all temps currently in eaq and required later on.
	   Subscript values can be stored in an index reg or not stored at all.
	   All others are stored in storage. The machine state is not directly affected. */

dcl  array_sym fixed binary (18);			/* zero or sym offset of sym changing eaq state. */
dcl  reg_no fixed binary (18);			/* eaq register */
dcl  protect_ind fixed binary (18);			/* if ^= 0 then protect ind state while storing temps */

dcl  asp pointer;					/* null or -> node changing eaq state. */

	if array_sym > 0
	then asp = addr (rands (array_sym));
	else asp = null;

	if current_ms.eaq (IND).number > 0 & protect_ind = 0
	then call use_ind ();

	if reg_no ^= IND
	then call save (EAQ);			/* Only IND does not affect EAQ */

	if reg_no = EAQ
	then do;					/* EAQ affects both A and Q */
	     call save (A);
	     call save (Q);
	     end;
	else call save ((reg_no));

	return;

save:
     procedure (reg);

	/* Internal procedure of save_eaq_temps.  Saves temps in
	   one of the eaq registers. */

dcl  (reg, r) fixed binary (18);
dcl  bit6 bit (6) aligned;
dcl  i fixed binary (18);
dcl  own_sub pointer;
dcl  p pointer;
dcl  saved_state fixed binary (18);
dcl  st_inst fixed binary (18);

	/* If symbol causing eaq state change is an array ref node, the value in the
	   eaq is the value of the subscript, and this is the last reference for
	   this value, then we don't have to store the value anywhere. */

	r = reg;

	if current_ms.eaq (r).number = 0
	then return;

	own_sub = null ();
	saved_state = 0;

	if r = Q					/* Subscripts can only be in the Q */
	then if array_sym > 0
	     then if asp -> node.node_type = array_ref_node
		then if asp -> array_ref.variable_offset
		     then if get_ref_count (asp) = 1
			then if addr (rands (asp -> array_ref.v_offset)) -> node.value_in.eaq
			     then own_sub = addr (rands (asp -> array_ref.v_offset));

	if ^do_rounding | current_ms.rounded
	then st_inst = store_no_round_inst (current_ms.eaq (r).name);
	else st_inst = store_inst (current_ms.eaq (r).name);

	do i = 1 by 1 while (i <= current_ms.eaq (r).number);

	     p = addr (rands (current_ms.eaq (r).variable (i)));

	     if p -> node.not_in_storage & ^p -> node.value_in.x
	     then do;
		if p -> temporary.used_as_subscript
		then if p = own_sub & get_ref_count (p) = 1
		     then ;
		     else do;
			if protect_ind ^= 0 & saved_state = 0
			then call save_ind_state (saved_state);
			bit6 = xr_man_load_any_xr (p);
			end;

		else call emit_temp_store (st_inst, (current_ms.eaq (r).variable (i)));
		end;

	     end;

	if saved_state ^= 0
	then call restore_ind_state (saved_state);

     end save;

     end save_eaq_temps;

use_ind:
     procedure ();

	/* If the indicators contain a logical value, it is saved
	   in the a. Then the indicators are set invalid. */

	call move_logical_to_a ();
	current_ms.indicators_valid = 0;

     end use_ind;

move_logical_to_a:
     procedure ();

	/* Moves logical value from indicators to A-reg if the value needs to be stored */

dcl  p pointer;
dcl  var fixed binary (18);

	if current_ms.eaq (IND).name > in_ind
	then if current_ms.eaq (IND).number > 0
	     then do;
		p = addr (rands (current_ms.eaq (IND).variable (1)));
		if p -> node.node_type = temporary_node
		then do;
		     call save_logical_temps ();
		     call emit_zero ((ind_to_a (current_ms.eaq (IND).name - in_ind)));

		     /* Update machine state */

		     var = current_ms.eaq (IND).variable (1);
		     call reset_eaq (IND);
		     current_ms.eaq (A).number = 1;
		     current_ms.eaq (A).name = in_a;
		     current_ms.eaq (A).variable (1) = var;
		     p -> node.value_in.eaq = "1"b;
		     current_ms.indicators_valid = A;

		     end;

		end;

save_logical_temps:
     procedure ();

	/* This procedure is analogous to save_eaq_temps, but is used
	   to save temps in the A register only.  It is called by
	   move_logical_to_a to avoid recursion. */

dcl  i fixed binary (18);
dcl  p ptr;
dcl  saved_state fixed bin (18);
dcl  bit6 bit (6) aligned;
dcl  st_inst fixed bin (18);

	do i = 1 by 1 while (i <= current_ms.eaq (A).number);
	     if addr (rands (current_ms.eaq (A).variable (i))) -> node.not_in_storage
	     then call emit_temp_store (sta, (current_ms.eaq (A).variable (i)));
	     end;

	if current_ms.eaq (EAQ).number > 0
	then do;
	     saved_state = 0;
	     if ^do_rounding | current_ms.rounded
	     then st_inst = store_no_round_inst (current_ms.eaq (EAQ).name);
	     else st_inst = store_inst (current_ms.eaq (EAQ).name);

	     do i = 1 to current_ms.eaq (EAQ).number;
		p = addr (rands (current_ms.eaq (EAQ).variable (i)));

		if p -> node.not_in_storage & ^p -> node.value_in.x
		then do;
		     if p -> temporary.used_as_subscript
		     then do;
			call save_ind_state (saved_state);
			bit6 = xr_man_load_any_xr (p);
			end;

		     else call emit_temp_store (st_inst, (current_ms.eaq (EAQ).variable (i)));
		     end;

		end;

	     if saved_state ^= 0
	     then call restore_ind_state (saved_state);
	     end;

	call reset_eaq (A);

     end save_logical_temps;
     end move_logical_to_a;

flush_eaq:
     procedure ();

	/* Flushes eaq without moving temps to x-regs */

dcl  r fixed binary (18);
dcl  i fixed binary (18);
dcl  p pointer;
dcl  st_inst fixed binary (18);

	if current_ms.eaq (IND).number > 0
	then call use_ind ();

	do r = 1 to 3;				/* A, Q, EAQ */

	     if current_ms.eaq (r).number > 0
	     then do;

		if ^do_rounding | current_ms.rounded
		then st_inst = store_no_round_inst (current_ms.eaq (r).name);
		else st_inst = store_inst (current_ms.eaq (r).name);

		do i = 1 to current_ms.eaq (r).number;

		     p = addr (rands (current_ms.eaq (r).variable (i)));

		     if p -> node.node_type = temporary_node
		     then if p -> temporary.not_in_storage
			then if get_ref_count (p) > 0
			     then call emit_temp_store (st_inst, (current_ms.eaq (r).variable (i)));

		     p -> node.value_in.eaq = "0"b;	/* no longer in eaq */
		     end;

		current_ms.eaq (r).name = 0;
		current_ms.eaq (r).number = 0;

		end;

	     end;

	current_ms.rounded = "0"b;

     end flush_eaq;

load:
     procedure (vp, name);

	/* Loads an operand into an eaq register */

dcl  vp fixed binary (18),				/* operand to be loaded */
     name fixed binary (18);				/* eaq_name to be loaded */
dcl  (var, eaq_name, regno, i) fixed binary (18);

	eaq_name = name;

	if eaq_name <= 0 | eaq_name > in_ind
	then do;
	     call print_message (421, vp);
	     return;
	     end;

	var = vp;

	/* If this load would destroy the A, and if there are
	   logical values in the indicators, we must get the
	   indicators into the A now, before the load takes place.
	   Otherwise, a subsequent call to use_ind could
	   destroy the load.  This is a kludge. */

	if eaq_name_to_reg (eaq_name) ^= Q & current_ms.eaq (IND).number > 0
	then call move_logical_to_a ();

	if addr (rands (var)) -> node.value_in.eaq
	then do;

	     /* Search the machine state; the operand may already be
	        in the desired register */

	     do regno = 1 to hbound (current_ms.eaq, 1);	/* A, Q, EAQ, IND */

		do i = 1 by 1 while (i <= current_ms.eaq (regno).number);

		     if var = current_ms.eaq (regno).variable (i)
		     then do;

			if eaq_name = in_tq | eaq_name = in_q
			then if current_ms.eaq (regno).name = in_tq | current_ms.eaq (regno).name = in_q
			     then current_ms.eaq (regno).name = eaq_name;

			if eaq_name = current_ms.eaq (regno).name
			then do;
			     call drop_count (var, 1);
			     return;
			     end;

			if eaq_name = in_ind
			then do;
			     if regno = IND
			     then do;
				call drop_count (var, 1);
				return;
				end;

			     if current_ms.eaq (regno).name = in_a
			     then if current_ms.indicators_valid = A
				then do;
				     call flush_ref (var);
				     if current_ms.eaq (A).number = 0
				     then current_ms.eaq (A).name = 0;
				     call in_reg (var, tnz);
						/* Put it in INDs */
				     call drop_count (var, 1);
				     return;
				     end;

			     end;

			else if eaq_name = in_a & regno = IND
			     & addr (rands (var)) -> node.node_type = temporary_node
			then do;
			     call move_logical_to_a ();
			     call drop_count (var, 1);
			     return;
			     end;

			end;

		     end;

		end;

	     end;

	call emit_single ((load_inst (eaq_name)), var);

	if eaq_name = in_ind
	then eaq_name = tnz;

	call in_reg (var, eaq_name);

	current_ms.rounded = "1"b;

     end load;

check_zero:
     procedure (opnd) returns (bit (1) aligned);

	/* Returns true if operand is "zero value" for its data type */

dcl  opnd fixed binary (18);

	if opnd < 0				/* a count */
	then return (opnd = -bias);

	if addr (rands (opnd)) -> node.node_type = constant_node
	then return (opnd = zero_for_dt (addr (rands (opnd)) -> constant.data_type));
	else return ("0"b);

     end check_zero;

check_negative:
     procedure (opnd) returns (bit (1) aligned);

	/* return true if operand is "negative" for its data type */

dcl  opnd fixed bin (18);
dcl  (p, val_ptr) ptr;
dcl  based_integer fixed bin (35) aligned based;
dcl  based_real float bin (27) aligned based;
dcl  1 based_double aligned based,
       2 based_dp float bin (63) unaligned;

	if opnd < 0				/* a count */
	then return (opnd < -bias);

	p = addr (rands (opnd));
	if p -> node.data_type < 1 | p -> node.data_type > 4
	then return ("0"b);				/* cannot be neg if not numeric */
	val_ptr = addr (p -> constant.value);
	goto return_neg (p -> node.data_type);

return_neg (1):					/* INTEGER */
	return (val_ptr -> based_integer < 0);

return_neg (2):					/* REAL */
return_neg (4):					/* COMPLEX */
	return (val_ptr -> based_real < 0.0);

return_neg (3):					/* DOUBLE PRECISION */
	return (val_ptr -> based_dp < 0.0);

     end check_negative;

reset_eaq:
     procedure (reg_number);

	/* Resets the specified eaq register to the empty state */

dcl  reg_number fixed binary (18);

	if reg_number ^= IND
	then call reset (EAQ);			/* Only IND does not affect EAQ */

	if reg_number = EAQ
	then do;					/* EAQ affects both A and Q */
	     call reset (A);
	     call reset (Q);
	     end;
	else call reset (reg_number);

	current_ms.rounded = "0"b;

	return;

reset:
     procedure (r);

	/* Resets a single eaq register */

dcl  (i, r, regno) fixed binary (18);

	regno = r;

	do i = 1 by 1 while (i <= current_ms.eaq (regno).number);
	     addr (rands (current_ms.eaq (regno).variable (i))) -> node.value_in.eaq = "0"b;
	     end;

	current_ms.eaq (regno).number = 0;
	current_ms.eaq (regno).name = 0;

     end reset;

     end reset_eaq;

store:
     procedure (vp, name, update_flag);

dcl  vp fixed binary (18);				/* Operand to be stored */
dcl  name fixed binary (18);				/* Eaq_name from which storing takes place */
dcl  update_flag fixed binary (18);			/* =0 if store should update ms */

dcl  (var, eaq_name, inst_number) fixed binary (18);
dcl  v pointer;

	eaq_name = name;
	var = vp;
	v = addr (rands (var));

	if do_rounding & ^current_ms.rounded
	then inst_number = store_inst (eaq_name);
	else inst_number = store_no_round_inst (eaq_name);

	if v -> node.node_type = temporary_node
	then call bump_count (var, 1);

	call emit_single (inst_number, var);

	if eaq_name = in_q
	then if string (v -> node.value_in)
	     then call flush_ref (var);

	if update_flag = 0
	then do;
	     v -> node.not_in_storage = "0"b;
	     call in_reg (var, eaq_name);
	     end;

     end store;

lock_eaq:
     procedure (reg);

	/* Locks an EAQ register for use in addressing */

dcl  reg fixed binary (18);

	current_ms.eaq (reg).reserved = "1"b;

     end lock_eaq;

/**** INDICATOR SAVING AND RESTORING ****/

save_ind_state:
     procedure (a_state);

	/* Saves (and restores) indicator state if compiler must emit
	   instructions that modify the indicators. */

dcl  a_state fixed binary (18);			/* output - see below */
dcl  saved_state fixed binary (18);

	/* The parameter a_state is set as follows to indicate how the
	   indicators should be restored:
	   = 0: the indicators are meaningless, or the reg is empty;
	   the indicators need not be restored.
	   > 0: the indicators contain a logical value which was stored;
	   the indicators can be reloaded directly.
	   < 0: the indicators reflect the sign of a register;
	   the indicators can be restored with a comparison against 0. */

dcl  escape_address bit (36) aligned internal static options (constant) initial ("600056000100"b3);
						/* address of sp|46 */

	if current_ms.indicators_valid > 0 & current_ms.eaq (IND).name = 0
	then if current_ms.indicators_valid <= highest_ind_state
	     then saved_state = -current_ms.eaq (current_ms.indicators_valid).name;
	     else if current_ms.index_regs (current_ms.indicators_valid - highest_ind_state - 1).type > 0
	     then saved_state = -current_ms.indicators_valid;
	     else saved_state = 0;
	else if current_ms.eaq (IND).name >= in_ind
	then do;					/* logical value */
	     saved_state = current_ms.eaq (IND).name;
	     if current_ms.eaq (IND).name > in_ind
	     then current_ms.eaq (IND).name = in_ind;
	     call emit_c_a (store_ind, escape_address);
	     end;
	else saved_state = 0;

	a_state = saved_state;
	return;

restore_ind_state:
     entry (a_state);

	saved_state = a_state;

	if saved_state < 0
	then do;					/* inds reflect sign of reg, compare to zero */
	     saved_state = -saved_state;

	     if saved_state <= highest_ind_state
	     then do;
		call emit_c_a_const ((compare_inst (saved_state)), (zero_for_dt (dt_from_reg (saved_state))));
		current_ms.indicators_valid = eaq_name_to_reg (saved_state);
		end;

	     else do;
		call emit_c_a_const (cmpx0 + saved_state - highest_ind_state - 1, (zero_for_dt (int_mode)));
		saved_state = 0;
		end;
	     end;

	else if saved_state > 0
	then call emit_c_a (load_ind, escape_address);	/* ind state was stored, load it back */

	if saved_state > in_ind
	then current_ms.eaq (IND).name = saved_state;

     end save_ind_state;

/**** STATE MANAGEMENT ****/

save_state:
     procedure (lbl);

	/* Given a label operand, merge the current ms into the label's statement's machine state */

dcl  (lbl, msp, stmnt) fixed binary (18);
dcl  msp_ptr pointer;

	stmnt = addr (rands (lbl)) -> label.statement;
	if stmnt > 0
	then do;
	     msp = addr (quad (stmnt)) -> opt_statement.machine_state;
	     if msp = 0
	     then do;				/* No previous ms for statement */

		/* reuse an old machine_state node or allocate a new one */

		if next_free_ms = null
		then do;
		     msp = create_node (machine_state_node, size (machine_state));
		     msp_ptr = addr (rands (msp));
		     end;

		else do;
		     msp_ptr = next_free_ms;
		     msp = fixed (rel (msp_ptr), 18);
		     next_free_ms = msp_ptr -> machine_state.next;
		     unspec (msp_ptr -> machine_state) = "0"b;
		     msp_ptr -> machine_state.node_type = machine_state_node;
		     end;

		msp_ptr -> machine_state.next = null;
		addr (quad (stmnt)) -> opt_statement.machine_state = msp;

		/* if machine state exists, copy to target; empty state is initial value for node */

		if ^state_discarded
		then do;
		     call bump_all_ms_ref_counts;	/* mark everything in ms as saved */
		     msp_ptr -> machine_state.ms = current_ms.ms;
						/* copy ms to target label ms */
		     end;
		end;
	     else do;				/* Machine state exists, merge them. */
		msp_ptr = addr (rands (msp));

		if state_discarded
		then do;
		     call drop_all_ms_ref_counts (msp_ptr -> machine_state);
						/* all are unsaved */
		     unspec (msp_ptr -> machine_state.ms) = "0"b;
						/* empty state */
		     end;
		else call merge_state (msp_ptr -> machine_state, current_ms, "0"b);
		end;
	     end;

     end save_state;

merge_state:
     procedure (existing_state, a_new_state, update_flag);

	/* Merge new_state into existing_state. */

dcl  1 (existing_state, a_new_state, new_state) like machine_state aligned;
dcl  (update_flag, updating_ms) bit (1) aligned;
dcl  (i, j, r) fixed binary (18);
dcl  reg fixed binary (3);

	new_state = a_new_state;
	updating_ms = update_flag;			/* ="1"b if merging into current state. */

	if updating_ms				/* Merging states at a label, ms is freed when done. */
	then do;
	     new_state.next = next_free_ms;
	     next_free_ms = addr (a_new_state);
	     call drop_all_ms_ref_counts (new_state);
	     end;

	if state_discarded & updating_ms		/* make the current machine state be new_state */
	then do;
	     existing_state.ms = new_state.ms;		/* note this assignment destroys **.global */

	     do r = 1 to hbound (current_ms.eaq, 1);	/* A, Q, EAQ, IND */
		do i = 1 to new_state.eaq (r).number;
		     addr (rands (new_state.eaq (r).variable (i))) -> node.value_in.eaq = "1"b;
		     end;
		end;

	     if new_state.value_in_xr
	     then do i = first_index to last_index;
		     existing_state.index_regs (i).global = "0"b;
						/* invalid anyhow */
		     if new_state.index_regs (i).type = 1
		     then if new_state.index_regs (i).variable ^= 0
			then do;
			     addr (rands (new_state.index_regs (i).variable)) -> node.value_in.x = "1"b;
			     if analyzing
			     then if ^eligible (addr (rands (new_state.index_regs (i).variable)))
				then index_data.local = index_data.local + 1;
			     end;
			else ;
		     else if new_state.index_regs (i).type ^= 0
		     then index_data.local = index_data.local + 1;
		     end;

	     if new_state.address_in_base
	     then do i = first_base to last_base;
		     existing_state.base_regs (i).global = "0"b;
						/* invalid anyhow */
		     if new_state.base_regs (i).type = 1
		     then if new_state.base_regs (i).variable ^= 0
			then do;
			     j = new_state.base_regs (i).variable;
			     addr (rands (j)) -> node.addr_hold =
				substr (unspec (addr (rands (j)) -> node.address), 1, 18);
			     addr (rands (j)) -> node.reloc_hold = addr (rands (j)) -> node.reloc;
			     addr (rands (j)) -> node.address.base = bases (i);
			     addr (rands (j)) -> node.address.offset = 0;
			     addr (rands (j)) -> node.address.tag = "0"b;
			     addr (rands (j)) -> node.reloc = rc_a;
			     addr (rands (j)) -> node.address_in_base = "1"b;
			     ptr_data.local = ptr_data.local + 1;
			     end;
			else ;
		     else if new_state.base_regs (i).type = 7
		     then ptr_data.local = ptr_data.local + 1;
		     end;

	     /* Because the global bits have been wiped out by the structure
	        assignment to existing_state.ms, we refresh them by calling
	        refresh_global_bits. */

	     call refresh_global_bits (cur_lp);

	     return;
	     end;

	/* Form intersection of EAQ states. */

	do r = 1 to hbound (current_ms.eaq, 1);		/* A, Q, EAQ, IND */

	     if existing_state.eaq (r).number = 0 | new_state.eaq (r).number = 0
	     then call empty_the_eaq (r);

	     else if existing_state.eaq (r).name ^= new_state.eaq (r).name
	     then call empty_the_eaq (r);

	     else do;				/* Form intersection */

		i = 1;
		do while (i <= existing_state.eaq (r).number);

		     do j = 1 to new_state.eaq (r).number
			while (existing_state.eaq (r).variable (i) ^= new_state.eaq (r).variable (j));
			end;

		     if j > new_state.eaq (r).number
		     then do;			/* no match */

			if updating_ms
			then addr (rands (existing_state.eaq (r).variable (i))) -> node.value_in.eaq = "0"b;
			else call drop_ms_ref_count (addr (rands (existing_state.eaq (r).variable (i))), ("0"b));

			/* remove item from eaq variable list */

			do j = i to existing_state.eaq (r).number - 1;
			     existing_state.eaq (r).variable (j) = existing_state.eaq (r).variable (j + 1);
			     end;

			existing_state.eaq (r).number = existing_state.eaq (r).number - 1;

			end;

		     else i = i + 1;		/* matched, proceed */

		     end;				/* end intersection loop */

		if existing_state.eaq (r).number = 0
		then existing_state.eaq (r).name = 0;

		end;				/* end intersection code */

	     end;					/* end loop over eaq registers */

	/* Form intersection of rounded states. */

	existing_state.rounded = existing_state.rounded & new_state.rounded;

	/* Form intersection of indicator states. */

	if existing_state.indicators_valid ^= new_state.indicators_valid
	then existing_state.indicators_valid = 0;

	/* Form intersection of index regs states. */

	do reg = lbound (current_ms.index_regs, 1) to hbound (current_ms.index_regs, 1);

	     if existing_state.index_regs (reg).type = new_state.index_regs (reg).type
	     then if existing_state.index_regs (reg).variable ^= new_state.index_regs (reg).variable
		then call empty_xr;			/* Implied argument is "reg" */
		else ;				/* index reg the same in both states */
	     else call empty_xr;			/* not the same, flush the reg */
	     end;

	if ^new_state.value_in_xr
	then existing_state.value_in_xr = "0"b;

	/* Form intersection of base regs states. */

	do reg = lbound (current_ms.base_regs, 1) to hbound (current_ms.base_regs, 1);

	     if existing_state.base_regs (reg).type ^= new_state.base_regs (reg).type
		| existing_state.base_regs (reg).variable ^= new_state.base_regs (reg).variable
		| existing_state.base_regs (reg).offset ^= new_state.base_regs (reg).offset
	     then call empty_base;			/* implied arg is reg */

	     end;

	if ^new_state.address_in_base
	then existing_state.address_in_base = "0"b;

	/* Form intersection of dynamic temp states */

	if existing_state.stack_extended ^= new_state.stack_extended
	then existing_state.stack_extended = "1"b;

	if existing_state.last_dynamic_temp ^= new_state.last_dynamic_temp
	then existing_state.last_dynamic_temp = 0;

	return;					/* code for merging states */

flush_state:
     entry;

	call flush_eaq ();

	if current_ms.value_in_xr
	then do reg = first_index to last_index;
		call flush_xr (reg);
		end;

	if current_ms.address_in_base
	then do reg = first_base to last_base;
		call flush_base (reg);
		end;

	unspec (current_ms) = "0"b;

	current_ms.base_regs (which_base (4)).type = 6;	/* linkage_ptr */

	index_data.local, ptr_data.local = 0;

	return;					/* code to flush state */

empty_the_eaq:
     procedure (r);

	/* Marks the specified eaq register as empty. */

dcl  (r, n) fixed binary (18);

	existing_state.eaq (r).name = 0;

	n = existing_state.eaq (r).number;
	do while (n > 0);

	     if updating_ms
	     then addr (rands (existing_state.eaq (r).variable (n))) -> node.value_in.eaq = "0"b;
	     else call drop_ms_ref_count (addr (rands (existing_state.eaq (r).variable (n))), ("0"b));

	     n = n - 1;

	     end;

	existing_state.eaq (r).number = 0;
	existing_state.rounded = "0"b;

     end empty_the_eaq;

empty_xr:
     procedure ();

	/* Marks the specified index register as empty */

	if updating_ms
	then call flush_xr (reg);
	else if existing_state.index_regs (reg).type = 1
	then call drop_ms_ref_count (addr (rands (existing_state.index_regs (reg).variable)), ("0"b));

	existing_state.index_regs (reg).type = 0;
	existing_state.index_regs (reg).variable = 0;

     end empty_xr;

empty_base:
     procedure ();

	/* Marks the specified base register as empty */

	if updating_ms
	then call flush_base (reg);
	else if existing_state.base_regs (reg).type = 1
	then call drop_ms_ref_count (addr (rands (existing_state.base_regs (reg).variable)), ("0"b));

	existing_state.base_regs (reg).type = 0;
	existing_state.base_regs (reg).variable = 0;
	existing_state.base_regs (reg).offset = 0;

     end empty_base;

     end merge_state;

discard_state:
     procedure ();

	/* Discard the machine state. Empty all the registers. */

dcl  i fixed binary (3);

	if state_discarded
	then return;

	if current_ms.address_in_base
	then do i = first_base to last_base;
		call flush_base (i);
		end;

	call reset_eaq (EAQ);
	call reset_eaq (IND);

	if current_ms.value_in_xr
	then do i = first_index to last_index;
		if current_ms.index_regs (i).type = 1
		then if current_ms.index_regs (i).variable ^= 0
		     then addr (rands (current_ms.index_regs (i).variable)) -> node.value_in.x = "0"b;
		end;

	unspec (current_ms) = "0"b;

	index_data.local, ptr_data.local = 0;

	state_discarded = "1"b;

     end discard_state;

/**** GLOBAL REGISTER MANAGEMENT (See also find_global_base and find_global_index) ****/

leave_loop:
     procedure (lp_msp);

	/* Turns off global bits in current_ms and globally_assigned bits for
	   operands globally assigned in this loop */

dcl  (msp, lp_msp) pointer;				/* -> loop node's machine_state template */

dcl  1 loop_state based (msp) aligned like machine_state;

dcl  i fixed binary;

	msp = lp_msp;

	if msp ^= null
	then do;
	     do i = first_base to last_base;
		current_ms.base_regs (i).global = "0"b;
		end;

	     do i = first_index to last_index;
		current_ms.index_regs (i).global = "0"b;

		if loop_state.index_regs (i).type = 1
		then addr (rands (loop_state.index_regs (i).variable)) -> node.globally_assigned = "0"b;
		end;
	     end;

     end leave_loop;

enter_loop:
     procedure (lp, lp_msp);

	/* Sets lp_msp for a new loop.  Turns on the proper global bits in
	   current_ms and turns on the globally_assigned bits for globally
	   assigned operands */

dcl  lp pointer,					/* -> loop node */
     lp_msp pointer;				/* loop_node's machine_state pointer (output) */

dcl  msp pointer;
dcl  1 loop_state based (msp) aligned like machine_state;

dcl  i fixed binary;

	if lp ^= null
	then do;
	     lp_msp, msp = lp -> loop.msp;

	     if msp ^= null
	     then do;
		do i = first_base to last_base;
		     current_ms.base_regs (i).global = loop_state.base_regs (i).global;
		     end;

		do i = first_index to last_index;
		     current_ms.index_regs (i).global = loop_state.index_regs (i).global;

		     if loop_state.index_regs (i).type = 1
		     then addr (rands (loop_state.index_regs (i).variable)) -> node.globally_assigned = "1"b;
		     end;
		end;
	     end;

     end enter_loop;

refresh_global_bits:
     procedure (p_lp);

	/* Refreshes the global bits in current_ms by copying them from the
	   loop template, if it exists, or by zeroing them. */

dcl  (lp, p_lp) pointer;				/* -> loop node */

dcl  i fixed binary;
dcl  useless pointer;

	lp = p_lp;

	if lp ^= null
	then if lp -> loop.msp ^= null
	     then call enter_loop (lp, useless);
	     else do;
		do i = first_base to last_base;
		     current_ms.base_regs (i).global = "0"b;
		     end;

		do i = first_index to last_index;
		     current_ms.index_regs (i).global = "0"b;
		     end;
		end;

     end refresh_global_bits;

adjust_state_for_globals:
     procedure ();

	/* This is called when processing a label that has a backwards reference.
	   It adds the globally assigned items to the current machine_state by
	   looking in the loop node's template.	*/

dcl  i fixed binary;

	if lp_msp ^= null
	then do;
	     do i = first_base to last_base;
		if loop_state.base_regs (i).type ^= 0
		then current_ms.base_regs (i) = loop_state.base_regs (i);
		end;

	     do i = first_index to last_index;
		if loop_state.index_regs (i).type ^= 0
		then do;

		     /* type should be 1 (a variable or temp) */

		     current_ms.index_regs (i) = loop_state.index_regs (i);
		     addr (rands (current_ms.index_regs (i).variable)) -> node.value_in.x = "1"b;
		     end;
		end;

	     current_ms.value_in_xr = loop_state.value_in_xr;
	     current_ms.address_in_base = loop_state.address_in_base;
	     end;

     end adjust_state_for_globals;

cleanup_loop_state_nodes:
     procedure ();

dcl  i fixed binary;
dcl  lp pointer;

	do i = 1 to n_loops - 1;
	     lp = loop_vector (i);
	     if lp -> loop.msp ^= null
	     then do;
		lp -> loop.msp -> machine_state.next = next_free_opt_ms;
		next_free_opt_ms = lp -> loop.msp;
		lp -> loop.msp = null;
		end;
	     end;

     end cleanup_loop_state_nodes;

refresh_regs:
     procedure (protect_ind);

	/* This is called at the end of a flow_unit to ensure that all globally
	   assigned values are in their proper registers.  All registers are
	   unlocked at the end of the routine.	*/

dcl  (protect_ind, protect_indicators) fixed binary (18);	/* if ^= 0, protect indicators
						   when loading xregs. */

dcl  saved_state fixed binary (18);

dcl  (i, pass) fixed binary;
dcl  bit6 bit (6) aligned;
dcl  bit3 bit (3) aligned;

	if ^fu -> flow_unit.refreshed & lp_msp ^= null
	then do;
	     saved_state = 0;
	     protect_indicators = protect_ind;

	     /* Refresh the index registers. */

	     do i = first_index to last_index;
		if current_ms.index_regs (i).global & current_ms.index_regs (i).type <= 0
		then do;
		     if protect_indicators ^= 0 & saved_state = 0
		     then call save_ind_state (saved_state);
		     bit6 = xr_man_load_any_xr (addr (rands (loop_state.index_regs (i).variable)));
		     end;
		end;

	     /* Refresh the base registers.  First refresh all the registers
	        with offset = 0, then refresh the others.  This avoids
	        generating code to add an offset and then subtract it again
	        if two pointers into the same region (stack, linkage, common
	        block) with different offsets are to be loaded. */

	     do pass = 1 to 2;
		do i = first_base to last_base;
		     if current_ms.base_regs (i).global
			& (current_ms.base_regs (i).type <= 0 | current_ms.base_regs (i).type = 7)
						/* kludge for load_pr_value */
		     then if (pass = 1 & loop_state.base_regs (i).offset = 0)
			     | (pass = 2 & loop_state.base_regs (i).offset ^= 0)
			then bit3 =
				base_man_dispatch (loop_state.base_regs (i).type,
				loop_state.base_regs (i).variable, loop_state.base_regs (i).offset);
		     end;
		end;

	     /* Restore the indicators if xr_man altered them and they were protected. */

	     if saved_state ^= 0
	     then call restore_ind_state (saved_state);

	     /* Mark the flow_unit as refreshed so that we don't process redundantly. */

	     fu -> flow_unit.refreshed = "1"b;
	     end;

	/* Free all locked registers. */

	call free_regs ();

     end refresh_regs;

assign_register:
     procedure (p_adam, p_reg_type, p_regno, p_code, p_var, p_off);

	/* Assigns an item to a register across adam and all loops contained in adam */

dcl  (adam, p_adam) pointer,				/* -> loop nest over which reg is assigned */
     (reg_type, p_reg_type) fixed binary,		/* INDEX, BASE */
     (regno, p_regno) fixed binary (3),			/* register number */
     (code, p_code) fixed binary (18),
     (var, p_var) fixed binary (18),
     (off, p_off) fixed binary (18);

dcl  p pointer;

	/* copy in the parameters */

	adam = p_adam;
	reg_type = p_reg_type;
	regno = p_regno;
	code = p_code;
	var = p_var;
	off = p_off;

	/* assign the item to the register in adam */

	call assign (adam);

	if adam -> loop.son = null
	then return;

	/* By using a simulated recursive walk, assign the item to the register
	   in all loops contained in adam. */

	p = adam -> loop.son;

	do while ("1"b);
	     call assign (p);

	     if p -> loop.son ^= null
	     then p = p -> loop.son;

	     else do;
		do while (p -> loop.brother = null);
		     p = p -> loop.father;
		     if p = adam
		     then return;
		     end;

		p = p -> loop.brother;
		end;

	     end;

	return;

assign:
     procedure (lp);

dcl  lp pointer;					/* -> loop node */

dcl  msp pointer;

	if lp -> loop.msp ^= null
	then msp = lp -> loop.msp;
	else lp -> loop.msp, msp = create_machine_state ();

	if reg_type = INDEX
	then do;
	     msp -> machine_state.index_regs (regno).global = "1"b;
	     msp -> machine_state.index_regs (regno).type = code;
	     msp -> machine_state.index_regs (regno).variable = var;
	     msp -> machine_state.value_in_xr = "1"b;
	     end;

	else do;
	     msp -> machine_state.base_regs (regno).global = "1"b;
	     msp -> machine_state.base_regs (regno).type = code;
	     msp -> machine_state.base_regs (regno).variable = var;
	     msp -> machine_state.base_regs (regno).offset = off;
	     if code = 1
	     then msp -> machine_state.address_in_base = "1"b;
	     end;

     end assign;

     end assign_register;

create_machine_state:
     procedure () returns (pointer);

	/* Allocates a machine_state node */

dcl  msp pointer;

	if next_free_opt_ms = null
	then msp = get_opt_space (size (machine_state));
	else do;
	     msp = next_free_opt_ms;
	     next_free_opt_ms = msp -> machine_state.next;
	     unspec (msp -> machine_state) = "0"b;
	     end;

	msp -> machine_state.node_type = machine_state_node;
	msp -> machine_state.next = null;

	return (msp);

     end create_machine_state;

is_induction_var:
     procedure (p) returns (bit (1) aligned);

	/* Returns "1"b if p -> symbol for an induction variable in cur_lp */

dcl  p pointer;

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then return (substr (cur_lp -> loop.induction_var -> bits, p -> symbol.coordinate, 1));

	return ("0"b);

     end is_induction_var;

find_range:
     procedure (pt, lp) returns (pointer);

	/* Finds range data for a variable. */

dcl  (
     p unaligned,
     pt
     ) pointer,					/* -> symbol node */
     lp pointer;					/* -> loop node */

dcl  r pointer;

	p = pt;

	do r = lp -> loop.range_list repeat r -> range.next while (r ^= null);
	     if p = r -> range.variable
	     then return (r);
	     end;

	return (null);

     end find_range;

definitely_initialized:
     procedure (coord, start_fu) returns (bit (1) aligned);

dcl  coord fixed binary (18),				/* Coordinate of symbol that we're checking out */
     start_fu pointer;				/* Flow_unit in which we're trying to check out the symbol */

dcl  i fixed binary;
dcl  fu pointer;

	/* We attempt to determine if a symbol has been definitely
	   initialized by searching back along the dominator chain.
	   This is not really the best method for accuracy or speed.
	   If this is important, it should be done by a more formal
	   data_flow_analysis method in fort_optimizer.  This algorithm
	   does err on the side of safety. */

	i = coord;

	do fu = start_fu repeat fu -> flow_unit.dominator while (fu ^= null);
	     if substr (fu -> flow_unit.always_completely_set -> bits, i, 1)
	     then return ("1"b);
	     end;

	return ("0"b);

     end definitely_initialized;

/**** REFERENCE COUNTS ****/

get_ref_count:
     procedure (p) returns (fixed binary (18));

	/* Returns temporary.ref_count or temporary.ref_count_copy depending
	   on whether we are analyzing or generating code. */

dcl  p pointer;					/* -> temporary node or array_ref node */

	if analyzing
	then return (p -> temporary.ref_count_copy);
	else return (p -> temporary.ref_count);

     end get_ref_count;

bump_count:
     procedure (opnd, incre);

	/* Increments ref count of opnd by incre */

dcl  opnd fixed binary (18);
dcl  incre fixed binary (18);				/* amount to bump ref count */

dcl  p pointer;

	p = addr (rands (opnd));

	if p -> node.node_type = array_ref_node | p -> node.node_type = temporary_node
	then if analyzing
	     then p -> temporary.ref_count_copy = p -> temporary.ref_count_copy + incre;
	     else p -> temporary.ref_count = p -> temporary.ref_count + incre;

     end bump_count;

drop_count:
     procedure (opnd, incre);

	/* Decrement ref count of opnd by incre */

dcl  opnd fixed binary (18);
dcl  incre fixed binary (18);				/* amount to drop ref count */
dcl  tp pointer;
dcl  n fixed binary;

	if opnd > 0
	then do;
	     tp = addr (rands (opnd));

	     if tp -> node.node_type = array_ref_node
	     then do;
		if analyzing
		then n, tp -> array_ref.ref_count_copy = tp -> array_ref.ref_count_copy - incre;
		else n, tp -> array_ref.ref_count = tp -> array_ref.ref_count - incre;
		if n <= 0
		then call free_array_ref (tp);
		end;

	     else if tp -> node.node_type = temporary_node
	     then do;
		if analyzing
		then n, tp -> temporary.ref_count_copy = tp -> temporary.ref_count_copy - incre;
		else n, tp -> temporary.ref_count = tp -> temporary.ref_count - incre;
		if n <= 0
		then call free_temp (tp);
		end;
	     end;

     end drop_count;

bump_all_ms_ref_counts:
     procedure ();

	/* Bumps ms_ref_count for everything currently in the machine state */

dcl  (i, r) fixed binary (18);

	do r = 1 to hbound (current_ms.eaq, 1);		/* A, Q, EAQ, IND */
	     do i = 1 to current_ms.eaq (r).number;
		call bump_ms_ref_count (addr (rands (current_ms.eaq (r).variable (i))));
		end;
	     end;

	if current_ms.value_in_xr
	then do i = first_index to last_index;
		if current_ms.index_regs (i).type = 1
		then call bump_ms_ref_count (addr (rands (current_ms.index_regs (i).variable)));
		end;

	if current_ms.address_in_base
	then do i = first_base to last_base;
		if current_ms.base_regs (i).type = 1
		then call bump_ms_ref_count (addr (rands (current_ms.base_regs (i).variable)));
		end;

	return;

bump_ms_ref_count:
     procedure (node_pt);

	/* Bumps ms ref count for the given operand */

dcl  node_pt pointer;

	if node_pt -> node.node_type = temporary_node
	then node_pt -> temporary.ms_ref_count = node_pt -> temporary.ms_ref_count + 1;

     end bump_ms_ref_count;

     end bump_all_ms_ref_counts;

drop_all_ms_ref_counts:
     procedure (affected_ms);

	/* Drops ms_ref_count for everything in specified machine state */

dcl  1 affected_ms aligned like machine_state;
dcl  count_is_zero bit (1) aligned;
dcl  (i, j, r) fixed binary (18);

	do r = 1 to hbound (current_ms.eaq, 1);		/* A, Q, EAQ, IND */
	     do i = affected_ms.eaq (r).number to 1 by -1;
		call drop_ms_ref_count (addr (rands (affected_ms.eaq (r).variable (i))), count_is_zero);

		if count_is_zero
		then do;
		     affected_ms.eaq (r).number = affected_ms.eaq (r).number - 1;
		     do j = i to affected_ms.eaq (r).number;
			affected_ms.eaq (r).variable (j) = affected_ms.eaq (r).variable (j + 1);
			end;
		     end;
		end;

	     if affected_ms.eaq (r).number = 0
	     then affected_ms.eaq (r).name = 0;

	     end;

	if affected_ms.value_in_xr
	then do i = first_index to last_index;
		if affected_ms.index_regs (i).type = 1
		then do;
		     call drop_ms_ref_count (addr (rands (affected_ms.index_regs (i).variable)), count_is_zero);

		     if count_is_zero
		     then affected_ms.index_regs (i).type, affected_ms.index_regs (i).variable = 0;
		     end;
		end;

	if affected_ms.address_in_base
	then do i = first_base to last_base;
		if affected_ms.base_regs (i).type = 1
		then do;
		     call drop_ms_ref_count (addr (rands (affected_ms.base_regs (i).variable)), count_is_zero);

		     if count_is_zero
		     then affected_ms.base_regs (i).type, affected_ms.base_regs (i).variable = 0;
		     end;
		end;

     end drop_all_ms_ref_counts;

drop_ms_ref_count:
     procedure (node_pt, ref_count_is_zero);

	/* Drops the ms ref_count of the given operand */

dcl  node_pt pointer;
dcl  ref_count_is_zero bit (1) aligned;			/* true ref_count, not ms_ref_count, is zero */

	if node_pt -> node.node_type = temporary_node
	then do;
	     node_pt -> temporary.ms_ref_count = node_pt -> temporary.ms_ref_count - 1;

	     if get_ref_count (node_pt) <= 0
	     then do;
		ref_count_is_zero = "1"b;
		if node_pt -> temporary.ms_ref_count <= 0
		then call free_temp ((node_pt));
		end;
	     else ref_count_is_zero = "0"b;
	     end;
	else ref_count_is_zero = "0"b;

     end drop_ms_ref_count;

/**** REL_CONSTANTS ****/

alloc_relcon:
     procedure (opnd, value);

	/* Allocates a rel_constant */

dcl  opnd fixed binary (18),				/* Operand offset in region */
     value fixed binary (18);				/* Value to be assigned to operand */

dcl  p pointer;

	p = addr (rands (opnd));

	p -> label.location = value;
	p -> label.allocated = "1"b;

     end alloc_relcon;

alloc_label:
     procedure (a_opnd, value);

	/* Does everything required to "define" an executable rel const. */

dcl  a_opnd fixed binary (18);
dcl  value fixed binary (18);
dcl  opnd fixed binary (18);
dcl  (lbl, st) pointer;

	opnd = a_opnd;
	lbl = addr (rands (opnd));

	if lbl -> label.referenced_executable
	then if lbl -> label.statement > 0
	     then do;
		st = addr (quad (lbl -> label.statement));

		/* set up correct machine state; flush state if label is backward ref */

		if st -> opt_statement.referenced_backwards | st -> opt_statement.referenced_by_assign
		then if st -> opt_statement.machine_state = 0
		     then do;
			call flush_state;		/* flush machine state since we have no info on regs */
			call adjust_state_for_globals;/* any globally assigned items can be added to ms */

			/* force doubleword alignment for entry of innermost loop */

			if mod (value, 2) ^= 0 & cur_lp -> loop.son = null & cur_lp -> loop.entry_unit = fu
			then call emit_zero (nop);
			end;

		     else do;			/* statement cannot have a machine state!!! */
			call print_message (444);	/* fatal */
			return;
			end;

		else if st -> opt_statement.machine_state > 0
		then do;
		     call merge_state (current_ms, addr (rands (st -> opt_statement.machine_state)) -> machine_state,
			"1"b);
		     st -> opt_statement.machine_state = 0;
		     end;

		state_discarded = "0"b;
		end;

	call alloc_relcon (opnd, (value));

	if lbl -> label.restore_prs
	then call emit_zero (getlp);                 /* Restore frozen ptr reg (pr4) */

     end alloc_label;

/**** BUILD PROFILE ENTRY ****/

build_profile_entry:
     procedure ();

	if ^generate_long_profile
	then call use_ind;				/* aos sets indicators */

	if analyzing
	then return;				/* modified to produce both long and short profile. */

	if generate_long_profile
	then do;					/* long_profile */
	     call emit_operator_call (long_profile);

	     /* emit internal static relative offset to long_profile_header */

	     text_halfs (text_pos).left = profile_start;
	     reloc (text_pos).left_rel = rc_is18;

	     /* emit relative offset from long_profile_header to entry */

	     text_halfs (text_pos).right = profile_pos;
	     reloc (text_pos).right_rel = rc_a;
	     text_pos = text_pos + 1;
	     profile_pos = profile_pos + size (long_profile_entry);
	     end;
	else do;					/* short profile */
	     call emit_c_a (aos, c_a (profile_pos + 1, 5));
	     reloc (text_pos - 1).left_rel = rc_is15;

	     profile_pos = profile_pos + size (profile_entry);
	     end;

     end build_profile_entry;

setup_message_structure:
     procedure ();

	/* Sets up message_structure for print & error macros */

dcl  i fixed binary (18);

	message_structure.message_number = left;
	message_structure.number_of_operands = macro_dt_inst (imac).data_type;

	do i = 1 to message_structure.number_of_operands;
	     imac = imac + 1;

	     left = macro_instruction (imac).left;
	     if left = 0
	     then do;

		/* have an operand as argument */

		message_structure.is_string (i) = "0"b;
		message_structure.operand_index (i) = stack (get_operand ((macro_instruction (imac).operand)));
		end;

	     else do;

		/* have a string as argument */

		message_structure.is_string (i) = "1"b;
		message_structure.string_length (i) = macro_dt_inst (imac).data_type;
		message_structure.string_ptr (i) = addrel (mac_base, macro_instruction (imac).left);
		end;
	     end;

     end setup_message_structure;

create_integer_constant:
     procedure (value) returns (fixed binary (18));

dcl  value fixed binary (35) aligned;
dcl  bvalue bit (72) aligned;

	bvalue = unspec (value);
	return (create_constant (int_mode, bvalue));

     end create_integer_constant;

/**** SUBSCRIPTING CODE ****/

	/* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */
optimized_subscript:
     procedure (quad_ptr);

	/* Prepares an array_ref node by using the operands of the
	   opt_subscript operator that produced it. */

dcl  quad_ptr pointer;				/* -> opt_subscript producing the array_ref */

dcl  (symbol_ptr, t, len) pointer;
dcl  (i, csize) fixed binary (18);

dcl  1 constant_address aligned,
       2 location fixed binary (17) unaligned,
       2 fill bit (11) unaligned,
       2 ext_base bit (1) unaligned,
       2 tag bit (6) unaligned;

	t = addr (rands (quad_ptr -> operator.output));

	if get_ref_count (t) = 0
	then do;
	     if ^analyzing
	     then call print_message (454, (quad_ptr -> operator.output));
	     return;
	     end;

	t -> array_ref.dont_update = "0"b;

	if t -> array_ref.has_address			/* see if already done */
	then return;

	symbol_ptr = addr (rands (quad_ptr -> operator.operand (1)));

	if quad_ptr -> operator.operand (3) = 0		/* =0 if no variable offset */
	then t -> array_ref.variable_offset = "0"b;
	else do;
	     t -> array_ref.variable_offset = "1"b;
	     t -> array_ref.v_offset = quad_ptr -> operator.operand (3);
	     end;

	t -> array_ref.variable_length = "0"b;

	if symbol_ptr -> symbol.VLA
	then do;
	     t -> array_ref.needs_pointer = "1"b;
	     unspec (t -> array_ref.address) = ""b;
	     t -> array_ref.ext_base = "1"b;
	     end;
	else do;
	     if quad_ptr -> operator.number = 4
	     then do;

		/* Fourth operand is length of substring reference */

		len = addr (rands (quad_ptr -> operator.operand (4)));
		if len -> node.operand_type = constant_type
		then do;
		     csize = addr (len -> constant.value) -> int_image;
		     if csize < 1
		     then do;
			call print_message (460, quad_ptr -> operator.operand (1));
			imac = fixed (rel (addr (fort_opt_macros_$error_macro)), 18);
			go to loop;
			end;
		     t -> array_ref.length = csize;
		     end;
		else do;
		     t -> array_ref.variable_length = "1"b;
		     t -> array_ref.length = quad_ptr -> operator.operand (4);
		     end;
		end;

	     else if t -> array_ref.data_type = char_mode
	     then do;
		csize = get_char_size (symbol_ptr);
		if csize < 0
		then t -> array_ref.length = csize + bias;
		else do;
		     t -> array_ref.variable_length = "1"b;
		     t -> array_ref.length = csize;
		     end;
		end;

	     t -> array_ref.needs_pointer = symbol_ptr -> symbol.needs_pointer;

	     if symbol_ptr -> symbol.named_constant
	     then do;
		unspec (t -> array_ref.address) = (36)"0"b;
		t -> array_ref.reloc = rc_t;
		i = addr (rands (symbol_ptr -> symbol.initial)) -> char_constant.address.location;
		end;
	     else do;
		unspec (t -> array_ref.address) = unspec (symbol_ptr -> symbol.address);
		t -> array_ref.reloc = symbol_ptr -> symbol.reloc;
		i = symbol_ptr -> symbol.address.offset;
		end;

	     if ^t -> array_ref.variable_offset
	     then t -> array_ref.is_addressable = ^t -> array_ref.needs_pointer;

	     t -> array_ref.units = symbol_ptr -> symbol.units;

	     if symbol_ptr -> symbol.large_address
	     then i = i + symbol_ptr -> symbol.location;

	     if symbol_ptr -> symbol.units = char_units
	     then i = i * chars_per_word + symbol_ptr -> symbol.address.char_num;

	     i = i + addr (addr (rands (quad_ptr -> operator.operand (2))) -> constant.value) -> int_image;

	     if symbol_ptr -> symbol.units = char_units
	     then do;
		t -> array_ref.address.char_num = mod (i, chars_per_word);
		if (i < 0) & (t -> array_ref.address.char_num ^= 0)
		then i = divide (i, chars_per_word, 18, 0) - 1;
		else i = divide (i, chars_per_word, 18, 0);
		end;

	     if symbol_ptr -> symbol.named_constant
	     then do;
		constant_address.location = i;
		substr (unspec (t -> array_ref.address), 1, 18) = unspec (constant_address.location);
		end;
	     else do;

		/* If the symbol node had large_addressing then the base in the array_ref
		   node will be incorrect if the array ref is a ^large_address.  Therefore
		   or large_address flags to cause base re-evaluation if required. */


		call set_address_offset (t, i, (symbol_ptr -> symbol.element_size), (symbol_ptr -> symbol.units));
		t -> array_ref.large_address = t -> array_ref.large_address | symbol_ptr -> symbol.large_address;
		end;
	     end;

	t -> array_ref.has_address = "1"b;

	/* The opt_subscript operator counts as a use of the offset
	   and length temporaries, which should decrement their ref
	   counts.  However, we also connect these temporaries to the
	   output array_ref node, which should increment their ref
	   counts.  Thus, the two operations cancel, and we do nothing
	   to the reference counts. */

     end optimized_subscript;

get_param_array_size:
     procedure (sym);

	/* Figures out the size of parameter arrays of
	   expression extents */

dcl  (d, s) pointer;
dcl  (vsum, i) fixed binary (18);
dcl  code_emitted bit (1) aligned;

dcl  sym pointer;

dcl  (virtual_origin, array_size, c_virtual_origin, c_multiplier, ndims, c_mult_offset, desc) fixed binary (18);
dcl  v_multiplier bit (1) aligned;
dcl  vo_already_set bit (1) aligned;

	s = sym;

	if ^s -> symbol.variable_extents & ^s -> symbol.star_extents
	then return;

	desc = s -> symbol.hash_chain;

	/* If there is a descriptor template node, but it has not been
	   assigned storage, then it is only needed to build the entry
	   point definitions and we can ignore it. */

	if desc ^= 0
	then if ^addr (rands (desc)) -> symbol.allocated
	     then desc = 0;

	d = addr (rands (s -> symbol.dimension));

	ndims = d -> dimension.number_of_dims;

	/* Get array_size symbol */

	array_size = d -> dimension.array_size;

	/* Copy descriptor template to automatic storage, but only
	   if get_param_char_size has not done so already. */

	if desc ^= 0 & s -> symbol.v_length = 0
	then call copy_array_desc_template (s);

	/* The rest of the code concerns itself with computing
	   the array size and virtual origin, and with initializing
	   the bound information in the descriptor. */

	/* For some 1 dimensional arrays, we can emit a more efficient
	   code sequence than is possible in the general case. */

	if ndims = 1 & desc = 0 & s -> symbol.v_length = 0 & ^d -> dimension.v_bound (1).lower
	then do;
	     d -> dimension.virtual_origin = s -> symbol.element_size * d -> dimension.lower_bound (1);
	     d -> dimension.has_virtual_origin = "1"b;
	     d -> dimension.variable_virtual_origin = "0"b;

	     code_emitted = "1"b;
	     call compute_dimension_size (1);

	     if ^d -> dimension.assumed_size
	     then do;
		call load ((d -> dimension.size (1)), in_q);
		call mult (s -> symbol.element_size - bias);
		call store (array_size, in_q, 0);
		end;
	     return;
	     end;

	/* The more general sequence must be used. */

	code_emitted = "0"b;
	virtual_origin = 0;
	c_virtual_origin = 0;

	if s -> symbol.v_length = 0
	then do;
	     c_multiplier = s -> symbol.element_size;
	     v_multiplier = "0"b;
	     end;
	else do;
	     c_multiplier = 1;
	     v_multiplier = "1"b;
	     end;

	if s -> symbol.units = char_units & desc ^= 0 & v_multiplier & shared_globals.user_options.table
	then c_mult_offset = ndims * 3;		/* possible variable dims */
	else c_mult_offset = 0;			/* constant dims */

	do i = 1 to ndims;

	     /* This section of code accumulates the virtual origin
	        and array size as long as the dimension bounds remain
	        constant.  When a variable bound is encountered, code
	        is emitted to initialize the virtual origin and array
	        size to the accumulated partial result. */
	     /* if we start with a variable multiplier (i.e. symbol.v_length
	        ^= 0 then ALL MULTIPLIERS MUST BE CALCULATED, not just the
	        LAST one. */

	     if ^code_emitted
	     then do;
		if string (d -> dimension.v_bound (i)) = "00"b & i < ndims & ^v_multiplier
		then do;
		     c_virtual_origin = c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i);
		     c_multiplier = c_multiplier * d -> dimension.size (i);
		     end;
		else do;
		     code_emitted = "1"b;
		     if i = ndims & ^v_multiplier & ^d -> dimension.v_bound (i).lower
		     then do;

			/* The virtual origin is constant. */

			d -> dimension.virtual_origin =
			     c_virtual_origin + c_multiplier * d -> dimension.lower_bound (i);
			d -> dimension.has_virtual_origin = "1"b;
			d -> dimension.variable_virtual_origin = "0"b;
			end;
		     else do;

			/* The virtual origin is variable. */

			virtual_origin = get_virtual_origin (s, vo_already_set);

			if ^vo_already_set
			then do;
			     if c_virtual_origin = 0
			     then call emit_single (stz, virtual_origin);
			     else do;
				if v_multiplier
				then do;
				     call load ((s -> symbol.v_length), in_q);
				     call mult (c_virtual_origin - bias);
				     end;
				else call load (create_integer_constant ((c_virtual_origin)), in_q);
				call store (virtual_origin, in_q, 0);
				end;
			     end;
			end;

		     /* Initialize the array size. */

		     if v_multiplier
		     then do;
			call load ((s -> symbol.v_length), in_q);
			call mult (c_multiplier - bias);
			end;
		     else call load (create_integer_constant ((c_multiplier)), in_q);

		     /* The array size is left in the Q register. */

		     call in_reg (array_size, in_q);
		     end;
		end;

	     /* The following block of code is executed once a variable
	        array bound has been encountered. */

	     if code_emitted
	     then do;

		/* Store the multiplier for this dimension in the
		   descriptor if appropriate. */
		/* If we will generate a runtime symbol entry and we have
		   star_extents in a character string  then save the byte
		   length in the runtime multiplier and the bit length will
		   be concocted later and stored in the true descriptor. */

		if desc ^= 0 & v_multiplier
		then if c_mult_offset ^= 0
		     then call emit_single_with_inc (store_inst (in_q), desc, c_mult_offset + i);
		     else call emit_single_with_inc (store_inst (in_q), desc, 3 * i);

		/* Store the array size if necessary.  If the lower
		   bound is known to be 1, we do not need to store the
		   array size because (1) multiplying it by 1 to compute
		   the virtual origin doesn't change it and (2) the Q
		   is left intact by compute_dimension_size in this
		   particular case. */

		if d -> dimension.v_bound (i).lower | d -> dimension.lower_bound (i) ^= 1
		then call store (array_size, in_q, 1);

		/* Update the virtual origin. */

		if virtual_origin ^= 0 & ^vo_already_set
		then do;
		     if d -> dimension.v_bound (i).lower
		     then call mult ((d -> dimension.lower_bound (i)));
		     else if d -> dimension.lower_bound (i) ^= 1
		     then call mult (d -> dimension.lower_bound (i) - bias);

		     call emit_single (asq, virtual_origin);
		     end;

		/* Compute the size of this dimension, and store the
		   bounds in the array's descriptor. */

		call compute_dimension_size (i);

		/* Update the array size to include the size of this
		   dimension.  One of two code sequences is chosen
		   depending on what is in the Q register.  This need
		   not be done if this is the last dimension of an
		   assumed size array. */

		if i < ndims | ^d -> dimension.assumed_size
		then do;
		     if get_eaq_name (array_size) = in_q
		     then do;

			/* Multiply by dimension size. */

			call load (array_size, in_q);
			if string (d -> dimension.v_bound (i)) = "00"b
			then call mult (d -> dimension.size (i) - bias);
			else call mult ((d -> dimension.size (i)));
			end;
		     else do;

			/* Multiply by array size. */

			if string (d -> dimension.v_bound (i)) = "00"b
			then call load (create_integer_constant ((d -> dimension.size (i))), in_q);
			else call load ((d -> dimension.size (i)), in_q);
			call mult (array_size);
			end;

		     /* The updated array size is left in the Q. */

		     call in_reg (array_size, in_q);
		     end;

		/* If bounds are variable, so is multiplier. */

		v_multiplier = v_multiplier | (string (d -> dimension.v_bound (i)) ^= "00"b);
		end;

	     end;

	/* Store the array size. */

	if ^d -> dimension.assumed_size
	then call store (array_size, in_q, 1);

	/* If the array is in character units and there is a descriptor,
	   the mulipliers must be converted from characters to bits. */

	if s -> symbol.units = char_units & desc ^= 0
	then do;
	     if s -> symbol.v_length ^= 0
	     then i = 1;
	     else i = 2;
	     do i = i to ndims;
		if c_mult_offset ^= 0
		then call emit_single_with_inc (load_inst (in_q), desc, c_mult_offset + i);
		else call emit_single_with_inc (load_inst (in_q), desc, 3 * i);
		call emit_single (mpy, bits_per_char - bias);
		call emit_single_with_inc (store_inst (in_q), desc, 3 * i);
		end;
	     call reset_eaq (Q);
	     end;

	return;

compute_dimension_size:
     procedure (dim_no);

	/* Emits code to compute the number of elements in a given
	   dimension.  Also stores variable array bounds in the array
	   descriptor. */

dcl  dim_no fixed binary (18);
dcl  i fixed binary (3);

	i = dim_no;

	/* If this is the last dimension of an assumed size array,
	   the dimension size must not be calculated.  Simply copy
	   the lower bound to the descriptor if necessary. */

	if (i = ndims) & d -> dimension.assumed_size
	then do;
	     if (desc ^= 0) & d -> dimension.v_bound (i).lower
	     then do;
		call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i)));
		call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2);
		end;
	     return;
	     end;

	/* The dimension size must be computed. */

	if string (d -> dimension.v_bound (i)) = "01"b
	then do;
	     if d -> dimension.lower_bound (i) = 1
	     then do;

		/* Lower bound is the constant 1.  The dimension size
		   is already correct.  If the upper bound needs to be
		   copied to the descriptor, we use the A register, as
		   the main loop in get_param_array_size depends on
		   the Q register remaining intact. */

		if desc ^= 0
		then do;
		     call emit_single (load_inst (in_a), (d -> dimension.upper_bound (i)));
		     call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 1);
		     end;
		end;
	     else do;

		/* Lower bound is some constant other than 1. */

		call load ((d -> dimension.upper_bound (i)), in_q);
		if desc ^= 0
		then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1);
		call sub (d -> dimension.lower_bound (i) - 1 - bias);
		call store ((d -> dimension.size (i)), in_q, 0);
		end;
	     end;

	else if string (d -> dimension.v_bound (i)) = "10"b
	then do;
	     if desc ^= 0
	     then do;
		call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i)));
		call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2);
		end;
	     call load (create_integer_constant (1 + d -> dimension.upper_bound (i)), in_q);
	     call sub ((d -> dimension.lower_bound (i)));
	     call store ((d -> dimension.size (i)), in_q, 0);
	     end;

	else if string (d -> dimension.v_bound (i)) = "11"b
	then do;
	     if desc ^= 0
	     then do;
		call emit_single (load_inst (in_a), (d -> dimension.lower_bound (i)));
		call emit_single_with_inc (store_inst (in_a), desc, 3 * i - 2);
		end;
	     call load ((d -> dimension.upper_bound (i)), in_q);
	     if desc ^= 0
	     then call emit_single_with_inc (store_inst (in_q), desc, 3 * i - 1);
	     call sub ((d -> dimension.lower_bound (i)));
	     call add (1 - bias);
	     call store ((d -> dimension.size (i)), in_q, 0);
	     end;

     end compute_dimension_size;

load_vsum:
     procedure ();

	/* Emits code to load the variable sum into the Q */

	call load (vsum, in_q);
	code_emitted = "1"b;

     end load_vsum;

mult:
     procedure (op);

	/* Emits code to multiply the variable sum by op */

dcl  op fixed binary (18);

	if ^code_emitted
	then call load_vsum;

	if op + bias < 0
	then call copy (create_integer_constant (op + bias));
	else call copy (op);
	call interpreter_proc (subscript_mpy, r2);
r2:
	call reset_eaq (Q);				/* Value has been modified */

     end mult;

add:
     procedure (op);

	/* Emits code to add op to the variable sum in the Q */

dcl  (mac, op) fixed binary (18);

	mac = adfx1;
	go to join;


sub:
     entry (op);

	/* Emits code to subtract op from the variable sum in the Q */

	mac = sbfx1;

join:
	if ^code_emitted
	then call load_vsum ();

	if op + bias < 0
	then call emit_single (mac, create_integer_constant (op + bias));
	else call emit_single (mac, op);

	call reset_eaq (Q);

     end add;

     end get_param_array_size;

get_virtual_origin:
     procedure (symbol_ptr, found) returns (fixed binary (18));

	/* Returns the operand offset of an array's virtual origin
	   symbol.  found is turned on if the virtual origin is found in
	   the list of those virtual origins that have already been
	   computed in the current entry sequence. */

dcl  symbol_ptr pointer;
dcl  found bit (1) aligned;

dcl  (s, d) pointer;
dcl  i fixed binary (17);

	s = symbol_ptr;
	d = addr (rands (s -> symbol.dimension));

	if s -> symbol.star_extents
	then do;
	     found = "0"b;
	     return (d -> dimension.virtual_origin);
	     end;

	do i = 1 by 1 while (i <= virtual_origin_count);
	     if computed_virtual_origin (i) = d -> dimension.virtual_origin
	     then do;
		found = "1"b;
		return (d -> dimension.virtual_origin);
		end;
	     end;

	found = "0"b;
	if virtual_origin_count < hbound (computed_virtual_origin, 1)
	then do;
	     virtual_origin_count = virtual_origin_count + 1;
	     computed_virtual_origin (virtual_origin_count) = d -> dimension.virtual_origin;
	     end;

	return (d -> dimension.virtual_origin);

     end get_virtual_origin;

free_array_ref:
     procedure (pt);

	/* Frees an array_ref.  The variable length and offset
	   temporaries are also freed if necessary. */

dcl  (pt, p, t) pointer;
dcl  (a_ref, n) fixed binary (18);

	p = pt;
	a_ref = fixed (rel (p), 18);

	if get_ref_count (p) < 0
	then do;
	     call print_message (415, a_ref);
	     return;
	     end;

	if p -> array_ref.v_offset ^= 0
	then do;
	     t = addr (rands (p -> array_ref.v_offset));
	     if t -> node.node_type = temporary_node
	     then do;
		if analyzing
		then n, t -> temporary.ref_count_copy = t -> temporary.ref_count_copy - 1;
		else n, t -> temporary.ref_count = t -> temporary.ref_count - 1;
		if n <= 0
		then call free_temp (t);
		end;
	     end;

	if p -> array_ref.variable_length
	then do;
	     t = addr (rands (p -> array_ref.length));
	     if t -> node.node_type = temporary_node
	     then do;
		if analyzing
		then n, t -> temporary.ref_count_copy = t -> temporary.ref_count_copy - 1;
		else n, t -> temporary.ref_count = t -> temporary.ref_count - 1;
		if n <= 0
		then call free_temp (t);
		end;
	     end;

	call flush_ref (a_ref);
	call flush_addr (a_ref);
	call disconnect_temp (p);

	p -> array_ref.dont_update = "1"b;

	if p -> array_ref.output_by = 0
	then do;
	     p -> array_ref.next = next_free_array_ref;
	     next_free_array_ref = a_ref;
	     end;

     end free_array_ref;

/**** CONCATENATION CODE ****/

start_cat:
     procedure (reallocated);

	/* Expects the stack to contain all the concatenation operands.
	   Computes the length of the result (emitting code if necessary),
	   and allocates the temporary for the result (which is pushed on
	   the stack.)  The parameter reallocated is turned on in the case
	   where the first operand of the concatenation is the most recently
	   allocated dynamic temporary.  (In this case the result temporary
	   is merely an extension of the first operand). */

dcl  reallocated bit (1) aligned;			/* (Output) */

dcl  alloc_length fixed binary (18);			/* Total of operand lengths */
dcl  result fixed binary (18);			/* Result temporary (pushed on stack) */
dcl  star_extent bit (1) aligned;			/* On if any operand is of * extent */
dcl  tv_offset fixed binary (14);			/* Operator offset */
dcl  i fixed binary;				/* Loop variable */

	/* Get total of allocated lengths of operands. */

	alloc_length = 0;
	star_extent = "0"b;
	do i = (top - quad_ptr -> operator.number + 1) to (top - 1) while (^star_extent);
	     alloc_length = alloc_length + get_cat_alloc_length ((stack (i)), star_extent);
	     end;

	if star_extent
	then do;

	     /* At least one of the operands was of star extent.  A dynamic
	        temporary is used for the result in this case. */

	     reallocated = (stack (base) = current_ms.last_dynamic_temp);

	     if reallocated
	     then tv_offset = reallocate_char_string;
	     else tv_offset = allocate_char_string;

	     result = assign_dynamic_temp ();
	     call assign_length_to_cat_result (result);
	     call allocate_dynamic_temp (result, tv_offset);
	     end;

	else do;

	     /* No star extents are involved - use an ordinary temp */

	     reallocated = "0"b;
	     result = assign_char_temp (alloc_length);
	     call assign_length_to_cat_result (result);
	     end;

	/* Initialize some variables that will be used as the concatenation
	   continues. */

	cat_offset_temp = 0;
	saved_cat_address = addr (rands (result)) -> temporary.address;

	call push (result);

     end start_cat;

continue_cat:
     procedure ();

	/* Adds the length of the most recently processed concatenation
	   operand into the address of the result.  The result is assumed
	   to be at the base of the stack, and the most recently processed
	   operand is assumed to be at the top. */

dcl  (p, p1) pointer;				/* To result, operand */
dcl  csize fixed binary (18);				/* Length of operand */
dcl  off fixed binary (18);				/* Total char offset */
dcl  regno fixed binary (3);				/* Base register number */

	p = addr (rands (stack (base)));
	p1 = addr (rands (stack (top)));

	csize = get_char_size (p1);
	if csize < 0
	then do;

	     /* Length of the operand is constant.  Try adding the length
	        to the address of the result, avoiding large address. */

	     off = p -> temporary.address.char_num + (p -> temporary.address.offset * chars_per_word) + (csize + bias);
	     if off < 16384 * chars_per_word
	     then do;
		p -> temporary.address.char_num = mod (off, chars_per_word);
		if (off < 0) & (p -> temporary.address.char_num ^= 0)
		then p -> temporary.address.offset = divide (off, chars_per_word, 18, 0) - 1;
		else p -> temporary.address.offset = divide (off, chars_per_word, 18, 0);
		return;
		end;
	     else csize = create_integer_constant (csize + bias);
	     end;

	/* The length will have to be kept in a register.  We use the Q,
	   so that the lengths of subsequent operands can be added. */

	if cat_offset_temp = 0
	then do;

	     /* This is the first operand length we have had to put in a
	        register.  Allocate a temporary to hold the variable offset
	        and load the length into the Q. */

	     cat_offset_temp = assign_temp (int_mode);
	     if analyzing
	     then addr (rands (cat_offset_temp)) -> temporary.ref_count_copy = 131071;
	     else addr (rands (cat_offset_temp)) -> temporary.ref_count = 131071;
	     call bump_count (csize, 1);
	     call load (csize, in_q);
	     call use_eaq (0, Q, 0);
	     call in_reg (cat_offset_temp, in_q);
	     end;

	else do;

	     /* Add the operand length into the variable offset. */

	     call load (cat_offset_temp, in_q);
	     addr (rands (cat_offset_temp)) -> temporary.not_in_storage = "0"b;
	     call bump_count (csize, 1);
	     call emit_single (adfx1, csize);
	     call in_reg (cat_offset_temp, in_q);
	     addr (rands (cat_offset_temp)) -> temporary.not_in_storage = "1"b;
	     end;

	/* Prevent emit_eis from using the Q in addressing by reserving it.
	   This is safe because at most one of the operands of the EIS
	   instruction can have a large offset. */

	call lock_eaq (Q);
	p -> temporary.address.tag = p -> temporary.address.tag | QL_mod;

	/* If the address of the result temporary is in a base register,
	   prevent m_a from using it by pretending it is reserved. */

	if p -> temporary.address_in_base
	then do;
	     regno = which_base (fixed (p -> temporary.address.base, 3));
	     current_ms.base_regs (regno).reserved = "1"b;
	     end;

     end continue_cat;

finish_cat:
     procedure ();

	/* Restores the original address of the result temporary, and
	   perform other cleanups now that the concatenation has been
	   completely compiled. */

	addr (rands (stack (base))) -> temporary.address = saved_cat_address;

	if cat_offset_temp ^= 0
	then call free_temp (addr (rands (cat_offset_temp)));

	call free_regs ();

     end finish_cat;

get_cat_alloc_length:
     procedure (opnd, star_extent) returns (fixed binary (18));

	/* Returns the allocation length of the character string operand
	   opnd.  If opnd is a star extent parameter, the star_extent bit
	   is turned on. */

dcl  opnd fixed binary (18);				/* Operand offset */
dcl  star_extent bit (1) aligned;
dcl  p pointer;					/* Pointer to operand */
dcl  csize fixed binary (18);				/* Character length */

	p = addr (rands (opnd));

	csize = get_char_size (p);
	if csize < 0
	then do;

	     /* Constant length */

	     star_extent = "0"b;
	     return (csize + bias);
	     end;

	/* If the operand is not of constant length, but is a substring or
	   array reference whose parent is of constant length, return the
	   parent's length as the length for allocation. */

	if p -> node.node_type = array_ref_node
	then do;
	     csize = get_char_size (addr (rands (p -> array_ref.parent)));
	     if csize < 0
	     then do;
		star_extent = "0"b;
		return (csize + bias);
		end;
	     end;

	/* If the operand is a variable length temporary that is not of star
	   extent, use the allocated length of the temporary. */

	else if p -> node.node_type = temporary_node
	then if ^p -> temporary.stack_indirect
	     then do;
		star_extent = "0"b;
		return (p -> temporary.size * chars_per_word);
		end;

	/* The operand must have been of star extent. */

	star_extent = "1"b;
	return (0);

     end get_cat_alloc_length;

assign_length_to_cat_result:
     procedure (cat_result);

	/* Puts the proper length onto the temporary which is the result of
	   concatenation operator currently being compiled.  The length is
	   taken from the last operand of the cat_op. */

dcl  cat_result fixed binary (18);

dcl  (length, result) pointer;

	result = addr (rands (cat_result));
	length = addr (rands (stack (top)));

	if length -> node.operand_type = constant_type
	then do;

	     /* Length is constant, so put it right in the temporary */

	     result -> temporary.length = addr (length -> constant.value) -> int_image;
	     result -> temporary.variable_length = "0"b;
	     end;

	else do;

	     /* Length is not constant - chain it to the temporary */

	     result -> temporary.length = stack (top);
	     result -> temporary.variable_length = "1"b;
	     end;

     end assign_length_to_cat_result;

/**** DESCRIPTOR RELATED CODE ****/

get_param_char_size:
     procedure (sym, arg_no);

	/* This procedure generates code to extract the length of a
	   star extent character string from the argument list
	   descriptor and store it in the symbol.v_length variable
	   allocated by the parse.  Also, if the character string is
	   passed as an argument and requires a descriptor of its own,
	   code is generated to initialize the automatic descriptor
	   from the template in the text section and to fill in the
	   length field. */

dcl  (s, sym) pointer;
dcl  arg_no fixed binary (18);

dcl  desc fixed binary (18);
dcl  mask fixed binary (18);				/* mask off high bits of Q register */

	s = sym;
	desc = s -> symbol.hash_chain;

	/* If there is a descriptor template node, but it has not been
	   assigned storage, then it is only needed to build the entry
	   point definitions and we can ignore it. */

	if desc ^= 0
	then if ^addr (rands (desc)) -> symbol.allocated
	     then desc = 0;

	/* Initialize the automatic descriptor if array */

	if desc ^= 0 & s -> symbol.dimensioned
	then call copy_array_desc_template (s);

	/* Extract length from descriptor and store it in symbol.v_length */

	addr (rands (builtins (11))) -> symbol.location = 2 * arg_no - 2;
	call emit_single ((load_inst (in_q)), (builtins (11)));
	call emit_c_a (anq, descriptor_mask_addr);
	call emit_single ((store_inst (in_q)), (s -> symbol.v_length));

	/* Put length into automatic descriptor */

	if desc ^= 0
	then do;
	     mask = create_constant (int_mode, "777700000000"b3);
	     if s -> symbol.dimensioned
	     then do;
		call emit_single (orq, mask);
		call emit_single (anq, desc);
		call emit_single (stq, desc);
		end;

	     else do;

		/* Get type bits while we're at it */
		call emit_single (orq, mask);
		call emit_single (anq, (addr (rands (desc)) -> symbol.general));
		call emit_single ((store_inst (in_q)), desc);
		end;
	     end;

	call reset_eaq (Q);

     end get_param_char_size;

copy_array_desc_template:
     procedure (sym);

	/* Generates code to copy the descriptor template for an array
	   from the text into automatic storage. */

dcl  (s, sym) pointer;
dcl  desc fixed binary (18);

	s = sym;
	desc = s -> symbol.hash_chain;

	call push ((addr (rands (desc)) -> symbol.general));
	call push (desc);
	call interpreter_proc (move_eis, r3);
r3:
	return;

     end copy_array_desc_template;

make_descriptor:
     procedure (var) returns (fixed binary (18));

	/* Builds a descriptor for var, which must be either a temporary,
	   an array reference, or a symbol of constant extent (variable-
	   and star-extent symbols have been dealt with at storage
	   allocation time.)  If the temporary or arry_ref is a character
	   string of star extent, code is emitted to fill in the length
	   field of the descriptor. */

dcl  var fixed binary (18);				/* argument that needs a descriptor */
dcl  p pointer;
dcl  (desc, const, dt, csize) fixed binary (18);
dcl  v_length bit (1) aligned;

dcl  1 descriptor aligned,				/* Scalars only */
       2 type_word aligned,
         3 bit_type unaligned,
	 4 flag bit (1) unaligned,
	 4 type bit (6) unaligned,
	 4 packed bit (1) unaligned,
         3 number_dims fixed binary (3) unaligned,
         3 size fixed binary (23) unaligned;

	p = addr (rands (var));
	unspec (descriptor) = "0"b;
	v_length = "0"b;

	/* Handle symbols */

	if p -> node.node_type = symbol_node
	then if p -> symbol.hash_chain ^= 0
	     then return (p -> symbol.hash_chain);
	     else return (make_symbol_descriptor ((var)));

	/* Initialize the descriptor's type word */

	if p -> node.operand_type >= bif
	then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7));
	else do;
	     dt = p -> node.data_type;
	     unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt));
	     if dt = char_mode
	     then do;
		if p -> node.units = char_units
		then descriptor.packed = "1"b;
		csize = get_char_size (p);
		if csize < 0
		then descriptor.size = csize + bias;
		else v_length = "1"b;
		end;
	     end;

	/* Create a constant node for the descriptor */

	const = create_constant (int_mode, unspec (descriptor.type_word));

	/* If the descriptor must be filled in at runtime, allocate a
	   temporary for it, and emit code to initialize it. */

	if v_length
	then do;
	     desc = assign_temp (int_mode);
	     if analyzing
	     then addr (rands (desc)) -> temporary.ref_count_copy = 131071;
	     else addr (rands (desc)) -> temporary.ref_count = 131071;
	     call load (get_char_size (p), in_q);
	     call emit_c_a (anq, descriptor_mask_addr);
	     call emit_single (orq, const);
	     call emit_single (store_inst (in_q), desc);
	     call reset_eaq (Q);

	     /* Chain this descriptor so that it can be freed after
	        the call has been compiled. */

	     addr (rands (desc)) -> temporary.next = desc_temp_chain;
	     desc_temp_chain = desc;
	     end;
	else desc = const;

	return (desc);

     end make_descriptor;

set_itp_addr:
     procedure (pt, pos);

	/* Sets one element of an ITP list to contain the
	   address of the operand pointed to by pt. */

dcl  (pt, p) pointer;
dcl  (pos, i) fixed binary (18);

	p = pt;
	i = pos;

	string (itp_list (i)) = "0"b;

	if p -> node.ext_base
	then do;
	     itp_list (i).pr_no = p -> node.base;
	     itp_list (i).itp_mod = ITP_mod;
	     itp_list (i).offset = bit (fixed (p -> node.address.offset, 18), 18);
	     itp_list (i).bit_offset = bit (fixed (p -> node.address.char_num * bits_per_char, 6), 6);

	     /* Fix bug344 - stack_indirect ITP needs RI (*n) indirect modification */

	     if p -> node.stack_indirect
	     then itp_list (i).mod = RI_mod;
	     end;
	else addr (itp_list (i)) -> ind_word = unspec (p -> node.address);

     end set_itp_addr;

check_arg_list:
     procedure ();

	/* Checks argument lists for consistency, using subprogram
	   definition if possible otherwise using the first invoction
	   of each subprogram as a model for checking.  If the call is
	   to an external (descriptors) procedure, consistency is not
	   checked, but assumed size arrays as arguments are diagnosed.
	   The stack looks like:

	   external reference
	   count
	   arg1
	   arg2
	   .
	   .
	   .
	   argn
	*/

dcl  (adesc, i) fixed binary (18);
dcl  (a, p, s) pointer;

	num_args = stack (base + 1) + bias;
	s = addr (rands (stack (base)));

	if s -> symbol.variable_arglist
	then do;

	     /* Must diagnose assumed size arrays as arguments */

	     do i = 1 to num_args;
		p = addr (rands (stack (base + i + 1)));
		if p -> node.node_type = symbol_node
		then if p -> symbol.dimensioned
		     then if addr (rands (p -> symbol.dimension)) -> dimension.assumed_size
			then call print_message (468, stack (base), stack (base + i + 1));
		end;
	     end;

	else do;
	     if s -> symbol.general = 0
	     then call find_arg_desc (s);
	     if s -> symbol.general = 0
	     then do;				/* couldn't find arg_desc node, probably an external procedure */

		/* first time, set up arg_desc structure */


		adesc, s -> symbol.general = create_node (arg_desc_node, size (arg_desc));
		a = addr (rands (adesc));
		a -> arg_desc.n_args = num_args;

		do i = 1 to num_args;
		     p = addr (rands (stack (base + i + 1)));
		     a -> arg_desc.data_type (i) = p -> node.data_type;
		     if p -> node.node_type = symbol_node
		     then if p -> symbol.dimensioned
			then do;
			     a -> arg_desc.must_be.array (i) = "1"b;
			     if p -> symbol.ext_attributes.VLA
			     then a -> arg_desc.must_be.VLA (i) = "1"b;
			     end;
			else a -> arg_desc.must_be.scalar (i) = "1"b;
		     else if p -> node.node_type ^= array_ref_node
		     then a -> arg_desc.must_be.scalar (i) = "1"b;
		     end;
		end;

	     else do;

		/* not the first time, compare args with arg_desc structure */

		a = addr (rands (s -> symbol.general));

		if num_args ^= a -> arg_desc.n_args
		then do;
		     call print_message (400, stack (base));
		     if num_args > a -> arg_desc.n_args
		     then num_args = a -> arg_desc.n_args;
		     end;

		do i = 1 to num_args;
		     p = addr (rands (stack (base + i + 1)));

		     /* When a program calls an internal subroutine with arguments
		        that are declared as different data types in the included
		        routine, it will raise an error except in the case of
		        passing a character constant. */

		     if (p -> node.node_type ^= char_constant_node)
		     then do;
			if (p -> node.data_type ^= a -> arg_desc.data_type (i))
			     &
			     ^(p -> node.node_type = temporary_node
			     & addr (rands (a -> arg_desc.arg (i).symbol)) -> symbol.external)
			then call bad_arg;

			else if p -> node.node_type = symbol_node
			then do;
			     if p -> symbol.dimensioned
			     then do;
				if a -> arg_desc.must_be.scalar (i)
				then call bad_arg;
				else if p -> symbol.ext_attributes.VLA
				then if ^a -> arg_desc.must_be.VLA (i)
				     then call bad_arg;
				end;
			     else if a -> arg_desc.must_be.array (i)
			     then call bad_arg;
			     end;
			else if p -> node.node_type ^= array_ref_node
			then if a -> arg_desc.must_be.array (i)
			     then call bad_arg;
			end;
		     end;
		end;
	     end;


bad_arg:
     procedure ();

	call print_message (401, stack (base + i + 1), stack (base));

     end bad_arg;

	/* This procedure finds an arg_desc node that corresponds to an entry node.
	   It looks up the entry node that corresponds to the actual declaration of
	   a subprogram (if one exists), and looks in its symbol.general field to
	   find its arg_desc node. It returns the location of the arg_desc node by
	   setting the referencing entry node's general field.  It also makes sure
	   that the arg_desc node contains the data_type associated with each
	   parameter. */
find_arg_desc:
     proc (sp);
dcl  (e, i, ii) fixed bin;
dcl  (sp, ap, ep, symp) ptr;

	/* find the entry node with the same name */
	e = shared_globals.first_entry_name;
	do while (addr (rands (e)) -> symbol.name ^= sp -> symbol.name & e ^= shared_globals.last_entry_name);
	     e = addr (rands (e)) -> symbol.next_symbol;
	     end;
	ep = addr (rands (e));

	if ep -> symbol.name ^= sp -> symbol.name
	then return;				/* couldn't find it */
	if ep -> symbol.general = 0
	then return;				/* no arg_desc node */

	sp -> symbol.general = ep -> symbol.general;

	/* make sure that the data_type fields are set.  If there are any * arguments
	   (indicated by there being no symbol node accociated with the argument), then
	   remove all of these args and place one * arg at the end of the list.  Set
	   its data_type to 1. */

	ap = addr (rands (ep -> symbol.general));
	ii = 1;
	do i = 1 to ap -> arg_desc.n_args;
	     if ap -> arg_desc.arg (i).symbol ^= 0
	     then do;
		ap -> arg_desc.arg (ii) = ap -> arg_desc.arg (i);
		if ap -> arg_desc.arg (ii).data_type = 0
		then do;
		     symp = addr (rands (ap -> arg_desc.arg (ii).symbol));
		     ap -> arg_desc.arg (ii).data_type = symp -> symbol.data_type;
		     if symp -> node.node_type = symbol_node
		     then if symp -> symbol.dimensioned
			then do;
			     ap -> arg_desc.arg (ii).must_be.array = "1"b;
			     if symp -> symbol.ext_attributes.VLA
			     then ap -> arg_desc.must_be.VLA (ii) = "1"b;
			     end;
			else ap -> arg_desc.arg (ii).must_be.scalar = "1"b;
		     else if symp -> node.node_type ^= array_ref_node
		     then ap -> arg_desc.arg (ii).must_be.scalar = "1"b;
		     end;
		ii = ii + 1;
		end;
	     end;
	if ii ^= i
	then do;

	     /* at least one asterisk arg was removed */

	     ap -> arg_desc.n_args = ii;
	     unspec (ap -> arg_desc.arg (ii)) = "0"b;
	     ap -> arg_desc.arg (ii).data_type = 1;
	     end;
     end find_arg_desc;

     end check_arg_list;

replace_inputs:
     procedure (old_input, new_input);

dcl  old_input fixed binary (18);			/* Existing temp */
dcl  new_input fixed binary (18);			/* Replacement */

dcl  (new, i) fixed binary (18);
dcl  input pointer;

	new = new_input;

	i = addr (rands (old_input)) -> temporary.start_input_to;
	if i = 0
	then return;

	do input = addr (polish (i)) repeat (input -> input_to.next) while (input ^= null ());
	     if input -> input_to.which > 0		/* Operand number */
	     then input -> input_to.operator -> operator.operand (input -> input_to.which) = new;
	     else if input -> input_to.which = 0	/* Output temp */
	     then input -> input_to.operator -> operator.output = new;
	     end;

     end replace_inputs;

/**** REGISTER USAGE ANALYSIS -- End of flow_unit, End of loop processing. ****/

reset_scan:
     procedure (cur_statement, statement_ptr, iquad, fu, cur_lp);

	/* Resets scanners at end of flow_unit.  May do end_of_loop processing. */

dcl  cur_statement fixed binary (18),			/* Current statement */
     statement_ptr pointer,				/* addr(quad(cur_statement)) */
     iquad fixed binary (18),				/* Next operator to be scanned */
     fu pointer,					/* flow_unit being processed */
     cur_lp pointer;				/* Loop being processed */

dcl  (next_lp, last_fu, next_stm) pointer;


	if fu -> flow_unit.next_in_loop ^= fu -> flow_unit.next
	then do;

	     /* We are either about to pass over flow_units from other
	        loops, or have processed the last flow_unit of this loop. */

	     if fu -> flow_unit.falls_through
	     then do;
		next_lp = fu -> flow_unit.next -> flow_unit.loop;

		if cur_lp -> loop.depth < next_lp -> loop.depth
		then call flush_state;
		else do;
		     next_stm = addr (quad (fu -> flow_unit.next -> flow_unit.first_statement));
		     if ^next_stm -> opt_statement.referenced_backwards
			& ^next_stm -> opt_statement.referenced_by_assign
		     then call save_state (get_label (next_stm));
		     call discard_state;
		     end;
		end;
	     end;

	if fu -> flow_unit.next_in_loop ^= null
	then do;

	     /* We have another flow_unit in this loop,
	        so initialize for the next flow_unit. */

	     last_fu = fu;
	     fu = fu -> flow_unit.next_in_loop;

	     if last_fu ^= fu -> flow_unit.back
	     then do;

		/* We have passed over flow_units from other loops. */

		if ^fu -> flow_unit.back -> flow_unit.falls_through
		then call discard_state;
		else if ^state_discarded
		then if next_lp ^= fu -> flow_unit.back -> flow_unit.loop
		     then call discard_state;
		end;
	     end;

	else do;

	     /* We've finished this loop. */

	     call allocate_registers;

	     string (cur_lp -> loop.father -> loop.erases) =
		string (cur_lp -> loop.father -> loop.erases) | string (cur_lp -> loop.erases);
	     string (cur_lp -> loop.father -> loop.avoid_pr) =
		string (cur_lp -> loop.father -> loop.avoid_pr) | string (cur_lp -> loop.avoid_pr);

	     call reset_global_data;

	     do i_loop = i_loop + 1 to n_loops - 1 while (loop_vector (i_loop) -> loop.members = null);
		end;

	     if i_loop >= n_loops
	     then do;
		iquad = cs -> subprogram.last_quad;
		return;
		end;

	     cur_lp = loop_vector (i_loop);
	     fu = cur_lp -> loop.members;
	     call discard_state;
	     end;

	cur_statement = fu -> flow_unit.first_statement;
	statement_ptr = addr (quad (cur_statement));
	iquad = statement_ptr -> opt_statement.first_operator;

     end reset_scan;

get_label:
     procedure (st) returns (fixed binary (18));

	/* Returns label attached to a statement.  Creates, if not found. */

dcl  st pointer;

dcl  lbl fixed binary (18);

	lbl = st -> opt_statement.label;

	if lbl = 0
	then do;
	     lbl, st -> opt_statement.label = create_rel_constant (cs);
	     addr (rands (lbl)) -> label.statement = fixed (rel (st), 18);
	     end;

	return (lbl);

     end get_label;

reset_global_data:
     procedure ();

	/* Resets info in ptr_data and index_data */

dcl  p pointer;

	ptr_data.local, ptr_data.max_local, ptr_data.locked, ptr_data.max_locked = 0;

	do while (ptr_data.n_global > 0);
	     p = ptr_data.item (ptr_data.n_global);
	     p -> pointer.count = 0;
	     ptr_data.n_global = ptr_data.n_global - 1;
	     end;

	index_data.local, index_data.max_local, index_data.locked, index_data.max_locked = 0;

	do while (index_data.n_global > 0);
	     p = index_data.item (index_data.n_global);
	     p -> node.loop_ref_count = 0;
	     index_data.n_global = index_data.n_global - 1;
	     end;

     end reset_global_data;

/**** GLOBAL REGISTER ALLOCATION ****/

allocate_registers:
     procedure ();

dcl  p pointer;
dcl  (i, n_allocated) fixed binary;

	/* Sort the global register items. */

	call sort_globals (ptr_data.item_st, ptr_data.n_global, BASE);
	call sort_globals (index_data.item_st, index_data.n_global, INDEX);

	/* Initialize the regs_used fields. */

	cur_lp -> loop.xregs_used =
	     max (index_data.max_local, index_data.max_locked, fixed (index_data.n_global > avail_xregs, 1));
	cur_lp -> loop.pregs_used =
	     max (ptr_data.max_local, ptr_data.max_locked, fixed (ptr_data.n_global > avail_pregs, 1));

	/* Process the globals in descending order. */

	do i = 1 to ptr_data.n_global while (cur_lp -> loop.pregs_used < avail_pregs);
	     p = ptr_data.item (i);
	     if ok_to_allocate (p, cur_lp, BASE)
	     then do;
		call allocate (p, cur_lp, BASE);
		cur_lp -> loop.pregs_used = cur_lp -> loop.pregs_used + 1;
		end;
	     end;

	n_allocated = 0;

	do i = 1 to index_data.n_global while (cur_lp -> loop.xregs_used < avail_xregs);
	     p = index_data.item (i);
	     if ok_to_allocate (p, cur_lp, INDEX)
	     then do;
		call allocate (p, cur_lp, INDEX);
		cur_lp -> loop.xregs_used = cur_lp -> loop.xregs_used + 1;
		n_allocated = n_allocated + 1;
		end;
	     end;

	if n_allocated = avail_xregs
	then cur_lp -> loop.all_xrs_globally_assigned = "1"b;

	return;

sort_globals:
     procedure (item_st, n_items, p_reg_type);

	/* Sorts global items in descending order by count of uses in the loop. */

dcl  1 item_st like ptr_data.item_st aligned;
dcl  n_items fixed binary;
dcl  (reg_type, p_reg_type) fixed binary;		/* INDEX, BASE */

dcl  (d, i, j, k) fixed binary;
dcl  (p1, p2, p) pointer;

	reg_type = p_reg_type;

	d = n_items;

	do while (d > 1);
	     d = 2 * divide (d, 4, 17, 0) + 1;

	     do i = 1 to n_items - d;
		k = i + d;
		p2 = item (k);
up:
		j = k - d;
		p1 = item (j);

		if less_than (p1, p2, reg_type)
		then do;
		     p = item (j);
		     item (j) = item (k);
		     item (k) = p;

		     if j > d
		     then do;
			k = j;
			go to up;
			end;
		     end;
		end;
	     end;

	return;

less_than:
     procedure (p1, p2, reg_type) returns (bit (1) aligned);

dcl  (p1, p2) pointer;
dcl  reg_type fixed binary;				/* INDEX, BASE */

	if reg_type = INDEX
	then return (p1 -> node.loop_ref_count < p2 -> node.loop_ref_count);
	else return (p1 -> pointer.count < p2 -> pointer.count);

     end less_than;

     end sort_globals;

ok_to_allocate:
     procedure (pt, p_adam, p_reg_type) returns (bit (1) aligned);

	/* Determines if it is ok to allocate a global item across inner loops. */

dcl  (p, pt) pointer,				/* -> global item */
     (adam, p_adam) pointer,				/* -> loop */
     (reg_type, p_reg_type) fixed binary;		/* INDEX, BASE */

dcl  lp pointer;

	adam = p_adam;

	if adam -> loop.son = null
	then return ("1"b);

	p = pt;
	reg_type = p_reg_type;

	/* Simulate a recursive walk across the loop nest. */

	lp = adam -> loop.son;

	do while ("1"b);
	     if reg_type = INDEX
	     then if ^ok ((lp -> loop.xregs_used), avail_xregs, (lp -> loop.global_xr_items))
		then return ("0"b);
		else ;
	     else if ^ok ((lp -> loop.pregs_used), avail_pregs, (lp -> loop.global_pr_items))
	     then return ("0"b);

	     if lp -> loop.son ^= null
	     then lp = lp -> loop.son;

	     else do;
		do while (lp -> loop.brother = null);
		     lp = lp -> loop.father;
		     if lp = adam
		     then return ("1"b);
		     end;

		lp = lp -> loop.brother;
		end;
	     end;

	stop;

ok:
     procedure (regs_used, avail_regs, item_chain) returns (bit (1) aligned);

dcl  regs_used fixed binary (4),
     avail_regs fixed binary (4),
     item_chain pointer;

dcl  c pointer;
dcl  found bit (1) aligned;

	if regs_used >= avail_regs
	then do;
	     found = "0"b;
	     do c = item_chain repeat c -> chain.next while (^found & c ^= null);
		if p = c -> chain.value
		then found = "1"b;
		end;

	     if ^found
	     then return ("0"b);
	     end;

	return ("1"b);

     end ok;

     end ok_to_allocate;

allocate:
     procedure (pt, p_adam, p_reg_type);

	/* Allocate a global item across a loop next. */

dcl  (p, pt) pointer,				/* -> global item */
     (adam, p_adam) pointer,				/* -> loop */
     (reg_type, p_reg_type) fixed binary;		/* INDEX, BASE */

dcl  (opnd, new_opnd) fixed binary (18);

dcl  (bt, c, list_head, lp) pointer;
dcl  (op, op_code) fixed binary (18);
dcl  n fixed binary;

	p = pt;
	adam = p_adam;
	reg_type = p_reg_type;
	bt = adam -> loop.back_target;
	opnd = fixed (rel (p), 18);

	/* First, allocate in adam. */

	c = create_chain ();
	c -> chain.value = p;

	if reg_type = INDEX
	then do;
	     n = 2;
	     c -> chain.next = adam -> loop.global_xr_items;
	     adam -> loop.global_xr_items = c;
	     op_code = load_xreg_op;
	     call check_comparisons_and_increments (opnd, adam);
	     call propagate_and_eliminate_assignment (opnd, adam, new_opnd);
	     end;

	else do;
	     n = 1;
	     c -> chain.next = adam -> loop.global_pr_items;
	     adam -> loop.global_pr_items = c;
	     op_code = load_preg_op;
	     end;

	op, bt -> flow_unit.insert_operator = insert_operator_after (op_code, n, (bt -> flow_unit.insert_operator));
	call connect_expression (opnd, op, 1);

	if n = 2
	then call connect_expression (new_opnd, op, 2);

	/* Now, allocate in inner loops. */

	if adam -> loop.son ^= null
	then do;
	     lp = adam -> loop.son;

	     do while ("1"b);
		if reg_type = INDEX
		then do;
		     list_head = lp -> loop.global_xr_items;
		     call alloc_inner (list_head, lp -> loop.xregs_used, n);
		     lp -> loop.global_xr_items = list_head;
		     if n = avail_xregs
		     then lp -> loop.all_xrs_globally_assigned = "1"b;
		     end;
		else do;
		     list_head = lp -> loop.global_pr_items;
		     call alloc_inner (list_head, lp -> loop.pregs_used, n);
		     lp -> loop.global_pr_items = list_head;
		     end;

		if lp -> loop.son ^= null
		then lp = lp -> loop.son;

		else do;
		     do while (lp -> loop.brother = null);
			lp = lp -> loop.father;
			if lp = adam
			then return;
			end;

		     lp = lp -> loop.brother;
		     end;
		end;
	     end;

	return;

alloc_inner:
     procedure (list_head, regs_used, n_allocated);

dcl  list_head pointer,
     regs_used fixed binary (4),
     n_allocated fixed binary;			/* (output) */

dcl  c pointer;

	n_allocated = 1;

	do c = list_head repeat c -> chain.next while (c ^= null);
	     if c -> chain.value = p
	     then return;
	     n_allocated = n_allocated + 1;
	     end;

	regs_used = regs_used + 1;
	c = create_chain ();
	c -> chain.value = p;
	c -> chain.next = list_head;
	list_head = c;

     end alloc_inner;

     end allocate;

check_comparisons_and_increments:
     procedure (p_opnd, p_cur_lp);

	/* If opnd is an induction variable, we check to see if it is compared
	   against a non_constant.  If it is, that non_constant must be left
	   shifted 18 for the comparison. */

dcl  (opnd, p_opnd) fixed binary (18),			/* Induction variable? */
     (cur_lp, p_cur_lp) pointer;			/* -> current loop */

dcl  (bt, c, non_const_p, lp, o, outp, p, lsc, lsp, t, stp) pointer;
dcl  (i_non_const, non_constant, ls_op) fixed binary (18);
dcl  i fixed binary;
dcl  found bit (1) aligned;


	cur_lp = p_cur_lp;
	opnd = p_opnd;
	p = addr (rands (opnd));

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then if substr (cur_lp -> loop.induction_var -> bits, p -> symbol.coordinate, 1)
		then do c = cur_lp -> loop.eligible_ind_var_op_var repeat c -> chain.next while (c ^= null);
			o = c -> chain.value;

			found = "0"b;

			if o -> operator.op_code = storage_add_op | o -> operator.op_code = neg_storage_add_op
			then if o -> operator.output = opnd
			     then do;
				found = "1"b;
				i_non_const = 1;
				end;
			     else ;

			else do;
			     do i = 1 to 2 while (o -> operator.operand (i) ^= opnd);
				end;

			     if i <= 2
			     then do;
				found = "1"b;
				i_non_const = 3 - i;
				end;
			     end;

			if found
			then do;

			     /* Found such a comparison, now find the outermost loop in
			        which the non_constant is invariant. */

			     non_constant = o -> operator.operand (i_non_const);

			     do lp = cur_lp repeat lp -> loop.father
				while (lp -> loop.father -> loop.back_target ^= null
				& is_invariant_in (non_constant, (lp -> loop.father)));
				end;

			     bt = lp -> loop.back_target;

			     /* Now find out if there is already a left shift of the
			        non_constant to be commoned. */

			     found = "0"b;
			     lsc = lp -> loop.left_shift_chain;
			     do while (^found & lsc ^= null);
				if lsc -> chain.value -> operator.operand (1) = non_constant
				then found = "1"b;
				else lsc = lsc -> chain.next;
				end;

			     if ^found
			     then do;

				/* We must create a left_shift of the non_constant . */

				ls_op, bt -> flow_unit.insert_operator =
				     insert_operator_after (mult_op, 2, (bt -> flow_unit.insert_operator));
				lsp = addr (quad (ls_op));

				call connect_expression (non_constant, ls_op, 1);
				lsp -> operator.operand (2) = create_integer_constant (262144);
				lsp -> operator.output = create_integer_temporary (ls_op);

				/* Stick in loop_end list. */

				call put_in_loop_end (addr (rands (lsp -> operator.output)), lp);

				if ^bt -> flow_unit.falls_through
				then do;

				     /* The back target ends with a jump_op.  The
				        target of the jump is the first statement
				        in the loop entry unit.  Add the left shift
				        to the operator list of that statement, to
				        ensure that the shifted value is stored
				        before the loop is entered. */

				     stp = addr (quad (lp -> loop.entry_unit -> flow_unit.first_statement));

				     t = get_opt_space (size (primary));
				     t -> primary.last = null ();
				     t -> primary.next = stp -> opt_statement.operator_list;
				     stp -> opt_statement.operator_list = t;

				     if t -> primary.next ^= null ()
				     then t -> primary.next -> primary.last = t;
				     else stp -> opt_statement.has_operator_list = "1"b;

				     t -> primary.expression = lsp;
				     t -> primary.flow_unit = bt;
				     end;

				/* Stick in left_shift chain. */

				lsc = create_chain ();
				lsc -> chain.value = lsp;
				lsc -> chain.next = lp -> loop.left_shift_chain;
				lp -> loop.left_shift_chain = lsc;
				end;

			     else lsp = lsc -> chain.value;

			     /* Now replace the non_constant. */

			     non_const_p = addr (rands (non_constant));
			     if non_const_p -> node.node_type = temporary_node
			     then do;
				call disconnect_temporary (non_const_p, o);

				/* make up for the fact that we already have scanned
				   non_const_p, but won't during CG */

				non_const_p -> temporary.ref_count_copy =
				     non_const_p -> temporary.ref_count_copy + 1;
				end;

			     call connect_expression ((lsp -> operator.output), fixed (rel (o), 18), i_non_const);

			     /* since we won't scan operator.output in this loop,
			        decrement its ref_count, accordingly */

			     outp = addr (rands (lsp -> operator.output));
			     outp -> temporary.ref_count_copy = outp -> temporary.ref_count_copy - 1;
			     end;
			end;

     end check_comparisons_and_increments;

propagate_and_eliminate_assignment:
     procedure (p_opnd, p_lp, new_opnd);

	/* If opnd is assigned a constant or symbol value in lp's back target,
	   we attempt to remove the assignment and return the value in new_opnd
	   for loading into an xreg. */

dcl  (p_opnd, opnd) fixed binary (18),			/* operand to be loaded into an xreg */
     (p_lp, lp) pointer,				/* -> loop node */
     new_opnd fixed binary (18);			/* operand to actually be loaded */

dcl  (bt, inp, o, p) pointer;
dcl  (c, first_stm, i, op) fixed binary (18);
dcl  in_common bit (1) aligned;

	lp = p_lp;
	bt = lp -> loop.back_target;
	opnd = p_opnd;
	new_opnd = opnd;
	p = addr (rands (opnd));

	if p -> node.node_type = symbol_node
	then do;
	     c = p -> symbol.coordinate;

	     if ^substr (lp -> loop.busy_on_exit -> bits, c, 1) & substr (lp -> loop.induction_var -> bits, c, 1)
		& substr (bt -> flow_unit.set -> bits, c, 1)
	     then do;
		in_common = p -> symbol.in_common;

		/* loop backwards through operators looking for uses and sets */

		first_stm = bt -> flow_unit.first_statement;

		do op = bt -> flow_unit.insert_operator repeat o -> operator.back while (op ^= first_stm);
		     o = addr (quad (op));

		     /* special handling for namelist and common */

		     if o -> operator.op_code = read_namelist_op | o -> operator.op_code = write_namelist_op
		     then if in_namelist (o, opnd)
			then return;
			else ;
		     else if in_common
		     then if o -> operator.op_code = func_ref_op | o -> operator.op_code = call_op
			then return;

		     /* look for uses */

		     do i = 1 to o -> operator.number;
			if o -> operator.operand (i) = opnd
			then return;
			end;

		     /* look for set */

		     if o -> operator.output = opnd
		     then do;
			if o -> operator.op_code = assign_op
			then do;
			     inp = addr (rands (o -> operator.operand (1)));
			     if inp -> node.node_type = constant_node
			     then call eliminate ();
			     else if inp -> node.node_type = symbol_node
			     then do;

				/* If the input symbol might be set later in the flow unit,
				   this assignment cannot be eliminated because the
				   RHS may not be the correct value when the loop
				   is entered. */

				if inp -> symbol.aliasable
				then return;	/* Punt */

				if substr (bt -> flow_unit.set -> bits, inp -> symbol.coordinate, 1)
				then return;

				call eliminate ();
				end;
			     end;
			return;
			end;
		     end;
		end;
	     end;

eliminate:
     procedure ();

	/* This procedure does the actual elimination of assignments for
	   propagate_and_eliminate_assignment. */

	if op = bt -> flow_unit.insert_operator
	then bt -> flow_unit.insert_operator = o -> operator.back;

	new_opnd = o -> operator.operand (1);

	call unthread (o);

	if ^substr (bt -> flow_unit.set_multiple -> bits, c, 1)
	then substr (bt -> flow_unit.set -> bits, c, 1) = "0"b;

     end eliminate;

     end propagate_and_eliminate_assignment;

     end allocate_registers;

insert_operator_after:
     procedure (op_code, number, last_operator) returns (fixed binary (18));

dcl  op_code fixed binary (18),
     number fixed binary,
     last_operator fixed binary (18);

dcl  (o, next_o, last_o) pointer;
dcl  op fixed binary (18);

	/* Allocate the space. */

	n_operands = number;
	op = get_quad_space (size (operator));
	o = addr (quad (op));

	/* Initialize the space. */

	o -> operator.op_code = op_code;
	o -> operator.number = n_operands;
	o -> operator.assigns_constant_to_symbol, o -> operator.freed = "0"b;
	o -> operator.primary = null;

	/* Insert the operator. */

	last_o = addr (quad (last_operator));
	next_o = addr (quad (last_o -> operator.next));
	o -> operator.next = last_o -> operator.next;
	o -> operator.back = last_operator;
	last_o -> operator.next = op;
	next_o -> operator.back = op;

	return (op);

     end insert_operator_after;

create_integer_temporary:
     procedure (op) returns (fixed binary (18));

dcl  op fixed binary (18);				/* Operator producing the temp */

dcl  t pointer;
dcl  temp fixed binary (18);

	temp = get_temp_node ();
	t = addr (rands (temp));

	t -> temporary.data_type = int_mode;
	t -> temporary.operand_type = temp_type;
	t -> temporary.size = 1;
	t -> temporary.output_by = op;
	t -> temporary.not_in_storage = "1"b;

	return (temp);

     end create_integer_temporary;

is_invariant_in:
     procedure (opnd, lp) reducible returns (bit (1) aligned);

dcl  opnd fixed binary (18),				/* Operand which might be invariant */
     lp pointer;					/* -> loop in which invariance is tested */

dcl  (o, p) pointer;

	p = addr (rands (opnd));

	if p -> node.node_type = symbol_node
	then if p -> symbol.coordinate > 0
	     then return (^substr (lp -> loop.set -> bits, p -> symbol.coordinate, 1));
	     else ;

	else if p -> node.node_type = temporary_node
	then if lp -> loop.computed ^= null
	     then do;
		o = addr (quad (p -> temporary.output_by));
		if o -> operator.coordinate > 0
		then return (^substr (lp -> loop.computed -> obits, o -> operator.coordinate, 1));
		end;
	     else ;

	else if p -> node.node_type = constant_node
	then return ("1"b);

	return ("0"b);

     end is_invariant_in;

process_loop_end_lists:
     procedure ();

	/* Turns the loop_end lists of the various loops into operators and operands. */

dcl  (i, j) fixed binary;
dcl  (op, last_operator, next_statement) fixed binary (18);
dcl  (c, fu, last_c, o) pointer;

	do i = 1 to n_loops - 1;
	     fu = loop_vector (i) -> loop.last_unit;
	     if fu -> flow_unit.n_in_loop_end > 0
	     then do;
		next_statement = fixed (addr (quad (fu -> flow_unit.last_statement)) -> opt_statement.next, 18);
		last_operator = addr (quad (next_statement)) -> opt_statement.prev_operator;
		op = insert_operator_after (loop_end_op, (fu -> flow_unit.n_in_loop_end), last_operator);
		o = addr (quad (op));

		j = 0;
		do c = fu -> flow_unit.loop_end_chain repeat c -> lchain.next while (c ^= null);
		     j = j + 1;
		     last_c = c;
		     o -> operator.operand (j) = c -> lchain.value;
		     end;

		last_c -> lchain.next = free (size (lchain));
		free (size (lchain)) = fu -> flow_unit.loop_end_chain;
		fu -> flow_unit.loop_end_chain = null;
		fu -> flow_unit.n_in_loop_end = 0;
		end;
	     end;

     end process_loop_end_lists;

%include fort_opt_utilities;

/**** FLD BUILTIN CODE ****/
signal_error:
     procedure ();

	/* Aborts from an FLD builtin error */

	imac = fixed (rel (addr (fort_opt_macros_$abort_list)), 18);
	go to loop;

     end signal_error;

one_word_dt:
     procedure (opnd) returns (bit (1));

	/*  Returns true if "opnd" has a data type that takes up exactly one word
	   of aligned storage. */

dcl  opnd fixed bin (18);
dcl  p pointer;

	p = addr (rands (opnd));
	if (p -> node.data_type = int_mode) | (p -> node.data_type = real_mode) | (p -> node.data_type = typeless_mode)
	then return ("1"b);
	else if (p -> node.data_type = char_mode)
	then if (p -> node.node_type = symbol_node)
	     then return (p -> symbol.char_size = 3 & ^p -> symbol.aliasable);
	     else if (p -> node.node_type = char_constant_node)
	     then return (p -> char_constant.length = 4);
	     else return ("0"b);
	else return ("0"b);
     end one_word_dt;

generate_mask:
     procedure (start, len) returns (fixed bin (18));

	/* Creates an integer constant mask */

dcl  (start, len) fixed bin (18);
dcl  mask fixed bin (35);

	mask = 0;
	substr (unspec (mask), start + 1, len) = "111111111111111111111111111111111111"b;

	return (create_integer_constant (mask));
     end generate_mask;

rhs_fld:
     procedure;

	/* emits the code for the case of the fld intrinsic on the right hand
	   side of an assignement statement.  The code is emitted manually as the macros are
	   are not general enough to allow computed bit masks.  */

dcl  shift fixed bin;
dcl  (arg1, arg2, arg3, start, len) fixed bin (18);
dcl  (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b);

	arg1 = stack (get_operand (5));
	if addr (rands (arg1)) -> node.data_type ^= int_mode
	then do;
	     call print_message (359, arg1);
	     found_error = "1"b;
	     end;
	arg2 = stack (get_operand (6));
	if addr (rands (arg2)) -> node.data_type ^= int_mode
	then do;
	     call print_message (359, arg2);
	     found_error = "1"b;
	     end;
	arg3 = stack (get_operand (7));
	if ^one_word_dt (arg3)
	then do;
	     call print_message (360, arg3);
	     found_error = "1"b;
	     end;
	if found_error
	then call signal_error;

	if addr (rands (arg2)) -> node.node_type = constant_node
	then do;
	     arg2_is_const = "1"b;
	     len = addr (addr (rands (arg2)) -> constant.value) -> based_integer;
	     if len < 1 | len > 36
	     then call print_message (364);
	     if len = 0
	     then do;
		call load (create_integer_constant (0), in_tq);
		return;
		end;
	     end;
	if addr (rands (arg1)) -> node.node_type = constant_node
	then do;
	     arg1_is_const = "1"b;
	     start = addr (addr (rands (arg1)) -> constant.value) -> based_integer;
	     if start < 0 | start > 35
	     then call print_message (363);
	     end;

	if arg1_is_const & arg2_is_const
	then do;
	     start = min (max (start, 0), 35);
	     len = min (max (len, 0), 36 - start);
	     shift = 36 - (start + len);

	     call load (arg3, in_tq);

	     if start = 0
	     then do;
		if len = 36
		then return;
		call emit_single (qrl, shift - bias);
		end;

	     else if shift = 0
	     then call emit_single (anq, generate_mask (start, len));

	     else do;
		call emit_single (qls, start - bias);
		call emit_single (qrl, (36 - len) - bias);
		end;
	     call reset_eaq (Q);
	     return;
	     end;
	else do;
	     call load (arg3, in_tq);

	     if arg1_is_const
	     then do;
		if start ^= 0
		then call emit_single (qls, start - bias);
		call emit_single (lca, arg2);
		call emit_with_tag (qrl, 36, AL_mod);
		call reset_eaq (A);
		end;
	     else if arg2_is_const
	     then do;
		call load (arg1, in_ia);
		call emit_with_tag (qls, 0, AL_mod);
		call emit_single (qrl, (36 - len) - bias);
		end;
	     else do;
		call load (arg1, in_ia);
		call emit_with_tag (qls, 0, AL_mod);
		call emit_single (lca, arg2);
		call emit_with_tag (qrl, 36, AL_mod);
		call reset_eaq (A);
		end;
	     call reset_eaq (Q);
	     return;
	     end;
	return;
     end rhs_fld;

lhs_fld:
     procedure;

	/*  emits the code for the case of the fld intrinsic on the left hand side
	   of an assignment statement.  The code is emitted manually as the macros
	   are not general enough to allow certain optimizations (such as bit
	   masks. */

dcl  shift fixed bin;
dcl  RHS fixed bin (35);
dcl  (arg1, arg2, arg3, arg4, start, len) fixed bin (18);
dcl  (found_error, arg1_is_const, arg2_is_const) bit (1) init ("0"b);
dcl  copy builtin;

	arg1 = stack (get_operand (1));
	if addr (rands (arg1)) -> node.data_type ^= int_mode
	then do;
	     call print_message (359, arg1);
	     found_error = "1"b;
	     end;
	arg2 = stack (get_operand (2));
	if addr (rands (arg2)) -> node.data_type ^= int_mode
	then do;
	     call print_message (359, arg2);
	     found_error = "1"b;
	     end;
	arg3 = stack (get_operand (3));
	if ^one_word_dt (arg3)
	then do;
	     call print_message (360, arg3);
	     found_error = "1"b;
	     end;
	arg4 = stack (get_operand (4));
	if ^one_word_dt (arg4)
	then do;
	     call print_message (361);
	     found_error = "1"b;
	     end;
	if found_error
	then call signal_error;

	if addr (rands (arg2)) -> node.node_type = constant_node
	then do;
	     arg2_is_const = "1"b;
	     len = addr (addr (rands (arg2)) -> constant.value) -> based_integer;
	     if len < 1 | len > 36
	     then call print_message (364);
	     if len = 0
	     then return;
	     end;
	if addr (rands (arg1)) -> node.node_type = constant_node
	then do;
	     arg1_is_const = "1"b;
	     start = addr (addr (rands (arg1)) -> constant.value) -> based_integer;
	     if start < 0 | start > 35
	     then call print_message (363);
	     end;

	if arg1_is_const & arg2_is_const
	then do;
	     start = min (max (start, 0), 35);
	     len = min (max (len, 0), 36 - start);

	     if start = 0 & len = 36
	     then do;
		call load (arg4, in_tq);
		call store (arg3, in_tq, 0);
		return;
		end;

	     if addr (rands (arg4)) -> node.node_type = constant_node
	     then do;
		unspec (RHS) =
		     copy ("0"b, start) || substr (addr (rands (arg4)) -> constant.value, 36 - len + 1, len);
		call load (create_integer_constant (RHS), in_tq);
		end;
	     else do;
		call load (arg4, in_tq);
		shift = 36 - start - len;
		if shift > 0
		then call emit_single (qls, shift - bias);
		end;

	     /* increment the count as it is automatically decremented by emit_single */
	     call drop_count (arg3, -1);
	     call emit_single (erq, arg3);
	     call emit_single (anq, generate_mask (start, len));
	     call emit_single (ersq, arg3);
	     call reset_eaq (Q);
	     end;

	else if arg1_is_const
	then do;
	     call use_eaq (0, EAQ, 0);
	     call reserve_regs (("1"b));

	     call emit_single (lxl0, arg2);

	     /* increment the count as it is automatically decremented by emit_single */
	     call drop_count (arg3, -1);
	     call emit_single (load_inst (in_ia), arg3);
	     call emit_with_tag (alr, start, X0_mod);
	     call emit_single (era, arg4);
	     call emit_with_tag (load_inst (in_iq), 0, DL_mod);
	     call emit_with_tag (lrs, 0, X0_mod);
	     if start ^= 0
	     then call emit_single (qrl, start - bias);
	     call emit_single (ersq, arg3);
	     end;

	else if arg2_is_const
	then do;
	     call use_eaq (0, EAQ, 0);
	     call reserve_regs (("1"b));

	     call emit_single (lxl0, arg1);

	     /* increment the count as it is automatically decremented by emit_single */
	     call drop_count (arg3, -1);
	     call emit_single (load_inst (in_ia), arg3);
	     call emit_with_tag (alr, len, X0_mod);
	     call emit_single (era, arg4);
	     call emit_with_tag (load_inst (in_iq), 0, DL_mod);
	     call emit_single (lrs, len - bias);
	     call emit_with_tag (qrl, 0, X0_mod);
	     call emit_single (ersq, arg3);
	     end;

	else do;
	     call use_eaq (0, EAQ, 0);
	     call reserve_regs (("11"b));

	     call emit_single (lxl0, arg1);
	     call emit_single (lxl1, arg2);

	     /* increment the count as it is automatically decremented by emit_single */
	     call drop_count (arg3, -1);
	     call emit_single (load_inst (in_ia), arg3);
	     call emit_with_tag (alr, 0, X0_mod);
	     call emit_with_tag (alr, 0, X1_mod);
	     call emit_single (era, arg4);
	     call emit_with_tag (load_inst (in_iq), 0, DL_mod);
	     call emit_with_tag (lrs, 0, X1_mod);
	     call emit_with_tag (qrl, 0, X0_mod);
	     call emit_single (ersq, arg3);
	     end;
	return;
     end lhs_fld;

start_subprogram:
     procedure ();

	/* Initializes global variables for a subprogram.  Most references
	   are nonlocal. */

dcl  i fixed binary;
dcl  (last, temp) fixed binary (18);

	cur_lp, fu, lp_msp = null;

	cs = addr (rands (cur_subprogram));
	call get_subr_options (cs);

	loop_vector_p = cs -> subprogram.loop_vector_p;
	n_loops = cs -> subprogram.n_loops;
	max_sym = cs -> subprogram.max_sym;
	max_operators = cs -> subprogram.max_operators;

	if analyzing
	then do;
	     do i_loop = 1 to n_loops - 1 while (loop_vector (i_loop) -> loop.members = null);
		end;

	     if i_loop >= n_loops
	     then iquad = cs -> subprogram.last_quad;

	     else do;
		iquad = loop_vector (i_loop) -> loop.members -> flow_unit.first_statement;

		/* refresh flow_unit.insert_operator for all back targets */

		do i = 1 to n_loops - 1;
		     if loop_vector (i) -> loop.members ^= null
		     then call derive_insert_for_bt ((loop_vector (i) -> loop.back_target));
		     end;
		end;
	     end;

	else iquad = cs -> subprogram.first_quad;

	if cs -> subprogram.subprogram_type ^= main_program
	then do;
	     last_auto_loc = last_auto_loc + mod (last_auto_loc, 2);
	     cs -> subprogram.entry_info = last_auto_loc;
	     call set_address_offset (addr (rands (builtins (8))), last_auto_loc, entry_info_size, word_units);
	     last_auto_loc = last_auto_loc + entry_info_size;

	     if last_auto_loc > max_stack_size
	     then call print_message (414,
		     "making subroutine entry for " || addr (rands (cs -> subprogram.symbol)) -> symbol.name
		     || " has exceeded the stack frame", max_stack_size - bias);
	     end;

	do i = 1 to 3;
	     if free_temps (i) ^= 0
	     then do;
		do temp = free_temps (i) repeat addr (rands (temp)) -> temporary.next while (temp ^= 0);
		     last = temp;
		     end;

		addr (rands (last)) -> temporary.next = next_free_temp;
		next_free_temp = free_temps (i);
		free_temps (i) = 0;
		end;
	     end;
     end start_subprogram;

reset_subprogram:
     procedure ();

	/* This resets the address, not_in_storage, and value_in fields of all
	   temps produced in all loops, and it resets statement nodes
	   throughout the program. */

dcl  (lp, fu, stm, o, outp) pointer;
dcl  (next_unit_statement, next_statement, op) fixed binary (18);
dcl  i fixed binary;

	call discard_state;
	state_discarded = "0"b;			/* To make merge_state CHEAP! */

	do i = 1 to n_loops;
	     lp = loop_vector (i);

	     do fu = lp -> loop.members repeat fu -> flow_unit.next_in_loop while (fu ^= null);
		if fu -> flow_unit.next ^= null
		then next_unit_statement = fu -> flow_unit.next -> flow_unit.first_statement;
		else next_unit_statement = 0;

		if fu -> flow_unit.first_statement ^= 0
		then do cur_statement = fu -> flow_unit.first_statement repeat next_statement
			while (cur_statement ^= next_unit_statement);
			stm = addr (quad (cur_statement));
			next_statement = fixed (stm -> opt_statement.next, 18);

			if stm -> opt_statement.machine_state ^= 0
			then call free_machine_state (stm);

			do op = stm -> opt_statement.first_operator repeat o -> operator.next
			     while (op ^= next_statement);
			     o = addr (quad (op));
			     if o -> operator.output > 0
			     then do;
				outp = addr (rands (o -> operator.output));
				if outp -> node.node_type = temporary_node
				then do;
				     unspec (outp -> temporary.address) = "0"b;
				     outp -> temporary.not_in_storage = "1"b;
				     outp -> temporary.ref_count_copy = 0;
				     end;
				end;
			     end;
			end;
		end;
	     end;

	state_discarded = "1"b;

	return;

free_machine_state:
     procedure (stm);

dcl  stm pointer;

	call merge_state (current_ms, addr (rands (stm -> opt_statement.machine_state)) -> machine_state, "1"b);
	stm -> opt_statement.machine_state = 0;

     end free_machine_state;

     end reset_subprogram;

     end interpreter;

get_char_size:
     procedure (pt) returns (fixed binary (18));

	/* Procedure to return the size of a character string.
	   The size is returned as a count (if it is constant)
	   or as an operand index. */

dcl  (p, pt) pointer;				/* Pointer to character node */

	p = pt;

	if p -> node.data_type ^= char_mode
	then call print_message (412, fixed (rel (p), 18));

	if p -> node.node_type = char_constant_node
	then return (p -> char_constant.length - bias);

	if p -> node.node_type = symbol_node
	then do;
	     if p -> symbol.v_length ^= 0
	     then return (p -> symbol.v_length);
	     else return (p -> symbol.char_size + 1 - bias);
	     end;

	if p -> node.node_type = array_ref_node
	then do;
	     if p -> array_ref.variable_length
	     then return (p -> array_ref.length);
	     else return (p -> array_ref.length - bias);
	     end;

	if p -> node.node_type = temporary_node
	then do;
	     if p -> temporary.variable_length
	     then return (p -> temporary.length);
	     else return (p -> temporary.length - bias);
	     end;

	call print_message (412, fixed (rel (p), 18));

     end get_char_size;

make_symbol_descriptor:
     procedure (var) returns (fixed binary (18));

	/* Builds a descriptor for the symbol var.  If var is a parameter
	   of star or expression extents, the appropriate fields of the
	   descriptor are filled in later by get_param_array_size or
	   get_param_char_size. */

dcl  var fixed binary (18);				/* symbol that needs a descriptor */

dcl  (p, d, cs) pointer;
dcl  (i, cm, desc, dt, const, ndims, char_star_ndims, csize) fixed binary (18);
dcl  v_length bit (1) aligned;

dcl  1 descriptor aligned,
       2 type_word aligned,
         3 bit_type unaligned,
	 4 flag bit (1) unaligned,
	 4 type bit (6) unaligned,
	 4 packed bit (1) unaligned,
         3 number_dims fixed binary (3) unaligned,
         3 size fixed binary (23) unaligned,
       2 array_info (7) aligned,
         3 l_bound fixed binary (18),
         3 h_bound fixed binary (18),
         3 multiplier fixed binary (18);

dcl  desc_image char (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor));

dcl  (length, size) builtin;

	p = addr (rands (var));
	unspec (descriptor) = "0"b;
	v_length = "0"b;
	ndims, char_star_ndims = 0;

	/* If the symbol already has a descriptor, return it */

	if p -> symbol.hash_chain ^= 0
	then return (p -> symbol.hash_chain);

	/* Initialize the descriptor's type word */

	if p -> symbol.operand_type >= bif
	then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7));
	else do;
	     dt = p -> symbol.data_type;
	     unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt));
	     if dt = char_mode
	     then do;
		if p -> symbol.units = char_units
		then descriptor.packed = "1"b;
		csize = get_char_size (p);
		if csize < 0
		then descriptor.size = csize + bias;
		else do;
		     v_length = "1"b;
		     unspec (descriptor.size) = "77777777"b3;
		     end;
		end;
	     end;

	/* If symbol is dimensioned, add the dimension info */

	/* If we would have to concoct runtime character*(*) length for a
	   funtime symbol table, reserve space for the character multipliers. */

	if p -> symbol.dimensioned
	then do;
	     d = addr (rands (p -> symbol.dimension));
	     ndims = d -> dimension.number_of_dims;
	     descriptor.number_dims = ndims;

	     if v_length & shared_globals.user_options.table
	     then char_star_ndims = ndims;		/* count char*(*) multiplier extras */

	     if descriptor.packed
	     then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units));
	     else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units));

	     do i = 1 to ndims;

		if ^v_length
		then descriptor.multiplier (i) = cm;

		if string (d -> dimension.v_bound (i)) = "00"b
		then do;
		     descriptor.l_bound (i) = d -> dimension.lower_bound (i);
		     descriptor.h_bound (i) = d -> dimension.upper_bound (i);
		     if ^v_length
		     then cm = cm * d -> dimension.size (i);
		     end;
		else do;
		     v_length = "1"b;

		     /* if no specific bounds are seen, fill in '*' bounds in the static descriptor.
		        This requires variable descriptor math to over-write the bounds in auto
		        when called. */

		     if ^d -> dimension.v_bound (i).lower
		     then descriptor.l_bound (i) = d -> dimension.lower_bound (i);
		     else unspec (descriptor.l_bound (i)) = "400000000000"b3;
						/* '*' bound */

		     if ^d -> dimension.v_bound (i).upper
		     then descriptor.h_bound (i) = d -> dimension.upper_bound (i);
		     else if (i = ndims) & d -> dimension.assumed_size
		     then unspec (descriptor.h_bound (i)) = "377777777777"b3;
		     else unspec (descriptor.h_bound (i)) = "400000000000"b3;
						/* '*' bound */
		     end;
		end;
	     end;

	/* Create a constant node for the descriptor */

	if ndims = 0
	then const = create_constant (int_mode, unspec (descriptor.type_word));
	else const = create_char_constant (desc_image);

	/* If the descriptor must be filled in at runtime, allocate a
	   symbol node for it. */

	if v_length
	then do;
	     desc = create_node (symbol_node, size (symbol));
	     d = addr (rands (desc));
	     d -> symbol.data_type = char_mode;
	     d -> symbol.by_compiler = "1"b;
	     d -> symbol.character = "1"b;
	     d -> symbol.allocate = "1"b;
	     d -> symbol.automatic = "1"b;
	     d -> symbol.char_size = length (desc_image) - 1;
	     d -> symbol.element_size = 1 + char_star_ndims + 3 * ndims;
	     d -> symbol.general = const;

	     /* Thread in the new symbol, so its storage is allocated */

	     cs = addr (rands (cur_subprogram));
	     addr (rands (cs -> subprogram.last_symbol)) -> node.next = desc;
	     cs -> subprogram.last_symbol = desc;
	     end;
	else desc = const;

	/* Remember that we made this descriptor */

	p -> symbol.hash_chain = desc;

	/* Return the descriptor node */

	return (desc);

     end make_symbol_descriptor;

make_entry_descriptor:
     procedure (var) returns (fixed binary (18));

dcl  var fixed binary (18);				/* Symbol that needs a descriptor */

dcl  (p, d) pointer;
dcl  (i, cm, dt, const, ndims, char_star_ndims, csize) fixed binary (18);
dcl  v_length bit (1) aligned;

dcl  1 descriptor aligned,
       2 type_word aligned,
         3 bit_type unaligned,
	 4 flag bit (1) unaligned,
	 4 type bit (6) unaligned,
	 4 packed bit (1) unaligned,
         3 number_dims fixed binary (3) unaligned,
         3 size fixed binary (23) unaligned,
       2 array_info (7) aligned,
         3 l_bound fixed binary (18),
         3 h_bound fixed binary (18),
         3 multiplier fixed binary (18);

dcl  desc_image character (chars_per_word * (1 + char_star_ndims + 3 * ndims)) unaligned based (addr (descriptor));


	p = addr (rands (var));
	unspec (descriptor) = "0"b;
	v_length = "0"b;
	ndims, char_star_ndims = 0;

	/* If the symbol already has a descriptor, return it. */

	if p -> symbol.hash_chain ^= 0
	then do;
	     d = addr (rands (p -> symbol.hash_chain));

	     /* return only constant nodes */
	     if d -> node.node_type = symbol_node
	     then d = addr (rands (d -> symbol.general));

	     /* make sure the constant is allocated */
	     d -> node.allocate = "1"b;
	     return (fixed (rel (d), 18));
	     end;

	/* Initialize the descriptor's type word */

	if p -> symbol.operand_type >= bif
	then unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, 7));
	else do;
	     dt = p -> symbol.data_type;
	     unspec (descriptor.type_word) = unspec (descriptor_type_word (fptype, dt));
	     if dt = char_mode
	     then do;
		if p -> symbol.units = char_units
		then descriptor.packed = "1"b;
		csize = get_char_size (p);
		if csize < 0
		then descriptor.size = csize + bias;
		else do;
		     v_length = "1"b;
		     unspec (descriptor.size) = "77777777"b3;
		     end;
		end;
	     end;

	/* If symbol is dimensioned, add the dimension info */
	/* If we would have to concoct runtime character*(*) lengths for a
	   runtime symbol table, reserve space for the character multipliers. */

	if p -> symbol.dimensioned
	then do;
	     d = addr (rands (p -> symbol.dimension));
	     ndims = d -> dimension.number_of_dims;
	     descriptor.number_dims = ndims;

	     if v_length & shared_globals.user_options.table
	     then char_star_ndims = ndims;		/* count char*(*) multiplier extras */

	     if descriptor.packed
	     then cm = get_size_in_bits ((p -> symbol.element_size), (p -> symbol.units));
	     else cm = get_size_in_words ((p -> symbol.element_size), (p -> symbol.units));

	     do i = 1 to ndims;

		if ^v_length
		then descriptor.multiplier (i) = cm;

		if string (d -> dimension.v_bound (i)) = "00"b
		then do;
		     descriptor.l_bound (i) = d -> dimension.lower_bound (i);
		     descriptor.h_bound (i) = d -> dimension.upper_bound (i);
		     if ^v_length
		     then cm = cm * d -> dimension.size (i);
		     end;
		else do;
		     v_length = "1"b;

		     /* if no specific bounds are seen, fill in '*' bounds in the static descriptor.
		        This requires variable descriptor math to over-write the bounds in auto
		        when called. */

		     if ^d -> dimension.v_bound (i).lower
		     then descriptor.l_bound (i) = d -> dimension.lower_bound (i);
		     else unspec (descriptor.l_bound (i)) = "400000000000"b3;
						/* '*' bound */

		     if ^d -> dimension.v_bound (i).upper
		     then descriptor.h_bound (i) = d -> dimension.upper_bound (i);
		     else if (i = ndims) & d -> dimension.assumed_size
		     then unspec (descriptor.h_bound (i)) = "377777777777"b3;
		     else unspec (descriptor.h_bound (i)) = "400000000000"b3;
						/* '*' bound */
		     end;
		end;
	     end;

	/* Create a constant node for the descriptor */

	if ndims = 0
	then const = create_constant (int_mode, unspec (descriptor.type_word));
	else const = create_char_constant (desc_image);

	/* Remember that we made this descriptor */

	p -> symbol.hash_chain = const;

	/* Make sure the constant is allocated. */

	addr (rands (const)) -> node.allocate = "1"b;

	/* Return the descriptor node */

	return (const);

     end make_entry_descriptor;

/**** DATA INITIALIZATION ****/

initialize_static:
     procedure ();

dcl  (cur_subr, hdr) fixed binary (18);
dcl  (csp, h, s) pointer;

dcl  base ptr;
dcl  full_pointer ptr based (base);
dcl  packed_pointer ptr unaligned based (base);


	do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0);
	     csp = addr (rands (cur_subr));

	     /* Do static Large Arrays - full null pointer. */

	     do hdr = csp -> subprogram.storage_info.first (14) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));
		base = addrel (link_base, h -> header.location);
		full_pointer = null ();
		end;

	     /* Do static Very Large Arrays - packed null pointer. */

	     do hdr = csp -> subprogram.storage_info.first (16) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));
		s = addr (rands (h -> header.VLA_base_addressor));
		if ^s -> symbol.large_address
		then base = addrel (link_base, s -> symbol.address.offset);
		else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location);
		packed_pointer = null ();
		end;

	     /* Do Very Large Common - packed null pointer. */

	     do hdr = csp -> subprogram.storage_info.first (17) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));
		s = addr (rands (h -> header.VLA_base_addressor));
		if ^s -> symbol.large_address
		then base = addrel (link_base, s -> symbol.address.offset);
		else base = addrel (link_base, s -> symbol.address.offset + s -> symbol.location);
		packed_pointer = null ();
		end;
	     end;


	/* Initialize normal static. */
	do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0);
	     csp = addr (rands (cur_subr));
	     call initialize (link_base, 5);
	     end;

	/* initialize long_profile_header */

	if generate_profile & generate_long_profile
	then do;
	     base = addrel (link_base, profile_start);
	     unspec (base -> long_profile_header) = "0"b;
	     end;
	return;


initialize_auto:
     entry;

	auto_template = text_pos;

	do cur_subr = first_subprogram repeat csp -> subprogram.next_subprogram while (cur_subr > 0);
	     csp = addr (rands (cur_subr));
	     call initialize (addrel (object_base, text_pos - first_auto_var_loc), 1);
	     end;

	text_pos = text_pos + (csp -> subprogram.next_loc (2) - first_auto_var_loc);

	return;

initialize:
     procedure (pt, start);

dcl  pt pointer,					/* base of section to place initialized vars */
     start fixed binary (18);				/* first bucket to initialize */

dcl  (base, h, s) pointer;
dcl  (sym, hdr, i) fixed binary (18);

	base = pt;

	do i = start to start + 1;
	     do hdr = csp -> subprogram.storage_info.first (i) repeat h -> node.next while (hdr > 0);
		h = addr (rands (hdr));
		if h -> node.node_type = header_node
		then do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
			s = addr (rands (sym));
			if s -> symbol.initialed
			then call initialize_symbol (s, base);
			end;
		else call initialize_symbol (h, base);
		end;
	     end;

     end initialize;

     end initialize_static;

list_initialize:
     procedure (pt, hdr, words);

dcl  pt pointer,					/* Base of section to place initialized vars */
						/* left at last point of init */
     hdr fixed binary (18),				/* header to init from */
     words fixed bin (18);				/* words used for init info + original value */

dcl  (h, s) pointer;
dcl  sym fixed binary (18);
dcl  start_offset fixed bin (18);
dcl  end_offset fixed bin (35);

	h = addr (rands (hdr));
	if ^h -> header.initialed
	then return;				/* No work to do */
	end_offset = 0;
	start_offset = fixed (rel (pt), 18);

	do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
	     s = addr (rands (sym));

	     if s -> symbol.initialed
	     then call list_initialize_symbol (s, pt, end_offset);
	     end;
	pt -> create_init_entry.length = 0;		/* END */
	pt = addrel (pt, 1);

	/* calculate words taken for initialization list data */

	words = words + fixed (rel (pt), 18) - start_offset;
	return;
     end list_initialize;

initialize_symbol:
     procedure (sym_pt, init_pt);

dcl  (sym_pt, init_pt) pointer;

dcl  (s, address) pointer;
dcl  (index, case, csize, limit, off) fixed binary (18);

dcl  1 initial aligned auto,
       2 next fixed binary (18),
       2 limit fixed binary (18),
       2 value fixed binary (18);

dcl  1 initial_in_polish aligned based,
       2 next fixed binary (18) aligned,
       2 limit fixed binary (18) aligned,
       2 value fixed binary (18) aligned;

dcl  single_target (10000) bit (36) aligned based (address);

dcl  double_target (10000) bit (72) aligned based (address);

dcl  char_target (10000) char (csize) aligned based (address);

dcl  char77_target (10000) char (csize) unaligned based (address);

dcl  char_overlay (0:3) char (1) unaligned based;

	s = sym_pt;
	address = init_pt;
	index = 1;

	/* Develop a full pointer to the initial template for the symbol */

	off = s -> symbol.address.offset;
	if s -> symbol.large_address
	then off = off + s -> symbol.location;
	address = addrel (address, off);

	if s -> symbol.units = char_units
	then do;
	     off = s -> symbol.address.char_num;
	     address = addr (address -> char_overlay (off));
	     end;

	if s -> symbol.character
	then if s -> symbol.units = char_units
	     then do;
		csize = s -> symbol.char_size + 1;
		case = 4;
		end;
	     else do;
		csize = s -> symbol.char_size + 1;
		case = 3;
		end;
	else case = data_type_size (s -> symbol.data_type);

	if ^s -> symbol.dimensioned
	then do;
	     initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value;
	     if initial.value ^= gap_value
	     then call assign_value;
	     return;
	     end;

	initial.next = s -> symbol.initial;
	limit = 0;

	do while (initial.next > 0);

	     /* can't use aggregate assignment because of bug 1466 */

	     initial.value = addr (polish (initial.next)) -> initial_in_polish.value;
	     initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit;
	     initial.next = addr (polish (initial.next)) -> initial_in_polish.next;
	     limit = limit + initial.limit;

	     do while (index <= limit);
		if initial.value ^= gap_value
		then call assign_value;
		index = index + 1;
		end;

	     end;

assign_value:
     procedure ();

	go to action (case);

action (1):
	single_target (index) = addr (rands (initial.value)) -> constant.value;
	return;

action (2):
	double_target (index) = addr (rands (initial.value)) -> constant.value;
	return;

action (3):
	char_target (index) = addr (rands (initial.value)) -> char_constant.value;
	return;

action (4):
	char77_target (index) = addr (rands (initial.value)) -> char_constant.value;
	return;

     end assign_value;

     end initialize_symbol;

list_initialize_symbol:
     procedure (sym_pt, init_pt, end_offset);

dcl  (
     sym_pt,					/* pointer to symbol */
     init_pt
     ) pointer;					/* pointer to template storage */

dcl  end_offset fixed bin (35);			/* offset end of last stored */

	/* end_offset will be the last offset value assigned, and used as both input
	   and output.  The difference between the end_offset input and the first
	   offset calculated will be a null filler.  end_offset output will be the
	   end of the area initialized to this point. */

dcl  boffset fixed bin (35);
dcl  s pointer;
dcl  (index, case, bsize, csize) fixed binary (18);
dcl  off fixed bin (35);

dcl  1 initial aligned automatic,
       2 next fixed binary (35),
       2 limit fixed binary (35),
       2 value fixed binary (35);

dcl  1 initial_in_polish aligned based,
       2 next fixed binary (35) aligned,
       2 limit fixed binary (35) aligned,
       2 value fixed binary (35) aligned;

dcl  single_target (10000) bit (36) aligned based;

dcl  double_target (10000) bit (72) aligned based;

dcl  char_target (10000) character (csize) aligned based;

dcl  char77_target (10000) character (csize) unaligned based;


	s = sym_pt;
	index = 1;

	/* Develop an offset to the start of the variable area to be initialized */

	if s -> symbol.VLA
	then off = s -> symbol.location;
	else do;
	     off = s -> symbol.address.offset;
	     if s -> symbol.large_address
	     then off = off + s -> symbol.location;
	     end;

	boffset = off * 36;

	if s -> symbol.units = char_units
	then boffset = boffset + 9 * s -> symbol.address.char_num;

	if s -> symbol.character
	then if s -> symbol.units = char_units
	     then do;
		csize = s -> symbol.char_size + 1;
		case = 4;
		end;
	     else do;
		csize = s -> symbol.char_size + 1;
		case = 3;
		end;
	else case = data_type_size (s -> symbol.data_type);

	if ^s -> symbol.dimensioned
	then do;
	     initial.value = addr (polish (s -> symbol.initial)) -> initial_in_polish.value;
	     call list_assign_value (1);
	     return;
	     end;

	initial.next = s -> symbol.initial;

	do while (initial.next > 0);

	     /* can't use aggregate assignment because of bug 1466 */

	     initial.value = addr (polish (initial.next)) -> initial_in_polish.value;
	     initial.limit = addr (polish (initial.next)) -> initial_in_polish.limit;
	     initial.next = addr (polish (initial.next)) -> initial_in_polish.next;
	     call list_assign_value (initial.limit);
	     index = index + initial.limit;

	     end;
	return;

list_assign_value:
     procedure (repeat);

dcl  repeat fixed bin (35);

	if initial.value = gap_value			/* skip */
	then return;

	go to size_it (case);

size_it (1):					/* single precision */
	bsize = 36;
	off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize;
	goto list_assign_create;

size_it (2):					/* double precision */
	bsize = 72;
	off = (divide (boffset + bsize - 1, bsize, 35) + (index - 1)) * bsize;
	goto list_assign_create;

size_it (3):					/* ansi66 character aligned target */
	bsize = divide (csize + 3, 4, 35) * 36;		/* round up to word */
	off = divide (boffset + 35, 36, 35) * 36 + (index - 1) * bsize;
	goto list_assign_create;

size_it (4):					/* ansi77 character unaligned */
	bsize = csize * 9;
	off = boffset + (index - 1) * bsize;
	goto list_assign_create;


	/* create the initialization entry at the specified pointer. */

list_assign_create:
	if end_offset ^= off			/* see if we formed a gap */
	then do;					/* filler */
	     init_pt -> create_init_entry.repeat = 0;	/* skip */
	     init_pt -> create_init_entry.length = off - end_offset;
	     init_pt = addrel (init_pt, 2);
	     end;
	init_pt -> create_init_entry.length = bsize;
	init_pt -> create_init_entry.repeat = repeat;
	go to action (case);

action (1):
	addr (init_pt -> create_init_entry.datum) -> single_target (1) = addr (rands (initial.value)) -> constant.value;
	goto list_assign_finish;

action (2):
	addr (init_pt -> create_init_entry.datum) -> double_target (1) = addr (rands (initial.value)) -> constant.value;
	goto list_assign_finish;

action (3):
	addr (init_pt -> create_init_entry.datum) -> char_target (1) =
	     addr (rands (initial.value)) -> char_constant.value;
	goto list_assign_finish;

action (4):
	addr (init_pt -> create_init_entry.datum) -> char77_target (1) =
	     addr (rands (initial.value)) -> char_constant.value;
	goto list_assign_finish;

list_assign_finish:
	init_pt = addrel (init_pt, currentsize (init_pt -> create_init_entry));
	end_offset = off + bsize * repeat;
	return;

     end list_assign_value;

     end list_initialize_symbol;

/**** LINKAGE SECTION GENERATION ****/

init_linkage:
     procedure ();

	/* This procedure is called to initialize the linkage generator.
	   It builds the linkage_header and generates the class 3
	   segname definition  and the definition for "symbol_table". */

dcl  1 def_header based aligned,
       2 forward bit (18) unaligned,
       2 backward bit (18) unaligned,
       2 skip bit (18) unaligned,
       2 flags bit (18) unaligned;


	/* initialize linkage header */

	link_base -> virgin_linkage_header.def_offset = bit (defrel, 18);
	link_base -> virgin_linkage_header.link_begin = bit (begin_links, 18);
	link_base -> virgin_linkage_header.linkage_section_lng = bit (link_pos, 18);
	link_base -> virgin_linkage_header.static_length =
	     bit (fixed (begin_links - size (virgin_linkage_header), 18), 18);

	link_reloc_base -> reloc (1) = rc_t;

	/* generate definition header.  the word of zeros terminating
	   the definition chain will be at location 2 */

	def_base -> def_header.flags = "11"b;		/* new,ignore */
	def_reloc_base -> reloc (0) = rc_dp;
	zero_def = "000000000000000010"b;
	last_def = (18)"0"b;
	def_pos = 3;

	/* generate definition for segname, class 3 */

	call generate_definition (segname, 3, zero_def);

	/* generate definition for "symbol_table" */

	call generate_definition ("symbol_table", 2, "0"b);

	addrel (def_base, seg_def) -> segname_def.defblock = last_def;

	return;

     end init_linkage;

gen_linkage:
     procedure ();

	/* Generate the links for common and external references */

dcl  i fixed binary (18);
dcl  position fixed binary (15);
dcl  s pointer;

	do i = begin_external_list to end_external_list - 1 by 3;
	     s = ext_ref (i);
	     if s -> node.allocated
	     then if s -> node.node_type = symbol_node
		then if s -> symbol.initial = 0
		     then do;
			position = s -> symbol.address.offset;
			if s -> symbol.large_address
			then position = position + s -> symbol.location;
			call compile_link (s -> symbol.name, "0"b, 0, position);
			end;
		     else ;
		else do;

		     /* the following code is affected by PL/I bug 1599 */
		     /* This bug is fixed by release 23 of PL/I */

		     if index (s -> header.block_name, "$") = 0
		     then call compile_link (s -> header.block_name, initialize_common (s, (polish (i + 1))), 1,
			     (s -> header.location));
		     else if ^s -> header.initialed
		     then call compile_link (s -> header.block_name, "0"b, 1, (s -> header.location));
		     else call print_message (429, s -> header.block_name);
		     end;
	     end;

	return;

     end gen_linkage;

compile_link:
     procedure (string, grow, type, link_pos);

dcl  string char (*) aligned,
     grow bit (18) aligned,
     type fixed binary (18),
     link_pos fixed binary (15);

dcl  (seg_name, ent_name, block_type) bit (18) aligned;

dcl  (def_ptr, link_ptr, def_reloc_ptr, link_reloc_ptr) pointer;
dcl  head_address fixed binary (35) based aligned;

dcl  k fixed binary (18);

dcl  dollar_name char (32) aligned;

dcl  length builtin;

	if length (string) = 0
	then do;

	     /* <*symbol>|0 link */

	     block_type = "000001"b3;
	     seg_name = "000002"b3;
	     ent_name = "000000"b3;
	     end;

	else do;

	     /* ordinary link */

	     if grow
	     then block_type = "000005"b3;
	     else block_type = "000004"b3;

	     k = index (string, "$");

	     if k ^= 0
	     then do;				/* name of the form a$b */

		dollar_name = substr (string, 1, k - 1);/* get segment part of dollar name */
		seg_name = name_assign (dollar_name);

		/* different link required if common block name ends with $; it is illegal for */
		/* external reference names to end with $. */

		if k = length (string)		/* name ends with $ */
		then do;
		     ent_name = zero_def;		/* there is no entry name */
		     block_type = "000003"b3;		/* valid only for common block links */
		     end;
		else do;				/* reference of the form a$b; get entry name */
		     dollar_name = substr (string, k + 1);
		     ent_name = name_assign (dollar_name);
		     end;
		end;

	     else do;				/* no $ in name */

		ent_name = name_assign (string);

		if type = 0
		then seg_name = ent_name;
		else seg_name = "000005"b3;
		end;
	     end;

	def_ptr = addrel (def_base, def_pos);
	def_reloc_ptr = addrel (def_reloc_base, def_pos);
	link_ptr = addrel (link_base, link_pos);
	link_reloc_ptr = addrel (link_reloc_base, link_pos);

	def_ptr -> type_pair.type = block_type;
	def_ptr -> type_pair.trap_ptr = grow;
	if grow
	then def_reloc_ptr -> reloc (0) = rc_a_dp;

	def_ptr -> type_pair.seg_ptr = seg_name;
	def_ptr -> type_pair.ext_ptr = ent_name;
	if type = 0
	then def_reloc_ptr -> reloc (1) = rc_a_dp;
	else def_reloc_ptr -> reloc (1) = rc_dp_dp;

	addrel (def_ptr, 2) -> exp_word.type_ptr = bit (def_pos, 18);
	def_reloc_ptr -> reloc (2) = rc_dp;

	link_ptr -> head_address = -link_pos * binary (262144, 19);
	link_ptr -> link.ft2 = FT2_mod;		/* 46 octal */
	link_reloc_ptr -> reloc (0) = rc_nlb;

	link_ptr -> link.exp_ptr = bit (fixed (def_pos + 2, 18), 18);
	link_reloc_ptr -> reloc (1) = rc_dp;

	def_pos = def_pos + 3;

	return;

     end compile_link;

name_assign:
     procedure (name) returns (bit (18) aligned);

dcl  name char (*) aligned;
dcl  vname char (32) varying;

dcl  1 acc aligned based,
       2 count bit (9) unaligned,
       2 string char (n) unaligned;

dcl  n fixed binary (9);
dcl  (i, old_pos) fixed binary (18);
dcl  p pointer;

dcl  1 st aligned based (polish_base),
       2 acc_ptrs (0:next_free_polish - 1) pointer unaligned;

dcl  length builtin;

	/* trim the blanks from name */

	vname = substr (name, 1, length (name) - verify (reverse (name), " ") + 1);

	/* see if this acc string has already been used */

	do i = begin_forward_refs to hbound (acc_ptrs, 1);
	     p = acc_ptrs (i);
	     n = fixed (p -> acc.count, 9);
	     if length (vname) = n
	     then if vname = p -> acc.string
		then do;
		     old_pos = fixed (rel (p), 18) - defrel;
		     return (bit (old_pos, 18));
		     end;
	     end;

	/* build a new acc string */

	n = length (vname);
	p = addrel (def_base, def_pos);

	if next_free_polish < polish_max_len
	then do;
	     next_free_polish = next_free_polish + 1;
	     acc_ptrs (next_free_polish - 1) = p;
	     end;

	p -> acc.count = bit (n, 9);
	p -> acc.string = vname;

	old_pos = def_pos;
	def_pos = def_pos + divide (n + chars_per_word, chars_per_word, 17, 0);

	return (bit (old_pos, 18));

     end name_assign;

initialize_common:
     procedure (pt, len) returns (bit (18) aligned);

dcl  (h, s, pt, grow_pt, init_pt) pointer;
dcl  (len, init_val, sym) fixed binary (18);
dcl  (
     m,						/* length of LIST_TEMPLATE_INIT */
     n						/* length of TEMPLATE_INIT */
     ) fixed bin (18);
dcl  grow_info bit (18) aligned;
dcl  use_pool bit (1) aligned;

dcl  max_template_init_size fixed bin (18) static options (constant) init (256);

%include system_link_init_info;



	h = pt;
	n = len;

	if h -> header.alignment.character
	then n = divide (n + chars_per_word - 1, chars_per_word, 18, 0);

	if h -> header.initialed & n <= max_template_init_size
	then if fixed (rel (addrel (def_base, def_pos + n + mod (def_pos, 2)))) > max_linkage_size
	     then do;				/* CANNOT INIT ON PAIN OF DEATH */
		call print_message (469, h -> header.block_name, max_linkage_size - bias);
		h -> header.initialed = "0"b;		/* PULL OUT THE RUG */
		end;


	if h -> header.initialed
	then def_pos = def_pos + mod (def_pos, 2);

	grow_info = bit (def_pos, 18);
	grow_pt = addrel (def_base, grow_info);
	init_pt = addrel (grow_pt, 2);

	init_val = NO_INIT;

	if h -> header.initialed
	then if n > max_template_init_size
	     then do;
		m = 0;				/* presume no template generated */
		init_val = LIST_TEMPLATE_INIT;
		call list_initialize (addrel (init_pt, 1), fixed (rel (h), 18), m);
		grow_pt -> list_init_info.list_size = m;
		end;
	     else do;
		init_val = TEMPLATE_INIT;
		do sym = h -> header.first_element repeat s -> symbol.next_member while (sym > 0);
		     s = addr (rands (sym));
		     if s -> symbol.initial ^= 0
		     then call initialize_symbol (s, init_pt);
		     end;
		end;

	use_pool = init_val = NO_INIT & n <= hbound (def_pool, 1);
	if use_pool
	then if def_pool (n) ^= 0
	     then return (bit (def_pool (n), 18));

	grow_pt -> init_info.size = n;
	grow_pt -> init_info.type = init_val;

	if use_pool
	then def_pool (n) = def_pos;

	def_pos = def_pos + 2;
	if init_val = TEMPLATE_INIT
	then def_pos = def_pos + n;
	else if init_val = LIST_TEMPLATE_INIT
	then def_pos = def_pos + m + 1;
	return (grow_info);

     end initialize_common;

/**** DEFINITION SECTION ****/

generate_definition:
     procedure (name, class, value);

dcl  name char (*) aligned,				/* symbol  for definition */
     class fixed binary (3),				/* class of definition */
     value bit (18) aligned;				/* value of definition */

dcl  (def_ptr, def_reloc_ptr) pointer;
dcl  (b18, pos) bit (18) aligned;

dcl  rel_code (0:3) aligned bit (18) internal static options (constant) initial ("000000000000010000"b,
						/* text */
	"000000000000010010"b,			/* link 18 */
	"000000000000010110"b,			/* symbol */
	"000000000000010101"b);			/* definition */


	b18 = name_assign (name);

	pos = bit (def_pos, 18);
	def_ptr = addrel (def_base, pos);
	def_reloc_ptr = addrel (def_reloc_base, pos);

	if last_def
	then def_ptr -> definition.backward = last_def;
	else def_ptr -> definition.backward = zero_def;

	addrel (def_base, last_def) -> definition.forward = pos;

	def_ptr -> definition.forward = 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 seg_def = pos;
	else do;
	     def_ptr -> definition.segname = seg_def;
	     def_ptr -> definition.entry = class = 0;
	     end;

	def_reloc_ptr -> reloc (0) = rc_dp_dp;
	def_reloc_ptr -> reloc (2) = rc_dp_dp;
	def_reloc_ptr -> reloc (1) = rel_code (class);

	last_def = pos;
	def_pos = def_pos + 3;

     end generate_definition;

gen_entry_defs:
     procedure ();

	/* Generates entry definitions and finishes up entry sequences */

dcl  desc fixed bin (18);
dcl  (s, def_ptr) pointer;
dcl  (sym, stack_size) fixed binary (18);
dcl  ent_pos fixed binary (18);


	stack_size = divide (last_auto_loc + 15, 16, 17, 0) * 16;

	do sym = first_entry_name repeat s -> symbol.next_symbol while (sym > 0);
	     s = addr (rands (sym));
	     ent_pos = s -> label.location;		/* a slight kludge */

	     /* fill in stack_size (must be multiple of 16) */

	     text_halfs (ent_pos).left = stack_size;

	     /* generate entry definition */

	     call generate_definition (s -> symbol.name, 0, bit (ent_pos, 18));

	     reloc_halfs (ent_pos - 1).left = rc_dp;

	     unspec (text_halfs (ent_pos - 1).left) = last_def;
	     def_ptr = addrel (def_base, last_def);

	     if assembly_list
	     then a_name (ent_pos - 1) = -1;		/* tell listing generator this is not an inst */

	     def_ptr -> definition.retain = "1"b;

	     /* process entry definitions */

	     parm_desc_ptrsp = addr (text_halfs (text_halfs (ent_pos - 2).left));
	     do i = 1 to parm_desc_ptrs.n_args;
		desc = parm_desc_ptrs.descriptor_relp (i);
		parm_desc_ptrs.descriptor_relp (i) = addr (rands (desc)) -> label.location;
		end;
	     end;

     end gen_entry_defs;

     end code_generator;

     end fort_optimizing_cg;




		    fort_version_info.alm           12/11/91  2238.3r w 12/11/91  2227.1       28872



" *********************************************************
" *                                                       *
" * Copyright, (C) BULL HN Information Systems Inc., 1989 *
" *                                                       *
" * Copyright, (C) Honeywell Limited, 1983                *
" *                                                       *
" *********************************************************

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7286),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bugs 427, 430, 433, 449, 451, 452, 453, 454, 455, 456, 457,
"     458, 460, 461, 462, 463, 464, 467, 468, and 492.
"  2) change(86-07-14,BWong), approve(86-07-14,MCR7382),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bugs 122, 355, 389, 396, 411, 425, 428, 470, 471, 472, 473,
"     476, 477, 478, 480, 481, 482, 490 (SCP6284), and 494.
"  3) change(86-07-14,BWong), approve(86-07-14,MCR7442),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bugs 410, 488, 493, 497, and 498.
"  4) change(86-10-17,Ginter), approve(86-10-17,MCR7556),
"     audit(86-10-22,Huen), install(86-11-13,MR12.0-1216):
"     Fixed fortran bugs 496 and 502.
"  5) change(88-07-19,RWaters), approve(88-07-19,MCR7875),
"     audit(88-07-19,Huen), install(88-11-10,MR12.2-1209):
"     New version number for scp 6339.
"  6) change(89-06-14,RWaters), approve(89-06-14,MCR8115),
"     audit(89-07-21,Blackmore), install(89-07-31,MR12.3-1065):
"     Updated version number for MR12.3
"  7) change(90-04-27,Huen), approve(90-04-27,MCR8155), audit(90-05-16,Gray),
"     install(90-05-30,MR12.4-1011):
"     Update version number from MR12.3a MR12.4a - including fix for ft_508.
"  8) change(90-05-02,Huen), approve(90-05-02,MCR8159), audit(90-05-16,Gray),
"     install(90-05-30,MR12.4-1011):
"     Version MR12.4a include fix for ft_512.
"  9) change(91-06-27,Huen), approve(91-06-27,MCR8245), audit(91-11-25,Vu),
"     install(91-12-11,MR12.5-1004):
"     Version MR12.5a include fix for ft_513.
" 10) change(91-11-06,Huen), approve(91-11-06,MCR8246), audit(91-11-25,Vu),
"     install(91-12-11,MR12.5-1004):
"     Version MR12.5b include fix for ft_514.
"                                                      END HISTORY COMMENTS


"  ***************************************
"  *                                     *
"  *  COPYRIGHT (C) HONEYWELL LTD. 1983  *
"  *                                     *
"  ***************************************

	name	fort_version_info
	segdef	version_name
	segdef	version_number
	segdef	greeting
"
"
"		dcl	fort_version_info$greeting char(16) aligned ext static
"
greeting:			" must be char(16)
	aci	"New Fortran     "
"		012345678901234567 This is here for those who cannot count
"
"
"		dcl	fort_version_info$version_number char(16) aligned ext static
"
version_number:		" must be char(16)
	aci	", Release 12.5b "
"		012345678901234567 This is here for those who cannot count
"		This field must have numbers in it somewhere
"
"
"		dcl	fort_version_info$version_name char(132) varying ext static
"
version_name:
	dec	28
	aci	"Multics New Fortran Compiler"
	end




		    new_fortran.pl1                 08/06/87  1147.1r w 08/06/87  1047.7      115200



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

/* format: style3,^delnl,linecom */
new_fortran:
     proc;
fortran:
     entry;
ft:
     entry;

/* Modified:
	12 Jul 83, MM - 380: Prevent -check from truncating existing object
		segments.
	12 Jul 83, MM - Prevent -version from displaying the version twice.
	12 Jul 83, MM - 379: Change argument handling to use fort_defaults_.
	10 May 83, RG - 174: Allow source to be an archive component.
	31 Jan 83, HH - Install LA/VLA support.
	17 December 1982, TO - Add "long_profile" option.
	21 June  1982, TO - Conform to MPM standards with:
	     "-nstrg", "-nsubr", "-ckmpy", "-nckmpy", "-ntb".
	 3 April 1982, TO - Conform to mr10 info seg with:
	     "-no_strg", "-no_subrg", "-ck_mpy" and "-no_ck_mpy".
	28 May 1982, TO - Make "-check_multiply", "-stringrange",
	     "-subscriptrange" defaults for ansi77 with no optimize.
	28 May 1982, TO - Add controls "-nsubrg", "-nstrg",
	      "-no_stringrange", "-no_subscriptrange".
	 3 May 1982, TO  - Add "-check_multiply" and "-no_check_multiply".
	 3 May 1982, TO  - Add "-table" as default if not optimizing.
	 3 May 1982, TO  - Add "-no_table"/"-ntb" option.
	 3 May 1982, TO  - Add "-auto_zero"/"-no_auto_zero".
	 1 Apr 1982, TO  - fix bug 205.
	 1 Apr 1982, TO  - fix bug 259.
	26 Sep 1980, CRD - use new cu_$arg_count with code.
	26 Feb 1979, PES - add -version and -no_version control args.
	06 Nov 1979, SRH - arguments made non-positional.
	13 Sep 1979, PES - add -ansi66/-ansi77 control args.  Default to 66.
		fix usage message.
	12 Jul 1979, PES - Make -relocatable the default.  Add -non_relocatable.
	07 Apr 1979, RAB - Make -time_ot NOT imply -time
	18 Dec 1978, PES - Make auto_zero the default.  Broken by change of 29 Nov.
	30 Nov 1978, PES - Add undocumented control args -truncate and -round.
	29 Nov 1978, PES - Changes to control arguments for MR7.0--Remove -consolidate and -super,
		add -safe_ot and -top_down, change -optimize to include -consolidate -super.
	27 Sep 1978, PES - Don't announce compiler until after all checking of command line is done
		and it is known that fort_ will be invoked.
	27 Jul 1978, PES - Remove simple and full control arguments (introduced as special optimizer
		control arguments).
	13 Jun 1978, DSL - Implement v2 opt features; set bit count of obj seg to zero if compilation
		fails;  have special optimizer control args also set optimize bit.
	18 May 1978, DSL - Print name of given entry name if compilation fails.
	26 Jan 1978, RAB - add special loop optimizer control_args.
	30 Aug 1977, DSL - implement fortran_severity_.
	10 Feb 1977, DSL - add -optimize (-ot); use temp seg if user specifies -check
		instead of real obj seg.
	09 Dec 1976, DSL - Standardize the listing options; change -rel to -rlc;
		use new version of compiler_source_info.incl.pl1; ref fort_version_info$greeting.
	30 Aug 1976, DSL - to allow new listing options.
*/

dcl	acl_ptr		pointer;
dcl	archive_$get_component
			entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35));
dcl	arg_count		fixed bin;
dcl	arg_error		bit (1) aligned init ("0"b);
dcl	arg_len		fixed bin;
dcl	arg_list_ptr	ptr;
dcl	arg_no		fixed bin;
dcl	arg_pt		pointer;
dcl	arg_string	char (arg_len) based (arg_pt);
dcl	binary_file	(1:o_len) bit (36) aligned based;
dcl	cleanup		condition;
dcl	code		fixed bin (35);
dcl	com_err_		entry options (variable);
dcl	compiler_suffix	char (7) int static options (constant) init ("fortran");
dcl	cu_$arg_count	entry (fixed bin, fixed bin (35));
dcl	cu_$arg_list_ptr	entry (ptr);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	cu_$make_entry_value
			entry (pointer, entry);
dcl	comp_name		char (32);
dcl	dir_name		char (256);
dcl	ent_binary_name	char (256);
dcl	ent_name		char (66);
dcl	error_table_$badopt fixed bin (35) ext static;
dcl	error_table_$entlong
			fixed bin (35) ext static;
dcl	error_table_$pathlong
			fixed bin (35) ext static;
dcl	find_source_file_	entry (char (*), char (*), char (*), ptr, fixed bin (24), fixed bin (35));
dcl	fort_		entry (ptr, ptr, fixed bin (19), ptr, ptr, entry, entry, fixed bin (35));
dcl	fort_defaults_$check_args
			entry (ptr, aligned bit (1));
dcl	fort_defaults_$argument
			entry (ptr, fixed bin, fixed bin, ptr, ptr, aligned bit (1));
dcl	fort_defaults_$set	entry (ptr, ptr);
dcl	fort_version_info$greeting
			char (16) aligned ext static;
dcl	fort_version_info$version_number
			char (16) aligned ext static;
dcl	fortran_severity_	fixed bin (35) ext static;
dcl	get_temp_segments_	entry (char (*), dim (*) ptr, fixed bin (35));
dcl	get_pdir_		entry returns (char (168));
dcl	get_wdir_		entry returns (char (168));
dcl	got_path		bit (1) aligned init ("0"b);
dcl	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
			fixed bin, ptr, fixed bin (35));
dcl	hcs_$terminate_noname
			entry (pointer, fixed bin (35));
dcl	ioa_		entry options (variable);
dcl	len		fixed bin (24);
dcl	library_entry	entry variable;
dcl	next_source_seg_entry
			entry variable;
dcl	o_len		fixed bin (19);
dcl	o_ptr		pointer;
dcl	p_array		(1) ptr;			/* used in calls to (get release)_temp_segments_ */
dcl	path		char (path_len) based (path_pt) unaligned;
dcl	path_len		fixed bin;
dcl	path_pt		pointer;
dcl	program_name	char (11) int static options (constant) init ("new_fortran");
dcl	release_temp_segments_
			entry (char (*), dim (*) ptr, fixed bin (35));
dcl	src_ptr		pointer;
dcl	translator_info_$component_get_source_info
			entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned,
			fixed bin (35));
dcl	tssi_$clean_up_segment
			entry (ptr);
dcl	tssi_$finish_segment
			entry (ptr, fixed bin (24), bit (36), ptr, fixed bin (35));
dcl	tssi_$get_segment	entry (char (*), char (*), ptr, ptr, fixed bin (35));
dcl	1 csi		aligned like compiler_source_info;
dcl	1 fo		aligned like fortran_options;
dcl	1 fd		aligned like fortran_declared;
dcl	(addr,
	baseno,
	divide,
	index,
	length,
	null,
	rtrim,
	string,
	substr,
	unspec)		builtin;
%include compiler_source_info;
%include fort_options;

	fortran_severity_ = 5;			/* initialize ext static status word */

/* the following initializations affect the cleanup handler */

	acl_ptr = null;				/* There is no ACL list to clean up */
	o_ptr = null;				/* There is no object segment to terminate */
	src_ptr = null;				/* There is no source segment to terminate */

/* Set the default fortran options */
	unspec (fd) = "0"b;
	unspec (fo) = "0"b;
	fo.auto_zero = "1"b;
	fo.do_rounding = "1"b;
	fo.relocatable = "1"b;

/* get options */

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, program_name);
		return;
	     end;

	if arg_count = 0
	then do;
		call com_err_ (0, program_name, "Usage: new_fortran source_path {-control_args}");
		return;
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);		/* get pointer to arguments for fort_defaults_ */

	do arg_no = 1 to arg_count;

	     call cu_$arg_ptr (arg_no, arg_pt, arg_len, code);

	     if code ^= 0
	     then do;
		     call com_err_ (code, program_name, "While processing ""^a"".", arg_string);
		     arg_error = "1"b;
		end;

	     else if index (arg_string, "-") ^= 1
	     then if got_path
		then do;
			call com_err_ (0, program_name, "Hyphen missing from ^a.", arg_string);
			arg_error = "1"b;
		     end;
		else do;
			got_path = "1"b;
			path_pt = arg_pt;
			path_len = arg_len;
		     end;
	     else call fort_defaults_$argument (arg_pt, arg_len, arg_no, arg_list_ptr, addr (fd), arg_error);
	end;					/* loop thru arguments */

	if ^got_path
	then if arg_count > 1 | ^fd.version
	     then do;
		     call com_err_ (0, program_name, "User has not supplied a source segment path name.");
		     arg_error = "1"b;
		end;
	     else do;
		     call identify_version;
		     return;
		end;

	call fort_defaults_$check_args (addr (fd), arg_error);
	call fort_defaults_$set (addr (fd), addr (fo));

	if arg_error
	then do;
		if fd.version
		then call identify_version;
		return;
	     end;

/* find the source */

	call find_source_file_ (path, compiler_suffix, ent_name, src_ptr, len, code);
	if src_ptr = null
	then do;
		call com_err_ (code, program_name, "^a", path);
		if fd.version
		then call identify_version;
		return;
	     end;

/* store entry name as given by the user in structure for the compiler */

	csi.given_ename = before (ent_name, "." || compiler_suffix);

/* establish a clean up handler */

	on condition (cleanup)
	     begin;
		call truncate ();
	     end;

	p_array (1), acl_ptr = null ();
	ent_binary_name = csi.given_ename;
	dir_name = get_wdir_ ();
	call hcs_$initiate_count (dir_name, ent_binary_name, "", (0), 1, o_ptr, code);

	if baseno (src_ptr) = baseno (o_ptr)
	then do;
		call com_err_ (0, program_name,
		     "Source and object segment are the same segment.");
		o_ptr, acl_ptr = null ();
		go to abort;
	     end;
	call hcs_$terminate_noname (o_ptr, code);

/* get pointer to temporary object segment or just temp seg (for -check option) */

	call get_temp_segments_ (program_name, p_array, code);
	if code ^= 0
	then do;
		call com_err_ (code, program_name, "Getting temp seg for compiler.");
		go to abort;
	     end;
	o_ptr = p_array (1);

/* get actual pathname, unique id, and date time modified; store in structure for compiler. */

	call translator_info_$component_get_source_info (src_ptr, dir_name, ent_name, comp_name,
	     csi.date_time_modified, csi.unique_id, code);
	if code ^= 0
	then do;
		call com_err_ (code, program_name, ent_name);
		go to abort;
	     end;

/* Set segname to "" and the entire pathname is put into dirname */
	csi.dirname = rtrim (dir_name, "> ") || ">" || rtrim (ent_name);
	if comp_name ^= ""
	then if length (csi.dirname) + length (rtrim (comp_name)) - length (".archive") + 1 > maxlength (csi.dirname)
	     then do;
		     call com_err_ (error_table_$pathlong, program_name, "^a::^a", before (csi.dirname, ".archive"),
			comp_name);
		     goto abort;
		end;
	     else csi.dirname = before (csi.dirname, ".archive") || "::" || rtrim (comp_name);
	csi.segname = "";

	csi.input_lng = divide (len + 8, 9, 21, 0);	/* Convert length to chars. */
	csi.input_pointer = src_ptr;

	csi.version = compiler_source_info_version_2;


/* CALL THE COMPILER */

	call cu_$make_entry_value (null (), next_source_seg_entry);
	call cu_$make_entry_value (null (), library_entry);

/* announce the compiler */

	if ^fd.no_version
	then call identify_version;

	fortran_severity_ = 0;			/* For call to the compiler. it sets actual severity */

	call fort_ (addr (csi), o_ptr, o_len, addr (fo), addr (fd), next_source_seg_entry, library_entry, code);

	if code ^= 0
	then call com_err_ (code, program_name, "^a.fortran", csi.given_ename);
	else if ^fo.check
	then do;

/* Create the object segment, and copy the binary. */

		dir_name = get_wdir_ ();
		call tssi_$get_segment (dir_name, ent_binary_name, o_ptr, acl_ptr, code);
		if o_ptr = null			/* cannot create binary */
		then do;
			call com_err_ (code, program_name, "Cannot create ^a in working directory.",
			     ent_binary_name);
			dir_name = get_pdir_ ();
			call tssi_$get_segment (dir_name, ent_binary_name, o_ptr, acl_ptr, code);

			if o_ptr = null
			then do;
				call com_err_ (code, program_name, "Cannot create ^a in process directory.",
				     ent_binary_name);
				go to abort;
			     end;
			else call com_err_ (0, program_name, "^a created in process_directory.", ent_binary_name);
		     end;
		unspec (o_ptr -> binary_file) = unspec (p_array (1) -> binary_file);
	     end;

/* clean up and return */
abort:
	if src_ptr ^= null
	then call hcs_$terminate_noname (src_ptr, code);

	if o_ptr ^= null & o_ptr ^= p_array (1)
	then call tssi_$finish_segment (o_ptr, o_len * 36, "1100"b, acl_ptr, code);
	if p_array (1) ^= null
	then call release_temp_segments_ (program_name, p_array, code);
	return;

identify_version:
     procedure ();

	call ioa_ (rtrim (fort_version_info$greeting) || substr (fort_version_info$version_number, 10));
	return;
     end;


truncate:
     procedure;					/* cleans up after to compiler */

	if src_ptr ^= null
	then call hcs_$terminate_noname (src_ptr, code);
	src_ptr = null;

	if p_array (1) ^= null ()
	then call release_temp_segments_ (program_name, p_array, code);

	if acl_ptr ^= null
	then call tssi_$clean_up_segment (acl_ptr);

	acl_ptr, o_ptr = null ();
     end /* truncate */;
     end /* new fortran */;

*/
                                          -----------------------------------------------------------


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

*/
