


		    PNOTICE_fortran.alm             11/14/89  1119.2r w 11/14/89  1119.2        3402


	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	139			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."
          acc       "Copyright, (C) Honeywell Limited, 1989"

	aci	"C1F77M0E0000"
	aci	"C2F77M0E0000"
	aci	"C3F77M0E0000"
	end
  



		    display_entries.alm             12/27/84  0834.1rew 12/27/84  0751.1        4896


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

	segdef	fdisplay

	use	linkc

fdisplay:
	its	-1,1,n
	its	-1,1,n
	join	/link/linkc
	end



		    ext_code_generator.pl1          12/11/91  2238.1r w 12/11/91  2230.0     2880666


/****^  *********************************************************
        *                                                       *
        * 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, 455, 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, 473, and 476.
  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(88-01-07,Huen), approve(88-01-07,MCR7825), audit(88-01-13,RWaters),
     install(88-01-19,MR12.2-1014):
     Fix fortran bug 504.
  5) 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.
  6) change(91-06-27,Huen), approve(91-06-27,MCR8245), audit(91-11-25,Vu),
     install(91-12-11,MR12.5-1004):
     Fix fortran bug 513 to generate correct code for VLA reference if one of
     the dimensions is greater than the maximum number that fits in a 18 bit
     halfword (262143).
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo,indnoniterend,inditerdo,indend,^indproc,indcom,declareind5 */
ext_code_generator:
     procedure (p1, p2);

dcl  (p1, p2, shared_struc_ptr, cg_struc_ptr) pointer;
dcl  (object_base, operand_base, polish_base, relocation_base) pointer;
dcl  (object_max_len, operand_max_len, polish_max_len) fixed binary (19);

%include fort_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;

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;


	object_base = shared_globals.object_base;
	operand_base = shared_globals.operand_base;
	polish_base = shared_globals.polish_base;
	relocation_base = shared_globals.relocation_base;


	call code_generator;

%include fort_utilities;

code_generator:
     procedure ();

/****^ Written: 1 February 1976 by Richard A. Barnes

Modified: 31 Mar 90, SH - 508: Avoid inserting an instruction in the middle of
	the scm arg sequence for Index intrinsic when pr 4 is valid.
          Also remove "restore_prs", "lock_base", "lock_index".
Modified: 13 Dec 87, SH - 504: Change the relocation factor for the VLA common
          block members from "internal_static_15" to "absolute".
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: 11 Dec 85, 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: 07 Nov 85, SH & MM - 476:  Reduce severity of a compile time
	subscript error (422) from severity 3 to a warning.
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: 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: 22 Jan 85, MM - 447: Fix base_man_load_any_pr to set the bit
	address_in_base for VLA elements and allow the base_regs
	structure to retain the knowledge that it points to a VLA element.
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, MM - 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: To look up entry-defined arg_desc if one exists.
Modified: 27 Jul 83, HH - 371: 'mult' needs to support -ve constants.
Modified:	17 June 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 bug in flush_ref which used aliasable
	instead of in_equiv_stmnt.
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, make_substring 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:  3 January  1982, TO - Add 'force_even' operation from macros to
	emit 'nop' to align to an even word boundary to permit DO-loop
	optimization.
Modified: 31 December 1982, TO: 367 - Cause allocation of named constants if
	we want a symbol_table.
Modified: 17 December 1982, TO - Add '-long_profile' support.
Modified: 17 Nov 82, HH - 361:  Incorrect code was generated for an ASSIGN
	to a format which the parser had made into a named constant if
	there was no reference to the format before the ASSIGN, because
	the code supporting the 'get_format_var' macro did not call
	'use_input' to replace named constants by their value.  Rather
	than have 'get_format_var' use 'use_input', we have opted for
	the more general fix of moving the code for 'get_format_var'
	into 'use_input'.  'use_input' was renamed to 'effective_operand'
	because of its enhanced function.
Modified: 30 Sep 1982, TO - 364: Fix 'finish_subscript' bug - first loop did
	a 'mult' even if we did not have 'vsum', this took an uninitialized
	value.  Also put a constant creation into 'load_vsum' if called 
	without a vsum created.
Modified: 05 August 1982, HH - Fix bug 357:  Pad char constants with spaces
	rather than NULs.
Modified: 23 July 1982, TO - fix named constant bug in emit_c_a_var where refs
	to the text section are not seen and fixed up.
Modified: 20 May 1982, TO - Fix bug in check_arg_list where 'n' rather than
	'num_args' is set to 'a -> arg_desc.n_args ' in limiting the scan
	of the arg_desc list.  This would permit a scan longer than the list.
Modified: 18 May 1982, TO - Fix descriptor bug where char*(*) multiplier is
	only calculated for last dimension, leaving an unprobable, and at
	times (dims>2) unrunnable binary.
Modified: 17 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: 13 May 1982, TO - Fix substr of named_constant, with fix to substr,
	and emit_eis, have emit_eis do correct text reference.
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 use_ind.
	previously use_ind used and reset A, but didn't consider those things
	in EAQ, which subsiquently got lost and not stored.
Modified:  3 May 1982, TO - Allocate char_star_function return_value.
Modified:  3 May 1982, TO - Add action (74) (if unless)_char_star_function.
Modified:  3 May 1982, TO - Add action (75) (if unless)_check_multiply.
Modified: 28 April 1982, TO - fix navytest3 bug.  Cause flush_ref to remove
	ALL equivalenced refs in this chain.
Modified: 19 April 1982, TO - Implement NAMED CONSTANTS.
Modified: 14 April 1982, TO - Implement extended information for stack and
	linkage overflow message (error 414).
Modified: 12 April 1982, TO - fix bug 344, stack indirect through ITP in
	set_itp_addr.
Modified: 4 September 1981, CRD - Change reset_regs to call flush_xr.
Modified: 27 July 1981, CRD - Implement get_format_var macro.
Modified: 2 June 1981, CRD - Implement push_sf_arg_count macro.
Modified: 21 May 1981, CRD - Reorganize subscript range checking.
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: 13 March 1981, CRD - Implement assumed size arrays.
Modified: 27 February 1981, CRD - Implement array lower bounds ^= 1.
Modified: 8 January 1981, CRD - Fix bug 303.
Modified: 9 December 1980, CRD - Changed upper bound of
	operator_table array to 102 for block_if, else_if, and
	else operators.
Modified: 20 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: 10 October 1980, CRD - Fixed bug in use_eaq which caused
	temporaries to be stored into the wrong address when more
	than one item was in the register.
Modified: 6 October 1980, CRD - Changes mandated by audit. Also
	move symbol names of instructions in the single_inst table
	to the include file fort_single_inst_names.incl.pl1.
Modified: 26 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: 1 September 1980, CRD - Use array_ref.has_address instead
	of ext_base, to correspond with optimizing CG.
Modified: 15 August 1980, CRD - Fix large address bug in
	continue_cat.
Modified: 13 August 1980, CRD - Fix error handling in make_substring.
Modified: 12 August 1980, CRD - Fix bug in (if unless)_ansi77.
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: 27 June 1980, CRD - Fix bug in push_length macro - it was
	not bumping the ref count of temporaries.
Modified: 23 June 1980, CRD - Add (if unless)_ansi77.
Modified: 15 May 1980, CRD - Fix bug in make_substring: if variable
	length temporary already existed, increment its ref count;
	and make sure the variable length of an array_ref is never
	another array_ref.
Modified: 8 April 1980, CRD - Add code to recycle temporary nodes
	from one subprogram to another; centralize subprogram
	initialization in start_subprogram.
Modified: 4 April 1980, CRD - Fix bug intorduced by new EAQ mgt.
	Changed load to call use_ind in all cases except when
	loading into the indicators.
Modified: 7 March 1980, CRD - Implement concatenation.  Changes
	node.multi_position to node.stack_indirect.
Modified: 7 February 1980, CRD - Add char1_to_int, int_to_char1
	macros, fix text_ref to work with char constants, and
	change the return macro to convert counts to integers.
Modified: 5 February 1980, CRD - Add (if unless)_aligned macro, and
	change text_ref to handle direct EIS operands.
Modified: 29 January 1980, CRD - Add support for substrings.
Modified: 24 January 1980, CRD - Add support for Fortran entries
	which require descriptors.
Modified: 17 January 1980, CRD - split make_descriptor into two
	routines: make_descriptor and make_symbol_descriptor.
Modified: 17 December 1979, CRD - completion of changes for
	variable length character strings.
Modified: 12 December 1979, CRD - phase 1 of changes to allow
	variable length character strings (make_descriptor).
Modified: 11 December 1979, CRD - change subscripting code to agree
	with new large address scheme, and fix it to load large
	offsets correctly.
Modified: 7 December 1979, CRD - change over to large address scheme
	used in the optimizing side (pointer registers instead of 
	index registers).
Modified: 6 December 1979, CRD - invent emit_temp_store to avoid
	recursion in eaq_man_load_a_or_q.
Modified: 6 November 1979, CRD - change eaq register management and
	addressing to handle large character offsets.
Modified: 24 September 1979, CRD - added code to finish_subscript to
	handle 77 char mode (character offsets, large offsets).
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 the logic planned for the register optimizer.
Modified: 12 September 1979, CRD - change large address scheme to
	use full 32K addressing capability of 15 bit offset.
Modified: 31 August 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: 25 July 1979, CRD - rearrange opcodes of some more simple
	macro instructions.
Modified: 24 July 1979, CRD - fix bug 229, in which the parent chain
	in the runtime symbol table was being built incorrectly.
Modified: 23 July 1979, CRD - to compress opcodes for certain pairs
	of if/unless macro instructions.
Modified: 23 July 1979, CRD - to rearrange opcodes for macros which
	take no arguments or operands to occupy the left half of
	the instruction word.
Modified: 16 July 1979, CRD - to fix bug 225 to make subscripts in the Q work
	properly.
Modified:	17 January 1979, RAB - to speed up reg management by using
	machine_state.value_in_xr
Modified: 6 December 1978, PES - for %options and %global
Modified:	4 December 1978, RAB - for option to initialize auto storage to zero
Modified: 30 November 1978, PES - Key rounding off of fortran_options.
Modified:	18 November 1978, RAB - Centralize control of rounding
	by use of eaq.rounded.
Modified:  25 October 1978, PES - Changes for large common 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 fields.
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 bug in which a register may not be reloaded
	before being used as an index, even if the value has been changed in
	storage.
Modified: 27 July 1978, PES - Fix bug in setting of symbol.simple for
	parameters.
Modified: 23 June 1978, DSL - Add emit_c_a_const so that all procs remain quick
	procs; set symbol.element_size for descriptors (formerly done by
	storage allocator).
Modified: 19 June 1978, DSL - Changes dictated by audit.
Modified: 12 June 1978, DSL - Modify for loop optimizer. This includes the
	renaming of node.subs_in_q to node.dont_update. All nodes were
	changed. Also, removed all code in storage allocator that assigns a
	data type or a storage class.
Modified: 23 May 1978, DSL - Prepare for loop optimizing code generator; add
	load_for_test to fix bug 159 in which indicator state is not set
	correctly. Mark some code as purely version I optimizer, i.e.,
	obsolete. Change action 105 from "also_in_reg" to "compare".
Modified: 18 April 1978, DSL - to fix bug 149 in which incorrect code is
	generated for arrays with large addresses.  Also fixed bug 142 in
	which save_xr protect_indicators destroys the machine state.
Modified: 4 January 1978, DSL - Allocate double word character constants on
	double word boundaries.
Modified: 20 December 1977, DSL - Clean up previous fix; add new macros,
	load_for_test, set_in_storage, pad_char_const_to_word,
	pad_char_const_to_dw, dt_jump1; fix store macro to allow no_round
	option.
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  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  (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  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  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  (
     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_stack_size fixed bin (18) int static init (62000) options (constant);
dcl  max_linkage_size fixed binary (18) internal static options (constant) initial (131071);

dcl  (abs, addr, addrel, bin, binary, bit, byte, char, cleanup, copy,
     currentsize, divide, fixed, hbound, index, 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;				/* no active statement node */
	allocate_symbol_name = 0;			/* no names for symbols created by code generator */
	unspec (def_pool) = "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;

	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, begin_forward_refs = next_free_polish;

	/* interpret */

	call interpreter;

	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;
	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;
	init_auto_to_zero = cs -> subprogram.options.auto_zero;

	return;

     end get_subr_options;

/**** CONSTANT ALLOCATION ****/

alloc_constants:
     procedure (start, amt);

	/* Allocates constants in the text section */

dcl  start fixed binary (18);
dcl  (amt, n) fixed binary;

	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;

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 ();
	     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 */
               /* 87.12.13  The relocation factor for VLA common block members is 
                  absolute (rc_a); whereas the relocation factor for VLA common block
                  is internal_static_15 (rc_is15).                                   */

	     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;
		     h -> header.reloc = rc_a;

		     if h -> header.automatic
		     then h -> header.address.base = sp;
		     else h -> header.address.base = lp;

		     call alloc_members;

		     /*  Allocate the base addressor.  */

		     if ^h -> header.automatic then h -> header.reloc = rc_is15;
		     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);

	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 symbols for dimension.size (*) */

	     if ^d -> dimension.has_dim_sizes
	     then do;
		do i = 1 to d -> dimension.number_of_dims - 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  cs pointer;					/* Subprogram node pointer */

dcl  s pointer;					/* Symbol pointer */
dcl  sym fixed binary (18);				/* Symbol offset */

	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 () returns (fixed binary (18));

	/* Creates a rel_constant */

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;

	return (var);

     end create_rel_constant;

interpreter:
     procedure ();

	/* Written by R. A. Barnes 1 January 1976 */

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  imac fixed bin (18);				/* index into fort_cg_macros_ */
dcl  ipol fixed bin (18);				/* index into polish */

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_array_ref fixed bin (18);
dcl  desc_temp_chain fixed bin (18) unsigned;

dcl  op_code fixed bin (18);

dcl  (i, k, n, op1, op2, next_base, relation, scan_proc, skip, temp, zarg, desc, eaq_name, regno, sym) fixed bin (18);
dcl  (cdt, dt, dt1, dt2) fixed bin (4);
dcl  char1 character (1);

dcl  (p, s) ptr;
dcl  (b1, b2, err_flag, build_profile_after_label) bit (1) aligned;
dcl  bit3 bit (3) aligned;

dcl  from_base_man bit (1) aligned;			/* "1"b if base_man_load_pr is active */


dcl  stack (300) fixed bin (18);

dcl  (
     fort_cg_macros_$first_scan,
     fort_cg_macros_$abort_list,
     fort_cg_macros_$error_macro
     ) bit (36) aligned external static;

dcl  1 fort_cg_macros_$interpreter_macros (4) aligned ext static,
       2 entry fixed bin (17) unal,
       2 pad fixed bin (17) unal;

dcl  1 fort_cg_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 pad1 bit (18) unal,
       2 directable bit (1) unal,
       2 pad2 bit (17) unal;

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),
     arg_ptr initial (26),
     descriptor_ptr initial (34)
     ) fixed binary (18) internal static options (constant);

dcl  1 fort_cg_macros_$single_inst (158) aligned ext static like machine_instruction;

%include fort_single_inst_names;

dcl  dt_from_reg (18) 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);

dcl  eaq_name_to_reg (18) fixed bin internal static options (constant)
	initial (2, 1, 3, 3, 3, 3, 2, 1, 2, 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 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 */
     ) fixed bin (18) int static options (constant);

dcl  (						/* op_base equ 361 */
     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),
     VLA_words_per_seg initial (361 - 476)		/* SPECIAL conversion */
     ) 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  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  char_temp char (8);

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 machine_state aligned,
       2 eaq (4),					/* A, Q, EAQ, IND */
         3 name fixed bin (18),
         3 number fixed bin (18),
         3 variable (4) fixed bin (18),
         3 reserved bit (1) aligned,
       2 rounded bit (1) aligned,
       2 indicators_valid fixed bin (18),
       2 value_in_xr bit (1) aligned,
       2 index_regs (0:7),
         3 bits structure unaligned,
	 4 global bit (1),				/* Not used */
	 4 reserved bit (1),
	 4 mbz bit (34),
         3 type fixed bin (18),
         3 variable fixed bin (18),
         3 used fixed bin (18),
         3 offset fixed bin (18),
       2 address_in_base bit (1) aligned,
       2 base_regs (0:7),
         3 bits structure unaligned,
	 4 global bit (1),				/* Not used */
	 4 reserved bit (1),
	 4 mbz bit (34),
         3 type fixed bin (18),
         3 variable fixed bin (18),
         3 used fixed bin (18),
         3 offset fixed bin (18),
       2 stack_extended bit (1) aligned,
       2 last_dynamic_temp fixed bin (18);

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);

dcl  1 hast based (addr (macro_instruction (imac))),
       2 instruction_word bit (36) aligned,
       2 half_array (18) 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  (length, mod) builtin;

%include relocation_bits;

	/* initialize cur_subprogram and friend */

	cur_subprogram = first_subprogram;
	cs = addr (rands (cur_subprogram));
	call get_subr_options (cs);

	/* 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 */
	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.location = auto_template;
	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 */

	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;
	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 */

	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;

	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;

	/* perform other initializations */

	next_free_array_ref = 0;
	desc_temp_chain = 0;
	build_profile_after_label, unspec (machine_state) = "0"b;
	from_base_man = "0"b;

	/* initialize scanners */

	mac_base = ptr (addr (fort_cg_macros_$first_scan), 0);
	imac = fixed (rel (addr (fort_cg_macros_$first_scan)), 18) - 1;

	/* get first procedure frame and initialize operand stack */

	cur_frame = null;

	cur_frame = create_proc_frame ();

	base, top = 0;

	/* Set things up for the first program unit */

	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 */

		     left = stack (top) + bias;
		     top = top - 1;
		     end;
		call push (assign_block (left));
		end;

	     go to step;

action (5):					/* push_variable  */
	     call push_variable ((macro_dt_inst (imac).data_type));
	     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 ());
	     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 */
action (70):
	     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 */

		     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;

		else do;

		     /* return eaq_name */

		     call pop (base);

		     dt = dt_from_reg (i);
		     temp = assign_temp (dt);
		     call push (temp);

		     call in_reg (temp, 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;
		err_flag = "0"b;
		go to p -> proc_frame.interpreter_return;
		end;

	     go to step;

action (16):					/* jump */
	     imac = left;
	     go to loop;

action (17):					/* scan */
rescan:
	     do while (polish (ipol) < 0 | polish (ipol) > last_assigned_op);

		/* have a count or operand */

		call push (effective_operand (polish (ipol)));
		ipol = ipol + 1;
		end;

	     /* we have an operator */

	     op_code = polish (ipol);
	     ipol = ipol + 1;

	     scan_proc = fort_cg_macros_$operator_table (op_code).entry;

	     next_base = get_nextbase (scan_proc);

	     do i = next_base repeat i + 1 while (i <= top & stack (i) ^= ERROR);
		end;

	     if i <= top
	     then do;
		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 (18):					/* exit */
	     if proc_frame.func
	     then call print_message (405);
	     else if ^proc_frame.scan_called
	     then call print_message (406);

	     call pop (base);

	     imac = proc_frame.return + left;

	     call pop_frame;
	     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 */
	     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 dt2 <= 0
	     then call print_message (445, stack (top - 1), "data_type");

	     else if dt1 = typeless_mode
	     then i = 19;

	     else if dt1 > cmpx_mode
	     then i = 17;

	     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 machine_state.eaq (IND).name < tze
	     then call print_message (409);
	     else imac = half_array (machine_state.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 machine_state.eaq (IND).name >= in_ind & machine_state.eaq (IND).number > 0
	     then call print_message (410);

	     eaq_name = macro_instruction (imac).eaq_name;
	     regno = eaq_name_to_reg (eaq_name);
	     b1 = (machine_state.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 (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 (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 (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 */
	     do imac = imac + 1 to imac + left;
		text_word (text_pos) = unspec (machine_instruction (imac));
		text_pos = text_pos + 1;
		end;
	     go to loop;

action (78):					/* assign_entry */
	     op1 = get_operand (mopnd);
	     call reset_regs;
	     goto label_join;

action (35):					/* label */
	     op1 = get_operand (mopnd);

	     if addr (rands (stack (op1))) -> label.referenced_executable
						/* reset only if label is used */
	     then call reset_regs;
	     goto label_join;

action (36):					/* relcon */
	     op1 = get_operand (mopnd);

label_join:
	     call alloc_label (op1, text_pos);

	     if addr (rands (stack (op1))) -> label.restore_prs
						/* is this label the target of a non-local goto */
	     then call emit_zero (getlp);		/* yes, restore frozen register (pr4) */

	     if build_profile_after_label
	     then do;
		call build_profile_entry;
		build_profile_after_label = "0"b;
		end;
	     go to step;

action (37):					/* set_rel_constant */
	     op1 = get_operand (mopnd);
	     call alloc_label (op1, stack (top) + bias);
	     top = top - 1;
	     go to step;

action (38):					/* add_to_address */
	     if left = 0
	     then do;
		instruction (text_pos - 1).offset = instruction (text_pos - 1).offset + stack (top) + bias;
		top = top - 1;
		end;

	     else do;
		op1 = get_operand (mopnd);
		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;

		top = top - 2;
		end;

	     go to step;

action (39):					/* insert_bits */
	     call print_message (424, "insert_bits");
	     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);
	     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 */
	     machine_state.base_regs (which_base (3)).type = 9;
	     machine_state.base_regs (which_base (3)).used = text_pos;
	     machine_state.base_regs (which_base (3)).variable = 0;
	     machine_state.base_regs (which_base (3)).offset = 0;
	     go to step;

simple (50):					/* arg_ptr_in_pr1 */
	     machine_state.base_regs (which_base (1)).type = 5;
	     machine_state.base_regs (which_base (1)).used = text_pos;
	     machine_state.base_regs (which_base (1)).variable = 0;
	     machine_state.base_regs (which_base (1)).offset = 0;
	     go to step;

simple (4):					/* free_regs */
	     call free_regs;
	     go to step;

simple (5):					/* reset_regs */
	     call reset_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 (45):					/* use_eaq */
	     call use_eaq (0);
	     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;

simple (22):					/* safe_load */
	     call print_message (424, "safe_load");
	     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 loading into the A, get temps in IND out first */

	     if eaq_name = in_a
	     then if machine_state.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 use_ind ();

	     /* 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 if the top operand is a 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 machine_state.indicators_valid ^= regno
	     then do;
		call emit_single ((compare_inst (op2)), (zero_for_dt (dt_from_reg (op2))));
		machine_state.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 (105):					/* compare */
	     op1 = stack (get_operand (mopnd));
	     if op1 < 0				/* a count */
	     then op1 = create_integer_constant (op1 + bias);
	     b1 = (op1 = zero_for_dt (addr (rands (op1)) -> node.data_type));
	     eaq_name = macro_instruction (imac).eaq_name;
	     regno = eaq_name_to_reg (eaq_name);

	     if machine_state.indicators_valid ^= regno | ^b1
	     then do;

		if do_rounding & ^machine_state.rounded
		then if (eaq_name = in_eaq) | (eaq_name = in_deaq)
		     then if (eaq_name = machine_state.eaq (regno).name) | (eaq_name ^= in_deaq)
			     | (machine_state.eaq (regno).name = 0)
			then do;
			     if machine_state.eaq (regno).name ^= 0
			     then i = round_inst (machine_state.eaq (regno).name);
			     else i = round_inst (eaq_name);
			     call emit_zero (i);
			     machine_state.rounded = "1"b;
			     end;

		call emit_single ((compare_inst (eaq_name)), op1);

		if b1
		then machine_state.indicators_valid = regno;
		else machine_state.indicators_valid = 0;

		end;

	     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;

action (20):					/* set_inds_valid */
	     eaq_name = macro_instruction (imac).eaq_name;
	     machine_state.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;

simple (28):					/* skip_data */
	     ipol = ipol + polish (ipol) + 1;
	     go to step;

action (50):					/* push_sf_arg_count */
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 (8):					/* start_subscript */
	     call start_subscript;
	     go to step;

simple (9):					/* next_subscript */
	     call next_subscript;
	     go to step;

simple (10):					/* finish_subscript */
	     call finish_subscript;
	     go to step;

simple (11):					/* subscript_error */
	     call signal_error;
	     go to step;

simple (21):					/* optimized_subscript */
	     call print_message (424, "optimized_subscript");
	     goto step;

simple (39):					/* make_substring */
	     call make_substring ();
	     go to step;

simple (12):					/* s_func_finish */
	     free_temps (1), free_temps (2), free_temps (3) = 0;
	     go to step;

action (61):					/* s_func_label */
	     op1 = get_operand (mopnd);
	     addr (rands (stack (op1))) -> symbol.initial = stack (top);
	     go to step;

action (62):					/* push_s_func_label */
	     op1 = get_operand (mopnd);
	     call push ((addr (rands (stack (op1))) -> symbol.initial));
	     go to step;

action (63):					/* push_s_func_var */
	     op1 = stack (get_operand (mopnd));

	     do i = 1 to stack (top) + bias;
		p = addr (rands (op1));
		if p -> symbol.next_member = 0
		then do;
		     imac = left;
		     go to loop;
		     end;

		op1 = p -> symbol.next_member;
		end;

	     call push (op1);

	     go to 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;

	     /* NOTE - This code was modified on 26 May 1977 by DSL to conflict with the documented
	        actions for this macro.

	        In the case of the frame called by scan being a "FUNC" frame, the error
	        macro now pushes an ERROR operand whether or not the error_label for
	        the scan was "continue".
	     */
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;

	     call pop (proc_frame.base);

	     p = cur_frame;

	     call pop_frame;

	     if p -> proc_frame.scan_called
	     then if p -> proc_frame.func
		then call push (ERROR);

	     if ^p -> proc_frame.interpreter_called
	     then do;
		imac = p -> proc_frame.error_label;
		go to loop;
		end;

	     else do;
		err_flag = "1"b;
		imac = p -> proc_frame.return;
		go to p -> proc_frame.interpreter_return;
		end;

action (68):					/* push_length */
	     op1 = get_char_size (addr (rands (stack (get_operand (mopnd)))));
	     if op1 > 0				/* Not a count */
	     then do;
		p = addr (rands (op1));
		if p -> node.node_type = temporary_node
		then p -> temporary.ref_count = p -> temporary.ref_count + 1;
		end;

	     call push (op1);
	     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);

	     cur_subprogram = cs -> subprogram.next_subprogram;
	     if cur_subprogram = 0
	     then return;

	     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;
	     b1 = one_word_dt (stack (get_operand (mopnd)));
	     goto if_join;

simple (14):					/* stat */
	     cur_statement = ipol - 1;
	     addr (polish (cur_statement)) -> statement.location = bit (text_pos, 18);
	     ipol = ipol + (size (statement) - 1);

	     if generate_profile
	     then if addr (polish (cur_statement)) -> statement.put_in_profile
		then if polish (ipol + 1) = label_op
		     then build_profile_after_label = "1"b;
		     else call build_profile_entry;
	     go to step;

simple (15):					/* check_parameters */
	     /*** Expects:

		count of parameters
		param1
		param2
		.
		.
		.
		paramn ***/
	     zarg = base;
	     n = stack (zarg) + bias;

	     /* 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;
		call base_man_load_pr ((stack (zarg + i)), 3);

		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 (3), temp, 2 * i);
		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);
		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)));

		     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, 3);
		     call emit_single_with_inc (store_base (3), temp, skip + 2 * i);
		     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):					/* check_ref_count */
	     call print_message (424, "check_ref_count");
	     goto step;

action (110):					/* save_state */
	     call print_message (424, "save_state");


action (108):					/* round */
	     if do_rounding & ^machine_state.rounded
	     then do;
		eaq_name = macro_instruction (imac).eaq_name;
		call emit_zero ((round_inst (eaq_name)));
		machine_state.rounded = "1"b;
		machine_state.indicators_valid = eaq_name_to_reg (eaq_name);
		end;

	     goto step;

action (109):					/* flush_ref */
	     op1 = stack (get_operand (mopnd));
	     call flush_ref (op1);

	     goto step;

action (114):					/* set_in_storage */
	     op1 = stack (get_operand (mopnd));
	     addr (rands (op1)) -> node.not_in_storage = "0"b;
	     goto 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;

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 (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 machine_state.stack_extended
	     then do;

		/* Reserve pr1 and call the correct operator */

		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;

		machine_state.stack_extended = "0"b;
		machine_state.last_dynamic_temp = 0;

		call free_regs ();
		end;

	     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;

simple (57):					/* rhs_fld */
	     call rhs_fld;
	     goto step;

simple (58):					/* lhs_fld */
	     call lhs_fld;
	     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 (55):					/* force_even */
	     if mod (text_pos, 2) ^= 0
	     then call emit_zero (nop);
	     goto step;

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;

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
	        optimizing code generaor. */

simple (23):					/* discard_state */
simple (24):					/* push_output */
simple (25):					/* bump_args */
simple (26):					/* drop_args */
simple (27):					/* push_operand_count */
simple (29):					/* set_rounded */
simple (30):					/* load_xreg */
simple (31):					/* load_preg */
simple (32):					/* drop_all_counts */
simple (33):					/* ind_to_a */
simple (34):					/* assign_index */
simple (35):					/* compare_index */
simple (36):					/* test_index */
simple (37):					/* increment_index */
simple (38):					/* decrement_index */
simple (40):					/* refresh_regs_if_next_is_jump */
simple (41):					/* note_eligible_ind_var_use */
simple (43):					/* force_ql */
simple (51):
	     call print_message (436, left - bias);
	     go to step;

action (42):					/* use_a */
action (43):					/* use_q */
action (49):					/* refresh_regs */
action (59):					/* set_next_operand */
action (82):					/* (if unless)_global */
action (83):					/* (if unless)_induction_var */
action (84):					/* (if unless)_fb17 */
action (86):					/* (if unless)_global_ind_var */
action (94):
action (96):
action (97):
action (98):
action (100):
action (101):					/* if_next_statement */
action (102):					/* unless_next_statement */
action (103):
action (106):
action (107):
action (115):					/* bump */
action (116):					/* drop */
action (117):
action (118):					/* (if unless)_zero */
action (119):
action (120):
action (121):					/* push_ref_count */
action (122):
action (123):
action (127):					/* power_of_two */
	     call print_message (436, mop - bias);
	     go to step;

	     /* THESE SHOULD NOT EXECUTE */
action (0):					/* undefined */
action (12):					/* proc */
action (13):					/* func */
action (56):					/* (if unless)_saving_stack_extent */
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 = effective_operand (opnd);

	call push (op);

	if op > 0
	then do;
	     p = addr (rands (op));
	     if p -> node.node_type = array_ref_node | p -> node.node_type = temporary_node
	     then p -> temporary.ref_count = p -> temporary.ref_count + 1;
	     end;

     end copy;

pop:
     procedure (pthru);

	/* Pops the stack through thru -- top becomes thru - 1 */

dcl  (pthru, thru) fixed binary (18);			/* pop through thru */

dcl  n fixed binary (18);

	thru = pthru;

	do while (top >= thru);
	     if stack (top) > 0
	     then do;
		p = addr (rands (stack (top)));
		if p -> node.node_type = temporary_node
		then do;
		     n, p -> temporary.ref_count = p -> temporary.ref_count - 1;
		     if n <= 0
		     then call free_temp (p);
		     end;
		else if p -> node.node_type = array_ref_node
		then do;
		     n, p -> array_ref.ref_count = p -> array_ref.ref_count - 1;
		     if n <= 0
		     then call free_array_ref (p);
		     end;
		end;

	     top = top - 1;
	     end;

     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 stack subscript. */

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_cg_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);
	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) returns (fixed binary (18));

	/* Calculates base of new stack frame */

dcl  macro_proc fixed binary (18);			/* Proc being called */

dcl  nargs fixed binary (18);

	nargs = macro_dt_inst (macro_proc).data_type;
	if nargs < 0
	then nargs = stack (top) + bias + 1;
	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;
	addr (rands (temp)) -> temporary.ref_count = 1;
	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  node_size fixed binary;
dcl  (amount, op_type, temp) fixed binary (18);
dcl  amt fixed binary (18);
dcl  loc fixed binary (18);
dcl  node_type fixed binary (4);
dcl  p pointer;
dcl  size builtin;

	node_type = temporary_node;
	node_size = size (temporary);
	op_type = temp_type;
	go to join;

create_var:
     entry (amount) returns (fixed binary (18));

	/* Creates an automatic variable of the desired size */

	node_type = symbol_node;
	node_size = size (symbol);
	op_type = variable_type;

join:
	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;

	if node_type = symbol_node
	then temp = create_node (node_type, node_size);
	else temp = get_temp_node ();

	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 node_type = temporary_node
	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;

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;
		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);

	/* Check for reference count error */

	if tp -> temporary.ref_count < 0
	then do;
	     call print_message (415, temp);
	     return;
	     end;

	tp -> temporary.not_in_storage = "1"b;
	temp_size = tp -> temporary.size;

	call flush_ref (temp);
	call flush_addr (temp);

	/* Restore address of dynamic temporary */

	if tp -> temporary.stack_indirect
	then do;
	     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;

push_variable:
     procedure (dt);

	/* Pushes an automatic variable of data_type dt onto the stack */

dcl  dt fixed binary (18);

dcl  (var, amt, temp) fixed binary (18);

	amt = data_type_size (dt);

	if amt > 1
	then if mod (last_auto_loc, 2) ^= 0
	     then do;

		/* force doubleword alignement for the variable */

		temp = create_temp (1);
		call free_temp (addr (rands (temp)));
		end;

	var = create_var (amt);

	addr (rands (var)) -> symbol.data_type = dt;

	call push (var);

     end push_variable;

/**** 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 load ((p -> temporary.length), in_q);
	call use_eaq (0);
	call flush_base (which_base (2));
	call emit_operator_call ((tv_offset));

	machine_state.stack_extended = "1"b;
	machine_state.address_in_base = "1"b;
	p -> temporary.address_in_base = "1"b;
	p -> temporary.address.base = bases (which_base (2));

	machine_state.last_dynamic_temp = temp;

	machine_state.base_regs (which_base (2)).variable = temp;
	machine_state.base_regs (which_base (2)).type = 1;
	machine_state.base_regs (which_base (2)).used = text_pos;
	machine_state.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 text_word (text_pos) = unspec (machine_instruction (imac));

	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_cg_macros_$single_inst (mac_num).increment;

	call put_word ((fort_cg_macros_$single_inst (mac_num)), (rand), inc);

	text_pos = text_pos + 1;
	return;


emit_single_with_inc:
     entry (mac_num, rand, incr);

	/* Emits a single instruction with a specified address increment */

dcl  incr fixed binary (18);

	inc = incr;


	call put_word ((fort_cg_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_cg_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);

	text_word (text_pos) = unspec (fort_cg_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;

	text_word (text_pos) = (unspec (fort_cg_macros_$single_inst (mac_num)) & mask_left) | address;

	if fort_cg_macros_$single_inst (mac_num).increment ^= 0
	then if instruction (text_pos).ext_base
	     then instruction (text_pos).offset =
		     instruction (text_pos).offset + fort_cg_macros_$single_inst (mac_num).increment;
	     else text_halfs (text_pos).left =
		     text_halfs (text_pos).left + fort_cg_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 given an address probably supplied by
	   c_a and outputs reloc and listing info */

dcl  mac_num fixed binary (18);			/* Single instruction number */
dcl  var_ptr pointer;				/* Pointer to node for operand */
dcl  p pointer;					/* Pointer to array_ref_parent */
dcl  text_offset fixed bin;				/* offset of instruction in text section */

	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));

	/* catch possible references to the text section  - phx13550 */

	p = var_ptr;
	if var_ptr -> node.node_type = array_ref_node
	then p = addr (rands (var_ptr -> array_ref.parent));

	if substr (unspec (p -> node.address), 30, 7) = "0000000"b
	then do;
	     text_pos = text_pos - 1;			/* Backup since emit_c_a inc text_pos */
	     text_offset = instruction.offset (text_pos);
	     instruction.offset (text_pos) = 0;		/* clear out offset (14 bit) */
	     call text_ref (p, (fort_cg_macros_$single_inst (mac_num).increment) + text_offset,
		fixed (fort_cg_macros_$single_inst (mac_num).op_code, 10), 0);
	     text_pos = text_pos + 1;			/* fixup */
	     end;
     end emit_c_a_var;

emit_temp_store:
     procedure (mac_no, temp);

	/* Emits code to store a temporary.  Calls emit_c_a rather
	   than emit_single to avoid recursion. */

dcl  (mac_no, mac) fixed binary (18);
dcl  temp fixed binary (18);
dcl  p pointer;

	mac = mac_no;
	p = addr (rands (temp));

	if ^p -> temporary.is_addressable
	then call m_a_except_xreg (p);

	call emit_c_a (mac, unspec (p -> temporary.address));

	p -> temporary.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;

	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, 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,
     rand fixed binary (18),
     inc fixed binary (18);

dcl  p pointer;

dcl  mop fixed binary (18);

	if rand < 0
	then do;

	     /* have a count, make it the address */

	     text_word (text_pos) = unspec (inst) & mask_left;

	     /* use direct modifier if possible */

	     mop = fixed (inst.op_code, 10);
	     if directable (mop)
	     then instruction (text_pos).tag = DL_mod;	/* dl */

	     text_halfs (text_pos).left = rand + bias + inc;
	     return;
	     end;

	p = addr (rands (effective_operand (rand)));

	if ^p -> node.is_addressable
	then do;
	     if inc ^= 0 & p -> node.address.ext_base
	     then call increment_address (p, (inc));
	     call m_a (p);
	     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), fixed (inst.op_code, 10), 0);
	else if inc ^= 0
	then if instruction (text_pos).ext_base
	     then if ^p -> node.is_addressable
		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;

     end put_word;

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 init ("236"b3),
     lcq init ("336"b3),
     adq init ("076"b3),
     sbq init ("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.  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  p ptr;					/* pointer to descriptor addressed node */
dcl  text_offset fixed bin (18);			/* used for text reference */

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  (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));

	/* 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);

	     reloc (text_pos).left_rel = arg (i) -> node.reloc;

	     if assembly_list
	     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);

	     /* See if text reference, if so may need forward reference. */

	     text_offset = inc (i);
	     p = arg (i);
	     if p -> node.node_type = array_ref_node
	     then do;
		p = addr (rands (p -> array_ref.parent));
		text_offset = text_offset + arg (i) -> node.offset;
		end;
	     if substr (unspec (p -> node.address), 30, 7) = "0000000"b
	     then call text_ref (p, text_offset, fixed (machine_instruction (imac - i).op_code, 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);
	     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 of 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				/* Constant length */
	     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 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;

	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 do;
		call print_message (446, fixed (rel (p), 18));
		stop;
		end;

	     if p -> array_ref.variable_offset
	     then do;
		v = addr (rands (p -> array_ref.v_offset));
		if v -> node.value_in.eaq | v -> node.dont_update
						/* really node.subs_in_q */
		     | p -> array_ref.large_offset
		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 do;
			p -> array_ref.address.tag = eaq_man_load_a_or_q (v);
			v -> node.dont_update = "0"b; /* really node.subs_in_q */
			end;

		     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 make addressable */
dcl  p1 pointer;					/* Node to get adressing 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 p1 = p;

	if p1 -> node.needs_pointer
	then do;

	     /* 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 -> temporary.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
		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 */

	     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 */
dcl  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;

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 & p -> node.address.ext_base
		then call increment_address (p, inc (i));

		call m_a (p);

		/* Reserve any XRs or EAQ registers used */

		call lock_tag_register ((p -> node.address.tag));

		/* Reserve any base registers used */

		if p -> node.address.ext_base
		then do;
		     reg = which_base (fixed (p -> node.address.base, 3));
		     machine_state.base_regs (reg).reserved = "1"b;	/* lock for use in addressing */
		     end;

		end;

	     end;

     end make_both_addressable;

/**** GET_FREE_REG ****/

get_free_reg:
     procedure (regs, first, last, k) returns (fixed binary (3));

	/* Implements register searching algorithm */

dcl  1 regs (0:7) aligned like base_regs,
     (first, last) fixed binary (18),			/* Limits of search */
     k fixed binary (3);				/* Register already found to be empty */

dcl  (i, j) fixed binary (3);
dcl  lused fixed binary (18);

	if k > 0
	then if ^regs (k).reserved
	     then return (k);

	j = -1;
	lused = 131071;

	do i = first to last;

	     if ^regs (i).reserved
	     then do;
		if regs (i).type = 0
		then return (i);
		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;

/**** 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
	   2		ptr to loc v in arg list
	   3		ptr thru link with offset v
	   4		ptr at 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 desc 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 bin (3);
dcl  address bit (36) aligned;
dcl  diff fixed bin (18);

	n = code;
	v = num;
	diff, off = offset;

	j, k = 0;

	do i = first_base to last_base;
	     if base_regs (i).type = 0
	     then k = i;
	     else if base_regs (i).type = n
	     then if base_regs (i).variable = v
		then if base_regs (i).offset = off
		     then do;
			base_regs (i).used = text_pos;
			return (bases (i));
			end;
		     else j = i;
	     end;

	if j > 0
	then do;

	     /* Right storage area, but wrong offset */

	     diff = off - base_regs (j).offset;
	     address = c_a (0, 6);
	     substr (address, 1, 3) = bases (j);
	     i = get_free_reg (base_regs, first_base, last_base, 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;
	     machine_state.address_in_base = "1"b;
	     i = get_free_reg (base_regs, first_base, last_base, 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)));
	     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 (base_regs, first_base, last_base, 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 (base_regs, first_base, last_base, k);
	     call flush_base (i);

	     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));

	base_regs (i).type = n;
	base_regs (i).variable = v;
	base_regs (i).offset = off;
	base_regs (i).used = text_pos;

	return (bases (i));

     end base_man_load_any_pr;

base_man_load_VLA:
     proc (op, i);

dcl  op fixed bin (18);
dcl  (loc_p, s, p, v) ptr;
dcl  i fixed bin (3);
dcl  address bit (36) aligned;
dcl  1 inst_address like symbol.address based (addr (address));
dcl  location fixed bin (18);				/* address of operand */

	/* Do addressing in the following situations.

	   1. Simple reference.  Use the 256K pointer directly at the symbol.
	   2. Array reference.   Use the 255K pointer if 'VLA_is_255K', else use
	   the packed pointer.  The 255K pointer is either in the A or Q or
	   stored at 'v_offset'.  Set the listing to indicate the symbol. */

	/* p is the pointer to the operand supplied.
	   s is the pointer to the symbol involved.
	   v is the pointer to the node whose address will be loaded. */

	p = addr (rands (op));
	if p -> node.node_type = array_ref_node
	then do;
	     s = addr (rands (p -> array_ref.parent));	/* symbol */
	     v = addr (rands (p -> array_ref.v_offset));	/* addressor */
	     end;
	else v, s = p;				/* symbol and addressor */

	reloc (text_pos).left_rel = v -> node.reloc;

	/* Use array name in listing. */

	if assembly_list
	then a_name (text_pos) = binary (rel (s), 18, 0);

	/* if we are dealing with the symbol direct, then use its addressing info, else
	   use the addressing info of the v_offset temp, which is in the stack */

	if v ^= s					/* not symbol */
	then loc_p = v;				/* array_ref */
	else loc_p = s;				/* symbol */

	/* if this is a non-dimensioned VLA symbol, use it's saved
	   offset information. */
	if v = s & ^s -> symbol.dimensioned
	then substr (unspec (s -> symbol.address), 1, 18) = s -> symbol.addr_hold;

	if loc_p -> symbol.large_address
	then location = loc_p -> node.address.offset + loc_p -> node.location;
	else location = loc_p -> node.address.offset;

	if v ^= s
	then address = c_a (location, 6);		/* array_ref */
	else if loc_p -> symbol.in_common | loc_p -> symbol.static
	then address = c_a (location, 5);		/* static/common */
	else address = c_a (location, 6);		/* auto */

	/* If the subscript calculated is aready in the A or the Q then we can do
	   work directly.  Else we load the packed base. */

	if s ^= v & v -> node.value_in.eaq
	then do;
	     address = "0"b;
	     if get_eaq_name ((p -> array_ref.v_offset)) = in_q
	     then do;				/* use Q addressing */
		inst_address.tag = QL_mod;		/* load segment with text ring */
		call emit_c_a ((load_base (i)), address);
		inst_address.tag = QU_mod;		/* load word number */
		call emit_c_a ((load_segment_num (i)), address);
		end;
	     else do;				/* use A addressing */
		inst_address.tag = AL_mod;		/* load segment with text ring */
		call emit_c_a ((load_base (i)), address);
		inst_address.tag = AU_mod;		/* load word */
		call emit_c_a ((load_segment_num (i)), address);
		end;
	     end;
	else do;
	     call emit_c_a ((load_packed_base (i)), address);

	     /* for symbols (not array_refs), zero the offset in the
	        symbol, since all references through the pointer just
	        created must be prN|0 references. */
	     if v = s & ^s -> symbol.dimensioned
	     then s -> symbol.address.offset = 0;
	     end;
     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 machine_state.base_regs (i).type = 1
	then do;
	     p = addr (rands (machine_state.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));
			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;

	     end;

     end flush_base;

base_man_load_pr:
     procedure (opnd, which);

	/* Loads the address of an operand into the
	   specified register and reserves the 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;
dcl  1 inst_address aligned like node.address;
dcl  tag_hold bit (6) aligned;
dcl  char_num_hold fixed bin (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);

	/* 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 we are dealing in char_units, then we want to avoid
	   calling m_a and setting the 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 call emit_c_a_var ((load_base (i)), p);
	     else if VLA
	     then call base_man_load_VLA (op, i);
	     else call emit_single ((load_base (i)), op);

	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;

	machine_state.base_regs (i).reserved = "1"b;	/* Lock for use in addressing */
	machine_state.base_regs (i).type = -1;		/* Unknown value */
	machine_state.base_regs (i).variable = op;	/* debugging */
	machine_state.base_regs (i).offset = 0;
	machine_state.base_regs (i).used = text_pos;

	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 machine_state.base_regs (i).type ^= 7 | machine_state.base_regs (i).variable ^= op
	     | machine_state.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)	/* inst 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 */

	     base_regs (i).type = 7;			/* value of op in pr */
	     base_regs (i).variable = op;		/* debugging */
	     base_regs (i).offset = 0;
	     end;

	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);
dcl  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;

	k = 0;

	do i = first_base to last_base;
	     if base_regs (i).type = 0
	     then k = i;
	     else if base_regs (i).type = code & base_regs (i).offset = off
	     then do;
		base_regs (i).used = text_pos;
		return (bases (i));
		end;

	     end;

	i = get_free_reg (base_regs, first_base, last_base, 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));

	base_regs (i).type = code;
	base_regs (i).variable = 0;
	base_regs (i).offset = off;
	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 base_regs (which).type = 8;
	else base_regs (which).type = 6;
	base_regs (which).variable = 0;
	base_regs (which).offset = offset;
	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);

	k = 0;

	do i = first_base to last_base;
	     if machine_state.base_regs (i).type = 0
	     then k = i;
	     else if machine_state.base_regs (i).type = 5
	     then do;
		machine_state.base_regs (i).used = text_pos;
		return (bases (i));
		end;
	     end;

	i = get_free_reg (machine_state.base_regs, first_base, last_base, 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));

	machine_state.base_regs (i).type = 5;
	machine_state.base_regs (i).variable = 0;
	machine_state.base_regs (i).used = text_pos;
	machine_state.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 any pointer register with a pointer to the argument
	   descriptor list. */

dcl  (i, k) fixed binary (3);
dcl  n fixed binary (18);

	k = 0;

	do i = first_base to last_base;
	     if base_regs (i).type = 0
	     then k = i;
	     else if base_regs (i).type = 9
	     then do;
		base_regs (i).used = text_pos;
		return (bases (i));
		end;
	     end;

	i = get_free_reg (base_regs, first_base, last_base, 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));

	base_regs (i).type = 9;
	base_regs (i).variable = 0;
	base_regs (i).used = text_pos;
	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 may 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  (free_reg, large_base_reg, i) 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;

	tp -> temporary.not_in_storage = "0"b;

	/* If the temp is simply addressable, 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 base_regs (i).type = 0
	     then free_reg = i;
	     else if base_regs (i).type = 8 & base_regs (i).offset = tp -> temporary.location
	     then large_base_reg = i;
	     end;

	/* If there is such a pointer register, use it */

	if large_base_reg > 0
	then do;
	     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 = base_regs (temp_reg).reserved;
	base_regs (temp_reg).reserved = "1"b;
	i = get_free_reg (base_regs, first_base, last_base, free_reg);
	base_regs (temp_reg).reserved = was_reserved;

	if base_regs (i).type ^= 1
	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 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;

/**** 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);

	/* Loads an operand into any index register */

dcl  pt pointer;					/* Points at value to be loaded */

dcl  p pointer;
dcl  v fixed binary (18);
dcl  i fixed binary (3);

	p = pt;
	v = fixed (rel (p), 18);

	if p -> node.value_in.x
	then do;
	     do i = first_index to last_index;
		if index_regs (i).type = 1
		then if index_regs (i).variable = v
		     then do;
			machine_state.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 (index_regs, first_index, last_index, 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
	     then call print_message (419, v);

	     if ^p -> node.is_addressable
	     then call m_a_except_xreg (p);

	     call emit_c_a_var (lxl0 + i, p);
	     end;

	index_regs (i).type = 1;
	index_regs (i).variable = v;
	p -> node.value_in.x = "1"b;
	index_regs (i).used = text_pos;
	machine_state.value_in_xr = "1"b;

	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 bin (18);
dcl  p ptr;

	if index_regs (which).type ^= 1
	then return;

	i = which;

	p = addr (rands (index_regs (i).variable));
	p -> node.value_in.x = "0"b;

	/* the value has not been previously stored, so do so */

	if p -> node.not_in_storage
	then do;
	     call emit_temp_store (sxl0 + i, index_regs (i).variable);
	     end;

     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);				/* Constant 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;
	     index_regs (k).used = text_pos;
	     return ("001"b || bit (binary (k, 3), 3));
	     end;

	i = get_free_reg (index_regs, first_index, last_index, k);

	call flush_xr (i);

	call use_ind;

	call emit_c_a (eax0 + i, c_a_18 (c, 0));

	index_regs (i).type = 2;
	index_regs (i).variable = c;
	index_regs (i).used = text_pos;

	return ("001"b || bit (i, 3));

     end xr_man_load_const;

const_in_xr:
     procedure (value, first_xr, xr_num) returns (bit (1) aligned);

	/* Procedure to find xr containing a particular constant value
	   or find an empty xr. */

dcl  value fixed binary (18);				/* Constant value required in xr */
dcl  first_xr fixed binary (18);			/* First xr to be checked */
dcl  xr_num fixed binary (3);				/* Xr containing value or a free xr */
dcl  c fixed binary (18);
dcl  i fixed binary (3);

	xr_num = 0;				/* initialize - no xr found */
	c = value;

	do i = first_xr to last_index;
	     if index_regs (i).type = 0
	     then xr_num = i;
	     else if index_regs (i).type = 2
	     then if index_regs (i).variable = c
		then do;
		     xr_num = i;
		     return ("1"b);
		     end;
	     end;

	return ("0"b);

     end const_in_xr;

xr_man_add_const:
     procedure (which, csize) returns (bit (6) aligned);

	/* Add a constant to the value in an index register */

dcl  which fixed binary (3);
dcl  csize fixed binary (18);

dcl  c fixed binary (18);
dcl  (i, 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 (machine_state.index_regs, first_index, last_index, 0);

	call flush_xr (j);
	call use_ind ();
	call emit_c_a (eax0 + j, address);		/* Emit eax_m 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. */

	machine_state.index_regs (j).type = 0;		/* Empty */
	machine_state.index_regs (j).variable = 0;
	machine_state.index_regs (j).used = text_pos;

	return (bit (fixed (j + 8, 6), 6));		/* Return XR modifier */

     end xr_man_add_const;

/**** 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;

	do i = 1 to length (reserve);
	     if substr (reserve, i, 1)
	     then if i <= 8
		then do;
		     j = i - 1;
		     call flush_xr (j);
		     machine_state.index_regs (j).reserved = "1"b;
		     machine_state.index_regs (j).type = -1;
						/* Unknown value */
		     end;
		else do;
		     j = i - 8;
		     call flush_base (j);
		     machine_state.base_regs (j).reserved = "1"b;
		     machine_state.base_regs (j).type = -1;
						/* Unknown value */
		     machine_state.base_regs (j).variable = 0;
						/* debugging */
		     machine_state.base_regs (j).offset = 0;
		     end;
	     end;

     end reserve_regs;

free_regs:
     procedure ();

	/* Frees all reserved registers (index, base, and eaq)
	   reloading pr4 if necessary */

dcl  i fixed binary (18);

	machine_state.eaq (*).reserved = "0"b;

	do i = escape_index to last_index;
	     if machine_state.index_regs (i).reserved
	     then do;
		machine_state.index_regs (i).reserved = "0"b;
		if machine_state.index_regs (i).type < 0/* Unknown? */
		then machine_state.index_regs (i).type = 0;
		end;
	     end;

	do i = first_base to last_base;		/* Normal bases */
	     if machine_state.base_regs (i).reserved
	     then do;
		machine_state.base_regs (i).reserved = "0"b;
		if machine_state.base_regs (i).type < 0 /* Unknown? */
		then machine_state.base_regs (i).type = 0;
		end;
	     end;

	/* Bug 508: Reload pr4 with linkage ptr value only if necessary */

	i = which_base (4);
	if machine_state.base_regs (i).reserved & machine_state.base_regs (i).type ^= 6
	then do;
	     call emit_zero (getlp);                            /* Emit code to restore pr4 */
	     machine_state.base_regs (i).type = 6; /* linkage ptr */
	     end;

	machine_state.base_regs (i).reserved = "0"b;

     end free_regs;

reset_regs:
     procedure ();

	/* Resets all regs to their initial state */

dcl  i fixed binary (3);

	if machine_state.address_in_base
	then do i = first_base to last_base;
		call flush_base (i);
		end;

	call reset_eaq (IND);			/* Reset indicators */
	call reset_eaq (EAQ);			/* Reset A, Q, EAQ */

	if machine_state.value_in_xr
	then do i = first_index to last_index;
		if index_regs (i).type = 1
		then if index_regs (i).variable ^= 0
		     then call flush_xr (i);
		end;

	unspec (machine_state) = "0"b;

	machine_state.base_regs (which_base (4)).type = 6;/* linkage_ptr */

     end reset_regs;

flush_ref:
     procedure (index);

	/* Flush complex reference.  This is an aliased reference.  Here we find the
	   paren 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 (machine_state.eaq, 1);	/* A, Q, EAQ, IND */
		do i = 1 by 1 while (i <= machine_state.eaq (r).number);
		     if machine_state.eaq (r).variable (i) = temp
		     then do;
			do i = i + 1 by 1 while (i <= machine_state.eaq (r).number);
			     machine_state.eaq (r).variable (i - 1) = machine_state.eaq (r).variable (i);
			     end;

			machine_state.eaq (r).number = machine_state.eaq (r).number - 1;
			if machine_state.eaq (r).number = 0
			then machine_state.eaq (r).name = 0;

			end;
		     end;
		end;
	     end;

	if p -> node.value_in.x
	then do i = first_index repeat i + 1 while (i <= last_index);
		if index_regs (i).type > 0
		then if index_regs (i).variable = temp
		     then index_regs (i).type = 0;
		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 base_regs (i).type = 1
		then if base_regs (i).variable = temp
		     then base_regs (i).type = 0;
		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 XR modification, lock index reg for use in addressing */
	if substr (t, 3, 1)			
	then machine_state.index_regs (fixed (t, 6) - 8).reserved = "1"b;
	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);

	/* Take care of subscripts in the Q */

	if p -> node.dont_update			/* really node.subs_in_q */
	then return (QL_mod);

	/* 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 machine_state.eaq (A).reserved & machine_state.eaq (Q).reserved
	then call print_message (449);		/* Oops */

	if machine_state.eaq (A).reserved
	then name = in_q;
	else if machine_state.eaq (Q).reserved
	then name = in_ia;
	else if machine_state.eaq (Q).number > 0 & machine_state.eaq (A).number = 0 & machine_state.eaq (IND).number = 0
	then name = in_ia;
	else name = in_q;

	call use_eaq (v);

	if ^p -> node.is_addressable
	then call m_a_except_xreg (p);

	call emit_c_a_var (load_inst (name), p);

	machine_state.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 (machine_state.eaq, 1);

	     do v = 1 to machine_state.eaq (r).number;

		if machine_state.eaq (r).variable (v) = op
		then return (machine_state.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),
     regno fixed binary (18);

	var = v;
	regno = eaq_name_to_reg (name);

	call reset (regno);

	machine_state.rounded = "0"b;

	machine_state.eaq (regno).number = 1;
	machine_state.eaq (regno).variable (1) = var;
	machine_state.eaq (regno).name = name;

	if machine_state.eaq (regno).name = in_ind
	then do;
	     call print_message (420, var);
	     return;
	     end;

	addr (rands (var)) -> node.value_in.eaq = "1"b;

	if regno = IND
	then machine_state.indicators_valid = 0;
	else machine_state.indicators_valid = regno;

     end in_reg;

also_in_reg:
     procedure (v, name);

	/* Appends an operand to the eaq register state */

dcl  (var, v) fixed binary (18),
     (i, regno) fixed binary (18),
     name fixed binary (18),
     p pointer;

	regno = eaq_name_to_reg (name);
	var = v;

	addr (rands (var)) -> node.value_in.eaq = "1"b;

	if machine_state.eaq (regno).number < hbound (machine_state.eaq.variable, 2)
	then do;
	     machine_state.eaq (regno).number = machine_state.eaq (regno).number + 1;
	     machine_state.eaq (regno).variable (machine_state.eaq (regno).number) = var;
	     return;
	     end;
	else do i = 1 to hbound (machine_state.eaq.variable, 2);

		p = addr (rands (machine_state.eaq (regno).variable (i)));

		if p -> node.node_type ^= temporary_node
		then do;
		     machine_state.eaq (regno).variable (i) = var;
		     p -> node.dont_update,		/* really node.subs_in_q */
			p -> node.value_in.eaq = "0"b;
		     return;
		     end;
		end;

	call print_message (448);

     end also_in_reg;

use_eaq:
     procedure (array_name);

	/* Empties the eaq, saving temporaries in storage and indexes
	   of array references in index registers */

dcl  array_name fixed binary (18);
dcl  p pointer;
dcl  own_sub pointer;
dcl  bit6 bit (6) aligned;
dcl  mac fixed binary (18);
dcl  (r, i) fixed binary (18);

	own_sub = null ();

	if array_name > 0
	then if addr (rands (array_name)) -> node.node_type = array_ref_node
	     then if addr (rands (array_name)) -> array_ref.ref_count = 1
		then if addr (rands (array_name)) -> array_ref.variable_offset
		     then if addr (rands (array_name)) -> array_ref.data_type ^= cmpx_mode
			then if addr (rands (addr (rands (array_name)) -> array_ref.v_offset)) -> node.value_in.eaq
			     then own_sub = addr (rands (addr (rands (array_name)) -> array_ref.v_offset));

	if machine_state.eaq (IND).number > 0
	then call use_ind ();

	do r = 1 to hbound (machine_state.eaq, 1) - 1;	/* A, Q, EAQ */

	     do i = 1 to machine_state.eaq (r).number;

		p = addr (rands (machine_state.eaq (r).variable (i)));
		if p -> node.node_type = temporary_node
		then do;
		     if p -> temporary.dont_update	/* really temporary.subs_in_q */
		     then if p = own_sub & p -> temporary.ref_count = 1 & r = Q
			then ;
			else do;
			     bit6 = xr_man_load_any_xr (p);
			     p -> temporary.dont_update = "0"b;
						/* really temporary.subs_in_q */
			     end;

		     else if p -> temporary.not_in_storage & ^p -> temporary.value_in.x
		     then do;
			if ^do_rounding | machine_state.rounded
			then mac = store_no_round_inst (machine_state.eaq (r).name);
			else mac = store_inst (machine_state.eaq (r).name);
			call emit_temp_store (mac, (machine_state.eaq (r).variable (i)));
			end;
		     end;

		if p -> node.node_type = symbol_node & p ^= own_sub
		then p -> symbol.dont_update = "0"b;	/* really symbol.subs_in_q */

		p -> node.value_in.eaq = "0"b;
		end;

	     machine_state.eaq (r).name = 0;		/* mark register empty */
	     machine_state.eaq (r).number = 0;

	     end;

	machine_state.rounded = "0"b;

     end use_eaq;

use_ind:
     procedure ();

	/* Empties the indicators, saving logical values in the
	   A register if necessary */
	/* NOTE if anything in EAQ then it too has to go. */

dcl  var fixed binary (18);

	if machine_state.eaq (IND).number > 0
	then if addr (rands (machine_state.eaq (IND).variable (1))) -> node.not_in_storage
	     then do;
		call save_logical_temps ();
		call emit_zero ((ind_to_a (machine_state.eaq (IND).name - in_ind)));

		/* Update machine state */

		var = machine_state.eaq (IND).variable (1);
		call reset_eaq (IND);
		machine_state.eaq (A).number = 1;
		machine_state.eaq (A).name = in_a;
		machine_state.eaq (A).variable (1) = var;
		addr (rands (var)) -> node.value_in.eaq = "1"b;
		end;

	machine_state.indicators_valid = 0;

save_logical_temps:
     procedure ();

	/* This procedure is analogous to use_eaq, but is used to save
	   temps in the A and EAQ registers only.  It is called by use_ind to
	   avoid recursion with use_eaq. */

dcl  (mac, i) fixed binary (18);
dcl  bit6 bit (6) aligned;
dcl  p ptr;

	do i = 1 by 1 while (i <= machine_state.eaq (A).number);

	     if addr (rands (machine_state.eaq (A).variable (i))) -> node.not_in_storage
	     then call emit_temp_store (sta, (machine_state.eaq (A).variable (i)));
	     end;

	/* The following code is more or less taken from use_eaq. */

	do i = 1 to machine_state.eaq (EAQ).number;
	     p = addr (rands (machine_state.eaq (EAQ).variable (i)));
	     if p -> node.node_type = temporary_node
	     then do;
		if p -> temporary.dont_update		/* really temporary.subs_in_q */
		then do;
		     bit6 = xr_man_load_any_xr (p);
		     p -> temporary.dont_update = "0"b; /* really temporary.subs_in_q */
		     end;

		else if p -> temporary.not_in_storage & ^p -> temporary.value_in.x
		then do;
		     if ^do_rounding | machine_state.rounded
		     then mac = store_no_round_inst (machine_state.eaq (EAQ).name);
		     else mac = store_inst (machine_state.eaq (EAQ).name);
		     call emit_temp_store (mac, (machine_state.eaq (EAQ).variable (i)));
		     end;
		end;

	     if p -> node.node_type = symbol_node
	     then p -> symbol.dont_update = "0"b;	/* really symbol.subs_in_q */

	     p -> node.value_in.eaq = "0"b;
	     end;

	call reset_eaq (A);

     end save_logical_temps;
     end use_ind;

load:
     procedure (vp, name);

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 we are trying to load some register other than the
	   indicators, and there are logical values in the indicators,
	   we must get the indicators into the A now, before the load
	   takes place.  This is a kludge, and a holdover from the old
	   EAQ management scheme. */

	if eaq_name ^= in_ind & machine_state.eaq (IND).number > 0
	then call use_ind ();

	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 (machine_state.eaq, 1);
						/* A, Q, EAQ, IND */

		do i = 1 by 1 while (i <= machine_state.eaq (regno).number);
		     if var = machine_state.eaq (regno).variable (i)
		     then do;

			if eaq_name = in_tq | eaq_name = in_q
			then if machine_state.eaq (regno).name = in_tq | machine_state.eaq (regno).name = in_q
			     then machine_state.eaq (regno).name = eaq_name;

			if eaq_name = machine_state.eaq (regno).name
			then return;

			if eaq_name = in_ind
			then do;
			     if regno = IND
			     then return;

			     if machine_state.eaq (regno).name = in_a
			     then if machine_state.indicators_valid = A
				then do;
				     call flush_ref (var);
				     call in_reg (var, tnz);
				     return;
				     end;
			     end;

			else if eaq_name = in_a & regno = IND
			     & addr (rands (var)) -> node.node_type = temporary_node
			then do;
			     call use_ind ();
			     machine_state.indicators_valid = A;
			     return;
			     end;

			end;

		     end;

		end;

	     end;

	call use_eaq (var);

	call emit_single ((load_inst (eaq_name)), var);

	if eaq_name = in_ind
	then eaq_name = tnz;

	call in_reg (var, eaq_name);

	machine_state.rounded = "1"b;

     end load;

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);

	machine_state.rounded = "0"b;

	return;

     end reset_eaq;

reset:
     procedure (r);

	/* Resets a single eaq register */

dcl  (i, r, regno) fixed binary (18);
dcl  p pointer;

	regno = r;

	do i = 1 by 1 while (i <= machine_state.eaq (regno).number);
	     p = addr (rands (machine_state.eaq (regno).variable (i)));
	     p -> node.dont_update,			/* really node.subs_in_q */
		p -> node.value_in.eaq = "0"b;
	     end;

	machine_state.eaq (regno).name = 0;
	machine_state.eaq (regno).number = 0;

     end reset;

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, reg) fixed binary (18);
dcl  v pointer;

	eaq_name = name;
	var = vp;
	v = addr (rands (var));

	if do_rounding & ^machine_state.rounded
	then inst_number = store_inst (eaq_name);
	else inst_number = store_no_round_inst (eaq_name);

	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;
	     reg = eaq_name_to_reg (eaq_name);
	     if eaq_name = machine_state.eaq (reg).name
	     then call also_in_reg (var, eaq_name);
	     else 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);

	machine_state.eaq (reg).reserved = "1"b;
     end lock_eaq;

/**** REL CONSTANTS ****/

alloc_label:
     procedure (stack_sub, value);

dcl  stack_sub fixed binary (18),			/* Subscript of operand in stack */
     value fixed binary (18);				/* Value to be assigned to operand */

dcl  p pointer;

	p = addr (rands (stack (stack_sub)));

	p -> label.location = value;
	p -> label.allocated = "1"b;

     end alloc_label;

/**** BUILD PROFILE ENTRY ****/

build_profile_entry:
     procedure ();

	/* 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 use_ind;				/* aos sets indicators */
	     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 ****/

next_subscript:
     procedure ();

	/* Generates code to check the range of the subscript
	   at the top of the stack.  The following stack format
	   is expected:

	   array variable
	   number of subscripts
	   sub1
	   sub2
	   .
	   .
	   .
	   subn
	*/

dcl  (d, p, s) pointer;
dcl  (isub, csub, bound) fixed binary (18);

	s = addr (rands (stack (base)));
	d = addr (rands (s -> symbol.dimension));
	p = addr (rands (stack (top)));
	isub = top - base - 1;

	/* Do compile time range checking if the subscript is constant */

	if p -> node.operand_type = constant_type
	then do;
	     unspec (csub) = p -> constant.value;

	     if ^d -> dimension.v_bound (isub).lower
	     then if csub < d -> dimension.lower_bound (isub)
		then call print_message (422, stack (top), stack (base));
						/* Warning if lower bound exceeded */

	     if ^d -> dimension.v_bound (isub).upper
	     then if csub > d -> dimension.upper_bound (isub)
		then if s -> symbol.parameter
		     then do;

			/* Warning if upper bound is exceeded and array is a parameter */

			call print_message (431, stack (top), stack (base));
			end;
		     else do;

			/* Severity 3 error if upper bound is exceeded and array is not a parameter */

			call print_message (422, stack (top), stack (base));
			call signal_error ();
			return;
			end;

	     end;

	/* Emit code to check subscript range (if necessary) */

	if cs -> subprogram.options.subscriptrange
	then if (isub < d -> dimension.number_of_dims | ^d -> dimension.assumed_size)
	     then if (p -> node.operand_type ^= constant_type | string (d -> dimension.v_bound (isub)) ^= "00"b)
		then do;

		     if d -> dimension.v_bound (isub).lower
		     then bound = d -> dimension.lower_bound (isub);
		     else bound = create_integer_constant ((d -> dimension.lower_bound (isub)));
		     call copy (bound);

		     if d -> dimension.v_bound (isub).upper
		     then bound = d -> dimension.upper_bound (isub);
		     else bound = create_integer_constant ((d -> dimension.upper_bound (isub)));
		     call copy (bound);

		     call interpreter_proc (check_subscript, r1);
r1:
		     end;

     end next_subscript;

finish_subscript:
     procedure ();

	/* Puts out code to compute offset of subscripted reference
	   and creates an array ref.  A similar stack format
	   to that expected by next_subscript is expected */

dcl  (a, d, p, s) pointer;
dcl  csum fixed bin (24);
dcl  (vsum, i, a_ref, zsub, cvalue) fixed binary (18);
dcl  (first_time, have_vsum, code_emitted, char_77_mode, big_offset) bit (1) aligned;


	s = addr (rands (stack (base)));
	d = addr (rands (s -> symbol.dimension));

	first_time = "1"b;
	code_emitted, have_vsum, big_offset = "0"b;
	char_77_mode = (s -> symbol.units = char_units);
	csum = 0;
	zsub = base + 1;

	do i = d -> dimension.number_of_dims to 1 by -1;
	     if ^first_time
	     then do;

		/* multiply by dimension.size (i) */

		if string (d -> dimension.v_bound (i)) = "00"b
		then do;
		     csum = csum * d -> dimension.size (i);
		     if have_vsum
		     then call mult (d -> dimension.size (i) - bias);
		     end;

		else do;
		     if csum ^= 0
		     then do;
			if have_vsum
			then call add_csum;
			else do;
			     have_vsum = "1"b;
			     vsum = create_integer_constant ((csum));
			     end;

			csum = 0;
			end;

		     if have_vsum			/* PREVIOUSLY FORGOTTEN */
		     then call mult ((d -> dimension.size (i)));
		     end;
		end;

	     first_time = "0"b;

	     /* add ith subscript */

	     p = addr (rands (stack (zsub + i)));

	     if p -> node.operand_type = constant_type
	     then do;
		unspec (cvalue) = p -> constant.value;
		csum = csum + cvalue;
		end;
	     else do;
		if have_vsum
		then call add ((stack (zsub + i)));
		else do;
		     have_vsum = "1"b;
		     vsum = stack (zsub + i);
		     end;
		end;
	     end;

	/* multiply by element size */

	if s -> symbol.v_length ^= 0
	then do;
	     if csum ^= 0
	     then do;
		if have_vsum
		then call add_csum;
		else do;
		     have_vsum = "1"b;
		     vsum = create_integer_constant ((csum));
		     end;
		csum = 0;
		end;
	     if have_vsum
	     then call mult ((s -> symbol.v_length));
	     else do;
		vsum = s -> symbol.v_length;
		have_vsum = "1"b;
		end;
	     end;
	else if s -> symbol.element_size ^= 1
	then do;
	     csum = csum * s -> symbol.element_size;
	     if have_vsum
	     then call mult (s -> symbol.element_size - bias);
	     end;

	/* subtract the virtual origin */

	if ^d -> dimension.variable_virtual_origin
	then csum = csum - d -> dimension.virtual_origin;
	else do;

	     /* we must have_vsum since one of  the checked
	        bounds must be a variable */

	     call sub ((d -> dimension.virtual_origin));
	     end;

	/* If we are addressing in units of characters, the variable
	   offset may not fit in an index register (big_offset = "1"b).
	   For vsum to be placed in an index register, we must have
	   0 <= vsum <= 262143.  Since we know 0 <= csum + vsum <=
	   array_size - 1, we can derive these two conditions for the
	   use of index registers:
	   csum <= 0  AND  array_size - csum <= 262144
	   If either of these conditions is not met, vsum cannot be kept
	   in an index register. */

	if char_77_mode
	then if have_vsum
	     then if s -> symbol.variable_extents | s -> symbol.star_extents | csum > 0
		     | d -> dimension.array_size - csum > 262144
		then big_offset = "1"b;

	/* if symbol has large address, add into csum */

	if s -> symbol.large_address & ^s -> symbol.VLA
	then if char_77_mode
	     then csum = csum + (s -> symbol.location * chars_per_word);
	     else csum = csum + s -> symbol.location;

	/* create and initialize an array_ref node */

	a_ref = create_array_ref ((stack (base)));
	a = addr (rands (a_ref));
	a -> array_ref.large_offset = big_offset;

	/* Include address of parent in csum */

	if char_77_mode
	then do;
	     csum = csum + a -> array_ref.address.char_num;
	     a -> array_ref.address.char_num = mod (csum, chars_per_word);
	     if (csum < 0) & (a -> array_ref.address.char_num ^= 0)
	     then csum = divide (csum, chars_per_word, 18, 0) - 1;
	     else csum = divide (csum, chars_per_word, 18, 0);
	     end;

	if s -> symbol.VLA
	then do;

	     /* add the packed pointer to the subscript, and add the offset from the pointer
	        to the start of the array. */

	     a -> array_ref.large_offset, big_offset = "1"b;
	     csum = csum + s -> symbol.offset;		/* Add offset in block */

	     /* If code emitted, then subscript is in Q already.  So add a possible constant
	        offset, then add the packed pointer to the storage section and leave in Q. */

	     if code_emitted
	     then do;
		call add_csum;			/* add offset */
		call add_pointer (stack (base));	/* add pointer */
		end;

	     /* no code emitted - may have to load vsum then add offset and pointer. */

	     else if have_vsum			/* vsum exists */
	     then do;
		call add_csum;			/* add offset */
		call add_pointer (stack (base));	/* add pointer */
		end;

	     /* load constant and add pointer. */

	     else do;
		call load_vsum;			/* forces constant gen and load */
		call add_pointer (stack (base));
		end;
	     csum = 0;

	     if ^VLA_is_256K			/* Convert logical address to packed ptr. */
	     then do;
		unspec (inst_address) = ""b;
		inst_address.offset = VLA_words_per_seg;
		inst_address.ext_base = "1"b;
		call emit_c_a ((div), unspec (inst_address));
						/* seg to Q, word to A */
		call emit_single (als, 18 - bias);	/* word to high A */
		call emit_single (llr, 18 - bias);	/* full packed pointer in Q */
		end;

	     have_vsum = "1"b;
	     end;
	else csum = csum + a -> array_ref.address.offset;

	if have_vsum
	then call finalize_vsum ();
	else a -> array_ref.is_addressable = ^a -> array_ref.needs_pointer;

	call set_address_offset (a, (csum), (s -> symbol.element_size), (s -> symbol.units));

	/* 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. */

	a -> array_ref.large_address = a -> array_ref.large_address | s -> symbol.large_address;

	a -> array_ref.has_address = "1"b;


	/* push the final result on top of the stack */

	call push (a_ref);

	return;

add_csum:
     proc ();

	/* add csum, either through creating a constant, or through simple instruction. */
	if ^code_emitted				/* load vsum if needed */
	then call load_vsum;

	if csum = 0
	then return;

	if csum > max_fixed_bin_18 | csum < 0
	then call add (create_integer_constant ((csum)));
	else call add (csum - bias);
	return;
     end add_csum;


add_pointer:
     proc (op);

dcl  op fixed bin (18);

dcl  d ptr;
dcl  s ptr;
dcl  v ptr;

	if ^code_emitted
	then call load_vsum;

	s = addr (rands (op));
	d = addr (rands (s -> symbol.dimension));
	v = addr (rands (d -> dimension.VLA_base_addressor));
	call emit_c_a_var (adfx1, v);
	call reset_eaq (Q);				/* Value has been modified */

     end add_pointer;

make_substring:
     entry ();

	/* Emits code to compute the length and offset of a substring
	   reference.  The following stack format is expected:

	   substring parent (symbol or array_ref)
	   index of first character in substring
	   index of last character in substring

	   An array_ref node representing the substring reference is
	   filled in and pushed on the operand stack. */

dcl  (p1, p2, v) pointer;
dcl  (v_length, indx1_constant, indx2_constant) bit (1) aligned;
dcl  (substr_size, csize) fixed binary (18);
dcl  xr fixed binary (3);
dcl  (indx1_value, indx2_value) fixed binary (35);

	/* Get pointers to operands */

	p = addr (rands (stack (base)));
	p1 = addr (rands (stack (base + 1)));
	p2 = addr (rands (stack (base + 2)));

	if p1 -> node.operand_type = constant_type
	then do;
	     indx1_constant = "1"b;
	     indx1_value = addr (p1 -> constant.value) -> int_image;
	     end;
	else indx1_constant = "0"b;

	if p2 -> node.operand_type = constant_type
	then do;
	     indx2_constant = "1"b;
	     indx2_value = addr (p2 -> constant.value) -> int_image;
	     end;
	else indx2_constant = "0"b;

	/* Get address information from parent */

	if p -> node.node_type = array_ref_node
	then do;
	     have_vsum = p -> array_ref.variable_offset;
	     vsum = p -> array_ref.v_offset;
	     big_offset = p -> array_ref.large_offset;
	     s = addr (rands (p -> array_ref.parent));
	     v = addr (rands (vsum));

	     /* If temporary.dont_update was set for vsum, then it will
	        not have been stored.  We must either store it from the
	        index register which now holds it, or prevent it from
	        getting into an index register if it is still in the Q.
	        Note that storing from the index register only works
	        because EIS instruction offsets in index registers must
	        be positive. */

	     if v -> node.node_type = temporary_node
	     then if v -> temporary.not_in_storage
		then if v -> temporary.value_in.x
		     then do;
			do xr = first_index to last_index while (index_regs (xr).variable ^= vsum);
			     end;
			call emit_temp_store (stz, vsum);
			call emit_temp_store (sxl0 + xr, vsum);
			end;
		     else v -> temporary.dont_update = "0"b;
	     end;
	else do;
	     have_vsum = "0"b;
	     vsum = 0;
	     big_offset = "0"b;
	     s = p;
	     end;

	/* Do stringrange checking */

	csize = get_char_size (p);

	if cs -> subprogram.options.stringrange
	then if ^indx1_constant | ^indx2_constant
	     then do;
		call push (csize);
		call copy ((stack (base + 1)));
		call copy ((stack (base + 2)));
		call interpreter_proc (check_stringrange, r4);
r4:
		end;

	/* Check constant indices */

	if indx1_constant
	then if indx1_value <= 0 | (csize < 0 & indx1_value > csize + bias)
	     then do;
		call print_message (457, stack (base + 1), stack (base));
		go to substring_error;
		end;

	if indx2_constant
	then if indx2_value <= 0 | (csize < 0 & indx2_value > csize + bias)
	     then do;
		call print_message (457, stack (base + 2), stack (base));
		go to substring_error;
		end;

	/* Compute the length of the substring */

	if indx1_constant
	then if indx2_constant
	     then do;

		/* Both indices are constant */

		v_length = "0"b;
		substr_size = indx2_value - indx1_value + 1;
		if substr_size <= 0
		then do;
		     call print_message (460, stack (base));
		     go to substring_error;
		     end;
		end;

	     else do;

		/* Only the first index is constant */

		v_length = "1"b;
		if indx1_value = 1 & addr (rands (stack (base + 2))) -> node.node_type ^= array_ref_node
		then do;
		     code_emitted = "0"b;
		     substr_size = stack (base + 2);
		     if addr (rands (substr_size)) -> node.node_type = temporary_node
		     then addr (rands (substr_size)) -> temporary.ref_count =
			     addr (rands (substr_size)) -> temporary.ref_count + 1;

		     end;
		else do;
		     code_emitted = "1"b;
		     call load ((stack (base + 2)), in_q);
		     if indx1_value ^= 1
		     then call sub (indx1_value - 1 - bias);
		     end;
		end;

	else if indx2_constant
	then do;

	     /* Only the second index is constant */

	     v_length, code_emitted = "1"b;
	     call load (indx2_value + 1 - bias, in_q);
	     call sub ((stack (base + 1)));
	     end;

	else do;

	     /* Neither index is constant */

	     v_length, code_emitted = "1"b;
	     call load ((stack (base + 2)), in_q);
	     call sub ((stack (base + 1)));
	     call add (1 - bias);
	     end;

	/* If code was emitted to compute the length, assign a temp */

	if v_length & code_emitted
	then do;
	     substr_size = assign_temp (int_mode);
	     call in_reg (substr_size, in_q);
	     end;

	/* Now compute the offset of the substring reference */

	code_emitted = "0"b;

	csum = p -> node.address.char_num + (chars_per_word * p -> node.address.offset);

	/* Figure first character index into the offset */

	if indx1_constant
	then csum = csum + indx1_value - 1;
	else do;
	     if have_vsum
	     then call add ((stack (base + 1)));
	     else do;
		have_vsum = "1"b;
		vsum = stack (base + 1);
		end;
	     csum = csum - 1;
	     end;

	/* If parent has a large address, add in the base location */

	if p -> node.large_address
	then csum = csum + (chars_per_word * p -> node.location);

	/* Make sure the variable offset fits in an index register.
	   This is only an issue if we take a substring of an array
	   element (since the maximum offset into a scalar is
	   max_char_length - 1), there is a variable offset, and the
	   substring offset is not purely constant. */

	if p -> node.node_type = array_ref_node
	then if ^s -> symbol.variable_extents & ^s -> symbol.star_extents
	     then if have_vsum
		then if ^indx1_constant
		     then do;

			/* Derive the total constant offset due to the combined
			   substring and subscript operations. */

			cvalue = s -> symbol.address.offset;
			if s -> symbol.large_address
			then cvalue = cvalue + s -> symbol.location;
			cvalue = chars_per_word * cvalue + s -> symbol.address.char_num;
			cvalue = csum - cvalue;

			big_offset =
			     (cvalue > 0)
			     | (addr (rands (s -> symbol.dimension)) -> dimension.array_size - cvalue > 262144);
			end;

	/* Create and initialize an array_ref node */

	a_ref = create_array_ref (fixed (rel (s), 18));
	a = addr (rands (a_ref));

	a -> array_ref.variable_length = v_length;
	a -> array_ref.length = substr_size;
	a -> array_ref.large_offset = big_offset;

	/* Convert constant offset back to words */

	a -> array_ref.address.char_num = mod (csum, chars_per_word);
	if (csum < 0) & (a -> array_ref.address.char_num ^= 0)
	then csum = divide (csum, chars_per_word, 18, 0) - 1;
	else csum = divide (csum, chars_per_word, 18, 0);

	if have_vsum
	then call finalize_vsum ();
	else a -> array_ref.is_addressable = ^a -> array_ref.needs_pointer;

	if s -> node.node_type = symbol_node
	then 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 (a, (csum), (s -> symbol.element_size), (s -> symbol.units));
	     a -> array_ref.large_address = a -> array_ref.large_address | s -> symbol.large_address;
	     end;
	else do;
	     a -> node.offset = csum;
	     if s -> node.node_type = char_constant_node
	     then a -> node.units = char_units;		/* prevent m_a making a pointer */
	     end;

	a -> array_ref.has_address = "1"b;

	call push (a_ref);

	return;


substring_error:
	imac = fixed (rel (addr (fort_cg_macros_$error_macro)), 18);
	go to loop;

get_param_array_size:
     entry (sym);

	/* Figures out the size of parameter arrays of star or
	   expression extents.  Emits code to compute the array_size
	   and virtual_origin, and initializes the array descriptor. */

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;

	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;

	/* Allocate array_size */

	if ^d -> dimension.has_array_size
	then do;
	     array_size, d -> dimension.array_size = create_var (1);
	     addr (rands (array_size)) -> symbol.data_type = int_mode;
	     d -> dimension.has_array_size = "1"b;
	     d -> dimension.variable_array_size = "1"b;
	     end;
	else 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 code 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. */

			if ^d -> dimension.has_virtual_origin
			then do;
			     virtual_origin, d -> dimension.virtual_origin = create_var (1);
			     addr (rands (virtual_origin)) -> symbol.data_type = int_mode;
			     d -> dimension.has_virtual_origin = "1"b;
			     d -> dimension.variable_virtual_origin = "1"b;
			     end;
			else virtual_origin = d -> dimension.virtual_origin;

			/* Initialize the virtual origin. */

			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;

		     /* 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
		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 multipliers 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;

finalize_vsum:
     procedure ();

	/* Ensures that the variable offset is addressable or
	   in a register.  Called by finish_subscript and
	   make_substring. Uses the following variables globally:
	   code_emitted, vsum, a, big_offset */

dcl  v pointer;
dcl  i fixed binary (18);

	if code_emitted
	then do;
	     vsum = assign_temp (int_mode);
	     v = addr (rands (vsum));
	     call in_reg (vsum, in_q);
	     end;
	else do;
	     v = addr (rands (vsum));
	     if v -> node.node_type = temporary_node
	     then v -> temporary.ref_count = v -> temporary.ref_count + 1;
	     end;

	a -> array_ref.variable_offset = "1"b;
	a -> array_ref.v_offset = vsum;

	/* If the single subscript is an array reference,
	   get it into a register by temporarily pretending
	   it is the associated temp.  (explicitly call m_a
	   to prevent recursion.) */

	if v -> node.node_type = array_ref_node
	then do;
	     if big_offset
	     then do;
		i = get_eaq_name (vsum);
		if i ^= in_ia & i ^= in_q
		then call m_a (v);
		a -> array_ref.address.tag = eaq_man_load_a_or_q (v);
		if a -> array_ref.address.tag = QL_mod
		then i = in_q;
		else i = in_ia;
		vsum = assign_temp (int_mode);
		a -> array_ref.v_offset = vsum;
		call flush_ref (fixed (rel (v), 18));
		call in_reg (vsum, i);
		end;

	     else do;
		if ^v -> node.value_in.x
		then call m_a (v);
		a -> array_ref.address.tag = xr_man_load_any_xr (v);
		i = fixed (a -> array_ref.address.tag, 18) - 8;
		vsum = assign_temp (int_mode);
		a -> array_ref.v_offset, index_regs (i).variable = vsum;
		addr (rands (vsum)) -> temporary.value_in.x = "1"b;
		v -> node.value_in.x = "0"b;
		end;
	     end;

	else if ^big_offset
	then if get_eaq_name (vsum) = in_q
	     then v -> node.dont_update = "1"b;		/* really node.subs_in_q */

     end finalize_vsum;

	/* Miscellaneous code emission procedures use by finish_subscript, make_substring, and get_param_array_size */

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);				/* Value has been modified */

     end add;

load_vsum:
     procedure ();

	/* Emits code to load the variable sum into the Q */

	if ^have_vsum
	then do;
	     have_vsum = "1"b;
	     vsum = create_integer_constant ((csum));
	     csum = 0;
	     end;

	call load (vsum, in_q);
	call use_eaq (0);
	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;

	/* Bug 513: Use an indirect addressing code for referencing, when (op  + bias)
	   is greater than 262143 which is the largest 18 bit value */

	if (op + bias < 0) | (op + bias > 262143)
	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;

     end finish_subscript;

start_subscript:
     procedure ();

	/* Checks number of subscripts */

dcl  (s, d) pointer;

	s = addr (rands (stack (base)));
	d = addr (rands (s -> symbol.dimension));

	if d -> dimension.number_of_dims ^= stack (base + 1) + bias
	then do;
	     call print_message (423, stack (base));
	     call signal_error;
	     end;

     end start_subscript;

signal_error:
     procedure ();

	/* Aborts from a subscript or FLD builtin error */

	imac = fixed (rel (addr (fort_cg_macros_$abort_list)), 18);
	go to loop;

     end signal_error;

/**** ARRAY REF MANAGEMENT ****/

create_array_ref:
     procedure (sym) returns (fixed binary (18));

	/* Creates an array_ref node with sym as its parent */

dcl  (a_ref, sym, csize) fixed binary (18);
dcl  (a, s) pointer;

	if next_free_array_ref = 0
	then do;
	     a_ref = create_node (array_ref_node, size (array_ref));
	     a = addr (rands (a_ref));
	     end;
	else do;
	     a_ref = next_free_array_ref;
	     a = addr (rands (a_ref));
	     next_free_array_ref = a -> array_ref.next;
	     unspec (a -> array_ref) = "0"b;
	     a -> array_ref.node_type = array_ref_node;
	     end;


	a -> array_ref.parent = sym;
	s = addr (rands (sym));
	a -> array_ref.operand_type = array_ref_type;
	a -> array_ref.data_type = s -> symbol.data_type;
	a -> array_ref.units = s -> symbol.units;
	if s -> symbol.data_type = char_mode
	then do;
	     csize = get_char_size (s);
	     if csize > 0
	     then do;
		a -> array_ref.variable_length = "1"b;
		a -> array_ref.length = csize;
		end;
	     else a -> array_ref.length = csize + bias;
	     end;
	a -> array_ref.needs_pointer = s -> symbol.needs_pointer;
	unspec (a -> array_ref.address) = unspec (s -> symbol.address);
	a -> array_ref.reloc = s -> symbol.reloc;
	a -> array_ref.ref_count = 1;

	return (a_ref);

     end create_array_ref;

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 p -> array_ref.ref_count < 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;
		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;
		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);

	p -> array_ref.next = next_free_array_ref;
	next_free_array_ref = a_ref;

     end free_array_ref;

/**** CONCATENATION CODE ****/

start_cat:
     procedure (reallocated);

	/* Expects the stack to contain only the two 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  op (2) fixed binary (18);			/* The two operands */
dcl  csize (2) fixed binary (18);			/* Actual lengths of operands */
dcl  result fixed binary (18);			/* Result temporary (pushed on operand stack) */
dcl  asize (2) fixed binary (18);			/* Number of characters allocated to operand */
dcl  tv_offset fixed binary (14);			/* Operator offset */
dcl  i fixed binary;				/* Loop variable */

	/* Get current and allocated lengths of operands */

	do i = 1 to 2;
	     op (i) = stack (base + i - 1);
	     call get_cat_lengths (op (i), csize (i), asize (i));
	     end;

	/* If neither operand was of star extent, allocate a normal character
	   temporary and compute its length */

	if (asize (1) > 0) & (asize (2) > 0)
	then do;
	     result = assign_char_temp (asize (1) + asize (2));
	     call compute_cat_result_length (result, csize);
	     call push (result);
	     reallocated = "0"b;
	     return;
	     end;

	/* At least one of the operands was of star extent */

	reallocated = (op (1) = machine_state.last_dynamic_temp);

	if reallocated
	then tv_offset = reallocate_char_string;
	else tv_offset = allocate_char_string;

	result = assign_dynamic_temp ();
	call compute_cat_result_length (result, csize);
	call allocate_dynamic_temp (result, tv_offset);
	call push (result);

     end start_cat;

continue_cat:
     procedure ();

	/* Adds the length of the first concatenation operand into the
	   address of the result.  Expects the stack to be as start_cat
	   left it (opnd1, opnd2, result). */

dcl  (p, p1) pointer;				/* To result, opnd1 */
dcl  csize fixed binary (18);				/* Length of opnd1 */
dcl  off fixed binary (18);				/* Total char offset */
dcl  lreg bit (6) aligned;				/* Register length tag */

	p = addr (rands (stack (top)));
	p1 = addr (rands (stack (base)));

	/* Save the address of the result temporary in the global variable
	   saved_cat_address.  It will be restored when the concatenation
	   is finished by finish_cat. */

	saved_cat_address = p -> temporary.address;

	csize = get_char_size (p1);
	if csize < 0
	then do;

	     /* Length of opnd1 is constant.  Try adding length to the
	        address of the result, avoiding large address.  Note that
	        opnd1 cannot be a dynamic temp in this case. */

	     off = (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;

	     lreg = xr_man_load_const (csize + bias);
	     end;

	else if get_eaq_name (csize) > 0
	then lreg = eaq_man_load_a_or_q (addr (rands (csize)));
	else lreg = xr_man_load_any_xr (addr (rands (csize)));

	call lock_tag_register (lreg);

	p -> temporary.address.tag = p -> temporary.address.tag | lreg;

     end continue_cat;

finish_cat:
     procedure ();

	/* Restores the original address of the result temporary.  The same
	   stack format as continue_cat is expected. */

	addr (rands (stack (top))) -> temporary.address = saved_cat_address;

	call free_regs ();

     end finish_cat;

get_cat_lengths:
     procedure (opnd, actual_length, alloc_length);

	/* Gets the actual length and the allocated length for one operand.
	   The actual length is either a count or an operand offset as
	   returned by get_char_size.  The allocated length is a positive
	   integer (the length in characters), or zero if the operand is
	   of star extent. */

dcl  opnd fixed binary (18);				/* Operand offset */
dcl  actual_length fixed binary (18);			/* (Output) Real char length */
dcl  alloc_length fixed binary (18);			/* (Output) Length for allocation */

dcl  p pointer;					/* To operand */
dcl  csize fixed binary (18);				/* Character length */
dcl  psize fixed binary (18);				/* Parent's length */

	p = addr (rands (opnd));

	csize = get_char_size (p);
	if csize < 0
	then do;

	     /* Constant length */

	     actual_length = csize;
	     alloc_length = csize + bias;
	     return;
	     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;
	     psize = get_char_size (addr (rands (p -> array_ref.parent)));
	     if psize < 0
	     then do;
		actual_length = csize;
		alloc_length = psize + bias;
		return;
		end;
	     end;

	/* If the operand is a variable length temporary that is not of
	   star extent, use the allocated length of the temporary as the
	   length for allocation. */

	else if p -> node.node_type = temporary_node
	then if ^p -> temporary.stack_indirect
	     then do;
		actual_length = csize;
		alloc_length = p -> temporary.size * chars_per_word;
		return;
		end;

	/* The operand must be of star extent. */

	actual_length = csize;
	alloc_length = 0;

     end get_cat_lengths;

compute_cat_result_length:
     procedure (result, op_length);

	/* Computes the length of concatenation result, emitting code if
	   necessary, and updates the result temporary appropriately. */

dcl  result fixed binary (18);			/* Result temp */
dcl  op_length (2) fixed binary (18);			/* Operand lengths */

dcl  p pointer;					/* To result temp */
dcl  temp fixed binary (18);				/* Length temp */
dcl  op1 fixed binary (18);				/* Length of first opnd */

	p = addr (rands (result));

	if (op_length (1) < 0) & (op_length (2) < 0)
	then do;

	     /* Both operands are of constant length */

	     p -> temporary.length = (op_length (1) + bias) + (op_length (2) + bias);
	     p -> temporary.variable_length = "0"b;
	     return;
	     end;

	/* At least one of the operand lengths is non-constant.  Emit code
	   to compute the length of the result. */

	if op_length (1) < 0
	then op1 = create_integer_constant (op_length (1) + bias);
	else op1 = op_length (1);

	call load (op1, in_q);
	call use_eaq (0);
	call emit_single (adfx1, (op_length (2)));

	temp, p -> temporary.length = assign_temp (int_mode);
	call in_reg (temp, in_q);

	p -> temporary.variable_length = "1"b;

     end compute_cat_result_length;

/**** 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);

	return;

     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 array_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);
	     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);

	     /* Bug 344 - If is indirect entry manufactured by the compiler to stack then we
	        need to indirect through ITP. */

	     if p -> node.stack_indirect & ^(p -> node.node_type = symbol_node & p -> symbol.VLA)
	     then itp_list (i).mod = RI_mod;		/* RI (*n) */
	     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;

/**** FLD BUILTIN CODE ****/
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;
	     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);
	     call reserve_regs (("1"b));

	     call emit_single (lxl0, arg2);
	     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);
	     call reserve_regs (("1"b));

	     call emit_single (lxl0, arg1);
	     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);
	     call reserve_regs (("11"b));

	     call emit_single (lxl0, arg1);
	     call emit_single (lxl1, arg2);
	     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. */

dcl  i fixed binary;
dcl  (last, temp) fixed binary (18);

	cs = addr (rands (cur_subprogram));
	call get_subr_options (cs);

	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;

	ipol = cs -> subprogram.first_polish;

	do i = 1 to hbound (free_temps, 1);
	     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;


     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 character (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*(*) 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);

	/* 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 automatic,
       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 (17) aligned,
       2 limit fixed binary (17) aligned,
       2 value fixed binary (17) aligned;

dcl  single_target (10000) bit (36) aligned based (address);

dcl  double_target (10000) bit (72) aligned based (address);

dcl  char_target (10000) character (csize) aligned based (address);

dcl  char77_target (10000) character (csize) unaligned based (address);

dcl  char_overlay (0:3) character (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;

%include segname_def;

	/* 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 character (*) 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 character (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 character (*) aligned;
dcl  vname character (32) varying;

dcl  1 acc aligned based,
       2 count bit (9) unaligned,
       2 string character (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 character (*) 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 */

%include 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  text_pos fixed binary (18);

%include definition;

	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));
	     text_pos = s -> label.location;		/* a slight kludge */

	     /* fill in stack_size (must be multiple of 16) */

	     text_halfs (text_pos).left = stack_size;

	     /* generate entry definition */

	     call generate_definition (s -> symbol.name, 0, bit (text_pos, 18));

	     reloc_halfs (text_pos - 1).left = rc_dp;

	     unspec (text_halfs (text_pos - 1).left) = last_def;
	     def_ptr = addrel (def_base, last_def);

	     if assembly_list
	     then a_name (text_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 (text_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;

effective_operand:
     proc (opnd) returns (fixed bin (18));

	/*  Function to replace an operand by its effective value.  */

dcl  opnd fixed bin (18);				/* incoming operand */

dcl  op fixed bin (18);				/* outgoing operand */
dcl  p ptr;					/* pointer to symbol */

	op = opnd;
	if op > 0
	then do;
	     p = addr (rands (op));
	     if p -> node.node_type = label_node
	     then if p -> label.format
		then do;
		     op = p -> label.format_var;
		     p = addr (rands (op));
		     end;
	     if p -> node.node_type = symbol_node
	     then if p -> symbol.named_constant
		then op = p -> symbol.initial;
	     end;
	return (op);
     end effective_operand;
     end code_generator;

     end ext_code_generator;
  



		    ext_listing_generator.pl1       11/10/88  1423.0r w 11/10/88  1336.4      870264


/****^  ******************************************************
        *                                                    *
        * 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 bugs 477 and 494.
  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.
                                                   END HISTORY COMMENTS */


/* format: style3,^delnl,linecom */
ext_listing_generator:
     procedure (shared_vp, parse_vp, cg_vp);

/* Created:	7 September 1976, David Levin

   Modified:
	04 Sep 86, AG - 496: Changed display_text$display_create to display
		more information about pointers in create_entry
		structures.  Display_create now displays the number of
		pointers, the linkage/stack section offset of each pointer,
		the absolute offset from the base of the storage section
		of the pointer target and the name of the symbol the
		pointer is for.
	27 Feb 86, BW - 494: Fix display_text so it doesn't misinterpret
		data text for instruction text.
	29 July 85, HH - 477: Fix code for naming references into
		'pl1_operators_' so that unnamed offsets in the range
		of special offsets won't produce garbage comments.
	20 July 83, TO - MSCR: Create internal binoct using ioa_$rsnnl, to
		comply with MSCR acceptance.
	17 Jun 83, HH - 383: Use '#' to represent expression extent array
		bounds.
	10 May 83, RG - 174: To use csi.dirname as pathname when csi.segname is ""
	18 Mar 83, HH - Use new include file 'op_mnemonic_dcl_' to declare
		'op_mnemonic_$op_mnemonic_'.
	 3 December 1982, TO - Make length print out take into account
	     the type of units. i.e. words, bits, chars, half_words.
	16 November 1982, TO - Make display_text$display_init to output
	     formatted create_init_entry.
	 8 November 1982, TO - Move operator name processing to cover all.
	 5 October 1982, TO - Add bit offset print to symbol location.
	28 September 1982, TO - extend symbol location field for VLA.
	23 September 1982, TO - Add first parts of LA/VLA output additions.
	 2 September 1982, TO - Add "epp" check to "t" check in printing 
	     special pl1_operator_'s names in display_text.
	19 May 1982, TO - Add "symbol_name" routine to create names for 
	     code_generator generated symbols.  Add length_symbol_name to
	     return length of a symbol name.
	19 May 1982, TO - to fix potential oob in printing external refs, if
	     a bug in code generator puts unreferenced compiler generated
	     symbols there.
	5 August 1981, CRD - Fix bug 333.
	6 May 1981, CRD - Include names in headers for main programs and
	     block data subprograms.
	13 March 1981, CRD - Print * for upper bound of assumed size array.
	18 February 1981, CRD - Change print_symbols to print lower bounds
	     of arrays.
	31 July 1979, CRD - Fix bug 228, in which the listing generator blew
	     up trying to print the name of a non-existant pl1 operator.
	15 February 1978, dsl - Fix previous bug fix. Print all user symbols.
	31 January 1978, David Levin - Change to support new optimizer; fix
	     minor bugs, i.e, fault because there are no cref nodes for a
	     compiler variable.
	30 August 1977, David Levin - remove source seg limit of 64K; prevent
	     fault if -table used; print size of stack frame used by program.
	     NOTE -- value of bias changed from 65536 to 131072.
	25 March 1977, David Levin - line up cont lines; fix headers; new
	     incl files; move unreferenced common block members to unused
	     part of listing.
	9 Dec 1976, David Levin - bugs fixes; line up continuation lines; fix
	     headers; ref fort_version_info$version_name.

   END Modifications */

dcl	(shared_vp, parse_vp, cg_vp)
			pointer;

dcl	(shared_ptr, parse_ptr, cg_ptr)
			pointer;
dcl	polish_base	ptr;
dcl	operand_base	ptr;
dcl	object_base	ptr;
dcl	cref_base		ptr;
dcl	source_line_base	ptr;
dcl	listing_base	ptr;
dcl	quad_base		ptr;

dcl	1 shared_structure	aligned based (shared_ptr),
%include fort_shared_vars;

dcl	1 parse_structure	aligned based (parse_ptr),
%include fort_parse_vars;

dcl	1 cg_structure	aligned based (cg_ptr),
%include fort_cg_vars;

%include fort_options;
%include fort_system_constants;
%include fort_nodes;
%include fort_listing_nodes;
%include fort_opt_nodes;
%include compiler_source_info;
%include fortran_storage;
%include object_map;

	shared_ptr = shared_vp;
	parse_ptr = parse_vp;
	cg_ptr = cg_vp;

	polish_base = shared_structure.polish_base;
	operand_base = shared_structure.operand_base;
	object_base = shared_structure.object_base;
	cref_base = shared_structure.cref_base;
	source_line_base = shared_structure.source_line_base;
	listing_base = shared_structure.listing_base;
	if shared_structure.options.optimize
	then quad_base = shared_structure.quadruple_base;

	call listing_generator;
	return;

listing_generator:
     procedure;

dcl	FF		char (1) int static options (constant) init ("");
dcl	TB		char (1) int static options (constant) init ("	");
dcl	NL		char (1) int static options (constant) init ("
");
dcl	abs		builtin;
dcl	addr		builtin;
dcl	addrel		builtin;
dcl	binary		builtin;
dcl	bits_per_char	fixed bin (18) int static options (constant) init (9);
dcl	blk_sym		fixed bin (18);
dcl	cg_called		bit (1) aligned;
dcl	cleanup		condition;
dcl	code		fixed bin (35);
dcl	com_err_$suppress_name
			entry options (variable);
dcl	cp		ptr;
dcl	cur_subp		ptr;
dcl	current		fixed bin (18);
dcl	date_line		char (24);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	debuggin_		bit (1) aligned;
dcl	divide		builtin;
dcl	file_no		fixed bin (8);
dcl	file_no_picture	picture "(3)zb";
dcl	first		fixed bin (18);
dcl	first_char	fixed bin (21);
dcl	first_file	fixed bin (8);
dcl	first_line	fixed bin (18);
dcl	first_loc		fixed bin (18);
dcl	first_stmnt	ptr;
dcl	in_list		bit (1) aligned;
dcl	ioa_$ioa_switch	entry options (variable);
dcl	iocb		ptr;
dcl	iox_$attach_ioname	entry (char (*), ptr, char (*), fixed bin (35));
dcl	iox_$close	entry (ptr, fixed bin (35));
dcl	iox_$detach_iocb	entry (ptr, fixed bin (35));
dcl	iox_$open		entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl	last		fixed bin (18);
dcl	last_char		fixed bin (21);
dcl	last_line		fixed bin (18);
dcl	last_loc		fixed bin (18);
dcl	last_symbol	fixed bin (18);
dcl	length		builtin;
dcl	line_len		fixed bin (18);
dcl	line_no		fixed bin (17);
dcl	line_no_picture	picture "(4)z9b";
dcl	line_ptr		pointer;
dcl	loc		fixed bin (18);
dcl	looping		bit (1);
dcl	ltrim		builtin;
dcl	m		fixed bin;
dcl	map_file_no_picture picture "(3)z-";
dcl	max_line		fixed bin (18) int static options (constant) init (131);
dcl	max_number	fixed bin (18);
dcl	more_than_one	bit (1) aligned;
dcl	moved_text	bit (1) aligned;
dcl	n		fixed bin (18);
dcl	n_com		fixed bin (18);
dcl	n_ep		fixed bin (18);
dcl	n_hdr		fixed bin (18);
dcl	n_ref		fixed bin (18);
dcl	next_entry_name	fixed bin (18);
dcl	null		builtin;
dcl	numb		char (12) varying;
dcl	number_of_operands	fixed bin (18);
dcl	number_referenced	fixed bin (18);
dcl	object		(0:261119) bit (36) aligned based (object_base);
dcl	object_map_ptr	ptr;
dcl	octal_string	char (12) aligned;
dcl	old_id		bit (27) aligned;
dcl	old_moved		bit (1) aligned;
dcl	optimizing	bit (1) aligned;
dcl	output		char (4096) varying;
dcl	output_max	fixed bin (18) int static options (constant) init (4096);
dcl	output_ptr	pointer;
dcl	p		pointer;
dcl	polish		(0:261119) fixed bin (18) based (polish_base);
dcl	ptr		builtin;
dcl	quad		(0:261119) fixed bin (18) based (quad_base);
dcl	rands		(0:261119) fixed bin (18) based (operand_base);
dcl	rel_base		ptr;
dcl	rtrim		builtin;
dcl	source_node_ptr	ptr;
dcl	source_ptr	ptr;
dcl	source_seg	char (1044479) aligned based (source_ptr);
dcl	sp		ptr;
dcl	1 stmnt		like statement aligned;
dcl	string		builtin;
dcl	subp_type		fixed bin (18);
dcl	subprogram_header	char (276) varying;
dcl	subprogram_name	char (256) varying;
dcl	subprogram_type	(0:3) char (18) int static options (constant)
						/* 5 tabs, some SP, then type */
			init ("					Main Program ",
			"					  Block Data ",
			"					  Subroutine ",
			"					    Function ");
dcl	substr		builtin;
dcl	sym_info		(0:261119) fixed bin (18) based (sym_info_base);
dcl	sym_info_base	ptr;
dcl	text_length	fixed bin (17);
dcl	three_digits	picture "zz9";
dcl	title_lines	(3) char (12) int static options (constant)
			init ("Compiled by:", "Compiled on:", "    Options:");
dcl	text_pos		fixed bin (18);
dcl	unspec		builtin;
dcl	verify		builtin;
dcl	work_base		ptr;
dcl	work_string	char (12) varying;

dcl	1 symbols		(max_number) aligned structure based (work_base),
	  2 str_p		ptr unal,
	  2 offset	fixed bin (18) unal unsigned,
	  2 length	fixed bin (18) unal unsigned;

dcl	1 swap_temp	like symbols aligned;

dcl	1 text_overlay	aligned structure based (source_ptr),
	  2 pad		char (first_char) unaligned,
	  2 text		char (text_length) unaligned;

dcl	1 stack_length_overlay
			aligned based,		/* structure to obtain length of program stack frame */
	  2 stack_len	fixed bin (18) unaligned unsigned,
	  2 pad		bit (18) unaligned;

dcl	1 source_info_line	aligned,
	  2 line_id	char (9) unaligned,
	  2 sp1		char (2) unaligned,
	  2 file_id	char (3) unaligned,
	  2 sp2		char (4) unaligned,
	  2 dtm		char (16) unaligned,
	  2 sp3		char (2) unaligned,
	  2 pathname	char (168) unaligned;

dcl	full_line		char (132) unaligned;

dcl	sym_name		char (09) unaligned defined full_line position (01);
dcl	sym_type		char (20) unaligned defined full_line position (12);
dcl	sym_loc		char (08) unaligned defined full_line position (32);
dcl	sym_char		char (04) unaligned defined full_line position (40);
dcl	sym_class		char (09) unaligned defined full_line position (45);
dcl	begin_class	fixed bin (18) int static options (constant) init (44);
dcl	begin_refs	fixed bin (18) int static options (constant) init (54);

dcl	lbl_name		char (10) unaligned defined full_line position (09);
dcl	lbl_loc		char (06) unaligned defined full_line position (01);
dcl	lbl_type		char (41) unaligned defined full_line position (21);
dcl	lbl_line		char (75) unaligned defined full_line position (36);
dcl	begin_line	fixed bin (18) int static options (constant) init (35);

dcl	ep_name		char (14) unaligned defined full_line position (01);
dcl	ep_loc		char (06) unaligned defined full_line position (21);
dcl	begin_ep_attr	fixed bin (18) int static options (constant) init (30);

/* set global variables */

	source_ptr = source_info_ptr -> compiler_source_info.input_pointer;
						/* source seg base */
	debuggin_ = string (shared_structure.options.system_debugging) ^= "0"b;
						/* local copy of debugging switches */
	max_number = divide (sys_info$max_seg_size - number_of_crefs, 2, 17, 0);
						/* maximum number of operands */
	work_base = addr (cross_reference (number_of_crefs + 1));
						/* base of operand array */
	subprogram_header = NL;			/* initial value of the header */
	line_len = 0;				/* line is initially empty */
	line_ptr = addr (full_line);			/* pointer for value of the line */
	next_entry_name = first_entry_name;		/* first entry name is first valid name */
	n_hdr = 0;				/* to count number of header nodes */
	more_than_one = first_subprogram ^= last_subprogram;

/* if code generator called, must pick up some info pointers */

	if next_free_object ^= 0
	then do;
		object_map_ptr = addrel (object_base, addrel (object_base, next_free_object - 1) -> map_ptr);
		text_pos = binary (object_map_ptr -> object_map.text_length, 18);
						/* text length */

		rel_base = relocation_base;		/* base of relocation info */
		sym_info_base = addr (source_list (number_of_lines + 2));
						/* base of symbol ref info */

		cg_called = "1"b;
	     end;
	else cg_called = "0"b;

	optimizing = shared_structure.options.optimize;
	moved_text = "0"b;

	iocb = null;				/* acts as a flag for the cleanup handler */
	output = "";				/* the buffer is empty */
	output_ptr = addrel (addr (output), 1);		/* pointer to the actual value of "output" */

	on condition (cleanup)
	     call close_file;			/* ensure the file is closed */

/* open the listing segment using iox_ */

	call iox_$attach_ioname ("fort_listing_", iocb, "vfile_ " || objectname || ".list", code);
	if code ^= 0
	then goto print_and_abort;

	call iox_$open (iocb, 2, "0"b, code);		/* open for stream_output */
	if code ^= 0
	then goto print_and_abort;

/* Print compiler header information */

	call date_time_ (date_time_compiled, date_line);

/* If segname is null then dirname contains the absolute pathname of the source */
	if source_info_ptr -> compiler_source_info.segname = ""
	then call ioa_$ioa_switch (iocb, "^-COMPILATION^xLISTING^xOF^x^a^x(^a)",
		source_info_ptr -> compiler_source_info.given_ename, source_info_ptr -> compiler_source_info.dirname);
	else call ioa_$ioa_switch (iocb, "^-COMPILATION^xLISTING^xOF^x^a^x(^a>^a)",
		source_info_ptr -> compiler_source_info.given_ename, source_info_ptr -> compiler_source_info.dirname,
		source_info_ptr -> compiler_source_info.segname);
						/* source pathname */

	call ioa_$ioa_switch (iocb, "^3(^/^-^a^x^a^)", title_lines (1),
	     fort_version_info$version_name || fort_version_info$version_number,
						/* compiler version */
	     title_lines (2),
	     date_line,				/* date time compiled */
	     title_lines (3), options_string);
						/* user options */

/* if errors occured before the first subprogram node was created, move those errors to first subprogram */

	cur_listing = listing_base;
	if listing_info.first_error ^= 0
	then do;
		p = addr (listing_seg (listing_info.next));

/* chain lists together */

		addr (listing_seg (listing_info.last_error)) -> error_text.next = p -> listing_info.first_error;
		p -> listing_info.first_error = listing_info.first_error;

		listing_info.first_error = 0;
		listing_info.last_error = 0;
	     end;

/* sort the cross reference nodes */

	call sort_words;


/* LISTING LOOP starts here */

	do cur_listing = addr (listing_seg (listing_base -> listing_info.next))
	     repeat addr (listing_seg (listing_info.next)) while (cur_listing ^= listing_base);

/* get pointer to current subprogram node */

	     cur_subprogram = listing_info.subprogram;
	     cur_subp = addr (rands (cur_subprogram));
	     subp_type = cur_subp -> subprogram.subprogram_type;

/* build a header for this program unit */

	     subprogram_header = substr (subprogram_header, 1, 1);
						/* throw away previous header info */
	     subprogram_header = subprogram_header || subprogram_type (subp_type);
						/* add new info */

	     subprogram_name = addr (rands (cur_subp -> subprogram.symbol)) -> symbol.name;

	     if subp_type = subroutine | subp_type = function
	     then subprogram_header = subprogram_header || subprogram_name;
	     else if subp_type = main_program
	     then if subprogram_name ^= default_main_entry_point_name
		then subprogram_header = subprogram_header || subprogram_name;
		else ;
	     else if subp_type = block_data
	     then if subprogram_name ^= unnamed_block_data_subprg_name
		then subprogram_header = subprogram_header || subprogram_name;

	     subprogram_header = subprogram_header || NL;
	     subprogram_header = subprogram_header || NL;

	     if length (output) + length (subprogram_header) > output_max
	     then call print$buffer;
	     output = output || subprogram_header;

	     substr (subprogram_header, 1, 1) = FF;	/* in the future, header will begin a page */


/* SOURCE LISTING */

	     if optimizing
	     then first_stmnt = addr (quad (cur_subp -> subprogram.first_quad));
	     else first_stmnt = addr (polish (cur_subp -> subprogram.first_polish));

	     if get_stmnt_ptr (first_stmnt) -> statement.file > shared_structure.incl_count
	     then do;
		     call print_message (500);	/* cannot get pointer to source */
		end;

	     else do;
		     first_line = listing_info.first_line;
		     first_char = source_list (first_line).line_start;
		     first_file = source_list (first_line).file_number;

		     if listing_info.next = 0		/* the last subprogram in the compilation */
		     then last_line = number_of_lines;	/* end of segment, get everything that remains */
		     else last_line = addr (listing_seg (listing_info.next)) -> listing_info.first_line - 1;
						/* use beginning of next program unit */
		     last = source_list (last_line).line_start + source_list (last_line).line_length;

		     if shared_structure.options.has_line_numbers & (shared_structure.incl_data.incl_count = 0)
		     then do;
			     text_length = last - first_char;

/* write the text directly from the source segment */

			     if length (output) > 0
			     then call print$buffer;
			     call iox_$put_chars (iocb, addr (text), length (text), code);
			     if code ^= 0
			     then goto print_and_abort;
			     output = "";		/* buffer has been printed */
			end;

/* user did not supply line numbers so we will */

		     else do n = first_line to last_line;
			     file_no = source_list (n).file_number;
			     source_ptr = shared_structure.file_list (file_no).incl_ptr;
			     first_char = source_list (n).line_start;
			     text_length = source_list (n).line_length;
			     line_no = source_list (n).line_number_in_file;

			     if length (output) + text_length + 11 > output_max
			     then call print$buffer;

			     file_no_picture = file_no;
			     output = output || file_no_picture;

			     if ^shared_structure.has_line_numbers
			     then do;
				     line_no_picture = line_no;
				     output = output || line_no_picture;
				end;

			     output = output || text;
			end;

/* if last char is not a newline, add one */

		     if substr (source_seg, last, 1) ^= NL
		     then do;
			     if length (output) = output_max
			     then call print$buffer;
			     output = output || NL;
			end;
		end;				/* code to print the source */


/* REFERENCED SYMBOLS */

	     if length (output) + length (subprogram_header) + 111 > output_max
	     then call print$buffer;

	     output = output || subprogram_header;

/* current length of this string is 111 characters */

	     output =
		output
		||
		"	NAMES USED IN THIS PROGRAM UNIT

NAME       TYPE OF NAME        LOC          STORAGE   ATTRIBUTES AND REFERENCES

"
		;

	     number_of_operands = 0;
	     number_referenced = 0;
	     last_symbol = 0;

/* get entry point symbols for this subprogram */

	     do while (next_entry_name ^= 0 & addr (rands (next_entry_name)) -> symbol.parent = cur_subprogram);
		call store_item (next_entry_name);
		next_entry_name = addr (rands (next_entry_name)) -> symbol.next_symbol;
						/* get next name */
	     end;

/* get the rest of the names */

	     if cg_called
	     then do;
		     do n = 1 to 11;		/* loop thru the symbol buckets */
			call walk_bucket (n);
		     end;
		     do n = 13 to 17;		/* loop thru LA/VLA buckets */
			call walk_bucket (n);
		     end;

		     number_referenced = number_of_operands;
						/* separate the two types */

		     call walk_bucket (12);		/* get unreferenced symbols */
		end;

	     else do;
		     do current = cur_subp -> subprogram.first_symbol
			repeat addr (rands (current)) -> symbol.next_symbol while (current ^= 0);
			call store_item (current);
		     end;

		     do current = cur_subp -> subprogram.common_chain
			repeat addr (rands (current)) -> header.next_header while (current ^= 0);
			call store_item (current);
		     end;

		     do current = cur_subp -> subprogram.LA_chain
			repeat addr (rands (current)) -> header.next_header while (current ^= 0);
			call store_item (current);
		     end;

		     do current = cur_subp -> subprogram.VLA_chain
			repeat addr (rands (current)) -> header.next_header while (current ^= 0);
			call store_item (current);
		     end;

		     number_referenced = number_of_operands;
		end;

	     last_symbol = number_of_operands;

/* move all unreferenced but allocated symbols to unused list */

	     do n = number_referenced to 1 by -1;

		sp = addr (rands (symbols (n).offset)); /* get pointer to list item */

		if sp -> node.node_type = symbol_node & ^sp -> symbol.referenced
		then do;				/* unused symbol */
			if n ^= number_referenced
			then do;			/* swap into the other list */
				swap_temp = symbols (n);
				symbols (n) = symbols (number_referenced);
				symbols (number_referenced) = swap_temp;
			     end;

			number_referenced = number_referenced - 1;
		     end;
	     end;

/* get all labels */

	     do current = cur_subp -> subprogram.first_label repeat addr (rands (current)) -> label.next_label
		while (current ^= 0);
		call store_item (current);
	     end;

/* link up cref node with appropriate operand nodes */

	     last = 0;				/* current node offset */

	     do current = listing_info.first_cref to listing_info.last_cref;
						/* crefs for the subr */

		if cross_reference (current).symbol ^= last
						/* cref for another operand node */
		then do;
			if last ^= 0
			then cross_reference (first).symbol = current - 1;
			first = current;		/* first cref for this item */
			last = cross_reference (current).symbol;
			sp = addr (rands (last));

			if sp -> node.node_type = symbol_node | sp -> node.node_type = label_node
			then sp -> node.hash_chain = current;

			else if sp -> node.node_type = header_node
			then sp -> header.last_element = current;

			else call print_message (502, last);
		     end;
	     end;

	     if last ^= 0
	     then cross_reference (first).symbol = listing_info.last_cref;

/* output referenced names and attributes */

	     call sort_symbols (1, number_referenced);
	     call print_symbols (1, number_referenced, "ref");


/* UNUSED SYMBOLS */

	     if last_symbol - number_referenced > 0
	     then do;
		     if length (output) + 30 > output_max
		     then call print$buffer;

		     output = output || "
NAMES DECLARED BUT NOT USED

";

		     call sort_symbols (number_referenced + 1, last_symbol);
		     call print_symbols (number_referenced + 1, last_symbol, "declared");
		end;


/* LABELS */

	     if number_of_operands - last_symbol > 0
	     then do;
		     if length (output) + 63 > output_max
		     then call print$buffer;

		     output = output || "
LOC          LABEL  TYPE           LINE           REFERENCES

";

		     call sort_symbols (last_symbol + 1, number_of_operands);
		     call print_symbols (last_symbol + 1, number_of_operands, "ref");
		end;


/* STATEMENT MAP */

	     if cg_called
	     then do;
		     if length (output) + 227 > output_max
		     then call print$buffer;		/* length (header) + 7*16 + 1 */

		     output =
			output
			||
			"
       LINE   LOC        LINE   LOC        LINE   LOC        LINE   LOC        LINE   LOC        LINE   LOC

"
			;

		     old_id = (27)"1"b;		/* print one entry per unique source_id */
		     line_len = 0;			/* line is empty */
		     in_list = "1"b;
		     do sp = first_stmnt repeat p while (in_list);

			sp = get_stmnt_ptr (sp);

			if sp -> statement.next = "0"b
			then in_list = "0"b;
			else p = ptr (first_stmnt, sp -> statement.next);

			if sp -> statement.put_in_map & ^moved_text
			then if unspec (sp -> statement.source_id) ^= old_id
			     then do;
				     old_id = unspec (sp -> statement.source_id);

				     if line_len = 108
						/* six per line; 6*18 = 108 */
				     then do;
					     output = output || NL;
					     line_len = 0;
					     if length (output) + 109 > output_max
					     then call print$buffer;
					end;

				     line_no_picture = binary (sp -> statement.line, 14);
				     map_file_no_picture = -sp -> statement.file;
				     work_string =
					substr ("           ", 1, 8 - length (ltrim (line_no_picture)));
				     work_string = work_string || map_file_no_picture;
				     work_string = work_string || ltrim (line_no_picture);

				     output = output || work_string;

				     call binoct (unspec (sp -> statement.location), octal_string);
				     output = output || substr (octal_string, 1, 6);

				     line_len = line_len + 18;
				end;
		     end;

		     if line_len > 0
		     then output = output || NL;
		end;


/* ERROR MESSAGES */

	     do current = listing_info.first_error repeat p -> error_text.next while (current ^= 0);
		p = addr (listing_seg (current));

		if length (output) + length (p -> error_text.string) > output_max
		then call print$buffer;

		output = output || p -> error_text.string;
	     end;


/* OBJECT LISTING */

	     if shared_structure.options.list & cg_called /* must be requested and available */
	     then do;
		     if length (output) + 16 > output_max
		     then call print$buffer;

		     output = output || "


OBJECT CODE

";

/* print any words left over from the last subprogram */

		     p = get_stmnt_ptr (first_stmnt);
		     first_loc = binary (p -> statement.location, 18);

		     old_id = (27)"1"b;		/* print one header per unique source_id */
		     old_moved = "0"b;
		     in_list = "1"b;
		     do sp = first_stmnt repeat p while (in_list);

			sp = get_stmnt_ptr (sp);

			if sp -> statement.next = "0"b
			then do;
				in_list = "0"b;
				last_loc = -1;
			     end;
			else do;
				p = ptr (first_stmnt, sp -> statement.next);
				if optimizing
				then last_loc = binary (p -> opt_statement.location, 18) - 1;
				else last_loc = binary (p -> statement.location, 18) - 1;
			     end;

			if sp -> statement.put_in_map & (^moved_text | last_loc >= first_loc)
			then do;

/* print statement header if it's unique */

				if unspec (sp -> statement.source_id) ^= old_id | (old_moved ^= moved_text)
				then do;
					old_id = unspec (sp -> statement.source_id);
					old_moved = moved_text;

					if length (output) + max_line > output_max
					then call print$buffer;

					output =
					     output
					     || "						 ";

					if moved_text
					then output = output || "EXTRACTED FROM STATEMENT ";
					else output = output || "STATEMENT ";
					output = output || print_number (binary (sp -> statement.statement, 5));

					output = output || " ON LINE ";
					output = output || print_number (binary (sp -> statement.line, 14));

					if sp -> statement.file ^= 0
					then do;
						output = output || " IN FILE ";
						output =
						     output || print_number (binary (sp -> statement.file));
					     end;

					output = output || NL;

/* print source line */

					if sp -> statement.length ^= "000000000"b
					then do;
						first_char = sp -> statement.start;
						last_char =
						     first_char + binary (sp -> statement.length, 9) - 1;
						text_length = last_char - first_char;

						if length (output) + text_length + 2 > output_max
						then call print$buffer;
						source_ptr =
						     shared_structure.file_list (sp -> statement.file)
						     .incl_ptr;
						output = output || text;
						if substr (source_seg, last_char, 1) ^= NL
						then output = output || NL;
						output = output || NL;
					     end;
				     end;

/* print object code */

				if last_loc >= first_loc
				then do;
					call display_text (first_loc, last_loc);
					first_loc = last_loc + 1;
				     end;
			     end;
		     end;				/* loop through statements */
		end;				/* do block to print object code */

	end;					/* LISTING LOOP */

/* print constants */

	if shared_structure.options.list & cg_called
	then do;
		in_list = "0"b;			/* header has not been printed */

		do current = first_dw_constant repeat sp -> constant.next_constant while (current ^= 0);
		     sp = addr (rands (current));

		     if sp -> constant.allocated
		     then do;
			     call print_header;

			     if length (output) = output_max
			     then call print$buffer;
			     output = output || NL;
			     call display_text$display_abs ((sp -> constant.location), sp -> constant.location + 1);
			end;
		end;

		do current = first_word_constant repeat sp -> constant.next_constant while (current ^= 0);
		     sp = addr (rands (current));

		     if sp -> constant.allocated
		     then do;
			     call print_header;

			     if length (output) = output_max
			     then call print$buffer;
			     output = output || NL;
			     call display_text$display_abs ((sp -> constant.location), (sp -> constant.location));
			end;
		end;

		do current = first_char_constant repeat sp -> char_constant.next_constant while (current ^= 0);
		     sp = addr (rands (current));

		     if sp -> constant.allocated
		     then do;
			     call print_header;

			     if length (output) = output_max
			     then call print$buffer;
			     output = output || NL;
			     call display_text$display_ascii ((sp -> char_constant.location),
				length (sp -> char_constant.value));
			end;
		end;

		do current = first_block_constant repeat sp -> char_constant.next_constant while (current ^= 0);
		     sp = addr (rands (current));

		     if sp -> constant.allocated
		     then do;
			     call print_header;

			     if length (output) = output_max
			     then call print$buffer;
			     output = output || NL;

			     first_loc = sp -> char_constant.location;
			     last_loc =
				first_loc
				+ divide (length (sp -> char_constant.value) - 1, chars_per_word, 17, 0);
			     call display_text$display_abs (first_loc, last_loc);
			end;
		end;

/* output Creation List */

		looping = "1"b;
		if Area_create_first ^= -1
		then do;
			if length (output) + 23 > output_max
			then call print$buffer;
			output = output || "
STORAGE CREATION LIST

";

			do current = Area_create_first repeat cp -> create_entry.next while (looping);
			     cp = ptr (object_base, current);
			     first_loc = current;
			     last_loc = current + currentsize (cp -> create_entry) - 1;
			     call display_text$display_create (first_loc, last_loc, cp);

			     if cp -> create_entry.init
			     then call display_text$display_init (addrel (cp, currentsize (cp -> create_entry)));

			     if length (output) + 1 > output_max
			     then call print$buffer;
			     output = output || "
";
			     if cp -> create_entry.next = 0
			     then looping = "0"b;
			end;
		     end;

/* output Initialization List */

		if Area_init_first ^= -1
		then do;
			if length (output) + 30 > output_max
			then call print$buffer;
			output = output || "
STORAGE INITIALIZATION LIST

";

			current = Area_init_first;

			cp = ptr (object_base, current);
			call display_text$display_init (cp);
		     end;
	     end;

/* flush the buffer */

	if length (output) > 0
	then call print$buffer;

/* print summary for segment */

	if cg_called
	then do;
		call ioa_$ioa_switch (iocb,
						/* stream ptr */
		     "^|^a^2/^a^/
^-Object^-Text^-Link^-Symbol^-Defs^-Static
Start^10x0^7x0^10o^12o^8o^12o
Length^10o^8o^10o^12o^8o^12o^/"
		     , "OBJECT SEGMENT SUMMARY",	/* first header */
		     "STORAGE REQUIREMENTS FOR THIS PROGRAM",
						/* second header */
		     binary (object_map_ptr -> linkage_offset, 18),
						/* linkage start */
		     binary (object_map_ptr -> symbol_offset, 18),
						/* symbol start */
		     binary (object_map_ptr -> definition_offset, 18),
						/* def start */
		     binary (object_map_ptr -> static_offset, 18),
						/* static start */
		     next_free_object,
						/* object length */
		     text_pos,			/* text length */
		     binary (object_map_ptr -> linkage_length, 18),
						/* linkage length */
		     binary (object_map_ptr -> symbol_length, 18),
						/* symbol length */
		     binary (object_map_ptr -> definition_length, 18),
						/* def length */
		     binary (object_map_ptr -> static_length, 18));
						/* static length */
		output = "";			/* buffer has been printed */


/* print length of the program stack frame */

		call ioa_$ioa_switch (iocb, "Stack frame is ^d (decimal) words.^/",
		     addr (object (addr (rands (first_entry_name)) -> label.location)) -> stack_len);

/* summary of external references, entry point references, and common block references */

		n_ep = 0;				/* counts entry points */

/* entry points */

		do n = first_entry_name repeat sp -> symbol.next_symbol while (n ^= 0);
		     sp = addr (rands (n));

		     n_ep = n_ep + 1;
		     symbols (n_ep).offset = n;
		     symbols (n_ep).length = length (sp -> symbol.name);
		     symbols (n_ep).str_p = addr (sp -> symbol.name);
		end;

/* common blocks and outgoing references */

		n_com = n_ep;			/* common list immediately follows ep list */
		n_ref = n_ep + n_hdr;		/* ext ref list immediately follows common */

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

		     do m = 9, 17;
			do n = addr (rands (current)) -> subprogram.storage_info.first (m)
			     repeat addr (rands (n)) -> node.next while (n ^= 0);

			     if addr (rands (n)) -> node.node_type = symbol_node
			     then do;
				     n_ref = n_ref + 1;
				     symbols (n_ref).offset = n;
				     symbols (n_ref).length = length_symbol_name (addr (rands (n)));
				     symbols (n_ref).str_p = addr (addr (rands (n)) -> symbol.name);
				     addr (rands (n)) -> symbol.parent = current;
						/* save parent block */
				end;
			     else do;
				     n_com = n_com + 1;
				     symbols (n_com).offset = n;
				     symbols (n_com).length = length (addr (rands (n)) -> header.block_name);
				     symbols (n_com).str_p = addr (addr (rands (n)) -> header.block_name);
				end;
			end;
		     end;
		end;

/* sort the three groups */

		call sort_symbols (1, n_ep);
		call sort_offset (1, n_ep);

		call sort_symbols (n_ep + 1, n_com);
		call sort_offset (n_ep + 1, n_com);

		n = n_ep + n_hdr + 1;
		call sort_symbols (n, n_ref);
		call sort_offset (n, n_ref);

/* print entry point symbols and any ext refs resolved by them */

		if length (output) + 43 > output_max
		then call print$buffer;
		output = output || "
ENTRY POINT         LOC       ATTRIBUTES

";
		first = n;

		do current = 1 to n_ep;
		     sp = addr (rands (symbols (current).offset));

		     full_line = "";
		     line_len = begin_ep_attr - 1;

		     if length_symbol_name (sp) > length (ep_name)
		     then call print$long_name (begin_ep_attr, 0, (symbol_name (sp)));
		     else ep_name = symbol_name (sp);

		     loc = sp -> symbol.address.offset;
		     call binoct (unspec (loc), octal_string);
		     ep_loc = substr (octal_string, 7, 6);

		     blk_sym = addr (rands (sp -> symbol.parent)) -> subprogram.symbol;

		     if blk_sym ^= symbols (current).offset & more_than_one
		     then do;
			     substr (full_line, line_len + 2, 2) = "in";
			     line_len = line_len + 4;

			     if length_symbol_name (addr (rands (blk_sym))) > max_line - line_len
			     then call print$long_name (begin_ep_attr, line_len,
				     (symbol_name (addr (rands (blk_sym)))));
			     else do;
				     loc = length_symbol_name (addr (rands (blk_sym)));
				     substr (full_line, line_len + 1, loc) = symbol_name (addr (rands (blk_sym)));
				     line_len = line_len + loc;
				end;
			end;

		     numb = print_line_number ((sp -> symbol.hash_chain));
		     if line_len + length (numb) + 9 > max_line
		     then call print$line (begin_ep_attr);
		     substr (full_line, line_len + 2, 7) = "on line";
		     substr (full_line, line_len + 10, length (numb)) = numb;
		     line_len = line_len + length (numb) + 9;

		     do while (first <= n_ref
			& symbol_name (sp) > symbol_name (addr (rands (symbols (first).offset))));
			first = first + 1;
		     end;

		     do while (first <= n_ref
			& symbol_name (sp) = symbol_name (addr (rands (symbols (first).offset))));
			if addr (rands (symbols (first).offset)) -> symbol.initial = symbols (current).offset
			then do;
				loc = symbols (first).offset;
				symbols (first).offset = 0;

				blk_sym = addr (rands (addr (rands (loc)) -> symbol.parent)) -> subprogram.symbol;
				last = length_symbol_name (addr (rands (blk_sym)));

				if line_len + 9 + last > max_line
				then call print$line (begin_ep_attr);
				substr (full_line, line_len + 2, 6) = "ref in";
				substr (full_line, line_len + 9, last) = addr (rands (blk_sym)) -> symbol.name;
				line_len = line_len + 9 + last;

				loc = addr (rands (loc)) -> symbol.hash_chain;
				if loc > 0	/* protect unreferenced */
				then do;
					last = cross_reference (loc).symbol;
					call print_crefs (loc, last, begin_ep_attr, "");
				     end;
			     end;

			first = first + 1;
		     end;

		     call print$line (begin_ep_attr);
		end;

/* print external references */

		do first = n_ep + n_hdr + 1 to n_ref while (symbols (first).offset = 0);
		end;

		if first <= n_ref
		then do;
			if length (output) + 43 > output_max
			then call print$buffer;
			output = output || "
EXTERNAL REFERENCE  LOC       ATTRIBUTES

";
			last_loc = -1;

			do current = first to n_ref;
			     if symbols (current).offset > 0
			     then do;
				     sp = addr (rands (symbols (current).offset));

				     full_line = "";
				     line_len = begin_ep_attr - 1;

				     loc = sp -> symbol.address.offset;

				     if loc ^= last_loc
				     then do;
					     last_loc = loc;

					     if length_symbol_name (sp) > length (ep_name)
					     then call print$long_name (begin_ep_attr, 0, (symbol_name (sp)));
					     else ep_name = symbol_name (sp);

					     call binoct (unspec (loc), octal_string);
					     ep_loc = substr (octal_string, 7, 6);
					end;

				     if more_than_one
				     then do;
					     substr (full_line, line_len + 2, 2) = "in";
					     line_len = line_len + 4;

					     blk_sym = addr (rands (sp -> symbol.parent)) -> subprogram.symbol;
					     if length_symbol_name (addr (rands (blk_sym)))
						> max_line - line_len
					     then call print$long_name (begin_ep_attr, line_len,
						     (symbol_name (addr (rands (blk_sym)))));
					     else do;
						     loc = length_symbol_name (addr (rands (blk_sym)));
						     substr (full_line, line_len + 1, loc) =
							symbol_name (addr (rands (blk_sym)));
						     line_len = line_len + loc;
						end;
					end;

				     loc = sp -> symbol.hash_chain;

				     if loc > 0	/* protect if unreffed */
				     then do;
					     last = cross_reference (loc).symbol;
					     call print_crefs (loc, last, begin_ep_attr, "ref");
					end;

				     call print$line (begin_ep_attr);
				end;
			end;
		     end;
		else do;
			if length (output) + 24 > output_max
			then call print$buffer;
			output = output || "
NO EXTERNAL REFERENCES
";
		     end;

		if n_com = n_ep
		then do;
			if length (output) + 18 > output_max
			then call print$buffer;
			output = output || "
NO COMMON BLOCKS
";
		     end;
		else do;
			if length (output) + 50 > output_max
			then call print$buffer;
			output = output || "
COMMON BLOCK        LOC      LENGTH  REFERENCES

";
			n = -1;			/* location of last block */

			do current = n_ep + 1 to n_com;
			     sp = addr (rands (symbols (current).offset));

			     full_line = "";
			     line_len = begin_ep_attr - 1;
			     loc = sp -> header.location;

			     if loc ^= n
			     then do;
				     if length (sp -> header.block_name) > length (ep_name)
				     then call print$long_name (begin_ep_attr, 0, (sp -> header.block_name));
				     else ep_name = sp -> header.block_name;

				     call binoct (unspec (loc), octal_string);
				     ep_loc = substr (octal_string, 7, 6);

				     n = loc;
				end;

			     numb = print_number ((sp -> header.length));
			     if sp -> header.units = bit_units
			     then numb = numb || "B";
			     else if sp -> header.units = char_units
			     then numb = numb || "C";
			     else if sp -> header.units = halfword_units
			     then numb = numb || "H";

			     substr (full_line, begin_ep_attr + 6 - length (numb), length (numb)) = numb;
			     line_len = begin_ep_attr + 6;

			     loc = sp -> header.last_element;
			     last = cross_reference (loc).symbol;
			     call print_crefs (loc, last, begin_ep_attr + 6, "declared");

			     call print$line (begin_ep_attr);
			end;
		     end;
	     end;

	if length (output) + 87 > output_max
	then call print$buffer;

	output = output || FF;
	output = output || "	SOURCE FILES USED IN THIS COMPILATION

LINE      NUMBER   DATE MODIFIED    PATHNAME

";

	do m = 0 to shared_structure.incl_count;
	     string (source_info_line) = "";
	     source_node_ptr = addr (rands (shared_structure.file_list (m).source_node_offset));

	     if m > 0
	     then do;

		     line_no_picture = source_list (source_node_ptr -> source.line_number).line_number_in_file;
		     map_file_no_picture = -source_list (source_node_ptr -> source.line_number).file_number;
		     source_info_line.line_id = ltrim (map_file_no_picture) || ltrim (line_no_picture);

		end;

	     three_digits = m;			/* known to take three digits at most */
	     source_info_line.file_id = three_digits;

	     call date_time_ ((source_node_ptr -> source.dtm), source_info_line.dtm);
	     source_info_line.pathname = source_node_ptr -> source.pathname;

	     if length (output) + length (rtrim (string (source_info_line))) + 1 > output_max
	     then call print$buffer;

	     output = output || rtrim (string (source_info_line));
	     output = output || NL;

	end;

	call close_file;
	return;


print_and_abort:
	call com_err_$suppress_name (code, "fort_listing_generator");
	call close_file;
	return;

close_file:
     procedure;

	if length (output) > 0
	then call iox_$put_chars (iocb, output_ptr, length (output), code);

	if iocb ^= null
	then call iox_$close (iocb, code);

	if iocb ^= null
	then call iox_$detach_iocb (iocb, code);
     end close_file;


get_stmnt_ptr:
     proc (a_ptr) returns (ptr);

dcl	a_ptr		ptr;
dcl	st_ptr		ptr;

	if optimizing
	then do;
		st_ptr = a_ptr;

		stmnt.next = st_ptr -> opt_statement.next;
		stmnt.location = st_ptr -> opt_statement.location;
		unspec (stmnt.source_id) = unspec (st_ptr -> opt_statement.source_id);
		stmnt.length = st_ptr -> opt_statement.length;
		substr (string (stmnt.bits), 1, 2) = substr (string (st_ptr -> opt_statement.bits), 1, 2);
		stmnt.start = st_ptr -> opt_statement.start;

		moved_text = st_ptr -> opt_statement.moved;

		return (addr (stmnt));
	     end;
	else return (a_ptr);
     end get_stmnt_ptr;


sort_offset:
     procedure (sr, fi);

dcl	(sr, fi)		fixed bin (18);
dcl	(i, fir)		fixed bin (18);
dcl	old_str		char (symbols (fir).length) aligned based (symbols (fir).str_p);
dcl	new_str		char (symbols (i).length) aligned based (symbols (i).str_p);

	fir = sr;
	do i = sr + 1 to fi;
	     if old_str ^= new_str
	     then do;
		     call simple_sort (i - 1);
		     fir = i;
		end;
	end;

	call simple_sort (fi);
	return;


simple_sort:
     procedure (last_slot);

dcl	last_slot		fixed bin (18);
dcl	(j, k)		fixed bin (18);

	do j = fir to last_slot - 1;
	     do k = j + 1 to last_slot;
		if symbols (j).offset > symbols (k).offset
		then do;
			swap_temp = symbols (j);
			symbols (j) = symbols (k);
			symbols (k) = swap_temp;
		     end;
	     end;
	end;
     end simple_sort;
     end sort_offset;


print_header:
     procedure;					/* to print header for constants */

	if in_list
	then return;				/* header already printed */
	in_list = "1"b;

	if length (output) + 11 > output_max
	then call print$buffer;

	if more_than_one
	then output = output || FF;
	else output = output || NL;

	output = output || "CONSTANTS
";
     end print_header;

print$buffer:
     procedure;

dcl	leading_columns	fixed bin (18);
dcl	resumption_column	fixed bin (18);
dcl	long_name		char (256) varying;

	call printer;
	return;


print$line:
     entry (resumption_column);

	if length (output) + line_len >= output_max
	then call printer;
	output = output || substr (full_line, 1, line_len);
	output = output || NL;
	full_line = "";
	line_len = resumption_column - 1;
	return;


print$long_name:
     entry (resumption_column, leading_columns, long_name);

	if length (output) + leading_columns + length (long_name) >= output_max
	then call printer;
	if leading_columns > 0
	then output = output || substr (full_line, 1, leading_columns);
	output = output || long_name;
	output = output || NL;
	full_line = "";
	line_len = resumption_column - 1;
	return;


printer:
     procedure;

	call iox_$put_chars (iocb, output_ptr, length (output), code);
	if code ^= 0
	then goto print_and_abort;
	output = "";
     end printer;
     end print$buffer;

print_number:
     procedure (value) returns (char (12) varying);

dcl	number		picture "(11)-9";
dcl	value		fixed bin (18);


	number = value;

	return (substr (number, verify (number, " ")));
     end print_number;

print_line_number:
     procedure (source_info_index) returns (char (12) varying);

dcl	source_info_index	fixed bin (18);
dcl	cref_file		fixed bin (18);
dcl	cref_line		fixed bin (18);
dcl	return_string	char (12) varying initial ("");

	if cross_reference (source_info_index).line_no = 0
	then return ("");

	cref_line = source_list (abs (cross_reference (source_info_index).line_no)).line_number_in_file;

	if cref_line > 0
	then do;
		cref_file = source_list (abs (cross_reference (source_info_index).line_no)).file_number;

		if cref_file > 0
		then return_string = print_number (cref_file) || "-";

		return_string = return_string || print_number (cref_line);
	     end;

	return (return_string);
     end print_line_number;

walk_bucket:
     procedure (bucket_number);

dcl	bucket_number	fixed bin (18);
dcl	i		fixed bin (18);
dcl	n		fixed bin (18);

	n = bucket_number;

	do current = cur_subp -> subprogram.storage_info.first (n) repeat sp -> node.next while (current ^= 0);

	     sp = addr (rands (current));

	     if sp -> node.node_type = symbol_node
	     then call store_item (current);

	     else if sp -> node.node_type = header_node
	     then do;
		     if sp -> header.in_common
		     then call store_item (current);

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

	     else call print_message (502, current);
	end;
     end walk_bucket;

store_item:
     procedure (node_offset);

dcl	node_offset	fixed bin (18);
dcl	x		fixed bin (18);
dcl	xp		ptr;

	if number_of_operands >= max_number
	then do;
		call print_message (501);		/* too many symbols */

		if last_symbol = 0			/* still doing symbols */
		then do;
			call sort_symbols (1, number_of_operands);
			call print_symbols (1, number_of_operands, "ref");

			number_of_operands = 0;
			number_referenced = 0;
		     end;

		else do;				/* have both symbols and labels */
			call sort_symbols (1, last_symbol);
						/* sort and print all symbols */
			call print_symbols (1, number_referenced, "ref");

			do n = 1 to number_of_operands - last_symbol;
						/* remove all symbols from the list */
			     symbols (n) = symbols (n + last_symbol);
			end;

			number_of_operands = number_of_operands - last_symbol;
			number_referenced = 0;
			last_symbol = 0;
		     end;
	     end;

	x = node_offset;
	xp = addr (rands (x));

	if xp -> node.node_type = symbol_node
	then do;
		if compiler_generated (xp)
		then return;

		number_of_operands = number_of_operands + 1;
		symbols (number_of_operands).offset = x;
		symbols (number_of_operands).length = length_symbol_name (xp);
		symbols (number_of_operands).str_p = addr (xp -> symbol.name);

		xp -> symbol.hash_chain = 0;		/* prevents bad cref output */
	     end;

	else if xp -> node.node_type = label_node
	then do;
		if xp -> label.name <= 0 & ^debuggin_
		then return;			/* eliminate compiler labels */

		number_of_operands = number_of_operands + 1;
		symbols (number_of_operands).offset = x;
		symbols (number_of_operands).length = 2;
		symbols (number_of_operands).str_p = addr (xp -> label.name);

		xp -> label.hash_chain = 0;		/* prevent bad cref output */
	     end;

	else if xp -> node.node_type = header_node
	then do;
		n_hdr = n_hdr + 1;			/* count all headers */
		number_of_operands = number_of_operands + 1;
		symbols (number_of_operands).offset = x;
		symbols (number_of_operands).length = xp -> header.name_length;
		symbols (number_of_operands).str_p = addr (xp -> header.block_name);

		xp -> header.last_element = 0;	/* prevent bad cref output */
	     end;

	else call print_message (502, x);
     end store_item;


compiler_generated:
     proc (sp) returns (bit (1) aligned);

dcl	sp		ptr;

	if debuggin_
	then return ("0"b);				/* Print all symbols when debugging. */
	if length (sp -> symbol.name) = 0
	then return ("1"b);				/* A cg symbol. */
	if substr (sp -> symbol.name, 1, 4) = "ftn."
	then return ("1"b);				/* A parse symbol. */
	if sp -> symbol.by_compiler
	then if sp -> symbol.name = unnamed_block_data_subprg_name
	     then return ("1"b);
	return ("0"b);
     end compiler_generated;

sort_words:
     procedure;

dcl	depth		fixed bin (18);
dcl	divide		builtin;
dcl	first		fixed bin (18);
dcl	high		fixed bin (18);
dcl	last		fixed bin (18);
dcl	low		fixed bin (18);
dcl	median		fixed bin (18);
dcl	swap_temp		bit (36) aligned;
dcl	t		bit (36) aligned;

dcl	1 stack		(0:20) aligned,
	  2 first		fixed bin (18),
	  2 last		fixed bin (18);


	last = number_of_crefs;
	if last <= 1
	then return;

	depth = 0;
	first = 1;
	go to L4;


L1:
	median = divide (first + last, 2, 17, 0);
	t = unspec (cross_reference (median));
	low = first;
	high = last;

	if unspec (cross_reference (first)) > t
	then do;
		unspec (cross_reference (median)) = unspec (cross_reference (first));
		unspec (cross_reference (first)) = t;
		t = unspec (cross_reference (median));
	     end;

	if unspec (cross_reference (last)) < t
	then do;
		unspec (cross_reference (median)) = unspec (cross_reference (last));
		unspec (cross_reference (last)) = t;
		t = unspec (cross_reference (median));

		if unspec (cross_reference (first)) > t
		then do;
			unspec (cross_reference (median)) = unspec (cross_reference (first));
			unspec (cross_reference (first)) = t;
			t = unspec (cross_reference (median));
		     end;

	     end;

L2:
	do high = high - 1 by -1 while (unspec (cross_reference (high)) > t);
	end;

	do low = low + 1 by 1 while (unspec (cross_reference (low)) < t);
	end;

	if low <= high
	then do;
		swap_temp = unspec (cross_reference (high));
		unspec (cross_reference (high)) = unspec (cross_reference (low));
		unspec (cross_reference (low)) = swap_temp;
		go to L2;
	     end;

	if (high - first) > (last - low)
	then do;
		stack.first (depth) = first;
		stack.last (depth) = high;
		first = low;
	     end;

	else do;
		stack.first (depth) = low;
		stack.last (depth) = last;
		last = high;
	     end;

	depth = depth + 1;

L4:
	if (last - first) > 10
	then go to L1;

	if first = 1
	then if first < last
	     then go to L1;

	do first = first + 1 to last;
	     t = unspec (cross_reference (first));
	     do low = first - 1 by -1 while (unspec (cross_reference (low)) > t);
		unspec (cross_reference (low + 1)) = unspec (cross_reference (low));
	     end;
	     unspec (cross_reference (low + 1)) = t;
	end;


	depth = depth - 1;

	if depth >= 0
	then do;
		first = stack.first (depth);
		last = stack.last (depth);
		go to L4;
	     end;
     end sort_words;

sort_symbols:
     procedure (a_initial, a_final);

dcl	a_final		fixed bin (18);
dcl	a_initial		fixed bin (18);
dcl	depth		fixed bin (18);
dcl	first		fixed bin (18);
dcl	first_string	char (symbols (first).length) unaligned based (symbols (first).str_p);
dcl	high		fixed bin (18);
dcl	high_string	char (symbols (high).length) unaligned based (symbols (high).str_p);
dcl	initial		fixed bin (18);
dcl	last		fixed bin (18);
dcl	last_string	char (symbols (last).length) unaligned based (symbols (last).str_p);
dcl	low		fixed bin (18);
dcl	low_string	char (symbols (low).length) unaligned based (symbols (low).str_p);
dcl	median		fixed bin (18);

dcl	1 t		like symbols aligned;
dcl	t_string		char (t.length) unaligned based (t.str_p);

dcl	1 stack		(0:20) aligned,
	  2 first		fixed bin (18),
	  2 last		fixed bin (18);


	first, initial = a_initial;
	last = a_final;
	if last - first <= 0
	then return;

	depth = 0;
	go to L4;


L1:
	median = divide (first + last, 2, 17, 0);
	t = symbols (median);
	low = first;
	high = last;

	if first_string > t_string
	then do;
		symbols (median) = symbols (first);
		symbols (first) = t;
		t = symbols (median);
	     end;

	if last_string < t_string
	then do;
		symbols (median) = symbols (last);
		symbols (last) = t;
		t = symbols (median);

		if first_string > t_string
		then do;
			symbols (median) = symbols (first);
			symbols (first) = t;
			t = symbols (median);
		     end;

	     end;

L2:
	do high = high - 1 by -1 while (high_string > t_string);
	end;

	do low = low + 1 by 1 while (low_string < t_string);
	end;

	if low <= high
	then do;
		swap_temp = symbols (high);
		symbols (high) = symbols (low);
		symbols (low) = swap_temp;
		go to L2;
	     end;

	if (high - first) > (last - low)
	then do;
		stack.first (depth) = first;
		stack.last (depth) = high;
		first = low;
	     end;

	else do;
		stack.first (depth) = low;
		stack.last (depth) = last;
		last = high;
	     end;

	depth = depth + 1;

L4:
	if (last - first) > 10
	then go to L1;

	if first = initial
	then if first < last
	     then go to L1;

	do first = first + 1 to last;
	     t = symbols (first);
	     do low = first - 1 by -1 while (low_string > t_string);
		symbols (low + 1) = symbols (low);
	     end;
	     symbols (low + 1) = t;
	end;


	depth = depth - 1;

	if depth >= 0
	then do;
		first = stack.first (depth);
		last = stack.last (depth);
		go to L4;
	     end;
     end sort_symbols;

binoct:
     procedure (number, string);

dcl	number		bit (36) aligned;
dcl	string		char (12) aligned;

dcl	ioa_$rsnnl	entry options (variable);

	call ioa_$rsnnl ("^w", string, 12, number);
     end binoct;

print_symbols:
     procedure (initial, final, head);

dcl	a		fixed bin (18);
dcl	dp		ptr;
dcl	final		fixed bin (18);
dcl	hdr		char (8) varying;
dcl	head		char (8) varying;
dcl	i		fixed bin (18);
dcl	initial		fixed bin (18);
dcl	iptr		ptr;
dcl	item		fixed bin (18);
dcl	n		fixed bin (18);
dcl	z		fixed bin (18);

	do item = initial to final;
	     iptr = addr (rands (symbols (item).offset));

	     hdr = head;				/* use header supplied by user (may be changed) */

	     full_line = "";
	     line_len = begin_refs - 1;

/* print symbol table entry */

	     if iptr -> node.node_type = symbol_node	/* SYMBOL NODE */
	     then do;
		     a = iptr -> symbol.hash_chain;	/* first cross reference entry */
		     if a > 0			/* i.e., there are cref nodes */
		     then z = cross_reference (a).symbol;
						/* last entry */
		     else z = -1;			/* must be < a */

		     if length_symbol_name (iptr) > length (sym_name)
		     then call print$long_name (begin_refs, 0, symbol_name (iptr));
		     else sym_name = symbol_name (iptr);

/* special attributes */

		     if iptr -> symbol.entry_point
		     then do;
			     sym_type = "entry point";
			     hdr = "on line";
			end;

		     else if iptr -> symbol.builtin
		     then sym_type = "builtin";

		     else if iptr -> symbol.external
		     then do;
			     if iptr -> symbol.initial = 0
			     then sym_type = "external";
			     else sym_type = "internal";

			     if iptr -> symbol.function
			     then substr (sym_type, 10, 8) = "function";
			     else if iptr -> symbol.subroutine
			     then substr (sym_type, 10, 10) = "subroutine";
			end;

		     else if iptr -> symbol.stmnt_func
		     then sym_type = "statement function";

		     else if iptr -> symbol.namelist
		     then sym_type = "namelist";

		     else if iptr -> symbol.named_constant
		     then sym_type = "named constant";

		     else if iptr -> symbol.dummy_arg
		     then sym_type = "st func parameter";

/* storage class */

		     if iptr -> symbol.LA & iptr -> symbol.parent ^= 0
		     then do;
			     call print_offset;

			     dp = addr (rands (iptr -> symbol.parent));

			     loc = dp -> header.location;
			     call binoct (unspec (loc), octal_string);
			     if iptr -> symbol.automatic
			     then call print$long_name (begin_refs, begin_class,
				     "la$auto$" || ltrim (substr (octal_string, 7, 6), "0"));
			     else call print$long_name (begin_refs, begin_class,
				     "la$static$" || ltrim (substr (octal_string, 7, 6), "0"));
			end;
		     else if iptr -> symbol.VLA & iptr -> symbol.parent ^= 0
		     then do;
			     call print_offset;

			     dp = addr (rands (iptr -> symbol.parent));

			     if iptr -> symbol.automatic
			     then call print$long_name (begin_refs, begin_class,
				     "vla$auto$" || addr (rands (dp -> header.first_element)) -> symbol.name);
			     else if iptr -> symbol.static
			     then call print$long_name (begin_refs, begin_class,
				     "vla$static$" || addr (rands (dp -> header.first_element)) -> symbol.name);
			     else do;
				     if dp -> header.block_name = blank_common_name
				     then call print$long_name (begin_refs, begin_class, "vla$common$_");
				     else call print$long_name (begin_refs, begin_class,
					     "vla$common$" || dp -> header.block_name);
				end;
			end;

		     else if iptr -> symbol.in_common
		     then do;
			     call print_offset;

			     dp = addr (rands (iptr -> symbol.parent));
			     n = length (dp -> header.block_name);

			     if dp -> header.block_name = blank_common_name
			     then sym_class = "//";
			     else if n > length (sym_class) - 2
						/* symbol overflows the field */
			     then call print$long_name (begin_refs, begin_class,
				     "/" || dp -> header.block_name || "/");
			     else do;
				     substr (sym_class, 1, 1) = "/";
				     substr (sym_class, 2, n) = dp -> header.block_name;
				     substr (sym_class, n + 2, 1) = "/";
				end;
			end;

		     else if iptr -> symbol.parameter
		     then if iptr -> symbol.VLA
			then sym_class = "vla$parm";
			else sym_class = "parameter";

		     else if iptr -> symbol.automatic
		     then do;
			     call print_offset;
			     sym_class = "automatic";
			end;

		     else if iptr -> symbol.static
		     then do;
			     call print_offset;
			     sym_class = "static";
			end;

		     else if iptr -> symbol.constant
		     then do;
			     if iptr -> symbol.address.offset > 0
			     then call print_offset;
			     sym_class = "constant";
			end;

/* mode */

		     if iptr -> symbol.parameter
		     then if iptr -> symbol.stack_indirect
			then do;
				if line_len + 18 > max_line
				then call print$line (begin_refs);
				substr (full_line, line_len + 2, 17) = "several positions";
				line_len = line_len + 18;
			     end;
			else do;
				if iptr -> symbol.referenced
				then numb = print_number (divide (iptr -> symbol.location, 2, 17, 0));
				else numb = print_number ((iptr -> symbol.location));

				if line_len + length (numb) + 10 > max_line
				then call print$line (begin_refs);
				substr (full_line, line_len + 2, 8) = "position";
				substr (full_line, line_len + 11, length (numb)) = numb;
				line_len = line_len + length (numb) + 10;
			     end;

		     if iptr -> symbol.external
		     then do;

			     if iptr -> symbol.initial ^= 0 & iptr -> symbol.initial < symbols (item).offset
			     then do;
				     numb =
					print_line_number
					((addr (rands (iptr -> symbol.initial)) -> symbol.hash_chain));

				     if line_len + 9 + length (numb) > max_line
				     then call print$line (begin_refs);
				     substr (full_line, line_len + 2, 7) = "on line";
				     substr (full_line, line_len + 10, length (numb)) = numb;
				     line_len = line_len + 9 + length (numb);
				end;

			     if iptr -> symbol.needs_descriptors
			     then do;
				     if line_len + 17 > max_line
				     then call print$line (begin_refs);
				     substr (full_line, line_len + 2, 16) = "with descriptors";
				     line_len = line_len + 17;
				end;
			end;

		     if iptr -> symbol.integer
		     then do;
			     if line_len + 8 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 7) = "integer";
			     line_len = line_len + 8;
			end;

		     else if iptr -> symbol.real
		     then do;
			     if line_len + 5 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 4) = "real";
			     line_len = line_len + 5;
			end;

		     else if iptr -> symbol.double_precision
		     then do;
			     if line_len + 17 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 16) = "double precision";
			     line_len = line_len + 17;
			end;

		     else if iptr -> symbol.complex
		     then do;
			     if line_len + 8 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 7) = "complex";
			     line_len = line_len + 8;
			end;

		     else if iptr -> symbol.logical
		     then do;
			     if line_len + 8 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 7) = "logical";
			     line_len = line_len + 8;
			end;

		     else if iptr -> symbol.character
		     then do;
			     if iptr -> symbol.star_extents
			     then numb = "*";
			     else numb = print_number (iptr -> symbol.char_size + 1);

			     if line_len + length (numb) + 12 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 10) = "character(";
			     substr (full_line, line_len + 12, length (numb) + 1) = numb || ")";
			     line_len = line_len + length (numb) + 12;
			end;

		     if iptr -> symbol.dimensioned
		     then do;
			     if line_len + 9 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 6) = "array(";
			     line_len = line_len + 7;

			     dp = addr (rands (iptr -> symbol.dimension));
			     do n = 1 to dp -> dimension.number_of_dims;

				call print_dim_bound (dp -> dimension.lower_bound (n),
				     (dp -> dimension.v_bound (n).lower));

				substr (full_line, line_len + 1, 1) = ":";
				line_len = line_len + 1;

				if (n = dp -> dimension.number_of_dims)
				     & dp -> dimension.assumed_size
				then do;
					if line_len + 2 > max_line
					then call print$line (begin_refs);
					substr (full_line, line_len + 1, 1) = "*";
					line_len = line_len + 1;
				     end;
				else call print_dim_bound (dp -> dimension.upper_bound (n),
					(dp -> dimension.v_bound (n).upper));

				if n = dp -> dimension.number_of_dims
				then substr (full_line, line_len + 1, 1) = ")";
				else substr (full_line, line_len + 1, 1) = ",";
				line_len = line_len + 1;
			     end;
			end;

		     if iptr -> symbol.equivalenced & ^iptr -> symbol.in_common
		     then do;
			     if line_len + 13 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 12) = "equivalenced";
			     line_len = line_len + 13;
			end;

		     if iptr -> symbol.initialed
		     then do;
			     if line_len + 12 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 11) = "initialized";
			     line_len = line_len + 12;
			end;

		     if iptr -> symbol.by_compiler & debuggin_
		     then do;
			     if line_len + 12 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 11) = "by compiler";
			     line_len = line_len + 12;
			end;

		     call print_crefs (a, z, begin_refs, hdr);
		end;


	     else if iptr -> node.node_type = label_node	/* LABEL NODE */
	     then do;
		     call binoct (unspec (iptr -> label.address), octal_string);
		     if substr (octal_string, 1, 6) ^= "000000"
		     then lbl_loc = substr (octal_string, 1, 6);

		     if iptr -> label.name <= 99999
		     then do;
			     line_no_picture = iptr -> label.name;
			     lbl_name = line_no_picture;
			end;
		     else substr (lbl_name, 5, 6) = ">99999";

		     if string (iptr -> label.usage) = "11"b
		     then lbl_type = "unusable";
		     else if iptr -> label.format
		     then lbl_type = "format";
		     else lbl_type = "executable";

		     a = iptr -> label.hash_chain;	/* first cross reference entry */
		     if a > 0			/* i.e., there are cref nodes */
		     then z = cross_reference (a).symbol;
						/* last entry */
		     else z = -1;			/* must be < a */

		     if iptr -> label.set
		     then do;
			     line_len = begin_line - 1;

			     if a > 0
			     then do while (a <= z & cross_reference (z).line_no < 0);
				     numb = print_line_number (z);
				     if line_len + length (numb) + 1 > max_line
				     then call print$line (begin_refs);
				     substr (full_line, line_len + 2, length (numb)) = numb;
				     line_len = line_len + length (numb) + 1;
				     z = z - 1;
				end;

			     if line_len < begin_refs - 1
			     then line_len = begin_refs - 1;
			end;
		     else lbl_line = "undefined";

		     if iptr -> label.referenced_executable & ^iptr -> label.format
		     then do;
			     if line_len + 17 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 16) = "used in transfer";
			     line_len = line_len + 17;
			end;

		     if iptr -> label.name <= 0
		     then do;
			     if line_len + 12 > max_line
			     then call print$line (begin_refs);
			     substr (full_line, line_len + 2, 11) = "by compiler";
			     line_len = line_len + 12;
			end;

		     call print_crefs (a, z, begin_refs, hdr);
		end;

	     else do;				/* HEADER NODE */
		     if length (iptr -> header.block_name) > length (sym_name)
		     then call print$long_name (begin_refs, 0, (iptr -> header.block_name));
		     else sym_name = iptr -> header.block_name;

		     sym_type = "common block name";

		     numb = print_number ((iptr -> header.length));

		     if numb = "1"
		     then i = 6;
		     else i = 7;

		     if line_len + length (numb) + i > max_line
		     then call print$line (begin_refs);

		     substr (full_line, line_len + 2, length (numb)) = numb;
		     if iptr -> header.units = word_units
		     then substr (full_line, line_len + length (numb) + 3, i - 2) = substr ("words", 1, i - 2);
		     else if iptr -> header.units = bit_units
		     then substr (full_line, line_len + length (numb) + 3, i - 2) = substr (" bits", 1, i - 2);
		     else if iptr -> header.units = char_units
		     then substr (full_line, line_len + length (numb) + 3, i - 2) = substr ("chars", 1, i - 2);
		     else if iptr -> header.units = halfword_units
		     then do;
			     i = i + 5;		/* space for "half_" */
			     substr (full_line, line_len + length (numb) + 3, i - 2) =
				substr ("half_words", 1, i - 2);
			end;

		     line_len = line_len + length (numb) + i;

		     a = iptr -> header.last_element;
		     if a > 0			/* i.e., there are cref nodes */
		     then z = cross_reference (a).symbol;
						/* last entry */
		     else z = -1;			/* must be < a */

		     call print_crefs (a, z, begin_refs, hdr);
		end;

	     call print$line (begin_refs);
	end;
	return;


print_offset:
     procedure;

	if iptr -> symbol.VLA
	then call binoct (unspec (iptr -> symbol.offset), octal_string);
	else do;
		loc = iptr -> symbol.address.offset;
		if iptr -> symbol.large_address
		then loc = loc + iptr -> symbol.location;
		call binoct (unspec (loc), octal_string);
	     end;

	sym_loc = substr (octal_string, 5, 8);

/* print bit offset if it applies */

	loc = iptr -> symbol.address.char_num * 9;
	if loc = 0
	then sym_char = "";
	else sym_char = "(" || print_number ((loc)) || ")";

     end print_offset;


print_dim_bound:
     procedure (bound, variable);

dcl	bound		fixed bin (24);		/* Bound value or operand offset */
dcl	Symbol_for_expression
			char (1) static options (constant) init ("#");

dcl	variable		bit (1) aligned;		/* On if bound is operand offset */

dcl	bp		pointer;			/* Pointer to bound variable */
dcl	name_length	fixed bin (18);		/* Length of variable name */
dcl	name_ptr		ptr;			/* Address of variable name. */

dcl	name		char (name_length) based (name_ptr);


	if variable
	then do;

		if bound = 0
		then do;

/* Bound should be variable, but has not been set */

			if line_len + 10 > max_line
			then call print$line (begin_refs);
			substr (full_line, line_len + 1, 9) = "undefined";
			line_len = line_len + 9;
		     end;

		else do;

/* Bound is variable; print a suitable name. */

			bp = addr (rands (bound));
			if bp -> symbol.by_compiler
			then if polish (bp -> symbol.initial - 1) = 1
			     then do;		/* Bound is value of a variable. */
				     bp = addr (rands (polish (bp -> symbol.initial)));
				     name_ptr = addr (bp -> symbol.name);
				     name_length = length (bp -> symbol.name);
				end;
			     else do;		/* Bound is value of an expression. */
				     name_ptr = addr (Symbol_for_expression);
				     name_length = length (Symbol_for_expression);
				end;
			else do;			/* Bound is a variable. */
				name_ptr = addr (bp -> symbol.name);
				name_length = length (bp -> symbol.name);
			     end;
			if line_len + name_length + 1 > max_line
			then if name_length > max_line - begin_refs
			     then do;
				     call print$long_name (begin_refs, line_len, (name));
				     name_length = 0;
				end;
			     else call print$line (begin_refs);

			if name_length > 0
			then substr (full_line, line_len + 1, name_length) = name;
			line_len = line_len + name_length;
		     end;
	     end;

	else do;

/* The bound is constant */

		numb = print_number ((bound));
		if line_len + length (numb) + 1 > max_line
		then call print$line (begin_refs);
		substr (full_line, line_len + 1, length (numb)) = numb;
		line_len = line_len + length (numb);
	     end;

     end print_dim_bound;
     end print_symbols;

print_crefs:
     procedure (first_cr, last_cr, begin_col, cref_hdr);

dcl	begin_col		fixed bin (18);
dcl	cref_hdr		char (8) varying;
dcl	cref_index	fixed bin (18);
dcl	first_cr		fixed bin (18);
dcl	last_cr		fixed bin (18);

	if last_cr < first_cr
	then return;

	if cross_reference (first_cr).line_no > 0 & length (cref_hdr) > 0
	then do;
		if line_len + length (cref_hdr) + 2 > max_line
		then call print$line (begin_col);
		substr (full_line, line_len + 2, length (cref_hdr)) = cref_hdr;
		line_len = line_len + length (cref_hdr) + 2;
	     end;

	do cref_index = first_cr to last_cr;

	     if cross_reference (cref_index).line_no > 0
	     then do;
		     numb = print_line_number (cref_index);
		     if line_len + length (numb) + 1 > max_line
		     then call print$line (begin_col);
		     substr (full_line, line_len + 1, length (numb)) = numb;
		     line_len = line_len + length (numb) + 1;
		end;
	end;
     end print_crefs;

length_symbol_name:
     proc (sp) returns (fixed bin (18));

dcl	sp		ptr;

/* routine to return length of symbol.  If symbol is compiler generated, and
   has a zero length name, then a 9 character name would be generated. */


	if sp -> symbol.name_length = 0 & sp -> symbol.by_compiler
	then return (9);
	else return (sp -> symbol.name_length);
     end length_symbol_name;


symbol_name:
     proc (sp) returns (char (*));


/* routine to return name of symbol.  If symbol is compiler generated, and
   has a zero length name, generate the name of cg.oooooo, where the oooooo
   is the octal address of the symbol node. */

dcl	sp		ptr;


	if sp -> symbol.name_length > 0
	then return (sp -> symbol.name);


	if sp -> symbol.by_compiler
	then do;
		call binoct (unspec (rel (sp)), octal_string);

		return ("cg." || substr (octal_string, 1, 6));
	     end;
	else return ("");
     end symbol_name;

/* program to display output text produced by pl/1 or fortran

   Initial Version: 17 October, 1968
	Modified: 01 October 1979 by PES to list char*(*) variables as char*(*).
	Modified: 12 September 1979 by CRD to fix bug 239 (-16384).
	Modified: 06 December 1978 by PES for %options and %global
	Modified: 25 October 1978 by PES for larger common and arrays.
	Modified: 19 August 1972 by BLW
	Modified:	20 February 1973 by RAB for multiple base-regs
	Modified:	3 July 1973 by RAB for EIS
	Modified: 30 September 1976 by DSL for new fortran compiler
	Modified: 12 May 1977 by DSL for new operator name convention
*/

display_text:
     proc (first_word, last_word);

dcl	first_word	fixed bin (18);
dcl	last_word		fixed bin (18);

dcl	(i, j, k, m, mop, save_k, irand, nrands, ndesc)
			fixed bin (18),
	(fract_offset, offset, size, scale)
			fixed bin (18),
	(ignore_ic_mod, double, eis, eis_desc, need_comma, ext_base, itag, has_ic, decimal)
			bit (1) aligned,
	htht		char (2) int static options (constant) aligned init ("		"),
						/* two tabs */
	pt		ptr,
	c		char (1),
	op_code		char (5),
	tag		char (3),
	line		char (256),
	pl1_operators_$operator_table
			fixed bin ext;

dcl	(fixed, length, min, ptr, rel)
			builtin;

dcl	pl1_operator_names_$pl1_operator_names_
			ext static;

%include op_mnemonic_dcl_;

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

dcl	based_string	aligned char (size) based;

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

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

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

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

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

dcl	1 half		(0:261119) based (object_base) aligned,
	  2 left		unaligned bit (18),
	  2 right		unaligned bit (18);

dcl	1 rel_tab		(0:261119) based (rel_base) aligned,
	  2 dummy_l	unaligned bit (14),
	  2 left		unaligned bit (4),
	  2 dummy_r	unaligned bit (14),
	  2 right		unaligned bit (4);

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

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

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

dcl	desc_op		(0:3) char (8) varying int static options (constant)
			init ("desc9a", "descb", "desc9fl", "desc9ls");

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

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

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

dcl	char		builtin;


%include operator_names;

/* begin display text */

	op_names_pt = addr (pl1_operator_names_$pl1_operator_names_);

	eis = "0"b;
	irand = 0;

	do i = first_word to last_word;

	     tag = "   ";
	     call binoct (unspec (i), octal_string);
	     substr (line, 1, 6) = substr (octal_string, 7, 6);
	     substr (line, 7, 2) = "  ";

	     call insert_relocation;

	     call binoct (object (i), octal_string);

	     if sym_info (i) < 0			/* negative value is used as flag to indicate */
	     then goto not_ins;			/* that word is definitely not an instruction */

	     if instruction (i).unused
	     then goto not_ins;

	     if ^eis
	     then do;
		     mop = fixed (instruction (i).op_code, 10);
		     op_code = op_mnemonic_$op_mnemonic_ (mop).name;
		end;
	     else do;
		     mop = 0;
		end;

	     if op_code = ".... "
	     then do;
not_ins:
		     substr (line, 13, 3) = "   ";
		     substr (line, 16, 12) = octal_string;
		     k = 28;
		     goto prt;
		end;

	     if op_mnemonic_$op_mnemonic_ (mop).num_words > 1
	     then do;

/* EIS */

		     call init_eis;

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

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

		     k = 35;

		     do j = 1 to ndesc;
			string (mod_factor) = substr (object (i), mf (j), 7);
			ebase (j) = mod_factor.ext_base;
			len_reg (j) = mod_factor.length_in_reg;

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

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

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

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

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


		     if substr (object (i), 10, 1)
		     then do;
			     substr (line, k, 12) = "enablefault,";
			     k = k + 12;
			end;

		     if desc_word = "desc9a"
		     then if ndesc < 3
			then do;
				if substr (op_code, 1, 2) ^= "sc"
				then substr (line, k, 5) = "fill(";
				else substr (line, k, 5) = "mask(";
				k = k + 5;
				substr (line, k, 3) = substr (octal_string, 1, 3);
				k = k + 3;
				substr (line, k, 1) = ")";
				k = k + 1;
			     end;
			else k = k - 1;
		     else if desc_word = "descb"
		     then do;
			     substr (line, k, 5) = "fill(";
			     k = k + 5;
			     substr (line, k, 1) = digit (fixed (substr (object (i), 1, 1), 1));
			     k = k + 1;
			     substr (line, k, 1) = ")";
			     k = k + 1;
			     if op_code ^= "cmpb "
			     then do;
				     substr (line, k, 6) = ",bool(";
				     k = k + 6;
				     j = fixed (substr (object (i), 6, 4), 4);
				     m = length (bool_word (j));
				     if m > 0
				     then do;
					     substr (line, k, m) = bool_word (j);
					     k = k + m;
					end;
				     else do;
					     substr (line, k, 1) = digit (fixed (substr (object (i), 6, 1), 1));
					     substr (line, k + 1, 1) =
						digit (fixed (substr (object (i), 7, 3), 3));
					     k = k + 2;
					end;
				     substr (line, k, 1) = ")";
				     k = k + 1;
				end;
			end;
		     else if substr (object (i), 11, 1)
		     then do;
			     substr (line, k, 5) = "round";
			     k = k + 5;
			end;
		     else k = k - 1;

		     irand = 0;
		     go to prt;
		end;

	     double, ignore_ic_mod = "0"b;

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

		     substr (line, 28, 1) = TB;

		     if decimal
		     then desc_word = desc_op (2 + fixed (addr (object (i)) -> descriptor.bit, 4));
		     if irand > 1
		     then if op_code = "dtb  " | op_code = "mvne "
			then desc_word = desc_op (0);
			else ;
		     else if op_code = "btd  "
		     then desc_word = desc_op (0);

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

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

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

	     if op_mnemonic_$op_mnemonic_ (mop).num_desc ^= 0
	     then do;
		     call binoct ((instruction (i).tag), octal_string);
		     tag = substr (octal_string, 1, 2);
		     ignore_ic_mod = "1"b;
		     goto set;
		end;

	     if instruction (i).tag ^= "0"b
	     then do;
		     tag = modifier (fixed (instruction (i).tag, 6));
		     if tag = "..."
		     then goto not_ins;
		end;

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

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

	     substr (line, k, 5) = op_code;

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

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

	     ext_base = instruction (i).ext_base;
	     itag = instruction (i).tag ^= "000000"b;
	     has_ic = instruction (i).tag = "000100"b;	/* IC */

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

	     save_k = k;

	     if ^eis
	     then if instruction (i).unused
		then do;

/* have rpd | rpt instruction */

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

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

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

sk:
		     j = 14;
		end;

	     substr (line, j, 1) = octal_string;

	     call bin2dec (offset);

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

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

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

	     if ignore_ic_mod
	     then goto chk_base;

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

		     pt = addr (object (i + offset - irand));
		     call binoct (rel (pt), octal_string);
		     substr (line, k, 6) = substr (octal_string, 1, 6);

		     k = k + 6;

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

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

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

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

		     goto prt;
		end;

chk_base:
	     if ^ext_base
	     then goto prt;

	     if instruction (i).base ^= "000"b
	     then do;
		     if sym_info (i) <= 0
		     then goto prt;

		     pt = addr (rands (sym_info (i)));

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

		     if pt -> node.node_type = symbol_node
		     then if compiler_generated (pt)
			then ;
			else do;
				j = length (pt -> symbol.name);
				substr (line, k, j) = pt -> symbol.name;
				k = k + j;
				goto prt;
			     end;

		     else if pt -> node.node_type = label_node
		     then if pt -> label.name <= 0 & ^debuggin_
			then ;
			else do;
				numb = print_number ((pt -> label.name));

				substr (line, k, 16) = "statement label ";
				substr (line, k + 16, length (numb)) = numb;
				k = k + 16 + length (numb);
				goto prt;
			     end;

		     else if pt -> node.node_type = header_node
		     then if ^pt -> header.in_common
			then ;
			else do;
				j = length (pt -> header.block_name);
				substr (line, k, j) = pt -> header.block_name;
				k = k + j;
				goto prt;
			     end;

		     else if pt -> node.node_type = array_ref_node & pt -> array_ref.parent > 0
		     then do;
			     pt = addr (rands (pt -> array_ref.parent));
			     j = length (pt -> symbol.name);
			     substr (line, k, j) = pt -> symbol.name;
			     k = k + j;
			     goto prt;
			end;

		     k = k - j;			/* remove the tabs */
		     goto prt;
		end;

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

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

			     call init_eis;

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

			     irand = 0;
			end;
		end;

	     if itag
	     then goto prt;

/* get appropriate operator name */

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

	     else if offset >= operator_names.first_special & offset <= operator_names.last_special
	     then do;
		     do j = 1 to operator_names.number_special;

			if operator_names.special (j).offset = offset
			then do;
				pt = addr (operator_names.special (j).namep);
				goto str_info;
			     end;
		     end;
		end;

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

	     else go to prt;			/* Not found */

str_info:
	     size = fixed (pt -> name_pair.size, 18);
	     pt = ptr (pt, pt -> name_pair.rel_ptr);

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

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

prt:
	     if length (output) + k > output_max
	     then call print$buffer;
	     output = output || substr (line, 1, k - 1);
	     output = output || NL;

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

	end;					/* loop thruough words */

	return;

display_text$display_abs:
     entry (first_word, last_word);

	do i = first_word to last_word;

	     call binoct (unspec (i), octal_string);
	     substr (line, 1, 6) = substr (octal_string, 7, 6);

	     substr (line, 7, 2) = "  ";
	     call insert_relocation;
	     substr (line, 13, 3) = "   ";

	     call binoct (object (i), octal_string);
	     substr (line, 16, 12) = octal_string;

	     if length (output) + 28 > output_max
	     then call print$buffer;
	     output = output || substr (line, 1, 27);
	     output = output || NL;
	end;

	return;

display_text$display_create:
     entry (first_word, last_word, cp);

dcl	extra_line	char (256) var;
dcl	cp		ptr;
dcl	cur_offset	fixed bin (35);		/* offset of current ptr from lp or sp */
dcl	s		ptr;			/* ptr to symbol */

	do i = first_word to last_word;

	     call binoct (unspec (i), octal_string);
	     substr (line, 1, 6) = substr (octal_string, 7, 6);

	     substr (line, 7, 2) = "  ";
	     call insert_relocation;
	     substr (line, 13, 3) = "   ";

	     call binoct (object (i), octal_string);
	     substr (line, 16, 12) = octal_string;
	     extra_line = "";

	     if i = first_word
	     then do;
		     extra_line = "    location ";
		     if cp -> create_entry.flags.auto
		     then extra_line = extra_line || "sp|";
		     else extra_line = extra_line || "lp|";
		     extra_line = extra_line || ltrim (substr (line, 16, 6), "0");
						/* pick out location */
		     if cp -> create_entry.auto
		     then extra_line = extra_line || " automatic";
		     else if cp -> create_entry.static
		     then extra_line = extra_line || " static";
		     else if cp -> create_entry.common
		     then extra_line = extra_line || " common";


		     if cp -> create_entry.LA
		     then extra_line = extra_line || " Large Array";
		     else if cp -> create_entry.VLA
		     then do;
			     if cp -> create_entry.K256
			     then extra_line = extra_line || " Very Large Array (256K)";
			     else extra_line = extra_line || " Very Large Array (255K)";
			end;

		     if cp -> create_entry.init
		     then extra_line = extra_line || " Initialized";
		end;

	     else if i = first_word + 1
	     then extra_line = extra_line || "    length " || ltrim (char (cp -> create_entry.length));

	     else if i = first_word + 2
	     then do;
		     extra_line = extra_line || "    next " || substr (line, 16, 6);
		     if cp -> create_entry.name_length > 0
		     then extra_line = extra_line || "  /" ||
			     cp -> create_entry.block_name || "/";
		end;
	     else if i = first_word + 3
	     then do;
		     if cp -> create_entry.common
		     then do;
			     extra_line = extra_line || "    linkage rel ";
			     extra_line = extra_line || substr (line, 16, 6);
			end;
		     if cp -> create_entry.pointer_count > 0
		     then do;
			     extra_line = extra_line || " ";
			     extra_line = extra_line || ltrim (char (cp -> create_entry.pointer_count));
			     extra_line = extra_line || " pointer";
			     if cp -> create_entry.pointer_count > 1
			     then
				extra_line = extra_line || "s";
			end;
		end;

/* the last create_entry.pointer_count entries are pointers */
	     else if (last_word - i) < cp -> create_entry.pointer_count
	     then do;
		     extra_line = extra_line || "    ";

/* output "lp|offset" or "sp|offset" as appropriate */
		     if cp -> create_entry.flags.auto
		     then
			extra_line = extra_line || "sp|";
		     else extra_line = extra_line || "lp|";
		     cur_offset = cp -> create_entry.location + cp -> create_entry.pointer_count + i - last_word;
		     call binoct (unspec (cur_offset), octal_string);
		     extra_line = extra_line || ltrim (octal_string, "0");

/* output " -> name|offset where name is the name of the storage block and
   offset is the octal offset from the beginning of the storage block */
		     extra_line = extra_line || " -> /";
		     if cp -> create_entry.name_length > 0
		     then do;
			     extra_line = extra_line ||
				cp -> create_entry.block_name || "/|";
			end;
		     else do;
			     extra_line = extra_line || "base/|";
			end;
		     extra_line = extra_line ||
			ltrim (substr (line, 20, 8), "0");

		     extra_line = extra_line || "	";

/* output the symbol name this pointer points to */
		     if sym_info (i) > 0
		     then do;
			     s = addr (rands (sym_info (i)));
			     extra_line = extra_line || "    " || s -> symbol.name;
			end;

		end;

	     if length (output) + 28 + length (extra_line) > output_max
	     then call print$buffer;
	     output = output || substr (line, 1, 27);
	     output = output || extra_line;
	     output = output || NL;
	end;

	return;


display_text$display_init:
     entry (cp);

dcl	init_p		ptr;
dcl	(first_init_word, last_init_word)
			fixed bin (18);

	init_p = cp;
	do while (init_p ^= null);
	     first_init_word = fixed (rel (init_p), 18);

/* If we are a filler then repeat = 0, if we are the end then length = 0 */

	     if init_p -> create_init_entry.repeat = 0
	     then last_init_word = first_init_word + 1;
	     else last_init_word = first_init_word + currentsize (init_p -> create_init_entry) - 1;

	     if init_p -> create_init_entry.length = 0
	     then last_init_word = first_init_word;

	     if length (output) + 1 > output_max
	     then call print$buffer;
	     output = output || NL;

	     do i = first_init_word to last_init_word;
		call binoct (unspec (i), octal_string);
		substr (line, 1, 6) = substr (octal_string, 7, 6);

		substr (line, 7, 2) = "  ";
		call insert_relocation;
		substr (line, 13, 3) = "   ";

		call binoct (object (i), octal_string);
		substr (line, 16, 12) = octal_string;
		extra_line = "";

		if i = first_init_word + 1
		then if init_p -> create_init_entry.repeat = 0
		     then extra_line = "  Fill Zero";
		     else extra_line = "  repeat " || ltrim (print_number ((init_p -> create_init_entry.repeat)));

		else if i = first_init_word
		then if init_p -> create_init_entry.length = 0
		     then extra_line = "  End of Init";
		     else extra_line =
			     "  Data length (bits) " || ltrim (print_number ((init_p -> create_init_entry.length)));

		if length (output) + 28 + length (extra_line) > output_max
		then call print$buffer;
		output = output || substr (line, 1, 27);
		output = output || extra_line;
		output = output || NL;
	     end;
	     if init_p -> create_init_entry.length = 0
	     then init_p = null ();
	     else init_p = addrel (init_p, last_init_word - first_init_word + 1);
	end;
	return;

display_text$display_ascii:
     entry (first_word, n_chars);

dcl	n_chars		fixed bin (18);		/* size of string to be displayed */

dcl	nc		fixed bin (18),
	char_off		fixed bin (18),
	char_string	char (4) aligned based (addr (object (i)));

	i = first_word;
	nc = n_chars;


	do char_off = 1 by 4 to nc;

	     call binoct (unspec (i), octal_string);
	     substr (line, 1, 6) = substr (octal_string, 7, 6);
	     substr (line, 7, 2) = "  ";
	     substr (line, 9, 4) = "aa  ";

	     call binoct (object (i), octal_string);
	     k = 13;
	     do j = 1 by 3 to 12;
		substr (line, k, 4) = substr (octal_string, j, 3);
		k = k + 4;
	     end;

	     substr (line, 28, 1) = TB;

	     k = min (4, nc - char_off + 1);
	     do j = 1 to k;
		c = substr (char_string, j, 1);
		if unspec (c) < "000100000"b | unspec (c) > "001111110"b
		then substr (line, j + 28, 1) = " ";
		else substr (line, j + 28, 1) = c;
	     end;

	     if length (output) + k + 29 > output_max
	     then call print$buffer;
	     output = output || substr (line, 1, k + 28);
	     output = output || NL;

	     i = i + 1;
	end;
	return;

insert_relocation:
     proc;

/* inserts relocation characters in line */

	if rel_base = null
	then do;
		substr (line, 9, 4) = "aa  ";
		return;
	     end;

	if rel_tab (i).dummy_l
	then k = fixed (rel_tab (i).left, 4);
	else k = -1;

	substr (line, 9, 1) = relocation (k);

	if rel_tab (i).dummy_r
	then k = fixed (rel_tab (i).right, 4);
	else k = -1;

	substr (line, 10, 3) = relocation (k);

     end insert_relocation;


bin2dec:
     proc (number);

dcl	(m, number)	fixed bin (18);

	numb = print_number ((number));
	m = length (numb);
	substr (line, k, m) = numb;
	k = k + m;

     end bin2dec;


init_eis:
     proc;

	eis = "1"b;
	nrands = op_mnemonic_$op_mnemonic_ (mop).num_words - 1;
	ndesc = op_mnemonic_$op_mnemonic_ (mop).num_desc;
	decimal = op_mnemonic_$op_mnemonic_ (mop).dtype = 2;
	desc_word = desc_op (op_mnemonic_$op_mnemonic_ (mop).dtype);

     end init_eis;
     end display_text;
     end listing_generator;
     end ext_listing_generator;



		    ext_parse.pl1                   12/11/91  2238.1r w 12/11/91  2227.1     4086162


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        * 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 457, 458, 461, and 463.
  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, 389, 396, 428, 470, 473, 481, and 482.
  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, 497, and 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 bugs 479 and 431.
  5) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen),
     install(87-08-06,MR12.1-1069):
     Implemented SCP 6315: Added a fortran runtime error-handler argument.
  6) change(88-02-29,Huen), approve(88-02-29,MCR7846), audit(88-03-07,RWaters),
     install(88-03-15,MR12.2-1036):
     Fix bug 506: Do not always assign bp -> header.units to char_units
     whenever the first element of  the common block is of character type.
  7) 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:  Allow  character variables to be up to 128K-1
     (131071) character long.
  8) change(89-06-14,RWaters), approve(89-06-14,MCR8115),
     audit(89-07-21,Blackmore), install(89-07-31,MR12.3-1065):
     Fix bug 511; error in format statements > 512 chars long.
  9) change(91-11-06,Huen), approve(91-11-06,MCR8246), audit(91-11-25,Vu),
     install(91-12-11,MR12.5-1004):
     Fix Fortran compiler (ft_514) to be able to consistently diagnose errors
     when the VLA size is greater than the maximum value.  The maximum value is
     (2**24 - 1) words long.
                                                   END HISTORY COMMENTS */


/* format: style3,^indattr,linecom,ifthendo,ifthen,^indnoniterdo,^elsestmt,dclind9 */
ext_parse:
     procedure (p, q);

/* Created:	June 1976, David Levin

   Modified:
          15 May 87, RW SCP 6315 added the -debug_io argument, set
                    io_bits.debug according to subr_options.debug_io;
          23 Feb 87, SH & RW - 431: Allow substrings in equivalence
                    statements in ansi77 mode.
          02 Jan 87, SH - 479: Whenever a left parenthesis prior to
                    an input list item in a set context, display 
                    additional information "A redundant parenthesis
                    was encountered." after the error message 95.
          21 Mar 86, NS - 498: Put in check for invalid unit numbers.
          18 Mar 86, NS - 497: Check for the typeless function fld.
          08 Mar 86, SH - 410: Allow builtin functions to be declared 
                    in external statements in ansi66 mode. Update the
                    bif_table.external table and delete the intrinsic
                    include file.
	28 Feb 86, BW - 428.a: Make minor declaration changes:
		o default_char_size only needs to be increased from
		  fixed bin (9) to fixed bin (10)
		o token can be left as bit (9) aligned
		o token_list structure is padded to make it word aligned
		o temp_str only needs to be increased from char (256)
		  to char (512).
	27 Feb 86, BW - 461.a: Fix error introduced with the character
		equivalencing.  Block lengths were calculated larger then
		they should be causing unnecessarily large text sections.
	19 Feb 86, BW & AG - 473.a: Fix allowing individual storage classes 
		(automatic, static, parameter, or common) to be addressed
		as VLA's or LA's.  Move code to set maximum array sizes
		from fort_defaults_$check_global_args to the new routine
		set_max_array_size so the values are set properly.
          12 Dec 85, NS, MM, & BW - 482: Change the default in precision of 
                    an unsupported REAL type from single to double precision.
          12 Dec 85, NS, MM, & BW - 481: Warn user of a change in the 
		precision of a real variable from that in which it was
     		declared.
          11 Dec 85, NS - 389: Warn user of a complex type declaration of
                    precision other than single precision.
          05 Dec 85, RW - 396: Stop compiler from changing automatics into
		named constants if they are in equivalence statements.
          29 Nov 85, RW - 428: Allow strings up to 512 (up from 256)
          25 Nov 85, RW - 122: Changed max number of items in a format 
                    statement to 1023 (up from 510)
	09 Oct 85, BW - 473: Allow individual storage classes (automatic,
		static, parameter, or common) to be addressed as
		VLA's or LA's.
	26 Sept 85, BW - 470: Use only the significant digits of real and
		double precision constants when converting from
		character to floating point representation.
	02 Aug 85, BW - 463: Removed code to set must_save_stack_extent.
		The saving will no longer be done because of fortran_io_
		problems.
	16 Jul 85, MM & BW - 461: Allow character variables and
		non-character variables to be equivalenced in ansi77.
          12 Jun 85, BW - 458: Suppress generation of error messages for
                    compiler generated symbols.
          12 Jun 85, BW - 457: Correct cross referencing of format statements
                    which are declared before they are referenced.
	22 Mar 85, MM - 433: Correct the polish for the bypass label that
		is emitted around entry statements.  The label itself must
		fall on the end of the last entry statement - not on the
		following statement.
          12 Aug 84, BW - 435: Generate correct polish for entry points
                    followed by non-executable statements only.
          03 Aug 84, BW - 434: Allow option names of up to 32 characters.
	22 Jun 84, MM - Install typeless functions support.
	25 Apr 84, HH - 424: Argument type & shape specification disallowed
		after 1st executable statement.
	13 Apr 84, MM - 419: Generate correct polish for routines that do
		not contain executable statements.  
	12 Apr 84, BW - 418: Correct lexer error which occurred when a
		Hollerith string was followed by a labelled statement.
	28 Mar 84, MM - Install HFP support.
	05 Dec 83, HH - 412: Prevent possible endless loop when checking
		for branches into do-loops in '77 mode.
	16 Sep 83, RG & MM - 242/370: Pass ptr (symbol.general) to arg_desc in entry node.
	14 Aug 83, HH - 387: Allow substrings as targets in DATA statements.
	14 Aug 83, HH - 386: Generalize expressions in DATA statements to
		comply with the '77 Standard.
	12 Jul 83, MM - 379: Give more consistancy to compilation options.
	 4 Jul 83, RG - 385: To allow conversions to integer in DATA statements
	19 Jun 83, HH - 145: Disallowing branching into do-loops in '77 mode.
	17 Jun 83, HH - 383: Make adjustable arrays conform to the Standard
		in '77 mode.
	10 May 83, MM - 375: Allow common variables to be initilized to 0.
	10 May 83, RG - 174: Allow include files to be archive components.
	10 Feb 83, HH - Install LA/VLA support.
	21 Oct 82, TO - 360: Add default 'UNIT=' to INQUIRE.
	21 Oct 82, TO - 362: Add parsing for 'CHARACTER*(*) FUNCTION f ('.
	14 May 82, TO  - Modify extraneous text error for parenthesis test.
	 5 May 82, TO  - Save stack extent if char_star_function is only one.
	22 Mar 82, TO  - Fix navy test bug 1, label with code on continuation lines only.
	22 Mar 82, TO  - Fix navy test bug 2, lack of comma in assigned goto.
	18 Mar 82, TO  - Fix bug 296 - implied IO do loop gets errors on left_parn of expression.
	17 Mar 82, TO  - Fix bug 326 - assign lex doesn't know about logical if with substr assign target.
     	16 Mar 82, TO  - Fix bug 269 - incorrect line number reporting.
	12 Mar 82, TO  - Fix bug 320 - failure to detect duplicate entries.
	17 Dec 81, MEP - Fix bug in doubly subscripted implied do in data statement.
	15 Dec 81, MEP - Fix bugs in label_const parsing (*<int>) and filed length in mode statements.
	14 Dec 81, MEP - Fix unreported bug in parsing of * as unit number.
	4 Dec 81, MEP - Fix bug 257 allow proper equivalencing of ansi66 and ansi77 arrays
	19 Nov 81, MEP - Fix bug 246 too many constants for variable list in data statment
	17 Nov 81, MEP - Fix bug 327 not allow chars and non-chars in fortran 77 equiv groups
	17 Nov 81, MEP - Fix bug 328 on external (descriptors) character functions in ansi_77.
	16 Nov 81, MEP - Fix bug 323 on lacking s permission of include file's directory.
	13 Nov 81, MEP - Fix unreported bug in typed functions
	22 Oct 81, MEP - Added code for INQUIRE statement.  Changed parse_open_field to have parameter
		for expression_type.
	1 Oct 1981, MEP - Fortran 77 internal files
	5 August 1981, MEP - Fixed bug 324, incorrect tally of stack high-water mark
	16 July 1981, MEP - Completion of ASSIGN with format labels
	14 July 1981, MEP - Full ansi77 format specifiers
	30 June 1981, MEP - Allow format statements to be objects of ASSIGN TO
	June 1981, MEP - Finished alteration to REWIND, etc.  Began changes for new 
		READ/WRITE specifications.
	1 June 81, MEP - Alterations to parse_parameter_list, and argument list of statement functions to
		allow functions with no arguments.
	20 May 81, MEP - Alterations in the lex to allow blank lines to be comments in ansi77
	12 May 81, MEP - Added code for INTRINSIC statement.
     	11 May 81, MEP - Added code for .EQV., .NEQV., and SAVE /common-block-name/
	4 May 81, MEP - Added code for new features in rewind, backspace, and  endfile statements.
	3 May 81, MEP - Minor changes per CRD's audit for array and data changes.
	29 Apr 81, MEP - Program statement and named block data subprogs.
	11 Mar 81, MEP - Began the enhancements for ansi77 array declarators
	22 Feb 81, MEP - Fixed bug 307 (blank common not recognized unless first in common statement and bug 305
		(parse fails when identifier continued onto next line and next char is not letter or digit).
	26 January 1981, CRD - Improve interaction of elseif statement with
		profile and breakpoints.
	 5 January 1980, MEP - Added code to handle illegally referenced labels
	31 December 1980, MEP - Added a field in statement_attributes for warnings on labelled statements 
	29 December 1980, MEP - Cleaned up the error handling for improperly nested do's and block if's.
	15 December 1980, MEP - Added code that manipulates the do_blockif_stack, formerly the do_stack for nested do loops
		and the code for the parsing of block if's.
	19 November 1980, CRD - Fix bug in which array_size was computed for
		star extent arrays instead of leaving it to later phases.
	24 October 1980, CRD - Added new intrinsics for Fortran 77.
	8 October 1980, CRD - Fixed bug 283.  Lex was not properly handling
		hollerith constants which need to be blank padded but are
		not continued.
	29 September 1980, CRD - Fixed bug 281.  Changed the lex not to make
		substr_left_parn tokens; and invented the subroutine
		get_next_token$paren_operator which differentiates between
		left_parn and substr_left_parn by scanning the token list.
		parse_expression calls this new subroutine, as it is the 
		only place which needs to differentiate.
	17 September 1980, CRD - Fixed bug 277: %include lex was not
		stripping white space properly.  Also fixed bug 268:
		fold keyword not allowed in %options or %global.
	31 July 80, MEP - Added code to allow evaluation of fortran 77
		parameter statements
	29 July 80, CRD - Fix bug in declaration processing of entry_points.
	16 July 80, MEP - Set symbol.variable_arglist in external statement.
	10 June 80, MEP - Added code to set must_save_stack_extent iff more
		than one subprogram and char star-extent variables seen.
	5 June 80, MEP - Changed parse to properly set needs_descriptors bit
		for all entry points.  This is done if any of the formal parameters
		is star_extents or the function itself is.
	16 May 80, MEP - Added code to set io_bits.ansi_77 so that character array i/o
		is handled correctly in both modes.
	09 May 1980, MEP - Fixed two bugs in character mode.  The first
		bug was that the use of two substered variables in an expression was mishandled.
		The second was that a reference to an unsubscripted substered variable failed to
		correctly set the variable bit in symbol.attribute.
	01 May 1980, MEP - Removed the builtins until such time as the required
		alterations to the back end are implemented.  Also fixed a bug in which subscripted
		substered references are correctly handled.
	04 Apr 1980, MEP - Add the new builtins sinh, cosh, dcosh, dtanh,
		dsinh.  Also fix bug to make tan externable.
	04 Apr 1980, PES - Fix uninitialized subroutine_options bug.
	18 Dec 1979, PES - Change parse to emit (read write)_namelist_op rather than namelist_op
		when optimizing, to fix bug 249, in which the optimizer appears to ignore the 
		fact that a namelist read sets the values in the namelist.  Eliminate all
		references to the obsolete bit symbol.need_word_count.
	06 Dec 1979, PES - Multiplied all positive precedences in parse_expression by 10, to ease
		addition of new operators.  Since only relative values are  supposed to matter, this
		should have no visible effect.
	27 Nov 1979, PES - Fix bug 248, in which symbol.in_equiv_stmnt is not set for a
		variable which is in both a common block and an equivalence statement.
	26 Sep 1979, PES - major butchery for new CHARACTER mode.  Make comma in assigned goto
		statement optional.
	02 Sep 1979, PES - Fix bug 206, in which certain unfortunate placements of delimiters in
		card-image format statements could cause spurious error 134 messages.
	02 Sep 1979, PES - Allow multiple namelist declarations to refer to same namelist, if
		they are consecutive statements; fix unreported bug in multiple segment
		handling; minor cleanups; allow optional comma in COMMON statements declaring
		multiple commons; change to allow blank lines before %options and %global
		statements; slightly limit the free form check for unintended comment lines;
		fix an unreported namelist bug in which if the first ref to a namelist was in a
		write any following refs in a read would not cause the namelist members to be
		marked set; fixed an unreported namelist bug in which namelist names were
		always listed in the "not referenced" list, with proper cross-reference info;
		changed namelist so that a namelist reference is also cross-referenced as a
		reference to each member; and fixed bug 208, in which variables on the lhs of
		the first assignment statement might be multiply cross-referenced.
	18 Jul 1979, PES - fix bug 211 in which fortran incorrectly evaluates a**b**c as
		(a**b)**c, rather than as a**(b**c).  Also adds diagnosis of possible
		unintended comments in free format input.  Also correct an error in handling of
		encode/decode statements when the string is an entire character array,
		introduced by the fix to 222/223.
	13 Jul 1979, CRD - initialize io_bits.fold to implement fortran_io_ suggested improvement
		078 (case insensitive namelist input with -fold or -card).
	12 Jul 1979, PES - changes to fix bug 222 and implement suggested improvment 223, both
		having to do with encode/decode problems; and to fix various unreported bugs in
		encode/decode.  Also, allow the optional comma after the statement number in a
		do statement, as permitted by the 77 ANSI Standard.
	05 Jul 1979, PES - fixes bug 219 in which an uninitialized variable in the parse may
		cause the listing generator to fault.
	03 Jul 1979, PES - fix uninited variable which caused misc faults.
	12 Jun 1979, PES - major butchery for new PARAMETER statement.
	07 Jun 1979, PES - fixes bug 210 in which the parse will generate a spurious error 125
		message (data type of entry does not match data type of function) if the data
		type of a function entry does not match the default data type of the primary
		function name.
	14 Mar 1979, PES - serious modifications towards include file handling.
	28 Feb 1979, PES - fixes bug 202 in which a missing ; on an %options or %global statement
		will cause the parse to fault.
	8 Jan 1979, RAB - fixes bug 200 in which equivalence alignment is wrong if the second
		item in a pair belongs to a header that is further to the left than the first
		item and difference is odd.
	13 Dec 1978, PES -fixes bug in which named constants are not marked as referenced, and
		bug in which fort_converter does not properly handle string_op.
	12 Dec 1978, PES - fixes bug 189 in which the compiler does not diagnose statements of
		the form "x+y = exp".  If optimizing, such a statement causes a fault; if not
		optimizing, useless code is produced.
	06 Dec 1978, RAB - fixes 193 in which missing comma in implied do causes fault.
	06 Dec 1978, PES - Implement %options and %global--change implementation of octal
		constants to match old_fortran.
	25 Oct 1978, PES - Changes for larger common and arrays.
	25 Sep 1978, PES - Change to fix bug 188, in which block data fails if data statements
		for a common block contain only equivalenced variables and do not contain any
		variables actually appearing in the common statement.
	06 Sep 1978, PES - Change so variables read by namelist directed read are marked as set.
	31 Aug 1978, PES - Change to the constants used by convert_real to check real number
		magnitudes before conversion.  Both original values were too small, meaning:
		(1) That certain very large real constants would not be accepted, even though
		they were proper values; and (2) that certain very small magnitude real
		constants could cause the compiler to take an underflow fault , instead of
		being diagnosed as errors.
	19 July 1978, PES - Fix to relaxed statment ordering, to again permit variables to be
		declared in common after they have been declared equivalenced.  This feature
		was broken by the last change.
	20 June 1978, DSL - Fixes to declaration processing.  Bug fixed in which a variable can
		have two storage classes because default storage class was applied before(!)
		equivalence processing; improved processing of invalid equiv groups; set
		symbol.equivalenced when equiv st is parsed, rather than when dcl processor is
		run.  See comments concerning this parse design change under equiv st parser
		#13.
	12 June 1978, DSL - Have "declaration_processor" set storage class as well as data type
		for all variables, and data type for all ext funcs.  Declare alternate return
		symbol as a variable (bug fix).
	25 May 1978, DSL - Fix bug 157 correctly so compiler will not fault if label > 999999.
		Move create_node to include file.  Insure that statement.put_in_profile and
		statement.put_in_map are always set correctly.
	18 May 1978, DSL - Final fix to bug 144 in which dcl for based_double assumed double word
		alignment for all dp values; fix bug in which text of first statement appears
		as text for main entry point entry sequence; fix bug 158 in which data type for
		float bif is erroneously d.p.; fix bug 157 in which parse faults trying to
		print error message for label > 131071.
	2 May 1978, dsl - minor code changes for v2 opt; also clean up a_complex_constant.
	26 April 1978, DSL - Fix introduced bug in which label parsing was broken.  Other small
		fixes.
	18 April 1978, DSL - Set symbol.set for a format if it is ref'd in a read st and
		contains_hollerith; fix bug 151 in which parse neglects to set symbol.ref'd
		(etc.) for parameter bounds.
	7 April 1978, DSL - Move complex constant processing from lexical analyzer to expression
		parser; fix introduced bug in optimizer in which parse does not force data type
		of a symbol before deciding how much temp space it needs; change card-image lex
		to supply blanks for lines less than 72 chars in length.
	28 March 1978, DSL - Finish relaxed statement ordering; allow another form of function
		statement; fix bug 144 in which conversion from dp to real fails because dcl of
		based_double is wrong.

******************  Converted to version 2 optimizer.  ******************

	28 February 1978, DSL - Change logic to allow statements to appear in any order.  The
		only surviving restrictions are: a) declaratives must precede first reference;
		b) all statement func.  defs.  must precede all other executables.
	2 February 1978, DSL - Mark return statement code generated by an end line as being
		executable.
	1 February 1978, DSL - Fix post-parse declaration processor to set all symbol.data_type
		and symbol.element_size.
	29 December 1977, DSL - Fix bug 124 so that -3435...  (-2**35) is accepted in a data
		specification; fix bug 126 so that cg will not fault on an unreferenced
		st.func.  def.; fix bug 137 so that max number of consts is 500, not 200.
		Also, some changes were made in preparation for relaxing all stmnt order
		requirements.  Also, fixed unreported bug in which char func with different
		lengths declared at each entry point would not be diagnosed, although compiler
		does not handle this case correctly.  Also, modified data spec parse to allow
		char consts and octal consts for all data type.  Data spec parse no longer
		limits the number of error msgs it prints.  print_message is made responsible.
	30 August 1977, D Levin - print message if subr or func ref has too many args;
		NOTE - value of bias changed from 65536 to 131072.
	18 July 1977, David Levin - fix bugs in open and close.
	30 June 1977, David Levin - 1) new fort_system_constants.incl.pl1; 2) open and close
		statements; 3) move block data code from fort_ to here.
	26 May 1977, David Levin - data parser printed random stuff instead of octal constant in
		error msg.
	2 May 1977, David Levin - for new fort_system_constants.incl.pl1 and changes for implied
		do loop optimization and bug fix for stop/pause.
	22 April 1977, David Levin - convert long real const (>8) to dp; warn user if char var
		init'ed with const too long; fix bug in warning msg.
	14 April 1977 David Levin - small optimizer fix; add 6 new builtin functions.
	25 March 1977 David Levin - fix for char const as fmt; set label.referenced_executable.
	24 February 1977 Gabriel Chang - to emit a zero operand for not, and negate operators and
		emit no_ops for complicated subscripts for optimization.
	10 February 1977 David Levin - fix bug in equiv stmnt; improve lex for real constants.
	24 January 1977 David Levin - minor tuning; prepare for the addition of optimizer changes.
	19 January 1977 David Levin - bug fix for data stmnt parser.
	14 September 1976 David Levin - listing addition bug fixes, some error msg clean up.
	9 September, 1976 David Levin - bug fixes for listing additions.
*/

dcl      p pointer;
dcl      q pointer;
dcl      parse_ptr pointer;
dcl      shared_ptr pointer;
dcl      polish_string (0:polish_max_len - 1) fixed bin (19) aligned based (polish_base);
dcl      polish_base ptr;
dcl      operand_base ptr;
dcl      object_base ptr;
dcl      cref_base ptr;
dcl      source_line_base ptr;
dcl      listing_base ptr;
dcl      polish_max_len fixed bin (19);
dcl      object_max_len fixed bin (19);
dcl      1 max_array_size,
	 2 auto fixed bin (24),
	 2 char fixed bin (24),
	 2 common fixed bin (24),
	 2 parm fixed bin (24),
	 2 static fixed bin (24);

dcl      1 segment_options aligned like fortran_options;
dcl      1 subr_options aligned like fortran_options;
dcl      1 segment_declared aligned like fortran_declared;
dcl      1 subr_declared aligned like fortran_declared;

dcl      1 parse_structure aligned based (parse_ptr),
%include fort_parse_vars;

dcl      1 shared_structure aligned based (shared_ptr),
%include fort_shared_vars;
%include fort_options;
%include fort_system_constants;
%include fort_nodes;
%include fort_listing_nodes;
%include std_descriptor_types;

	parse_ptr = q;
	shared_ptr = p;

	polish_base = shared_structure.polish_base;
	operand_base = shared_structure.operand_base;
	object_base = shared_structure.object_base;

	if shared_structure.options.map then do;
	     cref_base = shared_structure.cref_base;
	     source_line_base = shared_structure.source_line_base;
	     listing_base = shared_structure.listing_base;
	end;

	polish_max_len = shared_structure.polish_max_len;
	object_max_len = shared_structure.object_max_len;
	max_array_size.char = sys_info$max_seg_size;
	call set_max_array_size;
	call parse_source (source_info_ptr);
	return;

set_max_array_size:
     procedure;

	if shared_structure.options.VLA_auto then
	     max_array_size.auto = max_fixed_bin_24;
	else
	     max_array_size.auto = sys_info$max_seg_size;
	if shared_structure.options.VLA_parm then
	     max_array_size.parm = max_fixed_bin_24;
	else
	     max_array_size.parm = sys_info$max_seg_size;
	if shared_structure.options.VLA_static then
	     max_array_size.static = max_fixed_bin_24;
	else
	     max_array_size.static = sys_info$max_seg_size;
	if shared_structure.options.VLC then
	     max_array_size.common = max_fixed_bin_24;
	else
	     max_array_size.common = sys_info$max_seg_size;
	return;
     end;

%include fort_utilities;

parse_source:
     procedure (src_info_ptr);

/*	Program Specifications (parse_source)

     Inputs

     Output

     Description - This routine parses one or more source segment and produces
	the intermediate representation. Before each subprogram is parsed,
	all local work areas are reinitialized. This includes the operand table (or symbol table),
	the segment containing the intermediate representation of each statement, etc.

	Each symbol table is independent except there is a single thread which runs through
	all symbols in all segments compiled. There are similar threads for constants and labels.

	Each subprogram compiled produces a block of independent intermediate text. This text is
	preceded by a header which indicates subprogram name and type, and some switches. One switch
	indicates whether or not the intermediate text should be skipped or compiled. This switch
	will be used primarily to prevent the compilation of more than one subprogram with the
	same name.

*/

dcl      COLON_BEFORE_ASSIGN bit (1) aligned;
dcl      BEGIN_DO_LOOP fixed bin (18) static options (constant) init (-1);
declare	CURRENT_VALUE fixed binary (18) internal static options (constant) initial (1);
dcl      DECLARED bit (5) aligned int static options (constant) init ("0"b);
dcl      DIGIT char (10) aligned int static options (constant) init ("0123456789");
declare	END_DO_LOOP fixed binary (18) internal static options (constant) initial (-2);
declare	END_DO_LOOP_SIZE fixed binary (18) internal static options (constant) initial (1);
dcl      END_DO_RANGE bit (1) aligned;
dcl      FALSE bit (1) aligned int static options (constant) init ("0"b);
dcl      GOTO_REF bit (5) aligned int static options (constant) init ("10101"b);
dcl      GOTO_TARGET bit (5) aligned int static options (constant) init ("11101"b);
dcl      INIT bit (5) aligned int static options (constant) init ("00001"b);
declare	INITIAL_EXPRESSION fixed binary (18) internal static options (constant) initial (2);
dcl      NO_NAME char (8) unaligned int static options (constant) init ("");
dcl      NOT_SET bit (1) int static options (constant) init ("0"b);
dcl      NULL_STRING char (0) int static options (constant) init ("");
dcl      ONE fixed bin (18) int static options (constant) init (1);
dcl      OS (0:operand_max_len - 1) bit (36) aligned based (operand_base);
dcl      PASSED bit (5) aligned int static options (constant) init ("10110"b);
dcl      REF bit (5) aligned int static options (constant) init ("10100"b);
dcl      SECOND_EQUALS bit (1) aligned;
dcl      SET bit (5) aligned int static options (constant) init ("11100"b);
dcl      SET_ATTR bit (1) int static options (constant) init ("1"b);
dcl      SI fixed bin (18);
dcl      SKIP fixed bin (18) static options (constant) init (0);
dcl      SUBSCRIPTED_VAR fixed bin (18) static options (constant) init (-4);
dcl      SUBSCRIPTED_SUBSTR fixed bin (18) static options (constant) init (-5);
dcl      SUBSTR fixed bin (18) static options (constant) init (-3);
declare	SYMBOL_INDEX fixed binary (18) internal static options (constant) initial (1);
dcl      TRUE bit (1) aligned int static options (constant) init ("1"b);
dcl      ZERO bit (1) aligned int static options (constant) init ("0"b);
dcl      max_char_var_length fixed bin (21) internal static options (constant) init (131071);

dcl      abs builtin;
dcl      addr builtin;
dcl      after_subprogram fixed bin (18) int static options (constant) init (11);
dcl      all_attributes bit (47) aligned int static options (constant)
	    init ("11111111111111111111111111111111111111111111111"b);
dcl      allow_star_after bit (1) aligned;
dcl      alphabetic char (52) aligned int static options (constant)
	    init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");
dcl      alternate_return_index fixed bin (18);
dcl      any_label bit (2) aligned int static options (constant) init ("00"b);
dcl      arg_type bit (36) aligned;
dcl      asf_attribute bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000010000000000000"b);
dcl      asf_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111111111110000"b);
dcl      asf_definition fixed bin (18) int static options (constant) init (28);
dcl      assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
dcl      assignment_statement fixed bin (18) int static options (constant) init (60);
dcl      assignment_statement_index fixed bin (18);
declare	asterisk_seen bit (1) aligned;
dcl      attr_table (0:6) bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000000000000"b,
	    "00000000000000000000100000000000000000000000000"b, "00000000000000000000010000000000000000000000000"b,
	    "00000000000000000000001000000000000000000000000"b, "00000000000000000000000100000000000000000000000"b,
	    "00000000000000000000000010000000000000000000000"b, "00000000000000000000000001000000000000000000000"b);
dcl      attributes bit (47) aligned;
dcl      auto_attribute bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000010000001000"b);
dcl      b72_one bit (72) aligned int static options (constant)
	    init ("100000000000000000000000000000000000000000000000000000000000000000000000"b);
dcl      b72_zero bit (72) aligned int static options (constant)
	    init ("000000000000000000000000000000000000000000000000000000000000000000000000"b);
dcl      bad_type fixed bin (18);
dcl      based_bit_72 bit (72) aligned based;
dcl      based_char char (8) aligned based;
dcl      based_integer fixed bin (35) based;
dcl      based_real (2) float bin (27) based aligned;
dcl      based_words (512) bit (36) aligned based;
dcl      before builtin;
dcl      begin_char fixed bin (18);
dcl      bif_conflicts bit (47) aligned int static options (constant)
	    init ("11111111111111111111000011111110011111111111000"b);
dcl      binary builtin;
dcl      bit builtin;
dcl      bit_mask (4) bit (36) aligned int static options (constant)
	    init ("111111111000000000000000000000000000"b, "111111111111111111000000000000000000"b,
	    "111111111111111111111111111000000000"b, "111111111111111111111111111111111111"b);
dcl      bit_value bit (9) aligned;
dcl      bypass_first_pending_entry bit (1);
dcl      card_image bit (1) aligned;
dcl      char builtin;
dcl      char_index fixed bin (20);
dcl      char_siz fixed bin (18);
dcl      char_temp char (1320) aligned;			/* Refer to procedure "create_format" before changing. */
dcl      char_type fixed bin (18);
dcl      char_value char (1) aligned based (addr (bit_value));
dcl      code fixed bin (35);
dcl      common_name char (256) varying;
dcl      common_storage bit (3) aligned int static options (constant) init ("001"b);
dcl      const_index fixed bin (18);
dcl      const_count fixed bin (18);
dcl      constant_type (6) bit (9) aligned int static options (constant)
	    init ("001100110"b, "001100111"b, "001101000"b, "001101001"b, "001000010"b, "001000001"b);
dcl      continuation_line fixed bin (18) int static options (constant) init (2);
dcl      copy builtin;
dcl      count fixed bin (18);
dcl      cp_count fixed bin (18);
dcl      cp_label_count fixed bin (18);
dcl      cur_paren fixed bin (18);
dcl      cur_segment fixed bin (18);
dcl      cur_stmnt_ptr pointer;
dcl      current_character char (1) aligned;
dcl      current_parameter fixed bin (18);
dcl      current_token fixed bin (18);
dcl      decimal builtin;
dcl      decode_statement fixed bin (18) int static options (constant) init (44);
dcl      default_char_size fixed bin (10);
dcl      default_table (52) bit (47) aligned;
declare	default_unit_specifier fixed binary (18);
dcl      defined fixed bin (18);
dcl      dim_attr bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000100000001000"b);
dcl      dim_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111100000110000"b);
dcl      dim builtin;
dcl      digits fixed bin (18) int static options (constant) init (3);
dcl      divide builtin;
dcl      do_index fixed bin (18);
dcl      do_info (8) fixed bin (18);
dcl      do_level fixed bin (18);
dcl      do_statement fixed bin (18) int static options (constant) init (61);
dcl      dp pointer;
dcl      (E_start, E_finish) fixed bin;
dcl      E_token fixed bin;
dcl      elseif_statement fixed bin (18) int static options (constant) init (30);
dcl      else_statement fixed bin (18) int static options (constant) init (31);
dcl      end_char fixed bin (18);
dcl      end_line fixed bin (18) int static options (constant) init (64);
dcl      end_of_line fixed bin (18);
dcl      end_possible bit (1) aligned;
dcl      entry_point_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111111111111000"b);
dcl      entry_value bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000001000000000000000"b);
dcl      entry_value_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000110010011111110111000"b);
declare	equivalence_statement fixed bin (18) int static options (constant) init (14);
dcl      equiv_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111000001110000"b);
dcl      error bit (1);
dcl      error_code fixed bin (35);
dcl      executable_label bit (2) aligned int static options (constant) init ("01"b);
dcl      ext_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000001000000000000000"b);
dcl      ext_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111111110111000"b);
dcl      fast_lookup char (24) unaligned defined (full_name);
dcl      fields_specified bit (72) aligned;
dcl      file_number fixed bin (8) init (0);
dcl      file_number_pic picture "zzz-";
dcl      file_stack_depth fixed bin (17);
dcl      first_mode_keyword fixed bin (18) int static options (constant) init (15);
dcl      first_time bit (1) aligned;
dcl      first_token fixed bin (18);
dcl      first_word fixed bin (18);
dcl      fixed builtin;
dcl      fold_option bit (1) aligned;
dcl      force_symtab_entry fixed bin (2) int static options (constant) init (2);
dcl      format_label bit (2) aligned int static options (constant) init ("10"b);
dcl      format_label_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000001000000000001000001000"b);
dcl      fort_defaults_$global ext entry (ptr, fixed bin, ptr, entry);
dcl      fort_defaults_$check_global_args ext entry (ptr, ptr, entry);
dcl      fort_defaults_$init_shared_vars external entry (ptr);
dcl      fort_defaults_$option ext entry (ptr, fixed bin, ptr, ptr, ptr, bit (1) aligned, bit (1) aligned, entry);
dcl      fort_defaults_$set ext entry (ptr, ptr);

declare	fort_eval_parm ext entry (ptr, char (*), fixed bin (35));
dcl      free_chain fixed bin (18);
dcl      from_data_parser bit (1) aligned;
dcl      full_name char (256) unaligned;
dcl      func_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000110110111111110111000"b);
dcl      func_ref_attribute bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000001001000000000000000"b);
dcl      function_attribute bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000001010000000000100000"b);
declare	function_statement fixed binary (18) internal static options (constant) initial (4);
dcl      general_format_parse_ entry (char (1320) aligned, char (4096) aligned, bit (1) aligned, fixed bin (35));
dcl      hash_table (0:210) fixed bin (18);
dcl      have_auto_option bit (1) aligned;
dcl      have_auto_stmnt bit (1) aligned;
dcl      have_save_stmnt bit (1) aligned;
dcl      have_static_option bit (1) aligned;
dcl      have_subscript bit (1);
dcl      hbound builtin;
dcl      i fixed bin (18);
dcl      ignore_bits bit (36) aligned;
dcl      ignore_octal_value bit (72) aligned;
dcl      ignore_symtab_entry fixed bin (2) int static options (constant) init (0);
dcl      ignore_value fixed bin (18);
dcl      impossible_align bit (2) aligned int static options (constant) init ("11"b);
dcl      impossible_class (0:7) bit (1) aligned int static options (constant) init ((3) (1)"0"b, "1"b, "0"b, (3) (1)"1"b);
dcl      in_list bit (1) aligned;
dcl      in_stmnt bit (1) aligned;
dcl      index builtin;
dcl      indx fixed bin (18);
declare	indx_type fixed binary (18);
dcl      initial_line fixed bin (18) int static options (constant) init (1);
dcl      inx fixed binary;
declare	io_control_type fixed binary (4);
dcl      jnx fixed binary;
dcl      keyword_index fixed bin (18);
dcl      label_args bit (1) aligned;
dcl      label_hash_table (0:210) fixed bin (18);
dcl      label_ptr fixed bin (18);
dcl      last_cur_statement fixed bin (18);
dcl      last_do fixed bin (18);
dcl      last_element fixed bin (18);
dcl      last_mode_keyword fixed bin (18) int static options (constant) init (20);
dcl      last_namelist fixed bin (18);
dcl      last_namelist_word_offset fixed bin (18);
dcl      last_paren_parsed fixed bin (18);
dcl      last_source_line fixed bin (18);
dcl      last_statement fixed bin (18);
dcl      last_statement_type fixed bin (18);
dcl      last_token fixed bin (18);
dcl      lbound builtin;
dcl      length builtin;
dcl      letters fixed bin (18) int static options (constant) init (1);
dcl      line_number fixed bin (18);
dcl      line_number_pic picture "zzzzz9";
dcl      line_numbered_text bit (1) aligned;
dcl      locate_symtab_entry fixed bin (2) int static options (constant) init (1);
dcl      logical_if_statement bit (1) aligned;
dcl      local_attributes bit (47) aligned;
dcl      ltrim builtin;
dcl      main_attr bit (47) aligned int static options (constant) init ("000000000000000000010000000000100000"b);
dcl      max builtin;
dcl      max_arglist fixed bin (18) int static options (constant) init (63);
dcl      max_stack fixed bin (18);
dcl      member_attr bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000110001000"b);
dcl      member_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111011101110000"b);
dcl      min builtin;
dcl      mod builtin;
dcl      mode_defined bit (52) aligned;
dcl      mode_type fixed bin (4);
dcl      must_have_label bit (1) aligned;
dcl      named_constant_ptr pointer;
dcl      named_constant_ptr_valid bit (1) aligned;
dcl      named_const_attr bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000000010000"b);
dcl      named_const_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111111111111101"b);
dcl      namelist_attr bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000001000000000000"b);
dcl      need_comma bit (1) aligned;
declare	need_ref bit (1) aligned;
dcl      new fixed bin (18);
dcl      next_line_index fixed bin (20);
dcl      next_statement_label fixed bin (18);
dcl      next_token bit (9) aligned;
dcl      no_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000000000000"b);
dcl      no_more_source fixed bin (18) int static options (constant) init (0);
declare	not_found bit (1) aligned;
dcl      null builtin;
dcl      number_of_dims fixed bin;
dcl      number_of_subs fixed bin;
dcl      old fixed bin (18);
dcl      op_code fixed bin;
dcl      1 other_segment_info aligned like compiler_source_info;
dcl      out_of_sequence fixed bin (18) int static options (constant) init (63);
dcl      p fixed bin (18);
dcl      param_attr bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000001000000"b);
dcl      param_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111110111011110110000"b);
dcl      param_ptr pointer;
dcl      param_variable_attrs bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000001001000"b);
dcl      parameter_statement fixed bin (18) int static options (constant) init (24);
dcl      paren_array (660) fixed bin (18);
dcl      paren_count fixed bin (18);
dcl      01 pending_entry (50) aligned,
	 02 entry_symbol fixed bin (18),
	 02 entry_stmnt bit (36 * size (statement));
dcl      pending_entry_cnt fixed bin;
dcl      produce_listing bit (1) aligned;
dcl      put_in_map bit (9) aligned int static options (constant) init ("100000000"b);
dcl      put_in_profile bit (9) aligned int static options (constant) init ("110000000"b);
dcl      reset_stack (max_stack) bit (36) aligned based (object_base);
dcl      return_value fixed bin (18);
dcl      return_value_param fixed bin (18);
dcl      round builtin;
dcl      rtrim builtin;
dcl      save_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000001000001000"b);
dcl      save_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111011111110000"b);
dcl      save_current_token fixed bin (18);
dcl      saved_number_of_crefs fixed bin (18);
dcl      scalar_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111100000110000"b);
dcl      search builtin;
dcl      seg_ptr pointer;
dcl      seg_chain_end_ptr pointer;
dcl      sign bit (9) aligned;			/* Refer to proc "convert_integer_constant" before using. */
dcl      size builtin;
dcl      source_info pointer;
dcl      source_len fixed bin (21);
dcl      source_ptr pointer;
dcl      src_info_ptr pointer;
dcl      stack (0:sys_info$max_seg_size - 1) fixed bin (18) based (object_base);
dcl      stack_base fixed bin (18);
dcl      stack_index fixed bin (18);
dcl      start_of_expression fixed bin (18);
dcl      start_of_node fixed bin (18);
dcl      statement_info bit (36 * size (statement)) aligned;
dcl      statement_label fixed bin (18);
dcl      statement_length fixed bin (18);
dcl      statement_offset fixed bin (20);
dcl      statement_type fixed bin (18);
dcl      string builtin;
dcl      st_copy char (1320) aligned;
dcl      st_lbl_type bit (2) aligned;
dcl      sub_ptr pointer;
dcl      subprogram_attributes bit (47) aligned;
dcl      subprogram_conflicts bit (47) aligned;
dcl      subprogram_op fixed bin;
dcl      subprogram_symbol fixed bin (18);
dcl      subroutine_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000110000000000100000"b);
dcl      subroutine_conflicts bit (47) aligned int static options (constant)
	    init ("11111111111111111111111111111010111111110111000"b);
dcl      subroutine_reference bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000101000000000000000"b);
dcl      subs_list (0:7) fixed bin (18);
dcl      subscript fixed bin (24);
dcl      substr builtin;
dcl      symbol_index fixed bin (18);
dcl      symbol_length fixed bin (18);
dcl      symp pointer;
dcl      temp pointer;
dcl      token bit (9) aligned;
dcl      token_length fixed bin (18);
dcl      token_offset fixed bin (18);
dcl      translate builtin;
dcl      type_conflicts bit (47) aligned int static options (constant)
	    init ("11111111111111111111111111110100011000000110000"b);
dcl      type_of_line fixed bin (18);
dcl      unknown_statement fixed bin (18) int static options (constant) init (62);
dcl      unspec builtin;
dcl      v_length_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000100000000000000010000001000"b);
dcl      value_0 fixed bin (18);
dcl      value_1 fixed bin (18);
dcl      value_7 fixed bin (18);
dcl      variable_attributes bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000000000000000000001000"b);
dcl      variable_conflicts bit (47) aligned int static options (constant)
	    init ("00000000000000000000000000111111111000000110000"b);
dcl      verify builtin;
dcl      word_offset fixed bin (18);
dcl      work bit (72) aligned;

dcl      1 do_blockif_stack (50) aligned,
	 2 label_ptr fixed binary (18),
	 2 clauses fixed binary (18),
	 2 count_op fixed binary (18),
	 2 line_number fixed binary (18),
	 2 do_loop bit (1) aligned,
	 2 else_seen bit (1) aligned;

dcl      1 word_align aligned based,
	 2 based_double float bin (63) unaligned;

dcl      1 token_list (1000) aligned,
	 2 type bit (9) unaligned,
	 2 pad bit (9) unaligned,
	 2 offset fixed bin (18) unaligned unsigned,
	 2 length fixed bin (10) aligned;

dcl      1 constant_array (500) aligned,
	 2 prec fixed bin (8) unaligned,
	 2 scale fixed bin (8) unaligned,
	 2 exponent fixed bin (8) unaligned,
	 2 length fixed bin (8) unaligned;

dcl      1 file_stack (0:32) aligned,
	 2 fs_seg_ptr ptr,				/* ptr to source_node for segment. */
	 2 fs_source_ptr ptr,			/* ptr to base of source segment. */
	 2 fs_end_of_line fixed bin (21),		/* offset of end of current line in source seg. */
	 2 fs_source_length fixed bin (21),		/* length in chars of source segment. */
	 2 fs_line_number fixed bin (18),		/* line number in source segment. */
	 2 fs_file_number fixed bin (8);		/* file number of source segment. */

dcl      1 token_structure aligned based (addr (st_copy)),
	 2 pad char (token_offset) unaligned,
	 2 token_string char (token_length) unaligned;

dcl      1 format_structure aligned based (addr (st_copy)),
	 2 pad char (6) unaligned,
	 2 format_string char (statement_length - 6) unaligned;

dcl      1 paren_info (100) aligned structure,
	 2 chain fixed bin (18),
	 2 position fixed bin (18),
	 2 begin_index fixed bin (18),
	 2 implied_loop bit (1);

%include fort_parameter;

declare	1 parameter_info aligned like parameter;

dcl      1 io_bits unaligned structure,
%include fortran_job_bits;
	dummy fixed bin (18);

%include format_tables;

/* format: off */
dcl	1 statement_attributes
			(64) aligned structure internal static options (constant),
	  2 statement_label_type
			bit (2) unaligned		/* Stmnt label is: executable, format, non-executable */
init (
			(28) (1)"11"b,		/* 1-28 */
			"01"b,			/* 29 */
			(3) (1)"01"b,		/* 30-32 */
			(4) (1)"01"b,		/* 33-36 */
			"10"b, "11"b,		/* 37&38 */
			(7) (1)"01"b,		/* 39-45 */
			"11"b,			/* 46 */
			(17) (1)"01"b,		/* 47-63 */
			"11"b),			/* 64 */
	  2 ok_second_statement
			bit (1) unaligned /* On if legal second stmnt for logical if stmnt. */ 
init (
			(28) (1)"0"b,		/* 1-28 */
			"1"b,			/* 29 */
			(3) (1)"0"b,		/* 30-32 */
			(4) (1)"1"b,		/* 33-36 */
			"0"b, "0"b,		/* 37&38 */
			(7) (1)"1"b,		/* 39-45 */
			"0"b,			/* 46 */
			(14) (1)"1"b,		/* 47-60 */
			"0"b, "1"b, "1"b, "0"b),	/* 61-64 */
	  2 need_label	bit (1) unaligned /* On if FOLLOWING stmnt must have a label. */ 
init (
			(28) (1)"0"b,		/* 1-28 */
			"1"b,			/* 29 */
			(3) (1)"0"b,		/* 30-32 */
			"1"b,			/* 33 */
			(5) (1)"0"b,		/* 34-38 */
			"1"b,			/* 39 */
			(7) (1)"0"b,		/* 40-46 */
			"1"b,			/* 47 */
			(5) (1)"0"b,		/* 48-52 */
			"1"b,			/* 53 */
			(11) (1)"0"b),		/* 54-64 */
	  2 cant_be_reached bit (1) unaligned		/* On if THIS statement is not reached by block if */
init (
			(29) (1)"1"b,		/* 1-29 */
			(3) (1)"0"b,		/* 30-32 */
			(32) (1)"1"b),		/* 33-64 */

	  2 cant_ref_label	bit (1) unaligned		/* ON if label on  this statment cant be referenced */
init (
			(29) (1)"0"b,		/* 1 -29 */
			(2) (1)"1"b,		/* 30-31 */
			(33) (1)"0"b),		/* 32-64 */
	  2 reserved	bit (12) unaligned init ((64) (1)""b),
						/* Unused. */
	  2 first_keyword	fixed bin (18) unaligned unsigned
						/* Beginning of program section for this stmnt. */
init (
			(11) 11,			/* 1-11 */
			(50) 12,			/* 12-61 */
			(3) 0);			/* 62-64 */

/* format: on */
/* Keyword character strings. */

dcl      keyword_table (64) char (28) varying internal static options (constant)
	    init ("program", "blockdata", "subroutine", "function", "integerfunction", "realfunction",
	    "doubleprecisionfunction", "complexfunction", "logicalfunction", "characterfunction", "implicit",
	    "dimension", "common", "equivalence", "integer", "real", "doubleprecision", "complex", "logical",
	    "character", "external", "intrinsic", "namelist", "parameter", "library", "save", "automatic",
	    "statement func. definition", "if", "elseif", "else", "endif", "goto", "call", "continue", "write",
	    "format", "data", "return", "rewind", "endfile", "read", "encode", "decode", "print", "entry", "stop",
	    "pause", "assign", "punch", "input", "backspace", "chain", "closefile", "margin", "openfile", "open",
	    "close", "inquire", "assignment", "do", "UNKNOWN", "SEQUENCE ERROR", "end");

/*	Statement			Key Label      Ok   Need 1st
	Type			Len Type      2nd  Label Key
	
	 1 Program		 7  Un   .    No   No    11
	 2 Block Data		 9  Un   .    No   No    11
	 3 Subroutine		10  Un   .    No   No    11
	 4 Function		 8  Un   .    No   No    11	= function_statement
	 5 Integer Function		15  Un   .    No   No    11
	 6 Real Function		12  Un   .    No   No    11
	 7 Double Precision Function	23  Un   .    No   No    11
	 8 Complex Function		15  Un   .    No   No    11
	 9 Logical Function		15  Un   .    No   No    11
	10 Character Function	17  Un   .    No   No    11
	11 Implicit		 8  Un   .    No   No    11	= after_subprogram
	12 Dimension		 9  Un   .    No   No    12
	13 Common			 6  Un   .    No   No    12
	14 Equivalence		11  Un   .    No   No    12   = equivalence_statement
	15 Integer		 7  Un   .    No   No    12	= first_mode_keyword
	16 Real			 4  Un   .    No   No    12
	17 Double Precision		15  Un   .    No   No    12
	18 Complex		 7  Un   .    No   No    12
	19 Logical		 7  Un   .    No   No    12
	20 Character		 9  Un   .    No   No    12	= last_mode_keyword
	21 External		 8  Un   .    No   No    12
	22 Intrinsic		 9  Un   .    No   No    12
	23 Namelist		 8  Un   .    No   No    12
	24 Parameter		 9  Un   .    No   No    12	= parameter_statement
	25 Library		 7  Un   .    No   No    12
	26 Save			 4  Un   .    No   No    12
	27 Automatic		 9  Un   .    No   No    12
	28 Statement Function Def	 0  Un   .    No   No    12	= asf_definition
	29 If (Arithmetic)		 2  Ex   .    Yes  Yes   12
	30 Elseif			 6  Un   .    No   No    12	= elseif_statement
	31 Else			 4  Un   .    No   No    12	= else_statement
	32 Endif			 5  Un   .    No   No    12
	33 Goto			 4  Ex   .    Yes  Yes   12
	34 Call			 4  Ex   .    Yes  No    12
	35 Continue		 8  Ex   .    Yes  No    12
	36 Write			 5  Ex   .    Yes  No    12
	37 Format			 6  Fmt  .    No   No    12
	38 Data			 4  Un   .    No   No    12
	39 Return			 6  Ex   .    Yes  Yes   12
	40 Rewind			 6  Ex   .    Yes  No    12
	41 Endfile		 7  Ex   .    Yes  No    12
	42 Read			 4  Ex   .    Yes  No    12
	43 Encode			 6  Ex   .    Yes  No    12
	44 Decode			 6  Ex   .    Yes  No    12	= decode_statement
	45 Print			 5  Ex   .    Yes  No    12
	46 Entry			 5  Un   .    No   No    12
	47 Stop			 4  Ex   .    Yes  Yes   12
	48 Pause			 5  Ex   .    Yes  No    12
	49 Assign To		 6  Ex   .    Yes  No    12
	50 Punch			 5  Ex   .    Yes  No    12
	51 Input			 5  Ex   .    Yes  No    12
	52 Backspace		 9  Ex   .    Yes  No    12
	53 Chain			 5  Ex   .    Yes  Yes   12
	54 Closefile		 9  Ex   .    Yes  No    12
	55 Margin			 6  Ex   .    Yes  No    12
	56 Openfile		 8  Ex   .    Yes  No    12
	57 Open			 4  Ex   .    Yes  No    12
	58 Close			 5  Ex   .    Yes  No    12
	59 Inquire		 7  Ex   .    Yes  No    12
	60 Assignment		 0  Ex   .    Yes  No    12	= assignment_statement
	61 Do			 2  Ex   .    No   No    12	= do_statement
	62 Unknown		 0  Ex   .    Yes  No     0	= unknown_statement
	63 Out of Sequence		 0  Ex   .    Yes  No     0	= out_of_sequence
	64 End			 0  Un   .    No   No     0	= end_line
*/


dcl      1 expression aligned based structure,
	 2 storage_info like symbol.storage_info unaligned,
						/* currently 5 bits */
	 2 allow_array_name bit (1) unaligned,
	 2 reset_arg_bit bit (1) unaligned,
	 2 needs_descriptors bit (1) unaligned,
	 2 not_scalar_ref unaligned structure,
	   3 subscripted_ref bit (1) unaligned,
	   3 array_name bit (1) unaligned,
	   3 not_simple_ref bit (1) unaligned,
	   3 substring_ref bit (1) unaligned,
	 2 not_constant bit (1) unaligned,
	 2 no_assumed_size_array bit (1) unaligned;

/* format: off */
/*		L E G E N D
		IN = set by caller to parse_expression
		OUT = set by parse_expression

			       allocate (IN)
			       |set (IN)
			       | referenced (IN)
			       | |passed_as_arg (IN - OUT)
			       | | initialed (IN)
			       | | |allow_array_name (IN)
			       | | | reset_arg_bit (IN)
			       | | | |needs_descriptors (IN) 
			       | | | | subscripted_ref (OUT)
			       | | | | |array_name (OUT)
			       | | | | | not_simple_ref (OUT)
			       | | | | | |substring_ref (OUT)
			       | | | | | | not_constant (OUT)
			       | | | | | | |no_assumed_size_array (IN)
			       ||||||||||||||	
			       ||||||||||||||
          Constant Names	       ||||||||||||||
			       vvvvvvvvvvvvvv */
declare	(
	any_expression	init ("101000000000000000000000000000000000"b),
	set_reference	init ("111000000000000000000000000000000000"b),
	input_element	init ("111001000000010000000000000000000000"b),
	output_element	init ("101001000000010000000000000000000000"b),
	string_target	init ("111001000000010000000000000000000000"b),
	string_source	init ("101001000000010000000000000000000000"b),
	arg_list_expr	init ("101101100000000000000000000000000000"b),
	darg_list_expr	init ("101101110000000000000000000000000000"b),
	simple_reference	init ("101000000000000000000000000000000000"b),
	format_reference	init ("101001000000010000000000000000000000"b),
	set_no_symbol_bits	init ("000000000000000000000000000000000000"b)
	)		bit (36) aligned int static options (constant);

/* format: on */

dcl      out bit (36) aligned;			/* for return value */

%include compiler_source_info;
%include fortran_io_consts;

/* THE PARSE PHASE BEGINS HERE. */

/* Initialize constants used by the entire phase. */

	addr (work) -> based_integer = 0;
	value_0 = create_constant (int_mode, work);
	default_unit_specifier = value_0;
	addr (work) -> based_integer = 1;
	value_1 = create_constant (int_mode, work);
	value_7 = 0;

	cur_segment = 0;				/* Used to chain the source nodes. */
	first_segment = 0;				/* Head of source node chain. */
	number_of_source_segments = 0;
	number_of_lines = 0;			/* count total number of lines parsed */
	last_source_line = 0;			/* insures comments print with following program unit */
	profile_size = 0;				/* counts number of profile entries required */
	unnamed_block_data_subprogram = 0;		/* keep track of whether or not one was compiled */
	from_data_parser = FALSE;			/* Used by get_next_token to suppress error msgs. */

	free_chain = 0;				/* Free initial "nodes". */
	max_stack = 0;				/* Number of words used in stack. */
	file_stack_depth = 0;			/* Current include file nesting depth. */
	shared_structure.incl_count = -1;		/* Count of include files used in this compilation. */

	subprogram_op = main_op;
	subprogram_attributes = main_attr;
	subprogram_conflicts = all_attributes;

	sign = ZERO;				/* Refer to procedure "convert_integer_constant" for explanation. */

	options.namelist_used = FALSE;
	line_numbered_text = shared_structure.options.has_line_numbers;
	produce_listing = string (shared_structure.options.listing) ^= ZERO;
	parameter_info.shared_pointer = shared_ptr;

/* the following makes a template for the statement node */

	unspec (statement_info) = ZERO;
	addr (statement_info) -> statement.op_code = stat_op;
	addr (statement_info) -> statement.next = (18)"0"b;
	addr (statement_info) -> statement.location = (18)"1"b;
	addr (statement_info) -> statement.statement = "00001"b;

/* SEGMENT LOOP. THIS LOOP IS EXECUTED ONCE FOR EACH SOURCE SEGMENT. */

	source_info = src_info_ptr;			/* Copy input argument. */
	source_ptr = source_info -> compiler_source_info.input_pointer;
						/* Points to source segment. */

	shared_structure.source_file_number, shared_structure.source_line_number = 0;
	do while (source_ptr ^= null);

	     source_len = source_info -> compiler_source_info.input_lng;

/* Build source node and save segment info. */

	     shared_structure.incl_count = shared_structure.incl_count + 1;

	     addr (statement_info) -> statement.file = shared_structure.incl_count;

	     number_of_source_segments = number_of_source_segments + 1;

	     if source_info -> compiler_source_info.segname = "" then
		i = 63 - divide (length (source_info -> compiler_source_info.dirname), chars_per_word, 17, 0);
	     i = 63
		-
		divide (length (source_info -> compiler_source_info.dirname)
		+ length (source_info -> compiler_source_info.segname), chars_per_word, 17, 0);

	     indx = create_node (source_node, size (source) - i);
						/* Pathname cannot be made longer. */

	     shared_structure.source_node_offset (incl_count) = indx;
	     shared_structure.incl_len (incl_count) = source_len;
	     shared_structure.incl_ptr (incl_count) = source_ptr;

	     if cur_segment = 0 then
		first_segment = indx;
	     else
		seg_ptr -> source.next = indx;

	     cur_segment = indx;
	     seg_chain_end_ptr, seg_ptr = addr (OS (cur_segment));

	     seg_ptr -> source.pathname = source_info -> compiler_source_info.dirname;
	     if source_info -> compiler_source_info.segname ^= "" then do;
		seg_ptr -> source.pathname = seg_ptr -> source.pathname || ">";
		seg_ptr -> source.pathname =
		     seg_ptr -> source.pathname || source_info -> compiler_source_info.segname;
	     end;

	     seg_ptr -> source.uid = source_info -> compiler_source_info.unique_id;
	     seg_ptr -> source.dtm = source_info -> compiler_source_info.date_time_modified;

/* Initialize the lex and get the first significant character in the segment. */

	     call statement_lex$initialize;		/* Sets "type_of_line", subr_options, segment_options */

	     if type_of_line = no_more_source		/* Abort if segment contains no statements. */
	     then do;
		call print_message (1);		/* segment contains no source code */
	     end;

/* SUBPROGRAM LOOP. EXECUTED ONCE FOR EACH SUBPROGRAM. */

	     do while (type_of_line ^= no_more_source);

/* INITIALIZATION REQUIRED FOR EACH SUBPROGRAM. */

/* Build a subprogram header for the subprogram's attributes. */

		cur_subprogram = create_node (subprogram_node, size (subprogram));
		sub_ptr = addr (OS (cur_subprogram));

		if last_subprogram ^= 0		/* Chain this header in with the others. */
		then do;
		     sub_ptr -> previous_subprogram = last_subprogram;
		     addr (OS (last_subprogram)) -> next_subprogram = cur_subprogram;
		end;
		else
		     first_subprogram = cur_subprogram;
		last_subprogram = cur_subprogram;

		if seg_ptr -> source.initial_subprogram = 0
						/* Set field as needed. */
		     then
		     seg_ptr -> source.initial_subprogram = cur_subprogram;

		sub_ptr -> first_polish = next_free_polish;
		sub_ptr -> subprogram.options = subr_options;
		last_statement = -1;		/* No previous statement. */
		subprogram_op = 0;			/* Not a function or subroutine yet. */
		alternate_return_index = 0;		/* argument to implement alternate return */


/* If a listing is to be produced, build the listing_info node */

		if produce_listing then do;
		     listing_info.next = next_free_listing;
						/* build forward chain */

		     cur_listing = addr (listing_seg (next_free_listing));
						/* point to new node */
		     unspec (listing_info) = ZERO;	/* initialize the node */
		     next_free_listing = next_free_listing + size (listing_info);

		     listing_info.subprogram = cur_subprogram;

		     listing_info.first_cref = number_of_crefs + 1;
		     listing_info.first_line = last_source_line + 1;
		end;


/* Initialize symbol and label hash tables, and zero count of compiler generated symbols. */

		unspec (hash_table) = ZERO;
		unspec (label_hash_table) = ZERO;
		cp_count = 0;			/* Count of compiler generated names. */
		cp_label_count = 0;			/* Count of compiler labels. */

		have_auto_stmnt = FALSE;		/* information about storage class statements */
		have_save_stmnt = FALSE;

/* Set up the default mode tables. The letters i thru n are integer. All others are real. */

		do i = 1 to 8;			/* The letters a thru h in each case. */
		     default_table (i) = attr_table (real_mode);
		     default_table (i + 26) = attr_table (real_mode);
		end;
		do i = 9 to 14;			/* The letters i thru n in each case. */
		     default_table (i) = attr_table (int_mode);
		     default_table (i + 26) = attr_table (int_mode);
		end;
		do i = 15 to 26;			/* The letters o thru z in each case. */
		     default_table (i) = attr_table (real_mode);
		     default_table (i + 26) = attr_table (real_mode);
		end;

		mode_defined = ZERO;		/* Nothing defined by the user. */

/* Initialize the parse of a subprogram. */

		must_have_label = FALSE;		/* Label not required for first executable statement. */
		assignment_statement_index = asf_definition;
						/* First apparent asgn stmnt might be st.func.def. */
		bypass_first_pending_entry = FALSE;	/* No need to bypass main entry. */
		pending_entry_cnt = 0;		/* No entries pending. */
		keyword_index = 1;			/* First statement may be anything. */
		do_index = 0;			/* Reset do loop stack. */
		stack_index = lbound (stack, 1);	/* Stack is initially empty. */

		stack_base = stack_index;		/* lex first statement separately because of special case below. */

		call statement_lex (statement_type);	/* Lex the first statement of a subprogram. */

/* Function statements of the form "mode*k function" look like mode statements
		   to the statement recognizer. Decide if initial mode st is really a func st. */

		allow_star_after = TRUE;		/* Allow either form of function statement. */

		if statement_type >= first_mode_keyword & statement_type <= last_mode_keyword
						/* a mode st */
		     then
		     if token_list (first_token).type = asterisk & first_token + 2 <= last_token then do;
			if token_list (first_token + 2).type = ident then
			     if substr (st_copy, token_list (first_token + 2).offset + 1, 8) = "function" then do;

/* Set stmnt type = function_statement + mode. Delete "function" chars. */

				statement_type = function_statement + (statement_type - first_mode_keyword + 1);
				call split_token (8, first_token + 2, TRUE);
				allow_star_after = FALSE;
						/* "*k" field must precede func name. */
			     end;
			     else
				;
			else			/* process potential character *(*) function */
			     if token_list (first_token + 1).type = left_parn
			     & token_list (first_token + 2).type = asterisk
			     & token_list (first_token + 3).type = right_parn
			     & token_list (first_token + 4).type = ident & first_token + 4 <= last_token then
			     if substr (st_copy, token_list (first_token + 4).offset + 1, 8) = "function" then do;

/* re-build the list as if we read 'CHARACTER FUNCTION f*(*) */
/* list looked like: (referenced to first_token)                                        */
/* token  -2    -1    0     1     2     3     4              */
/*      ----- -----   *     (     *     )   FUNCTIONvar      */
/* and moves to be:      (FUNCTION is deleted)               */
/* token  -2    -1    0     1     2     3     4              */
/*      ----- -----  var    *     (     *     )              */

/* Set stmnt type = function_statement + mode. Delete "function" chars. */

				statement_type = function_statement + (statement_type - first_mode_keyword + 1);

				call split_token (8, first_token + 4, TRUE);

				token_list (first_token + 0) = token_list (first_token + 4);
				token_list (first_token + 4) = token_list (first_token + 3);
				token_list (first_token + 3) = token_list (first_token + 2);
				token_list (first_token + 2) = token_list (first_token + 1);
				token_list (first_token + 1) = token_list (first_token + 3);
			     end;
		     end;

/* The first statement of a program unit specifies the type of subprogram. An end line at this point is
	   legal.  If the first statement is not a subroutine, function, or block data statement,
             then this is a main program and a "main statement" must be manufactured. */

		if statement_type >= after_subprogram then do;
		     main_entry_point_name = default_main_entry_point_name;
		     call build_main_program (build_symbol ((main_entry_point_name), main_attr, SET));
		end;

/* STATEMENT LOOP. EXECUTED ONCE FOR EACH STATEMENT OF A SUBPROGRAM, EXCEPT THE END LINE. */
/* Note - a subprogram consisting of only an end_line is diagnosed above. */

		do while (statement_type ^= end_line);

/* This removes some statement types from look up at appropriate time. */

		     if first_keyword (statement_type) > keyword_index then
			keyword_index = first_keyword (statement_type);
						/* "Shorten" the keyword list. */

/* Initialize for statement label processing. */

		     END_DO_RANGE = FALSE;		/* This stmnt is not the terminal stmnt of a do loop. */
		     st_lbl_type = statement_label_type (statement_type);

/* If this is the first executable statement, inhibit future recognition of s.f. defs.
			Also, if any s.f. defs. have been parsed, emit a label to prevent the
			execution of the s.f. defs. by erroneous means. */

		     if st_lbl_type = executable_label then
			if assignment_statement_index ^= assignment_statement then
			     call finish_sf_defs;

/* If the next statement is executable and there are any entries pending,
   process them now. */

		     if st_lbl_type = executable_label & pending_entry_cnt > 0 then
			call process_pending_entries;

/* Process statement label. "statement_label" is set by statement_lex; to zero if no label or value of label.
   All statement labels are entered in the label table. Only executable labels are checked when looking for
   the end of a do loop. Only executable stmnts are checked for missing labels. i.e. - the first executable
   statement after an unconditional transfer of control. */

		     if statement_label ^= 0 then do;
			statement_label = enter_label (st_lbl_type, statement_label, SET);
			addr (OS (statement_label)) -> label.not_referencable =
			     statement_attributes.cant_ref_label (statement_type);

			if produce_listing		/* mark cref node as a defining ref */
			then do;
			     if ^(addr (OS (statement_label)) -> label.referenced) then
				cross_reference (number_of_crefs - 1).line_no =
				     -cross_reference (number_of_crefs - 1).line_no;
			     else
				cross_reference (number_of_crefs).line_no =
				     -cross_reference (number_of_crefs).line_no;
			end;

			if st_lbl_type = executable_label then do;
			     END_DO_RANGE = "0"b;

/* check if this terminates any do loops 
   if so insure proper nesting of do loops and block if's and pop stack to terinating level */

			     do inx = do_index to 1 by -1 while (^END_DO_RANGE);
				if do_blockif_stack (inx).do_loop then
				     END_DO_RANGE = statement_label = do_blockif_stack (inx).label_ptr;
				if END_DO_RANGE then
				     do jnx = do_index to inx + 1 by -1;
					if do_blockif_stack (jnx).do_loop then
					     call print_message (183, do_blockif_stack (jnx).label_ptr);
					else
					     call print_message (184,
						ltrim (char (do_blockif_stack (jnx).line_number)));
				     end;
			     end;

			     if END_DO_RANGE then
				do_index = inx + 1;
			     must_have_label = need_label (statement_type);
						/* Reset need for label on following stmnt. */

			     call emit_operand (statement_label);
						/* Emit label operand and label operator. */
			     call emit_operator (label_op);
			end;
		     end;
		     else if st_lbl_type = executable_label then do;
						/* Executable stmnt without label */
			if must_have_label & statement_attributes.cant_be_reached (statement_type) then
			     call print_message (5);	/* statement cannot be referenced */
			must_have_label = need_label (statement_type);
		     end;

/* Reset global variables modified by the stmnt parsers. */

		     logical_if_statement = FALSE;	/* Statement is not a logical if statement. */
		     stack_base = stack_index;	/* Stack can only grow by resetting stack_base. */
		     current_token = first_token - 1;	/* First token of stmnt is next not current. */
		     go to parser (statement_type);	/* Actually case(statement_type) */

/* Input conditions true for all statement parsers:
	1. values of token, token_offset, and token_length are invalid at entry; parsers must get first token by
	   incrementing current_token; (i.e. - get_next_token(TRUE, ...))
	2. value of "statement_type" is valid when parser is entered;
	3. value of "statement_label" is valid when parser is entered (pointer to label operand for statement label);

   Output requirements for each statement parser:
	1. parser must position after last token processed to allow test for extraneous text;
*/

/* End of case(statement_type) */


missing_identifier:
		     call print_message (10, err_string ());
		     go to statement_parse_abort;

missing_right_paren:
		     call print_message (11, err_string ());
		     go to statement_parse_abort;

missing_slash:
		     call print_message (13, err_string ());
		     go to statement_parse_abort;

missing_left_paren:
		     call print_message (22, err_string ());
		     go to statement_parse_abort;

missing_comma:
		     call print_message (26, err_string ());
		     go to statement_parse_abort;

missing_equals_sign:
		     call print_message (49, err_string ());
		     go to statement_parse_abort;

missing_label:
		     call print_message (23, err_string ());
		     go to statement_parse_abort;

missing_keyword:
		     call print_message (40, err_string ());
		     go to statement_parse_abort;
invalid_keyword:
		     call print_message (66, err_string (), keyword_table (statement_type));
		     go to statement_parse_abort;

invalid_substring:
		     call print_message (195);
		     go to statement_parse_abort;

parse_done:					/* Check for extraneous text in statement. */
		     if current_token <= last_token then
			if token = right_parn	/* be more explicit if parenthesis */
			     then
			     call print_message (90);
			else
			     call print_message (6, keyword_table (statement_type));
						/* extra text */

statement_parse_abort:				/* If stmnt was a logical if, an exit operator must be emitted. */
		     if logical_if_statement then do;
			call emit_operator (exit_op);
		     end;

/* If current stmnt terminates a do loop, emit exit operators for each loop which is terminated, 
   but not if there is a block if seperating them */

		     if END_DO_RANGE then
			do do_index = do_index to 1 by -1
			     while (do_blockif_stack (do_index).do_loop
			     & statement_label = do_blockif_stack (do_index).label_ptr);
			     call emit_operator (exit_op);
			end;

/* Lex the next statement in the subprogram. Reexecute the loop if it is not an end_line. */

		     stack_index = stack_base;	/* Insure validity of what is on the stack. */
		     last_statement_type = statement_type;
		     call statement_lex (statement_type);
		end;				/* END OF STATEMENT LOOP. */

/* The following code is executed after a subprogram is completely parsed. */

		cur_statement = -1;			/* Suppress line number in error msgs. */

/* Check for main program, subroutine, function, or entry point without executable code. */

		if sub_ptr -> subprogram_type ^= block_data
		     & (assignment_statement_index ^= assignment_statement | pending_entry_cnt > 0) then
		     call process_pending_entries;

/* Terminate all unended do loops and block ifs for the code generator. */

		do i = do_index to 1 by -1;
		     if do_blockif_stack (i).do_loop then do;
			call emit_operator (exit_op);
			call print_message (8, do_blockif_stack (i).label_ptr);
		     end;
		     else do;
			call emit_operator (item_op);
			call emit_operator (eol_op);
			call print_message (178, ltrim (char (do_blockif_stack (i).line_number)));
		     end;
		end;

/* Generate a return stmnt if control would pass thru to end_line. Then generate an endunit operator. */

		if ^must_have_label & sub_ptr -> subprogram_type ^= block_data then do;
		     profile_size = profile_size + 1;
		     string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

		     call emit_return_op;
		     call emit_statement_op (addr (statement_info));
						/* NOT in profile or map */
		end;

		call emit_operator (endunit_op);

/* Indicate default storage class to storage allocator. */

		if ^have_auto_stmnt & ^have_save_stmnt then do;
		     if have_auto_option | have_static_option then
			sub_ptr -> default_is.static = have_static_option;
		     else
			sub_ptr -> default_is.static = shared_structure.options.user_options.static_storage;
		end;

		sub_ptr -> default_is.auto = ^sub_ptr -> default_is.static;

/* Save offset of last emitted halfword. */

		sub_ptr -> last_polish = next_free_polish - 1;


		call declaration_processor;


/* For listings, finish up the listing_info node */

		if produce_listing then do;
		     listing_info.last_cref = number_of_crefs;
		     last_source_line = number_of_lines;/* insures comments following endline are printed */
		end;

/* Get first significant character of next subprogram, if such exists. */

		call statement_lex$get_next_subprogram; /* Sets "type_of_line". */
	     end;					/* END OF SUBPROGRAM LOOP. */

/* The following code is executed after all subprograms in the current source segment have been parsed. */

	     source_info = addr (other_segment_info);	/* use separate area for second thru nth segments */

	     call get_next_source_seg (source_info);	/* Returns new source info ptr or null. */

	     if source_info = null then
		source_ptr = null;
	     else
		source_ptr = source_info -> compiler_source_info.input_pointer;
	end;					/* END OF SEGMENT LOOP. */

/* if there is an entry name chain, insure it is separate from the symbol table */

	if last_entry_name ^= 0 then
	     addr (OS (last_entry_name)) -> symbol.next_symbol = 0;
	call check_entry_duplication;			/* Ensure no dups */

/* Zero the object segment. */

	unspec (reset_stack) = ZERO;
	return;

/* BEGIN  ext_parse section - PARSE - split 82-03-29  T. Oke */
/* Modification History:

83-02-10 HH - Install LA/VLA support.
82-06-28 TO.  Change INQUIRE keyword "filename=" to "file=" to conform to
	standard.
82-05-03 TO. Implement star_extent functions.
82-05-03 TO. Start on multiply_check option catching.
82-04-19 TO, Fix bug 287 in declaration_processor - create named_constant if
	static or automatic variable fit limits.  Stolen from optimizer.
82-04-05 TO, Fix bug 306 in get_equiv_var, by correctly throwing back a header
	node if equivalence cannot be made.
	*/

/* BEGIN case(statement_type) */

/* Case		Program

Syntax:	<program_name>

Polish:	<program_name> <count_op> <main_op> <eol_op>

Notes:	If present, must be the first statement in the source segment.
*/

parser (1):
	string (cur_stmnt_ptr -> statement.bits) = put_in_map;

	call get_next_token (force_symtab_entry, subprogram_symbol);
	if token ^= ident then
	     go to missing_identifier;

	call build_main_program (subprogram_symbol);
	current_token = current_token + 1;
	go to parse_done;

/* Case		Block Data

Syntax:	[ <block_data_subprog_name> ] 

Polish:	<non_executable> <block_data>

Notes:
	sub_ptr		points to subprogram header node in polish
	subprogram_op, etc	unchanged
	common_name used to hold the name (or "unnamed name) of sub_prog
	it is also used in the parsing of common statements.
*/
parser (2):
	call emit_operator (block_data_op);

	call get_next_token (ignore_symtab_entry, ignore_value);

	if token = EOS_token then do;
	     if unnamed_block_data_subprogram ^= 0 then
		call print_message (15);		/* duplicate unnamed block data subprograms */
	     unnamed_block_data_subprogram = cur_subprogram;
	     common_name = unnamed_block_data_subprg_name;
	end;
	else if token = ident then do;
	     common_name = token_string;
	     current_token = current_token + 1;
	end;
	else
	     goto missing_identifier;

	sub_ptr -> subprogram_type = block_data;
	SI, sub_ptr -> subprogram.symbol = build_symbol (common_name, no_attributes, SET);

/* if named block data, then indicate it's a user defined name.  build symbol assumes compiler generated names */

	if common_name ^= unnamed_block_data_subprg_name then
	     addr (OS (SI)) -> symbol.by_compiler = FALSE;

	go to parse_done;


/* Case		Subroutine

Syntax:	<subroutine_name> [ ( [ <parameter_list> ] ) ] <eos>

Polish:	<subroutine_name> <parameter_count> <subr>  [ <parameter> <item> ] <eol>

Notes:
	subprogram_attributes	same as a subroutine
	subprogram_conflicts	any and all attributes
	subprogram_op	subroutine opr
*/
parser (3):
	string (cur_stmnt_ptr -> statement.bits) = put_in_map;

	call get_next_token (force_symtab_entry, subprogram_symbol);
	if token ^= ident then
	     go to missing_identifier;

/* set fields in subprogram node */

	sub_ptr -> subprogram_type = subroutine;
	sub_ptr -> subprogram.symbol = subprogram_symbol;

/* set global variables for parameter list parse and entry statement parse */

	subprogram_op = subr_op;			/* This symbol and its entries are subroutines. */
	subprogram_attributes = subroutine_attributes;
	subprogram_conflicts = all_attributes;
	return_value_param = 0;			/* used if label args are in parameter list */

	call parse_parameter_list (subprogram_symbol);	/* emits all polish for stmnt and parses param list */
	go to parse_done;


/* Case		Function

Syntax:	[ <mode_keyword> [ <*> <K> ] ] <function_name> ( [ <parameter_list> ] ) <eos>

Polish:	<function_name> <func_count> <func> <parameter> <item> ... <return_value> <item> <eol>

Notes:
	<func_count> includes return value parameter
*/
parser (4):
parser (5):
parser (6):
parser (7):
parser (8):
parser (9):
parser (10):
	string (cur_stmnt_ptr -> statement.bits) = put_in_map;
	attributes = attr_table (statement_type - function_statement);

/* if mode keyword is provided, set function data type */

	if statement_type = function_statement then
	     allow_star_after = FALSE;		/* mode not specified, so "*k" is invalid */
	else if ^allow_star_after			/* i.e., "*k" must appear before name */
	     then
	     call get_mode_size (statement_type - function_statement, (default_char_size), attributes, asterisk_seen);

/* get name of function */

	call get_next_token (force_symtab_entry, return_value);
	if token ^= ident then
	     go to missing_identifier;

/* if alternate form is possible, check for "*k" */

	if allow_star_after then
	     call get_mode_size (statement_type - function_statement, (default_char_size), attributes, asterisk_seen);

/* function return value will be in hash table. Set accumulated attributes. */

	attributes = attributes | auto_attribute;	/* force auto storage for return value */
	if declare_symbol (return_value, attributes, all_attributes, DECLARED) then
	     ;					/* Error is impossible */

/* function name is not in hash table */

	subprogram_symbol = build_symbol (substr (full_name, 1, symbol_length), no_attributes, SET);
	addr (OS (subprogram_symbol)) -> symbol.by_compiler = FALSE;
						/* treat as user symbol */

/* function return value parameter */
/* do a little work on this to handle character*(*) functions. */

/* if the attributes of the symbol indexed by "return_value" have star_extents
   then set them here too, and set the return_value as being stack_indirect. */

	return_value_param = build_symbol ((NO_NAME), param_variable_attrs, SET);
	if addr (OS (return_value)) -> symbol.star_extents then do;
	     sub_ptr -> subprogram.star_extent_function = "1"b;
	     addr (OS (return_value)) -> symbol.stack_indirect = "1"b;
	     addr (OS (return_value_param)) -> symbol.star_extents = "1"b;
	     addr (OS (subprogram_symbol)) -> symbol.star_extents = "1"b;
	end;

/* set fields in subprogram node */

	sub_ptr -> subprogram_type = function;
	sub_ptr -> subprogram.symbol = subprogram_symbol;

/* set global variables for parameter list and entry statement parsers */

	subprogram_op = func_op;
	subprogram_attributes = function_attribute;
	subprogram_conflicts = entry_point_conflicts;

	call parse_parameter_list (subprogram_symbol);	/* emits all polish for stmnt and parses param list */

	go to parse_done;


/* Case		Implicit

Syntax:

Polish:

Notes:
*/
parser (11):					/* Parse each mode range separately. */
	in_stmnt = TRUE;
	do while (in_stmnt);

/* Get mode type and build attribute bit string. */

	     call get_next_token (ignore_symtab_entry, ignore_value);
	     if token ^= ident then
		go to missing_keyword;

	     if length (fast_lookup) - symbol_length > 0	/* pad with blanks when necessary */
		then
		substr (fast_lookup, symbol_length + 1, length (fast_lookup) - symbol_length) = NULL_STRING;

	     do i = first_mode_keyword to last_mode_keyword while (keyword_table (i) ^= fast_lookup);
	     end;

	     if i > last_mode_keyword then
		go to invalid_keyword;

	     attributes = attr_table (i - first_mode_keyword + 1);
	     call get_mode_size (i - first_mode_keyword + 1, (default_char_size), attributes, asterisk_seen);

/* Parse letter range(s). */

	     call get_next_token$operator;		/* Get left parenthesis. */
	     if token ^= left_parn then
		go to missing_left_paren;

	     in_list = TRUE;
	     do while (in_list);

/* get the first, or only letter in the range */

		call get_next_token (ignore_symtab_entry, ignore_value);
		if token ^= ident | symbol_length ^= 1 then do;
		     call print_message (45, err_string ());
		     go to statement_parse_abort;
		end;

		begin_char, end_char = index (alphabetic, substr (full_name, 1, 1));

/* there is a second letter if the first is followed by a hyphen */

		call get_next_token$operator;		/* get comma, right paren, or hyphen (minus) */
		if token = minus then do;
		     call get_next_token (ignore_symtab_entry, ignore_value);
		     if token ^= ident | symbol_length ^= 1 then do;
			call print_message (45, err_string ());
			go to statement_parse_abort;
		     end;

		     end_char = index (alphabetic, substr (full_name, 1, 1));

/* insure the range specified is valid */

		     if end_char < begin_char then do;
			call print_message (46);	/* chars wrong order */
			go to statement_parse_abort;
		     end;

		     if divide (begin_char - 1, 26, 17, 0) ^= divide (end_char - 1, 26, 17, 0) then do;
			call print_message (47);
			go to statement_parse_abort;
		     end;

		     call get_next_token$operator;	/* get comma or right paren */
		end;

/* regardless of how we got the range, see if it's been used before */

		if substr (mode_defined, begin_char, end_char - begin_char + 1) ^= ZERO then
		     call print_message (129);

		substr (mode_defined, begin_char, end_char - begin_char + 1) = (26)"1"b;

/* set range to desired type */

		do i = begin_char to end_char;
		     default_table (i) = attributes;
		end;
		if token ^= comma then
		     in_list = FALSE;
	     end;
	     if token ^= right_parn then
		go to missing_right_paren;

	     call get_next_token$operator;		/* get comma or eos */
	     if token ^= comma then
		in_stmnt = FALSE;
	end;
	go to parse_done;


/* Case		Dimension

Syntax:

Polish:

Notes:
*/
parser (12):
	in_list = TRUE;
	do while (in_list);
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= ident then
		go to missing_identifier;

	     if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		then
		call print_message (140, SI, (keyword_table (statement_type)));

	     call get_next_token$operator;		/* get left paren */
	     if token ^= left_parn then
		go to missing_left_paren;

	     call get_bounds (SI);
	     if token ^= comma then
		in_list = FALSE;
	end;
	go to parse_done;


/* Case		Common

Syntax:	[ / [ <name> ] / ] <list> [ / [ <name> ] / <list> ] ...

Polish:	<non_executable>

Notes:
	common_name	8 (?)-character name of common block, also used in block_data statement parse
	in_stmnt		on while parsing a common block list; off if current list not followed by another list
	SI		passes output from get_next_token to other subroutines
	indx		word offset of current common block header node
	in_list		on while conditions for loop still hold
*/
parser (13):
	call get_next_token (force_symtab_entry, SI);	/* Get slash or first member of list. */

	in_stmnt = TRUE;				/* Indicates more text left to parse. */
	do while (in_stmnt);			/* Loop for each common list. */

/* Get common block name. */

	     if token = slash			/* Name is given explicitly. */
	     then do;
		call get_next_token (ignore_symtab_entry, ignore_value);
						/* Get slash or block name. */

		if token ^= ident then
		     go to missing_identifier;
		common_name = substr (full_name, 1, symbol_length);
						/* save block name */

		call get_next_token$operator;		/* Get slash. */

		if token ^= slash then
		     go to missing_slash;

		call get_next_token (force_symtab_entry, SI);
						/* Get first member of list. */
	     end;
	     else if token = concat			/* Two slashes in a row */
	     then do;
		common_name = blank_common_name;
		call get_next_token (force_symtab_entry, SI);
	     end;
	     else
		common_name = blank_common_name;	/* initial common name is omitted */

/* Find header node if already defined or create a new one. */

	     indx = sub_ptr -> common_chain;		/* Get head of list. */
	     if indx = 0 then do;

/* create a header node for this common block and thread into chain */

		indx = build_common_block (common_name);
		sub_ptr -> common_chain = indx;
	     end;

	     else do;				/* List is not empty. */
		in_list = TRUE;
		do while (in_list);			/* Search the list. */
		     if addr (OS (indx)) -> header.block_name = common_name then
			in_list = FALSE;		/* Found old block. */
		     else if addr (OS (indx)) -> header.next_header = 0 then do;
						/* End of list and not found. Create a new header node. */
			in_list = FALSE;		/* Indicate end of search. */

			addr (OS (indx)) -> header.next_header = build_common_block (common_name);
			indx = addr (OS (indx)) -> header.next_header;
		     end;

		     else
			indx = addr (OS (indx)) -> header.next_header;
		end;
	     end;


/* If needed, generate cross reference nodes */

	     if produce_listing then
		call generate_cross_ref (indx);


/* Parse common block list. */

	     in_list = TRUE;
	     do while (in_list);
		if token ^= ident then
		     go to missing_identifier;

		if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		     then
		     call print_message (140, SI, (keyword_table (statement_type)));

		if declare_symbol (SI, member_attr, member_conflicts, DECLARED) then do;

/* Thread new member into common block list. */

		     if addr (OS (indx)) -> header.last_element = 0 then
			addr (OS (indx)) -> header.first_element = SI;
		     else
			addr (OS (addr (OS (indx)) -> header.last_element)) -> symbol.next_member = SI;
		     addr (OS (indx)) -> header.last_element = SI;

		     addr (OS (SI)) -> symbol.parent = indx;

/* insure it is initialized only in a block data subprogram */

		     if addr (OS (SI)) -> symbol.initialed then
			if sub_ptr -> subprogram_type = block_data then
			     string (addr (OS (indx)) -> header.storage_info) =
				string (addr (OS (indx)) -> header.storage_info)
				| string (addr (OS (SI)) -> symbol.storage_info);
			else
			     call print_message (80, SI);
		end;

		else
		     call print_message (20, SI, indx); /* Cannot be in this common block. */

/* Process member bound, next member, or end of list. */

		call get_next_token$operator;		/* Get left paren, comma, or slash. */
		if token = left_parn then
		     call get_bounds (SI);

		if token = comma then do;
		     call get_next_token (force_symtab_entry, SI);
						/* Get next member of list. */
		     if token = slash | token = concat then
			in_list = FALSE;
		end;
		else
		     in_list = FALSE;
	     end;
	     if token ^= slash & token ^= concat then
		in_stmnt = FALSE;
	end;
	go to parse_done;


/* Case		Equivalence

Syntax:

Polish:

Notes:
	78.06.20 - Parse has been changed so that symbol.equivalenced DOES NOT imply that symbol.parent
		is valid. symbol.equivalenced may be TRUE while symbol.parent equals zero.

	Automatic storage is equivalence conflict.
*/
parser (14):
	in_stmnt = TRUE;
	do while (in_stmnt);
	     call get_next_token$operator;		/* get left paren */
	     if token ^= left_parn then
		go to missing_left_paren;

	     if token_list (current_token + 2).type = right_parn then do;
		call print_message (28);		/* at least two required in group */
		go to statement_parse_abort;
	     end;

	     call stack_operand ((cur_statement));	/* For error messages. */

	     in_list = TRUE;
	     do while (in_list);
		call get_next_token (force_symtab_entry, SI);
		if token ^= ident then
		     go to missing_identifier;

		E_token = SI;
		if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		     then
		     call print_message (140, SI, (keyword_table (statement_type)));
		else
		     addr (OS (SI)) -> symbol.in_equiv_stmnt, addr (OS (SI)) -> symbol.equivalenced,
						/* mark as equiv'd */
			addr (OS (SI)) -> symbol.variable = TRUE;
						/* must remain a variable */

		call stack_operand (SI);

		call get_next_token$paren_operator;	/* get comma, left paren, substring left paren, or right paren */

		if token = left_parn | token = substr_left_parn then do;

		     if token = left_parn		/* Parse subscripts */
			then
			call stack_operand (get_constant_offset (SI, FALSE));
						/* inhibit variable subscripts */

		     if token = substr_left_parn	/* Parse substring */
		     then do;
			if ^subr_options.ansi_77 then do;
			     call print_message (154);
			     goto statement_parse_abort;
			end;
			call stack_operand (0);

			call get_next_token (ignore_symtab_entry, SI);
			if token = dec_int then do;
			     E_start = binary (addr (st_copy) -> token_structure.token_string, 17);

/* Check the constant start is in range */
			     if (E_start < 1) then
				call print_message (155, SI, "Start has a length < 1.");
			     else if (E_start > addr (OS (E_token)) -> symbol.char_size + 1) then
				call print_message (155, SI, "Start > length.");
			     else
				call stack_operand (E_start - 1);

			     call get_next_token$operator;
			     if token = colon then do;

				call get_next_token (ignore_symtab_entry, SI);
				if token = dec_int then do;
				     E_finish = binary (addr (st_copy) -> token_structure.token_string);

/* Check if the constant finish is in range */
				     if (E_finish < E_start) then
					call print_message (155, SI, "Finish < start.");
				     if (E_finish > addr (OS (E_token)) -> symbol.char_size + 1) then
					call print_message (155, SI, "Finish > length.");
				     call get_next_token$operator;
				end;
				else if token ^= right_parn then
				     go to invalid_substring;
			     end;
			     else
				go to invalid_substring;
			     call get_next_token$operator;
			end;
			else if token = colon then do;
			     E_start = 1;
			     call stack_operand (E_start - 1);
			     call get_next_token (ignore_symtab_entry, SI);
			     if token = dec_int then do;
				E_finish = binary (addr (st_copy) -> token_structure.token_string);
						/* Check if the constant finish is in range */
				if (E_finish < 1) then
				     call print_message (155, SI, "Finish < 1.");
				if (E_finish > addr (OS (E_token)) -> symbol.char_size + 1) then
				     call print_message (155, SI, "Finish > length.");
				call get_next_token$operator;
			     end;
			     else if token ^= right_parn then
				go to invalid_substring;
			     call get_next_token$operator;
			end;
			else
			     go to invalid_substring;
		     end;
		     else
			call stack_operand (0);
		end;
		else do;
		     call stack_operand (0);
		     call stack_operand (0);
		end;

		if token ^= comma then
		     in_list = FALSE;
	     end;

	     if token ^= right_parn then
		go to missing_right_paren;

	     call stack_operator (-1);		/* End of equivalence group. */
	     stack_base = stack_index;		/* Prevent the info from being lost. */

	     call get_next_token$operator;		/* get comma or eos */
	     if token ^= comma then
		in_stmnt = FALSE;
	end;
	go to parse_done;


/* Case		Character, Complex, Double Precision, Integer, Logical, Real

Syntax:	[ * k ] <name> [ * k ] [ ( d1 , ... dn ) ] ... [ / <constants> / ] ...

Polish:	<non_executable> [ <increment_polish_op> <halfword> <junk> ]
     where
	<halfword> is the number of halfwords in <junk>
	<junk> is the code representing the data specifications.

Notes:
	mode_type		mode, or data type, specified by this statement
	in_stmnt		on if data specifications are encountered; otherwise off
	char_siz		used only for char stmnt; global char size to be used
	attributes	attributes to be aplied to the variable being declared
	SI		passes output from get_next_token to other subroutines
*/
parser (15):
parser (16):
parser (17):
parser (18):
parser (19):
parser (20):
	mode_type = statement_type - first_mode_keyword + 1;
						/* Convert stmnt type to mode. */
	first_word = 0;				/* No "nodes" generated by data specs. */
	char_siz = default_char_size;			/* Only used if mode is character. */
	attributes = attr_table (mode_type);
	call get_mode_size (mode_type, char_siz, attributes, asterisk_seen);
						/* Get the global mode for this statement. */

	in_list = TRUE;
	do while (in_list);				/* Loop thru variable list. */
	     call get_next_token (force_symtab_entry, SI);/* Get variable name. */
	     if token ^= ident then
		go to missing_identifier;

	     if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		then
		call print_message (140, SI, (keyword_table (statement_type)));

	     local_attributes = attributes;
	     call get_mode_size ((mode_type), (char_siz), local_attributes, asterisk_seen);
						/* Get local attributes, but save global ones. */

	     call stack_operand (SI);			/* Stack it in case of data specifications. */

	     call get_next_token$operator;		/* Get left paren, slash, comma, or eos. */

	     if token = left_parn then do;
		call get_bounds (SI);		/* Declaring bounds in mode stmnt. */
		if ^asterisk_seen & mode_type = char_mode then do;
		     current_token = current_token - 1;
		     call get_mode_size ((mode_type), (char_siz), local_attributes, asterisk_seen);
		     call get_next_token$operator;
		end;
	     end /* left_parn */;
	     if ^declare_symbol (SI, local_attributes, type_conflicts, DECLARED) then
		call print_message (30, keyword_table (statement_type), SI);

	     if token = slash then
		call parse_data;			/* Data spec in mode stmnt. */

	     if token ^= comma then
		in_list = FALSE;			/* If no comma, list is done. */
	end;

/* If data specs generated "nodes" in polish, must indicate how many halfwords are used. */
	if first_word ^= 0 then
	     polish_string (first_word) = next_free_polish - first_word - 1;

	go to parse_done;


/* Case		External

Syntax:

Polish:

Notes:
*/
parser (21):
	in_list = TRUE;
	do while (in_list);
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= ident then
		go to missing_identifier;

	     if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		then
		call print_message (140, SI, (keyword_table (statement_type)));

/* In ansi66 mode, builtin functions may be declared in external statements */

	     if ^(sub_ptr -> subprogram.options.ansi_77) & (builtin_lookup (SI, NOT_SET)) then do;
		if ^declare_symbol (SI, no_attributes, bif_conflicts, DECLARED) then
		     call print_message (30, keyword_table (statement_type), SI);
		if (builtin_lookup (SI, SET_ATTR)) then do;
		     call get_next_token$operator;
		     in_list = (token = comma);
		end;
	     end;
	     else do;
		if ^declare_symbol (SI, ext_attributes, ext_conflicts, DECLARED) then
		     call print_message (30, keyword_table (statement_type), SI);

		call get_next_token$operator;		/* get comma, left paren, or eos */

/* the name may optionally be followed by "(descriptors)" */

		if token = left_parn then do;
		     call get_next_token (ignore_symtab_entry, ignore_value);
						/* get "descriptors" */
		     if token ^= ident | substr (full_name, 1, symbol_length) ^= "descriptors" then do;
			call print_message (044, "descriptors", err_string ());
			go to statement_parse_abort;
		     end;

		     call get_next_token$operator;	/* get right paren */
		     if token ^= right_parn then
			go to missing_right_paren;

		     addr (OS (SI)) -> symbol.needs_descriptors = TRUE;
		     addr (OS (SI)) -> symbol.variable_arglist = TRUE;
		     call get_next_token$operator;	/* get comma or eos */
		end;

		if token ^= comma then
		     in_list = FALSE;
	     end;
	end;
	go to parse_done;

/* Case		Intrinsic

Syntax:	<fun> [,<fun>] where <fun> in a builtin function name

Polish:	None

Notes:	Check to see name is not referenced and no declaration conflicts.

*/
parser (22):
	in_list = TRUE;
	do while (in_list);
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= ident then
		goto missing_identifier;

	     if addr (OS (SI)) -> symbol.referenced	/* symbol previously used */
		then
		call print_message (140, SI, (keyword_table (statement_type)));

	     if ^declare_symbol (SI, no_attributes, bif_conflicts, DECLARED) then
		call print_message (30, keyword_table (statement_type), SI);

	     if ^builtin_lookup (SI, SET_ATTR)		/* name is not recognized as a builtin */
		then
		call print_message (93, SI);

	     call get_next_token$operator;		/* get comma or EOS */
	     in_list = (token = comma);
	end /* in_list loop */;
	goto parse_done;

/* Case		Namelist

Syntax:

Polish:

Notes:
	Not Audited.
*/
parser (23):
	call get_next_token$operator;			/* get slash */
	if token ^= slash then
	     go to missing_slash;

	in_stmnt = TRUE;
	do while (in_stmnt);
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= ident then
		go to missing_identifier;

	     if ^declare_symbol (SI, namelist_attr, all_attributes, DECLARED) then do;
		if last_statement_type = statement_type & last_namelist = SI then do;
		     word_offset = last_namelist_word_offset;
		     next_free_polish = cur_statement;
		     cur_statement = last_cur_statement;
		end;
		else
		     call print_message (30, keyword_table (statement_type), SI);
	     end;
	     else do;
		call emit_operator (increment_polish_op);
		call emit_count (word_offset);
		polish_string (word_offset) = 0;	/* count will always be correct */
		addr (OS (SI)) -> symbol.initial = word_offset;
	     end;

	     last_namelist = SI;
	     last_namelist_word_offset = word_offset;

	     call get_next_token$operator;		/* get slash */
	     if token ^= slash then
		go to missing_slash;

	     in_list = TRUE;
	     do while (in_list);
		call get_next_token (force_symtab_entry, SI);
		if token ^= ident then
		     go to missing_identifier;

		if ^declare_symbol (SI, variable_attributes, variable_conflicts, REF) then
		     call print_message (10, SI);

		call emit_operand (SI);		/* list is saved in the polish */
		polish_string (word_offset) = polish_string (word_offset) + 1;
						/* keep count accurate */

		call get_next_token$operator;		/* get comma, slash, or eos */
		if token ^= comma then
		     in_list = FALSE;
	     end;
	     if token ^= slash then
		in_stmnt = FALSE;
	end;
	go to parse_done;


/* Case		Parameter

Syntax:

Polish:

Notes:
	Not Audited.
*/
parser (24):
	call get_next_token (force_symtab_entry, SI);
	in_list = TRUE;

/* To de-implement the old style PARAMETER statement, delete the block of
   code at old_parameter_stmt, and replace the following statement with:

	if token ^= left_parn then go to missing_left_paren;

*/

	if token ^= left_parn then
	     go to old_parameter_statement;

/* New style parameter statement.  Using parse_expression, while round-about
   insures consistency of expression interpretation with what would be done
   at run-time.
*/

	parameter_info.start_of_polish = next_free_polish;

	do while (in_list);
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= ident then
		go to missing_identifier;

	     if ^declare_symbol (SI, named_const_attr, named_const_conflicts, DECLARED) then do;
		call print_message (30, "named constant", SI);
		SI = 0;				/* indicates an error. */
	     end;
	     current_parameter = SI;

	     call get_next_token$operator;		/* get equals  */
	     if token ^= assign then
		go to missing_equals_sign;

	     call get_next_token (force_symtab_entry, SI);

	     call parse_expression (any_expression, SI, ignore_bits);

	     if current_parameter > 0 then do;
		call assign_data_type (current_parameter);

		param_ptr = addr (OS (current_parameter));
		parameter_info.stack_index = stack_index;
		parameter_info.max_stack = max_stack;
		parameter_info.desired_data_type = index (string (param_ptr -> symbol.mode), "1"b);
		parameter_info.end_of_polish = next_free_polish - 1;
		parameter_info.rounding = subr_options.do_rounding;

		call fort_eval_parm (addr (parameter_info), (param_ptr -> symbol.name), error_code);
		max_stack = parameter_info.max_stack;

		if error_code = 0 then do;

/* non-star-extent character parameters require different treatment, since the string must be padded or truncated
   or padded with blanks to make it of the declared length */

		     if param_ptr -> symbol.mode.character then do;

/* for star extent stuff, set the length to the length of the calculated string, otherwise pad on the right
   with blanks or truncated to set to declared length */

			if param_ptr -> symbol.star_extents then do;
			     param_ptr -> symbol.initial = parameter_info.result_location;
			     param_ptr -> symbol.star_extents = "0"b;
			     param_ptr -> symbol.mode_bits.char_size =
				addr (OS (parameter_info.result_location)) -> char_constant.length - 1;
			end;
			else do;
			     param_ptr -> symbol.initial =
				create_char_constant (
				substr (addr (OS (parameter_info.result_location)) -> char_constant.value
				|| copy (" ", max_char_length), 1, param_ptr -> symbol.mode_bits.char_size + 1));
			end;
		     end /* character parameters */;

		     else do;
			param_ptr -> symbol.initial = parameter_info.result_location;
		     end /* non_character params */;

		end /* error_code = 0 */;

		else do;
		     param_ptr -> symbol.initial = 0;
		end /* non_zero error_codes */;


	     end;

	     next_free_polish = parameter_info.start_of_polish;

	     if token ^= comma then
		in_list = FALSE;
	end;

	if token ^= right_parn then
	     go to missing_right_paren;
	current_token = current_token + 1;		/* Skip over the right paren. */

	go to parse_done;

old_parameter_statement:
	first_time = TRUE;

	do while (in_list);
	     if ^first_time then
		call get_next_token (force_symtab_entry, SI);
	     first_time = FALSE;

	     if token ^= ident then
		go to missing_identifier;

	     if ^declare_symbol (SI, named_const_attr, all_attributes, DECLARED) then do;
		call print_message (30, "named constant", SI);
		SI = 0;				/* indicates an error */
	     end;

	     call get_next_token$operator;		/* get equals */
	     if token ^= assign then
		go to missing_equals_sign;

	     call get_next_token (ignore_symtab_entry, const_index);
						/* get constant or sign */

	     call parse_a_constant (FALSE, const_index, ignore_octal_value);
						/* FALSE= octal is invalid */

	     if SI > 0 then
		addr (OS (SI)) -> symbol.initial = const_index;
						/* store it only if valid */

	     call get_next_token$operator;		/* get comma or eos */
	     if token ^= comma then
		in_list = FALSE;
	end;
	go to parse_done;


/* Case		Library

Syntax:

Polish:

Notes:
*/
parser (25):
	call get_next_token (ignore_symtab_entry, const_index);

	if token ^= char_string then do;
	     call print_message (53, err_string ());	/* missing char ref */
	     go to statement_parse_abort;
	end;

	if options.compile_only			/* If compiling, call our own routine. */
	     then
	     call add_to_lib_list (addr (OS (const_index)) -> char_constant.value, code);
	else
	     call add_to_lib_list_run (addr (OS (const_index)) -> char_constant.value, code);

	if code ^= 0 then
	     call print_message (54);			/* illegal pathname */
	current_token = current_token + 1;
	go to parse_done;


/* Case		Save

Syntax: <eos> | <save-element> [,<save-element>]
	where save-element is an array-name, a variable-name, or /common-block-name/

Polish: None

Notes: This statement serves to set the save attributes for a symbol.
*/
parser (26):					/* Save statements and automatic statements cannot co-exist in a program unit. */
	if have_auto_stmnt then do;
	     call print_message (38);
	     go to statement_parse_abort;
	end;

/* If there is no list, this is a global save statement. */

	if current_token >= last_token then do;
	     if have_save_stmnt then
		call print_message (33);		/* global save must be only save stmnt */
	     else
		sub_ptr -> default_is.static = TRUE;

	     have_save_stmnt = TRUE;

	     current_token = current_token + 1;
	     go to parse_done;
	end;

/* Particular save statement may not follow global one. */

	if sub_ptr -> default_is.static then
	     call print_message (33);			/* global save statement already encountered */
	else
	     sub_ptr -> default_is.auto = TRUE;

	have_save_stmnt = TRUE;

/* Parse list of variable names. */

	in_list = TRUE;
	do while (in_list);
	     call get_next_token (force_symtab_entry, SI);

/* if this is a common-block-name, add a header if not there already. header.first_element will be zero */

	     if token = slash then do;
		call get_next_token (ignore_symtab_entry, ignore_value);
		if token ^= ident then
		     goto missing_identifier;
		common_name = substr (full_name, 1, symbol_length);
		not_found = TRUE;
		indx = sub_ptr -> common_chain;

		do while (indx ^= 0 & not_found);
		     if substr (addr (OS (indx)) -> header.block_name, 1, symbol_length) = common_name then
			not_found = FALSE;
		     else
			indx = addr (OS (indx)) -> header.next_header;
		end /* search loop for common-block-name */;

/* if not found, then add the header to the end of the chain of headers (or to the start if this is the first header). */

		if not_found then do;
		     SI = build_common_block (common_name);
		     if sub_ptr -> common_chain = 0 then
			sub_ptr -> common_chain = SI;
		     else
			addr (OS (indx)) -> header.next_header = SI;
		end;
		call get_next_token$operator;
		if token ^= slash then
		     goto missing_slash;
	     end;
	     else if token ^= ident then
		go to missing_identifier;

	     else do;
		if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		     then
		     call print_message (140, SI, (keyword_table (statement_type)));

		if ^declare_symbol (SI, save_attributes, save_conflicts, DECLARED) then
		     call print_message (30, keyword_table (statement_type), SI);
	     end;
	     call get_next_token$operator;		/* get comma or eos */
	     if token ^= comma then
		in_list = FALSE;
	end;
	go to parse_done;


/* Case		Automatic

Syntax:

Polish:	non_executable {increment_polish_op}

Notes:
	Not audited.
*/
parser (27):					/* save and automatic statements cannot co-exist in a single program unit */
	if have_save_stmnt then do;
	     call print_message (38);
	     go to statement_parse_abort;
	end;

	have_auto_stmnt = TRUE;
	sub_ptr -> default_is.static = TRUE;


	in_list = TRUE;
	do while (in_list);				/* Loop thru variable list. */
	     call get_next_token (force_symtab_entry, SI);/* Get variable name. */
	     if token ^= ident then
		go to missing_identifier;

	     if addr (OS (SI)) -> symbol.referenced	/* Symbol has already been used */
		then
		call print_message (140, SI, (keyword_table (statement_type)));

	     if ^declare_symbol (SI, auto_attribute, save_conflicts, DECLARED) then
		call print_message (30, keyword_table (statement_type), SI);

	     call stack_operand (SI);			/* Stack it in case of data specifications. */

	     call get_next_token$operator;		/* Get left paren or comma. */

	     if token = left_parn then
		call get_bounds (SI);		/* Declaring bounds in automatic stmnt. */

	     if token ^= comma then
		in_list = FALSE;			/* If no comma, list is done. */
	end;

	go to parse_done;


/* Case		Statement Function Definition

Syntax:

Polish:

Notes:
	label_ptr		set in parse loop to point to stmnt's label node
	SI		st func name
	indx		arg as provided by user
	new		arg used by compiler
	old		previous member of hash chain for indx
*/
parser (28):
	saved_number_of_crefs = number_of_crefs;

	call get_next_token (force_symtab_entry, SI);
	if token ^= ident then
	     go to missing_identifier;

	if token_list (current_token + 1).type = left_parn & ^COLON_BEFORE_ASSIGN then
	     if declare_symbol (SI, asf_attribute, asf_conflicts, DECLARED) then do;

		profile_size = profile_size + 1;	/* profile entry required by this statement */
		string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

		current_token = current_token + 1;

/* The statement function definition (sfd) will now be placed in the polish string
		   using the expression parser. The fields, symbol.initial and symbol.dimension,
		   are used to store the offset of the first word of the sfd and the offset of
		   the first word after the sfd. If the sf is not referenced, these values are
		   used to "remove" the sfd from the polish string. */

		addr (OS (SI)) -> symbol.initial = next_free_polish;
						/* offset of first word. */

		call emit_operand (SI);
		call emit_operator (sf_def_op);
		last_element = 0;
		count = 0;

/* if the next token is a right_paren, then an empty arg list, no need to scan */
		in_list = (token_list (current_token + 1).type ^= right_parn);
		if ^in_list then
		     call get_next_token$operator;

		do while (in_list);
		     call get_next_token (locate_symtab_entry, indx);
		     if token ^= ident then
			go to missing_identifier;

		     count = count + 1;

		     if indx = 0 then
			call find_symbol_index (symbol_length, new, force_symtab_entry, old);
		     else do;
			call find_symbol_index (symbol_length, indx, force_symtab_entry, old);
			new = build_symbol (substr (full_name, 1, symbol_length),
			     unspec (addr (OS (indx)) -> symbol.mode_bits), DECLARED);
			addr (OS (new)) -> symbol.hash_chain = indx;

			if old > hbound (hash_table, 1) then
			     addr (OS (old)) -> symbol.hash_chain = new;
			else
			     hash_table (old) = new;
		     end;

		     if ^declare_symbol (new, auto_attribute, variable_conflicts, DECLARED) then
			call print_message (30, keyword_table (statement_type), new);
						/* conflicting attr. */

		     addr (OS (new)) -> symbol.parent = old;
		     addr (OS (new)) -> symbol.general = last_element;

		     addr (OS (new)) -> symbol.by_compiler = TRUE;
						/* flag as special symbol */
		     addr (OS (new)) -> symbol.dummy_arg = TRUE;
						/* flag as stmnt func param */

		     if last_element = 0 then
			addr (OS (SI)) -> symbol.next_member = new;
		     else
			addr (OS (last_element)) -> symbol.next_member = new;
		     last_element = new;

		     call get_next_token$operator;	/* get comma or right paren */
		     if token ^= comma then
			in_list = FALSE;
		end;
		if token ^= right_parn then
		     go to missing_right_paren;

		call get_next_token$operator;		/* get equals */
		if token ^= assign then
		     go to missing_equals_sign;

		call get_next_token (force_symtab_entry, indx);
		call parse_expression (any_expression, indx, ignore_bits);

		do i = last_element repeat addr (OS (i)) -> symbol.general while (i ^= 0);
		     if ^addr (OS (i)) -> symbol.referenced
						/* Check for unused parameter. */
		     then do;
			addr (OS (i)) -> symbol.allocate = TRUE;
			call print_message (68, i, SI);
		     end;

		     old = addr (OS (i)) -> symbol.parent;

		     if old > hbound (hash_table, 1) then
			addr (OS (old)) -> symbol.hash_chain = addr (OS (i)) -> symbol.hash_chain;
		     else
			hash_table (old) = addr (OS (i)) -> symbol.hash_chain;

		     addr (OS (i)) -> symbol.parent = SI;
		end;

		call emit_operator (exit_op);

		addr (OS (SI)) -> symbol.dimension = next_free_polish;
						/* offset of 1st word after sfd */

		if count > 511 then do;
		     call print_message (55, 511 - bias);
						/* implementation restriction */
		     count = 511;
		end;

		addr (OS (SI)) -> symbol.char_size = count;

		go to parse_done;
	     end;

/* Control passes this point only if the statement cannot be an asf def. Stmnt becomes an assignment. */

	call finish_sf_defs;			/* End of sf defs. Emit by-pass label. */

/* Process all pending entries now. */
	if pending_entry_cnt > 0 then
	     call process_pending_entries;

	current_token = first_token - 1;
	number_of_crefs = saved_number_of_crefs;

	if statement_label ^= 0 then do;
	     string (addr (OS (statement_label)) -> label.usage) = executable_label;
	     call emit_operand (statement_label);
	     call emit_operator (label_op);
	end;

	statement_type = assignment_statement;
	keyword_index = first_keyword (assignment_statement);

/* assignment statement parse code must follow. */


/* Case		Assignment

Syntax:

Polish:

Notes:
*/
parser (60):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);

/* test for the assignment being to the typeless function "fld".  This is the
only builtin function that can appear on the left hand side of an equal sign */

	if (addr (OS (SI)) -> symbol.name = "fld" & ^addr (OS (SI)) -> symbol.dimensioned
	     & token_list (current_token + 1).type = left_parn & ^addr (OS (SI)) -> symbol.mode.character) then do;
	     call get_next_token (force_symtab_entry, SI);/* swallow left paren */
	     call get_next_token (force_symtab_entry, SI);
	     do i = 1 to 2;
		call parse_expression (any_expression, SI, ignore_bits);
		if token ^= comma then
		     go to missing_comma;
		call get_next_token (force_symtab_entry, SI);
	     end;
	     call parse_expression (set_reference, SI, ignore_bits);
	     if token ^= right_parn then
		go to missing_right_paren;
	     call get_next_token (force_symtab_entry, SI);
	     if token ^= assign then
		go to missing_equals_sign;
	     call get_next_token (force_symtab_entry, SI);
	     call parse_expression (any_expression, SI, ignore_bits);
	     call emit_operator (lhs_fld_op);
	     go to parse_done;
	end;
	call parse_expression (set_reference, SI, ignore_bits);
	if token ^= assign then
	     go to missing_equals_sign;

	call get_next_token (force_symtab_entry, SI);
	call parse_expression (any_expression, SI, ignore_bits);
	call emit_operator (assign_op);
	go to parse_done;

/* Case		Elseif

Syntax:	elseif <left_parn> <expression> <right_parn> then

Polish: 	<item_op> <polish for expression> <else_if_op>

Notes:	Must check for proper nesting, but in most ways this is much like
the parsing of block if's, so we parse it the same way.  A new statement is
created for the logical expression and else_if_op for the benefit of profiling
and setting breakpoints.

*/

parser (30):					/* this stmnt NOT in profile or map */
	call emit_operator (item_op);			/* elseif's terminate previous block ifs */
	call emit_statement_op (cur_stmnt_ptr);		/* make new statement for if part */
						/* fall through to if parser */

/* Case		If

Syntax:	if <left_parn> <expression> <right_parn> <logical, block or arithmetic if>
	<logical if> ::= <some legit second statment>
	<arithmetic if>::= <a sequence of labels for jumps>
	<block if>::= then

Polish:

Notes:
*/

parser (29):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

/* Parse if statement expression. */

	call get_next_token$operator;			/* Get left paren. */
	if token ^= left_parn then
	     go to missing_left_paren;

	call get_next_token (force_symtab_entry, SI);	/* Get first token of expression. */
	call parse_expression (any_expression, SI, ignore_bits);
	if token ^= right_parn then
	     go to missing_right_paren;

	call get_next_token (ignore_symtab_entry, ignore_value);
						/* Get integer, comma, or statement keyword. */

/* Arithmetic-if statement if integer or comma, and not an ELSEIF. */

	if statement_type ^= elseif_statement & (token = dec_int | token = comma) then do;
	     if END_DO_RANGE & ^logical_if_statement then
		call print_message (16, keyword_table (statement_type));
						/* cannot terminate do loop */

/* Parse three target labels. */

	     do i = 1 to 3;
		if token = dec_int			/* label is given */
		then do;
		     call emit_operand (enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF));
		     call get_next_token$operator;	/* get comma or eos */
		end;

		else if token = comma | token = EOS_token
						/* label is omitted */
		then do;
		     must_have_label = FALSE;
		     call emit_count (ignore_value);
		end;

		else
		     go to missing_label;		/* syntax error */

/* Commas must appear between the labels, even if the labels are omitted. */

		if i < 3 then do;
		     if token ^= comma then
			go to missing_comma;

		     call get_next_token$label (ignore_symtab_entry, ignore_value);
		end;
	     end;
	     call emit_operator (jump_arithmetic_op);
	     go to parse_done;
	end;

/* Parse logical-if, block-if, and else-if statements. */

	if logical_if_statement then
	     call print_message (42, "logical if");	/* illegal second statement */

/* distinguish between logical if's and (block if's and else if's) */

	logical_if_statement =
	     statement_type ^= elseif_statement & (SECOND_EQUALS | substr (full_name, 1, token_length) ^= "then");
	must_have_label = FALSE;

	if logical_if_statement then do;
	     if SECOND_EQUALS then
		statement_type = assignment_statement;
	     else
		call statement_lex$recognize_statement (statement_type);
						/* Get second stmnt type. */

	     call emit_operator (jump_logical_op);

	     if ^ok_second_statement (statement_type) then
		call print_message (42, keyword_table (statement_type));
						/* illegal second statement */

/* Now process the second statement. In order to make the profile option work usefully, a second
	   stat_op will be generated in the polish. This allows separated counts for the if statement and
	   its then clause. */

	     call emit_statement_op (cur_stmnt_ptr);

	     profile_size = profile_size + 1;		/* profile entry required by this statement */
	     string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	     current_token = current_token - 1;		/* Backup lex for all parsers. */
	     go to parser (statement_type);
	end /* logical_if_statement */;

	else do;					/*  else if and block if */
	     if END_DO_RANGE then
		call print_message (16, keyword_table (statement_type));

	     if substr (full_name, 1, token_length) ^= "then"
						/* required keyword */
		then
		call print_message (179, "then", keyword_table (statement_type));

	     else if statement_type = elseif_statement then do;
		current_token = current_token + 1;

/* elseif must be nested in blockif's not do loops, peel off erroneous do's */

		do do_index = do_index to 1 by -1 while (do_blockif_stack (do_index).do_loop);
		     call print_message (182, do_blockif_stack (do_index).label_ptr, keyword_table (statement_type));
		end;

		if do_index = 0			/* insure that elseif follows a if at same level */
		     then
		     call print_message (180, keyword_table (statement_type));

		else if do_blockif_stack (do_index).else_seen
						/* cant follow else on same level */
		     then
		     call print_message (181, keyword_table (statement_type));

		else do;
		     call emit_operator (else_if_op);
		     do_blockif_stack (do_index).clauses = do_blockif_stack (do_index).clauses + 1;
		end;
	     end;
	     else do;
		if do_index = hbound (do_blockif_stack, 1)
						/* stack oflo */
		     then
		     call print_message (27, hbound (do_blockif_stack, 1) - bias);
		else do;				/* block if */
		     current_token = current_token + 1;
		     call emit_count (word_offset);
		     call emit_operator (block_if_op);

/* pop up the do_blockif_stack and set values */

		     do_index = do_index + 1;
		     do_blockif_stack (do_index).do_loop = "0"b;
		     do_blockif_stack (do_index).clauses = 1;
		     do_blockif_stack (do_index).line_number = line_number - 1;
		     do_blockif_stack (do_index).count_op = word_offset;
		     do_blockif_stack (do_index).else_seen = "0"b;
		end;
	     end;
	end /* block_if and else if */;
	goto parse_done;

/* Case		Else

Syntax:	else

Polish:	<item op> <else op>

Notes: 	An else clause if valid iff it exists within a block_if  and is nested properly
	within the do_blockif_stack, nor can it be the object of a GOTO .
*/
/* Case		Endif

Syntax: endif

Polish: <item_op> <eol_op>

Notes:  In addition to checking for the nesting of the block_if's and the do loops, the endif
        must also properly set the count in the count_op emitted by the block_if
*/

parser (31):
parser (32):
	profile_size = profile_size + 1;		/* profile entry required by these statements */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;
	current_token = current_token + 1;

	if END_DO_RANGE then
	     call print_message (16, keyword_table (statement_type));

	do do_index = do_index to 1 by -1 while (do_blockif_stack (do_index).do_loop);
	     call print_message (182, do_blockif_stack (do_index).label_ptr, keyword_table (statement_type));
	end;

	if do_index = 0				/* nesting check */
	     then
	     call print_message (180, keyword_table (statement_type));

	else if statement_type = else_statement then do;
	     if do_blockif_stack (do_index).else_seen	/* cant have > 1 else at same level */
		then
		call print_message (181, keyword_table (statement_type));
	     else do;
		call emit_operator (item_op);
		call emit_operator (else_op);
		do_blockif_stack (do_index).clauses = do_blockif_stack (do_index).clauses + 1;
		do_blockif_stack (do_index).else_seen = "1"b;
	     end;
	end;

	else do;					/* endif statement */
	     call emit_operator (item_op);
	     call emit_operator (eol_op);

/* having come to the end of the blockif, set count operator reserved by the block if and pop stack */

	     polish_string (do_blockif_stack (do_index).count_op) = do_blockif_stack (do_index).clauses - bias;
	     do_index = do_index - 1;
	end;

	goto parse_done;

/* Case		Goto

Syntax:

Polish:
*/
parser (33):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if END_DO_RANGE & ^logical_if_statement then
	     call print_message (16, keyword_table (statement_type));
						/* cannot terminate do loop */

/* First token of statement determines type of goto. */

	call get_next_token$label (force_symtab_entry, SI);
						/* Get label, name, or left paren. */

	if token = dec_int				/* UNCONDITIONAL GOTO */
	then do;
	     call emit_operand (enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF));
	     call emit_operator (jump_op);
	     current_token = current_token + 1;
	end;

	else if token = ident			/* ASSIGNED GOTO */
	then do;
	     if token_list (current_token + 1).type ^= left_parn then do;
		call parse_expression (simple_reference, SI, out);

		if addr (out) -> expression.not_simple_ref
						/* must check result ourselves */
		     then
		     call print_message (143, SI);
	     end;
	     else do;				/* Let parse expression do its trick */
		token_list (current_token + 1).type = comma;
						/* Tell a white lie */
		call parse_expression (simple_reference, SI, out);
		if addr (out) -> expression.not_simple_ref then
		     call print_message (143, SI);
		token, token_list (current_token).type = left_parn;
	     end;

	     call emit_operator (jump_assigned_op);

	     if token = comma then do;
		call get_next_token$operator;		/* get left paren */
		if token ^= left_parn then
		     go to missing_left_paren;
	     end;

	     if token = left_parn then do;
		call scan_label_list (FALSE);		/* Returns pointing to right paren. */
		current_token = current_token + 1;
	     end;
	end;

	else if token = left_parn			/* COMPUTED GOTO */
	then do;
	     call scan_label_list (TRUE);		/* Returns pointing to right paren. */
	     call get_next_token (force_symtab_entry, SI);
	     if token = comma then
		call get_next_token (force_symtab_entry, SI);
	     call parse_expression (any_expression, SI, ignore_bits);
	     call emit_operator (exit_op);
	     must_have_label = FALSE;			/* label not required after computed goto */
	end;

	else do;					/* syntax error */
	     call print_message (41, err_string ());	/* missing  int, ident, or left paren */
	     go to statement_parse_abort;
	end;
	go to parse_done;


/* Case		Call

Syntax:	<subroutine name> [ ( [ <subroutine arg list> ] ) ]

Polish:	<subroutine name> <arg count> <call_op> [ <arg_list> ] <eol_op>

Notes:
	SI	passes output from get_next_token to parse_expr
*/
parser (34):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);	/* Get subroutine name. */
	if token ^= ident then
	     go to missing_identifier;

	if ^declare_symbol (SI, subroutine_reference, subroutine_conflicts, REF) then
	     call print_message (21, SI);

/* if the arg list contains label constants, must initialize alt ret value */

	if label_args then do;
	     if alternate_return_index = 0		/* first ref so create it */
		then
		alternate_return_index = build_symbol ((NO_NAME), auto_attribute | attr_table (int_mode), PASSED);

	     call emit_operand (alternate_return_index);
	     call emit_operand (value_0);
	     call emit_operator (assign_op);
	end;

/* emit polish for a call statement */

	call emit_operand (SI);
	call emit_count (word_offset);
	call emit_operator (call_op);

/* parse the argument list */

	call get_next_token$operator;			/* Get left paren or eos. */

	if token = left_parn then do;
	     count = 0;

	     if addr (OS (SI)) -> symbol.needs_descriptors then
		arg_type = darg_list_expr;
	     else
		arg_type = arg_list_expr;

	     in_list = (token_list (current_token + 1).type ^= right_parn);
	     if ^in_list then
		call get_next_token$operator;

	     do while (in_list);
		call get_next_token (force_symtab_entry, indx);
						/* Get next argument. expression or label const */

		if token = label_const then do;
		     call stack_operand (indx);
		     call get_next_token$operator;	/* get comma or right paren */
		end;
		else do;
		     call parse_expression (arg_type, indx, ignore_bits);
		     call emit_operator (item_op);
		     count = count + 1;
		end;

		if token ^= comma then
		     in_list = FALSE;
	     end;

	     if token ^= right_parn then
		go to missing_right_paren;
	     current_token = current_token + 1;		/* skip over paren */

/* if there are label args, include alt ret value in arg list */

	     if label_args then do;
		call emit_operand (alternate_return_index);
		call emit_operator (item_op);
		count = count + 1;
	     end;

/* check number of arguments and update count word */

	     if count > max_arglist then
		call print_message (138, max_arglist - bias, SI);

	     polish_string (word_offset) = count - bias;
	end;

	call emit_operator (eol_op);			/* terminate call arg list */

/* alternate return is implemented as computed goto */

	if stack_index - stack_base > 0 then do;
	     call emit_halfword ((stack_index - stack_base) - bias);
						/* count of labels */
	     call emit_operator (jump_computed_op);

	     do i = stack_base to stack_index - 1;	/* copy the labels into the polish */
		call emit_operand (stack (i));
		call emit_operator (item_op);
	     end;
	     call emit_operator (eol_op);		/* end of the list */

	     call emit_operand (alternate_return_index);	/* computed goto expression */
	     call emit_operator (exit_op);		/* end of expression */
	end;
	go to parse_done;


/* Case		Continue

Syntax:

Polish:

Notes:
*/
parser (35):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	current_token = current_token + 1;
	go to parse_done;


/* Case		Write

Syntax:

Polish:

Notes:
*/
parser (36):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call parse_io (FALSE);
	go to parse_done;


/* Case		Format

Syntax:

Polish:

Notes:
*/
parser (37):
	if statement_label = 0 then
	     call print_message (37);			/* format statement without label */

	call create_format (format_string, statement_label);
	current_token = last_token + 1;
	go to parse_done;


/* Case		Data

Syntax:

Polish:

Notes:
	The stack is built up with a series of "nodes", which are then interpreted by parse_data as it works its way 
	through the list of data elements.  The first word of each node determines what type of node it is.  A node may
	be any of the following:

	(1) a scalar variable node, which corresponds to the appearance of a scalar variable in the target list.
	It consists of a single word containing the index of the symbol node of the variable.

	(2) an array name node, which corresponds to the appearance of an array name in the target list.  It
	consists of a single word containing the index of the symbol node of the array.

	(3) a BEGIN_DO_LOOP node, which corresponds to the start of an implied do-loop in the target list.  It
	consists of 8 or more words.  The first word contains BEGIN_DO_LOOP, the code for this type of node.  The
	second word contains the index of the symbol node for the index variable of the loop.  The remaining words
	contain the Polish for the initial, final and increment expressions of the loop.  The first word of each
	expression is not part of the Polish, but rather the count of the number of following words which are the
	Polish.  The Polish is slightly nonstandard in that a variable (which must be an index of a containing
	implied loop) is represented by a negative value whose absolute value is the index in the stack of the
	symbol node index of the BEGIN_DO_LOOP node for the implied loop having the variable as its index. (Note
	that 'parse_data' will keep the current value of the loop index in that same location.)

	(4) an END_DO_LOOP node, which corresponds to the end of an implied do-loop in the target list.  It
	consists of a single word containing END_DO_LOOP, the code for this type of node.

	(5) a SUBSTRING node, which corresponds to a substring of a variable in the target list.  It consists
	of 6 or more words.  The first contains SUBSTR, the code for this type of node.  The second contains
	the index of the symbol node for the variable.  The remaining words contain the Polish (in the same
	format as the expressions in a BEGIN_DO_LOOP node) for the start and finish positions of the substring.

	(6) a SUBSCRIPTED_VAR node, which corresponds to a subscripted variable in the target list.  It
	consists of 6 or more words.  The first contains SUBSCRIPTED_VAR, the code for this type of node.
	The second contains the index of the symbol node for the variable.  The remaining words contain the
	Polish for the subscript expressions, in the same format as the expressions in a BEGIN_DO_LOOP node.

	(7) a SUBSCRIPTED_SUBSTR node, which corresponds to a substring of a subscripted variable in the target
	list.  It consists of 10 or more words.  The first contains SUBSCRIPTED_SUBSTR, the code for this type
	of node.  The second contains the index of the symbol node for the variable.  The remaining words contain
	the Polish for the subscript expressions, followed by the Polish for the start and finish positions of the
	substring.

	(8) a SKIP node, which corresponds to a substring, subscripted variable or subscripted substring
	in the target list in which an error was detected.  It consists of a single word containing SKIP,
	the code for this type of node.

	Note that the codes for node types (3) through (8) above are less than or equal to zero so that they can be
	distinguished from node types (1) and (2), which are always positive.
*/
parser (38):
	first_word = 0;				/* No "nodes" generated by data specs. */
	last_paren_parsed = 0;			/* indicates no pre-scan has occurred */

/* Parse each set of variables and constants separately. */

	in_stmnt = TRUE;
	do while (in_stmnt);

	     do_level = 0;				/* no implied do loops encountered */
	     last_do = 0;				/* ditto */

/* Parse variables, subscripted references, and implied do loops. */

	     in_list = TRUE;
	     do while (in_list);

/* Parse left paren or variable. */

		call get_next_token (force_symtab_entry, SI);

/* left paren must delimit an implied do loop */

		if token = left_parn then
		     if is_implied_loop () then do;
			save_current_token = current_token;
						/* remember current token position */
			current_token = paren_info (cur_paren).begin_index;
						/* move up to loop code */

			call stack_operator (BEGIN_DO_LOOP);
						/* stack begin loop operator */
			if do_level = hbound (do_info, 1) then do;
			     call print_message (89, hbound (do_info, 1) - bias);
						/* do loop nesting is too deep */
			     go to statement_parse_abort;
			end;
			else
			     do_info (do_level + 1) = stack_index;
						/* stack pointer to do loop info */

/* process new do loop index variable */

			call get_next_token (force_symtab_entry, indx);
			if token ^= ident then
			     go to missing_identifier;

			do i = 1 to do_level;	/* check for reused index variable */
			     if stack (do_info (i)) = indx then do;
				call print_message (18, indx);
						/* reused loop index */
				go to statement_parse_abort;
			     end;
			end;

			call stack_operand (indx);	/* stack loop index variable */

/* index must be scalar integer variable */

			if addr (OS (indx)) -> symbol.dimensioned then
			     call print_message (141, indx);
			else if (unspec (addr (OS (indx)) -> symbol.attributes) & scalar_conflicts) ^= ZERO then
			     call print_message (141, indx);
			else do;
			     call assign_data_type (indx);
			     if ^addr (OS (indx)) -> symbol.integer then
				call print_message (141, indx);
			end;

			call get_next_token$operator;

/* get equals */
			if token ^= assign then
			     go to missing_equals_sign;

/* Get and stack the initial, final and increment expressions. */
			start_of_expression = stack_index;
			call get_data_statement_expression;
			if stack (start_of_expression) = 0 then
			     goto statement_parse_abort;
			if token ^= comma then
			     go to missing_comma;
			start_of_expression = stack_index;
			call get_data_statement_expression;
			if stack (start_of_expression) = 0 then
			     goto statement_parse_abort;
			if token = comma then do;
			     start_of_expression = stack_index;
			     call get_data_statement_expression;
			     if stack (start_of_expression) = 0 then
				goto statement_parse_abort;
			end;
			else do;			/* Assume increment of 1. */
			     call stack_operand (1);
			     call stack_operand (value_1);
			end;

			if token ^= right_parn then
			     go to missing_right_paren;

			paren_info (cur_paren).position = current_token;
						/* remember end of loop code */
			current_token = save_current_token;
						/* restore scan to proper position */

			last_do = cur_paren;
			do_level = do_level + 1;	/* put this implied loop on stack */
		     end /* is implied do_loop */;

		     else do /* not implied do_loop */;
			call print_message (34);	/* syntax error in do loop */
			go to statement_parse_abort;
		     end;

		else do /* not a left_parn */;
		     if token ^= ident then
			go to missing_identifier;

		     call get_next_token$paren_operator;/* Get left paren, comma, or slash. */

/* Stack variable, substring, subscripted variable, or subscripted substring reference. */

		     symp = addr (OS (SI));
		     if token = left_parn | token = substr_left_parn then do;
						/* substr, subscripted variable or subscripted substring */
			error = FALSE;
			start_of_node = stack_index;
			if token = substr_left_parn then do;
			     call stack_operand (SUBSTR);
			     call stack_operand (SI);
			end;
			else do;
			     call stack_operand (SUBSCRIPTED_VAR);
			     call stack_operand (SI);
			     dp = null;
			     number_of_dims, number_of_subs = 0;
			     if ^symp -> symbol.dimensioned then do;
				call print_message (76, SI);
				error = TRUE;
			     end;
			     else if symp -> symbol.variable_extents then do;
				call print_message (77, SI);
				error = TRUE;
			     end;
			     else do;
				dp = addr (OS (symp -> symbol.dimension));
				number_of_dims = dp -> dimension.number_of_dims;
			     end;

			     have_subscript = TRUE;
			     do while (have_subscript);
				number_of_subs = number_of_subs + 1;
				start_of_expression = stack_index;
				call get_data_statement_expression;
				if stack (start_of_expression) = 0 then
				     error = TRUE;
				else if number_of_subs <= number_of_dims & stack (start_of_expression) = 1
				     & stack (start_of_expression + 1) > last_assigned_op then do;
						/* Verify constant subscript is in range. */
				     subscript =
					addr (addr (OS (stack (start_of_expression + 1))) -> constant.value)
					-> based_integer;
				     if subscript < dp -> dimension.lower_bound (number_of_subs) then do;
					call print_message (78, subscript - bias, "lower", SI);
					error = TRUE;
				     end;
				     else if subscript > dp -> dimension.upper_bound (number_of_subs) then do;
					call print_message (78, subscript - bias, "upper", SI);
					error = TRUE;
				     end;
				end;
				if token ^= comma then
				     have_subscript = FALSE;
			     end;
			     if token ^= right_parn then
				goto missing_right_paren;
			     if number_of_subs ^= number_of_dims & number_of_dims ^= 0 then do;
				call print_message (79, SI, "the wrong number of");
				error = TRUE;
			     end;
			     call get_next_token$paren_operator;
						/* Next token must be an operator. */
			end;
			if token = substr_left_parn then do;
						/* Parse substring start and finish. */
			     if stack (start_of_node) = SUBSCRIPTED_VAR then
				stack (start_of_node) = SUBSCRIPTED_SUBSTR;
			     if ^subr_options.ansi_77 then do;
				call print_message (154);
				error = TRUE;
			     end;
			     if symp -> symbol.character then
				char_siz = symp -> symbol.char_size + 1;
			     else do;
				char_siz = 0;
				call print_message (159, SI);
				error = TRUE;
			     end;

			     inx = 1;
			     if token_list (current_token + 1).type = colon then do;
				call stack_operand (1);
				call stack_operand (value_1);
			     end;
			     else do;
				start_of_expression = stack_index;
				call get_data_statement_expression;
				if token ^= colon then do;
				     call print_message (102, err_string ());
				     goto statement_parse_abort;
				end;
				if stack (start_of_expression) = 0 then
				     error = TRUE;
				else if stack (start_of_expression) = 1
				     & stack (start_of_expression + 1) > last_assigned_op then do;
						/* Check that constant index is in range. */
				     inx = addr (addr (OS (stack (start_of_expression + 1))) -> constant.value)
					-> based_integer;
				     if inx < 1 then do;
					call print_message (155, SI, "start < 1");
					error = TRUE;
				     end;
				     else if inx > char_siz & char_siz ^= 0 then do;
					call print_message (155, SI, "start > length");
					error = TRUE;
				     end;
				end;
			     end;
			     if token_list (current_token + 1).type = right_parn then do;
				call stack_operand (1);
				addr (work) -> based_integer = char_siz;
				call stack_operand (create_constant (int_mode, work));
			     end;
			     else do;
				start_of_expression = stack_index;
				call get_data_statement_expression;
				if token ^= right_parn then
				     goto missing_right_paren;
				if stack (start_of_expression) = 0 then
				     error = TRUE;
				else if stack (start_of_expression) = 1
				     & stack (start_of_expression + 1) > last_assigned_op then do;
						/* Check that constant finish is in range. */
				     jnx = addr (addr (OS (stack (start_of_expression + 1))) -> constant.value)
					-> based_integer;

				     if jnx < inx then do;
					call print_message (155, SI, "finish < start");
					error = TRUE;
				     end;
				     else if jnx > char_siz & char_siz ^= 0 then do;
					call print_message (155, SI, "finish > length");
					error = TRUE;
				     end;
				end;
			     end;
			     call get_next_token$operator;
						/* Next token must be an operator. */
			end;
			if error then do;
			     stack (start_of_node) = SKIP;
			     stack_index = start_of_node + 1;
			end;
		     end;
		     else do /* ident with no parn */;
			call stack_operand (SI);
		     end;

/* comma, end of loop, or end of list must follow reference */

		     need_comma = TRUE;
		     do while (need_comma & in_list);

			if token ^= comma then
			     in_list = FALSE;
			else if last_do > 0 & current_token = paren_info (last_do).begin_index then do;
			     current_token = paren_info (last_do).position;
						/* skip over loop code */
			     last_do = paren_info (last_do).chain;
						/* step up to containing loop */
			     do_level = do_level - 1;

			     call stack_operand (END_DO_LOOP);
						/* end of implied loop */

			     call get_next_token$operator;
						/* get comma or slash */
			end;
			else
			     need_comma = FALSE;
		     end /* need_comma & in_list */;
		end /* not left paren */;
	     end /* loop to parse all list elements */;

	     if token ^= slash then
		go to missing_slash;

/* Parse constant list. */

	     call parse_data;

	     if token ^= comma then
		in_stmnt = FALSE;
	end /* do while (in_stmnt) */;

/* If data specs generated "nodes" in polish, must indicate how many halfwords are used. */

	if first_word ^= 0 then
	     polish_string (first_word) = next_free_polish - first_word - 1;
	go to parse_done;


/* Case		Return

Syntax:

Polish:

Notes:
*/
parser (39):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if END_DO_RANGE & ^logical_if_statement		/* ends a loop only as part of logical if */
	     then
	     call print_message (16, keyword_table (statement_type));
						/* cannot terminate do loop */

	if sub_ptr -> subprogram_type = main_program then
	     call print_message (17, keyword_table (statement_type));
						/* return stmnt illegal in main */

/* if subroutine and text follows keyword, assume alternate return statement */

	call get_next_token (force_symtab_entry, SI);

	if subprogram_op = subr_op & token ^= EOS_token then do;
	     if return_value_param = 0		/* first ref so create it */
		then
		return_value_param = build_symbol ((NO_NAME), param_variable_attrs | attr_table (int_mode), REF);

	     call emit_operand (return_value_param);
	     call parse_expression (any_expression, SI, ignore_bits);
	     call emit_operator (assign_op);
	end;

	call emit_return_op;
	go to parse_done;


/* Case		Backspace, Rewind, Endfile

Syntax:	<expression> <eos> | (<specifier>...) <eos>
	<specifier> ::= [unit] = u | iostat = ios | err = s
Polish:	<expression> <op_code> [<polish for err> <error_label_op>]
		[<polish for iostat> <iostat_op>]

Notes:
	need_PS	indicates presence of an I/O statement
	SI	passes output from get_next_token to parse_expr
	at most one iostat or err and exactly 1 unit specifier
*/
parser (40):					/* rewind */
	op_code = rewind_op;
	io_control_type = rewind_opr;
	goto rewind_endfile_backspace;

parser (41):					/* endfile */
	op_code = endfile_op;
	io_control_type = endfile_opr;
	goto rewind_endfile_backspace;

parser (52):					/* backspace */
	op_code = backspace_op;
	io_control_type = backspace_opr;
	goto rewind_endfile_backspace;

rewind_endfile_backspace:
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

/* Initialize and then begin the parse */

	fields_specified = ZERO;
	string (io_bits) = ZERO;
	io_bits.control_type = bit (binary (io_control_type, 4, 0), 4);
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;
	count = 0;

	call get_next_token (force_symtab_entry, SI);	/* Get first token of the expr. */
	if token = left_parn			/* Keyword driven */
	then do;
	     in_list = TRUE;
	     do while (in_list);
		call get_next_token (ignore_symtab_entry, ignore_value);

/* if next token is an equals sign, then this may be a true keyword driven value, 
   otherwise it's the expression defining UNIT or some sort of syntactic error */
		count = count + 1;
		if token_list (current_token + 1).type = assign then do;
		     if token ^= ident then
			goto missing_keyword;
		     else if substr (full_name, 1, symbol_length) = "err" then
			call parse_error_label;
		     else if substr (full_name, 1, symbol_length) = "iostat" then
			call parse_iostat_var;
		     else if substr (full_name, 1, symbol_length) = "unit" then
			call parse_unit_specifier (FALSE, FALSE);
						/* asterisk forbidden */
		     else
			goto invalid_keyword;
		end;
		else do;

/* no keyword, UNIT = assumed (if first element in list ) */

		     if count = 1 then
			call parse_unit_specifier$no_keyword (FALSE, FALSE);
		     else
			goto missing_identifier;
		end /* no keyword */;
		in_list = (token = comma);
	     end /* looping over list */;

	     if token ^= right_parn then
		goto missing_right_paren;
	     if ^substr (fields_specified, units_field, 1) then
		call print_message (31, keyword_table (statement_type), "unit");
	     current_token = current_token + 1;
	end /* then clause */;

	else
	     call parse_expression (any_expression, SI, ignore_bits);
	call emit_operand (create_constant (int_mode, string (io_bits)));
	call emit_operator ((op_code));
	sub_ptr -> need_PS = TRUE;
	go to parse_done;


/* Case		Read

Syntax:

Polish:

Notes:
*/
parser (42):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if token_list (current_token + 1).type = left_parn then
	     call parse_io (TRUE);
	else
	     call parse_implied_io (TRUE, value_0, TRUE);
	go to parse_done;


/* Case		Decode, Encode - get and put string

Syntax:

Polish:

Notes:
*/
parser (43):
parser (44):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token$operator;			/* Get left paren. */
	if token ^= left_parn then
	     go to missing_left_paren;

/* Set up control string. */

	string (io_bits) = FALSE;
	io_bits.read = statement_type = decode_statement;
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	fields_specified = ZERO;
	sub_ptr -> need_PS = TRUE;			/* Indicate presence of an I/O statement. */

/* Parse the string reference. */

	call get_next_token (force_symtab_entry, SI);
	if token ^= ident then
	     go to missing_identifier;

/*  get_internal_file builds the polish for stmnt.  parameter indicates it is being called from encode/decode */

	call set_data_fields (SI);
	call get_internal_file (TRUE);

/* Process format and err=l fields. */

	if token ^= comma then
	     go to missing_comma;

	call parse_io_options;			/* io_bits.format may change. */
	if io_bits.format = unformatted		/* string io may not be unformatted */
	     then
	     call print_message (31, keyword_table (statement_type), "format");
	call parse_io_list;
	go to parse_done;


/* Case		Print

Syntax:

Polish:

Notes:
*/
parser (45):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call parse_implied_io (FALSE, value_0, TRUE);
	go to parse_done;


/* Case		Entry

Syntax:

Polish:

Notes:
	Not Audited -- not for first release.
*/
parser (46):
	string (cur_stmnt_ptr -> statement.bits) = put_in_map;

/* tell code generator there are multiple entry points */

	sub_ptr -> subprogram.multiple_entry = TRUE;

	if sub_ptr -> subprogram_type = main_program then
	     call print_message (35, keyword_table (statement_type));
						/* entry invalid in main program */

	call get_next_token (force_symtab_entry, SI);
	if token ^= ident then
	     go to missing_identifier;

/* if entry in function, data type must agree with main entry point */

	if subprogram_op = func_op then do;
	     call assign_data_type (return_value);	/* make sure main e.p. has data type, too */
	     call assign_data_type (SI);

	     if (unspec (addr (OS (SI)) -> symbol.mode_bits) ^= unspec (addr (OS (return_value)) -> symbol.mode_bits))
		then
		call print_message (125, SI, subprogram_symbol);
	end;

	call parse_parameter_list (SI);		/* parses param list */

	if pending_entry_cnt = 1 then
	     bypass_first_pending_entry = ^must_have_label;
	must_have_label = FALSE;			/* statement following entry stmt never needs label */

	go to parse_done;


/* Case		Pause, Stop

Syntax:

Polish:

Notes:
*/
parser (47):					/* Stop Statement */
	op_code = stop_op;
	go to stop_pause_common;

parser (48):					/* Pause Statement */
	op_code = pause_op;

stop_pause_common:
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if END_DO_RANGE & ^logical_if_statement then
	     call print_message (16, keyword_table (statement_type));
						/* cannot terminate do loop */

	call get_next_token (locate_symtab_entry, indx);

	if token = char_string then do;
	     current_token = current_token + 1;
	end;
	else if token = dec_int then do;
	     indx = create_char_constant (token_string);
	     current_token = current_token + 1;
	end;
	else do;
	     indx = create_char_constant (NULL_STRING);
	end;
	call emit_operand (indx);
	call emit_operator ((op_code));
	go to parse_done;


/* Case		Assign To

Syntax:

Polish:

Notes:
*/
parser (49):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token$label (ignore_symtab_entry, ignore_value);
	if token ^= dec_int then
	     go to missing_label;

	call emit_operand (enter_label (any_label, (addr (work) -> based_integer), GOTO_REF));
	call get_next_token (ignore_symtab_entry, ignore_value);
	if token ^= ident then do;
	     call print_message (44, "to", err_string ());/* missing keyword */
	     go to statement_parse_abort;
	end;

	if substr (fast_lookup, 1, 2) ^= "to" then do;
	     call print_message (44, "to", err_string ());/* missing keyword */
	     go to statement_parse_abort;
	end;

	call split_token (2, current_token, TRUE);
	current_token = current_token - 1;		/* Get the token again. */
	call get_next_token (force_symtab_entry, SI);

	call parse_expression (set_reference, SI, ignore_bits);
	call emit_operator (assign_label_op);
	go to parse_done;


/* Case	 	Punch

Syntax:

Polish:

Notes:
*/
parser (50):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if is_fast then
	     go to parser (unknown_statement);

	if value_7 = 0 then do;
	     addr (work) -> based_integer = 7;
	     value_7 = create_constant (int_mode, work);
	end;

	call parse_implied_io (FALSE, value_7, FALSE);
	go to parse_done;


/* Case		Input

Syntax:

Polish:

Notes:
*/
parser (51):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call parse_implied_io (TRUE, value_0, TRUE);
	go to parse_done;


/* Case		Chain */
parser (53):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);

	call parse_expression (any_expression, SI, ignore_bits);

	if token = comma then do;
	     in_stmnt = TRUE;
	     call get_next_token (ignore_symtab_entry, ignore_value);
	     if token ^= ident then
		go to missing_keyword;

	end;
	else
	     in_stmnt = FALSE;

	if in_stmnt & substr (fast_lookup, 1, 6) = "system" then do;
	     call split_token (6, current_token, TRUE);
	     current_token = current_token - 1;		/* Get the token again. */
	     call get_next_token (force_symtab_entry, SI);

	     call parse_expression (any_expression, SI, ignore_bits);

	     if token = comma then do;
		in_stmnt = TRUE;
		call get_next_token (ignore_symtab_entry, ignore_value);
		if token ^= ident then do;
		     call print_message (44, "with", err_string ());
						/* missing keyword */
		     go to statement_parse_abort;
		end;

	     end;
	     else
		in_stmnt = FALSE;
	end;
	else
	     call emit_operand (create_char_constant ("fortran"));

	call emit_count (word_offset);
	call emit_operator (chain_op);

	if in_stmnt then
	     if substr (fast_lookup, 1, 4) = "with" then do;
		call split_token (4, current_token, TRUE);
		current_token = current_token - 1;
		count = 0;
		in_list = TRUE;
		do while (in_list);
		     call get_next_token (force_symtab_entry, SI);
		     call parse_expression (any_expression, SI, ignore_bits);
		     count = count + 1;
		     if token ^= comma then
			in_list = FALSE;

		     call emit_operator (item_op);
		end;
		polish_string (word_offset) = count - bias;
	     end;
	     else
		current_token = current_token - 1;

	call emit_operator (eol_op);
	go to parse_done;


/* Case		Closefile

Syntax:	<expression> <eos>

Polish:	<expression> <closefile_op>

Notes:
	need_PS	indicates presence of an I/O statement
	SI	passes output from get_next_token to parse_expr
*/
parser (54):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);	/* Get first token of the expr. */
	call parse_expression (any_expression, SI, ignore_bits);
	call emit_operator (closefile_op);
	sub_ptr -> need_PS = TRUE;
	go to parse_done;


/* Case		Margin

Syntax:

Polish:

Notes:
*/
parser (55):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);
	call parse_expression (any_expression, SI, ignore_bits);
	if token ^= comma then
	     go to missing_comma;

	call get_next_token (force_symtab_entry, SI);
	call parse_expression (any_expression, SI, ignore_bits);
	call emit_operator (margin_op);
	sub_ptr -> need_PS = TRUE;
	go to parse_done;


/* Case		Openfile

Syntax:

Polish:

Notes:
*/
parser (56):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	call get_next_token (force_symtab_entry, SI);
	sub_ptr -> need_PS = TRUE;
	call parse_expression (any_expression, SI, ignore_bits);
	if token ^= comma then
	     go to missing_comma;

	call get_next_token (force_symtab_entry, SI);

	call parse_expression (any_expression, SI, ignore_bits);

	if token = comma then do;
	     call get_next_token (force_symtab_entry, SI);

	     call parse_expression (any_expression, SI, ignore_bits);

	end;
	else
	     call emit_operand (create_char_constant ("terminal"));
	call emit_operator (openfile_op);
	go to parse_done;


/* Case		Open

Syntax:	open ( <option list> )

		where option list is any of these in any order:
		(exactly one unit specifier is required)
	err=, status=, iostat=, attach=, switch=, form=, access=, mode=, prompt=, defer=, carriage=,
	file=, binary=, recl=, [unit =].

Polish:
	file_#  job_bits  fields_specified  #_of_fields  open  field_expre  field_#  item  ...  eol
	 <saved>  opnd	opnd		count	op	expre	count  op		op

Notes:
	THE CORRESPONDENCE BETWEEN FIELD AND NUMBER IS NOT ALTERABLE WITHOUT CHANGING:
		the parse (ext_parse), the macros (fort_cg_macros_), and bound_pl1_operators_.
	     Also, the include file fortran_open_data.incl.(pl1 alm).
*/
parser (57):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	sub_ptr -> subprogram.need_PS = TRUE;

/* Initialize */

	string (io_bits) = ZERO;			/* Control word to define type of operation. */
	io_bits.control_type = bit (binary (open_opr, 4, 0), 4);
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	fields_specified = ZERO;			/* Bit string to specify which fields have already appeared. */

	count = 0;				/* counts the number of fields present */

/* Begin the parse */

	call get_next_token$operator;			/* get left paren */
	if token ^= left_parn then
	     go to missing_left_paren;

/* Allocate polish for 0) unit_specifier built by code gen, 1) job_bits, 2) fields_specified, 3) a count */

	word_offset = next_free_polish;		/* remember where */
	call increment_polish (4);
	call emit_operator (open_op);

	in_list = TRUE;
	count = 0;
	do while (in_list);
	     count = count + 1;
	     call get_next_token (ignore_symtab_entry, ignore_value);
						/* get the keyword */
	     if token_list (current_token + 1).type ^= assign then do;
						/* non-keyword, must be implied unit if first */
		if count = 1 then
		     call parse_unit_specifier$no_keyword (FALSE, TRUE);
		else
		     goto missing_identifier;
	     end;
	     else do;

		if token ^= ident then
		     go to missing_keyword;

		if substr (full_name, 1, symbol_length) = "err" then
		     call parse_error_label;

		else if substr (full_name, 1, symbol_length) = "iostat" then
		     call parse_iostat_var;

		else if substr (full_name, 1, symbol_length) = "status" then
		     call parse_open_field (status_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "ioswitch" then
		     call parse_open_field (io_switch_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "attach" then
		     call parse_open_field (attach_desc_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "file" then
		     call parse_open_field (filename_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "mode" then
		     call parse_open_field (mode_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "access" then
		     call parse_open_field (access_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "form" then
		     call parse_open_field (form_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "recl" then
		     call parse_open_field (recl_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "binarystream" then
		     call parse_open_field (binarystream_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "prompt" then
		     call parse_open_field (prompt_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "carriage" then
		     call parse_open_field (carriage_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "defer" then
		     call parse_open_field (defer_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "blank" then
		     call parse_open_field (blank_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "unit" then
		     call parse_unit_specifier (FALSE, TRUE);

		else
		     go to invalid_keyword;
	     end /* keyword driven */;
	     in_list = (token = comma);
	end;					/* loop through option fields */

	if token ^= right_parn then
	     go to missing_right_paren;
	if ^substr (fields_specified, units_field, 1) then
	     call print_message (31, keyword_table (statement_type), "unit");
	current_token = current_token + 1;		/* skip over right paren */

	call emit_operator (eol_op);

/* copy values into polish slots reserved earlier */

	polish_string (word_offset) = -bias;
	polish_string (word_offset + 1) = create_constant (int_mode, string (io_bits));
	polish_string (word_offset + 2) = create_constant (int_mode, fields_specified);
	polish_string (word_offset + 3) = -bias;	/* count of zero. Index for field-specified bit string. */
	go to parse_done;

/* Case		Close

Syntax:	close ( <option list> )

		where option list is any of these in any order:
		(exactly one unit specifier required, keyword optional)
	err=, status=, iostat=, [unit = ],

Polish:
	file_#  job_bits  fields_specified  #_of_fields  close field_expre  field_#  item  ...  eol
	 <save>  opnd	opnd		count	op	expre	count  op		op

Notes:
	THE CORRESPONDENCE BETWEEN FIELD AND NUMBER IS NOT ALTERABLE WITHOUT CHANGING:
		the parse (ext_parse), the macros (fort_cg_macros_), and bound_pl1_operators_.
	     Also, the include file fortran_open_data.incl.(pl1 alm).
*/
parser (58):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	sub_ptr -> subprogram.need_PS = TRUE;

/* Initialize */

	string (io_bits) = ZERO;			/* Control word to define type of operation. */
	io_bits.control_type = bit (binary (close_opr, 4, 0), 4);
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	fields_specified = ZERO;			/* Bit string to specify which fields have already appeared. */

	count = 0;				/* counts the number of fields present */

/* Begin the parse */

	call get_next_token$operator;			/* get left paren */
	if token ^= left_parn then
	     go to missing_left_paren;

/* Allocate polish for 0) unit id built by code gen, 1) job_bits, 2) fields_specified, 3) a count */

	word_offset = next_free_polish;		/* remember where */
	call increment_polish (4);
	call emit_operator (close_op);

	in_list = TRUE;
	do while (in_list);
	     count = count + 1;
	     call get_next_token (ignore_symtab_entry, ignore_value);
						/* get the keyword */
	     if token_list (current_token + 1).type ^= assign then do;
						/* non-keyword, must be implied unit if first */
		if count = 1 then
		     call parse_unit_specifier$no_keyword (FALSE, TRUE);
		else
		     goto missing_identifier;
	     end;
	     else do;
		if token ^= ident then
		     go to missing_keyword;

		if substr (full_name, 1, symbol_length) = "err" then
		     call parse_error_label;

		else if substr (full_name, 1, symbol_length) = "iostat" then
		     call parse_iostat_var;

		else if substr (full_name, 1, symbol_length) = "status" then
		     call parse_open_field (status_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "unit" then
		     call parse_unit_specifier (FALSE, TRUE);

		else
		     go to invalid_keyword;
	     end /* keyword driven */;
	     in_list = (token = comma);
	end;					/* loop through option fields */

	if token ^= right_parn then
	     go to missing_right_paren;
	if ^substr (fields_specified, units_field, 1) then
	     call print_message (31, keyword_table (statement_type), "unit");
	current_token = current_token + 1;		/* skip over right paren */

	call emit_operator (eol_op);

/* copy values into polish slots reserved earlier */

	polish_string (word_offset) = -bias;
	polish_string (word_offset + 1) = create_constant (int_mode, string (io_bits));
	polish_string (word_offset + 2) = create_constant (int_mode, fields_specified);
	polish_string (word_offset + 3) = -bias;	/* count of zero. Index for field-specified bit string. */
	go to parse_done;


/* Case		Inquire

Syntax:	inquire ( <option list> )

		where option list is any of these in any order:
		(exactly one of unit or file is required)
	err=, iostat=, file=, form=, blank=, access=, exist=, opened=, number=, named=,
	sequential=, formatted=, recl=, unit =, unformatted=, nextrec=, direct=.

Polish:
	job_bits  fields_specified  #_of_fields  inquire  field_expre  field_#  item  ...  eol

Notes: This is much like the method in which the open statement is implemented, except that 
       here everything is returned by fortran_io_ except unit/file
*/
parser (59):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	sub_ptr -> subprogram.need_PS = TRUE;

/* Initialize */

	string (io_bits) = ZERO;			/* Control word to define type of operation. */
	io_bits.control_type = bit (binary (inquire_opr, 4, 0), 4);
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	fields_specified = ZERO;			/* Bit string to specify which fields have already appeared. */

/* Begin the parse */

	call get_next_token$operator;			/* get left paren */
	if token ^= left_parn then
	     go to missing_left_paren;

/* Allocate polish for 0) job_bits, 1) fields_specified, 2) a count */

	word_offset = next_free_polish;		/* remember where */
	call increment_polish (3);
	call emit_operator (inquire_op);

	in_list = TRUE;
	count = 0;
	do while (in_list);
	     count = count + 1;
	     call get_next_token (ignore_symtab_entry, ignore_value);
						/* get the keyword */
	     if token_list (current_token + 1).type = assign then do;

		if token ^= ident then
		     go to missing_keyword;

		if substr (full_name, 1, symbol_length) = "err" then
		     call parse_error_label;

		else if substr (full_name, 1, symbol_length) = "iostat" then
		     call parse_iostat_var;

		else if substr (full_name, 1, symbol_length) = "file" then
		     call parse_open_field (filename_field, any_expression);

		else if substr (full_name, 1, symbol_length) = "unit" then
		     call parse_unit_specifier (FALSE, TRUE);

		else if substr (full_name, 1, symbol_length) = "access" then
		     call parse_open_field (access_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "form" then
		     call parse_open_field (form_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "recl" then
		     call parse_open_field (recl_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "blank" then
		     call parse_open_field (blank_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "exist" then
		     call parse_open_field (exist_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "opened" then
		     call parse_open_field (opened_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "number" then
		     call parse_open_field (number_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "named" then
		     call parse_open_field (named_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "name" then
		     call parse_open_field (name_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "sequential" then
		     call parse_open_field (sequential_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "formatted" then
		     call parse_open_field (formatted_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "unformatted" then
		     call parse_open_field (unformatted_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "nextrec" then
		     call parse_open_field (nextrec_field, set_reference);

		else if substr (full_name, 1, symbol_length) = "direct" then
		     call parse_open_field (direct_field, set_reference);

		else
		     go to invalid_keyword;
	     end /* keyword driven */;
	     else do;				/* presume 'UNIT=' */
		if count = 1 then
		     call parse_unit_specifier$no_keyword (FALSE, TRUE);
		else
		     goto missing_identifier;
	     end;

	     in_list = (token = comma);
	end;					/* loop through option fields */

	if token ^= right_parn then
	     go to missing_right_paren;

	if ^substr (fields_specified, units_field, 1) & ^substr (fields_specified, filename_field, 1) then
	     call print_message (31, keyword_table (statement_type), "unit or a file");
	if substr (fields_specified, units_field, 1) & substr (fields_specified, filename_field, 1) then
	     call print_message (187, keyword_table (statement_type), "file and unit");

	current_token = current_token + 1;		/* skip over right paren */

	call emit_operator (eol_op);

/* copy values into polish slots reserved earlier */

	polish_string (word_offset) = create_constant (int_mode, string (io_bits));
	polish_string (word_offset + 1) = create_constant (int_mode, fields_specified);
	polish_string (word_offset + 2) = -bias;	/* count of zero. Index for field-specified bit string. */
	go to parse_done;

/* Case		Do

Syntax:

Polish:

Notes:
*/
parser (61):
	profile_size = profile_size + 1;		/* profile entry required by this statement */
	string (cur_stmnt_ptr -> statement.bits) = put_in_profile;

	if END_DO_RANGE then
	     call print_message (16, keyword_table (statement_type));
						/* cannot terminate do loop */

	call get_next_token$label (ignore_symtab_entry, ignore_value);
	if token ^= dec_int then
	     go to missing_label;

	label_ptr = enter_label (executable_label, (addr (work) -> based_integer), REF);
	call get_next_token (force_symtab_entry, SI);

	if token = comma then
	     call get_next_token (force_symtab_entry, SI);

	call parse_expression (set_reference, SI, ignore_bits);
	if token ^= assign then
	     go to missing_equals_sign;

	call get_next_token (force_symtab_entry, SI);
	call parse_expression (any_expression, SI, ignore_bits);
	if token ^= comma then
	     go to missing_comma;

	call get_next_token (force_symtab_entry, SI);
	call parse_expression (any_expression, SI, ignore_bits);
	if token = comma then do;
	     call get_next_token (force_symtab_entry, SI);
	     call parse_expression (any_expression, SI, ignore_bits);
	end;
	else
	     call emit_operand (value_1);
	call emit_operator (do_op);

	if do_index = hbound (do_blockif_stack, 1) then
	     call print_message (27, hbound (do_blockif_stack, 1) - bias);
						/* too many do loop nestings */
	else do;
	     do_index = do_index + 1;
	     do_blockif_stack (do_index).do_loop = "1"b;
	     do_blockif_stack (do_index).label_ptr = label_ptr;
	end;
	go to parse_done;


/* Case		Unknown */
parser (62):
	call get_next_token (ignore_symtab_entry, ignore_value);
						/* get first token of statement */

	if token = ident then
	     call print_message (32, token_string);	/* unknown keyword */
	else
	     call print_message (92, token_string);	/* doesnt start with identifier */

	go to statement_parse_abort;


/* Case		Out of Sequence */
parser (63):
	call print_message (56, keyword_table (bad_type));/* statement is out of sequence */
	go to statement_parse_abort;

declaration_processor:
     procedure;

/*	Program Specifications (declaration_processor)

     Inputs

     Output

     Description - Process common blocks and equvalence groups.
*/

dcl      LA_hdri fixed bin (18);
dcl      LA_hdrp ptr;
dcl      VLA_hdri fixed bin (18);
dcl      VLA_hdrp ptr;
dcl      added pointer;
dcl      added_group bit (1);
dcl      added_header_length fixed binary (24);
dcl      adesc fixed binary (18);
dcl      all_character_offsets_in_group bit (1);
dcl      ap pointer;
dcl      array_max_size fixed bin (24);
dcl      block_length fixed bin (25);
dcl      block_max_size fixed bin (24);
dcl      bp pointer;
dcl      (chars_in_block, chars_in_group, character_offset) bit (1);
dcl      common_hdri fixed bin (18);
dcl      common_hdrp ptr;
dcl      difference fixed bin (24);
dcl      displacement fixed bin (24);
dcl      equiv_error bit (1) aligned;
dcl      equiv_hdri fixed bin (18);
dcl      equiv_hdrp ptr;
dcl      group_align bit (2) aligned;
dcl      group_class bit (4) aligned;
dcl      group_length fixed bin (24);
dcl      i fixed bin (18);
dcl      ii fixed bin;
dcl      indx fixed bin (18);
dcl      indx_ptr pointer;
dcl      j fixed bin (18);
dcl      k fixed bin (24);
dcl      max_length_this_pass fixed bin (18);
dcl      new fixed bin (18);
dcl      old fixed bin (18);
dcl      original pointer;
dcl      prev_LA_hdrp ptr;
dcl      prev_common_hdrp ptr;
dcl      prev_equiv_hdrp ptr;
dcl      real_statement fixed bin (18);
dcl      sp pointer;
dcl      sp_header_length fixed binary (24);
dcl      symbol_even bit (1);
dcl      symbol_length fixed bin (24);
dcl      symbol_storage bit (5) unaligned defined (addr (OS (indx)) -> symbol.storage_info);
dcl      symbol_storage_class bit (3);
dcl      symi fixed bin (18);
dcl      tp pointer;
dcl      vbai fixed bin (18);
dcl      vbap ptr;
dcl      vba_name char (256) varying;

dcl      01 initial_in_polish aligned based,		/* Used to transform to named constant */
	 02 next fixed binary (17) aligned,
	 02 limit fixed binary (17) aligned,
	 02 value fixed binary (17) aligned;


	real_statement = cur_statement;		/* cur_statement is changed for error messages. */
	cur_statement = -1;				/* There is no current statement. */

/* force data type for function return value */

	if subprogram_op = func_op then do;

/* Insure that the function return value was set. */

	     if ^addr (OS (return_value)) -> symbol.set & ^addr (OS (return_value)) -> symbol.passed_as_arg then
		call print_message (9, return_value);	/* return value is not set */

	     call set_data_fields (return_value);	/* must have data type */

	     unspec (addr (OS (return_value_param)) -> symbol.mode_bits) =
		unspec (addr (OS (return_value)) -> symbol.mode_bits);
	     addr (OS (return_value_param)) -> symbol.data_type = addr (OS (return_value)) -> symbol.data_type;
	     addr (OS (return_value_param)) -> symbol.element_size = addr (OS (return_value)) -> symbol.element_size;
	end;

/*  *  *  *  *  *  LABEL PROCESSOR  *  *  *  *  *  */

/*	Check all labels for illegal reference. For format labels, if they
	contain hollerith fields and are referenced by a read statement, set symbol.set. */

	do SI = sub_ptr -> subprogram.first_label repeat symp -> label.next_label while (SI ^= 0);
	     symp = addr (OS (SI));

	     if symp -> label.referenced & ^symp -> label.set then
		call print_message (12, SI);

	     if symp -> label.referenced_executable & symp -> label.not_referencable then
		call print_message (185, SI);

	     if string (symp -> label.usage) = format_label then do;
		sp = addr (OS (symp -> label.format_var));

		if sp -> symbol.set			/* used in a read st, check for hollerith */
		then do;
		     addr (work) -> based_char /* copy because char_const.value is not word aligned */ =
			addr (addr (OS (polish_string (sp -> symbol.initial + 2))) -> char_constant.value)
			-> based_char;
		     if ^addr (work) -> runtime_format.contains_hollerith then
			sp -> symbol.set = FALSE;
		end;
	     end;
	end;


/*  *  *  *  *  *  SYMBOL TABLE PROCESSOR  *  *  *  *  *  */

/* The symbol table chain must be destroyed and replaced by two chains, -- a chain for entry point
   symbols and a chain for everything else. Also, while walking the original symbol table chain,
   the following actions are performed:

     o	symbol.general is zeroed; the cg assumes this as its initial value.

     o	symbols with the external attribute that are not builtins and without a storage class
	are assigned to constant storage.

     o	arrays with variable extents must be parameters; the bounds must all be scalar
	integer parameters.

     o	functions, statement functions, and variables are assigned a data type,
	if they don't already have one; symbol.data_type, symbol.element_size,
	(also dimension.element_count, dimension.array_size) are set if
	symbol.data_type is zero. */

	SI = sub_ptr -> subprogram.first_symbol;	/* get head of original symbol table chain */

	sub_ptr -> subprogram.first_symbol = 0;		/* general symbol chain is initially empty */
	sub_ptr -> subprogram.last_symbol = 0;

	do while (SI ^= 0);

/* get pointer to current node */

	     symp = addr (OS (SI));

	     new = symp -> symbol.next_symbol;		/* next member of the original chain */
	     symp -> symbol.next_symbol = 0;		/* destroy original chain */

/* Process each symbol. */

/* entry point symbols are added to the entry point chain */

	     if symp -> symbol.entry_point then do;

/* All function entry points must have a data type. */

		if subprogram_op = func_op then do;
		     unspec (addr (OS (SI)) -> symbol.mode_bits) =
			unspec (addr (OS (return_value)) -> symbol.mode_bits);
		     addr (OS (SI)) -> symbol.data_type = addr (OS (return_value)) -> symbol.data_type;
		     addr (OS (SI)) -> symbol.element_size = addr (OS (return_value)) -> symbol.element_size;
		end;

/* an entry_point needs descriptors iff any of its parameters is declared to
   be of star_extent.  The index of the symbol nodes for these parameters is
   put into an arg_desc node by parse_parameter_list for each entry point, but 
   as the symbols need not have been declared yet, star_extent_edness must be  
   checked on a per-subprogram basis.   */

		adesc = symp -> symbol.general;
		if adesc ^= 0 then do;
		     ap = addr (OS (adesc));
		     num_args = ap -> arg_desc.n_args;
		     if symp -> symbol.function then
			symp -> symbol.needs_descriptors = symp -> symbol.star_extents;
		     do i = 1 to num_args while (^symp -> symbol.needs_descriptors);
			if ap -> arg_desc.symbol (i) > 0
						/* if parameter was a symbol, not a *  */
			     then
			     symp -> symbol.needs_descriptors =
				addr (OS (ap -> arg_desc.symbol (i))) -> symbol.star_extents;
		     end;

		end;

		if first_entry_name = 0 then
		     first_entry_name = SI;
		else
		     addr (OS (last_entry_name)) -> symbol.next_symbol = SI;

		last_entry_name = SI;
	     end;

/* all others are added to symbol table chain */

	     else do;


/* DATA TYPE and STORAGE CLASS ALLOCATION. The parse sets the data type for
   all external functions, statement functions, and variables. It also assigns
   a storage class to all variables that do not have one. */

		if symp -> symbol.function | symp -> symbol.stmnt_func then
		     call set_data_fields (SI);	/* Assign a data type and set related fields. */

		else if symp -> symbol.variable | symp -> symbol.parameter then do;
		     call set_data_fields (SI);	/* Assign a data type and set related fields. */

/* Insure that all non-equivalenced variables have a storage class. */

		     if ^symp -> symbol.equivalenced	/* this symbol is not in common nor equivalenced */
			then
			if string (symp -> symbol.storage_class) = ZERO then do;
			     string (symp -> symbol.storage_class) = string (sub_ptr -> subprogram.default_is);
			     if symp -> symbol.dimensioned & ^symp -> symbol.variable_extents
				& ^symp -> symbol.star_extents then do;
				if symp -> symbol.automatic then
				     array_max_size = max_array_size.auto;
				else if symp -> symbol.static then
				     array_max_size = max_array_size.static;

				if (addr (OS (symp -> symbol.dimension)) -> dimension.array_size)
				     > array_max_size * units_per_word (symp -> symbol.units) then
				     call print_message (136, "size", SI,
					ltrim (char (array_max_size)) || " words");
			     end;
			end;

/* Print warning if variable is used but not set. Parameters, members of
   common and equiv groups, initialed vars, compiler generated symbols,
   and s.f. dummy args are excluded. */

		     if symp -> symbol.referenced then
			if ^symp -> symbol.set & ^symp -> symbol.passed_as_arg then
			     if ^symp -> symbol.parameter & ^symp -> symbol.equivalenced
				& ^symp -> symbol.dummy_arg & ^symp -> symbol.by_compiler
						/* make sure it wasn't compiler generated */
				then
				if symp -> symbol.initial = 0
						/* do this way to catch init to zero */
				     then
				     call print_message (043, SI);

/* If static variable is init'd to zero, is referenced, is not set or passed
   as arg, mark as init'd so that optimizer can make it a constant. */

		     if symp -> symbol.static then
			if ^symp -> symbol.set & ^symp -> symbol.passed_as_arg then
			     if ^symp -> symbol.initialed & symp -> symbol.initial ^= 0 then
				symp -> symbol.initialed = TRUE;

/* Convert a symbol into a named constant if possible. */

		     if (symp -> symbol.static | symp -> symbol.automatic) & symp -> symbol.initial ^= 0
			& ^symp -> symbol.set & ^symp -> symbol.passed_as_arg & ^symp -> symbol.aliasable
			& ^symp -> symbol.dimensioned & ^symp -> symbol.equivalenced then do;
						/* CONVERT FROM OPTMIZER */
			symp -> symbol.automatic, symp -> symbol.static = "0"b;
			symp -> symbol.named_constant = "1"b;
			symp -> symbol.initial =
			     addr (polish_string (symp -> symbol.initial)) -> initial_in_polish.value;
		     end;
		end;

/* default storage class for external references is constant and use word units
   for external (descriptors) character functions in ansi77 */

		if symp -> symbol.external then do;
		     if ^symp -> symbol.parameter & ^symp -> symbol.builtin then
			symp -> symbol.constant = TRUE;
		     if symp -> symbol.function then
			if symp -> symbol.mode.character then
			     if subr_options.ansi_77 then do;
				symp -> symbol.units = word_units;
				symp -> symbol.element_size =
				     divide (symp -> symbol.char_size + chars_per_word, chars_per_word, 17, 0);
			     end;
		end;

/* process variable bounds */

		else if symp -> symbol.variable_extents then do;
		     if ^symp -> symbol.parameter then
			call print_message (14, SI);

		     dp = addr (OS (symp -> symbol.dimension));

/* As we check the validity of the bounds, we will force their allocation. */

		     do i = 1 to dp -> dimension.number_of_dims;
			if dp -> dimension.v_bound.lower (i) then
			     call validate_array_bound (dp -> dimension.dim.lower_bound (i));

/* warning - dont attempt to validate the last upper bound for assumed size arrays */

			if dp -> dimension.v_bound.upper (i) then
			     if ^(i = dp -> dimension.number_of_dims & dp -> dimension.assumed_size) then
				call validate_array_bound (dp -> dimension.dim.upper_bound (i));
		     end;
		end;

/* Statement function definitions are masked if the statement function
   is not referenced. The borrowed fields symbol.initial and symbol.dimension
   are always zeroed. */

		else if symp -> symbol.stmnt_func then do;
		     if ^symp -> symbol.allocate then do;

/* The definition is removed from the polish string by overwriting it
   with an increment_polish_op. The def. is guaranteed to be at least
   three (3) words in length. */

			word_offset = symp -> symbol.initial;
			polish_string (word_offset) = increment_polish_op;
			polish_string (word_offset + 1) = symp -> symbol.dimension - word_offset - 2;

/* All of the s.f. parameters should not be allocated. */

			do indx = symp -> symbol.next_member repeat addr (OS (indx)) -> symbol.next_member
			     while (indx ^= 0);
			     symbol_storage = ZERO;
			end;
		     end;

		     symp -> symbol.initial = 0;
		     symp -> symbol.dimension = 0;
		end;

/* Check to make sure *-length declaration has not been used improperly;
   if used validly, create a symbol to hold length info. */

		if symp -> symbol.star_extents then
		     if ^(sub_ptr -> subprogram_type = function & SI = return_value) then
			if ^symp -> symbol.function & ^symp -> symbol.parameter then do;
			     call print_message (147, SI, default_char_size - bias);
			     symp -> symbol.star_extents = "0"b;
			     symp -> symbol.char_size = default_char_size - 1;
			end;
			else do;
			     if symp -> symbol.v_length = 0 then do;
				symp -> symbol.v_length = build_symbol ((NO_NAME), v_length_attributes, SET);
				addr (OS (symp -> symbol.v_length)) -> symbol.data_type = int_mode;
				addr (OS (symp -> symbol.v_length)) -> symbol.element_size = 1;

				if sub_ptr -> subprogram.star_extent_function & SI = return_value_param
						/* Update return_value symbol with our star extent for length. */
				then do;
				     addr (OS (return_value)) -> symbol.v_length = symp -> symbol.v_length;
				     addr (OS (subprogram_symbol)) -> symbol.v_length = symp -> symbol.v_length;
				     if addr (OS (return_value)) -> symbol.needs_descriptors then
					symp -> symbol.needs_descriptors = "1"b;
				end;
			     end;
			end;

/* Now, add the symbol to the general symbol table chain. */

		if sub_ptr -> subprogram.last_symbol = 0 then
		     sub_ptr -> subprogram.first_symbol = SI;
		else
		     addr (OS (sub_ptr -> subprogram.last_symbol)) -> symbol.next_symbol = SI;

		sub_ptr -> subprogram.last_symbol = SI;
	     end;

/* ensure that this field is zero for the code generator */

	     symp -> symbol.general = 0;

/* exception entrypoints, general point to argument descriptor */
	     if symp -> symbol.attributes.misc_attributes.entry_point then
		symp -> symbol.general = adesc;

/* step to next member of the original chain */

	     SI = new;
	end;


/*  *  *  *  *  *  COMMON BLOCK PROCESSOR  *  *  *  *  *  */

/* Walk common block chain calculating offsets and lengths. */

	do i = sub_ptr -> common_chain repeat bp -> header.next_header while (i ^= 0);
	     bp = addr (OS (i));
	     block_length = 0;			/* accumulates the block length */
	     if sub_ptr -> subprogram.options.ansi_77	/* If any var is char, all must be */
		then
		if addr (OS (bp -> header.first_element)) -> symbol.data_type = char_mode then do;
		     bp -> header.alignment.character = TRUE;
		     bp -> header.units = char_units;
		end;

/* Should the header node be associated with no elements, it has appeared only in a SAVE statement and not a COMMON statement */

	     if bp -> header.first_element = 0 then
		call print_message (186, i);

	     do j = bp -> header.first_element repeat sp -> symbol.next_member while (j ^= 0);
		sp = addr (OS (j));

		if (unspec (addr (OS (j)) -> symbol.attributes) & variable_conflicts) = ZERO then do;
						/* Enforce the ANSI77 character vars in common restriction (all or none) */

		     if sub_ptr -> subprogram.options.ansi_77 then
			if bp -> header.alignment.character then
			     if sp -> symbol.data_type ^= char_mode then
				call print_message (156, i);
			     else
				;
			else if sp -> symbol.data_type = char_mode then
			     call print_message (156, i);

/* Set member offset and update total block length. */

		     if sp -> symbol.double_precision | sp -> symbol.complex then
			if mod (block_length, 2) ^= 0 then do;
			     call print_message (57, i, j);
						/* Adding word to common for alignment */
			     block_length = block_length + 1;
			end;

		     sp -> symbol.offset = block_length;/* Set offset. */

		     if sp -> symbol.dimensioned then
			if sp -> symbol.variable_extents then do;
			     call print_message (58, j);
						/* cannot have variable extents in common */
			     k = 0;
			end;
			else
			     k = addr (OS (sp -> symbol.dimension)) -> dimension.array_size;
		     else
			k = sp -> symbol.element_size;

		     block_length = block_length + k;	/* Update length. */
		end;

		else
		     call print_message (20, j, i);	/* symbol cannot be in common */

/* copy block length into header */

		if block_length > max_fixed_bin_24 then
		     call print_message (136, "length", i, ltrim (char (max_fixed_bin_24)) || " words");
		else
		     bp -> header.length = block_length;
	     end;
	end;


/*  *  *  *  *  *  EQUIVALENCE GROUP PROCESSOR  *  *  *  *  *  */

/* Loop thru all equivalence groups. */

	i = lbound (stack, 1);
	do while (i < stack_index);

/* Get the beginning of a group. */

	     cur_statement = stack (i);
	     i = i + 1;

	     if subr_options.ansi_77 then do;
		all_character_offsets_in_group = TRUE;
		ii = i;
		do while (stack (ii) ^= -1 & all_character_offsets_in_group);
		     all_character_offsets_in_group = addr (OS (stack (ii))) -> symbol.mode.character;
		     ii = ii + 3;
		end;
	     end;
	     else
		all_character_offsets_in_group = FALSE;

	     equiv_error = TRUE;
	     do while (equiv_error & stack (i) ^= -1);
		displacement = get_equiv_var (old, bp, character_offset);
	     end;

/* Allow ansi77 characters to be equivalenced to other data types. */

	     displacement = verify_offset_type_kludge (displacement, character_offset);
						/* Loop thru remaining group members. */

	     do while (stack (i) ^= -1);

/* Get next member and difference between its offset and the group offset. */

		equiv_error = TRUE;
		do while (equiv_error & stack (i) ^= -1);
		     difference = get_equiv_var (new, sp, character_offset);
		end;

		if equiv_error then
		     go to equivalence_member_abort;

/* Allow ansi77 characters to be equivalenced to other data types. */

		difference = displacement - verify_offset_type_kludge (difference, character_offset);

/* Calculate new storage class for group. */

		group_class = string (bp -> header.storage_class) | string (sp -> header.storage_class);
		if impossible_class (binary (substr (group_class, 1, 3), 3, 0)) then do;
		     call print_message (59, indx);	/* conflicting storage classes */
		     go to equivalence_member_abort;
		end;

/* Process offset and alignment. */

		if old = new then
		     if difference ^= 0		/* If group is equivalenced to itself. */
		     then do;
			call print_message (60, indx);/* conflicting offset */
			go to equivalence_member_abort;
		     end;
		     else
			;
		else do;				/* Two different groups. */

/* OPTIMIZATION. If either group is in common, insure it is pointed to by "old".
   Both groups cannot be in common. */

		     if sp -> header.in_common then do;
			displacement = displacement - difference;
			difference = -difference;
			j = old;
			old = new;
			new = j;
			tp = bp;
			bp = sp;
			sp = tp;
		     end;

/* Handle special constraints raised by common. a) the origin of common may not
   be changed; b) two common blocks may not be equivalenced. */

		     if bp -> header.in_common then
			if difference < 0 then do;
			     call print_message (61, old);
						/* attempt to change address of common block */
			     go to equivalence_member_abort;
			end;
			else if sp -> header.in_common then do;
			     call print_message (62, indx, old);
						/* equivalencing two common blocks */
			     go to equivalence_member_abort;
			end;

/* If "difference" is non-zero, offsets in one group must be increased by abs(difference). */

		     if difference ^= 0 then do;
			if difference < 0 then do;	/* Old group is fiddled. This redefines its origin. */
			     difference = -difference;
			     added = bp;
			     original = sp;
			     displacement = displacement + difference;
						/* Fiddling is permanent. */
			end;
			else do;			/* New group is fiddled. */
			     added = sp;
			     original = bp;
			end;

/* Change all offsets in appropriate group. */

			do j = added -> header.first_element repeat tp -> symbol.next_member while (j ^= 0);
			     tp = addr (OS (j));
			     block_length = tp -> symbol.offset + difference;
			     if block_length <= max_fixed_bin_24 then do;
				if character_offset & tp -> symbol.mode.character
				     & ^all_character_offsets_in_group then
				     tp -> symbol.offset = block_length * 4;
				else
				     tp -> symbol.offset = block_length;
			     end;
			end;

/* Update length to include origin shift. */

			if bp -> header.units ^= added -> header.units then
			     if bp -> header.units = char_units then
				added_header_length = (added -> header.length + difference) * 4;
			     else
				added_header_length = (added -> header.length + difference) / 4;
			else
			     added_header_length = added -> header.length + difference;
			block_length = max (bp -> header.length, added_header_length);
			if block_length > max_fixed_bin_24 then
			     call print_message (136, "length", old, ltrim (char (max_fixed_bin_24)));
			else
			     bp -> header.length = block_length;
		     end;

		     else do;
			added = sp;
			original = bp;
		     end;

/* Calculate required group alignment: even word, odd word, or any word. */


		     group_align = string (added -> header.alignment);
		     if mod (difference, 2) ^= 0 & group_align ^= ZERO then
			group_align = ^group_align;
		     group_align = group_align | string (original -> header.alignment);
		     if group_align = impossible_align then do;
			call print_message (63, indx);/* conflicting alignment */
			go to equivalence_member_abort;
		     end;

/* Update member's storage class if it has changed. */

		     if substr (group_class, 1, 3) ^= string (bp -> header.storage_class) then
			do j = bp -> header.first_element repeat tp -> symbol.next_member while (j ^= 0);
			     tp = addr (OS (j));
			     string (tp -> symbol.storage_class) =
				string (tp -> symbol.storage_class) | group_class;
			end;

/* Update length if new group is longer than the old. */

		     if bp -> header.units ^= sp -> header.units then
			if bp -> header.units = char_units then
			     sp_header_length = 4 * sp -> header.length;
			else
			     sp_header_length = sp -> header.length / 4;
		     else
			sp_header_length = sp -> header.length;
		     bp -> header.length = max (bp -> header.length, sp_header_length);
						/* cannot overflow */

/* Thread the two group chains into one big one. */

		     addr (OS (bp -> header.last_element)) -> symbol.next_member = sp -> header.first_element;
		     bp -> header.last_element = sp -> header.last_element;

/* Change symbol.parent and storage class for all members of added group. */

		     do j = sp -> header.first_element repeat tp -> symbol.next_member while (j ^= 0);
			tp = addr (OS (j));
			tp -> symbol.parent = old;
			string (tp -> symbol.storage_class) = string (tp -> symbol.storage_class) | group_class;
		     end;

/* allocation information of both groups must be combined */

		     string (bp -> header.storage_info) =
			string (bp -> header.storage_info) | string (sp -> header.storage_info);

/* Added group can be eliminated from general equivalence chain. */

		     if sub_ptr -> equiv_chain = new then
			sub_ptr -> equiv_chain = sp -> header.next_header;
		     else do;
			do j = sub_ptr -> equiv_chain repeat addr (OS (j)) -> header.next_header
			     while (addr (OS (j)) -> header.next_header ^= new);
			end;
			addr (OS (j)) -> header.next_header = sp -> header.next_header;
		     end;

/* Added group header can be released if it is at the end of our area. */

		     allocate_symbol_name = sp -> header.name_length;
		     if new + size (header) = next_free_operand then
			next_free_operand = new;

/* Update group storage class and required alignment. */

		     string (bp -> header.alignment) = group_align;
		     string (bp -> header.storage_class) = group_class;
		end;

equivalence_member_abort:
	     end;					/* element loop. */
	     i = i + 1;

	     if all_character_offsets_in_group then
		bp -> header.alignment.character = TRUE;

	end;					/* equiv group. */

	stack_index = lbound (stack, 1);
	stack_base = lbound (stack, 1);

	cur_statement = real_statement;


/*  *  *  *  *  *   COMMON BLOCK & EQUIVALENCE GROUP POST-PROCESSOR  *  *  *  *  *  */

/*  Check the length of each common block.  Permanent common blocks may not  */
/*  exceed a segment in size.  Normal common blocks that contain character   */
/*  variables may not exceed 'max_array_size.char' in size.  Normal common   */
/*  blocks which do not contain character variables are limited in size to   */
/*  'max_array_size.common'.                                                 */

	do common_hdri = sub_ptr -> subprogram.common_chain repeat common_hdrp -> header.next_header
	     while (common_hdri ^= 0);
	     common_hdrp = addr (OS (common_hdri));
	     if index (common_hdrp -> header.block_name, "$") > 0 then
		block_max_size = sys_info$max_seg_size;
	     else do;
		chars_in_block = FALSE;
		do symi = common_hdrp -> header.first_element repeat symp -> symbol.next_member
		     while (symi ^= 0 & ^chars_in_block);
		     symp = addr (OS (symi));
		     if symp -> symbol.character then
			chars_in_block = TRUE;
		end;
		if chars_in_block then
		     block_max_size = max_array_size.char;
		else
		     block_max_size = max_array_size.common;
	     end;
	     if common_hdrp -> header.length > block_max_size * units_per_word (common_hdrp -> header.units) then
		call print_message (136, "size", common_hdri, ltrim (char (block_max_size)) || " words");
	end;

/*  Check the size of each equivalence group and insure it has been assigned */
/*  a storage class.  Equivalence groups which contain character variables   */
/*  may not exceed 'max_array_size.char' in size, while those that do not    */
/*  contain character variables are limited by 'max_array_size.auto',        */
/*  'max_array_size.common', or 'max_array_size.static'.                     */

	do equiv_hdri = sub_ptr -> subprogram.equiv_chain repeat equiv_hdrp -> header.next_header
	     while (equiv_hdri ^= 0);
	     equiv_hdrp = addr (OS (equiv_hdri));
	     if string (equiv_hdrp -> header.storage_class) = ZERO then
		string (equiv_hdrp -> header.storage_class) = string (sub_ptr -> subprogram.default_is);
	     chars_in_group = FALSE;
	     do symi = equiv_hdrp -> header.first_element repeat symp -> symbol.next_member
		while (symi ^= 0 & ^chars_in_group);
		symp = addr (OS (symi));
		if symp -> symbol.character then
		     chars_in_group = TRUE;
	     end;

	     if chars_in_group then
		block_max_size = max_array_size.char;
	     else if equiv_hdrp -> header.in_common then
		block_max_size = max_array_size.common;
	     else if equiv_hdrp -> header.automatic then
		block_max_size = max_array_size.auto;
	     else
		block_max_size = max_array_size.static; /* if equiv_hdrp -> header.static */

	     if equiv_hdrp -> header.length > block_max_size * units_per_word (equiv_hdrp -> header.units) then
		call print_message (136, "size of the equivalence group",
		     bin (equiv_hdrp -> header.first_element, 18), ltrim (char (block_max_size)) || " words");
	end;

/*  *  *  *  *  *  VERY LARGE ARRAY PROCESSOR  *  *  *  *  *  */

/*  Begin VLA processing.  */

/*  Move common blocks that exceed a segment in size from the common block   */
/*  chain to the VLA chain.                                                  */
	if subr_options.VLC | subr_options.VLA_auto | subr_options.VLA_static | subr_options.VLA_parm then do;

	     if subr_options.VLC then do;
		prev_common_hdrp = null;
		common_hdri = sub_ptr -> subprogram.common_chain;
		do while (common_hdri ^= 0);
		     common_hdrp = addr (OS (common_hdri));
		     block_length =
			divide (common_hdrp -> header.length + units_per_word (common_hdrp -> header.units) - 1,
			units_per_word (common_hdrp -> header.units), 24);
		     if block_length > sys_info$max_seg_size then do;
						/*  Move block to VLA chain.  */
			if prev_common_hdrp = null then
			     sub_ptr -> subprogram.common_chain = common_hdrp -> header.next_header;
			else
			     prev_common_hdrp -> header.next_header = common_hdrp -> header.next_header;
			common_hdrp -> header.next_header = sub_ptr -> subprogram.VLA_chain;
			sub_ptr -> subprogram.VLA_chain = common_hdri;
			common_hdrp -> header.VLA = TRUE;
			do symi = common_hdrp -> header.first_element repeat symp -> symbol.next_member
			     while (symi ^= 0);
			     symp = addr (OS (symi));
			     symp -> symbol.VLA = TRUE;
			end;
		     end;
		     else
			prev_common_hdrp = common_hdrp;
						/*  Leave block on common chain.  */
		     if prev_common_hdrp = null then
			common_hdri = sub_ptr -> subprogram.common_chain;
		     else
			common_hdri = prev_common_hdrp -> header.next_header;
		end;
	     end;

/*  Move equivalence groups that exceed a segment in size from the           */
/*  equivalence chain to the VLA chain.                                      */
	     if subr_options.VLC | subr_options.VLA_auto | subr_options.VLA_static then do;
		prev_equiv_hdrp = null;
		equiv_hdri = sub_ptr -> subprogram.equiv_chain;
		do while (equiv_hdri ^= 0);
		     equiv_hdrp = addr (OS (equiv_hdri));
		     if ((subr_options.VLC & equiv_hdrp -> header.in_common)
			| (subr_options.VLA_auto & equiv_hdrp -> header.automatic)
			| (subr_options.VLA_static & equiv_hdrp -> header.static)) then do;
			block_length =
			     divide (equiv_hdrp -> header.length + units_per_word (equiv_hdrp -> header.units) - 1,
			     units_per_word (equiv_hdrp -> header.units), 24);
			if block_length > sys_info$max_seg_size then do;
						/*  Move group to VLA chain.  */
			     if prev_equiv_hdrp = null then
				sub_ptr -> subprogram.equiv_chain = equiv_hdrp -> header.next_header;
			     else
				prev_equiv_hdrp -> header.next_header = equiv_hdrp -> header.next_header;
			     equiv_hdrp -> header.next_header = sub_ptr -> subprogram.VLA_chain;
			     sub_ptr -> subprogram.VLA_chain = equiv_hdri;
			     equiv_hdrp -> header.VLA = TRUE;
			     do symi = equiv_hdrp -> header.first_element repeat symp -> symbol.next_member
				while (symi ^= 0);
				symp = addr (OS (symi));
				symp -> symbol.VLA = TRUE;
			     end;
			end;
			else
			     prev_equiv_hdrp = equiv_hdrp;
						/*  Leave group on equiv chain.  */
		     end;
		     else
			prev_equiv_hdrp = equiv_hdrp; /*  Leave group on equiv chain.  */
		     if prev_equiv_hdrp = null then
			equiv_hdri = sub_ptr -> subprogram.equiv_chain;
		     else
			equiv_hdri = prev_equiv_hdrp -> header.next_header;
		end;
	     end;

/*  Set the VLA flag and allocate a base addressor for each dimensioned,     */
/*  noncharacter parameter.  Add to the VLA chain all dimensioned, nonchar,  */
/*  parentless (i.e. not equivalenced nor common) variables whose size       */
/*  exceeds that of a segment.                                               */

	     if subr_options.VLA_auto | subr_options.VLA_static | subr_options.VLA_parm then do;
		symi = sub_ptr -> subprogram.first_symbol;
		do while (symi ^= 0);
		     symp = addr (OS (symi));
		     if symp -> symbol.dimensioned & ^symp -> symbol.character then
			if subr_options.VLA_parm & symp -> symbol.parameter then do;
			     symp -> symbol.VLA = TRUE;
			     vba_name = symp -> symbol.name;
			     vbai = build_symbol (vba_name, variable_attributes | attr_table (int_mode), SET);
			     vbap = addr (OS (vbai));
			     vbap -> symbol.data_type = int_mode;
			     vbap -> symbol.automatic = TRUE;
			     vbap -> symbol.element_size = 1;
			     addr (OS (symp -> symbol.dimension)) -> dimension.VLA_base_addressor = vbai;
			end;
			else if ((subr_options.VLA_auto & symp -> symbol.automatic)
			     | (subr_options.VLA_static & symp -> symbol.static)) then do;
			     if divide (addr (OS (symp -> symbol.dimension)) -> dimension.array_size
				+ units_per_word (symp -> symbol.units) - 1,
				units_per_word (symp -> symbol.units), 24) > sys_info$max_seg_size
				& symp -> symbol.parent = 0 then do;
						/*  Add symbol to VLA chain.  */
				allocate_symbol_name = 0;
				VLA_hdri = create_node (header_node, size (header));
				VLA_hdrp = addr (OS (VLA_hdri));
				VLA_hdrp -> header.next_header = sub_ptr -> subprogram.VLA_chain;
				sub_ptr -> subprogram.VLA_chain = VLA_hdri;
				string (VLA_hdrp -> header.storage_info) = string (symp -> symbol.storage_info);
				if symp -> symbol.double_precision | symp -> symbol.complex then
				     VLA_hdrp -> header.even = TRUE;
				else if symp -> symbol.character & subr_options.ansi_77 then
				     VLA_hdrp -> header.character = TRUE;
				string (VLA_hdrp -> header.storage_class) =
				     substr (string (symp -> symbol.storage_class), 1, 3);
				VLA_hdrp -> header.units = symp -> symbol.units;
				VLA_hdrp -> header.VLA = TRUE;
				VLA_hdrp -> header.length =
				     addr (OS (symp -> symbol.dimension)) -> dimension.array_size;
				VLA_hdrp -> header.first_element, VLA_hdrp -> header.last_element = symi;
				symp -> symbol.VLA = TRUE;
				symp -> symbol.parent = VLA_hdri;
			     end;
			end;
		     symi = symp -> symbol.next_symbol;
		end;
	     end;

/*  For each VLA group, create an integer variable to hold the base address  */
/*  of the group.  If the group has a name, that name is also given to the   */
/*  integer variable; otherwise, the name of the first variable in the group */
/*  which has an offset of zero is given to the integer variable.            */

	     do VLA_hdri = sub_ptr -> subprogram.VLA_chain repeat VLA_hdrp -> header.next_header while (VLA_hdri ^= 0);
		VLA_hdrp = addr (OS (VLA_hdri));
		if VLA_hdrp -> header.block_name = "" then
		     vba_name = NO_NAME;
		else
		     vba_name = VLA_hdrp -> header.block_name;
		do symi = VLA_hdrp -> header.first_element repeat symp -> symbol.next_member
		     while (vba_name = NO_NAME & symi ^= 0);
		     symp = addr (OS (symi));
		     if symp -> symbol.offset = 0 then
			vba_name = symp -> symbol.name;
		end;
		vbai = build_symbol (vba_name, variable_attributes | attr_table (int_mode), SET);
		vbap = addr (OS (vbai));
		vbap -> symbol.data_type = int_mode;
		if VLA_hdrp -> header.automatic then
		     vbap -> symbol.automatic = TRUE;
		else
		     vbap -> symbol.static = TRUE;
		vbap -> symbol.element_size = 1;
		VLA_hdrp -> header.VLA_base_addressor = vbai;
		do symi = VLA_hdrp -> header.first_element repeat symp -> symbol.next_member while (symi ^= 0);
		     symp = addr (OS (symi));
		     if symp -> symbol.dimensioned then
			addr (OS (symp -> symbol.dimension)) -> dimension.VLA_base_addressor = vbai;
		end;
	     end;

	end;					/*  End VLA processing.  */

/*  *  *  *  *  *  LARGE ARRAY PROCESSOR  *  *  *  *  *  */

	if subr_options.LA_auto | subr_options.LA_static then do;
						/*  Begin LA processing.  */

/*  We must add all the array variables that are not parameters, nor VLA's   */
/*  nor in common to the Large Array chain.  We must also add long scalar    */
/*  character variables (i.e. longer than 'max_char_length') which are       */
/*  not parameters nor in common.  Each member of the Large Array chain looks*/
/*  like an equivalence group whose total storage does not exceed a segment. */
/*  Array variables are assigned to the Large Array chain in such a way that */
/*  a variable that does not exceed 16K in size will be totally contained in */
/*  the first 16K of the group in which it is entered.  (This allows us to   */
/*  generate more efficient code, since extra instructions are generated to  */
/*  access data outside the first 16K of a storage area.)                    */
/*                                                                           */
/*  There are two sources of arrays for the Large Array chain: parentless,   */
/*  dimensioned nonparameter symbols and the equivalence chain.  We pass     */
/*  through each of these sources twice.  The first time we pick out all     */
/*  arrays less than or equal to 16K in size.  The second time we pick up    */
/*  the rest.                                                                */

	     do max_length_this_pass = 16384, sys_info$max_seg_size;

/*  Run through the symbol table looking for parentless, nonparameter arrays */
/*  and long, parentless, nonparameter character scalars.  Add those whose   */
/*  size does not exceed 'max_length_this_pass' to a group in the LA chain,  */
/*  creating a new group if necessary.                                       */

		do symi = sub_ptr -> subprogram.first_symbol repeat symp -> symbol.next_symbol while (symi ^= 0);
		     symp = addr (OS (symi));
		     if ^symp -> symbol.parameter & symp -> symbol.parent = 0
			& (symp -> symbol.dimensioned
			| (symp -> symbol.character & symp -> symbol.char_size >= max_char_length)) then do;
			if ((subr_options.LA_auto & symp -> symbol.automatic)
			     | (subr_options.LA_static & symp -> symbol.static)) then do;
			     if symp -> symbol.dimensioned then
				symbol_length =
				     divide (addr (OS (symp -> symbol.dimension)) -> dimension.array_size
				     + units_per_word (symp -> symbol.units) - 1,
				     units_per_word (symp -> symbol.units), 18);
			     else
				symbol_length =
				     divide (symp -> symbol.char_size + chars_per_word - 1, chars_per_word, 18);
			     if symbol_length <= max_length_this_pass then do;
						/*  Add symbol to an LA group.  */
				symbol_even = symp -> symbol.double_precision | symp -> symbol.complex;
				symbol_storage_class = substr (string (symp -> symbol.storage_class), 1, 3);
				if symbol_storage_class = ""b then
				     symbol_storage_class = string (sub_ptr -> subprogram.default_is);
				prev_LA_hdrp = null;
				do LA_hdri = sub_ptr -> subprogram.LA_chain
				     repeat LA_hdrp -> header.next_header
				     while (symp -> symbol.parent = 0 & LA_hdri ^= 0);
				     LA_hdrp = addr (OS (LA_hdri));
				     block_length = LA_hdrp -> header.length;
				     if symbol_even then
					block_length = block_length + mod (block_length, 2);
				     if string (LA_hdrp -> header.storage_class) = symbol_storage_class
					& block_length + symbol_length <= max_length_this_pass then do;
						/*  Add symbol to end of this LA group.  */
					addr (OS (LA_hdrp -> header.last_element)) -> symbol.next_member = symi;
					string (LA_hdrp -> header.storage_info) =
					     string (LA_hdrp -> storage_info)
					     | string (symp -> symbol.storage_info);
					LA_hdrp -> header.last_element = symi;
					LA_hdrp -> header.length = block_length + symbol_length;
					symp -> symbol.LA = TRUE;
					symp -> symbol.parent = LA_hdri;
					symp -> symbol.offset =
					     units_per_word (symp -> symbol.units) * block_length;
				     end;
				     prev_LA_hdrp = LA_hdrp;
				end;
				if symp -> symbol.parent = 0 then do;
						/*  Create a new group for this array.  */
				     allocate_symbol_name = 0;
				     LA_hdri = create_node (header_node, size (header));
				     if prev_LA_hdrp = null then
					sub_ptr -> subprogram.LA_chain = LA_hdri;
				     else
					prev_LA_hdrp -> header.next_header = LA_hdri;
				     LA_hdrp = addr (OS (LA_hdri));
				     string (LA_hdrp -> header.storage_info) =
					string (symp -> symbol.storage_info);
				     LA_hdrp -> header.even = TRUE;
				     string (LA_hdrp -> header.storage_class) = symbol_storage_class;
				     LA_hdrp -> header.LA = TRUE;
				     LA_hdrp -> header.length = symbol_length;
				     LA_hdrp -> header.first_element, LA_hdrp -> header.last_element = symi;
				     symp -> symbol.LA = TRUE;
				     symp -> symbol.parent = LA_hdri;
				end;
			     end;
			end;
		     end;
		end;

/*  Run through the equivalence chain looking for groups whose size is more  */
/*  than that required for one element of the dominant type in the group but */
/*  not exceeding 'max_length_this_pass' and move them to a group in the LA  */
/*  chain, creating a new group if necessary.                                */

		prev_equiv_hdrp = null;
		equiv_hdri = sub_ptr -> subprogram.equiv_chain;
		do while (equiv_hdri ^= 0);
		     equiv_hdrp = addr (OS (equiv_hdri));
		     if ((subr_options.LA_auto & equiv_hdrp -> header.automatic)
			| (subr_options.LA_static & equiv_hdrp -> header.static)) then do;
			group_length =
			     divide (equiv_hdrp -> header.length + units_per_word (equiv_hdrp -> header.units) - 1,
			     units_per_word (equiv_hdrp -> header.units), 18);
			if group_length > bin (equiv_hdrp -> header.even) + 1 & group_length <= max_length_this_pass
			then do;			/*  Move this equivalence group to the LA chain.  */
			     if prev_equiv_hdrp = null then
				sub_ptr -> subprogram.equiv_chain = equiv_hdrp -> header.next_header;
			     else
				prev_equiv_hdrp -> header.next_header = equiv_hdrp -> header.next_header;
			     prev_LA_hdrp = null;
			     added_group = FALSE;
			     do LA_hdri = sub_ptr -> subprogram.LA_chain repeat LA_hdrp -> header.next_header
				while (^added_group & LA_hdri ^= 0);
				LA_hdrp = addr (OS (LA_hdri));
				block_length = LA_hdrp -> header.length;
				if equiv_hdrp -> header.even then
				     block_length = block_length + mod (block_length, 2);
				if string (LA_hdrp -> header.storage_class)
				     = string (equiv_hdrp -> header.storage_class)
				     & block_length + group_length <= max_length_this_pass then do;
						/*  Move equiv group to end of this LA group.  */
				     addr (OS (LA_hdrp -> header.last_element)) -> symbol.next_member =
					equiv_hdrp -> header.first_element;
				     string (LA_hdrp -> header.storage_info) =
					string (LA_hdrp -> storage_info)
					| string (equiv_hdrp -> header.storage_info);
				     LA_hdrp -> header.last_element = equiv_hdrp -> header.last_element;
				     LA_hdrp -> header.length = block_length + group_length;
				     do symi = equiv_hdrp -> header.first_element
					repeat symp -> symbol.next_member while (symi ^= 0);
					symp = addr (OS (symi));
					symp -> symbol.LA = TRUE;
					symp -> symbol.parent = LA_hdri;
					symp -> symbol.offset =
					     symp -> symbol.offset
					     + units_per_word (symp -> symbol.units) * block_length;
				     end;
				     allocate_symbol_name = equiv_hdrp -> header.name_length;
				     if equiv_hdri + size (header) = next_free_operand then
					next_free_operand = equiv_hdri;
						/*  Storage can be reused.  */
				     added_group = TRUE;
				end;
				prev_LA_hdrp = LA_hdrp;
			     end;
			     if ^added_group then do; /*  Create a new LA group from the equiv group.  */
				if prev_LA_hdrp = null then
				     sub_ptr -> subprogram.LA_chain = equiv_hdri;
				else
				     prev_LA_hdrp -> header.next_header = equiv_hdri;
				equiv_hdrp -> header.next_header = 0;
				equiv_hdrp -> header.LA = TRUE;
				equiv_hdrp -> header.units = word_units;
				equiv_hdrp -> header.length = group_length;
				do symi = equiv_hdrp -> header.first_element
				     repeat symp -> symbol.next_member while (symi ^= 0);
				     symp = addr (OS (symi));
				     symp -> symbol.LA = TRUE;
				end;
			     end;
			end;
			else
			     prev_equiv_hdrp = equiv_hdrp;
						/*  Leave group on equiv chain.  */
		     end;
		     else
			prev_equiv_hdrp = equiv_hdrp; /*  Leave group on equiv chain.  */
		     if prev_equiv_hdrp = null then
			equiv_hdri = sub_ptr -> subprogram.equiv_chain;
		     else
			equiv_hdri = prev_equiv_hdrp -> header.next_header;
		end;
	     end;
	end /*  End of LA processing.  */;

	return;


get_equiv_var:
     procedure (hdr, hdr_ptr, char_offset) returns (fixed bin (24));

dcl      hdr fixed bin (18);
dcl      hdr_ptr pointer;
dcl      char_offset bit (1);
dcl      offset fixed bin (24);
dcl      length fixed bin (24);

	indx = stack (i);
	indx_ptr = addr (OS (indx));
	i = i + 1;

/* set character_offset to see if ansi77 equiv group rules hold, tested later
   in the routine 'verify_offset_type_kludge' */

	char_offset = indx_ptr -> symbol.mode.character & subr_options.ansi_77;

	if (unspec (addr (OS (indx)) -> symbol.attributes) & equiv_conflicts) | addr (OS (indx)) -> symbol.by_compiler
	then do;
	     call print_message (64, indx);		/* cannot be equivalenced */
	     i = i + 1;
	     return (0);
	end;

	offset = stack (i) * indx_ptr -> symbol.element_size + stack (i + 1);
	i = i + 2;

	if offset > max_fixed_bin_24 then do;
	     call print_message (136, "length", indx, ltrim (char (max_fixed_bin_24)));
						/* implementation restriction */
	     return (0);
	end;

	if indx_ptr -> symbol.equivalenced & indx_ptr -> symbol.parent > 0 then do;
	     hdr = indx_ptr -> symbol.parent;
	     hdr_ptr = addr (OS (hdr));

	     offset = offset + indx_ptr -> symbol.offset;
	     if char_offset then
		hdr_ptr -> header.units = char_units;
	end;
	else do;
	     if indx_ptr -> symbol.dimensioned then do;
		length = addr (OS (indx_ptr -> symbol.dimension)) -> dimension.array_size;
		if length = 0 then do;
		     call print_message (65, indx);	/* cannot be equivalenced */
		     return (0);
		end;
	     end;
	     else
		length = indx_ptr -> symbol.element_size;

	     allocate_symbol_name = 0;		/* no name for equivalence group */
	     hdr = create_node (header_node, size (header));
	     hdr_ptr = addr (OS (hdr));

	     string (hdr_ptr -> header.storage_class) = substr (string (indx_ptr -> symbol.storage_class), 1, 3);
	     string (hdr_ptr -> header.storage_info) = string (indx_ptr -> symbol.storage_info);
	     hdr_ptr -> header.next_header = sub_ptr -> equiv_chain;
	     sub_ptr -> equiv_chain = hdr;
	     hdr_ptr -> header.first_element, hdr_ptr -> header.last_element = indx;
	     hdr_ptr -> header.length = length;
	     if char_offset then
		hdr_ptr -> header.units = char_units;

	     if indx_ptr -> symbol.double_precision | indx_ptr -> symbol.complex then
		hdr_ptr -> header.even = TRUE;

	     indx_ptr -> symbol.parent = hdr;
	     indx_ptr -> symbol.equivalenced = TRUE;
	end;

	equiv_error = FALSE;

	return (offset);
     end get_equiv_var;

verify_offset_type_kludge:
     proc (offset, char_type_offset) returns (fixed bin (24));

/* This routine allows ansi77 character variables to be equivalenced to other
   data types.  This is strickly AGAINST the standard.  We allow it for people
   who wish to use strange and dangerous programming practices.

   The code just checks to see if the offset is of type character and then
   whether the offset is actually supposed to be in words.  If so, it is
   converted.  */

dcl      char_type_offset bit (1);
dcl      offset fixed bin (24);
dcl      new_offset fixed bin (24);

	new_offset = offset;

	if char_type_offset then
	     if ^all_character_offsets_in_group then do;
		if stack (i + 2) > 0 then
		     return (new_offset);

		if mod (new_offset, 4) ^= 0 then do;
		     call print_message (63, indx);
		     goto equivalence_member_abort;
		end;
		new_offset = new_offset / 4;
	     end;
	return (new_offset);
     end verify_offset_type_kludge;

validate_array_bound:
     proc (bnd_sym_idx);

/* Check that a variable array bound is a common or parameter, scalar, integer
   variable, or the result of an arithmetic expression of such variables. */

dcl      bnd_sym_idx fixed bin (24);			/* Index of the symbol containing the bound. */

dcl      bnd_sym_ptr ptr,
         expression_size fixed bin,
         expression_start fixed bin (18),
         opnd_idx fixed bin (24),
         polish_idx fixed bin (18);

	bnd_sym_ptr = addr (OS (bnd_sym_idx));
	if ^bnd_sym_ptr -> symbol.by_compiler then
	     call validate (bnd_sym_idx);
	else if bnd_sym_ptr -> symbol.initial ^= 0 then do;
	     expression_start = bnd_sym_ptr -> symbol.initial;
	     expression_size = polish_string (expression_start - 1);
	     do polish_idx = expression_start to expression_start + expression_size - 1;
		opnd_idx = polish_string (polish_idx);
		if opnd_idx > last_assigned_op then
		     if addr (OS (opnd_idx)) -> node.node_type = symbol_node then
			call validate (opnd_idx);
	     end;
	end;
	return;


validate:
     procedure (ndx);

declare	ndx fixed binary (24);			/* INPUT: index of array bound symbol */
declare	symbol_storage bit (5) unaligned defined (sym_ptr -> symbol.storage_info);
declare	sym_ptr pointer;
declare	header_storage bit (5) unaligned defined (addr (OS (sym_ptr -> symbol.parent)) -> header.storage_info);

	sym_ptr = addr (OS (ndx));
	call set_data_fields ((ndx));

	if ^(sym_ptr -> symbol.parameter | sym_ptr -> symbol.in_common) | ^sym_ptr -> symbol.integer
	     | sym_ptr -> symbol.dimensioned then
	     call print_message (19, ndx, SI);
	else
	     symbol_storage = symbol_storage | REF;

/* if variable is in common, set common block header to indicate it is REF */

	if sym_ptr -> symbol.in_common & sym_ptr -> symbol.parent ^= 0 then
	     header_storage = header_storage | REF;

     end validate;
     end validate_array_bound;

     end declaration_processor;

/* BEGIN ext_parse section -SUPPORT  - split 82-03-29  T. Oke */

/* Modification History - 82-04-05 */

/* Modification:
	10 Feb 83, HH - Install LA/VLA support.
	08 Feb 83, HH - 366/369: Fix bug where 'parse_data' fails to force
	     initial value of a character variable to be at least as long
	     as the character variable.
	13 Dec 82, TO - 365: Fix bug in 'parse_expression', where substr
	     processing of (x:) uses 'indx' left from 'x' expression parse,
	     rather than the index of the string symbol which is currently
	     in the stack.
	21 May 82,  TO  - Have needs_descriptors of args set if character
	     and in ansi77 mode.
	19 May 82,  TO  - Have needs_descriptors set if star_extent char 
	     array, as well as variable_extents array in parse_expression.
	 6 May 82,  TO  - Fix bug of reference to entry point in assigning
	     result of  function, link entry assignment to 'return_value'.
	 4 May 82,  TO  - Add needs_descriptors check in parse_expression,
	     to manage setting descriptor requirement for local auto
	     stack allocated variable of character*(*) function.
	 5 Apr 82,  TO  - Check number of args in parse_parameter_list.
	*/

set_data_fields:
     procedure (a_sym);

dcl      a_sym fixed bin (18);
dcl      sym fixed bin (18);
dcl      array_max_size fixed bin (24);
dcl      dt fixed bin (18);
dcl      sp pointer;
dcl      te fixed bin (24);
dcl      wc fixed bin (18);

	sym = a_sym;

	call assign_data_type (sym);

	sp = addr (OS (sym));
	if sp -> symbol.data_type ^= 0 then
	     return;

	dt, sp -> symbol.data_type = index (string (sp -> symbol.mode), TRUE);

	if dt ^= char_mode then
	     wc, sp -> symbol.element_size = data_type_size (dt);
	else if subr_options.ansi_77 then do;
	     wc, sp -> symbol.element_size = sp -> symbol.char_size + 1;
	     sp -> symbol.units = char_units;
	end;
	else
	     wc, sp -> symbol.element_size = divide (sp -> symbol.char_size + chars_per_word, chars_per_word, 17, 0);

	if sp -> symbol.dimensioned & ^sp -> symbol.variable_extents & ^sp -> symbol.star_extents then do;
	     te = addr (OS (sp -> symbol.dimension)) -> dimension.element_count * wc;

	     if dt = char_mode then
		array_max_size = max_array_size.char;
	     else if sp -> symbol.automatic then
		array_max_size = max_array_size.auto;
	     else if sp -> symbol.in_common then
		array_max_size = max_array_size.common;
	     else if sp -> symbol.parameter then
		array_max_size = max_array_size.parm;
	     else if sp -> symbol.static then
		array_max_size = max_array_size.static;
	     else
		array_max_size =
		     max (max_array_size.auto, max_array_size.common, max_array_size.parm, max_array_size.static);

	     if te > array_max_size * units_per_word (sp -> symbol.units) then
		call print_message (136, "size", sym, ltrim (char (array_max_size)) || " words");
	     else
		addr (OS (sp -> symbol.dimension)) -> dimension.array_size = te;
	end;

	return;
     end set_data_fields;

assign_data_type:
     procedure (sym_index);

dcl      sp pointer;
dcl      sym_index fixed bin (18);

	sp = addr (OS (sym_index));
	if string (sp -> symbol.mode) ^= ZERO then
	     return;

	unspec (sp -> symbol.attributes) =
	     unspec (sp -> symbol.attributes) | default_table (index (alphabetic, substr (sp -> symbol.name, 1, 1)));
     end assign_data_type;

build_main_program:
     procedure (subpr_symb);

/* given the index of the symbol for this main program, set the subprogram node */

declare	subpr_symb fixed binary (18);			/* INPUT: index of symbol for main prog */

/* main program must be first */
	if cur_subprogram ^= first_subprogram then
	     call print_message (3);

/* set symbol for the entry point, link entry point to block, treat as user symbol */
	subprogram_symbol = subpr_symb;
	subprogram_conflicts = all_attributes;
	subprogram_attributes = main_attr;
	unspec (addr (OS (subprogram_symbol)) -> symbol.attributes) = main_attr;
	unspec (addr (OS (subprogram_symbol)) -> symbol.storage_info) = SET;
	addr (OS (subprogram_symbol)) -> symbol.parent = cur_subprogram;
	addr (OS (subprogram_symbol)) -> symbol.by_compiler = FALSE;

/* fill in type of subprogram and point to its symbol */

	sub_ptr -> subprogram_type = main_program;
	sub_ptr -> subprogram.symbol = subprogram_symbol;

/* Start the list of pending entries. */

	pending_entry_cnt = 1;
	pending_entry (1).entry_symbol = subprogram_symbol;
	if statement_type < after_subprogram then
	     pending_entry (1).entry_stmnt = unspec (cur_stmnt_ptr -> statement);
	else do;					/* There is no 'program' statement; fake a 'statement' node. */
	     pending_entry (1).entry_stmnt = ""b;
	     addr (pending_entry (1).entry_stmnt) -> statement.op_code = stat_op;
	     addr (pending_entry (1).entry_stmnt) -> statement.location = (18)"1"b;
	     addr (pending_entry (1).entry_stmnt) -> statement.statement = "00001"b;
	     addr (pending_entry (1).entry_stmnt) -> statement.put_in_map = TRUE;
	end;

	subprogram_op = main_op;
	return_value_param = 0;

	return;
     end build_main_program;

build_common_block:
     procedure (common_blk_name) returns (fixed binary (18));

/* build a header node and initialize it for a common-block */

declare	common_blk_name char (256) varying;		/* INPUT - name of common block */
declare	indxx fixed binary (18);			/* Return value */
declare	header_ptr pointer;

	allocate_symbol_name = length (common_blk_name);
	indxx = create_node (header_node, size (header));
	header_ptr = addr (OS (indxx));

	string (header_ptr -> header.storage_class) = common_storage;
	header_ptr -> header.even = TRUE;		/* MUST be on double-word boundary */
	header_ptr -> header.name_length = allocate_symbol_name;
	substr (header_ptr -> header.block_name, 1, allocate_symbol_name) = common_blk_name;

	return (indxx);
     end build_common_block;

process_pending_entries:
     proc;

/* For each pending entry, emit a 'main', 'func' or 'subr' operator, as
   appropriate.  If the entry has parameters, emit assignments to initialize
   any associated compiler generated array bound variables, then emit a
   'process_param_list' operator. */

dcl      Asterisk fixed bin static options (constant) init (0);

dcl      arg_desc_cnt fixed bin,
         arg_desc_idx fixed bin,
         arg_desc_ptr ptr,
         arg_symbol_ptr ptr,
         bound_is_expression bit (1),
         bound_symbol_ptr ptr,
         bypass_label fixed bin (18),
         dim_cnt fixed bin,
         dim_idx fixed bin,
         dimension_ptr ptr,
         entry_symbol fixed bin (18),
         entry_symbol_ptr ptr,
         expression_size fixed bin,
         expression_start fixed bin (18),
         i fixed bin,
         idx_of_count fixed bin (18),
         last_upper_bound fixed bin,
         param_count fixed bin,
         pending_entry_idx fixed bin,
         polish_idx fixed bin,
         stmnt_ptr ptr;

	if cur_statement + size (statement) < next_free_polish then
	     call emit_statement_op (cur_stmnt_ptr);	/* Insure last Polish item is a stat-op. */
	bypass_label = 0;
	do pending_entry_idx = 1 to pending_entry_cnt;
	     entry_symbol = pending_entry (pending_entry_idx).entry_symbol;

/* If there is more than one pending entry, the second and subsequent ones
   must be bypassed (i.e. preceded by a branch to the statement following
   the last pending entry) so that control can not "fall" into the entry
   sequence code from the preceding entry.  The 'bypass_first_pending_entry'
   flag tells us if we have to bypass the first entry. */

	     if bypass_label = 0 & (pending_entry_idx > 1 | bypass_first_pending_entry) then do;
						/* This is the 1st entry to bypass; create the bypass label. */
		cp_label_count = cp_label_count - 1;	/* Generate a unique label number. */
		bypass_label = create_label (cp_label_count, executable_label, GOTO_TARGET);
	     end;
	     if bypass_label ^= 0 then do;		/* Emit a jump to the bypass label. */
		call emit_operand (bypass_label);
		call emit_operator (jump_op);
		stmnt_ptr = cur_stmnt_ptr;
		call emit_statement_op (cur_stmnt_ptr);
		unspec (stmnt_ptr -> statement) = pending_entry (pending_entry_idx).entry_stmnt;
		stmnt_ptr -> statement.next = bit (cur_statement, 18);
	     end;

/* Emit a 'main_op', 'subr_op' or 'func_op', as required for this entry. */

	     call emit_operand (entry_symbol);
	     call emit_count (idx_of_count);
	     call emit_operator ((subprogram_op));

/* Determine the number of parameters for this entry.  The parameters are
   the "nonasterisk" arguments plus any return value.  Also, if the entry
   has any expression extent array parameters, emit assignments to
   initialize the compiler generated bound variables to the expressions. */

	     if return_value_param = 0 then
		param_count = 0;
	     else
		param_count = 1;

	     entry_symbol_ptr = addr (OS (entry_symbol));
	     if entry_symbol_ptr -> symbol.general = 0 then
		arg_desc_cnt = 0;
	     else do;
		arg_desc_ptr = addr (OS (entry_symbol_ptr -> symbol.general));
		arg_desc_cnt = arg_desc_ptr -> arg_desc.n_args;
	     end;

	     do arg_desc_idx = 1 to arg_desc_cnt;
		if arg_desc_ptr -> arg_desc.symbol (arg_desc_idx) ^= Asterisk then do;
		     param_count = param_count + 1;
		     arg_symbol_ptr = addr (OS (arg_desc_ptr -> arg_desc.symbol (arg_desc_idx)));

		     if arg_symbol_ptr -> symbol.variable_extents then do;
						/* Check if any of the variable extents are expressions. */
			dimension_ptr = addr (OS (arg_symbol_ptr -> symbol.dimension));
			dim_cnt = dimension_ptr -> dimension.number_of_dims;

			if dimension_ptr -> dimension.assumed_size then
			     last_upper_bound = dim_cnt - 1;
			else
			     last_upper_bound = dim_cnt;

			do dim_idx = 1 to dim_cnt;
			     do i = 1 to 2;		/* Check lower and upper bound of 'dim_idx'th dimension. */
				if i = 1 then
				     if dimension_ptr -> dimension.v_bound (dim_idx).lower then do;
					bound_symbol_ptr =
					     addr (OS (dimension_ptr -> dimension.lower_bound (dim_idx)));
					bound_is_expression = bound_symbol_ptr -> symbol.by_compiler;
				     end;
				     else
					bound_is_expression = FALSE;
				else if dimension_ptr -> dimension.v_bound (dim_idx).upper
				     & dim_idx <= last_upper_bound then do;
				     bound_symbol_ptr =
					addr (OS (dimension_ptr -> dimension.upper_bound (dim_idx)));
				     bound_is_expression = bound_symbol_ptr -> symbol.by_compiler;
				end;
				else
				     bound_is_expression = FALSE;

				if bound_is_expression then do;
						/* Emit assignment of bound expression to bound variable. */
				     expression_start = bound_symbol_ptr -> symbol.initial;
				     expression_size = polish_string (expression_start - 1);

				     if next_free_polish + expression_size + 2 >= polish_max_len then
					call print_message (67, "polish string", char (polish_max_len));
				     else do;
					call emit_operand (fixed (rel (bound_symbol_ptr)));
					do polish_idx = expression_start
					     to expression_start + expression_size - 1;
					     polish_string (next_free_polish) = polish_string (polish_idx);
					     next_free_polish = next_free_polish + 1;
					end;
					call emit_operator (assign_op);
				     end;
				end;
			     end;
			end;
		     end;
		end;
	     end;

/* If there are any parameters, emit the 'process_param_list' operator. */

	     if param_count > 0 then do;
		polish_string (idx_of_count) = param_count - bias;
						/* Store param_count in entry op. */
		call emit_operand (param_count - bias);
		call emit_operator (process_param_list_op);
		do arg_desc_idx = 1 to arg_desc_cnt;
		     if arg_desc_ptr -> arg_desc.symbol (arg_desc_idx) ^= Asterisk then do;
			call emit_operand ((arg_desc_ptr -> arg_desc.symbol (arg_desc_idx)));
			call emit_operator (item_op);
		     end;
		end;
		if return_value_param ^= 0 then do;
		     call emit_operand (return_value_param);
		     call emit_operator (item_op);
		end;
		call emit_operator (eol_op);
	     end;

/* Emit a new stat-op for the next statement, then change the preceding one
   to reflect the entry we just processed. */

	     stmnt_ptr = cur_stmnt_ptr;
	     call emit_statement_op (cur_stmnt_ptr);
	     unspec (stmnt_ptr -> statement) = pending_entry (pending_entry_idx).entry_stmnt;
	     stmnt_ptr -> statement.next = bit (cur_statement, 18);
	end;

/* If we bypassed any entries, emit the bypass label. */

	if bypass_label ^= 0 then do;
	     call emit_operand (bypass_label);
	     call emit_operator (label_op);
	     stmnt_ptr = cur_stmnt_ptr;
	     call emit_statement_op (cur_stmnt_ptr);
	     unspec (stmnt_ptr -> statement) = pending_entry (pending_entry_cnt).entry_stmnt;
	     stmnt_ptr -> statement.next = bit (cur_statement, 18);
	end;

	pending_entry_cnt = 0;
     end process_pending_entries;

emit_operator:
emit_operand:
emit_halfword:
     procedure (op_name_or_opnd_or_data);		/*	Program Specifications (emit_operator)

     Inputs

     Output

     Description (emit_operator)
*/

dcl      count fixed bin (18);
dcl      op_name_or_opnd_or_data fixed bin (18);
dcl      st_info_p ptr;
dcl      stmnt_info_ptr ptr;
dcl      wrd_off fixed bin (18);

	if next_free_polish >= polish_max_len then
	     call print_message (67, "polish string", char (polish_max_len));
						/* polish string too long */
	else do;
	     polish_string (next_free_polish) = op_name_or_opnd_or_data;
	     next_free_polish = next_free_polish + 1;
	end;
	return;

emit_count:
     entry (wrd_off);
	if next_free_polish >= polish_max_len then
	     call print_message (67, "polish string", char (polish_max_len));
						/* polish string too long */
	else do;
	     polish_string (next_free_polish) = -bias;
	     wrd_off = next_free_polish;
	     next_free_polish = next_free_polish + 1;
	end;
	return;

emit_statement_op:
     entry (st_info_p);
	stmnt_info_ptr = st_info_p;			/* Copy value in case input arg is cur_stmnt_ptr. */

	last_cur_statement = cur_statement;

	if next_free_polish + size (statement) >= polish_max_len then
	     call print_message (67, "polish string", char (polish_max_len));
	else do;
	     cur_statement = next_free_polish;
	     cur_stmnt_ptr = addr (polish_string (cur_statement));
	     cur_stmnt_ptr -> statement = stmnt_info_ptr -> statement;

	     next_free_polish = next_free_polish + size (statement);

	     if last_statement ^< 0 then
		addr (polish_string (last_statement)) -> statement.next = bit (cur_statement, 18);

	     last_statement = cur_statement;
	end;
	return;

increment_polish:
     entry (count);
	if next_free_polish + count >= polish_max_len then
	     call print_message (67, "polish string", char (polish_max_len));
	else do;
	     if count = 1 then
		polish_string (next_free_polish) = no_op;
	     else do;
		polish_string (next_free_polish) = increment_polish_op;
		polish_string (next_free_polish + 1) = count - 2;
	     end;
	     next_free_polish = next_free_polish + count;
	end;
	return;
     end emit_operator;

emit_return_op:
     procedure;
	if subprogram_op = func_op then do;
	     call emit_operand (return_value_param);
	     call emit_operand (return_value);
	     call emit_operator (assign_op);
	end;
	call emit_operator (return_op);
     end emit_return_op;

finish_sf_defs:
     proc;
	if sub_ptr -> subprogram_type = block_data then
	     call print_message (4);			/* executable statement in block data */

	assignment_statement_index = assignment_statement;
     end finish_sf_defs;

generate_cross_ref:
     procedure (item);

dcl      item fixed bin (18);


	if number_of_crefs = max_fixed_bin_18 then
	     call print_message (67, "cross reference region", char (max_fixed_bin_18));

	number_of_crefs = number_of_crefs + 1;
	cross_reference (number_of_crefs).symbol = item;

	if cur_statement < 0 | addr (polish_string (cur_statement)) -> statement.line = ZERO then
	     cross_reference (number_of_crefs).line_no = 0;
	else
	     cross_reference (number_of_crefs).line_no = cur_statement_list;
     end generate_cross_ref;

declare_symbol:
     procedure (indx, attributes, conflicts, storage_type) returns (bit (1) aligned);

/*	Program Specifications (declare_symbol)

     Inputs

     Output

     Description (declare_symbol)
*/

dcl      attributes bit (47) aligned;
dcl      conflicts bit (47) aligned;
dcl      header_storage bit (5) unaligned defined (addr (OS (indx_ptr -> symbol.parent)) -> header.storage_info);
dcl      indx fixed bin (18);
dcl      indx_ptr pointer;
dcl      storage_type bit (5) aligned;
dcl      symbol_storage bit (5) unaligned defined (indx_ptr -> symbol.storage_info);

	indx_ptr = addr (OS (indx));

	if (unspec (indx_ptr -> symbol.attributes) & conflicts) ^= ZERO then
	     return (FALSE);

	unspec (indx_ptr -> symbol.attributes) = unspec (indx_ptr -> symbol.attributes) | attributes;

	if storage_type ^= DECLARED then do;
	     symbol_storage = symbol_storage | storage_type;
	     if indx_ptr -> symbol.equivalenced then
		if indx_ptr -> symbol.parent > 0	/* update header only if it exists */
		     then
		     header_storage = header_storage | storage_type;
	end;

	return (TRUE);
     end declare_symbol;

enter_label:
     procedure (a_type, a_value, a_usage) returns (fixed bin (18));

/*	Program Specifications (enter_label)

     Inputs

     Output

     Description (enter_label)
	The fact that legal values for label_type are "01"b, "10"b, "11"b is used in
	selecting error messages.

	In '66 mode, branching into a do-loop is legal.  It is not legal in
	'77 mode and we diagnose a fatal error if we detect it.  We detect
	a branch into a do-loop as follows:  For each executable label, we
	keep track (in its 'label' node) of whether it is branched to or
	ends a do loop, and the statement number of the loop end of the
	do-loop that immediately contains the first executable reference
	to the label.  If we are asked to define an executable label that
	is branched to but which does not end a loop, we check that the
	loop which contained the first branch to the label is the same
	as or contained in the current loop.  If we are asked to reference
	a label in a DO statement, we check that the label has not yet
	been branched to.  If we are asked to reference a label that has
	already been defined, we check that it does not end a loop and
	that the loop containing the referencing statement is the same
	as or contained in the loop which contained the statement which
	defined the label.
*/

dcl      a_type bit (2) aligned;
dcl      a_usage bit (5) aligned;
dcl      a_value fixed bin (18);
dcl      actual_type bit (2) aligned;
dcl      current_loop_end fixed bin (18);
dcl      in_list bit (1) aligned;
dcl      indx fixed bin (18);
dcl      label_storage bit (5) aligned;
dcl      label_type bit (2) aligned;
dcl      label_value fixed bin (18);
dcl      last_item fixed bin (18);
dcl      loop_end fixed bin (18);
dcl      lp pointer;

	label_type = a_type;
	label_value = a_value;
	label_storage = a_usage;

	current_loop_end = 0;
	do indx = do_index to 1 by -1 while (current_loop_end = 0);
	     if do_blockif_stack (indx).do_loop then
		current_loop_end = do_blockif_stack (indx).label_ptr;
	end;

	if label_value <= 0 | label_value > 99999 then do;
	     call print_message (69, char (decimal (label_value, 12)));
						/* label is illegal */
	     label_value = min (max_fixed_bin_18, abs (label_value));
	end;

	last_item = mod (label_value, dim (label_hash_table, 1));
	indx = label_hash_table (last_item);

	in_list = TRUE;

	if indx > 0 then
	     do while (in_list);
		lp = addr (OS (indx));
		if lp -> label.name = label_value then
		     in_list = FALSE;
		else do;
		     last_item = indx;
		     indx = lp -> label.hash_chain;
		     if indx = 0 then
			in_list = FALSE;
		end;
	     end;

	if indx = 0 then do;
	     indx = create_label (label_value, (label_type), (label_storage));
	     lp = addr (OS (indx));

	     if last_item <= hbound (label_hash_table, 1) then
		label_hash_table (last_item) = indx;
	     else
		addr (OS (last_item)) -> label.hash_chain = indx;

	     if produce_listing then
		call generate_cross_ref (indx);

	     if label_type = format_label then do;
		if label_storage = SET then
		     label_storage = INIT;

		indx = build_symbol ((NO_NAME), format_label_attributes, (label_storage));
		lp -> label.format_var = indx;
	     end;

	     if label_type = executable_label & subr_options.ansi_77 then do;
		if substr (label_storage, 1, 3) = REF then
		     if statement_type = do_statement then
			lp -> label.ends_do_loop = TRUE;
		     else
			lp -> label.branched_to = TRUE;
		lp -> label.loop_end = current_loop_end;
	     end;
	     return (indx);
	end;

	if produce_listing then
	     call generate_cross_ref (indx);

	actual_type = string (lp -> label.usage);

/* if label previous entered with no usage info, e.g. in an ASSIGN, and we now can determine its usage, update the info 
   on the other hand, if this is an assign and previous was not, make this label type be consistent with previous */

	if actual_type = any_label & label_type ^= any_label then do;
	     actual_type = label_type;
	     string (lp -> label.usage) = label_type;
	end;
	else if label_type = any_label & actual_type ^= any_label then
	     label_type = actual_type;

	if substr (label_storage, 1, 3) = SET then
	     if lp -> label.set then
		call print_message (70, indx);	/* label is multiply declared */
	     else if actual_type ^= label_type then
		call print_message (70 + binary (label_type, 2, 0));
						/* usage conflicts with stmnt type */
	     else if label_type = executable_label & subr_options.ansi_77 then
		if lp -> label.branched_to & ^lp -> label.ends_do_loop then do;
		     if current_loop_end ^= 0 then do;
			do loop_end = lp -> label.loop_end repeat addr (OS (loop_end)) -> label.loop_end
			     while (loop_end ^= current_loop_end & loop_end ^= 0);
			end;
			if loop_end ^= current_loop_end then
			     call print_message (190, indx, current_loop_end);
		     end;
		     lp -> label.loop_end = current_loop_end;
		end;

	if substr (label_storage, 1, 3) = REF then
	     if label_type ^= actual_type then
		call print_message (73 + binary (label_type, 2, 0), indx);
						/* ref conflicts with previous */
	     else if label_type = executable_label & subr_options.ansi_77 then
		if lp -> label.set then do;		/* Label is already defined. */
		     if statement_type = do_statement then
			call print_message (70, indx);
		     else if lp -> label.ends_do_loop then
			call print_message (190, indx, indx);
		     else do;
			if lp -> label.loop_end ^= 0 then do;
			     do loop_end = current_loop_end repeat addr (OS (loop_end)) -> label.loop_end
				while (loop_end ^= lp -> label.loop_end & loop_end ^= 0);
			     end;
			     if loop_end ^= lp -> label.loop_end then
				call print_message (190, indx, fixed (lp -> label.loop_end, 18));
			end;
		     end;

		end;
		else do;				/* Label is not yet defined. */
		     if statement_type = do_statement then do;
			if lp -> label.branched_to then
			     call print_message (190, indx, indx);
			if ^lp -> label.ends_do_loop then do;
			     lp -> label.ends_do_loop = TRUE;
			     lp -> label.loop_end = current_loop_end;
			end;
		     end;
		     else if ^lp -> label.branched_to then do;
			lp -> label.branched_to = TRUE;
			if ^lp -> label.ends_do_loop then
			     lp -> label.loop_end = current_loop_end;
		     end;
		end;
	string (lp -> label.storage_info) = string (lp -> label.storage_info) | label_storage;

	if actual_type = format_label then do;
	     indx = lp -> label.format_var;
	     if indx = 0				/* no previous use in format context */
	     then do;
		indx = build_symbol ((NO_NAME), format_label_attributes, (label_storage));
		lp -> label.format_var = indx;
	     end;
	     if label_storage = SET then
		label_storage = INIT;
	     string (addr (OS (indx)) -> symbol.storage_info) =
		string (addr (OS (indx)) -> symbol.storage_info) | label_storage;
	end;

	return (indx);
     end enter_label;

create_label:
     procedure (label_name, label_usage, label_allocate_bits) returns (fixed bin (18));

dcl      label_allocate_bits bit (5) aligned;
dcl      label_name fixed bin (18);
dcl      label_usage bit (2) aligned;
dcl      new_label fixed bin (18);

	new_label = create_node (label_node, size (label));

	addr (OS (new_label)) -> label.operand_type = rel_constant;
	addr (OS (new_label)) -> label.name = label_name;
	string (addr (OS (new_label)) -> label.usage) = label_usage;
	string (addr (OS (new_label)) -> label.storage_info) = label_allocate_bits;

	if sub_ptr -> last_label = 0 then
	     sub_ptr -> first_label = new_label;
	else
	     addr (OS (sub_ptr -> last_label)) -> label.next_label = new_label;
	sub_ptr -> last_label = new_label;
	return (new_label);
     end create_label;

get_constant_offset:
     procedure (sym, allow_variable_subscripts) returns (fixed bin (18));

/*	Program Specifications (get_constant_offset)

     Inputs

     Output

     Description - calculates a constant offset, in elements, from constant subscript expressions
*/

dcl      allow_variable_subscripts bit (1) aligned;
declare	ansi66_equivalence_statement bit (1) aligned;
dcl      count fixed bin (18);
declare	dim_size fixed binary (18);
dcl      dp pointer;
declare	error_code fixed binary (35);
dcl      in_list bit (1) aligned;
declare	lower fixed binary (18);
dcl      multiplier fixed bin (18);
dcl      no_dims fixed bin (18);
dcl      off fixed bin (18);
dcl      sym fixed bin (18);
dcl      sp pointer;
dcl      subs fixed bin (18);
dcl      upper fixed bin (18);
declare	value fixed binary (24);
declare	variable_sub bit (1);

	sp = addr (OS (sym));

	off = 0;					/* calculated offset */
	multiplier = 1;				/* Multiplier for current subscript */
	count = 0;				/* number of subscripts */
	ansi66_equivalence_statement = (statement_type = equivalence_statement) & ^subr_options.ansi_77;

/* symbol must be dimensioned without variable bounds */

	if ^sp -> symbol.dimensioned then do;
	     call print_message (76, sym);		/* symbol must have dimension attribute */
	     no_dims = 0;
	     multiplier = 0;			/* final offset should be zero */
	end;
	else do;
	     dp = addr (OS (sp -> symbol.dimension));

	     if sp -> symbol.variable_extents then do;
		call print_message (77, sym);
		no_dims = 0;
		multiplier = 0;			/* final offset should be zero */
	     end;
	     else
		no_dims = dp -> dimension.number_of_dims;
	end;

	in_list = TRUE;
	do while (in_list);
	     count = count + 1;

	     call get_next_token (force_symtab_entry, subs);

/* pick up lower and upper bounds; used for bound checking and to build the multiplier */

	     if count <= no_dims then
		call get_bounds_and_size;
	     else
		upper, multiplier, lower = 0;		/* final offset will not include these subscripts */

/* subscript can be integer or an identifier is allowed */

	     const_index = subs;			/* save for err msg */
	     call get_integer_constant (subs, (allow_variable_subscripts), value, variable_sub, error_code);
	     if error_code ^= 0 then do;		/* illegal expression in constant or variable */
		call print_message (24, "the invalid expression");
		goto statement_parse_abort;
	     end;

	     else if ^variable_sub then do;		/* check that constant subscript within bounds */

		if value < lower then do;
		     if count <= no_dims & ^ansi66_equivalence_statement then do;
			call print_message (78, const_index, "lower", sym);
			value, off, multiplier = 0;
		     end;
		end;

		if value > upper then do;
		     if count <= no_dims & ^ansi66_equivalence_statement then do;
			call print_message (78, const_index, "upper", sym);
						/* subscript exceeds upper bound */
			value, off, multiplier = 0;	/* final offset will be zero */
		     end;
		end;

		off = off + (value - lower) * multiplier;
						/* accumulate constant offset */
	     end;
	     else do;				/* subscript can be a variable in some contexts */

		subs_list (0) = no_dims;		/* inexpensive way to tell caller there are subscripts */
		if count <= no_dims then
		     subs_list (count) = const_index;
	     end;

	     multiplier = multiplier * dim_size;	/* multiplier gets bigger */


	     if token ^= comma then
		in_list = FALSE;
	end;

	if token ^= right_parn then
	     go to missing_right_paren;
	call get_next_token$paren_operator;		/* next token must be an operator or a substr_left_parn */

	if no_dims ^= 0				/* check subscript count for valid refs */
	then do;
	     if ansi66_equivalence_statement then do;
		if count ^= 1 & count ^= no_dims then
		     call print_message (79, sym, "the wrong number of");
		else
		     do count = count + 1 to no_dims;
			call get_bounds_and_size;
			multiplier = multiplier * dim_size;
		     end;
		if multiplier < off then
		     call print_message (422, off + 1 - bias, sym);
	     end;
	     else if count ^= no_dims then
		call print_message (79, sym, "the wrong number of");
	end;
	return (off);

get_bounds_and_size:
     procedure;
	upper = dp -> dimension.dim.upper_bound (count);
	lower = dp -> dimension.dim.lower_bound (count);
	dim_size = dp -> dimension.dim.size (count);
     end get_bounds_and_size;

     end get_constant_offset;

get_char_length:
     procedure (action, sym_index) returns (fixed bin (18));

dcl      action fixed bin (2);
dcl      sym_index fixed bin (18);
dcl      symp pointer;

	symp = addr (OS (sym_index));
	if ^symp -> symbol.star_extents then do;
	     addr (work) -> based_integer = symp -> symbol.char_size + 1;
	     return (create_constant (int_mode, work));
	end;
	else if symp -> symbol.v_length ^= 0 then
	     return (symp -> symbol.v_length);
	else if action = force_symtab_entry then do;
	     symp -> symbol.v_length = build_symbol ((NO_NAME), v_length_attributes, SET);
	     addr (OS (symp -> symbol.v_length)) -> symbol.data_type = int_mode;
	     addr (OS (symp -> symbol.v_length)) -> symbol.element_size = 1;
	     return (symp -> symbol.v_length);
	end;
	else
	     return (0);
     end;

get_data_statement_expression:
     proc;

/* Parse an expression.  Check that its operands are all integer constants
   or implied do-loop indices.  Check that its operators are only '+', '-',
   '*', '/' and '**'.  If the expression is valid, stack its size and Polish;
   otherwise, stack 0 (i.e. a zero-length expression) to indicate it was
   invalid.  To save time later on during expression interpretation, we
   replace the node address of each implied do-loop index by the negative
   of the index of the stack element which will hold the current value of
   the loop index during interpretation. */

dcl      INVALID_CONSTANT fixed bin static options (constant) init (1),
         INVALID_OPERATOR fixed bin static options (constant) init (2),
         INVALID_SYMBOL fixed bin static options (constant) init (3);

dcl      do_idx fixed bin,
         indx fixed bin (18),
         op fixed bin (18),
         opnd_ptr ptr,
         polish_idx fixed bin (18),
         start_of_polish fixed bin (18),
         status fixed bin (35);

	start_of_polish = next_free_polish;
	call get_next_token (force_symtab_entry, indx);
	call parse_expression (set_no_symbol_bits, indx, out);
	status = 0;
	do polish_idx = start_of_polish to next_free_polish - 1 while (status = 0);
	     op = polish_string (polish_idx);
	     if op > last_assigned_op then do;
		opnd_ptr = addr (OS (op));
		if opnd_ptr -> node.node_type = constant_node then do;
		     if opnd_ptr -> constant.data_type ^= int_mode then
			status = INVALID_CONSTANT;
		end;
		else if opnd_ptr -> node.node_type = symbol_node then do;
		     do do_idx = 1 to do_level while (op ^= stack (do_info (do_idx)));
		     end;
		     if do_idx <= do_level then
			polish_string (polish_idx) = -do_info (do_idx);
		     else
			status = INVALID_SYMBOL;
		end;
		else
		     status = INVALID_CONSTANT;
	     end;
	     else if op < add_op | op > negate_op then
		status = INVALID_OPERATOR;
	end;
	if status = 0 then
	     if next_free_polish > start_of_polish + 1 & ^addr (out) -> expression.not_constant then do;
						/* Replace constant expression by its value. */
		parameter_info.desired_data_type = int_mode;
		parameter_info.rounding = subr_options.do_rounding;
		parameter_info.start_of_polish = start_of_polish;
		parameter_info.end_of_polish = next_free_polish;
		parameter_info.stack_index = stack_index;
		parameter_info.max_stack = max_stack;
		call fort_eval_parm (addr (parameter_info), "an integer constant expression", status);
		max_stack = parameter_info.max_stack;
		if status = 0 then do;
		     polish_string (start_of_polish) = parameter_info.result_location;
		     next_free_polish = start_of_polish + 1;
		end;
	     end;
	if status ^= 0 then do;
	     if status = INVALID_CONSTANT then
		call print_message (24, op);
	     else if status = INVALID_OPERATOR then
		call print_message (175, "an integer expression");
	     else if status = INVALID_SYMBOL then
		call print_message (135, op);
	     next_free_polish = start_of_polish;
	end;
	call stack_operand (next_free_polish - start_of_polish);
	do polish_idx = start_of_polish to next_free_polish - 1;
	     op = polish_string (polish_idx);
	     if op < 1 | op > last_assigned_op then
		call stack_operand (op);
	     else
		call stack_operator (op);
	end;
	next_free_polish = start_of_polish;
     end get_data_statement_expression;

parse_parameter_list:
     procedure (entry_point_name);			/* Not Audited. */

/*	Program Specifications (parse_parameter_list)

     Inputs

     Output

     Description - parses parameter list for subroutine, function, and entry statements.
*/
dcl      adesc fixed binary (18);
dcl      alternate_return bit (1) aligned;
dcl      ap pointer;
dcl      entry_point_name fixed bin (18);
dcl      ep_name fixed bin (18);
dcl      saved_stack_index fixed binary (18);

	ep_name = entry_point_name;

	if declare_symbol (ep_name, subprogram_attributes, subprogram_conflicts, SET) then
	     addr (OS (ep_name)) -> symbol.parent = cur_subprogram;
						/* link entry point to block */
	else
	     call print_message (127, ep_name);

/* parse parameter list */

	call get_next_token$operator;			/* get left paren or eos */

	count = 0;
	num_args = 0;
	saved_stack_index = stack_index;
	alternate_return = FALSE;			/* param list does not contain alt ret param */

	if token = left_parn then do;
	     in_list = (token_list (current_token + 1).type ^= right_parn);

/* an empty parameter list is just a left and right paren and needs no further analysis */

	     if in_list then
		sub_ptr -> subprogram.has_parameters = TRUE;
	     else
		call get_next_token$operator;

	     do while (in_list);			/* loop thru parameters */

		call get_next_token (force_symtab_entry, indx);

/* parameter must be name or * */

		if token = ident then do;
		     count = count + 1;

		     if ^declare_symbol (indx, param_attr, param_conflicts, DECLARED) then
			call print_message (30, "parameter", indx);
		     else
			call check_param_position (indx);
						/* check for different position */

		     call stack_operand (indx);	/* save indx for arg_desc  */
		end;

		else if token = asterisk & subprogram_op = subr_op then do;
		     alternate_return = TRUE;
		     call stack_operand (0);		/* tell we're  not a symbol   */
		end;

		else
		     go to missing_identifier;

		num_args = num_args + 1;
		call get_next_token$operator;		/* get comma or right paren */
		if token ^= comma then
		     in_list = FALSE;

	     end;

	     if token ^= right_parn then
		go to missing_right_paren;

	     current_token = current_token + 1;		/* skip over right paren */
	end;

/* entry and subroutine statements don't require the parens for a null list, but all function statements do */

	else if statement_type >= function_statement & statement_type < after_subprogram then
	     goto missing_left_paren;

/* for functions, the return value must be added to the parameter list */

	if subprogram_op = func_op then do;
	     count = count + 1;

	     call check_param_position (return_value_param);
						/* check for different position */

	end;

/* for subroutines with label value parameters, alt ret value must be added to param list */

	else if alternate_return then do;
	     count = count + 1;

	     if return_value_param = 0		/* first ref so create it */
		then
		return_value_param = build_symbol ((NO_NAME), param_variable_attrs | attr_table (int_mode), REF);

	     call check_param_position (return_value_param);
						/* otherwise check for different position */

	end;

/* create  an arg_desc node for the parameter-list and fill it in with the
   info placed in the stack - then reset the stack_index */

	adesc = create_node (arg_desc_node, size (arg_desc));
	ap = addr (OS (adesc));
	ap -> arg_desc.n_args = num_args;

	do i = 1 to num_args;
	     ap -> arg_desc.symbol (i) = stack (saved_stack_index + i - 1);
	end;


/* Check if too many parameters.  Warn if so. */

	if num_args > max_arglist then
	     call print_message (189, max_arglist - bias);

	addr (OS (ep_name)) -> symbol.general = adesc;
	stack_index = saved_stack_index;

/* Add this entry to the list of pending entries. */

	if pending_entry_cnt < hbound (pending_entry, 1) then do;
	     pending_entry_cnt = pending_entry_cnt + 1;
	     pending_entry (pending_entry_cnt).entry_symbol = ep_name;
	     pending_entry (pending_entry_cnt).entry_stmnt = unspec (cur_stmnt_ptr -> statement);
	end;
	else
	     call print_message (67, "pending_entry", char (hbound (pending_entry, 1)));

	return;

check_param_position:
     procedure (formal_parameter);

dcl      formal_parameter fixed bin (18);

	if addr (OS (formal_parameter)) -> symbol.location ^= 0 then
	     if addr (OS (formal_parameter)) -> symbol.location ^= count then
		if addr (OS (formal_parameter)) -> symbol.general ^= ep_name then
		     addr (OS (formal_parameter)) -> symbol.stack_indirect = TRUE;
		else
		     call print_message (39, formal_parameter);

	addr (OS (formal_parameter)) -> symbol.location = count;
	addr (OS (formal_parameter)) -> symbol.general = ep_name;
     end check_param_position;
     end parse_parameter_list;

parse_data:
     procedure;					/* Not Audited. */

/*	Program Specifications (parse_data)

     Inputs

     Output

     Description (parse_data)

Parses the constant list and generates "initial value nodes" to represent the required initiation.
These are not true nodes because they are allocated in the polish string. Each node requires three
halfwords that are used as follows:

	+0	pointer to next node (Also used to chain free "nodes")
	+1	repetition count for this value
	+2	pointer to operand table node for constant or has the value "gap_value"


     Initial values for arrays (and variables) are stored in a chained list
in the order of the array elements. This method prevents multiple initial values
for a given element and allows the storage allocator to make a single pass to
generate initial value templates.

     The initial attribute is assigned to the symbol only if a non-zero value
is given as an initial value.


     This parser is driven by information stored by either a data statement parser or a mode
statement parser. The information stored includes implied do loop control information as well as
variables, array element names, or array vectors. See the description under the data statement
parse for a complete description of how the information is encoded.
*/

dcl      c_count fixed bin (18);
dcl      c_dt fixed bin (4);
dcl      char_count fixed bin (18);
dcl      char_len fixed bin (18);
dcl      char_var_length fixed bin (10);
dcl      char_var_value char (char_var_length) based (addr (char_temp));
dcl      cv_ptr pointer;
dcl      conv_error fixed bin (35);
dcl      const fixed bin (18);
dcl      current_spec fixed bin (18);
declare	current_value fixed binary (18);
dcl      data_error bit (1) aligned;
declare	dim_size fixed bin (18);
dcl      dp pointer;
dcl      el_ct fixed bin (18);
dcl      final_expression_idx fixed bin (18);
declare	final_value fixed binary (18);
dcl      have_constant_subscripts bit (1) aligned;
dcl      i fixed bin (18);
dcl      in_list bit (1) aligned;
dcl      increment_expression_idx fixed bin (18);
declare	increment_value fixed binary (18);
dcl      indx fixed bin (18);
dcl      initial_expression_idx fixed bin (18);
dcl      interval fixed bin (18);
dcl      interval_ptr fixed bin (18);
dcl      j fixed bin (18);
dcl      last fixed bin (18);
declare	loop_info fixed binary (18);
declare	lower fixed bin (18);
dcl      multiplier fixed bin (18);
dcl      non_zero_value bit (5) aligned;
dcl      octal_value bit (72) aligned;
dcl      off fixed bin (18);
dcl      partial_offset fixed bin (18);
dcl      substr_finish fixed bin (10);
dcl      substr_length fixed bin (10);
dcl      substr_start fixed bin (10);
dcl      t_ct fixed bin (18);
dcl      target fixed bin (18);
dcl      upper fixed bin (18);
dcl      v_dt fixed bin (4);
dcl      v_count fixed bin (18);


	from_data_parser = TRUE;			/* To suppress msgs in get_next_token */
	c_count = 0;				/* number of constants parsed and as yet unused */
	token = comma;				/* token is actually a slash; this for loop */
	do_level = 0;				/* no do loops encountered. */

/* loop thru information stored on the stack */

	current_spec = stack_base;			/* beginning of the list */
	do while (current_spec < stack_index);

/* pick up all do loops that start with this variable */

	     do while (stack (current_spec) = BEGIN_DO_LOOP);
		if do_level = hbound (do_info, 1) then do;
		     call print_message (89, hbound (do_info, 1) - bias);
						/* too deeply nested */
		     go to statement_parse_abort;
		end;

		do_level = do_level + 1;
		do_info (do_level) = current_spec;	/* remember where loop starts */
		initial_expression_idx = current_spec + INITIAL_EXPRESSION;
		stack (current_spec + CURRENT_VALUE) = value (initial_expression_idx);

/* skip over do loop parameters */
		final_expression_idx = initial_expression_idx + stack (initial_expression_idx) + 1;
		increment_expression_idx = final_expression_idx + stack (final_expression_idx) + 1;
		current_spec = increment_expression_idx + stack (increment_expression_idx) + 1;
	     end /* current_spec = BEGIN_DO_LOOP */;

/* get the next item from the list, either subscripted or not */

	     target = stack (current_spec);

	     if target > 0				/* array name or scalar variable */
	     then do;
		indx = target;
		current_spec = current_spec + 1;
		if addr (OS (indx)) -> symbol.dimensioned then do;
		     v_count = addr (OS (addr (OS (indx)) -> symbol.dimension)) -> dimension.element_count;
		     if v_count = 0 then
			call print_message (77, indx);/* symbol must have constant extents */
		end;
		else
		     v_count = 1;
		off = 0;
		have_constant_subscripts = FALSE;
	     end /* array_name or scalar var */;

	     else if target = SUBSTR | target = SUBSCRIPTED_VAR | target = SUBSCRIPTED_SUBSTR then do;
		indx = stack (current_spec + SYMBOL_INDEX);
		off = 0;
		v_count = 1;
		current_spec = current_spec + 2;
		if target = SUBSTR then
		     have_constant_subscripts = FALSE;
		else do;
		     have_constant_subscripts = TRUE;	/* Assume all subscripts are constant. */

		     dp = addr (OS (addr (OS (indx)) -> symbol.dimension));
						/* dimension node for symbol */
		     multiplier = 1;		/* used to calculate offset */

		     do i = 1 to dp -> dimension.number_of_dims;

/* find and process subscripts */
			upper = dp -> dimension.dim.upper_bound (i);
			lower = dp -> dimension.dim.lower_bound (i);
			dim_size = dp -> dimension.dim.size (i);

			if stack (current_spec) ^= 1 | stack (current_spec + 1) < 0 then
			     have_constant_subscripts = FALSE;
						/* At least one subscript is not constant. */
			j = value (current_spec);
			if j > upper then do;
			     call print_message (78, j - bias, "upper", indx);
						/* value exceeds upper bound */
			     j = upper;
			end;
			else if j < lower then do;
			     call print_message (78, j - bias, "lower", indx);
			     j = lower;
			end;

			off = off + (j - lower) * multiplier;
						/* add subscript to offset */
			multiplier = multiplier * dim_size;
			current_spec = current_spec + stack (current_spec) + 1;
						/* skip over this subscript */
		     end;
		end;

		if target = SUBSTR | target = SUBSCRIPTED_SUBSTR then do;
						/* Extract start and finish positions. */
		     char_var_length = addr (OS (indx)) -> symbol.char_size + 1;
		     substr_start = value (current_spec);
		     current_spec = current_spec + stack (current_spec) + 1;
		     if substr_start < 1 then do;
			call print_message (155, indx, "start < 1");
			substr_start = 1;
		     end;
		     else if substr_start > char_var_length then do;
			call print_message (155, indx, "start > length");
			substr_start = char_var_length;
		     end;
		     substr_finish = value (current_spec);
		     current_spec = current_spec + stack (current_spec) + 1;
		     if substr_finish < substr_start then do;
			call print_message (155, indx, "finish < start");
			substr_finish = substr_start;
		     end;
		     else if substr_finish > char_var_length then do;
			call print_message (155, indx, "finish > length");
			substr_finish = char_var_length;
		     end;
		     substr_length = substr_finish - substr_start + 1;
		end;
	     end;

	     else do;				/* It had better be SKIP. */
		have_constant_subscripts = FALSE;
		indx = 0;
		off = 0;
		v_count = 1;
		current_spec = current_spec + 1;
	     end;

/* insure variable can acquire the initial attribute */

	     if indx = 0 then do;
		v_dt = 0;
		data_error = TRUE;
	     end;
	     else if ^declare_symbol (indx, variable_attributes, equiv_conflicts, DECLARED) then do;
		call print_message (126, indx);
		v_dt = 0;
		data_error = TRUE;
	     end;
	     else do;
		call set_data_fields (indx);
		v_dt = addr (OS (indx)) -> symbol.data_type;
						/* copy data type */
		data_error = FALSE;
	     end;

/* Common is initialed in block data only. Allocate bit is set only if in block data. */

	     if indx = 0 then
		non_zero_value = DECLARED;
	     else if addr (OS (indx)) -> symbol.in_common then
		if sub_ptr -> subprogram_type = block_data then
		     if addr (OS (addr (OS (indx)) -> symbol.parent)) -> header.block_name = blank_common_name
		     then do;
			call print_message (128, indx);
						/* a member of blank common */
			data_error = TRUE;
			non_zero_value = DECLARED;
		     end;
		     else
			non_zero_value = REF;	/* member of common in block data */
		else do;
		     call print_message (80, indx);	/* cannot initial common block */
		     data_error = TRUE;
		     non_zero_value = DECLARED;
		end;
	     else if sub_ptr -> subprogram_type = block_data then
		if addr (OS (indx)) -> symbol.equivalenced then
		     non_zero_value = REF;
		else
		     non_zero_value = DECLARED;
	     else
		non_zero_value = DECLARED;

/* If the offset > 0, then the correct element position must be found. */

	     partial_offset = off;			/* copy offset */
	     last = -indx;				/* indicates that there is no previous interval */
	     interval = 0;				/* number of elements in interval being redefined */
	     current_value = gap_value;		/* indicates there is no current value */

	     in_list = TRUE;
	     if indx = 0 then
		interval_ptr = 0;
	     else
		interval_ptr = addr (OS (indx)) -> symbol.initial;
	     do while (in_list & interval_ptr ^= 0);

		interval = polish_string (interval_ptr + 1);
						/* number of elements */

		if partial_offset < interval		/* initialization will redefine an existing interval */
		then do;
		     in_list = FALSE;
		     interval = interval - partial_offset;
						/* number of elements preceding new value */

/* interval being redefined must be empty and its length >= number of new values */

		     current_value = polish_string (interval_ptr + 2);
		     if current_value ^= gap_value then
			if target = SUBSTR | target = SUBSCRIPTED_SUBSTR then do;
			     if unspec (
				substr (addr (OS (current_value)) -> char_constant.value, substr_start,
				substr_length)) ^= ""b then do;
				call print_message (81, indx);
				data_error = TRUE;
			     end;
			end;
			else do;
			     call print_message (81, indx);
						/* redefining an element */
			     data_error = TRUE;
			end;

		     if polish_string (interval_ptr) ^= 0 & v_count > interval
						/* check length, if required */
		     then do;
			call print_message (81, indx);/* redefining an element */
			data_error = TRUE;
		     end;
		end;

/* not on this interval, get the next one */

		else do;
		     partial_offset = partial_offset - interval;
						/* reduce offset by width of this interval */
		     interval = 0;			/* no current interval */
		     last = interval_ptr;		/* remember this interval */
		     interval_ptr = polish_string (interval_ptr);
						/* get next interval or end of list */
		end;
	     end;

/* if the new element is in the middle of an interval, filler is required for preceding elements */

	     if partial_offset > 0 then
		call store_value (partial_offset, (current_value));

/* loop thru all the elements being initialized for this reference */

	     do while (v_count > 0);

/* if there are no left over constants, parse another one */

		if c_count = 0 then do;
		     if token ^= comma then
			if token ^= slash then
			     go to missing_comma;
			else do;
			     call print_message (82); /* fewer constants than variables */
			     call get_next_token (ignore_symtab_entry, ignore_value);
			     stack_index = stack_base;
			     return;
			end;

		     call get_next_token (locate_symtab_entry, const);

		     c_count = 1;
		     if token = dec_int then
			if token_list (current_token + 1).type = asterisk then do;
			     c_count = addr (work) -> based_integer;
			     if c_count <= 0 then do;
				call print_message (24, const);
						/* count must be positive */
				c_count = 1;
			     end;

			     current_token = current_token + 1;
						/* skip over the asterisk */
			     call get_next_token (locate_symtab_entry, const);
			end;

		     call parse_a_constant (TRUE, const, octal_value);
						/* TRUE= allow octal */

		     if const = 0 then
			c_dt = 0;			/* octal constants have no data type */
		     else do;
			c_dt = addr (OS (const)) -> constant.data_type;
			if c_dt ^= char_mode then
			     cv_ptr = addr (addr (OS (const)) -> constant.value);
		     end;

		     call get_next_token$operator;	/* get comma or slash */
		end;				/* loop to parse a constant and replication factor */

		el_ct = min (v_count, c_count);	/* only use what is available */

/* Now store the initial value, converting to target data type if required. */

		if v_dt > 0			/* zero if variable cannot take an initial value */
		then do;

		     if v_dt > char_mode then
			go to conversion_error;	/* weird mode for variable */

		     if c_dt > char_mode then
			go to conversion_error;	/* weird mode for constant */

		     go to convert_initial (v_dt * (char_mode + 1) - char_mode + c_dt);

convert_initial (42):				/* character = character */
		     char_var_length = addr (OS (indx)) -> symbol.char_size + 1;
		     if target = SUBSTR | target = SUBSCRIPTED_SUBSTR then do;
			if current_value = gap_value then
			     unspec (char_var_value) = ""b;
			else
			     char_var_value = addr (OS (current_value)) -> char_constant.value;
			if addr (OS (const)) -> char_constant.length > substr_length then do;
			     call print_message (139, indx, substr_length - bias);
			     substr (char_var_value, substr_start, substr_length) =
				substr (addr (OS (const)) -> char_constant.value, 1, substr_length);
			end;
			else
			     substr (char_var_value, substr_start, substr_length) =
				addr (OS (const)) -> char_constant.value;
			call store_value (el_ct, create_char_constant (char_var_value));
		     end;
		     else if addr (OS (const)) -> char_constant.length < char_var_length then do;
						/*  Too short: Create constant of required size.  */
			char_var_value = addr (OS (const)) -> char_constant.value;
			call store_value (el_ct, create_char_constant (char_var_value));
		     end;
		     else do;			/*  Long enough:  Use as much as needed.  */
			if addr (OS (const)) -> char_constant.length > char_var_length then
			     call print_message (139, indx, char_var_length - bias);
			call store_value (el_ct, (const));
		     end;
		     goto reduce_counts;

convert_initial (2):				/* integer = integer */
convert_initial (10):				/* real = real */
convert_initial (18):				/* double precision = double precision */
convert_initial (26):				/* complex = complex */
convert_initial (34):				/* logical = logical */
		     call store_value (el_ct, (const)); /* store without conversion */
		     go to reduce_counts;


convert_initial (6):				/* integer = logical */
convert_initial (13):				/* real = logical */
convert_initial (20):				/* double precision = logical */
convert_initial (27):				/* complex = logical */
convert_initial (29):				/* logical = octal constant */
convert_initial (30):				/* logical = integer */
convert_initial (31):				/* logical = real */
convert_initial (32):				/* logical = double precision */
convert_initial (33):				/* logical = complex */
convert_initial (36):				/* character = octal constant */
convert_initial (37):				/* character = integer */
convert_initial (38):				/* character = real */
convert_initial (39):				/* character = double precision */
convert_initial (40):				/* character = complex */
convert_initial (41):				/* character = logical */
conversion_error:
		     call print_message (83, const, indx);
		     call store_value (el_ct, gap_value);
						/* prevents reinitialization of these elements */
		     go to reduce_counts;


convert_initial (14):				/* real by character */
convert_initial (21):				/* double precision by character */
convert_initial (28):				/* complex by character */
convert_initial (35):				/* logical by character */
convert_initial (7):				/* integer = character */
						/* An entire array may be set using a single constant if the first element is specified. */
		     char_len = chars_per_word * data_type_size (v_dt);
						/* characters per element */
		     char_count = addr (OS (const)) -> char_constant.length;

		     if off = 0 & have_constant_subscripts & el_ct = 1 & do_level = 0 then do;
			t_ct = divide (char_count + char_len - 1, char_len, 17, 0);

			if t_ct > addr (OS (addr (OS (indx)) -> symbol.dimension)) -> dimension.element_count
			     & ^data_error then do;
			     t_ct = addr (OS (addr (OS (indx)) -> symbol.dimension)) -> dimension.element_count;
			     call print_message (139, indx, t_ct * char_len - bias);
			end;

			if interval_ptr ^= 0 & polish_string (interval_ptr) ^= 0 & t_ct > interval then do;
						/* Attempt to reinitialize an element. */
			     call print_message (81, indx);
			     t_ct = interval;
			end;

			do j = 1 to (t_ct - 1) * char_len by char_len;
						/* Store all but last value. */
			     substr (addr (work) -> based_char, 1, char_len) =
				substr (addr (OS (const)) -> char_constant.value, j, char_len);
			     call store_value (1, create_constant (v_dt, work));
			end;

			char_count = char_count - j + 1;
						/* number of chars remaining */
		     end;
		     else
			j = 1;

		     if char_count > char_len then
			call print_message (139, indx, char_len - bias);
						/* more chars than will fit */

		     substr (addr (work) -> based_char, 1, char_len) /* common code assigns last (or only) word. */ =
			substr (addr (OS (const)) -> char_constant.value, j, char_count);
		     go to converted;

convert_initial (1):				/* integer = octal constant */
convert_initial (8):				/* real = octal constant */
		     addr (work) -> based_bit_72 = substr (octal_value, 37, 36);
		     go to converted;

convert_initial (3):				/* integer = real */
convert_initial (5):				/* integer = complex */
		     conv_error = 0;
		     unspec (addr (work) -> based_integer) =
			conv_round (int_mode, real_mode) ((unspec (cv_ptr -> based_real (1))), conv_error);
		     if conv_error < 0		/* number is too large to be an integer */
			then
			call print_message (119, const);
		     goto converted;

convert_initial (4):				/* integer = double_precision */
		     conv_error = 0;
		     unspec (addr (work) -> based_integer) =
			conv_round (int_mode, dp_mode) ((unspec (cv_ptr -> based_double)), conv_error);
		     if conv_error < 0		/* number is too large to be an integer */
			then
			call print_message (119, const);
		     goto converted;

convert_initial (15):				/* double precision = octal constant */
convert_initial (22):				/* complex = octal constant */
		     addr (work) -> based_bit_72 = octal_value;
		     go to converted;

convert_initial (23):				/* complex = integer */
		     addr (work) -> based_real (2) = 0.0;
						/* 0 is the same in hex */

convert_initial (9):				/* real = integer */
		     unspec (addr (work) -> based_real (1)) =
			conv_round (real_mode, int_mode) ((unspec (cv_ptr -> based_integer)), 0);
		     go to converted;

convert_initial (25):				/* complex = double precision */
		     addr (work) -> based_real (2) = 0.0;
						/* 0 is the same in hex */

convert_initial (11):				/* real = double precision */
		     unspec (addr (work) -> based_real (1)) =
			conv_round (real_mode, dp_mode) ((unspec (cv_ptr -> based_double)), 0);
		     go to converted;

convert_initial (24):				/* complex = real */
		     addr (work) -> based_real (2) = 0.0;
						/* 0 is the same in hex */

convert_initial (12):				/* real = complex */
convert_initial (17):				/* double precision = real */
convert_initial (19):				/* double precision = complex */
		     addr (work) -> based_real (1) = cv_ptr -> based_real (1);
		     go to converted;

convert_initial (16):				/* double precision = integer */
		     unspec (addr (work) -> based_double) =
			conv_round (dp_mode, int_mode) ((unspec (cv_ptr -> based_integer)), 0);

converted:
		     call store_value (el_ct, create_constant (v_dt, work));
		end /* loop: v_dt > 0 */;

reduce_counts:
		v_count = v_count - el_ct;
		c_count = c_count - el_ct;
		interval = interval - el_ct;
	     end /* loop: v_count>0 */;

/* Initialization is done. If interval existed, attempt to combine it with last created node or eliminate it. */

	     if interval_ptr ^= 0 & ^data_error		/* Initialization redefined an existing interval. */
		then
		if interval <= 0 then do;		/* Interval was completely redefined. Remove it from chain. */
		     if last <= 0 then
			addr (OS (-last)) -> symbol.initial = polish_string (interval_ptr);
		     else
			polish_string (last) = polish_string (interval_ptr);

		     polish_string (interval_ptr) = free_chain;
						/* Free the "node". */
		     free_chain = interval_ptr;
		end;
		else if last > 0 then
		     if polish_string (last + 2) = polish_string (interval_ptr + 2) then do;
						/* Remaining part of interval can be combined. */
			polish_string (last + 1) = polish_string (last + 1) + interval;

			polish_string (interval_ptr) = free_chain;
						/* Free the "node". */
			free_chain = interval_ptr;
		     end;
		     else
			polish_string (interval_ptr + 1) = interval;
						/* Shorten the interval. */
		else
		     polish_string (interval_ptr + 1) = interval;
						/* Shorten the interval. */

/* Set attributes for symbol (and header) only if there are non zero values in initial chain. */

	     if (non_zero_value & INIT) = INIT & ^data_error then do;
		string (addr (OS (indx)) -> symbol.storage_info) =
		     string (addr (OS (indx)) -> symbol.storage_info) | non_zero_value;

		if addr (OS (indx)) -> symbol.equivalenced then
		     if addr (OS (indx)) -> symbol.parent > 0
						/* update header only if it exists */
			then
			string (addr (OS (addr (OS (indx)) -> symbol.parent)) -> header.storage_info) =
			     string (addr (OS (addr (OS (indx)) -> symbol.parent)) -> header.storage_info)
			     | non_zero_value;
	     end;

/* process all do loops terminating after this variable */

	     do while (stack (current_spec) = END_DO_LOOP);
		loop_info = do_info (do_level);	/* pointer to loop info */
		initial_expression_idx = loop_info + INITIAL_EXPRESSION;
		final_expression_idx = initial_expression_idx + stack (initial_expression_idx) + 1;
		increment_expression_idx = final_expression_idx + stack (final_expression_idx) + 1;

/* increment loop variable */
		increment_value = value (increment_expression_idx);
		current_value, stack (loop_info + CURRENT_VALUE) =
		     stack (loop_info + CURRENT_VALUE) + increment_value;

/* test if loop is complete */
		final_value = value (final_expression_idx);
		if (increment_value > 0 & current_value > final_value)
		     | (increment_value < 0 & current_value < final_value) then do;
						/* loop is completed, go forward */
		     current_spec = current_spec + END_DO_LOOP_SIZE;
		     do_level = do_level - 1;		/* one fewer containing loops */
		end;
		else
		     current_spec = increment_expression_idx + stack (increment_expression_idx) + 1;
						/* re-execute the range of the loop */
	     end /* loops terminating after this var */;
	end /* main driving loop: current_spec < stack_index */;

/* All variables have been processed. The constant list should also be expended; c_count >0 => excess in repeated value */

	if token ^= slash | c_count > 0 then do;
	     call print_message (84);			/* missing slash */
	     go to statement_parse_abort;
	end;

	call get_next_token (ignore_symtab_entry, ignore_value);
	stack_index = stack_base;
	from_data_parser = FALSE;
	return;


store_value:
     procedure (count, value);

dcl      count fixed bin (18);
dcl      value fixed bin;

	if data_error then
	     return;

	if value ^= gap_value then
	     non_zero_value = non_zero_value | INIT;

/* This value is combined with previous node if possible, otherwise, a new node is created. */

	if last > 0 then
	     if polish_string (last + 2) = value then do;
		polish_string (last + 1) = polish_string (last + 1) + count;
		return;
	     end;

/* A "node" is needed. Allocate it and return. */

	last = create_initial_node (last, interval_ptr, count, (value));
     end store_value;


value:
     proc (expression_idx) returns (fixed bin (18));

/* Return the value of an expression in the stack whose operands are integer
   constants or implied do-loop variables, and whose operators are '+', '-',
   '*', '/', and '**'.  The expression consists of a "size" word (indicating
   how many of the following words are in the expression) and the Polish for
   the expression.  A negative value in the Polish indicates an implied
   do-loop variable and its absolute value is the index of the stack location
   containing the current value of that variable. */

dcl      expression_idx fixed bin (18);

dcl      error condition,
         fixedoverflow condition,
         zerodivide condition;

dcl      exp_idx fixed bin (18),
         op fixed bin (18),
         orig_stack_index fixed bin (18);

	if stack (expression_idx) = 0 then
	     return (0);				/* Assume zero for value of null expression. */

	orig_stack_index = stack_index;
	on error goto error_detected;
	on fixedoverflow goto fixedoverflow_detected;
	on zerodivide goto zerodivide_detected;

	do exp_idx = expression_idx + 1 to expression_idx + stack (expression_idx);
	     op = stack (exp_idx);
	     if op < 0 then
		call stack_operand (stack (-op));
	     else if op > last_assigned_op then
		call stack_operand ((addr (addr (OS (op)) -> constant.value) -> based_integer));
	     else if op >= add_op & op <= negate_op then do;
		if op < negate_op then do;
		     if stack_index < orig_stack_index + 2 then
			goto invalid_expression;
		     stack_index = stack_index - 1;
		end;
		else if stack_index < orig_stack_index + 1 then
		     goto invalid_expression;
		unspec (stack (stack_index - 1)) =
		     binop_trunc (int_mode, int_mode)
		     (op - add_op + 1, (unspec (stack (stack_index - 1))), (unspec (stack (stack_index))), 0);
	     end;
	     else
		goto invalid_expression;
	end;

	if stack_index ^= orig_stack_index + 1 then
	     goto invalid_expression;
	stack_index = orig_stack_index;
	return (stack (stack_index));

error_detected:
	call print_message (174, "error", "an integer expression");
	goto statement_parse_abort;

fixedoverflow_detected:
	call print_message (174, "fixedoverflow", "an integer expression");
	goto statement_parse_abort;

invalid_expression:
	call print_message (525, "in an integer expression");
	goto statement_parse_abort;

zerodivide_detected:
	call print_message (174, "zerodivide", "an integer expression");
	goto statement_parse_abort;

     end value;
     end parse_data;

parse_a_constant:
     procedure (allow_octal_constant, constant_offset, octal_value);

/* This procedure parses one constant, preceded optionally by a sign. It returns a
	   pointer to the constant node for the constant parsed. */

dcl      allow_octal_constant bit (1) aligned;
dcl      const_offset fixed bin (18);
dcl      constant_offset fixed bin (18);
dcl      (i, j) fixed bin;
dcl      octal_digits char (8) aligned int static options (constant) init ("01234567");
dcl      octal_value bit (72) aligned;
dcl      octal_work bit (72) aligned;
dcl      temp_sign bit (9) aligned;

	const_offset = constant_offset;

	if token = plus | token = minus then do;
	     sign = token;
	     call get_next_token (locate_symtab_entry, const_offset);
	end;

/* If constant is a complex constant, call expression parser to parse it. */

	if token = left_parn then do;
	     temp_sign = sign;			/* Copy sign in case components also have signs */
	     sign = ZERO;				/* See procedure "convert_integer_constant" for explanation. */

	     if ^is_complex_constant (const_offset) then
		go to invalid_constant;

	     sign = temp_sign;			/* Restore sign for entire constant */
	end;

	else if (token & is_constant) = ZERO then
	     if token = ident & substr (fast_lookup, 1, 1) = "o" & allow_octal_constant then do;

		octal_work = "0"b;

/* convert the string of digits */

		do i = 1 to min (symbol_length - 1, 24);
		     j = index (octal_digits, substr (full_name, symbol_length - i + 1, 1)) - 1;

		     if j < 0			/* non_octal digit */
			then
			call print_message (130, substr (full_name, symbol_length - i + 1, 1));

		     else if j > 0 then
			substr (octal_work, 73 - 3 * i, 3) = bit (fixed (j, 3), 3);
		end;

		octal_value = octal_work;
		const_offset = 0;
	     end;

	     else do;
invalid_constant:
		call print_message (50, err_string ()); /* missing constant */
		const_offset = value_0;
	     end;

/* If sign is supplied, negate an arithmetic constant. */

	if sign ^= ZERO then do;
	     if const_offset = 0			/* sign invalid for octal constant */
		then
		call print_message (51);

	     else if (token & is_arith_constant) = ZERO then
		call print_message (51);		/* not arithmetic */

	     else if sign = minus then
		const_offset = negate_constant (const_offset);

	     sign = ZERO;				/* See procedure "convert_integer_constant" for explanation. */
	end;

	constant_offset = const_offset;
     end parse_a_constant;

create_initial_node:
     procedure (last_node, next_node, rep_count, value_ptr) returns (fixed bin (18));

dcl      last_node fixed bin (18);
dcl      next_node fixed bin (18);
dcl      new_node fixed bin (18);
dcl      rep_count fixed bin (18);
dcl      value_ptr fixed bin (18);

/* Reuse a free "node" or allocate a new one. */

	if free_chain ^= 0 then do;			/* Reuse an old "node". */
	     new_node = free_chain;			/* Remove node from free chain. */
	     free_chain = polish_string (new_node);

	     polish_string (new_node) = next_node;	/* Store values. */
	     polish_string (new_node + 1) = rep_count;
	     polish_string (new_node + 2) = value_ptr;
	end;
	else do;					/* Create a new "node". */
	     if first_word = 0			/* First "node" for this statement. */
	     then do;
		call emit_operator (increment_polish_op);
		call emit_count (first_word);
	     end;

	     new_node = next_free_polish;		/* Build a "node". */
	     call emit_halfword (next_node);
	     call emit_halfword (rep_count);
	     call emit_halfword (value_ptr);
	end;

	if last_node <= 0 then
	     addr (OS (-last_node)) -> symbol.initial = new_node;
	else
	     polish_string (last_node) = new_node;
	return (new_node);
     end create_initial_node;

create_format:
     procedure (fmt_str, sym_index);			/* Not Audited. */

/*	Program Specifications (create_format)

     Inputs

     Output

     Description (create_format)

     Notes - The variable "char_temp", declared in a containing procedure, must be an acceptable
	input argument in the call to general_format_parse_, below.
*/

dcl      fmt_length fixed bin (18);
dcl      fmt_ptr pointer;
dcl      fmt_str char (*);
dcl      fmt_word (512) char (4) unaligned based (addr (new_format));
dcl      format_string char (fmt_length) based (addr (new_format));
dcl      i fixed bin (18);
dcl      j fixed bin (18);
dcl      k fixed bin (18);
dcl      new_format char (4096) aligned;
dcl      sym_index fixed bin (18);

dcl      1 encoded_format like runtime_format aligned based (addr (new_format));

	if length (fmt_str) > length (char_temp) then do;
	     call print_message (85, length (char_temp) - bias);
						/* too many characters in format */
	     return;
	end;

	char_temp = fmt_str;

	call general_format_parse_ (char_temp, new_format, (subr_options.ansi_77), code);
	if code ^= 0 then do;
	     call print_message (86, addr (new_format) -> error_message);
						/* syntax error in format */
	     return;
	end;

/* The length, in characters, of the output string is returned in "fmt_len". It is always even.
	   The halfword immediately following the output string contains the number of characters parsed.
	   The number of characters parsed must equal the length of the input to this procedure. */

	fmt_length = encoded_format.fmt_len;		/* character length of encoded string */

/* compare length of input string with the number of characters parsed. */

	if length (fmt_str) ^= addr (new_format) -> old_format.fmt (divide (fmt_length, 2, 17, 0) - 1) then
	     call print_message (134);		/* garbage at end */

/* If the specification contains hollerith or character-string fields, the appropriate strings must
	   be copied into the representation of the format spec. */

	if encoded_format.contains_hollerith & encoded_format.version ^= fmt_parse_ver1 then do;

	     i = 1;
	     do k = addr (new_format) -> old_format.fmt (i) repeat addr (new_format) -> old_format.fmt (i)
		while (k ^= end_of_format);

		if k = hollerith_field | k = quoted_string then do;
		     j = addr (new_format) -> old_format.fmt (i + 1);
						/* length of the string */

		     if fmt_length + j > length (new_format)
						/* too big */
		     then do;
			call print_message (85, length (new_format) - bias);
			return;
		     end;

		     substr (new_format, fmt_length + 1, j) =
			substr (char_temp, addr (new_format) -> old_format.fmt (i + 2), j);
		     addr (new_format) -> old_format.fmt (i + 2) = fmt_length + 1;
						/* copy string and update offset field */

		     fmt_length = fmt_length + j;	/* update total length */
		end;

		i = i + increment_table (k);		/* point to next specification */
	     end;

	     addr (new_format) -> old_format.fmt_len = fmt_length;
						/* update length field to include strings */
	end;

/* now build the appropriate constant */

	first_word = 0;				/* No "nodes" allocated by this statement. */

	k = -sym_index;
	fmt_ptr = addr (OS (-k));
	fmt_ptr -> symbol.initialed = TRUE;

	if fmt_length > max_char_length		/* 512 */
	then do;
	     fmt_ptr -> symbol.dimensioned = TRUE;
	     fmt_ptr -> symbol.char_size = chars_per_word - 1;

	     i = divide (fmt_length + chars_per_word - 1, chars_per_word, 17, 0);
	     num_dims = 1;
	     j = create_node (dimension_node, size (dimension));
	     addr (OS (j)) -> dimension.number_of_dims = 1;
	     addr (OS (j)) -> dimension.dim.lower_bound (1) = 1;
	     addr (OS (j)) -> dimension.dim.upper_bound (1) = i;
	     addr (OS (j)) -> dimension.dim.size (1) = i;
	     addr (OS (j)) -> dimension.has_dim_sizes = TRUE;
	     addr (OS (j)) -> dimension.v_bound (1) = ""b;
	     addr (OS (j)) -> dimension.element_count = i;
	     fmt_ptr -> symbol.dimension = j;

	     if fmt_length - i * chars_per_word ^= 0	/* insure there is no garbage */
		then
		addr (new_format) -> based_words (i) =
		     addr (new_format) -> based_words (i)
		     & bit_mask ((fmt_length - i * chars_per_word) + chars_per_word);

	     do j = 1 to i;
		k = create_initial_node (k, 0, 1, create_char_constant (fmt_word (j)));
	     end;
	end;
	else do;
	     fmt_ptr -> symbol.char_size = fmt_length - 1;
	     ignore_value = create_initial_node (k, 0, 1, create_char_constant (format_string));
	end;

/* If data specs generated "nodes" in polish, must indicate how many halfwords are used. */
	if first_word ^= 0 then
	     polish_string (first_word) = next_free_polish - first_word - 1;
     end create_format;

find_symbol_index:
     procedure (a_len, a_index, create_sw, a_last);

/*	Program Specifications (find_symbol_index)

     Inputs

     Output

     Description (find_symbol_index)
*/

dcl      a_index fixed bin (18);
dcl      a_last fixed bin (18);
dcl      a_len fixed bin (18);
dcl      bool builtin;
dcl      create_sw fixed bin (2);
dcl      fast_bits bit (36) aligned;
dcl      in_list bit (1) aligned;
dcl      last_item fixed bin (18);
dcl      n fixed bin (18);
dcl      returned_index fixed bin (18);

	allocate_symbol_name = a_len;

/* Calculate hash bucket value. */

	if allocate_symbol_name = 1 then
	     last_item = binary (unspec (substr (full_name, 1, 1)), 9, 0);
	else do;

/* calculate number of words and mod(length, chars_per_word) */

	     last_item = divide (allocate_symbol_name - 1, chars_per_word, 17, 0) + 1;
	     n = allocate_symbol_name - (last_item - 1) * chars_per_word;

/* mask last word of the symbol name (bit_mask(4) is all ones) */

	     addr (full_name) -> based_words (last_item) = addr (full_name) -> based_words (last_item) & bit_mask (n);

/* form hash index by exclusive or'ing all the words of the symbol name */

	     fast_bits = addr (full_name) -> based_words (1);

	     if last_item >= 2 then
		do n = 2 to last_item;
		     fast_bits = bool (fast_bits, addr (full_name) -> based_words (n), "0110"b);
		end;

	     last_item = mod (binary (fast_bits, 35), dim (hash_table, 1));
	end;

	returned_index = hash_table (last_item);
	in_list = TRUE;

/* search through the symbol table */

	if returned_index > 0 then
	     do while (in_list);
		if addr (OS (returned_index)) -> symbol.name = substr (full_name, 1, allocate_symbol_name) then do;
		     in_list = FALSE;
		     if produce_listing then
			call generate_cross_ref (returned_index);
		end;
		else do;
		     last_item = returned_index;
		     returned_index = addr (OS (returned_index)) -> symbol.hash_chain;
		     if returned_index = 0 then
			in_list = FALSE;
		end;
	     end;

	if returned_index = 0 then
	     if create_sw = force_symtab_entry then do;
		returned_index = create_node (symbol_node, size (symbol));

		addr (OS (returned_index)) -> symbol.name_length = allocate_symbol_name;
		substr (addr (OS (returned_index)) -> symbol.name, 1, allocate_symbol_name) =
		     substr (full_name, 1, allocate_symbol_name);

		if sub_ptr -> last_symbol = 0 then
		     sub_ptr -> first_symbol = returned_index;
		else
		     addr (OS (sub_ptr -> last_symbol)) -> symbol.next_symbol = returned_index;
		sub_ptr -> last_symbol = returned_index;

		if last_item <= hbound (hash_table, 1) then
		     hash_table (last_item) = returned_index;
		else
		     addr (OS (last_item)) -> symbol.hash_chain = returned_index;

		if produce_listing then
		     call generate_cross_ref (returned_index);
	     end;

	a_index = returned_index;
	a_last = last_item;
     end find_symbol_index;

get_mode_size:
     procedure (mode, a_size, attributes, asterisk_seen);

/*	Program Specifications (get_mode_size)

     Inputs

     Output

     Description (get_mode_size)
	this procedure is called with the current token being the token before the asterisk, when it exists.
*/

dcl      a_size fixed bin (18);
declare	asterisk_seen bit (1) aligned;
dcl      1 attr like symbol.attributes based (addr (attributes));
dcl      attributes bit (47) aligned;
dcl      mode fixed bin (4);
dcl      size fixed bin (9);
dcl      star_extents bit (1) aligned;

	star_extents, asterisk_seen = FALSE;

	if token_list (current_token + 1).type = asterisk then do;
	     asterisk_seen = TRUE;
	     current_token = current_token + 1;
	     call get_next_token (locate_symtab_entry, const_index);

	     if token = dec_int then do;
		size = addr (work) -> based_integer;
		if mode = cmpx_mode then do;		/*   if not single precision then error  */
		     if size ^= 8 then
			call print_message (365, ltrim (char (size, 7)));
		end;
	     end;
	     else if token ^= left_parn then do;
		call print_message (24, err_string ());
		go to statement_parse_abort;
	     end;

	     else do;
		call get_next_token (force_symtab_entry, symbol_index);

		if token = asterisk then
		     if mode = char_mode then
			if subr_options.ansi_77 then do;
			     star_extents = "1"b;
			     call get_next_token$operator;
			end;
			else do;
			     call print_message (158);
			     go to statement_parse_abort;
			end;
		     else do;
			call print_message (24, err_string ());
			go to statement_parse_abort;
		     end;

		else do;
		     parameter_info.start_of_polish = next_free_polish;
		     call parse_expression (any_expression, symbol_index, ignore_bits);

		     parameter_info.max_stack = max_stack;
		     parameter_info.stack_index = stack_index;
		     parameter_info.desired_data_type = int_mode;
		     parameter_info.end_of_polish = next_free_polish - 1;
		     parameter_info.rounding = subr_options.do_rounding;

		     call fort_eval_parm (addr (parameter_info), "a length field expression", error_code);
		     max_stack = parameter_info.max_stack;
		     next_free_polish = parameter_info.start_of_polish;

		     if error_code = 0 then do;
			const_index = parameter_info.result_location;
			size = addr (addr (OS (const_index)) -> constant.value) -> based_integer;
		     end;
		     else if mode = char_mode then
			size = default_char_size;
		end;

		if token ^= right_parn then
		     go to missing_right_paren;
	     end;

	     if mode = char_mode then
		if star_extents then
		     attr.star_extents = "1"b;
		else do;
		     attr.star_extents = "0"b;
		     if size <= 0 then do;
			call print_message (24, const_index);
			size = default_char_size;
		     end;
		     else if size > max_char_var_length /*131071*/
		     then do;
			call print_message (87, addr (OS (SI)) -> symbol.name,
			     max_char_var_length /*131071*/ - bias);
			size = default_char_size;
		     end;
		end;
	     else if (mode = real_mode | mode = dp_mode) then do;
		if size <= 4 then do;
		     if size ^= 4 then
			call print_message (366, "single", ltrim (char (size, 7)));
		     mode = real_mode;
		end;
		else do;
		     if size ^= 8 then
			call print_message (366, "double", ltrim (char (size, 7)));
		     mode = dp_mode;
		end;
	     end;

	end;
	else
	     size = a_size;

	if mode = char_mode then
	     if attr.star_extents then do;
		attr.char_size = 0;
		a_size = 0;
	     end;
	     else do;
		attr.char_size = size - 1;
		a_size = size;
	     end;
	else
	     attributes = attr_table (mode);

     end get_mode_size;

parse_implied_io:
     procedure (rd_sw, unit, allow_asterisk);

/*	Program Specifications (parse_implied_io)

     Inputs

     Output

     Description (parse_implied_io)
*/

dcl      indx fixed bin (18);
dcl      rd_sw bit (1) aligned;
declare	allow_asterisk bit (1) aligned;

dcl      unit fixed bin (18);

	string (io_bits) = FALSE;
	fields_specified = ZERO;
	io_bits.read = rd_sw;
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	sub_ptr -> need_PS = TRUE;

	call emit_operand (unit);

	call get_next_token$label (force_symtab_entry, indx);
	if token ^= comma & token ^= EOS_token then do;
	     call get_format (indx, allow_asterisk);
	end;

	if token = comma then do;
	     if current_token >= last_token then do;
		current_token = current_token + 1;
		go to missing_identifier;
	     end;
	end;
	else if token ^= EOS_token then
	     go to missing_comma;

	call parse_io_list;
     end parse_implied_io;

parse_io:
     procedure (rd_sw);

/*	Program Specifications (parse_io)

     Inputs

     Output

     Description (parse_io)
*/

dcl      indx fixed bin (18);
dcl      rd_sw bit (1) aligned;
declare	no_keyword fixed binary;
declare	fmt fixed binary (18);

	string (io_bits) = FALSE;
	fields_specified = ZERO;
	io_bits.read = rd_sw;
	io_bits.fold = subr_options.fold;
	io_bits.ansi_77 = subr_options.ansi_77;
	io_bits.hfp = subr_options.hfp;
	io_bits.debug_io = subr_options.debug_io;

	sub_ptr -> need_PS = TRUE;

	call get_next_token$operator;			/* get left paren */
	if token ^= left_parn then
	     go to missing_left_paren;

	count = 0;
	no_keyword = 0;
	in_list = TRUE;
	do while (in_list);
	     count = count + 1;
	     call get_next_token (ignore_symtab_entry, ignore_value);
	     if token_list (current_token + 1).type = assign then do;
						/* keyword driven list element */
		if token ^= ident then
		     go to missing_keyword;
		else if substr (full_name, 1, symbol_length) = "err" then
		     call parse_error_label;
		else if substr (full_name, 1, symbol_length) = "end" then
		     call parse_end_label;
		else if substr (full_name, 1, symbol_length) = "unit" then
		     call parse_unit_specifier (TRUE, FALSE);
		else if substr (full_name, 1, symbol_length) = "iostat" then
		     call parse_iostat_var;
		else if substr (full_name, 1, symbol_length) = "fmt" then do;
		     call get_next_token$operator;	/* skip over the "=" */
		     call get_next_token$label (force_symtab_entry, fmt);
		     call get_format (fmt, TRUE);
		end;
		else if substr (full_name, 1, symbol_length) = "rec" then do;
		     call get_next_token$operator;
		     call get_next_token (force_symtab_entry, indx);
		     call parse_record_number (indx);
		end;
		else
		     goto invalid_keyword;
	     end;
	     else do;

/* if no keyword, then assume UNIT = if first in list, FMT = if second in list
and first was also unit, but with no keyword, otherwise an error */

		no_keyword = no_keyword + 1;
		if count = 1 then do;
		     call parse_unit_specifier$no_keyword (TRUE, FALSE);
		     if token = apostrophe then do;
			call get_next_token (force_symtab_entry, indx);
			call parse_record_number (indx);
		     end;
		end;
		else if count = 2 then do;
		     if no_keyword = 2 then
			if token = comma | token = right_parn then do;
						/* old list directed input */
			     io_bits.format = list_directed;
			     substr (fields_specified, fmt_field, 1) = TRUE;
			end /* null list element */;
			else do;
			     current_token = current_token - 1;
			     call get_next_token$label (force_symtab_entry, fmt);
			     call get_format (fmt, TRUE);
			end /* usual parse of format */;
		     else do;

/* if this is not keyword driven, is the second list item, the first item should have been keyword driven */
			go to missing_keyword;
		     end;
		end /* count = 2 */;
		else
		     goto missing_keyword;		/* count > 2 */
	     end /* no keyword */;

	     in_list = (token = comma);
	end /* while loop */;

/* error checking */

	if ^substr (fields_specified, units_field, 1) then
	     call print_message (31, keyword_table (statement_type), "unit");

	if substr (fields_specified, rec_field, 1) & io_bits.end_label then
	     call print_message (187, keyword_table (statement_type), "rec and end");

	if io_bits.end_label & ^io_bits.read then
	     call print_message (187, keyword_table (statement_type), "end");

	if io_bits.read & io_bits.end_label & io_bits.mode ^= sequential_access then
	     call print_message (187, keyword_table (statement_type), "sequential access and end");

	if ^substr (fields_specified, fmt_field, 1) then
	     io_bits.format = unformatted;

	if io_bits.mode = internal_file then do;
	     if io_bits.format = unformatted then
		call print_message (31, "internal file" || keyword_table (statement_type), "format");
	     else if io_bits.format = list_directed then
		call print_message (187, keyword_table (statement_type), "internal file and list directed");
	end;
	if token ^= right_parn then
	     go to missing_right_paren;

	call parse_io_list;
     end parse_io;

parse_io_options:
     procedure;

/*	Program Specifications (parse_io_options)

     Inputs

     Output

     Description (parse_io_options)
	Comment the sneakiness loudly.
*/
dcl      fmt fixed bin (18);

	if token ^= comma then
	     io_bits.format = unformatted;
	else do;
	     next_token = token_list (current_token + 1).type;
	     if next_token = comma then
		call get_next_token$operator;		/* get that comma */
	     else if token_list (current_token + 2).type = assign & current_token + 2 <= last_token then
		io_bits.format = unformatted;
	     else if next_token = right_parn then
		call get_next_token$operator;		/* get that right paren */
	     else do;
		call get_next_token$label (force_symtab_entry, fmt);
		call get_format (fmt, FALSE);
	     end;
	     do while (token = comma);
		call get_next_token (ignore_symtab_entry, ignore_value);
		if token ^= ident then
		     go to missing_keyword;

		if substr (fast_lookup, 1, symbol_length) = "err" then
		     call parse_error_label;

		else if io_bits.read & io_bits.mode = sequential_access
		     & substr (fast_lookup, 1, symbol_length) = "end" then
		     call parse_end_label;

		else
		     go to invalid_keyword;

	     end /* exception loop */;
	end /* token = comma */;

	if token ^= right_parn then
	     go to missing_right_paren;
     end parse_io_options;

parse_error_label:
     procedure;

dcl      exit_lbl fixed bin (18);
dcl      op_name fixed bin;

	if io_bits.error_label then
	     call print_message (48, "err");
	io_bits.error_label = TRUE;

	op_name = error_label_op;
	go to parse_error_common;

parse_end_label:
     entry;
	if io_bits.end_label then
	     call print_message (48, "end");
	io_bits.end_label = TRUE;

	op_name = end_label_op;

parse_error_common:
	call get_next_token$operator;			/* get equals */
	if token ^= assign then
	     go to missing_equals_sign;

	call get_next_token$label (ignore_symtab_entry, ignore_value);
	if token ^= dec_int then
	     go to missing_label;

	exit_lbl = enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF);
	addr (OS (exit_lbl)) -> label.restore_prs = TRUE;

	call emit_operand (exit_lbl);
	call emit_operator ((op_name));
	call get_next_token (ignore_symtab_entry, ignore_value);
     end parse_error_label;

parse_iostat_var:
     procedure;

dcl      first_sym fixed bin (18);

	if io_bits.iostat_var then
	     call print_message (48, "iostat");
	io_bits.iostat_var = TRUE;

	call get_next_token$operator;			/* get equals */
	if token ^= assign then
	     go to missing_equals_sign;

	call get_next_token (force_symtab_entry, first_sym);
	call parse_expression (set_reference, first_sym, ignore_bits);

	call emit_operator (iostat_op);
     end parse_iostat_var;

parse_unit_specifier:
     procedure (allow_asterisk, build_list_item);

/* the unit specifier is either an asterisk, identifying the default unit specifier, or an integer expression > 0.
   If allow_asterisk is false (e.g. for backspace, endfile, etc.) then must be of the usual variety.
   Unlike parse_iostat_var and parse_end_label, this subroutine does not emit any polish for a "unit" operator.
   This is done as part of the polish by the caller in an appropriate place.
*/
declare	allow_asterisk bit (1) aligned;		/* INPUT */
declare	build_list_item bit (1) aligned;		/* INPUT */

	call get_next_token$operator;
	if token ^= assign then
	     goto missing_equals_sign;
	goto unit_parse_common;

parse_unit_specifier$no_keyword:
     entry (allow_asterisk, build_list_item);

	current_token = current_token - 1;		/* back it up, we assumed it was a keyword */

unit_parse_common:
	if substr (fields_specified, units_field, 1) then
	     call print_message (48, "unit specifier or unit");
	substr (fields_specified, units_field, 1) = TRUE;

	call get_next_token (force_symtab_entry, SI);

/* Check for invalid unit numbers. */

	if (token = dec_int | token = minus) then do;
	     if (token = minus) then do;
		call get_next_token (force_symtab_entry, SI);
		call print_message (194, "-" || (ltrim (char (addr (work) -> based_integer))));
	     end;
	     else if (addr (work) -> based_integer > 99) then
		call print_message (194, ltrim (char (addr (work) -> based_integer)));
	end;

	if token = asterisk then do;
	     if allow_asterisk then do;
		call emit_operand (default_unit_specifier);
		call get_next_token$operator;
	     end;
	     else
		call print_message (149, keyword_table (statement_type));
	end;
	else if token = ident then do;
	     call set_data_fields (SI);
	     if addr (OS (SI)) -> symbol.character then
		call get_internal_file (FALSE);
	     else
		goto not_internal_file;
	end;
	else do;
not_internal_file:
	     call parse_expression (any_expression, SI, ignore_bits);
	end;

/* if building list item, put out the polish - open and close statements */

	if build_list_item then do;
	     call emit_halfword (units_field - bias);
	     call emit_operator (item_op);
	end;
	return;
     end parse_unit_specifier;

parse_record_number:
     procedure (indx);

declare	indx fixed binary (18);			/* INPUT: 1st symbol in expression for record number */

	if substr (fields_specified, rec_field, 1) then
	     call print_message (48, "record specifier or rec");
	if io_bits.mode = internal_file then
	     call print_message (187, keyword_table (statement_type), "internal file and direct access");
	substr (fields_specified, rec_field, 1) = TRUE;

	call parse_expression (any_expression, indx, ignore_bits);
	io_bits.mode = direct_access;
	call emit_operator (record_number_op);
     end parse_record_number;

get_internal_file:
     procedure (from_encode_decode);

declare	from_encode_decode bit (1) aligned;		/* INPUT: T if from encode/decode, F if from read/write */
declare	symp pointer;				/* ptr to symbol node */

	symp = addr (OS (SI));
	call emit_operand (value_0);			/* Dummy file number. */
	if io_bits.read then
	     call parse_expression (string_source, SI, out);
	else
	     call parse_expression (string_target, SI, out);

/* this must be a variable, array name, array element, or substring of those */

	if addr (out) -> expression.not_simple_ref then
	     call print_message (29, keyword_table (statement_type));

/* Emit proper operator, check for errors, and emit polish for string length (encode_decode only) */

	if from_encode_decode then do;
	     if ^sub_ptr -> subprogram.options.optimize then
		call emit_operator (string_op);
	     else if io_bits.read then
		call emit_operator (decode_string_op);
	     else
		call emit_operator (encode_string_op);

	     if io_bits.mode = direct_access then
		call print_message (187, keyword_table (statement_type), "direct access");
	     else
		io_bits.mode = string_io;

/* We must emit the polish for the length of the string 
   for encode/decode, we permit character scalars and non-logical arrays and array elements 
*/

	     if symp -> symbol.character then do;
		addr (work) -> based_integer = symp -> symbol.char_size + 1;
		call emit_operand (create_constant (int_mode, work));
	     end;
	     else do;
		addr (work) -> based_integer = chars_per_word * symp -> symbol.element_size;
		if symp -> symbol.dimensioned & addr (out) -> expression.array_name then do;
		     dp = addr (OS (symp -> symbol.dimension));
		     p = 0;

		     if symp -> symbol.variable_extents then do;
			if dp -> dimension.assumed_size then do;
			     call print_message (166, keyword_table (statement_type));
			     goto statement_parse_abort;
			end;
			do i = 1 to dp -> dimension.number_of_dims;
			     if string (dp -> dimension.v_bound (i)) = ""b
						/* both bounds constant just multiply constant part by size */
				then
				addr (work) -> based_integer =
				     addr (work) -> based_integer * dp -> dimension.dim.size (i);
			     else if string (dp -> dimension.v_bound (i)) = "11"b
						/* both bounds variable, size = upper - lower + 1 */
			     then do;
				call emit_operand ((dp -> dimension.dim.upper_bound (i)));
				call emit_operand ((dp -> dimension.dim.lower_bound (i)));
				call emit_operator (sub_op);
				call emit_operand (value_1);
				call emit_operator (add_op);
				p = p + 1;
			     end;
			     else if dp -> dimension.v_bound.lower (i)
						/* only lower bound is variable.  size = constant (upper_bound +1) - lower_bound */
			     then do;
				call emit_operand (
				     create_constant (int_mode, bit (dp -> dimension.dim.upper_bound (i) + 1, 72))
				     );
				call emit_operand ((dp -> dimension.dim.lower_bound (i)));
				call emit_operator (sub_op);
				p = p + 1;
			     end;
			     else do;

/* only upper bound is variable.  size = upper - constant (lower -1) */
				call emit_operand ((dp -> dimension.dim.upper_bound (i)));
				call emit_operand (
				     create_constant (int_mode, bit (dp -> dimension.dim.lower_bound (i) - 1, 72))
				     );
				call emit_operator (sub_op);
				p = p + 1;
			     end;

			     if i = dp -> dimension.number_of_dims then do;
				call emit_operand (create_constant (int_mode, work));
				p = p + 1;
			     end;

			     if p > 1 then
				call emit_operator (mult_op);
			end /* do loop number of dimesnions */;
		     end /* variable extents */;
		     else do;
			addr (work) -> based_integer = addr (work) -> based_integer * dp -> dimension.element_count;
			call emit_operand (create_constant (int_mode, work));
		     end;
		end /* dimension and array_name */;
		else
		     call emit_operand (create_constant (int_mode, work));
	     end /* not character */;

	     call emit_operator (string_length_op);
	end /* from_encode_decode */;

/* for internal_files from read/write, the code generator deals with length */

	else do;
	     if io_bits.read then
		call emit_operator (read_internal_file_op);
	     else
		call emit_operator (write_internal_file_op);
	     if io_bits.mode = direct_access then
		call print_message (187, keyword_table (statement_type), "direct access and internal file");
	     else
		io_bits.mode = internal_file;
	end /* read-write internal files */;

     end get_internal_file;

get_format:
     procedure (fmt, allow_asterisk);

/*	Program Specifications (get_format)

     Inputs

     Output

     Description (get_format)
*/

dcl      fmt fixed bin (18);
declare	allow_asterisk bit (1) aligned;

dcl      label_ptr fixed bin (18);
dcl      label_storage bit (5) aligned;
dcl      nl_ind fixed bin (18);
dcl      nl_off fixed bin (18);
declare	saved_polish fixed binary (18);

	if io_bits.read then
	     label_storage = SET;
	else
	     label_storage = REF;

	if substr (fields_specified, fmt_field, 1) then
	     call print_message (48, "format specifier or format label");
	substr (fields_specified, fmt_field, 1) = TRUE;

	if token = dec_int				/* FORMAT STATEMENT LABEL */
	then do;
	     label_ptr = enter_label (format_label, (addr (work) -> based_integer), REF);
	     call emit_operand (label_ptr);

	     call process_format_symbol (/* label_ptr */);

	     call get_next_token$operator;		/* get comma or right paren */
	end;

	else if token = ident then do;
	     label_ptr = fmt;

	     if addr (OS (label_ptr)) -> symbol.namelist	/* NAMELIST REFERENCE */
	     then do;

/* mark the group as used and force members into symbol table; add crossref entries for the namelist variables.  */

		addr (OS (label_ptr)) -> symbol.allocate = TRUE;
		nl_off = addr (OS (label_ptr)) -> symbol.initial;
						/* offset into polish */

		do nl_ind = nl_off + 1 to nl_off + polish_string (nl_off);
						/* loop thru members */
		     addr (OS (polish_string (nl_ind))) -> symbol.put_in_symtab = TRUE;
						/* force into symtab */
		     if produce_listing then
			call generate_cross_ref ((polish_string (nl_ind)));

		     if io_bits.read then
			addr (OS (polish_string (nl_ind))) -> symbol.set = TRUE;
						/* if read, mark as set */
		end;				/* loop thru members */

/* emit polish */

		call emit_operand (label_ptr);
		if ^sub_ptr -> subprogram.options.optimize then
		     call emit_operator (namelist_op);
		else if io_bits.read then
		     call emit_operator (read_namelist_op);
		else
		     call emit_operator (write_namelist_op);

		addr (OS (label_ptr)) -> symbol.bits.referenced = TRUE;

		io_bits.format = namelist;		/* set type of I/O */

		options.namelist_used = TRUE;		/* tell code generator namelist occurred */
		sub_ptr -> subprogram.namelist_used = TRUE;
						/* ditto */

		call get_next_token$operator;		/* get comma or right paren */
	     end;					/* do block for namelist */

	     else do;				/* VARIABLE REFERENCE */
		call parse_expression (format_reference, (label_ptr), out);

		call process_format_symbol (/* label_ptr */);

		if ^addr (OS (label_ptr)) -> symbol.attributes.mode_bits.mode.character
		     & addr (out) -> expression.not_simple_ref then
		     call print_message (143, label_ptr);
	     end;					/* do block for var ref */
	end;					/* do block for identifier */

	else if token = char_string			/* CHARACTER STRING REFERENCE */
	then do;

/* optimization: if the expression is a single char_string, at compile time we can create its format variable, much as if
   it were a dec_int, saving the work of the code generator */

	     saved_polish = next_free_polish;
	     label_ptr = fmt;
	     call parse_expression (format_reference, label_ptr, out);
	     if next_free_polish > saved_polish + 1 then
		call process_format_symbol (/* label_ptr */);
	     else do;
		next_free_polish = saved_polish;
		label_ptr = build_symbol ((NO_NAME), format_label_attributes, label_storage);
		call create_format (addr (OS (fmt)) -> char_constant.value, label_ptr);
		call emit_operand (label_ptr);
		call process_format_symbol (/* label_ptr */);
	     end;
	end;

	else if allow_asterisk & token = asterisk then do;
	     io_bits.format = list_directed;		/* set format */
	     call get_next_token$operator;		/* comma or right parn */
	end;

	else do;
	     call print_message (88, err_string ());	/* syntax error */
	     go to statement_parse_abort;
	end;


process_format_symbol:
     proc;

/* Procedure to handle any weird stuff for format symbols. */

	call emit_operator (format_op);
	io_bits.format = formatted;

	if io_bits.read then
	     addr (OS (label_ptr)) -> symbol.set = TRUE;
     end process_format_symbol;
     end get_format;

is_implied_loop:
     procedure /* ( paren_info, paren_count, cur_paren, last_paren_parsed ) */ returns (bit (1) aligned);

/*	Program Specifications


     Inputs

	No explicit arguments.
	This routine assumes the current token is a left paren. It prescans the
	remaining tokens of the statement to determine if this paren begins an implied loop.


     Output

	No explicit arguments.
	Implicit arguments:
	     paren_info - a structure, see notes below
	     paren_count - number of implied do loops encountered. If there were none, this field
		is set to one, and the first vector of the array appears to be a set of parens.
	     cur_paren - index into paren_info for current left paren
	     last_paren_parsed - set to last right paren scanned.


     Description (is_implied_loop)

Notes:
	The structure paren_info contains the following subfields:

	implied_loop - initially false; set to true if an equal sign encountered within this set of parens.

	position - token index of left paren; e.i. - value of current_token for left paren.

	chain - multi-purpose chain; while scanning, it is chain to containing paren for this set; as loops are
	     encountered, a left to right chain is made of the do loops.

	begin_index - token index of last comma encountered before the equal sign; this is updated every time
	     a comma is encountered until an equal sign is encountered.
*/

dcl      j fixed bin (18);
dcl      last_do fixed bin (18);
dcl      previous fixed bin (18);
dcl      token bit (9) aligned;


/* if the current paren is enclosed in another set of parens, scanning is already done */

	if current_token < last_paren_parsed then do;

	     if paren_count = 0 then
		return (FALSE);			/* all scanned parens are not loops */

/* must find info for current paren or there is a logic error */

	     do cur_paren = cur_paren + 1 to paren_count;
		if paren_info (cur_paren).position = current_token then
		     return (paren_info (cur_paren).implied_loop);
	     end;

	     call print_message (34);			/* apparent syntax error or logic error */
	     go to statement_parse_abort;
	end;

/* this paren (and contained parens) has not been prescanned; do it now */

	last_do = 0;				/* left to right chain of nested loops */

	paren_count = 1;				/* current token is first left paren */
	cur_paren = 1;				/* current paren info is in first array slot */

	paren_info (1).implied_loop = FALSE;		/* not yet determined to be an implied loop */
	paren_info (1).chain = 0;			/* no containing paren set exists */
	paren_info (1).position = current_token;	/* first paren is at current token position */
	paren_info (1).begin_index = 0;		/* no comma found yet */

/* loop until matching right paren is found or end of statement */

	do j = 1 to last_token - current_token;

	     token = token_list (current_token + j).type;

/* process left parenthesis */

	     if token = left_parn then
		if paren_count >= hbound (paren_info, 1) then do;
		     call print_message (89, hbound (paren_info, 1) - bias);
						/* imp res - too many nested parens */
		     go to statement_parse_abort;
		end;
		else do;
		     paren_count = paren_count + 1;	/* stack a new set of parens */
		     paren_info (paren_count).implied_loop = FALSE;
		     paren_info (paren_count).chain = cur_paren;
						/* chain to previous left paren */
		     paren_info (paren_count).position = current_token + j;
						/* token index for left paren */
		     paren_info (paren_count).begin_index = 0;
						/* no comma found yet */

		     cur_paren = paren_count;		/* becomes current set of parens */
		end;

/* process right parenthesis */

	     else if token = right_parn then do;
		if cur_paren = 0 then do;
		     call print_message (90);		/* mismatched parens - more right parens than left */
		     go to statement_parse_abort;
		end;

		previous = paren_info (cur_paren).chain;/* save index of previous left paren */

		if paren_info (cur_paren).implied_loop then do;
		     if last_do > 0 then
			paren_info (last_do).chain = cur_paren;
						/* forward chain of do loops */
		     last_do = cur_paren;
		end;

		cur_paren = previous;		/* step to containing set of parens */

/* if we closed first paren set, return */

		if cur_paren = 0 then do;
		     if last_do > 0 then
			paren_info (last_do).chain = 0;
						/* last element of chain */

		     cur_paren = 1;			/* paren of interest is first one */
		     last_paren_parsed = current_token + j;
						/*remember how far the stmnt has been scanned */

		     if paren_count = 0 then
			return (FALSE);		/* all parens encountered are not loops */
		     return (paren_info (1).implied_loop);
		end;
	     end;

/* check for comma and assign tokens only if assign token not yet encountered */

	     else if ^paren_info (cur_paren).implied_loop then
		if token = comma then
		     paren_info (cur_paren).begin_index = current_token + j;
						/* remember last comma */

		else if token = assign then
		     if paren_info (cur_paren).begin_index ^= 0
						/* make sure comma has been encountered */
			then
			paren_info (cur_paren).implied_loop = TRUE;
		     else do;
			call print_message (91);	/* syntax error in implied loop */
			go to statement_parse_abort;
		     end;
	end;

/* loop exits here only if parens are not matched */

	call print_message (90);			/* mismatched parens - too few right parens */
	go to statement_parse_abort;
     end is_implied_loop;

parse_io_list:
     procedure;

/*	Program Specifications (parse_io_list)

     Inputs

     Output

     Description (parse_io_list)
*/

dcl      element_type bit (36) aligned;
dcl      in_list bit (1) aligned;
dcl      io_ele fixed bin (18);
dcl      last_do fixed bin (18);
dcl      need_comma bit (1) aligned;
dcl      need_element bit (1) aligned;

	if current_token < last_token then
	     io_bits.list = TRUE;
	else
	     current_token = current_token + 1;		/* current token has been parsed */

	call emit_operand (create_constant (int_mode, string (io_bits)));

	if io_bits.read then do;			/* a read statement */
	     call emit_operator (read_op);
	     element_type = input_element;
	end;
	else do;					/* a write statement */
	     call emit_operator (write_op);
	     element_type = output_element;
	end;

/* process I/O list or return */

	if io_bits.list then do;
	     if io_bits.format = namelist then
		call print_message (145, keyword_table (statement_type));
						/* list is illegal */
	end;
	else do;
	     if io_bits.mode = string_io then
		call print_message (146, keyword_table (statement_type));
						/* list is required */
	     return;
	end;

	last_paren_parsed = 0;			/* indicates no prescan has occurred */
	last_do = 0;

	in_list = TRUE;
	do while (in_list);
	     call get_next_token (force_symtab_entry, io_ele);
	     if token = left_parn then
		if is_implied_loop ()		/* Modifies paren_info, paren_count, cur_paren, last_paren_parsed */
		then do;
		     save_current_token = current_token;
		     current_token = paren_info (cur_paren).begin_index;
						/* move up to do_loop specs */
		     call get_next_token (force_symtab_entry, io_ele);

		     call parse_expression (set_reference, io_ele, out);

		     if addr (out) -> expression.subscripted_ref then
			call print_message (25, io_ele);

		     call get_next_token (force_symtab_entry, io_ele);
		     call parse_expression (any_expression, io_ele, ignore_bits);
		     if token ^= comma then
			go to missing_comma;

		     call get_next_token (force_symtab_entry, io_ele);
		     call parse_expression (any_expression, io_ele, ignore_bits);
		     if token = comma then do;
			call get_next_token (force_symtab_entry, io_ele);
			call parse_expression (any_expression, io_ele, ignore_bits);
		     end;
		     else
			call emit_operand (value_1);
		     if token ^= right_parn then
			go to missing_right_paren;

		     call emit_operator (do_op);
		     paren_info (cur_paren).position = current_token;
		     current_token = save_current_token;
		     need_element = FALSE;
		     last_do = cur_paren;
		end;
		else
		     need_element = TRUE;		/* paren is part of expression */
	     else
		need_element = TRUE;		/* obviously not an implied do loop */

	     if need_element then do;
		call parse_expression (element_type, io_ele, out);

		if addr (out) -> expression.array_name then
		     call emit_operator (xmit_array_op);
		else
		     call emit_operator (xmit_scalar_op);

		need_comma = TRUE;
		do while (need_comma & in_list);
		     if token ^= comma then
			in_list = FALSE;
		     else if last_do > 0 & current_token = paren_info (last_do).begin_index then do;
			current_token = paren_info (last_do).position;
			last_do = paren_info (last_do).chain;
			call emit_operator (exit_op);
			call get_next_token$operator; /* get comma or eos */
		     end;
		     else
			need_comma = FALSE;
		end /* item_op loop */;
	     end /* parse list element */;
	end /* list loop */;

	if last_do ^= 0 then
	     call print_message (91);			/* syntax error in implied loop */

	call emit_operator (terminate_op);
     end parse_io_list;

parse_open_field:
     procedure (field_no, expression_type);

dcl      field_no fixed bin;
declare	expression_type bit (36) aligned;
dcl      field_number fixed bin (18);
dcl      first_sym fixed bin (18);

/* parse the fields in open and possibly other i/o statments.  The field numbers of fields_specified are listed in the
   include file fortran_io_consts.  Changes must be made consistently with EP, FIO, pl1_ops, and the code generators. 
*/

	field_number = field_no;

	if substr (fields_specified, field_number, 1) = TRUE then
	     call print_message (48, substr (full_name, 1, symbol_length));

	substr (fields_specified, field_number, 1) = TRUE;

	call get_next_token$operator;
	if token ^= assign then
	     go to missing_equals_sign;

	call get_next_token (force_symtab_entry, first_sym);
	call parse_expression (expression_type, first_sym, ignore_bits);

	call emit_halfword (field_number - bias);
	call emit_operator (item_op);

	count = count + 1;
     end parse_open_field;

scan_label_list:
     procedure (build_list);

/*	Program Specifications (scan_label_list)

     Inputs

     Output

     Description (scan_label_list)
*/

dcl      count fixed bin (18);
dcl      word_offset fixed bin (18);
dcl      build_list bit (1) aligned;
dcl      in_list bit (1) aligned;
dcl      label_ptr fixed bin (18);
dcl      list_bits bit (5) aligned;

	if build_list				/* list of lbls will be emitted in polish */
	then do;
	     list_bits = GOTO_REF;			/* computed goto IS goto_ref */

	     call emit_count (word_offset);
	     count = 0;
	     call emit_operator (jump_computed_op);
	end;
	else
	     list_bits = DECLARED;			/* assigned goto is NOT goto_ref */

	in_list = TRUE;
	do while (in_list);
	     call get_next_token$label (ignore_symtab_entry, ignore_value);
	     if token ^= dec_int then
		go to missing_label;

	     label_ptr = enter_label (executable_label, (addr (work) -> based_integer), list_bits);

	     call get_next_token$operator;		/* get comma or right paren */
	     count = count + 1;
	     if token ^= comma then
		in_list = FALSE;

	     if list_bits ^= DECLARED then do;
		call emit_operand (label_ptr);
		call emit_operator (item_op);

		if ^in_list then do;
		     call emit_operator (eol_op);
		     polish_string (word_offset) = count - bias;
		end;
	     end;
	end;
	if token ^= right_parn then
	     go to missing_right_paren;

     end scan_label_list;

get_bounds:
     procedure (symb);

/*	Program Specifications (get_bounds)

     Inputs

     Output

     Description (get_bounds)

NB - An entire dimension node may not be allocated. Only enough words are allocated
for the actual number of dimensions.

	explain use of positive and negative
*/

declare	assumed_size_index fixed bin (18);
dcl      bound_error bit (1) aligned;
dcl      count fixed bin (18);
dcl      dim_node fixed bin (18);
declare	dim_size fixed bin (24);
dcl      dp pointer;
dcl      ele_cnt fixed bin (48);
declare	error_code fixed binary (35);
dcl      indx fixed bin (18);
dcl      in_list bit (1) aligned;
declare	size builtin;
dcl      symb fixed bin (18);
dcl      sp pointer;
dcl      var_bounds bit (1) aligned;

declare	1 bounds (7) aligned like dimension.dim;
declare	1 v_bounds (7) aligned like dimension.v_bound;

	count = 0;
	ele_cnt = 1;
	var_bounds = FALSE;
	assumed_size_index = 0;
	bounds = 0;
	v_bounds = ""b;

	bound_error = ^declare_symbol (symb, dim_attr, dim_conflicts, DECLARED);

	if bound_error then
	     call print_message (30, "dimension", symb);	/* redundant declaration */

	in_list = TRUE;
	do while (in_list);
	     count = count + 1;
	     if count = hbound (bounds, 1) then
		in_list = FALSE;

/* get the next declarator, check for errors.  Assume it  is upper bound, can change later if required */

	     call get_next_token (force_symtab_entry, indx);

	     if token = asterisk then
		call check_assumed_size;
	     else do;
		call get_one_bound (indx, bounds (count).upper_bound, v_bounds (count).upper, error_code);

		if error_code ^= 0 then do;
		     call print_message (169, symb);
		     bound_error = TRUE;
		end;
		else if ^v_bounds (count).upper then
		     call check_size;

	     end /* not asterisk */;

	     if token = colon then do;		/* this dimension has user defined lower bound */
		if assumed_size_index = count		/* asterisk in lower bound */
		     then
		     call print_message (167, symb);

		bounds (count).lower_bound = bounds (count).upper_bound;
		bounds (count).upper_bound = 0;
		v_bounds (count).lower = v_bounds (count).upper;
		v_bounds (count).upper = FALSE;

/* get the upper bound information and do error checking */

		call get_next_token (force_symtab_entry, indx);

		if token = asterisk then
		     call check_assumed_size;
		else do;
		     call get_one_bound (indx, bounds (count).upper_bound, v_bounds (count).upper, error_code);
		     if error_code ^= 0 then do;
			call print_message (169, symb);
			bound_error = TRUE;
		     end;
		     else if ^v_bounds (count).upper then
			call check_size;

		end /* not asterisk in upper bound */;
	     end /* token = colon */;
	     else do;

/* if no colon, the bounds we see are the upper bounds - set the lower to 1 */

		bounds (count).lower_bound = 1;
		v_bounds (count).lower = FALSE;
	     end;

/* if both bounds are not variable or assumed-size, then compute size, otherwise set var_bounds */

	     if string (v_bounds (count)) = ""b then do;
		dim_size = bounds (count).upper_bound - bounds (count).lower_bound + 1;
		if dim_size < 1			/* lower bnd > upper bnd */
		then do;
		     call print_message (168, symb);
		     bound_error = TRUE;
		     dim_size = 1;
		end;
		ele_cnt = ele_cnt * dim_size;
		bounds (count).size = dim_size;
		if ele_cnt > max_fixed_bin_24		/* prevent overflow */
		     then
		     ele_cnt = max_fixed_bin_24 + 1;
	     end;
	     else
		var_bounds = TRUE;

/* see if any other bounds */

	     if token ^= comma then
		in_list = FALSE;
	end /* do while (in_list) */;

	if token ^= right_parn then
	     go to missing_right_paren;

	call get_next_token (ignore_symtab_entry, ignore_value);

	if assumed_size_index ^= 0 then
	     if assumed_size_index ^= count		/* assumed size in non-final  dimension */
	     then do;
		call print_message (167, symb);
		bound_error = TRUE;
	     end;
	     else
		var_bounds = TRUE;

	if bound_error then
	     return;

	num_dims = count;
	dim_node = create_node (dimension_node, size (dimension));
	dp = addr (OS (dim_node));
	dp -> dimension.number_of_dims = count;
	dp -> dimension.assumed_size = (assumed_size_index ^= 0);

	sp = addr (OS (symb));
	sp -> symbol.dimension = dim_node;
	sp -> symbol.variable_extents = var_bounds;

	do i = 1 to num_dims;
	     dp -> dimension.dim (i) = bounds (i);
	     dp -> dimension.v_bound (i) = v_bounds (i);
	end;

	if ^var_bounds				/* store the element count if constant and in range */
	     then
	     if ele_cnt <= max_fixed_bin_24 then
		dp -> dimension.element_count = ele_cnt;
	     else
		call print_message (136, "length", symb, ltrim (char (max_fixed_bin_24)));
						/* array is too long */
	return;

check_assumed_size:
     procedure;
	if assumed_size_index ^= 0			/* second assumed size in this array */
	then do;
	     call print_message (167, symb);
	     bound_error = TRUE;
	end;
	else do;
	     assumed_size_index = count;
	     v_bounds (count).upper = TRUE;
	     call get_next_token$operator;
	end;
	return;
     end check_assumed_size;

check_size:
     procedure;

	if abs (bounds (count).upper_bound) > max_fixed_bin_24 then do;
	     call print_message (136, "magnitude of an array bound", symb, ltrim (char (max_fixed_bin_24)));
	     if bounds (count).upper_bound > 0 then
		bounds (count).upper_bound = max_fixed_bin_24;
	     else
		bounds (count).upper_bound = -max_fixed_bin_24;
	end;
     end check_size;

get_one_bound:
     procedure (indx, bound, bound_is_variable, err_code);

/* Parse one bound of an array declaration and, if the syntax of the bound
   is correct (i.e. is an arithmetic expression of integer constants and
   scalar variables), return either the value of the bound (if constant) or
   the index of a symbol for the value of the bound.  If the bound is not
   a constant or a constant expression, an anonymous automatic integer
   variable is created to hold the value of the bound, unless the bound
   is a scalar variable and we are in '66 mode, in which case we just use
   the variable.  If we create a variable to hold the bound, the index of
   the Polish to initialize it is stored in the 'initial' field of its
   symbol node.  This Polish is preceded by an 'increment_polish' operator
   to "hide" it from the code generator.  The 'process_pending_entries'
   routine is responsible for generating the assignment to initialize a
   compiler generated array bound variable at the appropriate point in
   the entry sequence. */

dcl      indx fixed bin (18),				/* INPUT: index of initial symbol in expression */
         bound fixed bin (24),			/* OUTPUT: if bound is constant then its value else indx of its symbol */
         bound_is_variable bit (1),			/* OUTPUT: "1"b if bound is not constant */
         err_code fixed binary (35);			/* OUTPUT: error code */

dcl      Invalid_operand fixed bin (35) static options (constant) init (1),
         Invalid_operator fixed bin (35) static options (constant) init (2);

dcl      idx_of_expression fixed bin (18),
         idx_of_increment_polish_op fixed bin (18),
         opnd_ptr ptr,
         polish_idx fixed bin (18);


	idx_of_increment_polish_op = next_free_polish;
	call increment_polish (2);
	idx_of_expression = next_free_polish;
	call parse_expression (set_no_symbol_bits, indx, out);

	err_code = 0;
	do polish_idx = idx_of_expression to next_free_polish - 1 while (err_code = 0);
	     if polish_string (polish_idx) > last_assigned_op then do;
						/* Found an operand; check if it is valid. */
		opnd_ptr = addr (OS (polish_string (polish_idx)));
		if opnd_ptr -> node.data_type ^= 0 then
		     if opnd_ptr -> node.data_type ^= int_mode then
			err_code = Invalid_operand;
	     end;
	     else if polish_string (polish_idx) < add_op | polish_string (polish_idx) > negate_op then
		err_code = Invalid_operator;
	end;

	bound = 0;
	bound_is_variable = addr (out) -> expression.not_constant;
	if err_code ^= 0 then
	     next_free_polish = idx_of_increment_polish_op;
	else if bound_is_variable then
	     if next_free_polish > idx_of_expression + 1 | subr_options.ansi_77 then do;
						/* Generate an anonymous variable to receive the bound. */
		bound = build_symbol ((NO_NAME), v_length_attributes, SET);
		addr (OS (bound)) -> symbol.initial = idx_of_expression;
		polish_string (idx_of_increment_polish_op + 1) = next_free_polish - idx_of_expression;
	     end;
	     else do;				/* Use the scalar variable as the bound. */
		bound = indx;
		next_free_polish = idx_of_increment_polish_op;
	     end;
	else if next_free_polish > idx_of_expression + 1
	     | addr (OS (polish_string (idx_of_expression))) -> constant.data_type ^= int_mode then do;
						/* Reduce the expression to an integer value. */
	     parameter_info.desired_data_type = int_mode;
	     parameter_info.max_stack = max_stack;
	     parameter_info.stack_index = stack_index;
	     parameter_info.start_of_polish = idx_of_expression;
	     parameter_info.end_of_polish = next_free_polish - 1;
	     parameter_info.rounding = subr_options.do_rounding;

	     call fort_eval_parm (addr (parameter_info), "an integer constant expression", err_code);
	     max_stack = parameter_info.max_stack;

	     if err_code = 0 then
		unspec (bound) = addr (OS (parameter_info.result_location)) -> constant.value;
	     next_free_polish = idx_of_increment_polish_op;
	end;
	else do;					/* Use the integer value as the bound. */
	     unspec (bound) = addr (OS (polish_string (idx_of_expression))) -> constant.value;
	     next_free_polish = idx_of_increment_polish_op;
	end;

     end get_one_bound;
     end get_bounds;

get_integer_constant:
     procedure (indx, allow_variables, value, variable_found, err_code);
declare	indx fixed bin (18);			/* INPUT: index of initial symbol in expression */
declare	allow_variables bit (1);			/* INPUT: "1"b iff scalar integer expressions permitted */
declare	value fixed bin (24);			/* OUTPUT: value or (symbol index, if variable_found set) */
declare	variable_found bit (1);			/* OUTPUT: "1"b if non-constant found and allowed */
declare	err_code fixed binary (35);			/* OUTPUT: error code */

declare	sp pointer;
declare	ILLEGAL_EXPRESSION_FOUND fixed binary (35) internal static options (constant) initial (1);


/* parses the next expression in the input stream, usually searching for integer constants or constant expressions which
   it converts to constants via fort_eval_parm.  Optionally allows scalars integer variables as well, 
   and if permitted and found, it sets variable_found TRUE.   
*/
	variable_found = FALSE;
	err_code = 0;

	parameter_info.start_of_polish = next_free_polish;

	call parse_expression (set_no_symbol_bits, indx, out);

/* result can be either constant expression or simple scalar variable.
   if it is not a simple_ref
   then if not constant, it is a  error
        else it's a constant expression
	 if only one operand and it is an integer constant
	 then simply get its value.
	 else it is a constant expression of more than term
	      call fort_eval_parm to get its value.
   else its a simple ref
        cant be a substr or subscripted ref
        must be a simple variable.
*/

	if addr (out) -> expression.not_simple_ref then do;
	     if addr (out) -> expression.not_constant then
		err_code = ILLEGAL_EXPRESSION_FOUND;

	     else do;				/* constant expression */
		sp = addr (OS (polish_string (parameter_info.start_of_polish)));

/* if bound is a single integer constant simply gets its value */

		if next_free_polish = parameter_info.start_of_polish + 1 & sp -> constant.data_type = int_mode then
		     unspec (value) = sp -> constant.value;
		else do;
		     parameter_info.desired_data_type = int_mode;
		     parameter_info.max_stack = max_stack;
		     parameter_info.stack_index = stack_index;
		     parameter_info.end_of_polish = next_free_polish - 1;
		     parameter_info.rounding = subr_options.do_rounding;

		     call fort_eval_parm (addr (parameter_info), "an integer constant expression", err_code);
		     max_stack = parameter_info.max_stack;

		     if err_code = 0 then
			unspec (value) = addr (OS (parameter_info.result_location)) -> constant.value;
		end /* complex constant expression */;
	     end /* constant expression */;
	end /* not simple reference */;
	else do;					/* simple reference */
	     if addr (out) -> expression.substring_ref | addr (out) -> expression.subscripted_ref
						/* must be scalar ref */
		then
		err_code = ILLEGAL_EXPRESSION_FOUND;
	     else do;
		variable_found = TRUE;
		if allow_variables then
		     value = indx;
		else
		     err_code = ILLEGAL_EXPRESSION_FOUND;
	     end;
	end;
	next_free_polish = parameter_info.start_of_polish;

     end get_integer_constant;

stack_operand:
stack_operator:
     procedure (op_code_or_operand);

dcl      op_code_or_operand fixed bin (18);

	if stack_index > hbound (stack, 1) then
	     call print_message (67, "stack", hbound (stack, 1) - bias);
						/* stack overflow */
	stack (stack_index) = op_code_or_operand;
	stack_index = stack_index + 1;
	max_stack = max (stack_index, max_stack);
     end stack_operator;

build_symbol:
     procedure (name, attributes, storage_bits) returns (fixed bin (18));

dcl      name char (256) varying;
dcl      attributes bit (47) aligned;
dcl      storage_bits bit (5) aligned;
dcl      sym_indx fixed bin (18);
dcl      sym_ptr pointer;
dcl      count_pic picture "9999";

	allocate_symbol_name = length (name);
	sym_indx = create_node (symbol_node, size (symbol));
	sym_ptr = addr (OS (sym_indx));

	if sub_ptr -> last_symbol = 0 then
	     sub_ptr -> first_symbol = sym_indx;
	else
	     addr (OS (sub_ptr -> last_symbol)) -> symbol.next_symbol = sym_indx;
	sub_ptr -> last_symbol = sym_indx;

	unspec (sym_ptr -> symbol.attributes) = attributes;
	string (sym_ptr -> symbol.storage_info) = storage_bits;
	sym_ptr -> symbol.by_compiler = TRUE;		/* indicate declared by compiler */

	sym_ptr -> symbol.name_length = allocate_symbol_name;

	if substr (name, 1, length (NO_NAME)) = NO_NAME then do;
	     substr (sym_ptr -> symbol.name, 1, 4) = "ftn.";
	     cp_count = cp_count + 1;
	     count_pic = cp_count;
	     substr (sym_ptr -> symbol.name, 5, 4) = count_pic;
	end;
	else
	     substr (sym_ptr -> symbol.name, 1, allocate_symbol_name) = name;

	if produce_listing then
	     call generate_cross_ref (sym_indx);

	return (sym_indx);
     end build_symbol;

/* 08 Mar 86, SH - 410: The bif_table.external has been updated. This table
                        defines the validity of builtins for use as external
                        entry references.*/
builtin_lookup:
     procedure (indx, set_attributes) returns (bit (1) aligned);

dcl      bif_dt fixed bin (18);
dcl      bif_name char (8) aligned;
dcl      bif_ptr pointer;
dcl      i fixed bin (18);
dcl      indx fixed bin (18);
dcl      lower fixed bin (18);
dcl      not_found bit (1) aligned;
dcl      set_attributes bit (1);
dcl      upper fixed bin (18);

/* format: off */

dcl	1 bif_table	(95) aligned int static options (constant),
	  2 name		char (8) aligned init (
			"abs     ", "acos    ", "aimag   ", "aint    ", "alog    ", "alog10  ", "amax0   ", "amax1   ",
			"amin0   ", "amin1   ", "amod    ", "and     ", "anint   ", "asin    ", "atan    ", "atan2   ",
			"bool    ", "cabs    ", "ccos    ", "cexp    ", "char    ", "clog    ", "cmplx   ", "compl   ",
			"conjg   ", "cos     ", "cosh    ", "csin    ", "csqrt   ", "dabs    ", "dacos   ", "dasin   ",
			"datan   ", "datan2  ", "dble    ", "dcos    ", "dcosh   ", "ddim    ", "dexp    ", "dim     ",
			"dint    ", "dlog    ", "dlog10  ", "dmax1   ", "dmin1   ", "dmod    ", "dnint   ", "dprod   ",
			"dsign   ", "dsin    ", "dsinh   ", "dsqrt   ", "dtan    ", "dtanh   ", "exp     ", "fld     ",
			"float   ", "iabs    ", "ichar   ", "idim    ", "idint   ", "idnint  ", "ifix    ", "ilr     ",
			"ils     ", "index   ", "int     ", "irl     ", "irs     ", "isign   ", "len     ", "lge     ",
			"lgt     ", "lle     ", "llt     ", "log     ", "log10   ", "max     ", "max0    ", "max1    ",
			"min     ", "min0    ", "min1    ", "mod     ", "nint    ", "or      ", "real    ", "sign    ",
			"sin     ", "sinh    ", "sngl    ", "sqrt    ", "tan     ", "tanh    ", "xor     "),
	  2 external	bit (1) unaligned init (
			"1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b,
			"0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b,
			"0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "0"b, "0"b,
			"1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b,
			"1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b,
			"1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b,
			"1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b,
			"0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b,
			"1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "0"b,
			"0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b,
			"0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b,
			"1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b),
	  2 pad		bit (3) unaligned init ((95) (3)"0"b),
	  2 data_type	fixed bin (4) unaligned init (
			0, 0, 2, 0, 0, 0, 2, 2,
			2, 2, 2, 7, 0, 0, 0, 0,
			7, 2, 4, 4, 6, 4, 4, 7,
			4, 0, 0, 4, 4, 3, 3, 3,
			3, 3, 3, 3, 3, 3, 3, 2,
			3, 3, 3, 3, 3, 3, 3, 3,
			3, 3, 3, 3, 3, 3, 0, 7,
			2, 1, 1, 1, 1, 1, 1, 1,
			1, 1, 1, 1, 1, 1, 1, 5,
			5, 5, 5, 0, 0, 0, 1, 1,
			0, 1, 1, 0, 0, 7, 2, 2,
			0, 0, 2, 0, 0, 0, 7),
	  2 index		fixed bin (8) unaligned init (
			001, 063, 055, 049, 005, 008, 024, 025,
			030, 031, 036, 084, 079, 061, 010, 012,
			085, 004, 016, 022, 065, 007, 057, 086,
			058, 014, 073, 043, 046, 003, 064, 062,
			011, 013,	056, 015, 075, 019, 021, 017,
			078, 006,	009, 028, 034, 037, 080, 083,
			040, 042,	076, 045, 060, 077, 020, 087,
			051, 002, 066, 018, 050, 082, 052, 088,
			089, 067, 048, 090, 091, 039, 068, 069,
			070, 071, 072, 005, 008, 023, 026, 027,
			029, 032, 033, 035, 081, 092, 054, 038,
			041, 074, 053, 044, 059, 047, 093);

/* format: revert */

	bif_ptr = addr (OS (indx));

	if bif_ptr -> symbol.builtin then
	     return (TRUE);
	else if bif_ptr -> symbol.external then
	     return (FALSE);

	if (unspec (bif_ptr -> symbol.attributes) & bif_conflicts) ^= ZERO then
	     return (FALSE);

	if bif_ptr -> symbol.name_length > length (bif_name) then
	     return (FALSE);
	bif_name = bif_ptr -> symbol.name;
	i = 1;
	lower = 1;
	upper = hbound (bif_table, 1);

	not_found = TRUE;
	do while (not_found);
	     if bif_name = bif_table (i).name then
		not_found = FALSE;
	     else do;
		if bif_name < bif_table (i).name then do;
		     upper = i;
		     i = i - divide (upper - lower + 1, 2, 17, 0);
		end;
		else do;
		     lower = i;
		     i = i + divide (upper - lower + 1, 2, 17, 0);
		end;
		if i = lower then
		     return (FALSE);
	     end;
	end;

	bif_dt = bif_table (i).data_type;

	if bif_dt ^= 0 then
	     if unspec (bif_ptr -> symbol.mode_bits) ^= ZERO then
		if (unspec (bif_ptr -> symbol.attributes) & attr_table (bif_dt)) = ZERO then
		     return (FALSE);		/* Data types differ. */

	if bif_ptr -> symbol.referenced then do;
	     call print_message (93, indx);		/* cannot become a bif */
	     return (FALSE);
	end;

/* symbol.char_size holds the number of the builtin */

	if (set_attributes) then do;
	     bif_ptr -> symbol.char_size = bif_table (i).index;
	     bif_ptr -> symbol.builtin = TRUE;
	     bif_ptr -> symbol.external = bif_table (i).external;
	     if unspec (bif_ptr -> symbol.mode_bits) = ZERO then
		unspec (bif_ptr -> symbol.attributes) = unspec (bif_ptr -> symbol.attributes) | attr_table (bif_dt);
	end;

	return (TRUE);
     end builtin_lookup;

parse_expression:
     procedure (control_bits, save_index, return_bits);	/* Not audited. */

/*	Program Specifications (parse_expr)

     Inputs

     Output

     Description (parse_expr)


		 left right
	operator	 prec  prec  type  op_code

	0. BOE	   0    -1   -	  0
	1. +	  60    60   both	  2
	2. -	  60    60   both	  3
	3. *	  70    70   infix	  4
	4. /	  70    70   infix	  5
	5. **	  90   100   infix	  6
	6. not	  30    30   prefix	  16
	7. and	  20    20   infix	  15
	8. or	  10    10   infix	  14
	9. eq	  40    40   infix	  10
	10. ne	  40    40   infix	  11
	11. lt	  40    40   infix	  8
	12. gt	  40    40   infix	  13
	13. le	  40    40   infix	  9
	14. ge	  40    40   infix	  12
	15. =	  -1     0   -	  0
	16. ,	  -1     0   -	  0
	17. (	   0    -1   prefix	  0
	18. )	  -1     0   -	  0
	19. '	  -1     0   -	  0
	20. :	  -1     0   -        0
	21. //	  50    50   infix    96
	22. substr  -1     0   -        0
	 left_parn
	23. eqv	   0     0   infix    103
	24. neqv	   0     0   infix	  104
	25.	   0     0   not used
	26.	   0     0   not used
	27.	   0     0   not used
	28.	   0     0   not used
	29.	   0     0   not used
	30.	   0     0   not used
	31.	   0     0   not used
	32.	   0     0   not used
	33.	   0     0   not used
	34. negate  80    -1   prefix	   7
*/

dcl      BOE fixed bin (18) int static options (constant) init (0);
dcl      concat_op fixed bin (18) int static options (constant) init (23);
dcl      control_bits bit (36) aligned;
dcl      count fixed bin (18);
dcl      expr bit (36) aligned;
dcl      expon_op fixed bin (18) int static options (constant) init (5);
dcl      have_operand bit (1) aligned;
dcl      header_storage bit (5) unaligned defined (addr (OS (sp -> symbol.parent)) -> header.storage_info);
dcl      in_expr bit (1) aligned;
dcl      indx fixed bin (18);
dcl      is_infix bit (2) aligned int static options (constant) init ("10"b);
dcl      is_prefix bit (2) aligned int static options (constant) init ("01"b);
dcl      left_parenthesis fixed bin (18) int static options (constant) init (10001b);
dcl      may_need_descriptors bit (1);			/* true if may need descriptors */
dcl      negate_token fixed bin (18) int static options (constant) init (34);
dcl      new_state bit (36) aligned;
dcl      not_token fixed bin (18) int static options (constant) init (00110b);
dcl      opc fixed bin;
dcl      pop_stack bit (1) aligned;
dcl      return_bits bit (36) aligned;
dcl      save_index fixed bin (18);
declare	set_storage bit (1) aligned;
dcl      sp pointer;
dcl      subs_or_arg_list fixed bin (18) int static options (constant) init (32);
dcl      substr_paren fixed bin (18) int static options (constant) init (33);
dcl      symbol_storage bit (5) unaligned defined (sp -> symbol.storage_info);
dcl      token_prec fixed bin (18);
dcl      top fixed bin (18);
dcl      tkn fixed bin (18);
dcl      word_offset fixed bin (18);


/* Precedence table initializations */

dcl      lprec (0:34) fixed bin (18) int static options (constant)
	    init (0, 60, 60, 70, 70, 90, 30, 20, 10, (6) 40, (2) - 1, 0, (3) - 1, 50, -1, (2) 5, (9) 0, 80);
dcl      rprec (0:34) fixed bin (18) int static options (constant)
	    init (-1, 60, 60, 70, 70, 100, 30, 20, 10, (6) 40, (2) 0, -1, (3) 0, 50, 0, (2) 5, (7) 0, (3) - 1);
dcl      op_code (0:34) fixed bin (18) int static options (constant)
	    init (0, 2, 3, 4, 5, 6, 16, 15, 14, 10, 11, 8, 13, 9, 12, (6) 0, 96, 0, 103, 104, (9) 0, 7);
dcl      t_type (0:34) bit (2) aligned int static options (constant)
	    init ("0"b, (2) (2)"1"b, (3) (1)"10"b, "01"b, (8) (1)"10"b, (2) (2)"0"b, "01"b, (3) (2)"0"b, "10"b, "00"b,
	    (2) (1)"10"b, (9) (2)"0"b, "01"b);

/* Expression parsing begins here. */

	top = BOE;				/* Prime the top of stack. */
	word_offset = 0;				/* Current symbol does not have a list. */
	count = 0;				/* Therefore list has zero items. */

	expr = control_bits;			/* Copy initial state from input arg. */
	symbol_index = save_index;			/* Copy initial symbol ptr from input arg. */
	set_storage = control_bits ^= set_no_symbol_bits; /* Flag indicates handling of symbol node */

/* EXPRESSION LOOP. Exited when expression is completely parsed. */

	have_operand = FALSE;
	in_expr = TRUE;
	do while (in_expr);

/* OPERAND LOOP. Exited after one opnd, and any prefix operators and left parens, have been parsed. */

	     do while (^have_operand);

/* Stack any prefix operators and left parens which precede the operand. */

		do while (token & is_operator);

/*	Recognition of complex tokens was moved from the lexical analyzer to the
			expression parser on 78.04.07, by David Levin. */

		     if token = left_parn then
			if is_complex_constant (symbol_index) then
			     go to have_constant;

		     tkn = binary (substr (token, 5, 5), 5, 0);

		     if (t_type (tkn) & is_prefix) = ZERO then do;
			call print_message (94, err_string ());
			go to statement_parse_abort;
		     end;

		     if addr (expr) -> expression.set	/* expr in set reference */
			then
			if token = left_parn then
			     call print_message (95, "A redundant parenthesis was encountered. ");
			else
			     call print_message (95);
		     else
			;
		     addr (expr) -> expression.not_simple_ref = TRUE;

		     if token ^= plus		/* No need to stack prefix plus. */
		     then do;
			call stack_operator (top);	/* Stack the old one. */
			if token = minus then
			     top = negate_token;	/* Prefix minus is negate. */

			else if token = not then
			     top = not_token;

			else
			     top = tkn;		/* The rest are what they seem. */
		     end;

		     call get_next_token (force_symtab_entry, symbol_index);
						/* Get token after prefix. */
		end;

/* Prefix operators and left parens are parsed. Now there must be an operand. */

		if token & is_constant		/* All constants. */
		then do;
have_constant:
		     if addr (expr) -> expression.set then
			call print_message (95);	/* constant in set reference */

		     if named_constant_ptr_valid then do;
			sp = named_constant_ptr;
			symbol_storage = symbol_storage | string (addr (expr) -> expression.storage_info);
		     end;
		     call emit_operand (symbol_index);	/* Put constant into polish string. */

		     call get_next_token$operator;	/* Get binary opr or end of expr. */
		     tkn = binary (substr (token, 5, 5), 5, 0);

		     call determine_complexity;	/*  sets not_simple_ref, passed_as_arg, and have_operand */
		     addr (expr) -> expression.not_simple_ref = TRUE;
						/* constant is never simple ref */

		     if addr (expr) -> expression.passed_as_arg
						/* constant is passed as arg */
			then
			addr (OS (symbol_index)) -> constant.passed_as_arg = TRUE;
		end;

		else if token = ident		/* Otherwise, it could be an identifier. */
		then do;
		     addr (expr) -> expression.not_constant = TRUE;
		     indx = symbol_index;		/* freeze index to the symbol. */
		     sp = addr (OS (indx));		/* Pointer to the symbol node. */

		     if addr (expr) -> expression.needs_descriptors = "1"b
			| (sp -> node.node_type = symbol_node & sp -> symbol.mode.character = "1"b
			& addr (expr) -> expression.passed_as_arg = "1"b) then
			may_need_descriptors = "1"b;
		     else
			may_need_descriptors = "0"b;

		     call get_next_token$paren_operator;/* Get left paren, bin opr, or end of expr. */

		     if token = left_parn | token = substr_left_parn
						/* Subscripted ref or some kind of func ref. */
		     then do;

/* Determine the semantics of this reference. */

			if token = substr_left_parn then do;
						/* better be substring */
			     if sp -> symbol.dimensioned & ^addr (expr) -> expression.subscripted_ref then
				call print_message (155, indx,
				     "Substring may only be applied to simple variables or array elements");
						/* can't substr an array */

			     if (unspec (sp -> symbol.attributes) & scalar_conflicts) = ZERO
						/* simple ref */
				then
				if set_storage then
				     sp -> symbol.variable = TRUE;
						/* Symbol must remain a variable */

			     new_state = any_expression;
			     opc = substr_op;
			end;

			else if sp -> symbol.dimensioned then do;
						/* Subscripted reference. */
			     addr (expr) -> expression.subscripted_ref = TRUE;
			     new_state = any_expression;
			     opc = subscript_op;
			end;

/* if not dimensioned, Then some sort of func ref */

			else if sp -> symbol.external & sp -> symbol.function then do;
						/* External function reference. */
			     addr (expr) -> expression.not_simple_ref = TRUE;

			     if addr (expr) -> expression.set then
				call print_message (96, indx);

			     if sp -> symbol.needs_descriptors then
				new_state = darg_list_expr;
			     else
				new_state = arg_list_expr;

			     opc = func_ref_op;
			end;

			else if sp -> symbol.stmnt_func then do;
						/* st func reference. */
			     addr (expr) -> expression.not_simple_ref = TRUE;

			     if addr (expr) -> expression.set then
				call print_message (96, indx);

			     new_state = any_expression;
			     opc = sf_op;
			end;

			else if builtin_lookup (indx, SET_ATTR) then do;
						/* builtin func reference. */
			     addr (expr) -> expression.not_simple_ref = TRUE;
						/* fld is the only bif that can be used in a set reference */

			     if addr (expr) -> expression.set & addr (OS (indx)) -> symbol.name ^= "fld" then
				call print_message (96, indx);

			     new_state = any_expression;
			     opc = builtin_op;
			end;

			else do;			/* Anything else must become an external func ref. */
			     if (unspec (sp -> symbol.attributes) & func_conflicts) = ZERO then do;
				if set_storage then
				     unspec (sp -> symbol.attributes) =
					unspec (sp -> symbol.attributes) | func_ref_attribute;
			     end;
			     else
				call print_message (97, indx);
						/* cannot be ext func */

			     addr (expr) -> expression.not_simple_ref = TRUE;

			     if addr (expr) -> expression.set then
				call print_message (96, indx);

			     if sp -> symbol.needs_descriptors then
				new_state = darg_list_expr;
			     else
				new_state = arg_list_expr;

			     opc = func_ref_op;
			end;

/* Stack the current expression state. State will be restored after correct right paren encountered. */

			call emit_operand (indx);
substring_of_array_ref:
			call stack_operator (top);	/* Stack previous operator. */
			call stack_operator ((addr (expr) -> based_integer));
						/* Stack state */
			call stack_operator (count);
			if opc = substr_op then do;
			     call stack_operator (indx);
			     top = substr_paren;
			     if ^subr_options.ansi_77 then
				call print_message (154);
			end;
			else do;
			     top = subs_or_arg_list;
			     call stack_operator (word_offset);
			end;

			expr = new_state;

/* Emit correct polish. */
			if opc ^= substr_op then do;
			     call emit_count (word_offset);
			     call emit_operator ((opc));
			end;
			count = 0;		/* Local copy of item count. */

			call get_next_token (force_symtab_entry, symbol_index);
						/* Get beginning of first item or right paren. */

			if token = right_parn	/* func ref with no args. */
			then do;
			     call process_eol;
			     call get_next_token$operator;
						/* get binary opr or end of expr */
			end;

			else if token = colon	/* substring, no start given */
			then do;
			     count = count + 1;

			     call get_next_token (force_symtab_entry, symbol_index);

			     if token = right_parn	/* (:)--just ignore it */
			     then do;
				have_operand = TRUE;
				call process_end_of_substr;
				call get_next_token$operator;
			     end;

			     else
				call emit_operand (value_1);
						/* otherwise, beginning is implicitly 1 */
			end;

		     end;				/* SUBSCRIPTED REF or FUNCTION REF */

		     else do;

/* ident without left_parn */
			tkn = binary (substr (token, 5, 5), 5, 0);
						/* gives context */
			call determine_complexity;	/*  sets not_simple_ref, passed_as_arg, and have_operand */

			if set_storage then do;

/* determine the semantics */
			     if sp -> symbol.function & sp -> symbol.entry_point then do;
						/* LINK  ENTRY TO return_value */
				indx = return_value;
				sp = addr (OS (indx));
			     end;

			     if (unspec (sp -> symbol.attributes) & scalar_conflicts) = ZERO
						/* simple ref */
			     then do;
				sp -> symbol.variable = TRUE;

/* If star extent automatic, then it will not get picked up by declaration
   processor, entry argument processing to set the needs descriptors.  Therefore
   we must set it when we know the reference. */

				if sp -> symbol.star_extents & may_need_descriptors then
				     sp -> symbol.needs_descriptors = "1"b;
			     end;			/* Symbol must remain a variable */

			     else if sp -> symbol.dimensioned
						/* array name ref */
			     then do;
				if may_need_descriptors
				     & (sp -> symbol.variable_extents | sp -> symbol.star_extents) then
				     sp -> symbol.needs_descriptors = TRUE;

				addr (expr) -> expression.array_name = TRUE;

				if ^addr (expr) -> expression.allow_array_name
				     | addr (expr) -> expression.not_simple_ref then
				     call print_message (98, indx);
						/* array name is illegal */
				if addr (expr) -> expression.no_assumed_size_array then
				     if addr (OS (sp -> symbol.dimension)) -> dimension.assumed_size then
					call print_message (166, keyword_table (statement_type));
			     end;

			     else if sp -> symbol.external | sp -> symbol.builtin
						/* entry value in arg list */
			     then do;
				if ^addr (expr) -> expression.passed_as_arg then
				     call print_message (99, indx);
						/* illegal use of entry value */
				if ^sp -> symbol.external then
				     call print_message (461, indx);
						/* Not a passable intrinsic */
				addr (expr) -> expression.not_simple_ref = TRUE;

				if (unspec (sp -> symbol.attributes) & entry_value_conflicts) = ZERO then
				     unspec (sp -> symbol.attributes) =
					unspec (sp -> symbol.attributes) | entry_value;
				else
				     call print_message (99, indx);
			     end;

			     else
				call print_message (100, indx);
						/* ref is in wrong context */

			     call set_storage_bits;

			end /* set_storage */;
			call emit_operand (indx);
		     end;
		end /* ident */;
		else do;
		     call print_message (94, err_string ());
		     go to statement_parse_abort;	/* missing operand */
		end;
	     end /* looking for operand */;

/* Now parse one binary operator or the end of the expression. Then check precedence. */

	     if (token & is_operator) = ZERO		/* Token must be an operator. */
	     then do;
		call print_message (101, err_string ());
		go to statement_parse_abort;		/* missing operator */
	     end;

	     if t_type (tkn) = is_prefix		/* Must be infix operator. */
	     then do;
		call print_message (101, err_string ());
		go to statement_parse_abort;		/* missing operator */
	     end;

	     if addr (expr) -> expression.set then
		if (t_type (tkn) & is_infix) ^= ZERO then
		     call print_message (95);		/* expr in set reference */

	     have_operand = FALSE;			/* Must have operand if not end of expression. */

/* Unstack operators as long as the current token has lower or equal precedence. */

	     token_prec = rprec (tkn);		/* right precedence for the token */

	     pop_stack = lprec (top) >= token_prec;
	     do while (pop_stack);

/* If stack contains executable ops, start emitting them. */

		if op_code (top) ^= 0		/* All executable operators. */
		then do;
		     call emit_operator ((op_code (top)));
		     stack_index = stack_index - 1;	/* Get the previous operator from stack. */
		     top = stack (stack_index);
		     pop_stack = lprec (top) >= token_prec;
		end;

/* Otherwise, end of expr, end of subs or arg list, end of parenthesized expr, or error. */

		else do;
		     pop_stack = FALSE;		/* No iteration possible. */
		     if top = BOE			/* If we're here, we're done. */
			then
			in_expr = FALSE;

		     else if top = left_parenthesis & token = right_parn
						/* Eliminate pair of parens. */
		     then do;
			stack_index = stack_index - 1;/* Get the previous operator from stack. */
			top = stack (stack_index);
			tkn = binary (substr (token_list (current_token + 1).type, 5, 5), 5, 0);
			have_operand = TRUE;
		     end;

		     else if top = subs_or_arg_list & (token = right_parn | token = comma) then do;
			count = count + 1;

			call emit_operator (item_op);

			if token = right_parn then do;
			     call process_eol;
			     if token_list (current_token + 1).type = left_parn then do;
				call get_next_token$paren_operator;
				if token ^= substr_left_parn then do;
				     call print_message (101, err_string ());
				     go to statement_parse_abort;
				end;
				have_operand = FALSE;
				opc = substr_op;
				addr (expr) -> expression.substring_ref = TRUE;
				new_state = any_expression;
				if sp -> symbol.attributes.mode.character then
				     go to substring_of_array_ref;
				else do;
				     call print_message (102, err_string ());
				     go to statement_parse_abort;
				end;
			     end;
			end;			/* End of list. */

			else do;			/* Get next expression. */
			     unspec (addr (expr) -> expression.not_scalar_ref) = ZERO;

			     if addr (expr) -> expression.reset_arg_bit then
				addr (expr) -> expression.passed_as_arg = TRUE;
			end;
		     end;

		     else if top = substr_paren & token = colon then do;
			count = count + 1;
			if count ^= 1 then do;
			     call print_message (102, err_string ());
			     go to statement_parse_abort;
			end;

			unspec (addr (expr) -> expression.not_scalar_ref) = ZERO;

			if token_list (current_token + 1).type = right_parn then do;
			     call get_next_token$operator;

/* recover index of string symbol from stacked expression */

			     indx = stack (stack_index - 1);
			     call emit_operand (get_char_length (force_symtab_entry, (indx)));
			     call process_end_of_substr;
			end;
		     end;

		     else if top = substr_paren & token = right_parn then do;
			if count ^= 1 then do;
			     call print_message (102, err_string ());
			     goto statement_parse_abort;
			end;
			call process_end_of_substr;
		     end;

		     else do;
			call print_message (102, err_string ());
						/* comma out of place */
			go to statement_parse_abort;
		     end;
		end;
	     end /* unstack loop */;

/* Stack the current operator if it is not the end of the expression. */

	     if token_prec > 0 then do;
		if top = expon_op & tkn = expon_op then
		     call print_message (144);
		call stack_operator (top);		/* Stack previous operator. */
		top = tkn;
		addr (expr) -> expression.not_simple_ref = TRUE;
	     end;

/* The test for concat in non-ansi77 subr moved to the code generator or
   converter ...  */
/* if tkn = concat_op & ^subr_options.ansi_77
	     then call print_message (153);     */


	     if in_expr then
		call get_next_token (force_symtab_entry, symbol_index);
	end /* expression loop */;

	return_bits = expr;				/* return final expression status */
	return;


determine_complexity:
     procedure;					/* check for binary operators and sets have_operand */
						/* also sets expr.not_simple_ref and expr.passed_as_arg */
	have_operand = TRUE;			/* binary opr or end of expr must follow */

	if t_type (tkn) & is_infix then
	     addr (expr) -> expression.not_simple_ref = TRUE;
						/* Is ref part of expr? */

	if addr (expr) -> expression.not_simple_ref then
	     addr (expr) -> expression.passed_as_arg = FALSE;
						/* argument only if not expr. */
     end determine_complexity;


process_eol:
     procedure;

	unspec (expr) = unspec (stack (stack_index - 3)); /* Restore expression status bits. */

	indx = polish_string (word_offset - 1);		/* Restore pointer to owner of this list. */
	sp = addr (OS (indx));			/* ditto. */

	call emit_operator (eol_op);

	if count > 0 then do;
	     if count > max_arglist - 1		/* must leave room for return value */
		then
		call print_message (138, max_arglist - 1 - bias, indx);

	     polish_string (word_offset) = count - bias;	/* Store list count in polish. */
	end;

	tkn = binary (substr (token_list (current_token + 1).type, 5, 5), 5, 0);
						/* gives context */
	call determine_complexity;			/*  sets not_simple_ref, passed_as_arg, and have_operand */

	if set_storage then
	     call set_storage_bits;

	word_offset = stack (stack_index - 1);		/* Restore list info for containing list. */
	count = stack (stack_index - 2);
	stack_index = stack_index - 4;		/* Remove this list from the stack and get prev opr. */
	top = stack (stack_index);
     end process_eol;
process_end_of_substr:
     procedure;

	unspec (expr) = unspec (stack (stack_index - 3));

	if ^have_operand then do;
	     have_operand = TRUE;
	     call emit_operator (substr_op);
	     addr (expr) -> expression.substring_ref = TRUE;
	end;

	top = stack (stack_index - 4);
	count = stack (stack_index - 2);
	indx = stack (stack_index - 1);
	sp = addr (OS (indx));
	if set_storage then
	     call set_storage_bits;
	stack_index = stack_index - 4;

	tkn = binary (substr (token_list (current_token + 1).type, 5, 5), 5, 0);

	return;
     end process_end_of_substr;
set_storage_bits:
     procedure;

	symbol_storage = symbol_storage | string (addr (expr) -> expression.storage_info);
	if sp -> symbol.equivalenced then
	     if sp -> symbol.parent > 0 then
		header_storage = header_storage | string (addr (expr) -> expression.storage_info);

	return;
     end set_storage_bits;
     end parse_expression;

is_complex_constant:
     procedure (complex_constant_offset) returns (bit (1) aligned);

dcl      complex_constant_offset fixed bin (18);
dcl      cx fixed bin (18);
dcl      following_token (2) bit (9) aligned int static options (constant) init ("220"b3, "222"b3);
						/* comma & right_parn */
dcl      i fixed bin (18);
dcl      indx fixed bin (18);
dcl      symb fixed bin (18);
dcl      var_len fixed bin (18);

dcl      1 complex_info (2) aligned,
	 2 sign_char bit (9),
	 2 value fixed bin (18);

dcl      1 two_words aligned,
	 2 words (2) bit (36) aligned;

	indx = current_token;

/* First, see if this is a complex const; while we check, we'll save what info we get. */

	do i = 1 to 2;

	     if token_list (indx + 1).type = plus | token_list (indx + 1).type = minus then do;
		complex_info (i).sign_char = token_list (indx + 1).type;
		indx = indx + 1;
	     end;
	     else
		complex_info (i).sign_char = ZERO;

	     if token_list (indx + 2).type ^= following_token (i) then
		return (FALSE);

	     if token_list (indx + 1).type = real_const | token_list (indx + 1).type = dec_int then
		complex_info (i).value = indx + 1;
	     else do;
		if token_list (indx + 1).type ^= ident then
		     return (FALSE);

		var_len = token_list (indx + 1).length + 1;

		substr (full_name, 1, var_len) = substr (st_copy, token_list (indx + 1).offset + 1, var_len);

		call find_symbol_index (var_len, symb, locate_symtab_entry, ignore_value);
		if symb = 0 then
		     return (FALSE);
		if ^addr (OS (symb)) -> symbol.named_constant then
		     return (FALSE);

		symb = addr (OS (symb)) -> symbol.initial;
		if addr (OS (symb)) -> constant.data_type ^= real_mode then
		     return (FALSE);
		complex_info (i).value = -symb;
	     end;

	     indx = indx + 2;
	end;					/* loop to check each part of a complex const */

/* Now, convert both parts to binary. */

	do i = 1 to 2;

	     sign = complex_info (i).sign_char;
	     cx = complex_info (i).value;

	     if cx > 0				/* then this is a token node */
		then
		if token_list (cx).type = real_const then do;
		     token_offset = token_list (cx).offset;
						/* get token info for conversion */
		     cx = token_list (cx).length + 1;
		     token_length = constant_array (cx).length + 1;

		     work = convert_real_constant (cx);
		     unspec (addr (two_words) -> based_real (i)) =
			conv_round (real_mode, dp_mode) ((unspec (addr (work) -> based_double)), 0);
		end;

		else do;				/* otherwise an integer */
		     work = convert_integer_constant ((token_list (cx).offset), token_list (cx).length + 1);
		     unspec (addr (two_words) -> based_real (i)) =
			conv_round (real_mode, int_mode) ((unspec (addr (work) -> based_integer)), 0);
		end;

	     else
		words (i) = addr (OS (-cx)) -> constant.value;
						/* this is named constant, get const value */

	     if sign = minus then
		unspec (addr (two_words) -> based_real (i)) =
		     negate_round (real_mode) (6, (unspec (addr (two_words) -> based_real (i))), "0"b, 0);
	end;

	sign = ZERO;				/* See procedure convert_integer_constant */

/* Next, modify token list info. */

	current_token = indx;

	if current_token >= last_token then
	     token_length, token_list (current_token).length = statement_length - token_offset - 1;
	else
	     token_length, token_list (current_token).length = token_list (current_token + 1).offset - token_offset - 1;

	token, token_list (current_token).type = complex_const;

	token_list (current_token).offset = token_offset;

/* Finally, create a complex constant. */

	work = string (two_words);			/* Many parsers expect the value to be here. */
	complex_constant_offset = create_constant (cmpx_mode, work);
	return (TRUE);
     end is_complex_constant;

/* BEGIN ext_parse section - LEX - split 82-03-29  T. Oke */

/* Modification History:

   Modified 10 Feb 83, HH - Install LA/VLA support.
   Modified  21 June  1982, TO - Change global and option names to:
	"ckmpy", "nckmpy", change optional "nsubrg", "nstrg".
   Modified   4 April 1982, TO - Change global and option names to:
	"ck_mpy" and "no_ck_mpy", add optional "no_subrg", "no_strg".
   Modified:  7 May 1982, TO - Make %global options print in header and binary.
   Modified:  3 May 1982, TO - change error_table_$no_entry to error_table_$noentry.
   Modified:  3 May 1982, TO - Add "-check_multiply" and "-no_check_multiply".
   Modified: 28 April 1982, TO - Fix phx12940, X FORMAT not followed by comma.
   Modified: 15 April 1982, TO - Fix bug300 to permit lex to see an apostrophe
	even if not preceeded by an operator, if in a FORMAT statement.
   */

statement_lex:
     procedure (a_stmnt_type);

/*	Program Specifications (statement_lex)

     Inputs

     Output

     Description (statement_lex)
*/

dcl      ASSIGN bit (1) aligned;
dcl      EOS bit (1) aligned;
dcl      FORTRAN_ONLY bit (2) aligned int static options (constant) init ("00"b);
dcl      GLOBAL_OK bit (2) aligned int static options (constant) init ("11"b);
dcl      LOWER char (26) aligned int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
dcl      NL char (1) aligned init ("
") int static options (constant);
dcl      OPTIONS_OK bit (2) aligned int static options (constant) init ("01"b);
dcl      UPPER char (26) aligned int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl      WHITE char (2) aligned int static options (constant) init ("	 ");
						/* tab & space */
dcl      a_stmnt_type fixed bin (18);
dcl      alphanumeric char (64) aligned int static options (constant)
	    init ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz");
dcl      apostrophe_char char (1) aligned int static options (constant) init ("'");
dcl      begin_text fixed bin (20);
dcl      blank_cont_count fixed bin (18);
dcl      cname char (32);
declare	command character (7) internal static options (constant) initial ("fortran");
dcl      count fixed bin (18);
dcl      dname char (256);
dcl      dtm fixed bin (71);
dcl      ename char (256);
dcl      end_text fixed bin (20);
dcl      end_zero fixed bin (18);
dcl      exp fixed bin (18);
dcl      extra_blanks fixed bin (18);
dcl      i fixed bin (18);
dcl      last_token_type bit (9) aligned;
dcl      lexing_a_token bit (1) aligned;
dcl      operator_follows bit (1) aligned;
dcl      paren_level fixed bin (18);
declare	penultimate_token_type bit (9) aligned;
dcl      percent_line_flag bit (2) aligned;
dcl      precision fixed bin (18);
dcl      quote char (1) aligned int static options (constant) init ("""");
dcl      stmnt_type fixed bin (18);
dcl      t_scale fixed bin (18);
dcl      token_table (0:127) fixed bin (18) int static options (constant)
						/* 000 - 037 */
	    init ((9) 0, -1, (22) 0,			/* 040 - 047 */
	    -1, 0, 13, 0, 15, (2) 0, 12,		/* 050 - 057 */
	    8, 9, 14, 4, 10, 5, 2, 11,		/* 060 - 100 */
	    (10) 3, 17, 16, 0, 7, (3) 0,		/* 101 - 177 */
	    (26) 1, (3) 0, 6, (2) 0, (26) 1, (5) 0);
dcl      token_type bit (9) aligned;
dcl      translate_string bit (1) aligned;
dcl      uid bit (36) aligned;

dcl      1 line_structure aligned based (source_ptr),
	 2 pad char (char_index) unaligned,
	 2 rest_of_line char (end_of_line - char_index) unaligned;

dcl      1 text_structure aligned based (source_ptr),
	 2 pad char (char_index) unaligned,
	 2 rest_of_text char (source_len - char_index) unaligned;

dcl      find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
dcl      hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl      translator_info_$component_get_source_info
	    entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35));
declare	com_err_ entry () options (variable);
declare	error_table_$noentry external static fixed binary (35);
declare	error_table_$no_s_permission fixed bin (35) ext static;

/* beginning of statement lexical analysis */

lex_aborted:
	if cur_statement + size (statement) = next_free_polish then
	     cur_stmnt_ptr -> statement = addr (statement_info) -> statement;
	else
	     call emit_statement_op (addr (statement_info));

	first_token = 2;				/* index of first token; leave room to split it */
	last_token = 1;				/* index of last token; it is always correct */

/* loop until a non-null statement is encountered */

	do while (last_token < first_token);

	     statement_length = 0;			/* Length of statement text copy. */
	     COLON_BEFORE_ASSIGN = FALSE;
	     ASSIGN = FALSE;			/* No assign token encountered. */
	     SECOND_EQUALS = FALSE;			/* Second statement of logical if is assignment. */
	     label_args = FALSE;			/* indicate presence of label args; used by call stmnt parse */
	     paren_level = 0;			/* Paren level. */
	     end_zero = 0;				/* Used to recognize logical if statements. */
	     const_count = 0;			/* Count of real and dp constants. */
	     last_token_type, penultimate_token_type = no_token;
	     stmnt_type = 0;			/* Statement type of statement lexed. */
	     EOS = FALSE;				/* have not yet reached end of this statement */

	     if line_number >= 16384			/* limitation imposed by stmnt map */
	     then do;
		cur_stmnt_ptr -> statement.line = ZERO; /* line has no line number */
		addr (statement_info) -> statement.line = ZERO;
						/* nor do future ones */

		if type_of_line ^= no_more_source then
		     call print_message (103, char (decimal (line_number, 12)));
	     end;
	     else do;
		addr (statement_info) -> statement.line = bit (fixed (line_number, 14), 14);
		cur_stmnt_ptr -> statement.line = bit (fixed (line_number, 14), 14);
	     end;

	     cur_statement_list = number_of_lines;

	     begin_text, end_text = statement_offset;	/* used to calculate sttmnt length */
	     cur_stmnt_ptr -> statement.start = statement_offset;

	     if type_of_line = no_more_source then do;
		call print_message (104);		/* missing end_line */
		statement_label = 0;
		a_stmnt_type = end_line;
		return;
	     end;

/* pick up statement label */

	     statement_label = next_statement_label;
	     if statement_label ^= 0 then do;
		end_possible = FALSE;
		next_statement_label = 0;
	     end;

/* loop to lex a statement; terminates when the next statement is encountered */

	     do while (^EOS);

		token_length = 0;
		token_offset = statement_length;

		translate_string = FALSE;		/* just copy, don't translate */

		go to lexer (char_type);		/* CASE ( token type ) */

/* Return here after lexing one token. If the token is simple, i.e.- an operator, only
		   the token type is stored. If it is complicated, its length and offset are also stored. */

store_token_length:					/* a complicated token */
		token_list (last_token + 1).offset = token_offset;
						/* last_token will never exceed the array bound */

		if token_length > 512 then do;
		     token_list (last_token + 1).length = 512;
		     call print_message (124, 512 - bias);
						/* token string too long */
		end;
		else
		     token_list (last_token + 1).length = token_length - 1;


have_token:					/* a simple token */
		last_token = last_token + 1;

		if last_token >= hbound (token_list, 1) then do;
		     call print_message (123, hbound (token_list, 1) - 1 - bias);
						/* token table overflow */
		     go to abort_lex;
		end;

		token_list (last_token).type = token_type;
		penultimate_token_type = last_token_type;
		last_token_type = token_type;

lex_next_token:					/* if token lex fails */
	     end;					/* lex of a single statement */

	     if last_token < first_token then do;
		call print_message (105);		/* null statement */
	     end;
	end;					/* loop to lex a non-null statement */

	if end_text - begin_text < 512 then
	     cur_stmnt_ptr -> statement.length = bit (binary (end_text - begin_text, 9), 9);
	else
	     cur_stmnt_ptr -> statement.length = "111111111"b;
						/* maximum length possible */

	current_token = 2;

	token_list (last_token + 1).type = EOS_token;	/* indicates the end to the parsers */

	if stmnt_type ^= 0				/* Statement type is already known. */
	then do;
	     if stmnt_type ^= asf_definition & stmnt_type ^= assignment_statement then
		call split_token ((length (keyword_table (stmnt_type))), current_token, FALSE);

	     a_stmnt_type = stmnt_type;
	     return;
	end;

statement_lex$recognize_statement:
     entry (a_stmnt_type);

/* Lookup first token in table to determine statement type. */

	if token_list (current_token).type ^= ident then do;
	     a_stmnt_type = unknown_statement;
	     return;
	end;

	fast_lookup = substr (st_copy, token_list (current_token).offset + 1, token_list (current_token).length + 1);

/* Order of look up is based on whether we are out of "declarative section". */

	if assignment_statement_index ^= assignment_statement then do;
						/* Most likely a declarative. */
	     do stmnt_type = keyword_index to asf_definition - 1
		while (substr (fast_lookup, 1, length (keyword_table (stmnt_type))) ^= keyword_table (stmnt_type));
	     end;

	     if stmnt_type >= asf_definition then
		do stmnt_type = asf_definition + 1 to assignment_statement - 1
		     while (substr (fast_lookup, 1, length (keyword_table (stmnt_type)))
		     ^= keyword_table (stmnt_type));
		end;
	end;

	else do;					/* Most likely executable. */
	     do stmnt_type = asf_definition + 1 to assignment_statement - 1
		while (substr (fast_lookup, 1, length (keyword_table (stmnt_type))) ^= keyword_table (stmnt_type));
	     end;

	     if stmnt_type >= assignment_statement then do;
		do stmnt_type = keyword_index to asf_definition - 1
		     while (substr (fast_lookup, 1, length (keyword_table (stmnt_type)))
		     ^= keyword_table (stmnt_type));
		end;
		if stmnt_type >= asf_definition then
		     stmnt_type = assignment_statement;
	     end;
	end;

/* If not found, see if it unknown or just out of sequence. */

	if stmnt_type >= assignment_statement then do;
	     do stmnt_type = 1 to keyword_index - 1
		while (substr (fast_lookup, 1, length (keyword_table (stmnt_type))) ^= keyword_table (stmnt_type));
	     end;
	     if stmnt_type >= keyword_index then
		stmnt_type = unknown_statement;
	     else do;
		bad_type = stmnt_type;
		stmnt_type = out_of_sequence;
	     end;
	end;

/* If it is legitimate, remove the keyword from the token. If stmnt_type = asf_definition
	   & stmnt_type = assignement_statement split_token will incorrectly remove valid characters. */

	else
	     call split_token ((length (keyword_table (stmnt_type))), current_token, FALSE);

	a_stmnt_type = stmnt_type;
	return;

statement_lex$initialize:
     entry;

	percent_line_flag = GLOBAL_OK;
	extra_blanks, blank_cont_count, source_line_number, line_number = 0;
	next_line_index, end_of_line = -1;

statement_lex$get_next_subprogram:
     entry;

	percent_line_flag = percent_line_flag | OPTIONS_OK;
	have_auto_option, have_static_option = "0"b;
	cur_statement = -1;
	next_statement_label = 0;

/* loop until the first initial line or end of text */

	EOS = FALSE;

	do while (^EOS);
	     call get_line_image (percent_line_flag);	/* Sets "type_of_line" & "EOS", processes %global, %options */

	     if type_of_line = continuation_line & ^EOS	/* continuation precedes initial line, error */
		then
		call print_message (112);
	end;

	call get_new_character;			/* get information about first character */
	return;

abort_lex:					/* if lex of a statement must be aborted */
	EOS = FALSE;
	do while (^EOS);
	     call get_line_image (FORTRAN_ONLY);
	end;

	call get_new_character;			/* reset global variables */

	go to lex_aborted;

/* Case	White space -- only possible if first significant char of a statement is on a continuation line */
lexer (-1):
	if statement_label ^= 0 then
	     next_statement_label = -1;		/* prevent multiple labels */
	call skip_characters (0);
	if next_statement_label < 0 then
	     next_statement_label = 0;
	go to lex_next_token;

/* Case	non-ASCII, characters not in character set. */
lexer (0):
	if binary (bit_value, 9, 0) <= 32 | binary (bit_value, 9, 0) >= hbound (token_table, 1) then
	     call print_message (106, "whose bit value is " || char (bit_value));
	else
	     call print_message (106, char_value);
	call skip_characters (ONE);
	go to lex_next_token;

/* Case A-Z a-z */
lexer (1):
	token_type = ident;
	translate_string = fold_option;		/* translate name if specified by user */

	lexing_a_token = TRUE;
	do while (lexing_a_token);
	     i = verify (rest_of_line, alphanumeric) - 1;
	     if i = 0 then
		lexing_a_token = FALSE;
	     else do;
		if i < 0 then
		     i = length (rest_of_line);
		call skip_characters (i);
		if EOS then
		     lexing_a_token = FALSE;
		else if char_type ^= digits & char_type ^= letters & current_character ^= "_"
		     & current_character ^= "$" then
		     lexing_a_token = FALSE;
	     end;
	end;

	go to store_token_length;

/* Case . decimal point */
lexer (2):
	call skip_characters (ONE);

	if EOS then do;
	     call print_message (107, ".");		/* illegal "." */
	     go to lex_next_token;
	end;

	if char_type = digits then do;
	     call get_digits (precision);
	     token_type = real_const;
	     t_scale = precision;
	     operator_follows = FALSE;
	     call parse_exponent;
	end;
	else do;
	     translate_string = fold_option;
	     call build_fortran_operator;
	end;
	go to store_token_length;

/* Case 0-9 digits */
lexer (3):
	token_type = dec_int;
	call get_digits (precision);
	t_scale = 0;
	operator_follows = FALSE;

/* for ansi77, a few changes here.  If the last token_type was an asterisk, there are several possibilities.
   If we're wihtin parens, and the next_to_last token is either a comma, or a left paren,
   then this should be a label constant (e.g. *8 ,like Multics $8) in a call statment.
   We can also detect an initial field length (e.g. character*30), but not an internal one,
   e.g. character *3 foo, bar *33.  The *33 can't be distinguished from an arithemetic expression at this point.
*/

	if EOS then
	     go to store_token_length;
	if last_token_type = asterisk then do;
	     if paren_level = 0 & last_token - first_token = 1 then
		go to store_token_length;		/* a initial length field */
	     else if paren_level > 0 & (penultimate_token_type = comma | penultimate_token_type = left_parn) then do;

/* The previous asterisk actually began an alternate return arg in a call.  We must back up the token list,
   and incorporate the "*" into this token.  This requires changing the token_type, and the length and offset.
*/

		token_offset = token_offset - 1;
		token_length = token_length + 1;
		label_args = TRUE;
		token_type = label_const;
		last_token = last_token - 1;
		goto store_token_length;
	     end /* label arg */;
	end /* last was asterisk */;

/* A little diddling added to handle x format within formats, but not
   followed by an operator, such as ) or ,. PHX12940.  Here detect the
   presence of a 6 character token as first on a line, followed by a
   left_parn, the best we can do other than actually setting a FORMAT flag. */

	if current_character = "x" | current_character = "X" then
	     if paren_level >= 1 & last_token > 2 & token_list (2).length = 5 & token_list (3).type = left_parn then do;
						/* must be FORMAT nX */
		call skip_characters (ONE);
		go to store_token_length;
	     end;

/* an integer followed by an h is usually a hollerith constant */

	if current_character = "h" | current_character = "H" then do;
	     unspec (count) = convert_integer_constant (token_offset, token_length);

	     token_length = -1;
	     token_offset = statement_length + 1;
	     token_type = char_string;

	     if count = 0				/* "call skip_characters" even if error. */
	     then do;
		call print_message (108);
		call skip_characters (ONE);		/* Skip "h". */
		go to store_token_length;
	     end;

	     count = count + 1;			/* Include the "h" in the count. */
	     do while (count > 0);
		i = min (count, length (rest_of_line));
		count = count - i;
		if count > 0 then do;
		     call get_continuation_line (count);/* Sets: type_of_line, EOS and its argument */

		     if EOS			/* string is terminated by the end of the statement */
		     then do;
			if count > 0		/* statement terminated before we got enough chars */
			     then
			     call print_message (109);
			if token_length = 0 then
			     call print_message (108);
			call skip_characters (0);
			go to store_token_length;
		     end;

		     i = count;			/* set i to number of remaining chars in const */
		end;
	     end;

	     call skip_characters (i);		/* copy end of string and find next significant char */
	     go to store_token_length;
	end;

/* now see if the number contains a decimal point */

	if current_character = "." then do;
	     call skip_characters (ONE);
	     token_type = real_const;
	     if ^EOS then do;
		if char_type = digits		/* Digits after the decimal point? */
		then do;				/* Yes. */
		     call get_digits (t_scale);
		     precision = precision + t_scale;
		end;
		else do;
		     translate_string = fold_option;	/* in case integer is followed by rel op */
		     operator_follows = TRUE;		/* could be integer followed by rel op */
		end;
	     end;
	end;

/* finally, see if there is an exponent field */

	call parse_exponent;

	if operator_follows				/* set by parse_exponent if rel op follows int */
	then do;

/*	A decimal point encountered is actually part of a relational operator. We will store the
		integer (which is the only possible token to precede it) and then process the rel op. */

	     last_token = last_token + 1;

	     if last_token >= hbound (token_list, 1) then do;
		call print_message (123, hbound (token_list, 1) - 1 - bias);
						/* token table overflow */
		go to abort_lex;
	     end;

	     token_list (last_token).type = dec_int;
	     token_list (last_token).offset = token_offset;

	     if precision > 512 then do;
		token_list (last_token).length = 511;
		call print_message (124, 512 - bias);	/* token string too long */
	     end;
	     else
		token_list (last_token).length = precision - 1;

/* now update length and offset to exclude the integer */

	     token_offset = token_offset + precision;
	     token_length = token_length - precision;
	     call build_fortran_operator;
	end;
	go to store_token_length;

/* Case + */
lexer (4):
	token_type = plus;
	call skip_characters (ONE);
	go to have_token;

/* Case - */
lexer (5):
	token_type = minus;
	call skip_characters (ONE);
	go to have_token;

/* Case ^ */
lexer (6):
	token_type = expon;
	call skip_characters (ONE);
	go to have_token;

/* Case = */
lexer (7):
	token_type = assign;
	if paren_level = 0 & ^ASSIGN then do;
	     ASSIGN = TRUE;				/* These tests made only once per statement. */
	     if substr (st_copy, 1, 3) = "if("		/* See if "if" stmnt */
		& ((end_zero = 1 & last_token_type = ident)
						/* if() x = */
		| (end_zero = 2 & last_token_type = right_parn))
						/* if () x() = */
		| (end_zero = 3 & last_token_type = right_parn & COLON_BEFORE_ASSIGN)
						/* if () x () (n:m) = */
		then
		SECOND_EQUALS = TRUE;		/* Probably log if stmnt whose second is assignmnt. */
	     else if keyword_index > parameter_statement	/* obviously not parameter. */
		then
		stmnt_type = assignment_statement_index;
	     else if substr (st_copy, 1, 9) = "parameter" & statement_length > 9 then
		stmnt_type = parameter_statement;
	     else
		stmnt_type = assignment_statement_index;
	end;

	call skip_characters (ONE);
	go to have_token;

/* Case ( */
lexer (8):
	token_type = left_parn;
	paren_level = paren_level + 1;
	call skip_characters (ONE);
	paren_array (paren_level) = last_token + 1;
	go to have_token;

/* Case ) */
lexer (9):
	token_type = right_parn;
	call skip_characters (ONE);

	paren_level = paren_level - 1;
	if paren_level = 0 then
	     end_zero = end_zero + 1;
	go to have_token;

/* Case , */
lexer (10):
	token_type = comma;
	if ASSIGN & paren_level = 0 & substr (st_copy, 1, 2) = "do" then
	     stmnt_type = do_statement;

	call skip_characters (ONE);
	go to have_token;

/* Case / */
lexer (11):
	token_type = slash;
	call skip_characters (ONE);
	if EOS then
	     go to have_token;
	if current_character ^= "/" then
	     go to have_token;
	token_type = concat;
	call skip_characters (ONE);
	go to have_token;

/* Case ' apostrophe */
/* A little diddling added to handle ' strings within formats, but not
   preceeded by an operator, such as ( or ,.  bug 300.  Here detect the
   presence of a 6 character token as first on a line, followed by a
   left_parn, the best we can do other than actually setting a FORMAT flag. */

lexer (12):
	token_type = apostrophe;

	if paren_level = 1 & (last_token_type = right_parn | (last_token_type & is_operand) ^= ZERO)
	     & ^(last_token > 2 & token_list (2).length = 5 & token_list (3).type = left_parn) then do;
						/* apostrophe operator */
	     call skip_characters (ONE);
	     go to have_token;
	end;
	else do;					/* char str constant */
	     call build_string (apostrophe_char);
	     go to store_token_length;
	end;

/* Case " quote */
lexer (13):
	call build_string (quote);
	go to store_token_length;

/* Case * */
lexer (14):
	token_type = asterisk;
	call skip_characters (ONE);
	if EOS then
	     go to have_token;
	if current_character ^= "*" then
	     go to have_token;
	token_type = expon;
	call skip_characters (ONE);
	go to have_token;

/* Case $ */
lexer (15):
	token_type = label_const;
	call skip_characters (ONE);

	if ^EOS & char_type = digits then
	     call get_digits (ignore_value);

	label_args = TRUE;
	go to store_token_length;

/* Case ; */
lexer (16):
	if card_image then
	     go to lexer (0);

	statement_offset, end_text = char_index + 1;	/* unless there is a newline, next stmnt starts here */

/* add one to the statement count for this line. it is reset if a new line is read */

	addr (statement_info) -> statement.statement =
	     bit (binary (binary (addr (statement_info) -> statement.statement, 5, 0) + 1, 5, 0), 5);

	end_possible = FALSE;			/* end line cannot contain a semi-colon */
	call skip_characters (ONE);			/* skip over the semi-colon */
	statement_length = statement_length - 1;	/* to keep format parse happy */

	EOS = TRUE;				/* semi-colon is the end of a statement */
	go to lex_next_token;			/* semi-colon is not stored in token table */

/* Case : */
lexer (17):
	token_type = colon;
	call skip_characters (ONE);
	if ^ASSIGN then
	     COLON_BEFORE_ASSIGN = TRUE;
	go to have_token;

get_continuation_line:
     procedure (a_count);

/*	Program Specifications (get_continuation_line)

     Inputs

     Output

     Description (get_continuation_line)

     NOTE - This procedure modifies:
	char_index
	st_copy
	statement_length
	token_length
	end_possible
*/

dcl      a_count fixed bin (18);
dcl      blank_count fixed bin (18);
dcl      const_max_len fixed bin (18);
dcl      i fixed bin (18);
dcl      len fixed bin (18);
dcl      more_on_this_line bit (1) aligned;


/* This entry point is used to get the next line if no blank suppression is desired. It also appends
	   blanks characters implied by card-image format that were removed as trailing white space.
	   Currently, it is only used if a character-string constant is continued onto a following line. */


	const_max_len = a_count;
	blank_count = min (const_max_len, extra_blanks);	/* number of blanks present and needed on this line */
	blank_cont_count = 0;			/* number of intervening completely blank cont. lines */
	end_possible = FALSE;			/* an endline cannot contain character-string constants */

/* copy character-string constant value into temp buffer */

	len = length (rest_of_line);			/* number of characters from this line */
	if len > 0 then
	     call concatenate_text;			/* must be something to concatenate */

	if blank_count > 0				/* add blanks for original line */
	then do;
	     const_max_len = const_max_len - blank_count;
	     call concatenate_blanks;
	end;

	call get_line_image (FORTRAN_ONLY);		/* Sets: type_of_line,EOS,blank_cont_count,extra_blanks */

	if blank_cont_count > 0			/* If we have skipped over some completely blank
	then if const_max_len > 0			/* continuation lines, add to constant if needed. */
	then do;
	     blank_count = min (const_max_len, blank_cont_count * 66);
	     const_max_len = const_max_len - blank_count;
	     call concatenate_blanks;
	end;

	a_count = const_max_len;
	return;


skip_characters:
     entry (a_count);

/* this entry point is called to skip zero or more characters and then find the next non-white character.
	   It also recognizes end lines as it is the only procedure with sufficient knowledge to make
	   the distinctions necessary */

/* copy characters into temp buffer */

	len = min (a_count, length (rest_of_line));	/* number of characters to cancatenate and skip */
	if len > 0 then
	     call concatenate_text;			/* must be something to concatenate */

/* loop until a non-blank character or the end of the text */

	more_on_this_line = length (rest_of_line) > 0;	/* something left on this line */
	current_character = substr (rest_of_line, 1, 1);

	do while (TRUE);

/* except for first line, always get a new line image */

	     if ^more_on_this_line			/* only on if first line had remaining chars */
	     then do;
		if end_possible then
		     if statement_length = 3 then
			if translate (substr (st_copy, 1, 3), LOWER, UPPER) = "end" then do;
			     EOS = TRUE;
			     stmnt_type = end_line;
			     return;
			end;

		call get_line_image (FORTRAN_ONLY);	/* Sets "type_of_line" & "EOS" */
		if type_of_line = no_more_source then
		     return;
	     end;

	     else
		more_on_this_line = FALSE;		/* only used once per line image, if at all */

	     call get_new_character;			/* determine character type */

	     if EOS | char_type > 0 then
		return;				/* return if it is a Fortran character */

	     i = verify (rest_of_line, WHITE) - 1;	/* is it white space? */

	     if i >= 0				/* at least one non-blank left on this line */
	     then do;				/* skip it */
		if i > 0				/* actually was white space; get new character */
		then do;
		     char_index = char_index + i;	/* skip the white space */
		     current_character = substr (rest_of_line, 1, 1);
						/* new cur char needed */
		end;

		if current_character ^= "!" | card_image/* found a non-blank character, return it */
		then do;
		     if i > 0 then
			call get_new_character;	/* determine character type */
		     return;
		end;
	     end;					/* skipping white space */
	end;

/* should never exit this loop here */


/* Procedure to append extra blank characters implied by a short card-image record. */

concatenate_blanks:
     procedure;

	if statement_length + blank_count > length (st_copy) then do;
	     call print_message (111, length (st_copy) - bias);
						/* text buffer overflow */
	     go to abort_lex;
	end;

	else do;
	     substr (st_copy, statement_length + 1, blank_count) = " ";
	     statement_length = statement_length + blank_count;
	     token_length = token_length + blank_count;
	end;
     end concatenate_blanks;


concatenate_text:
     procedure;

	if statement_length + len > length (st_copy) then do;
	     call print_message (111, length (st_copy) - bias);
						/* text buffer overflow */
	     go to abort_lex;
	end;

	else do;
	     if translate_string			/* user specified folding and token requires it */
	     then do;
		substr (st_copy, statement_length + 1, len) = translate (substr (rest_of_line, 1, len), LOWER, UPPER);
		statement_length = statement_length + len;
						/* included here to keep "shorten_stack" call out of main line */
	     end;
	     else do;
		substr (st_copy, statement_length + 1, len) = substr (rest_of_line, 1, len);
		statement_length = statement_length + len;
	     end;
	     char_index = char_index + len;
	     token_length = token_length + len;
	end;
     end concatenate_text;
     end get_continuation_line;

get_line_image:
     procedure (options_flag);

/*	Program Specifications (get_line_image)

     Inputs
	options_flag indicates what sorts of lines are acceptable:
	     "00"b -- only standard FORTRAN program lines (FORTRAN_ONLY)
	     "01"b -- FORTRAN lines of %options lines (OPTIONS_OK)
	     "11"b -- FORTRAN, %options, %global ok (GLOBAL_OK)

     Output
	options_flag is continuously updated to reflect the fact that %globals must precede %options,
	and that both must precede FORTRAN source statements, including comments.  By the time
	get_line_image returns, options_flag will be set to "00"b (FORTRAN_ONLY)

     Description

     this procedure isolates line images; it should be the only procedure to know about the actual
format of the source text

THERE ARE TWO LEXERS -- CARD IMAGE and FREE FORM

		The following block of code should be the only block of code to differentiate
		lines. For each type of source input three types of lines are defined:

			1. Initial lines
			2. Continuation lines
			3. Comment lines

		In the ansi77 standard, blank lines are treated differently  than they are in
		the 66 standard.  In ansi77 mode, they are comments, whereas in 66 mode they are initial lines.

		Each lex shall define these three line types. Comment lines are useful to the reader of the
		source code and not to the parsers or token lexers.


	CARD IMAGE LEX

		1. A comment line is any line whose first character is either a c, C, or *. This is the first
		      type of line to be checked for.
		2. An initial line is any line whose sixth character is neither a blank nor a zero.
		      Lines with fewer than six characters are initial lines.
		3. If neither of the above are satisfied, the line is a continuation line.

	FREE FORM LEX

		If the source text is required to have line numbers, they are processed and then
		stripped from the line.

		1. A comment line is either: a) a line whose first character is a c or C, or
		   b) a line whose first non blank character is * or !.
		2. A continuation line is a line whose first non blank character is &.
		3. An initial line is any other line. A line containing no text is an initial line.


THERE IS ADDITIONALLY A PSEUDO-LEXER

	which precedes the above, to recognize and process %options and %global statements, if they are
	allowed.  This processing has to be done at this point, since it is the first place at which
	the information necessary to process the statements is readily accessible, and the information
	is needed in this subprogram since it may affect which of the two lexers are to be used.

     NOTE - This procedure modifies:
	char_index
	next_line_index
	EOS
	type_of_line
	subr_options
	segment_options
*/

dcl      ERROR bit (1) aligned int static options (constant) init ("0"b);
dcl      LEGAL_NON_WHITE_SPACE char (66) aligned int static options (constant)
	    init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890()=_");
dcl      RETURN bit (1) aligned int static options (constant) init ("1"b);
dcl      WHITE_AND_DIGITS char (12) aligned int static options (constant) init ("	 0123456789");
						/* ht sp digits */
dcl      depthx fixed bin (17);
dcl      file_string_index fixed bin (17);
dcl      file_string_length fixed bin (17);
dcl      i fixed bin (18);
dcl      include_file_bit_count fixed bin (24);
dcl      include_file_name char (256) varying;
dcl      include_file_ptr pointer;
dcl      just_white_space fixed bin (18) int static options (constant) init (-1);
dcl      line_no fixed dec (6);
dcl      options_flag bit (2) aligned;
dcl      percent_index fixed bin (18);

dcl      last_label_line fixed bin (18) static;		/* source line of last label */

dcl      1 line_no_overlay aligned structure based (addr (line_no)),
	 2 pad char (1) unaligned,
	 2 ln_digits char (6) unaligned;

/* NOTE. use_source_info is ONLY ON IN get_line_image.  This is the peculiarity*/
/* of error message reporting.				         */

	shared_structure.use_source_info = "1"b;
	end_text = next_line_index + 1;		/* stmnt len will not include following comment lines */

	if options_flag then do;
	     if options_flag = GLOBAL_OK then do;
		segment_options = shared_structure.options.user_options;
		unspec (segment_declared) = "0"b;
	     end;
	     else
		subr_options = segment_options;
	     unspec (subr_declared) = "0"b;
	end;

/* loop until a significant character is found */

	type_of_line = just_white_space;
	do while (type_of_line = just_white_space);

/* get the next line image or the end of text */

NEED_NEW_LINE:					/* escape for case where options lexer eats the line. */
	     statement_offset, char_index = next_line_index + 1;

	     if char_index >= source_len		/* no more text */
	     then do;
		call test_orphan_label;
		if file_stack_depth = 0 then do;
		     EOS = TRUE;
		     type_of_line = no_more_source;
		end;

		else do;
		     file_stack_depth = file_stack_depth - 1;
		     seg_ptr = file_stack (file_stack_depth).fs_seg_ptr;
		     source_ptr = file_stack (file_stack_depth).fs_source_ptr;
		     next_line_index = file_stack (file_stack_depth).fs_end_of_line;
		     source_len = file_stack (file_stack_depth).fs_source_length;
		     source_line_number, line_number = file_stack (file_stack_depth).fs_line_number;
		     source_file_number, file_number = file_stack (file_stack_depth).fs_file_number;
		     addr (statement_info) -> statement.file = file_number;
		     go to NEED_NEW_LINE;
		end;

		goto exit_get_line_image;
	     end;

	     number_of_lines = number_of_lines + 1;	/* count lines */

/* now find the end of this line */

	     next_line_index = index (rest_of_text, NL) + char_index - 1;
	     if next_line_index < char_index then
		next_line_index = source_len;
	     end_of_line = next_line_index;		/* line ends with the beginning of the next one */

	     if produce_listing then do;
		source_list (number_of_lines).file_number = file_number;
		source_list (number_of_lines).line_start = statement_offset;
		source_list (number_of_lines).line_length = next_line_index - statement_offset + 1;
		source_list (number_of_lines).line_number_in_file = line_number + 1;
	     end;

/* %(OPTIONS GLOBAL INCLUDE) PSEUDO-LEX */

	     percent_index = verify (rest_of_line, WHITE_AND_DIGITS);

	     if percent_index > 0 then
		if substr (rest_of_line, percent_index, 1) = "%" then
		     call test_orphan_label;
	     if percent_index > 0 then
		if substr (rest_of_line, percent_index, 1) = "%" then
		     if translate (substr (rest_of_line, percent_index, 8), LOWER, UPPER) = "%include" then do;

			source_line_number, line_number = line_number + 1;
			char_index = char_index + percent_index + 7;

			if length (rest_of_line) <= 0 then do;
			     call print_message (160);
			     go to NEED_NEW_LINE;
			end;

			file_string_index = verify (rest_of_line, WHITE);
			char_index = char_index + file_string_index - 1;
			if length (rest_of_line) <= 0 then do;
			     call print_message (160);
			     go to NEED_NEW_LINE;
			end;

			file_string_length = search (rest_of_line, WHITE) - 1;

			if file_string_length <= 0 then
			     file_string_length = length (rest_of_line);
			if file_string_length >= 244 then do;
			     call print_message (161, substr (rest_of_line, 1, file_string_length));
			     go to NEED_NEW_LINE;
			end;

			include_file_name = substr (rest_of_line, 1, file_string_length) || ".incl.fortran";

			call find_include_file_$initiate_count (command, source_ptr, (include_file_name),
			     include_file_bit_count, include_file_ptr, code);
			if include_file_ptr = null	/* file not found */
			then do;
			     call print_message (162, include_file_name);
			     if code ^= 0 & code ^= error_table_$noentry then
				call com_err_ (code, command, "^a", include_file_name);
			     go to NEED_NEW_LINE;
			end;


			if shared_structure.incl_count > 255 then do;
			     call hcs_$terminate_noname (include_file_ptr, code);
			     call print_message (163, include_file_name);
			     go to NEED_NEW_LINE;
			end;

			if file_stack_depth > hbound (file_stack, 1) then do;
			     call hcs_$terminate_noname (include_file_ptr, code);
			     call print_message (164, include_file_name);
			     go to NEED_NEW_LINE;
			end;

			file_stack (file_stack_depth).fs_seg_ptr = seg_ptr;
			file_stack (file_stack_depth).fs_source_ptr = source_ptr;
			file_stack (file_stack_depth).fs_end_of_line = end_of_line;
			file_stack (file_stack_depth).fs_source_length = source_len;
			file_stack (file_stack_depth).fs_line_number = line_number;
			file_stack (file_stack_depth).fs_file_number =
			     binary (addr (statement_info) -> statement.file, 8, 0);

			do depthx = lbound (file_stack, 1) to file_stack_depth;
			     if file_stack (depthx).fs_source_ptr = include_file_ptr then do;
				call hcs_$terminate_noname (include_file_ptr, code);
				call print_message (165, include_file_name);
				go to NEED_NEW_LINE;
			     end;
			end;

			file_stack_depth = file_stack_depth + 1;
			shared_structure.incl_count = shared_structure.incl_count + 1;

			call translator_info_$component_get_source_info (include_file_ptr, dname, ename, cname, dtm,
			     uid, code);
			if code ^= 0 then do;
			     if code = error_table_$no_s_permission then
				call print_message (188, include_file_name);
			     else
				call com_err_ (code, command, "^a", include_file_name);
			     cname = "";
			     if substr (include_file_name, 1, 1) ^= ">" then do;
				dname = "UNKNOWN DIRECTORY NAME";
				ename = include_file_name;
			     end;
			     else do;
				ename = reverse (before (reverse (include_file_name), ">"));
				dname = before (include_file_name || " ", ">" || rtrim (ename) || " ");
			     end;
			     uid = ""b;
			     dtm = 0;
			end;

			number_of_source_segments = number_of_source_segments + 1;
			i = 63 - divide (length (ename) + length (dname), chars_per_word, 17, 0);

			indx = create_node (source_node, size (source) - i);
			seg_chain_end_ptr -> source.next = indx;
			cur_segment = indx;
			seg_chain_end_ptr, seg_ptr = addr (OS (cur_segment));

			if cname = "" then
			     seg_ptr -> source.pathname = rtrim (dname) || ">" || rtrim (ename);
			else
			     seg_ptr -> source.pathname =
				rtrim (dname) || ">" || before (ename, ".archive") || "::" || rtrim (cname);
			seg_ptr -> source.uid = uid;
			seg_ptr -> source.dtm = dtm;
			seg_ptr -> source.line_number = number_of_lines;

			source_ptr = include_file_ptr;
			char_index = 0;
			source_len = divide (include_file_bit_count + 8, 9, 21, 0);
			source_line_number, line_number = 0;
			source_file_number, file_number = shared_structure.incl_count;
			addr (statement_info) -> statement.file = file_number;
			next_line_index = -1;

			shared_structure.source_node_offset (shared_structure.incl_count) = cur_segment;
			shared_structure.incl_len (shared_structure.incl_count) = source_len;
			shared_structure.incl_ptr (shared_structure.incl_count) = source_ptr;

			go to NEED_NEW_LINE;
		     end;

		     else if options_flag then
			if translate (substr (rest_of_line, percent_index, 7), LOWER, UPPER) = "%global" then do;
			     source_line_number, line_number = line_number + 1;
			     if options_flag = GLOBAL_OK then
				call lex_global;
			     else
				call print_message (193);
			     go to NEED_NEW_LINE;
			end;

			else if translate (substr (rest_of_line, percent_index, 8), LOWER, UPPER) = "%options"
			then do;
			     if options_flag = GLOBAL_OK then do;
				options_flag = OPTIONS_OK;
				call fort_defaults_$check_global_args (addr (segment_declared),
				     addr (shared_structure.declared_options), print_message);
						/* check for any conflicts between arguments and %globals */
				unspec (segment_declared) =
				     unspec (segment_declared) | unspec (shared_structure.declared_options);
				call fort_defaults_$set (addr (segment_declared), addr (segment_options));
				shared_structure.options.user_options = segment_options;
				call set_max_array_size;
				subr_options = segment_options;
				shared_structure.declared_options = segment_declared;
				call fort_defaults_$init_shared_vars (addr (shared_structure));
			     end;
			     source_line_number, line_number = line_number + 1;
			     call lex_options;
			     go to NEED_NEW_LINE;
			end;

	     if options_flag ^= FORTRAN_ONLY then do;
		if options_flag = GLOBAL_OK then do;
		     call fort_defaults_$check_global_args (addr (segment_declared),
			addr (shared_structure.declared_options), print_message);
						/* check for any conflicts between arguments and %globals */
		     unspec (segment_declared) =
			unspec (segment_declared) | unspec (shared_structure.declared_options);
		     call fort_defaults_$set (addr (segment_declared), addr (segment_options));
		     shared_structure.options.user_options = segment_options;
		     call set_max_array_size;
		     subr_options = segment_options;
		     shared_structure.declared_options = segment_declared;
		     call fort_defaults_$init_shared_vars (addr (shared_structure));
		end;
		card_image = subr_options.card;
		fold_option = subr_options.fold;
		if subr_options.ansi_77 then
		     default_char_size = 1;
		else
		     default_char_size = 8;
	     end;

/* CARD IMAGE LEX */

	     if card_image then do;
		source_line_number, line_number = line_number + 1;
						/* use sequence number as the line number */

		if length (rest_of_line) <= 0 then
		     EOS = ^subr_options.ansi_77;
		else do;
		     if length (rest_of_line) > 72	/* only use 72 columns per card */
		     then do;
			if length (rest_of_line) > 80 /* warn user of a long card image */
			     then
			     call print_message (132);

			end_of_line = char_index + 72;
		     end;

		     if substr (rest_of_line, 1, 1) ^= "c" & substr (rest_of_line, 1, 1) ^= "C"
			& substr (rest_of_line, 1, 1) ^= "*" then
			if length (rest_of_line) < 6	/* column 6 is blank, an initial line */
			then do;
			     EOS = ^subr_options.ansi_77;
			     if rest_of_line ^= ""	/* Initial line */
				then
				EOS = TRUE;
			     call lex_label_field (length (rest_of_line), ERROR);
			end;
			else if substr (rest_of_line, 6, 1) ^= " " & substr (rest_of_line, 6, 1) ^= "0" then
			     if length (rest_of_line) > 6
						/* a non blank continuation line */
			     then do;
				char_index = char_index + 6;
				extra_blanks = max (0, 66 - length (rest_of_line));
				end_possible = FALSE;
						/* cont line cannot be end line */
				type_of_line = continuation_line;
			     end;

/* blank continuation line -- treat as comment line */

			     else
				blank_cont_count = blank_cont_count + 1;

			else do;			/* possibly an initial line */
			     EOS = (substr (rest_of_line, 6, 1) = "0" | ^subr_options.ansi_77);
			     if rest_of_line ^= " "	/* Determine if comment */
				then
				EOS = TRUE;
			     call lex_label_field (5, ERROR);
			     char_index = char_index + 1;
						/* skip continuation field */

/* find first non blank char on this line or get another line */

			     if length (rest_of_line) > 0 then do;
				i = verify (rest_of_line, WHITE) - 1;
				if i >= 0		/* non blank found */
				then do;
				     EOS = TRUE;
				     extra_blanks = max (0, 66 - length (rest_of_line));
				     char_index = char_index + i;
				     end_possible = TRUE;
						/* init line can be end line */
				     type_of_line = initial_line;
				end;
			     end;
			end;
		end;				/* non blank lines */
	     end;					/* CARD IMAGE LEX */


/* FREE FORM LEX */

	     else do;

		if line_numbered_text		/* for line numbered text, lex a line number */
		then do;
		     i = verify (rest_of_line, DIGIT) - 1;
						/* count digits in line number */
		     if i < 0 then
			i = length (rest_of_line);	/* entire line is digits (or length(line) = 0) */

		     if i = 0 then
			call print_message (113, rest_of_line);
						/* missing line number */

		     else do;			/* process line number field */
			if i - length (ln_digits) > 0 /* limit length of line number */
			then do;
			     call print_message (114, substr (rest_of_line, 1, i));
						/* line number too long */
			     char_index = char_index + (i - length (ln_digits));
						/* skip excess digits */
			     i = length (ln_digits);
			end;

			line_no = 0;		/* convert line number to binary */
			substr (ln_digits, length (ln_digits) - i + 1, i) = substr (rest_of_line, 1, i);

			char_index = char_index + i;	/* skip line number field */

			if line_no <= line_number	/* sequence check the line number */
			     then
			     call print_message (115, ln_digits, char (decimal (line_number, 12)));
						/* out of sequence */

			source_line_number, line_number = line_no;
						/* set current line number */
		     end;				/* processing existing line number */
		end;				/* lex for line numbers */

		else
		     source_line_number, line_number = line_number + 1;
						/* no line numbers, use sequence number */

		if length (rest_of_line) <= 0 then
		     EOS = ^subr_options.ansi_77;
		else if substr (rest_of_line, 1, 1) ^= "c" & substr (rest_of_line, 1, 1) ^= "C" then do;

		     i = verify (rest_of_line, WHITE) - 1;
		     if i < 0 then
			EOS = ^subr_options.ansi_77;
		     else do;			/* a line with text */
			char_index = char_index + i;
			current_character = substr (rest_of_line, 1, 1);

			if current_character ^= "*" & current_character ^= "!" then
			     if current_character = "&" then do;
						/* continuation line */
				char_index = char_index + 1;
						/* skip "&" */
				if length (rest_of_line) > 0 then do;
				     end_possible = FALSE;
						/* cont line cannot be end line */
				     type_of_line = continuation_line;
				end;
			     end;
			     else do;		/* initial line */
				call test_orphan_label;
				call get_new_character;
						/* Sets "char_type" */

				if char_type = digits
						/* lex label field if it exists */
				     then
				     call lex_label_field (length (rest_of_line), RETURN);

				if length (rest_of_line) > 0 then do;
				     end_possible = TRUE;
						/* init line can be end line */
				     type_of_line = initial_line;
				end;
				EOS = TRUE;
			     end;			/* initial line */
		     end;				/* non blank line */
		end;				/* non comment line */

		else do;				/* Quick cheap check to catch some unintended comments */
		     if index (LEGAL_NON_WHITE_SPACE, substr (rest_of_line, 2, 1)) ^= 0 then do;
			line_number_pic = line_number;
			file_number_pic = -file_number;
			call print_message (148, file_number_pic, line_number_pic);
		     end;
		end;
	     end;					/* FREE FORM LEX */

	end;					/* loop to get significant character */

	if options_flag ^= FORTRAN_ONLY then
	     options_flag = FORTRAN_ONLY;

	addr (statement_info) -> statement.statement = "00001"b;
						/* reset statement count for line */

	current_character = substr (rest_of_line, 1, 1);	/* return character just found */
exit_get_line_image:
	shared_structure.use_source_info = "0"b;	/* TURN OFF SOURCE LINE NUMBERS */
	return;

lex_global:
     procedure;

dcl      option char (32);

	char_index = char_index + percent_index + 7;

	call get_next_option (option);

	do while (option ^= "");

	     call fort_defaults_$global (addr (option), length (option), addr (segment_declared), print_message);

	     call get_next_option (option);

	end;

	return;
     end lex_global;

lex_options:
     procedure;

dcl      option char (32);

	char_index = char_index + percent_index + 8;

	call get_next_option (option);

	do while (option ^= "");

	     call fort_defaults_$option (addr (option), length (option), addr (subr_options), addr (subr_declared),
		addr (segment_options), have_auto_option, have_static_option, print_message);

	     call get_next_option (option);

	end;

	return;
     end lex_options;

get_next_option:
     procedure (option);

dcl      i fixed bin (18);
dcl      option char (32);
dcl      OPTION_DELIMS char (4) static int options (constant) init ("	 ,;");
						/* tab, space, comma, semi */
dcl      OPTION_SKIP char (3) static int options (constant) init ("	 ,");
						/* tab, space, comma */

	i = verify (rest_of_line, OPTION_SKIP) - 1;
	if i < 0 then do;
	     option = "";
	     char_index = char_index + length (rest_of_line);
	     return;
	end;

	else do;
	     char_index = char_index + i;

	     if substr (rest_of_line, 1, 1) = ";" then do;
		option = "";
		char_index = char_index + length (rest_of_line);
		return;
	     end;

	     i = search (rest_of_line, OPTION_DELIMS) - 1;
	     if i < 0 then
		i = length (rest_of_line);

	     if i = 0 then
		option = "";

	     else do;
		if substr (rest_of_line, i, 1) = ";" then
		     i = i - 1;
		option = translate (substr (rest_of_line, 1, min (i, 32)), LOWER, UPPER);
		char_index = char_index + i;
	     end;

	end;

	return;
     end get_next_option;


lex_label_field:
     procedure (width, action_on_non_numeric);

dcl      action_on_non_numeric bit (1) aligned;
dcl      digit fixed bin (18);
dcl      loop_index fixed bin (18);
dcl      numeric bit (1) aligned;
dcl      width fixed bin (18);

	call test_orphan_label;			/* ensure no label outstanding */
	numeric = FALSE;				/* no digits encountered */

	do loop_index = 1 to width;
	     digit = binary (unspec (substr (rest_of_line, 1, 1)), 9, 0);
	     if digit > hbound (token_table, 1) then
		char_type = 0;
	     else
		char_type = token_table (digit);

	     if char_type = digits then do;
		next_statement_label = next_statement_label * 10 + digit - 000110000b;
		numeric = TRUE;
	     end;

	     else if char_type ^= just_white_space then do;
		if action_on_non_numeric = ERROR then do;
		     call print_message (133);
		     char_index = char_index + (width - loop_index + 1);
		end;

		if numeric & next_statement_label = 0 then
		     call print_message (69, "0");
		return;
	     end;

	     char_index = char_index + 1;
	end;

	if numeric then
	     if next_statement_label = 0 then
		call print_message (69, "0");
	     else
		last_label_line = source_line_number;
     end lex_label_field;

test_orphan_label:
     proc;

/* Declare error if there is an orphan statement label */

/* see if there is a left over statement label */
/* code moved from "get_line_image to prevent navy bug #1 */

	if next_statement_label ^= 0 then do;
	     source_line_number = last_label_line;
	     call print_message (131);		/* label without text */
	     source_line_number = line_number;
	     next_statement_label = 0;
	end;
     end test_orphan_label;
     end get_line_image;


get_new_character:
     procedure;

	char_value = current_character;		/* do not want current_character to have an alias */
	if binary (bit_value, 9, 0) > hbound (token_table, 1)
						/* non ASCII character */
	     then
	     char_type = 0;
	else
	     char_type = token_table (binary (bit_value, 9, 0));
     end get_new_character;

get_digits:
     procedure (digit_count);

/*	Program Specifications (get_digits)

     Inputs

     Output

     Description (get_digits)

     NOTE - This procedure modifies:
	EOS
	text_bit
*/

dcl      i fixed bin (18);
dcl      d_count fixed bin (18);
dcl      digit_count fixed bin (18);

	d_count = 0;

	lexing_a_token = TRUE;
	do while (lexing_a_token);
	     i = verify (rest_of_line, DIGIT) - 1;
	     if i = 0 then
		lexing_a_token = FALSE;
	     else do;
		if i < 0 then
		     i = length (rest_of_line);
		call skip_characters (i);
		d_count = d_count + i;
		if EOS then
		     lexing_a_token = FALSE;
		else if char_type ^= digits then
		     lexing_a_token = FALSE;
	     end;
	end;

	digit_count = d_count;
     end get_digits;

build_fortran_operator:
     procedure;

/*	Program Specifications (build_fortran_operator)

     Inputs

     Output

     Description (build_fortran_operator)
*/

dcl      i fixed bin (18);
dcl      sp_op_name (13) char (8) aligned int static options (constant)
	    init (".not.", ".and.", ".or.", ".eq.", ".ne.", ".lt.", ".gt.", ".le.", ".ge.", ".false.", ".true.",
	    ".eqv.", ".neqv.");
dcl      sp_op_type (13) bit (9) aligned int static options (constant)
	    init ("010000110"b, "010000111"b, "010001000"b, "010001001"b, "010001010"b, "010001011"b, "010001100"b,
	    "010001101"b, "010001110"b, "001000010"b, "001000011"b, "010010111"b, "010011000"b);

	lexing_a_token = TRUE;
	do while (lexing_a_token);
	     i = verify (rest_of_line, alphabetic) - 1;
	     if i = 0 then
		lexing_a_token = FALSE;
	     else do;
		if i < 0 then
		     i = length (rest_of_line);
		call skip_characters (i);
		if EOS then
		     lexing_a_token = FALSE;
		else if char_type ^= letters then
		     lexing_a_token = FALSE;
	     end;
	end;

	if EOS then do;
	     call print_message (116);		/* missing "." */
	     go to lex_next_token;
	end;

	if current_character ^= "." then do;
	     call print_message (116);		/* missing "." */
	     go to lex_next_token;
	end;

	call skip_characters (ONE);

	if token_length > length (sp_op_name (1)) then do;
	     call print_message (117, token_string);	/* unknown operator */
	     go to lex_next_token;
	end;

	substr (fast_lookup, 1, length (sp_op_name (1))) = token_string;

	do i = 1 to hbound (sp_op_name, 1) while (substr (fast_lookup, 1, length (sp_op_name (1))) ^= sp_op_name (i));
	end;

	if i > hbound (sp_op_name, 1) then do;
	     call print_message (117, token_string);	/* unknown operator */
	     go to lex_next_token;
	end;

	token_type = sp_op_type (i);
     end build_fortran_operator;

parse_exponent:
     procedure;

/*	Program Specifications (parse_exponent)

     Inputs

     Output

     Description (parse_exponent)
*/

	exp = 0;
	if EOS then do;
	     if token_type ^= dec_int then
		call store_real_constant;
	     return;
	end;
	if current_character = "d" | current_character = "D" then
	     token_type = double_const;
	else if current_character = "e" | current_character = "E" then
	     token_type = real_const;
	else if token_type = dec_int then
	     return;
	else do;
	     if t_scale > 0 | char_type ^= letters then
		call store_real_constant;
	     return;
	end;
	call skip_characters (ONE);

	if EOS then do;
	     call missing_exponent;
	     return;
	end;

	exp = token_length;

	if current_character = "+" then do;
	     operator_follows = FALSE;
	     translate_string = FALSE;		/* translation is no longer necessary */

	     call skip_characters (ONE);
	     exp = exp + 1;
	end;
	else if current_character = "-" then do;
	     operator_follows = FALSE;
	     translate_string = FALSE;		/* translation is no longer necessary */

	     call skip_characters (ONE);
	     exp = -token_length;
	end;

	if EOS then do;
	     call missing_exponent;
	     return;
	end;

	if char_type = digits then do;
	     call get_digits (ignore_value);
	     call store_real_constant;
	end;
	else if ^operator_follows then
	     call missing_exponent;

	return;


store_real_constant:
     procedure;

	operator_follows = FALSE;
	translate_string = FALSE;			/* translation is no longer necessary */

	const_count = const_count + 1;
	if const_count > hbound (constant_array, 1)	/* check for constant table overflow */
	then do;
	     if const_count = hbound (constant_array, 1) + 1
						/* only print message once */
		then
		call print_message (110, hbound (constant_array, 1) - bias);
	     go to lex_next_token;
	end;

	constant_array (const_count).prec = precision;
	constant_array (const_count).scale = t_scale;
	constant_array (const_count).exponent = exp;
	constant_array (const_count).length = token_length - 1;
	token_length = const_count;
     end store_real_constant;


missing_exponent:
     procedure;

	call print_message (118);
	exp = 0;
	call store_real_constant;
     end missing_exponent;
     end parse_exponent;

build_string:
     procedure (delimiter);

/*	Program Specifications (build_string)

     Inputs

     Output

     Description (build_string)
	Modified 01/28/77 to allow embedded delimiters in char strings.
*/

dcl      embedded bit (1) aligned;
dcl      delimiter char (1) aligned;
dcl      len fixed bin (18);
dcl      len_pic picture "zz9";
dcl      off fixed bin (18);
dcl      temp_str char (512);

	token_offset = statement_length + 1;
	token_length = -1;
	token_type = char_string;

	off = 1;					/* skip over initial delimiter */
	embedded = FALSE;				/* no embedded delimiters found */

	do while (TRUE);

	     len = index (substr (rest_of_line, off + 1), delimiter) + off;

	     if len = off				/* delimiter not found, add rest of line */
	     then do;
		call get_continuation_line ((max_fixed_bin_18));
						/* get next line */

		if EOS				/* oops, no more lines for us */
		then do;
		     call print_message (109);
		     call get_new_character;		/* prime the lex */
		     go to return_string;
		end;

		off = 0;				/* begin with first character */
	     end;

	     else do;				/* see if encountered delimiter terminates the string */
		if len = length (rest_of_line) then do; /* following char is on next line */

		     if extra_blanks > 0 then
			go to final_delimiter;	/* last char followed by blank, must be delim */

		     call get_continuation_line (0);	/* no blanks follow, so get next line */

		     if blank_cont_count > 0		/* line of blanks follow, so must be delim */
		     then do;
			len = 0;			/* Characters have already been skipped */
			go to final_delimiter;
		     end;

		     if EOS then do;
			token_length = token_length - 1;
						/* length does not include the delimiters */
			call get_new_character;	/* prime the lex */
			go to return_string;
		     end;

		     off, len = 0;			/* want the first char on the line */
		end;

		if substr (rest_of_line, len + 1, 1) ^= delimiter then do;
						/* the final delimiter, done */
final_delimiter:
		     call skip_characters (len);

		     token_length = token_length - 1;	/* length does not include the delimiters */
		     go to return_string;
		end;

		embedded = TRUE;			/* an embedded delimiter; remove one from the const */
		call skip_characters (len);		/* next char is obviously non-blank */

		token_length = token_length - 1;	/* remove first delimiter of the pair from */
		statement_length = statement_length - 1;/* from the constant's value */

		off = 1;				/* continue processing with second delimiter */
	     end;
	end;

/* loop cannot exit here */

return_string:
	if token_length = 0 then
	     call print_message (108);		/* string length is zero */
	else if embedded				/* for format statements, strings with embedded */
	     then
	     if substr (st_copy, 1, 6) = "format"	/* delimiters must be converted to hollerith consts */
	     then do;
		if token_length > 512		/* string is too long */
		then do;
		     call print_message (124, 512 - bias);
						/* token length too long */
		     token_length = 512;
		end;

		substr (temp_str, 1, token_length) = token_string;
						/* save str value */

		statement_length = token_offset - 1;	/* remove original string from buffer */

		len_pic = token_length;		/* build length field for hollerith const */
		off = verify (len_pic, WHITE);	/* first significant char */
		len = length (len_pic) - off + 1;	/* number of digits */

		if statement_length + len + 1 + token_length > length (st_copy)
						/* will it fit? */
		then do;
		     call print_message (111, length (st_copy) - bias);
						/* text buffer overflow */
		     go to abort_lex;
		end;

		substr (st_copy, statement_length + 1, len) = substr (len_pic, off, len);
		statement_length = statement_length + len + 1;
		substr (st_copy, statement_length, 1) = "h";

		token_offset = statement_length;	/* new offset */

		token_string = substr (temp_str, 1, token_length);
						/* move value back */
		statement_length = statement_length + token_length;
	     end;
     end build_string;
     end statement_lex;

convert_integer_constant:
     procedure (off, len) returns (bit (72) aligned);

/*	Program Specifications (convert_integer_constant)

     Inputs
	Arguments
	     off - Offset into the character string "st_copy" at which the character representation
		 of the value to be converted is stored.
	     len - Length of the string to be converted.

	Implicit Arguments
	     sign - (Declared in the procedure parse_source.) This variable is used to simulate
		a condition handler for fixedoverflow in order to allow the conversion of the
		value -34359738368.  If "sign" has the value "minus", the conversion succeeds;
		otherwise the conversion fails. If "sign" is used to create a negative value,
		the procedure sets the value of "sign" to "ZERO" to prevent another negation.

     Output
	A 36-bit binary representation of the constant stored left justified in a 72-bit field.
	The remaining bits are undefined.
*/

dcl      based_dec char (12) aligned based (addr (dec_value));
dcl      dec_value fixed decimal (11);
dcl      i fixed bin (18);
dcl      int_bits bit (72) aligned;
dcl      j fixed bin (18);
dcl      max_value fixed decimal (11) int static options (constant) init (34359738368);
dcl      len fixed bin (18);
dcl      off fixed bin (18);

	j = off + verify (substr (st_copy, off + 1, len), "0") - 1;
	if j < off then
	     return (b72_zero);
	i = len - (j - off);

	if i >= length (based_dec) then do;
	     call print_message (119, substr (st_copy, off + 1, len));
						/* fixed overflow */
	     return (b72_zero);
	end;

	dec_value = 0;
	substr (based_dec, length (based_dec) - i + 1, i) = substr (st_copy, j + 1, i);

	if dec_value >= max_value			/* i.e., fixedoverflow will occur. */
	     then
	     if (dec_value = max_value) & (sign = minus) then do;
		sign = ZERO;
		return (b72_one);
	     end;
	     else do;
		call print_message (119, substr (st_copy, off + 1, len));
						/* fixed overflow */
		return (b72_zero);
	     end;

	addr (int_bits) -> based_integer = dec_value;
	return (int_bits);
     end convert_integer_constant;

negate_constant:
     procedure (in_const) returns (fixed bin (18));

dcl      in_const fixed bin (18);

	go to negate_code (addr (OS (in_const)) -> constant.data_type);

negate_code (1):					/* integer */
	if addr (work) -> based_integer = -34359738368 then do;
	     call print_message (137, in_const);
	     return (in_const);
	end;
	else do;
	     addr (work) -> based_integer = -addr (work) -> based_integer;
	     return (create_constant (int_mode, work));
	end;

negate_code (2):					/* real */
	unspec (addr (work) -> based_real (1)) =
	     negate_round (real_mode) (6, (unspec (addr (work) -> based_real (1))), "0"b, 0);
	return (create_constant (real_mode, work));

negate_code (3):					/* double precision */
	unspec (addr (work) -> based_double) =
	     negate_round (dp_mode) (6, (unspec (addr (work) -> based_double)), "0"b, 0);
	return (create_constant (dp_mode, work));

negate_code (4):					/* complex */
	unspec (addr (work) -> based_real (1)) =
	     negate_round (real_mode) (6, (unspec (addr (work) -> based_real (1))), "0"b, 0);
	unspec (addr (work) -> based_real (2)) =
	     negate_round (real_mode) (6, (unspec (addr (work) -> based_real (2))), "0"b, 0);
	return (create_constant (cmpx_mode, work));
     end negate_constant;

convert_real_constant:
     procedure (offset) returns (bit (72) aligned);

dcl      dec_exp fixed dec (3);
dcl      mantissa fixed dec (30) based (addr (ext_float_dec));
dcl      exp fixed bin (18);
dcl      indx fixed bin (18);
dcl      l_significant_digits fixed bin (18);
dcl      ldigits fixed bin (18);
dcl      ldigits_parm fixed bin (18);
dcl      lsd_parm fixed bin (18);
dcl      offset fixed bin (18);
dcl      r_significant_digits fixed bin (18);
dcl      rdigits fixed bin (18);
dcl      rdigits_parm fixed bin (18);
dcl      rsd_parm fixed bin (18);
dcl      real_bits bit (72) aligned;

dcl      1 ext_float_dec aligned,
	 2 sign char (1) unaligned,
	 2 digits char (30) unaligned,
	 2 expnt fixed bin (8) unaligned;

	rdigits = constant_array (offset).scale;
	ldigits = constant_array (offset).prec - rdigits;

	if ldigits > 0 then
	     l_significant_digits = length (ltrim (substr (token_string, 1, ldigits), "0"));
	else
	     l_significant_digits = 0;
	if rdigits > 0 then
	     r_significant_digits = length (rtrim (substr (token_string, ldigits + 2, rdigits), "0"));
	else
	     r_significant_digits = 0;		/* trim off the extraneous zeros */
	goto convert_constant;

convert_real_constant_from_real:
     entry (offset, rdigits_parm, ldigits_parm, rsd_parm, lsd_parm) returns (bit (72) aligned);

	rdigits = rdigits_parm;
	ldigits = ldigits_parm;
	r_significant_digits = rsd_parm;
	l_significant_digits = lsd_parm;

convert_constant:
	exp = constant_array (offset).exponent;
	mantissa = 0;
	if l_significant_digits + r_significant_digits > length (digits) then do;
	     call print_message (120, length (digits) - bias, token_string);
						/* constant too long */
	     return (b72_one);
	end;

	if l_significant_digits > 0 & ldigits > 0 then
	     substr (digits, 1, l_significant_digits) = ltrim (substr (token_string, 1, ldigits), "0");
	if r_significant_digits > 0 & rdigits > 0 then
	     substr (digits, l_significant_digits + 1, r_significant_digits) =
		rtrim (substr (token_string, ldigits + 2, rdigits), "0");

	if exp ^= 0 then do;
	     dec_exp = 0;
	     if exp < 0 then do;
		exp = -exp;
		substr (addr (dec_exp) -> based_char, 1, 1) = "-";
	     end;

	     indx = token_length - exp;
	     if indx > 3 then do;
		call print_message (121, token_string); /* exponent too large */
		return (b72_one);
	     end;

	     substr (addr (dec_exp) -> based_char, 5 - indx, indx) = substr (token_string, exp + 1, indx);
	     exp = dec_exp;
	end;

	exp = exp + l_significant_digits - length (digits);

	if mantissa = 0 then
	     return (b72_one);

	if exp > 255 then
	     call print_message (121, token_string);
	else if exp < -256 then
	     call print_message (122, token_string);
	else do;
	     expnt = exp;

/*THE NEXT FLOAT DEC CONSTANTS YOU SEE ARE THE LARGEST AND SMALLEST CONVERTIBLE FLOATING POINT DECIMAL MANTISSA'S */
	     if shared_structure.user_options.hfp then do;
		if (mantissa > 837987995621412318632521721850 & expnt = 123) | (expnt > 123) then
		     call print_message (121, token_string);
		else if (mantissa < 745834073120020674248233039307 & expnt = -184) | (expnt < -184) then
		     call print_message (122, token_string);
		else do;
		     call assign_ (addr (real_bits), 2 * ft_hex_double_dtype, 63, addr (ext_float_dec),
			2 * real_flt_dec_extended_dtype, 30);
		     return (real_bits);
		end;
	     end;
	     else do;
		if (mantissa > 170141183460469231713240559642 & expnt = 9) | (expnt > 9) then
		     call print_message (121, token_string);
		else if (mantissa < 146936793852785938496092067153 & expnt = -68) | (expnt < -68) then
		     call print_message (122, token_string);
		else do;
		     call assign_ (addr (real_bits), 2 * ft_double_dtype, 63, addr (ext_float_dec),
			2 * real_flt_dec_extended_dtype, 30);
		     return (real_bits);
		end;
	     end;
	end;
	return (b72_one);
     end convert_real_constant;

get_next_token:
     procedure (action, sym_index);

/*	Program Specifications (get_next_token)

     Inputs

     Output

     Description (get_next_token)
	current_token
	token
	token_offset
	token_length
*/

dcl      action fixed bin (2);
dcl      l_significant_digits fixed bin (18);
dcl      ldigits fixed bin (18);
dcl      paren_level fixed bin (18);
dcl      r_significant_digits fixed bin (18);
dcl      rdigits fixed bin (18);
dcl      sym_index fixed bin (18);
dcl      symtab_action fixed bin (2);
dcl      temp fixed bin (18);

	current_token = current_token + 1;

	named_constant_ptr_valid = FALSE;
	token = token_list (current_token).type;

	if token = ident then do;
	     token_offset = token_list (current_token).offset;
	     token_length = token_list (current_token).length + 1;
	     symbol_length = token_length;
	     substr (full_name, 1, symbol_length) = token_string;

	     symtab_action = action;
	     if symtab_action = ignore_symtab_entry then
		return;

	     call find_symbol_index (symbol_length, temp, symtab_action, ignore_value);

	     if temp ^= 0 then
		if addr (OS (temp)) -> symbol.named_constant then do;
		     named_constant_ptr = addr (OS (temp));
		     named_constant_ptr_valid = TRUE;
		     temp = addr (OS (temp)) -> symbol.initial;
		     token = constant_type (addr (OS (temp)) -> constant.data_type);

		     if token ^= char_string then
			work = addr (OS (temp)) -> constant.value;
		end;
	     sym_index = temp;
	end;

	else if token & is_constant then do;
	     token_offset = token_list (current_token).offset;
	     token_length = token_list (current_token).length + 1;

	     go to convert (binary (substr (token, 5, 5), 5, 0));
						/* actually case of token_type */
	end;
	return;


get_next_token$operator:
     entry;

	current_token = current_token + 1;
	token = token_list (current_token).type;
	return;


get_next_token$paren_operator:
     entry;

	current_token = current_token + 1;
	token = token_list (current_token).type;
	if token = left_parn then do;
	     paren_level = 1;
	     do temp = current_token + 1 to last_token while (paren_level > 0);
		if token_list (temp).type = left_parn then
		     paren_level = paren_level + 1;
		else if token_list (temp).type = right_parn then
		     paren_level = paren_level - 1;
		else if paren_level = 1 & token_list (temp).type = colon then do;
		     token = substr_left_parn;
		     return;
		end;
	     end;					/* token search loop */
	end;					/* left parenthesis case */
	return;


get_next_token$label:
     entry (action, sym_index);

	current_token = current_token + 1;
	token = token_list (current_token).type;

	if token = dec_int then do;
	     token_offset = token_list (current_token).offset;
	     token_length = token_list (current_token).length + 1;

	     work = convert_integer_constant (token_offset, token_length);
	     return;
	end;

	else if token & is_operator then
	     return;

	else if token = ident then do;
	     token_offset = token_list (current_token).offset;
	     token_length = token_list (current_token).length + 1;
	     symbol_length = token_length;
	     substr (full_name, 1, symbol_length) = token_string;

	     call find_symbol_index (symbol_length, temp, force_symtab_entry, ignore_value);

	     if addr (OS (temp)) -> symbol.named_constant /* named const cannot be label value */
		then
		call print_message (142, substr (full_name, 1, symbol_length));

	     sym_index = temp;
	     return;
	end;

	else if token = char_string then do;
	     token_offset = token_list (current_token).offset;
	     token_length = token_list (current_token).length + 1;
	     sym_index = create_char_constant (token_string);
	     return;
	end;

	go to missing_label;


/* Case		Character String */
convert (1):
	sym_index = create_char_constant (token_string);
	return;

/* Case		False */
convert (2):
	token = logical_const;
	work = FALSE;
	sym_index = create_constant (logical_mode, work);
	return;

/* Case		True */
convert (3):
	token = logical_const;
	work = TRUE;
	sym_index = create_constant (logical_mode, work);
	return;

/* Case		Label */
convert (4):
	if token_length > 1 then
	     work = convert_integer_constant (token_offset + 1, token_length - 1);
	else
	     addr (work) -> based_integer = 0;

	sym_index = enter_label (executable_label, (addr (work) -> based_integer), GOTO_REF);
	return;

/* Case		Octal */
convert (5):
	call print_message (229);			/* constant type not implemented */
	return;

/* Case		Integer */
convert (6):
	work = convert_integer_constant (token_offset, token_length);
	sym_index = create_constant (int_mode, work);
	return;

/* Case		Real */
convert (7):
	temp = token_length;
	token_length = constant_array (temp).length + 1;

	rdigits = constant_array (temp).scale;
	ldigits = constant_array (temp).prec - rdigits;
	if ldigits > 0 then
	     l_significant_digits = length (ltrim (substr (token_string, 1, ldigits), "0"));
	else
	     l_significant_digits = 0;
	if rdigits > 0 then
	     r_significant_digits = length (rtrim (substr (token_string, ldigits + 2, rdigits), "0"));
	else
	     r_significant_digits = 0;		/* trim off the extraneous zeros */
	if l_significant_digits + r_significant_digits > max_prec_single
						/* too many digits for single precision (after trimming extraneous zeros) */
	then do;					/* so, convert to double precision, with warning */
	     if ^from_data_parser then
		call print_message (36, token_string, max_prec_single - bias);
	     token = double_const;
	     go to convert_to_dp;
	end;

	work = convert_real_constant_from_real (temp, rdigits, ldigits, r_significant_digits, l_significant_digits);
	unspec (addr (work) -> based_real (1)) =
	     conv_round (real_mode, dp_mode) ((unspec (addr (work) -> based_double)), 0);
	sym_index = create_constant (real_mode, work);
	return;

/* Case		Double Precision */
convert (8):
	temp = token_length;
	token_length = constant_array (temp).length + 1;

convert_to_dp:
	work = convert_real_constant (temp);
	sym_index = create_constant (dp_mode, work);
	return;

/* Case		Complex */
convert (9):
	call print_message (229);			/* complex constant cannot be handled by get_next_token */
	return;

     end get_next_token;

split_token:
     procedure (length, indx, must_be_one);

/*	Program Specifications (split_token)

     Inputs

     Output

     Description (split_token)

     NOTE - This procedure modifies:
	token_list
	first_token
*/

dcl      j fixed bin (18);
dcl      indx fixed bin (18);
dcl      len fixed bin (18);
dcl      length fixed bin (18);
dcl      must_be_one bit (1) aligned;
dcl      off fixed bin (18);

dcl      1 split_structure aligned based (addr (st_copy)),
	 2 pad char (off) unaligned,
	 2 tkn char (len) unaligned;

	off, token_list (indx).offset = token_list (indx).offset + length;
	token_list (indx).length = token_list (indx).length - length;
	len = token_list (indx).length + 1;

	if len > 0 then do;
	     j = verify (tkn, DIGIT) - 1;
	     if j ^= 0 then
		if j < 0 then do;
		     j = len;
		     len = 0;
		end;
		else do;
		     if must_be_one then
			call print_message (52, tkn); /* extraneous characters */
		     if indx = first_token then
			first_token = first_token - 1;
		     token_list (indx).offset = token_list (indx).offset + j;
		     token_list (indx).length = token_list (indx).length - j;
		end;

	     if len - j > 0 then
		if verify (substr (tkn, j + 1, 1), alphabetic) ^= 0 then do;
		     call print_message (52, substr (tkn, j + 1));
		     if j > 0 then
			indx = indx - 1;		/* extraneous characters */
		end;
		else if j > 0 then
		     indx = indx - 1;
	     if j > 0 then do;
		token_list (indx).type = dec_int;
		token_list (indx).offset = off;
		token_list (indx).length = j - 1;
	     end;
	end;
	else do;
	     token_list (indx).type = no_token;
	     if indx = first_token then
		first_token = first_token + 1;
	     indx = indx + 1;
	end;
     end split_token;

err_string:
     procedure () returns (char (512) varying);		/* makes a printable string from the current token */

dcl      TKN bit (9) aligned;				/* to keep token a padded ref */
dcl      op_chars (22) char (4) aligned int static options (constant)
	    init ("+", "-", "*", "/", "**", "not", "and", "or", "eq", "ne", "lt", "gt", "le", "ge", "=", ",", "(", ")",
	    "'", ":", "//", "(");

	if current_token > last_token then
	     return ("the end of this statement");

	TKN = token_list (current_token).type;
	token_offset = token_list (current_token).offset;
	token_length = token_list (current_token).length + 1;

	if TKN = ident then
	     return ("the name " || token_string);

	else if TKN = octal_const then
	     return ("the octal constant " || token_string);

	else if TKN & is_constant then do;
	     if TKN = real_const | TKN = double_const then
		token_length = constant_array (token_length).length + 1;

	     return ("the constant " || token_string);
	end;

	else if TKN & is_operator then
	     return ("the operator " || op_chars (binary (substr (TKN, 5, 5), 5, 0)));

	else
	     return ("the token " || char (TKN) || " (compiler error)");
     end err_string;

/*Check to ensure no duplicate entries. */

check_entry_duplication:
     proc;

/* Routine to scan through list of entry points built by                     */
/* "declaration_processor" (first_entry_name, last_entry_name).  The method  */
/* used is a simple decreasing length scan and is not in the least elegant.  */
/* If a duplication is encountered error 428 is signaled.		       */

dcl      1 master like symbol based (addr (OS (master_index)));
dcl      1 slave like symbol based (addr (OS (slave_index)));
dcl      master_index fixed bin (18);
dcl      slave_index fixed bin (18);

	master_index = first_entry_name;
	do while (master_index ^= 0);			/* scan through list */
	     slave_index = master.next_symbol;
	     do while (slave_index ^= 0);		/* checking dups */
		if slave.name = master.name then
		     call print_message (428, slave.name);
		slave_index = slave.next_symbol;
	     end;
	     master_index = master.next_symbol;
	end;
     end check_entry_duplication;

     end parse_source;
     end ext_parse;


*/
                                          -----------------------------------------------------------


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

*/