fort_.pl1                       11/10/88  1423.2r w 11/10/88  1336.8      927882



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

/* Created:	June 1976

   Modified:
	22 Jun 84, MM - Install typeless functions support.
	28 Mar 84, MM - Install HFP support.
	12 Jul 83, MM - 379: Add references to fort_declared and replace code
		to generate options string with a call to fort_defaults_.
	19 Jun 83, HH - 145: Add display of new 'label' node fields.
	17 Jun 83, HH - 383: Add "process_param_list" to 'op_names'.
	13 Jan 83, HH - Add "form_VLA_packed_ptr" to 'op_names' and remove
		references to the obsolete 'indirect_scan_op'.
	22 September 1982, TO - Add VLA_is_256K for shared vars.
	 7 May 82, TO - To re-compute options string to reflect '%global's.
	 7 May 82, TO - To include multiply check in options string.
	15 March 82,	TO - Add source_line_number, source_file_number.
	15 March 82,	TO - Add "on or after line 16384" message.
	2 December 81, MEP - add "round" to options string.
	24 October 81, MEP - new operator for inquire statement.
	20 October 1981, CRD - new operators for internal files.
	12 May 1981, MEP - Added two new operators for display routines: equiv and not_equiv.
	17 February 1981, CRD - Change display routines for new dimension
		node layout.
	8 January 1981, CRD - Change display routines for new bit
		label.not_referencable.
	18 December 1980, CRD - Change display routines for new bit
		opt_statement.removable.
	9 December 1980, CRD - Change display routines for three new
		operators - block_if, else_if, and else.
	1 September 1980, CRD - Change diaplay routines for new bit
		array_ref.has_address.
	18 July 1980, CRD - Change display routines for new bit 
		symbol.variable_arglist.
	19 June 1980, MEP - fort_display now prints the source statments
                    when it encounters a source node or quad.      
	7 March 1980, CRD - change multi_position bit to stack_indirect.
	29 February 1980, CRD - change options string to properly reflect
		the new default of -relocatable.
	31 January 1980, CRD - changes for new stringrange option.
	23 January 1980, CRD - changes to header node and fix offset_unit_names.
	21 December 1979, RAB - more register optimizer changes and call probe instead of debug.
	5 November 1979, RAB - change display progs for register optimizer
	19 October 1979, CRD - increase length of phase names, and always
		display octal numbers with a trailing  "o".
	5 October 1979, CRD - node changes for new EAQ scheme.
	17 September 1979, RAB - for register optimizer (node changes)
	12 September 1979, CRD - fix minor glitch in decode_source_id.
	13 August 1979, RAB - add cat_op & substr_op
	19 July 1979, RAB - change fort_display for char_mode incl file changes
	4 July 1979, RAB - have temporary.loop_end_fu_pos and header.length
			print out in decimal.
	28 Jun 1979, PES - Initialize parameter math entry arrays.
	20 Jun 1979, PES - Fix unreported bug in which QUIT/RL before parse is called caused fault.
	18 Dec 1978, PES - Make auto_zero and do_rounding the defaults for FAST, DFAST, and run units.
	09 Dec 1978, PES - Change so fort_display will show options.
	05 Dec 1978, PES - Remove kludge of Jul 31, changes for new options.
	25 Oct 1978, PES - Changes for larger common and arrays.
	25 Sep 1978, RAB - c/loop_end_fu_num/loop_end_fu_pos/ to help fix 187
	31 Jul 1978, PES - Kludge around bug in PLI compiler.
	27 Jul 1978, PES - remove references to full and simple command arguments.
	26 Jun 1978, DSL - move create_constant to fort_utilities.incl.pl1.
	26 Jan 1978, RAB - Change for loop optimizer.
	10 Jan 1978, DSL - Implement once_per_statement and once_per_subprogram for error
		messages, and control them and once_per_compilation using options.brief.
		See comments in procedure print_meessage_op.
	27 Dec 1977, DSL - implement print once per compilation for error messages.
	30 Aug 1977, DSL - implement fortran_severity_; display changes: print common
		block nodes for "dcl", print summary of polish; NOTE -- value of bias
		changed from 65536 to 131072.
	05 Jul 1977, DSL - 1) 3 new operators; 2) remove refs to block_data_subprogram.
	03 May 1977, DSL - restore timing info to old format; add trim_floating.
	28 Apr 1977, DSL - recompile for new operator, xmit_vector.
	25 Mar 1977, DSL - improve error messages, improve display prgms,
		include counts with timing info only if debugging.
	24 Feb 1977, GDC - add optimize capability.
	09 Dec 1976, DSL - new compiler_source_info.incl.pl1;
		new fort_command_structure.incl.pl1; completely rewrite display code.
	20 Oct 1976, RAB - add relocation bits, variable max_lens.
	12 Sep 1976, DSL - add listing capability, clean up display programs.
*/

/* format: style3,^delnl,linecom */
fort_:
     procedure (source_info_ptr,			/* input; pointer to source info structure */
	object_base_ptr,
						/* input; pointer to object segment */
	object_length,				/* output; word length of object segment */
	options_ptr,
						/* input; pointer to fort options structure */
	declared_ptr,				/* input; pointer to fort declared structure */
	get_next_source_seg_entry,
						/* input; routine to provide next source seg or null entry value */
	add_to_lib_list_entry,
						/* input; routine to handle lib pathnames or null entry value */
	code);
						/* output; error code */

/* PARAMETERS */

dcl	add_to_lib_list_entry
			entry variable;
dcl	code		fixed bin (35);
dcl	get_next_source_seg_entry
			entry variable;
dcl	object_base_ptr	pointer;
dcl	object_length	fixed bin (19);
dcl	options_ptr	pointer;
dcl	declared_ptr	pointer;
dcl	source_info_ptr	pointer;

/* This is the main entry point to the new fortran compiler. */

%include fort_nodes;

%include fort_opt_nodes;

%include fort_listing_nodes;

%include fort_system_constants;

dcl	1 shared_globals	structure aligned,
%include fort_shared_vars;

dcl	1 parse_globals	structure aligned,
%include fort_parse_vars;

dcl	1 cg_globals	structure aligned,
%include fort_cg_vars;
%include fort_message_table_;

%include fort_options;

dcl	1 csi		aligned based (source_info_ptr) like compiler_source_info;

%include compiler_source_info;

%include relocation_bits;

dcl	(addr, addrel, baseno, binary, bool, convert, divide, fixed, hbound, lbound, index, length, max, min, mod, null,
	ptr, rel, size, string, substr, unspec, verify)
			builtin;

dcl	cleanup		condition;

dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35));
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));

dcl	get_temp_segment_	entry (char (*), ptr, fixed bin (35));
dcl	release_temp_segment_
			entry (char (*), ptr, fixed bin (35));

dcl	display_entries$fdisplay
			entry (ptr) external static variable;

dcl	error_table_$translation_aborted
			fixed bin (35) external static;
dcl	error_table_$translation_failed
			fixed bin (35) external static;

dcl	x		(0:operand_max_len - 1) fixed bin (35) based (operand_base);

dcl	1 polish_region	structure aligned based (polish_base),
	  2 polish_string	(0:polish_max_len - 1) fixed bin (18) aligned;

dcl	quad		(0:quad_max_len - 1) fixed bin (18) based (quadruple_base);

dcl	intermediate_base	ptr;

dcl	hash_table_size	init (211) fixed bin int static options (constant);
dcl	hash_table	(0:hash_table_size - 1) fixed bin (35) based (operand_base);

dcl	node_offset	fixed bin (18);
dcl	phase		fixed bin (18);

dcl	(
	node_ptr,
	tsegp		(10)
	)		ptr;
dcl	allocate_temp_segs	(number_of_temps) ptr based;
dcl	number_of_temps	fixed bin (18);

dcl	num_opt_segs	fixed bin (18);

dcl	i		fixed bin (18);
dcl	max_length	fixed bin (19);
dcl	(p, q)		pointer;

dcl	1 packed_ptr_st	based aligned,
	  2 packed_ptr	pointer unaligned;

dcl	1 meter_info	aligned structure,
	  2 per_phase_info	(0:7) aligned structure,
	    3 npages	fixed bin (17),
	    3 ncpu	fixed bin (52),
	    3 polish_count	fixed bin (18),
	    3 operand_count fixed bin (18),
	    3 quadruple_count
			fixed bin (18),
	    3 opt_count	fixed bin (18);

dcl	(cpu, total_cpu)	fixed bin (52);
dcl	last_phase	fixed bin (18);

dcl	last_error_subprogram
			fixed bin (18);
dcl	last_error_statement
			fixed bin (18);
dcl	begin_subprogram_errors
			fixed bin (18);
dcl	begin_statement_errors
			fixed bin (18);
dcl	msg_table_len	fixed bin (18);

dcl	1 error_msg	(200) aligned,
	  2 number	fixed bin (18),
	  2 opnd		fixed bin (18),
	  2 count		fixed bin (18),
	  2 statement	fixed bin (18);

dcl	fortran_severity_	fixed bin (35) ext static;


dcl	message_printed	bit (550) aligned init ("0"b);
dcl	produce_listing	bit (1) aligned;

dcl	(
	initialization	init (1),
	in_parse		init (2),
	in_converter	init (3),
	in_optimizer	init (4),
	in_code_generator	init (5),
	in_listing_generator
			init (6),
	in_clean_up	init (7)
	)		fixed bin int static options (constant);

dcl	phase_name	(7) char (16) aligned int static options (constant)
			init ("setup", "parse", "converter", "optimizer", "code generator", "listing", "cleanup");

dcl	date_string	char (24);
dcl	user_id		char (32) aligned;
dcl	static_user_id	char (32) varying int static init ("");

dcl	clock_		ext entry (fixed bin (71));
dcl	cu_$decode_entry_value
			entry (entry, pointer, pointer);
dcl	date_time_	ext entry (fixed bin (71), char (*));
dcl	fort_defaults_$options_string
			ext entry (ptr, char (256) varying, fixed bin (19));
dcl	get_group_id_	ext entry (char (*) aligned);
dcl	ioa_		ext entry options (variable);
dcl	ioa_$nnl		ext entry options (variable);
dcl	ioa_$rsnp		ext entry options (variable);
dcl	probe		ext entry options (variable);
dcl	hcs_$terminate_noname
			ext entry (ptr, fixed bin (35));
dcl	hcs_$usage_values	ext entry (fixed bin (17), fixed bin (52));
dcl	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) ext;



/* Main entry into the new fortran compiler */

	unspec (shared_globals) = "0"b;

/* get caller's source routine or use the compiler's internal one */

	call cu_$decode_entry_value (get_next_source_seg_entry, p, q);
	if p = null
	then get_next_source_seg = get_next_source_seg_comp;
						/* use the compiler's routine */
	else get_next_source_seg = get_next_source_seg_entry;
						/* use the caller's routine */

/* get caller's lib list routine or use internal one */

	call cu_$decode_entry_value (add_to_lib_list_entry, p, q);
	if p = null
	then shared_globals.options.compile_only = "1"b;	/* use the compiler's routine */
	else do;					/* use the caller's routine */
		shared_globals.options.compile_only = "0"b;
		add_to_lib_list_run = add_to_lib_list_entry;
	     end;

/* pick up the declared fortran options */

	shared_globals.declared_options = declared_ptr -> fortran_declared;

/* set Multics/FAST switch */

	shared_globals.options.is_fast = "0"b;
	max_length = sys_info$max_seg_size;
	goto initialize;


/* entry to compile one source segment from within FAST/DFAST */

compile:
     entry (source_info_ptr,				/* input; pointer to source info structure */
	object_base_ptr,
						/* input; pointer to object segment */
	object_length,				/* output; word length of object segment */
	options_ptr,
						/* input; pointer to fort options structure */
	code);
						/* output; error code */

/* use compiler's internal routines */

	get_next_source_seg = get_next_source_seg_comp;
	unspec (shared_globals) = "0"b;
	shared_globals.options.compile_only = "1"b;
	shared_globals.options.is_fast = "1"b;		/* Multics/FAST switch */
	unspec (shared_globals.declared_options) = "0"b;
	max_length = 65536;
	goto initialize;


/* entry called by run unit man to compile source programs for execution */

compile_run:
     entry (source_info_ptr,				/* input; pointer to source info structure */
	object_base_ptr,
						/* input; pointer to object segment */
	object_length,				/* output; word length of object segment */
	options_ptr,
						/* input; pointer to fort options structure */
	get_next_source_seg_entry,
						/* input; routine to provide next source seg or null entry value */
	add_to_lib_list_entry,
						/* input; routine to handle lib pathnames or null entry value */
	code);
						/* output; error code */

/* use caller's routines */

	get_next_source_seg = get_next_source_seg_entry;
	add_to_lib_list_run = add_to_lib_list_entry;
	unspec (shared_globals) = "0"b;
	shared_globals.options.compile_only = "0"b;
	shared_globals.options.is_fast = "1"b;		/* Multics/FAST switch */
	unspec (shared_globals.declared_options) = "0"b;
	max_length = 65536;

initialize:					/*  initialize local variables and pick up the user options	*/
	if csi.version ^= compiler_source_info_version_2
	then do;
		code = error_table_$translation_aborted;
		return;
	     end;

	phase = initialization;

	shared_globals.options.user_options = options_ptr -> fortran_options;
	produce_listing = string (shared_globals.options.listing) ^= "0"b;

	if shared_globals.options.time
	then do;
		unspec (meter_info) = "0"b;		/* Initialize the metering array. */

		call hcs_$usage_values (npages (0), ncpu (0));
	     end;

	display_entries$fdisplay = fort_display;

/* derive objectname */

	if csi.given_ename = ""
	then objectname = "object";
	else if length (csi.given_ename) > 8
	then if substr (csi.given_ename, length (csi.given_ename) - 7, 8) = ".fortran"
	     then objectname = substr (csi.given_ename, 1, length (csi.given_ename) - 8);
	     else objectname = csi.given_ename;
	else objectname = csi.given_ename;

/* set date time compiled */

	call clock_ (date_time_compiled);

/* determine user id */

	if length (static_user_id) = 0
	then do;
		call get_group_id_ (user_id);

		i = index (user_id, " ") - 1;
		if i < 0
		then i = length (user_id);

		static_user_id = substr (user_id, 1, i);
	     end;

	vuser_id = static_user_id;

/* initialize global variables	*/

	num_of_lib_names, first_lib_name, last_lib_name, num_of_word_constants, first_word_constant, last_word_constant,
	     num_of_dw_constants, first_dw_constant, last_dw_constant, num_of_char_constants, first_char_constant,
	     last_char_constant, num_of_block_constants, first_block_constant, last_block_constant = 0;

	num_opt_segs = 0;

	polish_max_len, operand_max_len, quad_max_len, object_max_len = max_length;

	opt_max_len = sys_info$max_seg_size;

	next_free_temp, next_free_array_ref = 0;

	next_free_object = 0;
	next_free_opt, next_free_polish, next_free_quad = 1;
						/*   must be initialized to non-zero for the optimizer   */
	next_free_operand = hash_table_size;

	cur_statement, cur_subprogram, first_subprogram, last_subprogram = 0;

	first_entry_name, last_entry_name = 0;

	error_level, msg_table_len, begin_statement_errors, begin_subprogram_errors, incl_count, last_error_subprogram =
	     0;

	last_error_statement = -1;


/* make sure window is shut tight for cleanup handler */

	number_of_temps = 0;
	tsegp (*) = null;
	opt_base = null;


/* set up a cleanup handler */

	on cleanup
	     call clean_up;

/*  get work segments	*/

	number_of_temps = 3;			/* require at least three temp segs */

	if produce_listing
	then number_of_temps = number_of_temps + 3;	/* cref, listing_info, source_line */

	if shared_globals.options.optimize
	then number_of_temps = number_of_temps + 2;	/* quadruples & optimizer stuff */

	call get_temp_segments_ ("fort_", addr (tsegp) -> allocate_temp_segs, code);
	if code ^= 0
	then return;

/* set work area pointers and zero object length */

	intermediate_base, polish_base = tsegp (1);
	operand_base = tsegp (2);
	relocation_base = tsegp (3);
	object_base = object_base_ptr;
	object_length = 0;

/* if a listing is to be produced, set appropriate global variables */

	if produce_listing
	then do;
		cref_base = tsegp (4);		/* contains cross ref info */
		source_line_base = tsegp (5);		/* char offset for each source line */
		listing_base = tsegp (6);		/* error text and listing info nodes */

/* build node for errors before the first subprogram */

		cur_listing = listing_base;
		unspec (listing_info) = "0"b;		/* initialize */

		number_of_crefs = 0;
		next_free_listing = size (listing_info);
	     end;

/* if optimizing set up for those phases */

	if shared_globals.options.optimize
	then do;
		opt_base = tsegp (number_of_temps);	/* get last temp_base seg pointer */
		opt_base -> packed_ptr = null;
		num_opt_segs = 1;
		quadruple_base = tsegp (number_of_temps - 1);
	     end;

	call BEGIN_COMPILER_PHASE (in_parse, "0"b);

	source_line_number, source_file_number = 0;
	use_source_info = "0"b;			/* Turn off source numbers */
	call parse_source (source_info_ptr);
	source_line_number, source_file_number = 0;
	use_source_info = "0"b;			/* Turn off source numbers */

/* compute options string to reflect control arguments and '%global' cards. */

	call fort_defaults_$options_string (addr (shared_globals.options), options_string,
	     pl1_operators_$VLA_words_per_seg_);

/*  if no fatal errors in parse then invoke (optimizer and) code generator	*/

	if error_level < unrecoverable_error & ^shared_globals.options.check
	then do;



		if shared_globals.options.optimize
		then do;
			call BEGIN_COMPILER_PHASE (in_converter, (shared_globals.options.stop_after_parse));

			call converter;

			intermediate_base = quadruple_base;

			call BEGIN_COMPILER_PHASE (in_optimizer, (shared_globals.options.stop_after_parse));

			call optimizer;

			call BEGIN_COMPILER_PHASE (in_code_generator, (shared_globals.options.stop_after_parse));

			call optimizing_cg;
		     end;

		else do;
			call BEGIN_COMPILER_PHASE (in_code_generator, (shared_globals.options.stop_after_parse));

			call code_generator;
		     end;

		object_length = next_free_object;
	     end;

/* set return code and object length */

	if error_level > unrecoverable_error
	then do;
fort_abort:
		code = error_table_$translation_aborted;
		object_length = 0;
	     end;
	else if error_level = unrecoverable_error
	then do;
		code = error_table_$translation_failed;
		object_length = 0;
	     end;
	else code = 0;

/* Before a listing can be produced, all error messages must be printed. */

	call print_message_op$epilogue;		/* Prints outstanding message counts. */

/* if user requested a listing, produce it now */

	if produce_listing
	then do;
		call BEGIN_COMPILER_PHASE (in_listing_generator, (shared_globals.options.stop_after_cg));

		call listing_generator;
	     end;

/* clean up and return */

	call BEGIN_COMPILER_PHASE (in_clean_up, shared_globals.options.stop_after_cg & ^produce_listing);

	call clean_up;

	if shared_globals.options.time
	then do;
		call hcs_$usage_values (npages (hbound (per_phase_info, 1)), ncpu (hbound (per_phase_info, 1)));
		polish_count (hbound (per_phase_info, 1)) = next_free_polish;
		operand_count (hbound (per_phase_info, 1)) = next_free_operand;
		quadruple_count (hbound (per_phase_info, 1)) = next_free_quad;
		opt_count (hbound (per_phase_info, 1)) = next_free_opt;

		call date_time_ (date_time_compiled, date_string);

		call ioa_
		     (
		     "^/Segment ^a (^d lines)^/Compiled by ^a on ^a^/
Phase               CPU     %   Pages   Polish   Operand^[   Quadruple Optimizer^]"
		     , objectname, number_of_lines, compiler_name, date_string, shared_globals.options.optimize);


		total_cpu = ncpu (hbound (per_phase_info, 1)) - ncpu (0);
		last_phase = 0;

		do i = 1 to hbound (per_phase_info, 1);

/* if phase was skipped, do not print a line for it */

		     if ncpu (i) > 0
		     then do;

/* compute time for this phase */

			     cpu = ncpu (i) - ncpu (last_phase);

/* print info for this phase */

			     call ioa_ ("^15a^9.3f^6.1f^6d^9o^10o^[^11o^10o^]", phase_name (i), cpu / 1.0e6,
				100.0e0 * cpu / total_cpu, npages (i) - npages (last_phase), polish_count (i),
				operand_count (i), shared_globals.options.optimize, quadruple_count (i),
				opt_count (i));
			     last_phase = i;
			end;
		end;

/* print totals */

		call ioa_ ("TOTAL          ^9.3f^12d^/", total_cpu / 1.0e6,
		     npages (hbound (per_phase_info, 1)) - npages (0));

		if num_opt_segs > 1
		then call ioa_ ("^/^d temp segments were used by the optimizer.", num_opt_segs);

	     end;

	return;

clean_up:
     proc;

dcl	code		fixed bin (35);
dcl	i		fixed bin;
dcl	p		ptr;

	do i = 1 to shared_globals.incl_count;
	     call hcs_$terminate_noname ((shared_globals.incl_ptr (i)), code);
	end;

	code = 0;

	if opt_base ^= null & baseno (opt_base) ^= "0"b
	then do;

		do while (opt_base ^= null & baseno (opt_base) ^= "0"b);
		     p = opt_base;
		     opt_base = p -> packed_ptr;
		     call release_temp_segment_ ("fort_", p, code);
		end;

		number_of_temps = number_of_temps - 1;
	     end;

	call release_temp_segments_ ("fort_", addr (tsegp) -> allocate_temp_segs, code);
	polish_base, operand_base, quadruple_base, opt_base, object_base = null;

     end clean_up;

BEGIN_COMPILER_PHASE:
     proc (new_phase, call_probe);

dcl	new_phase		fixed bin (17);
dcl	call_probe	bit (1) aligned;


	if shared_globals.options.time
	then do;
		call hcs_$usage_values (npages (phase), ncpu (phase));
		polish_count (phase) = next_free_polish;
		operand_count (phase) = next_free_operand;
		quadruple_count (phase) = next_free_quad;
		opt_count (phase) = next_free_opt;
	     end;

	if call_probe
	then do;
		call ioa_$nnl ("^a done! pb:", phase_name (phase));
		call probe ();
	     end;

	phase = new_phase;
     end BEGIN_COMPILER_PHASE;

abort_compiler:
     proc (msg);

dcl	msg		char (*);


	call ioa_ ("Compiler Error: ^a", msg);
	goto fort_abort;
     end abort_compiler;

parse_source:
     proc (source_ptr);

dcl	source_ptr	ptr;
dcl	ext_parse		entry (ptr, ptr);

	shared_globals.create_constant = create_constant;
	shared_globals.create_char_constant = create_char_constant;
	shared_globals.print_message = print_message;
	shared_globals.get_next_temp_segment = get_next_temp_segment;

	parse_globals.source_info_ptr = source_ptr;

	if shared_globals.options.compile_only
	then parse_globals.add_to_lib_list_run = add_to_lib_list;

	parse_globals.add_to_lib_list = parse_globals.add_to_lib_list_run;

	call ext_parse (addr (shared_globals), addr (parse_globals));

     end parse_source;

converter:
     proc;

dcl	fort_converter	entry (ptr);

	call fort_converter (addr (shared_globals));

     end converter;

optimizer:
     proc;

dcl	fort_optimizer	entry (ptr);

	call fort_optimizer (addr (shared_globals));

     end optimizer;

code_generator:
     proc;

dcl	ext_code_generator	entry (ptr, ptr);

	shared_globals.create_constant = create_constant;
	shared_globals.create_char_constant = create_char_constant;
	shared_globals.print_message = print_message;

	cg_globals.print_message_op = print_message_op;
	cg_globals.create_constant_block = create_constant_block;

	call ext_code_generator (addr (shared_globals), addr (cg_globals));

     end code_generator;

optimizing_cg:
     proc;

dcl	fort_optimizing_cg	entry (ptr, ptr);

	shared_globals.create_constant = create_constant;
	shared_globals.create_char_constant = create_char_constant;
	shared_globals.print_message = print_message;

	cg_globals.print_message_op = print_message_op;
	cg_globals.create_constant_block = create_constant_block;

	call fort_optimizing_cg (addr (shared_globals), addr (cg_globals));

     end optimizing_cg;

listing_generator:
     proc;

dcl	ext_listing_generator
			entry (ptr, ptr, ptr);

	call ext_listing_generator (addr (shared_globals), addr (parse_globals), addr (cg_globals));

     end listing_generator;

%include fort_utilities;

create_char_constant:
     proc (value) returns (fixed bin (18));

dcl	value		char (*);
dcl	a_value		char (char_constant_length) aligned based (addr (string_bit_array));
dcl	cc_offset		fixed bin (18);
dcl	cc_ptr		pointer;
dcl	hash_index	fixed bin (18);

dcl	(i, j, k, which)	fixed bin (18);
dcl	mod_2_sum		bit (36) aligned;
dcl	string_bit_array	(0:255) bit (36) aligned;

dcl	mask		(3) bit (36) int static aligned
			init ("111111111000000000000000000000000000"b, "111111111111111111000000000000000000"b,
			"111111111111111111111111111000000000"b);


	char_constant_length = length (value);
	a_value = value;
	which = 3;

/* calculate the hash index for the constant */

join:
	if length (a_value) = 0
	then hash_index = 0;
	else if length (a_value) = 1
	then do;
		hash_index = binary (unspec (substr (a_value, 1, 1)) & "001111111"b, 9);
	     end;
	else do;
		mod_2_sum = "0"b;

		j = divide (length (a_value) - 1, 4, 17, 0);
		k = length (a_value) - 4 * j;

		if k ^= 4
		then string_bit_array (j) = string_bit_array (j) & mask (k);

		do i = 0 to j;
		     mod_2_sum = bool (mod_2_sum, string_bit_array (i), "0110"b);
		end;

		hash_index = mod (binary (substr (mod_2_sum, 2, 35), 35), hash_table_size);
	     end;

/* search the hash table bucket for the constant */

	cc_offset = hash_table (hash_index);
	do while (cc_offset > 0);			/* search the entire bucket */
	     cc_ptr = addr (x (cc_offset));

	     if cc_ptr -> node.node_type = char_constant_node
						/* all constants in same hash table */
	     then if cc_ptr -> char_constant.length = char_constant_length
		then if cc_ptr -> char_constant.value = a_value
		     then return (cc_offset);

	     cc_offset = cc_ptr -> node.hash_chain;	/* will point to last item in bucket. get offset of next const */
	end;

/* a new constant node must be created */

	cc_offset = create_node (char_constant_node, size (char_constant));

	if hash_table (hash_index) = 0		/* Is this the first item in this bucket? */
	then hash_table (hash_index) = cc_offset;	/* yes */
	else cc_ptr -> node.hash_chain = cc_offset;	/* no, add it to end */

	cc_ptr = addr (x (cc_offset));
	cc_ptr -> char_constant.data_type = char_mode;
	cc_ptr -> char_constant.operand_type = constant_type;
	cc_ptr -> char_constant.length = char_constant_length;
	cc_ptr -> char_constant.value = a_value;
	cc_ptr -> char_constant.is_addressable = "1"b;
	cc_ptr -> char_constant.reloc = rc_t;

	constant_count (which) = constant_count (which) + 1;

	if first_constant (which) = 0			/* is this the first char constant? */
	then first_constant (which) = cc_offset;	/* yes */
	else addr (x (last_constant (which))) -> char_constant.next_constant = cc_offset;
						/* no, add it to list */

	last_constant (which) = cc_offset;

	return (cc_offset);


create_constant_block:
     entry (pt, nwords) returns (fixed bin (18));

dcl	pt		ptr,			/* points at block of data */
	nwords		fixed bin (18);		/* length of data */

dcl	b_value		char (char_constant_length) based (pt) aligned;

	which = 4;
	char_constant_length = chars_per_word * nwords;
	a_value = b_value;
	go to join;

     end create_char_constant;

add_to_lib_list:
     proc (pathname, code);

dcl	pathname		char (*);
dcl	a_pathname	char (256) var;
dcl	code		fixed bin (35);
dcl	char_node_offset	fixed bin (18);


	a_pathname = pathname;
	code = 0;					/* No error possible, except to abort compilation. */

/*  create character constant node and/or get its offset	*/

	char_node_offset = create_char_constant (pathname);
	addr (x (char_node_offset)) -> char_constant.allocate = "1"b;
						/* Force allocation of the constant. */

/*  is the list of library names non-empty	*/

	if first_lib_name > 0
	then do;
		node_offset = first_lib_name;

/*  yes, search the library list	*/

		do while (node_offset > 0);
		     node_ptr = addr (x (node_offset));
		     if node_ptr -> library.character_operand = char_node_offset
		     then return;
		     node_offset = node_ptr -> library.next_library_node;
		end;

	     end;


/* build a new library node and thread it into the chain. */

	num_of_lib_names = num_of_lib_names + 1;

	node_offset = create_node (library_node, size (library));

	addr (x (node_offset)) -> library.character_operand = char_node_offset;

	if last_lib_name = 0
	then first_lib_name = node_offset;
	else addr (x (last_lib_name)) -> library.next_library_node = node_offset;

	last_lib_name = node_offset;

     end add_to_lib_list;

get_next_source_seg_comp:
     proc (p);

dcl	p		ptr;

	p -> compiler_source_info.input_pointer = null ();

     end get_next_source_seg_comp;

get_next_temp_segment:
     proc (seg_base, next_free) returns (ptr);

dcl	seg_base		ptr;			/* -> base of temp segment (input/output) */
dcl	next_free		fixed bin (18);		/* used for making allocations (output) */

dcl	p		ptr;
dcl	code		fixed bin (35);

	call get_temp_segment_ ("fort_", p, code);

	if code ^= 0
	then call abort_compiler ("Can't get new temp segment.");

	num_opt_segs = num_opt_segs + 1;

	p -> packed_ptr = seg_base;
	seg_base = p;
	next_free = 1;

	return (p);

     end get_next_temp_segment;

/* Message printing utilizes "cur_statement" as the address of the word      */
/* starting a statement node.  However this functionality does not work for  */
/* some messages called from "ext_parse" and perhaps other areas.  Two fields*/
/* have been added to shared_structure.incl.pl1, source_line_number, and     */
/* source_file_number.  These are used rather than the numbers from the nodes*/
/* if "use_source_info is set.				       */

print_message:
     proc options (variable, no_quick_blocks);

dcl	cu_$arg_list_ptr	entry (ptr);
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	decode_descriptor_	entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);

dcl	(arg_list_ptr, arg_ptr)
			ptr;
dcl	packed		bit (1) aligned;
dcl	fixed_bin		fixed bin (18) based;
dcl	code		fixed bin (35);
dcl	(nargs, i, arg_len, a_type, ndims, size, scale)
			fixed bin (17);

dcl	(
	real_fixed_bin	init (1),
	character_string	init (21),
	char_string_varing	init (22)
	)		fixed bin int static options (constant);

dcl	bad_arg		char (12) aligned int static options (constant) init ("BAD ARGUMENT");


/*  get the number of arguments	*/

	call cu_$arg_count (nargs);
	message_structure.number_of_operands = nargs - 1;

/*  get the argument list pointer	*/

	call cu_$arg_list_ptr (arg_list_ptr);

/*  get the first argument	*/

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	message_structure.message_number = arg_ptr -> fixed_bin;

/*  get one to three optional arguments	*/

	do i = 2 to nargs;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     call decode_descriptor_ (arg_list_ptr, i, a_type, packed, ndims, size, scale);

	     if a_type = real_fixed_bin
	     then do;
		     message_structure.operands (i - 1).is_string = "0"b;
		     message_structure.operands (i - 1).operand_index = arg_ptr -> fixed_bin;
		end;
	     else if a_type = character_string | a_type = char_string_varing
	     then do;
		     message_structure.operands (i - 1).is_string = "1"b;
		     if a_type = character_string
		     then message_structure.operands (i - 1).string_length = arg_len;
		     else message_structure.operands (i - 1).string_length = addrel (arg_ptr, -1) -> fixed_bin;
		     message_structure.operands (i - 1).string_ptr = arg_ptr;
		end;

	     else do;				/* Bad  argument. */
		     message_structure.operands (i - 1).is_string = "1"b;
		     message_structure.operands (i - 1).string_length = length (bad_arg);
		     message_structure.operands (i - 1).string_ptr = addr (bad_arg);
		end;
	end;

	call print_message_op;

     end print_message;

print_message_op:
     proc;

dcl	(node_ptr, table_base)
			ptr;
dcl	(a_message_number, opnd)
			fixed bin (18);
dcl	(i, arg_length, noprds, new_slot, message_length, message_offset)
			fixed bin (18);

dcl	arg_string	(3) char (256) var;
dcl	arg_char_string	char (arg_length) based;

dcl	header_line	char (128) varying;

dcl	print_on_terminal	bit (1) aligned;

dcl	(a_node_type, an_error_level)
			fixed bin (4) aligned;

dcl	1 table_overlay	aligned based (table_base),
	  2 spacer	(message_offset) fixed bin,
	  2 formating_string
			char (message_length) unal;


/* First, get and validate error message number. If severity is zero or message length is
	   zero, chances are that message is not in table. Then, get its severity level. */

	a_message_number = message_structure.message_number;

	if a_message_number <= 0 | a_message_number > hbound (fort_message_table$fort_message_table.descrip, 1)
	     | fort_message_table$fort_message_table.descrip (a_message_number).level = 0
	     | fixed (fort_message_table$fort_message_table.descrip (a_message_number).length, 17) = 0
	then do;
		a_message_number = hbound (fort_message_table$fort_message_table.descrip, 1);
		message_structure.number_of_operands = 1;
		message_structure.operands (1).operand_index = message_structure.message_number - bias;
		message_structure.operands (1).is_string = "0"b;
	     end;

	an_error_level = fort_message_table$fort_message_table.descrip (a_message_number).level;

	print_on_terminal = an_error_level >= shared_globals.options.severity;
						/* Decide if user wants it online. */


/* Format the error message only if it is to be printed somewhere. */

	if print_on_terminal | produce_listing
	then do;

/* The following block of code implements restricted message printing. This is simply
		 effort to reduce the number of redundant error messages printed, without reducing
		formation available to the user. Use of the -brief control argument reduces the number
		 times a given message is printed, also.

		     Three flags control the number of times a message is printed and they are part of
		e message table entry for each error message. The flag "print_once" must be set to "1"b
		r messages that participate in this feature. Additionally, the flag "once_per_stmnt"
		 the flag "once_per_subpgm" may be "1"b. It is an error if all three are "1"b.

		     If only "print_once" is "1"b, the message is printed once per subprogram if
		rief is not specified, and once per compilation if it is. If "print_once" and
		nce_per_subpgm" are "1"b, the message is printed once per statement if -brief is not
		ecified, and once per subprogram if it is. if "print_once" and "once_per_stmnt" are
		"b, the message is always printed once per statement. */

		if fort_message_table$fort_message_table.descrip (a_message_number).print_once
		then do;

/* If match includes an operand, extract operand from current message. */

			opnd =
			     binary (fort_message_table$fort_message_table.descrip (a_message_number).saved_operand)
			     ;
			if opnd ^= 0
			then if message_structure.operands (opnd).is_string
			     then do;
				     arg_length = message_structure.operands (opnd).string_length;
				     opnd =
					create_char_constant
					((message_structure.operands (opnd).string_ptr -> arg_char_string));
				end;
			     else opnd = message_structure.operands (opnd).operand_index;

/* If previous message was from a different statement or subprogram, eliminate all messages
		     from the list that are no longer relavant. */

			if begin_statement_errors ^= 0 & last_error_statement ^= cur_statement
			then do;
				do i = begin_statement_errors to msg_table_len;
				     call print_message_summary (i, "statement");
				end;

				msg_table_len = begin_statement_errors - 1;
				begin_statement_errors = 0;
			     end;

			if begin_subprogram_errors ^= 0 & cur_subprogram ^= 0
			     & cur_subprogram ^= last_error_subprogram
			then do;
				do i = begin_subprogram_errors to msg_table_len;
				     call print_message_summary (i, "subprogram");
				end;

				msg_table_len = begin_subprogram_errors - 1;
				begin_subprogram_errors = 0;
				begin_statement_errors = 0;
			     end;

			last_error_statement = cur_statement;

/* Look new message up in the table. */

			do i = 1 to msg_table_len;
			     if a_message_number = error_msg (i).number
			     then if opnd = error_msg (i).opnd
				then do;

/* This message has already been printed. Update its count if necessary. */

					if cur_statement ^= error_msg (i).statement
					then do;	/* A new line. */
						error_msg (i).statement = cur_statement;
						error_msg (i).count = error_msg (i).count + 1;
					     end;

					else if fort_message_table$fort_message_table.descrip (a_message_number)
						.once_per_stmnt
					then error_msg (i).count = error_msg (i).count + 1;
						/* Multiple occurances on the line. */

					last_error_subprogram = cur_subprogram;
					return;
				     end;		/* message has occured before */
			end;			/* loop to look up message */

/* First time for this message, find appropriate slot. */

			if msg_table_len < hbound (error_msg, 1)
						/* Allocate a new slot if there's room, */
			then msg_table_len = msg_table_len + 1;

			else do;			/* or reuse one if there's not. */
				if begin_statement_errors = 1
				then call print_message_summary (1, "statement");
				else if begin_subprogram_errors = 1
				then call print_message_summary (1, "subprogram");
				else call print_message_summary (1, "compilation");

				do i = 2 to msg_table_len;
				     error_msg (i - 1) = error_msg (i);
				end;

				if begin_statement_errors > 0
				then begin_statement_errors = begin_statement_errors - 1;
				if begin_subprogram_errors > 0
				then begin_subprogram_errors = begin_subprogram_errors - 1;
			     end;

/* Now decide what type of message it is. */

			if fort_message_table$fort_message_table.descrip (a_message_number).once_per_stmnt
			     | (fort_message_table$fort_message_table.descrip (a_message_number).once_per_subpgm
			     & ^shared_globals.options.brief)
			then do;
				if begin_statement_errors = 0
				then begin_statement_errors = msg_table_len;
				new_slot = msg_table_len;
			     end;

			else if fort_message_table$fort_message_table.descrip (a_message_number).once_per_subpgm
				| ^shared_globals.options.brief
			then do;
				if begin_statement_errors = 0
				then new_slot = msg_table_len;

				else do;
					new_slot = begin_statement_errors;
					begin_statement_errors = begin_statement_errors + 1;

					do i = begin_statement_errors to msg_table_len;
					     error_msg (i) = error_msg (i - 1);
					end;
				     end;
				if begin_subprogram_errors = 0
				then begin_subprogram_errors = new_slot;
			     end;

			else do;
				if begin_subprogram_errors > 0
				then do;
					new_slot = begin_subprogram_errors;
					begin_subprogram_errors = begin_subprogram_errors + 1;
					if begin_statement_errors > 0
					then begin_statement_errors = begin_statement_errors + 1;

					do i = begin_subprogram_errors to msg_table_len;
					     error_msg (i) = error_msg (i - 1);
					end;
				     end;

				else if begin_statement_errors > 0
				then do;
					new_slot = begin_statement_errors;
					begin_statement_errors = begin_statement_errors + 1;

					do i = begin_statement_errors to msg_table_len;
					     error_msg (i) = error_msg (i - 1);
					end;
				     end;

				else new_slot = msg_table_len;
			     end;

			error_msg (new_slot).number = a_message_number;
			error_msg (new_slot).opnd = opnd;
			error_msg (new_slot).count = 0;
			error_msg (new_slot).statement = cur_statement;
		     end;


/* Produce a header for terminal output. */

		if print_on_terminal		/* if message to appear on the terminal */
		     & cur_subprogram ^= 0		/* and a subprogram node exisits */
		     & cur_subprogram ^= last_error_subprogram
						/* and message is for a new subprogram */
		     & (cur_subprogram ^= first_subprogram | cur_subprogram ^= last_subprogram)
						/* but not the only subprogram */
		then do;
			node_ptr = addr (x (cur_subprogram));
			if node_ptr -> subprogram.symbol ^= 0
						/* name is associated with the program unit */
			then do;
				call ioa_ ("^/^-Messages for ^a:",
				     addr (x (node_ptr -> subprogram.symbol)) -> symbol.name);

				last_error_subprogram = cur_subprogram;
			     end;
		     end;


/* expand error text if needed for listing or terminal */

		arg_string (1) = "";
		arg_string (2) = "";
		arg_string (3) = "";

		noprds = message_structure.number_of_operands;

		do i = 1 to noprds;

/* Caller can provide a character string */

		     if message_structure.operands (i).is_string
		     then do;
			     arg_length = message_structure.operands (i).string_length;
			     arg_string (i) = message_structure.operands (i).string_ptr -> arg_char_string;
			end;

/* or caller can provide a count */

		     else if message_structure.operands (i).operand_index < 0
		     then arg_string (i) = binary_to_char (bias + message_structure.operands (i).operand_index);

/* or caller can provide an operand offset */

		     else do;
			     arg_string (i) =
				identify_node (addr (x (message_structure.operands (i).operand_index)));
			end;			/* code for operand offset */
		end;				/* loop thru args */

/* get message out of error message table  */

		message_length = fixed (fort_message_table$fort_message_table.descrip (a_message_number).length, 17);
		message_offset = fixed (fort_message_table$fort_message_table.descrip (a_message_number).offset, 17);

		table_base = ptr (addr (fort_message_table$fort_message_table), 0);


/* build header string for error message */

		if an_error_level = 1
		then do;
			header_line = "WARNING ";
			header_line = header_line || binary_to_char (a_message_number);
		     end;

		else if an_error_level = max_error_level
		then do;
			header_line = "FATAL ERROR ";
			header_line = header_line || binary_to_char (a_message_number);
		     end;

		else do;
			header_line = "ERROR ";
			header_line = header_line || binary_to_char (a_message_number);
			header_line = header_line || ", severity ";
			header_line = header_line || binary_to_char ((an_error_level));
		     end;

/* add source line info, if it exists */

		header_line = header_line || decode_source_id ((cur_statement), intermediate_base, use_source_info);

/* print message on terminal if requested by user */

		if print_on_terminal
		then do;

			call ioa_ ("^/^a", header_line);
						/* print header for this error message */

/* determine if message text is necessary */

			if shared_globals.options.brief | substr (message_printed, a_message_number, 1)
			then if noprds > 0
			     then call ioa_ ("^v(^a^x^)", noprds, arg_string (1), arg_string (2), arg_string (3));
			     else ;
			else do;
				call ioa_ (formating_string, arg_string (1), arg_string (2), arg_string (3));
				substr (message_printed, a_message_number, 1) = "1"b;
			     end;

/* if debugging call probe */

			if string (shared_globals.options.system_debugging) ^= "0"b
			then do;
				call ioa_$nnl ("Calling probe:");
				call probe ();
			     end;
		     end;

/* save error text if producing a listing */

		if produce_listing
		then do;

/* Make educated guess for returned string length. Actual string may be shorter. */

			call create_listing_node (length (header_line) + 2 + message_length
			     + length (arg_string (1))
			     + length (arg_string (2)) + length (arg_string (3)));

/* Have ioa_ do the hard work for us. Just the control string is copied by compiler. */

			call ioa_$rsnp ("^/^a^/" || formating_string,
						/* control string */
			     p -> error_text.string,
						/* target string */
			     error_text_length,	/* actual length of error message */
			     header_line,
			     arg_string (1), arg_string (2), arg_string (3));
						/* substituted strings */

			call finish_listing_node;
		     end;
	     end;


	error_level = max (error_level, an_error_level);

	fortran_severity_ = error_level;

	if error_level >= max_error_level
	then goto fort_abort;
	return;


print_message_op$epilogue:
     entry;					/* Prints outstanding count information at end of compilation. */

	if begin_statement_errors > 0
	then do;
		do i = begin_statement_errors to msg_table_len;
		     call print_message_summary (i, "statement");
		end;
		msg_table_len = begin_statement_errors - 1;
	     end;

	if begin_subprogram_errors > 0
	then do;
		do i = begin_subprogram_errors to msg_table_len;
		     call print_message_summary (i, "subprogram");
		end;
		msg_table_len = begin_subprogram_errors - 1;
	     end;

	do i = 1 to msg_table_len;
	     call print_message_summary (i, "compilation");
	end;
	return;


print_message_summary:
     procedure (entry, type);				/* Procedure to print summary lines. */

dcl	entry		fixed bin (18);
dcl	lvl		fixed bin (18);
dcl	msg		fixed bin (18);
dcl	type		char (32) varying;

	if error_msg (entry).count = 0
	then return;

	msg = error_msg (entry).number;
	lvl = fort_message_table$fort_message_table.descrip (msg).level;

	if ^produce_listing & (lvl < shared_globals.options.severity)
	then return;

	if lvl = 1
	then header_line = "^/WARNING ^d";
	else header_line = "^/ERROR ^d";

	if error_msg (entry).opnd > 0
	then do;
		header_line = header_line || ", for ";
		header_line = header_line || identify_node (addr (x (error_msg (entry).opnd)));
		header_line = header_line || ",";
	     end;

	header_line = header_line || " has occurred an additional ";

	if error_msg (entry).count = 1
	then header_line = header_line || "time in this ^a.";
	else do;
		header_line = header_line || binary_to_char ((error_msg (entry).count));
		header_line = header_line || " times in this ^a.";
	     end;

	if lvl >= shared_globals.options.severity
	then call ioa_ (header_line, msg, type);

	if produce_listing
	then do;
		call create_listing_node (length (header_line) + length (type) + 3);

		call ioa_$rsnp (header_line,		/* control string */
		     p -> error_text.string,
						/* target string */
		     error_text_length,		/* actual length */
		     msg, type);
						/* substituted strings */

		call finish_listing_node;
	     end;
     end /* print_message_summary */;


create_listing_node:
     procedure (estimated_length);

dcl	estimated_length	fixed bin (18);

/* except during the parse, this routine must first find the correct listing_info node */

	if listing_info.subprogram ^= cur_subprogram
	then do;
		node_ptr = cur_listing;		/* remember current node to prevent infinite loop */
		do cur_listing = addr (listing_seg (listing_info.next))
		     repeat addr (listing_seg (listing_info.next))
		     while (cur_listing ^= node_ptr & listing_info.subprogram ^= cur_subprogram);
		end;

		if listing_info.subprogram ^= cur_subprogram
		then call abort_compiler ("Cannot find listing_info node for the current subprogram.");
	     end;

	p = addr (listing_seg (next_free_listing));	/* point to new error_text node */

	p -> error_text.length = estimated_length;
     end /* create_listing_node */;



finish_listing_node:
     procedure;

	p -> error_text.length = error_text_length;

	if last_error = 0
	then first_error = next_free_listing;
	else addr (listing_seg (last_error)) -> error_text.next = next_free_listing;

	last_error = next_free_listing;

	next_free_listing = next_free_listing + size (error_text);
     end /* finish_listing_node */;


identify_node:
     procedure (a_node_ptr) returns (char (260) varying);

dcl	a_node_ptr	ptr;

	node_ptr = a_node_ptr;
	a_node_type = node_ptr -> node.node_type;

	if a_node_type = constant_node
	then do;
		return (print_constant_value (node_ptr, "1"b));
	     end;

	else if a_node_type = char_constant_node
	then do;
		return (print_constant_value (node_ptr, "1"b));
	     end;

	else if a_node_type = temporary_node
	then return ("an expression");

	else if a_node_type = array_ref_node
	then do;
		node_ptr = addr (x (node_ptr -> array_ref.parent));
		return ("element in array " || node_ptr -> symbol.name);
	     end;

	else if a_node_type = symbol_node
	then return (node_ptr -> symbol.name);

	else if a_node_type = label_node
	then return (binary_to_char ((node_ptr -> label.name)));

	else if a_node_type = header_node
	then if node_ptr -> header.in_common
	     then return (node_ptr -> header.block_name);
	     else return ("equivalence group");

	else do;
		return ("NODE" || binary_to_char ((message_structure.operands (i).operand_index)));
	     end;
     end /* identify_node */;
     end /* print_message_op */;



binary_to_char:
     proc (value) returns (char (12) varying);

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

	output = value;
	return (substr (output, verify (output, " ")));
     end binary_to_char;


/* If line number = 0 then output "on or after line 16384", THIS IS A SPECIAL CASE. */

decode_source_id:
     proc (stmnt_off, int_base, use_source_info) returns (char (64) varying);

dcl	stmnt_off		fixed bin (18);
dcl	int_base		ptr;
dcl	use_source_info	bit (1) aligned;

dcl	id_line		char (64) varying;
dcl	i		fixed bin (18);
dcl	1 source_id	auto unaligned like statement.source_id;

	id_line = "";

	if stmnt_off > 0
	then do;
		if int_base = polish_base
		then source_id = addr (polish_string (stmnt_off)) -> statement.source_id;
		else source_id = addr (quad (stmnt_off)) -> opt_statement.source_id;

		if source_id.line ^= "0"b | use_source_info = "1"b
		then do;
			i = binary (source_id.statement, 5);
			if use_source_info = "1"b &
			     source_line_number ^= binary (source_id.line, 14)
			then i = 0;		/* If not right statement */
			if i > 1			/* don't mention statement no. 1 explicitly */
			then do;
				id_line = id_line || " in statement ";
				id_line = id_line || binary_to_char (i);
			     end;

			if use_source_info
			then i = source_line_number;
			else i = binary (source_id.line, 14);

			if i = 0
			then
			     id_line = id_line || " on or after line 16384";
			else do;
				id_line = id_line || " on line ";
				id_line = id_line || binary_to_char (i);
			     end;

			if use_source_info
			then i = source_file_number;
			else i = binary (source_id.file, 8);

			if i ^= 0			/* only print file no for second thru nth file */
			then do;
				id_line = id_line || " of file ";
				id_line = id_line || binary_to_char (i);
			     end;
		     end;
	     end;
	else if use_source_info
	then do;					/* NO CURRENT STATEMENT */
		id_line = id_line || " on line " || binary_to_char ((source_line_number));
		if source_file_number > 0
		then id_line = id_line || " of file " || binary_to_char ((source_file_number));
	     end;
	return (id_line);
     end decode_source_id;

print_constant_value:
     procedure (n_ptr, need_hdr) returns (char (256) varying);

dcl	based_bit		bit (1) aligned based;
dcl	1 based_double	aligned based,
	  2 based_dp	float bin (63) unaligned;
dcl	based_integer	fixed bin (35) aligned based;
dcl	based_real	float bin (27) aligned based;
dcl	chars		(2) char (4) aligned;
dcl	cs		char (256) varying;
dcl	(i, j, k, l)	fixed bin (18);
dcl	ltrim		builtin;
dcl	min		builtin;
dcl	n_ptr		pointer;
dcl	need_hdr		bit (1) aligned;
dcl	node_ptr		pointer;
dcl	piece		char (24);
dcl	rtrim		builtin;
dcl	value_ptr		pointer;

	node_ptr = n_ptr;

	if node_ptr -> node.data_type <= 0 | node_ptr -> node.data_type > hbound (print_routine, 1)
	then return ("UNKNOWN DATA TYPE");

	cs = "";					/* initialize */
	value_ptr = addr (node_ptr -> constant.value);
	goto print_routine (node_ptr -> node.data_type);


print_routine (1):					/* integer */
	if need_hdr
	then cs = "integer constant ";

	cs = cs || ltrim (convert (cs, value_ptr -> based_integer));
	return (cs);


print_routine (2):					/* real */
	if need_hdr
	then cs = "real constant ";

	cs = cs || trim_floating (value_ptr, "e");
	return (cs);


print_routine (3):					/* double precision */
	if need_hdr
	then cs = "double precision constant ";

	cs = cs || trim_floating (value_ptr, "d");
	return (cs);


print_routine (4):					/* complex */
	if need_hdr
	then cs = "complex constant ";

	cs = cs || "(";
	cs = cs || trim_floating (value_ptr, "e");
	cs = cs || ", ";
	cs = cs || trim_floating (addrel (value_ptr, 1), "e");
	cs = cs || ")";
	return (cs);


print_routine (5):					/* logical */
	if need_hdr
	then cs = "logical value ";

	if value_ptr -> based_bit
	then cs = cs || ".true.";
	else cs = cs || ".false.";
	return (cs);


print_routine (6):					/* character */
	if node_ptr -> char_constant.no_value_stored
	then return ("NO VALUE STORED");

	if verify (node_ptr -> char_constant.value,
	     " !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~") = 0
	then do;
		if need_hdr
		then cs = """";
		cs = cs || node_ptr -> char_constant.value;
		if need_hdr
		then cs = cs || """";
	     end;

	else do;
		cs = "
";
		do i = 1 to node_ptr -> char_constant.length by chars_per_word;
		     l = min (chars_per_word, node_ptr -> char_constant.length - i + 1);

		     chars (1) = substr (node_ptr -> char_constant.value, i, l);
		     chars (2) = chars (1);

		     do j = 1 to l;
			k = binary (unspec (substr (chars (2), j, 1)), 9);
			if k < 32 | k > 127		/* i.e. non-printable */
			then substr (chars (2), j, 1) = ".";
		     end;

		     call ioa_$rsnp ("^-^wo  ^a", piece, k, unspec (chars (1)), substr (chars (2), 1, l));
		     if l < chars_per_word
		     then substr (piece, l * 3 + 2, (chars_per_word - l) * 3) = " ";

		     if length (cs) + k > 256
		     then do;
			     call ioa_ ("^/String too long for format.");
			     cs = substr (cs, 1, length (cs) - 1);
						/* remove final newline char */
			     call ioa_ (cs);
			     cs = "
";
			end;

		     cs = cs || substr (piece, 1, k);
		end;

		cs = substr (cs, 1, length (cs) - 1);	/* remove final newline char */
	     end;
	return (cs);



trim_floating:
     proc (fpn_ptr, expon_char) returns (char (36) varying);


dcl	expon_char	char (1) aligned;
dcl	fpn_ptr		ptr;

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

dcl	fpn_prec		fixed bin (35);
dcl	fpn_type		fixed bin;
dcl	ret_value		char (36) varying;
dcl	temp		char (36) varying;
%include std_descriptor_types;

	if expon_char = "d"
	then do;
		fpn_prec = 63;
		if shared_globals.options.hfp
		then fpn_type = ft_hex_double_dtype;
		else fpn_type = ft_double_dtype;
	     end;
	else do;
		fpn_prec = 27;
		if shared_globals.options.hfp
		then fpn_type = ft_hex_real_dtype;
		else fpn_type = ft_real_dtype;
	     end;
	call assign_ (addr (temp), 2 * varying_char_dtype, maxlength (temp), fpn_ptr, 2 * fpn_type + 1, fpn_prec);
	temp = ltrim (rtrim (temp));			/* trim off all blanks */

/* trim off low order zeroes */

	if substr (temp, 1, 1) = "0"
	then ret_value = rtrim (substr (temp, 1, length (temp) - 5), "0");
						/* all digits are significant */
	else ret_value = rtrim (substr (temp, 1, length (temp) - 6), "0");
						/* last digit is really noise */

	if substr (ret_value, length (ret_value), 1) = "."
	then ret_value = ret_value || "0";

	if substr (temp, length (temp) - 4, 5) ^= "e+000" /* convert exponent if not zero */
	then do;
		temp = substr (temp, length (temp) - 4, 5);
						/* makes the rest easier to read */

		ret_value = ret_value || expon_char;	/* get proper character */
		ret_value = ret_value || substr (temp, 2, 1);
						/* exponent sign */
		if substr (temp, 3, 1) ^= "0"
		then ret_value = ret_value || substr (temp, 3, 3);
		else if substr (temp, 4, 1) ^= "0"
		then ret_value = ret_value || substr (temp, 4, 2);
		else ret_value = ret_value || substr (temp, 5, 1);
						/* exponent value */
	     end;

	return (ret_value);
     end /* trim_floating */;
     end print_constant_value;

fort_display:
     proc (command_structure_ptr);


/* Operator Names */
declare	count_array	(-3:109) fixed bin (18),	/* must have same upper bound as op_names */
	op_names		(-3:109) char (20) aligned int static options (constant)
			initial (/* WARNING - change "count_array" */ "quadruple", "operand", "count", "zero",
			"assign",
			"add", "sub", "mult", "div", "exponentiation", "negate", "less", "less_or_equal", "equal",
			"not_equal", "greater_or_equal", "greater", "or", "and", "not", "jump", "jump_logical",
			"jump_arithmetic", "jump_computed", "jump_assigned", "assign_label", "read", "write",
			"format",
			"end_label", "error_label", "xmit_scalar", "xmit_array", "xmit_vector", "endfile", "rewind",
			"backspace", "margin", "openfile", "closefile", "record_number", "string", "string_length",
			"terminate", "return", "pause", "stop", "item", "exit", "eol", "do", "builtin", "sf",
			"sf_def",
			"subscript", "func_ref", "block_data", "increment_polish", "main", "function", "subroutine",
			"stat", "label", "call", "chain", "endunit", "non_executable", "no_op",
			"form_VLA_packed_ptr",
			"opt_subscript", "left_shift", "right_shift", "store_zero", "storage_add", "storage_sub",
			"neg_storage_add", "storage_add_one", "namelist", "open", "close", "iostat",
			"convert_to_int",
			"convert_to_real", "convert_to_dp", "convert_to_cmpx", "read_scalar", "read_array",
			"read_vector", "write_scalar", "write_array", "write_vector", "jump_true", "jump_false",
			"sub_index", "loop_end", "read_namelist", "write_namelist", "decode_string",
			"encode_string",
			"cat", "substr", "load_xreg", "load_preg", "block_if", "else_if", "else", "equiv",
			"not_equiv", "read_internal_file", "write_internal_file", "inquire", "process_param_list",
			"lhs_fld");


dcl	node_names	(0:15) char (24)
			init ("filler", "source", "symbol", "dimension", "temporary", "constant", "label", "header",
			"character constant", "array_ref", "proc_frame", "library", "subprogram", "arg_desc",
			"pointer",
			"machine_state") int static options (constant);



dcl	node_size		(0:15) fixed bin (18);

	node_size (0) = 1;				/* filler */
	node_size (1) = 0;				/* source */
	node_size (2) = 0;				/* symbol */
	node_size (3) = 0;				/* dimension */
	node_size (4) = size (temporary);		/* temporary */
	node_size (5) = size (constant);		/* constant */
	node_size (6) = size (label);			/* label */
	node_size (7) = 0;				/* header */
	node_size (8) = 0;				/* character constant */
	node_size (9) = size (array_ref);		/* array ref */
	node_size (10) = 12;			/* proc frame */
	node_size (11) = size (library);		/* library */
	node_size (12) = size (subprogram);		/* subprogram */
	node_size (13) = 0;				/* arg desc */
	node_size (14) = size (pointer);		/* pointer */
	node_size (15) = size (machine_state);		/* machine_state */



dcl	mode_names	(0:7) char (24)
			init ("undefined", "integer", "real", "double precision", "complex", "logical", "character",
			"typeless")
			int static options (constant);



dcl	operand_names	(0:12) char (24)
			init ("undefined", "variable", "constant", "array reference", "temporary", "count",
			"relative constant", "bif", "statement function", "external", "entry", "dummy", "error")
			int static options (constant);

dcl	offset_unit_names	(0:7) character (16)
			initial ("word_units", "bit_units", "char_units", "halfword_units",
			"UNUSED", "UNUSED", "UNUSED", "UNUSED")
			int static options (constant);

dcl	subr_type		(0:3) char (12) int static options (constant)
			init ("main program", "block data  ", "subroutine  ", "function    ");

dcl	(
	all_fields	init ("1"b),
	(just_name, dont_walk)
			init ("0"b)
	)		bit (1) aligned int static options (constant);

dcl	ons		char (256) varying;
dcl	source_segment	character (csi.input_lng) based (csi.input_pointer);
dcl	stat_start	fixed binary (27);
dcl	stat_length	fixed binary (9);
dcl	cs		ptr;
dcl	sp		ptr;

dcl	first_time	bit (1) aligned;

dcl	n		fixed bin (18),
	nodetype		fixed bin (18),
	offset		fixed bin (18);

dcl	command_structure_ptr
			ptr;
dcl	i		fixed bin (18);
dcl	(subp, next_one, item)
			fixed bin (18);

dcl	1 command_structure structure aligned based (command_structure_ptr),
%include fort_command_structure;

/* display polish for the current statement */

	if command_structure.cur_stmnt
	then do;
		if cur_statement < 0		/* no current statement */
		then do;
			call ioa_ ("cur_statement = ^oo", cur_statement);
			return;
		     end;

		if intermediate_base = polish_base
		then do;
			if polish_string (cur_statement) ^= stat_op
						/* cur_statement does not point to correct polish */
			then do;
				call ioa_ ("cur_statement = ^oo", cur_statement);
				call display_int_text ((cur_statement), (cur_statement));
				return;
			     end;

/* Get offset of last polish word. If next statement exists, last polish word
		   is one less than next statement's first word. If next does not exist, this
		   is last statement of a subprogram or the last statement parsed so far. It is
		   the last statement parsed if subprogram.last_polish is still zero. */

			offset = binary (addr (polish_string (cur_statement)) -> statement.next, 18) - 1;

			if offset < 0
			then if addr (x (cur_subprogram)) -> subprogram.last_polish = 0
			     then offset = next_free_polish - 1;
			     else offset = addr (x (cur_subprogram)) -> subprogram.last_polish;

			call display_int_text ((cur_statement), (offset));
		     end;

		else do;
			sp = addr (quad (cur_statement));

			if sp -> opt_statement.op_code ^= stat_op
			then do;
				call ioa_ ("cur_statement = ^oo", cur_statement);
				call display_quadruples ((cur_statement), (cur_statement));
				return;
			     end;

			offset = binary (sp -> opt_statement.next, 18);

			if offset > 0
			then offset = addr (quad (offset)) -> opt_statement.prev_operator;

			call display_quadruples ((cur_statement), (offset));
		     end;
	     end;


/* display all polish for all statements whose line number is "starting_offset" */

	if command_structure.stmnt & ^region.quadruple
	then do;
		first_time = "1"b;			/* to get into the inner loop the first time */

		do subp = first_subprogram repeat cs -> subprogram.next_subprogram while (subp > 0);
		     cs = addr (x (subp));

		     do item = cs -> subprogram.first_polish repeat next_one while (item > 0 | first_time);
			sp = addr (polish_string (item));
			next_one = binary (sp -> statement.next, 18);

			if binary (sp -> statement.line, 18) = starting_offset
			then do;

/* Get offset of last polish word. If next statement exists, last polish word
			   is one less than next statement's first word. If next does not exist, this
			   is last statement of a subprogram or the last statement parsed so far. It is
			   the last statement parsed if subprogram.last_polish is still zero. */

				offset = next_one - 1;

				if offset < 0
				then if cs -> subprogram.last_polish = 0
				     then offset = next_free_polish - 1;
				     else offset = cs -> subprogram.last_polish;

				call display_int_text ((item), (offset));
			     end;

			first_time = "0"b;
		     end;

		end;

		call ioa_ ("Search for line ^d completed.", starting_offset);
	     end;

/* display all quads for all statements whose line number is starting_offset */

	if command_structure.stmnt & region.quadruple
	then do;
		do subp = first_subprogram repeat cs -> subprogram.next_subprogram while (subp > 0);
		     cs = addr (x (subp));

		     do item = cs -> subprogram.first_quad repeat next_one while (item > 0);
			sp = addr (quad (item));
			next_one = binary (sp -> opt_statement.next, 18);

			if binary (sp -> opt_statement.line, 18) = starting_offset
			then do;
				if next_one > 0
				then offset = addr (quad (next_one)) -> opt_statement.prev_operator;
				else offset = next_one;

				call display_quadruples ((item), (offset));
			     end;
		     end;
		end;

		call ioa_ ("Search for line ^d completed.", starting_offset);
	     end;


/* display all symbols whose name is specified in "dcl_name" */

	if command_structure.declaration
	then do;
						/* look thru entire operand region */

		do offset = hash_table_size repeat offset + get_node_size (node_ptr)
		     while (offset < next_free_operand);

		     node_ptr = addr (x (offset));

		     if node_ptr -> node.node_type = symbol_node
		     then if node_ptr -> symbol.name = dcl_name
			then call display_node ((offset), ^command_structure.brief, (command_structure.walk));

		     if node_ptr -> node.node_type = header_node
		     then if node_ptr -> header.in_common
			then if node_ptr -> header.block_name = dcl_name
			     then call display_node ((offset), ^command_structure.brief, (command_structure.walk));
		end;

		call ioa_ ("Search for symbol ^a completed.", dcl_name);
	     end;


/* display a portion of the operand region or the polish region */

	if command_structure.display
	then do;
		if region.operand
		then do;
			offset = max (starting_offset, hash_table_size);
			stopping_offset = max (stopping_offset, offset);

			do while (offset <= stopping_offset);
			     call display_node ((offset), ^command_structure.brief, (command_structure.walk));
			     offset = offset + get_node_size (addr (x (offset)));
			end;
		     end;

		else if region.polish
		then call display_int_text ((starting_offset), (stopping_offset));

		else if region.quadruple
		then call display_quadruples ((starting_offset), (stopping_offset));

		else do;
			call ioa_ ("polish- ^p, operand- ^p, object- ^p", polish_base, operand_base, object_base);
		     end;
	     end;


/* dump an entire region */

	if command_structure.dump
	then do;

		if region.operand
		then do offset = hash_table_size repeat offset + get_node_size (addr (x (offset)))
			while (offset < next_free_operand);
			call display_node ((offset), ^command_structure.brief, dont_walk);
		     end;

		if region.polish
		then call display_int_text (1, next_free_polish - 1);

		else if region.quadruple
		then do subp = first_subprogram repeat cs -> subprogram.next_subprogram while (subp > 0);
			cs = addr (x (subp));
			call display_quadruples ((cs -> subprogram.first_quad), 0);
		     end;

	     end;


/* display all known numeric and logical constants */

	if command_structure.list_word_consts
	then do;

		do offset = first_word_constant repeat addr (x (offset)) -> constant.next_constant while (offset > 0);
		     call display_node ((offset), ^command_structure.brief, dont_walk);
		end;

		do offset = first_dw_constant repeat addr (x (offset)) -> constant.next_constant while (offset > 0);
		     call display_node ((offset), ^command_structure.brief, dont_walk);
		end;

		if first_word_constant = 0 & first_dw_constant = 0
		then call ioa_ ("No numeric or logical constants.");
	     end;


/* display all known character constants */

	if command_structure.list_char_constants
	then if first_char_constant = 0
	     then call ioa_ ("No character constants.");
	     else do offset = first_char_constant repeat addr (x (offset)) -> char_constant.next_constant
		     while (offset > 0);

		     call display_node ((offset), ^command_structure.brief, dont_walk);
		end;


/* display all character constants on library chain */

	if command_structure.list_lib_names
	then if first_lib_name = 0
	     then call ioa_ ("No library names.");
	     else do offset = first_lib_name repeat addr (x (offset)) -> library.next_library_node while (offset > 0);

		     call display_node ((addr (x (offset)) -> library.character_operand), ^command_structure.brief,
			dont_walk);
		end;


/* count nodes in operand region */

	if command_structure.node_summary
	then do;
		unspec (count_array) = "0"b;

		call ioa_ ("^/^-  #^-Node^/");

		do n = hash_table_size repeat n + get_node_size (node_ptr) while (n < next_free_operand);
		     node_ptr = addr (x (n));
		     nodetype = node_ptr -> node.node_type;

		     count_array (nodetype) = count_array (nodetype) + 1;
		end;

		do n = 0 to hbound (node_names, 1);
		     if count_array (n) > 0
		     then call ioa_ ("^-^5d ^a", count_array (n), node_names (n));
		end;

		unspec (count_array) = "0"b;

		call ioa_ ("^/^-  #^-Operator/Operand^/");

		i = 1;
		do while (i < next_free_polish);

		     n = polish_string (i);
		     i = i + 1;

		     if n < 0
		     then count_array (-1) = count_array (-1) + 1;
						/* a count */

		     else if n = 0
		     then count_array (0) = count_array (0) + 1;
						/* a zero */

		     else if n <= hbound (op_names, 1)
		     then do;
			     count_array (n) = count_array (n) + 1;
						/* an operator */

			     if n = stat_op
			     then i = i + size (statement) - 1;

			     else if n = increment_polish_op
			     then i = i + polish_string (i) + 1;
			end;

		     else count_array (-2) = count_array (-2) + 1;
						/* an operand */
		end;

		do i = lbound (op_names, 1) to hbound (op_names, 1);

		     if count_array (i) > 0
		     then call ioa_ ("^-^5d ^a", count_array (i), op_names (i));
		end;
	     end;


/* display all subprogram nodes */

	if command_structure.list_subprograms
	then do offset = first_subprogram repeat addr (x (offset)) -> subprogram.next_subprogram while (offset > 0);
		call display_node ((offset), ^command_structure.brief, (command_structure.walk));
	     end;


/* display specified buckets in all subprograms */

	if command_structure.bucket
	then do;
		starting_offset = max (1, starting_offset);
		stopping_offset = min (stopping_offset, hbound (node_ptr -> subprogram.storage_info, 1));

		do subp = first_subprogram repeat cs -> subprogram.next_subprogram while (subp > 0);
		     cs = addr (x (subp));

		     first_time = "1"b;		/* only print info if a bucket is found */

		     do i = starting_offset to stopping_offset;
			offset = cs -> subprogram.storage_info (i).first;

			if offset ^= 0
			then do;
				if first_time
				then call display_node ((subp), just_name, dont_walk);
				first_time = "0"b;
				call ioa_ ("^/Bucket ^d", i);
			     end;

			do while (offset > 0);
			     call display_node ((offset), just_name, dont_walk);
			     offset = addr (x (offset)) -> node.next;
			end;			/* loop thru a single bucket chain */
		     end;				/* loop thru a subprogram's buckets */
		end;				/* loop thru subprograms */

		call ioa_ ("Search for buckets ^d thru ^d completed.", starting_offset, stopping_offset);
	     end;

abort_display:
	return;

display_int_text:
     proc (start, stop);				/* displays a portion of the polish string */

dcl	(an_offset, content)
			fixed bin (18);
dcl	(start, stop)	fixed bin (18);
dcl	op_ptr		ptr;

	an_offset = start;

	do while (an_offset <= stop);

	     content = polish_string (an_offset);
	     an_offset = an_offset + 1;		/* move to next polish word */

	     if content < 0				/* COUNT */
	     then call ioa_ ("^/COUNT: ^d", content + bias);

	     else if content = 0			/* ZERO */
	     then call ioa_ ("^/ZERO");

	     else if content <= hbound (op_names, 1)	/* printable OPERATOR */
	     then do;
		     call ioa_ ("^/OPERATOR @ ^oo: ^a", an_offset - 1, op_names (content));

		     if content = stat_op
		     then do;
			     op_ptr = addr (polish_string (an_offset - 1));
			     stat_start = binary (op_ptr -> statement.start, 26);
			     stat_length = binary (op_ptr -> statement.length, 9);

			     call ioa_ ("^4x^a start ^d, length ^d,  next ^oo, obj ^oo",
				decode_source_id (an_offset - 1, polish_base, "0"b), stat_start,
				stat_length, binary (op_ptr -> statement.next, 18),
				binary (op_ptr -> statement.location, 18));

			     if op_ptr -> statement.put_in_profile
			     then call ioa_ ("^5xPut in profile.");
			     else if op_ptr -> statement.put_in_map
			     then call ioa_ ("^5xPut in map.");
			     else call ioa_ ("^5xNot in map or profile.");
			     call ioa_ ("^/^5x^a", substr (source_segment, stat_start + 1, stat_length));
			     an_offset = an_offset + size (statement) - 1;
						/* stat_op is more than one word long */
			end;

		     else if content = increment_polish_op
		     then do;
			     if command_structure.walk
			     then call dump_words (addr (polish_string (an_offset + 1)), polish_string (an_offset));

			     an_offset = an_offset + polish_string (an_offset) + 1;
						/* skip over data words */
			end;
		end;				/* printable operator */

	     else if content < hash_table_size		/* unknown OPERATOR */
	     then call ioa_ ("^/OPERATOR @ ^oo: ^d", an_offset - 1, content);

	     else if content < next_free_operand	/* OPERAND */
	     then call display_node ((content), just_name, dont_walk);

	     else call ioa_ ("^/VALUE: ^wo", content);
	end;

     end display_int_text;

dump_words:
     proc (a_base, a_count);

dcl	a_base		ptr;
dcl	a_count		fixed bin (18);
dcl	bp		ptr;
dcl	(count, i)	fixed bin (18);
dcl	w		(4) bit (36) aligned based;

	bp = a_base;
	count = a_count;

	do i = 0 to count - 1 by 4;
	     call ioa_ ("^12oo:^v(^x^wo^)", binary (rel (bp), 18), min (4, count - i), bp -> w);
	     bp = addrel (bp, 4);
	end;
     end /* dump_words */;

get_node_size:
     proc (pt) returns (fixed bin (18));

dcl	(p, pt)		ptr;
dcl	node_type		fixed bin (18);
dcl	currentsize	builtin;

	p = pt;
	node_type = p -> node.node_type;

	if node_type < 0 | node_type > hbound (node_size, 1)
	then do;
unknown_node:
		call ioa_ ("Compiler error: Unknown node ^d at ^p to ""get_node_size"".", node_type, p);
		goto abort_display;
	     end;

	if node_size (node_type) ^= 0
	then return (node_size (node_type));

	if node_type = symbol_node
	then do;
		return (currentsize (p -> symbol));
	     end;

	if node_type = header_node
	then do;
		return (currentsize (p -> header));
	     end;

	if node_type = char_constant_node
	then do;
		if p -> char_constant.no_value_stored
		then char_constant_length = 0;
		else char_constant_length = p -> char_constant.length;

		return (size (char_constant));
	     end;

	if node_type = dimension_node
	then return (currentsize (p -> dimension));

	if node_type = source_node
	then return (size (source) - divide (256 - length (p -> source.pathname), 4, 17, 0));

	if node_type = arg_desc_node
	then do;
		return (currentsize (p -> arg_desc));
	     end;

	goto unknown_node;
     end get_node_size;

display_node:
     proc (an_offset, dump_sw, walk_sw);

dcl	a_node_type	fixed bin (18);
dcl	an_offset		fixed bin (18);
dcl	chain		fixed bin (18);
dcl	dump_sw		bit (1) aligned;
dcl	eaq_names		(0:17) char (8) aligned int static options (constant)
			init ("EMPTY", "Q", "A", "AQ", "EAQ", "DEAQ", "IEAQ", "IQ", "IND", "INVALID", "TZE", "TNZ",
			"TMI", "TPL", "TMOZ", "TPNZ", "TNC", "TRC");
dcl	eaq_regs		(4) char (4) aligned int static options (constant)
			init ("A", "Q", "EAQ", "IND");
dcl	everything	bit (1) aligned;
dcl	(ft, ls, nx)	fixed bin (18);
dcl	node_offset	fixed bin (18);
dcl	node_ptr		ptr;
dcl	prt_sw		bit (1) aligned;
dcl	walk_chains	bit (1) aligned;
dcl	walk_sw		bit (1) aligned;
dcl	i		fixed bin;

/* copy input arguments */

	node_offset = an_offset;
	everything = dump_sw;
	walk_chains = walk_sw | ^everything;		/* make sure brief means BRIEF!! */

/* validate our input */

	if node_offset < hash_table_size | node_offset >= next_free_operand
	then do;
		call ioa_ ("Operand offset ^oo is not valid.", node_offset);
		return;
	     end;

	node_ptr = addr (x (node_offset));

	a_node_type = node_ptr -> node.node_type;

	if a_node_type >= 0 & a_node_type <= hbound (node_names, 1)
	then call ioa_ ("^/^a NODE: ^oo", node_names (a_node_type), node_offset);
	else do;
unknown_node:
		call ioa_ ("^/unknown NODE ^d: ^oo", a_node_type, node_offset);
		return;
	     end;

	goto output_node (a_node_type);


output_node (0):					/* FILLER */
	if x (an_offset) ^= 0
	then call ioa_ ("^/^5x^wo", x (an_offset));
	return;


output_node (1):					/* SOURCE */
	if ^everything
	then return;

	call ioa_ ("^/^5xuid: ^wo, dtm: ^oo^/^5xnext: ^oo, subprogram: ^oo^/^5xpath: ^a", node_ptr -> source.uid,
	     node_ptr -> source.dtm, node_ptr -> source.next, node_ptr -> source.initial_subprogram,
	     node_ptr -> source.pathname);
	return;


output_node (2):					/* SYMBOL */
	call ioa_ ("^2xoperand type: ^a, data type: ^a, name: ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type), node_ptr -> symbol.name);

	if ^everything
	then return;

	call get_addressing_attributes;

/* special SYMBOL addressing attributes */

	if node_ptr -> symbol.initialed
	then ons = ons || "initialed ";
	if node_ptr -> symbol.variable_arglist
	then ons = ons || "variable_arglist ";
	if node_ptr -> symbol.dummy_arg
	then ons = ons || "dummy_arg ";
	if node_ptr -> symbol.variable_extents
	then ons = ons || "variable_extents ";
	if node_ptr -> symbol.needs_descriptors
	then ons = ons || "needs_descriptors ";
	if node_ptr -> symbol.put_in_symtab
	then ons = ons || "put_in_symtab ";
	if node_ptr -> symbol.by_compiler
	then ons = ons || "by_compiler ";

	if node_ptr -> symbol.aliasable
	then ons = ons || "aliasable ";
	if node_ptr -> symbol.has_constant_value
	then ons = ons || "has_constant_value ";
	if node_ptr -> symbol.new_induction_var
	then ons = ons || "new_induction_var ";

	if node_ptr -> symbol.integer
	then ons = ons || "integer ";
	if node_ptr -> symbol.real
	then ons = ons || "real ";
	if node_ptr -> symbol.double_precision
	then ons = ons || "double_precision ";
	if node_ptr -> symbol.complex
	then ons = ons || "complex ";
	if node_ptr -> symbol.logical
	then ons = ons || "logical ";
	if node_ptr -> symbol.character
	then do;
		ons = ons || "character(";
		ons = ons || binary_to_char (node_ptr -> symbol.char_size + 1);
		ons = ons || ") ";
	     end;
	if node_ptr -> symbol.label_value
	then ons = ons || "label_value ";
	if node_ptr -> symbol.entry_value
	then ons = ons || "entry_value ";
	if node_ptr -> symbol.function
	then ons = ons || "function ";
	if node_ptr -> symbol.subroutine
	then ons = ons || "subroutine ";
	if node_ptr -> symbol.entry_point
	then ons = ons || "entry_point ";
	if node_ptr -> symbol.external
	then ons = ons || "external ";
	if node_ptr -> symbol.builtin
	then do;
		ons = ons || "builtin(";
		ons = ons || binary_to_char ((node_ptr -> symbol.char_size));
		ons = ons || ") ";
	     end;
	if node_ptr -> symbol.stmnt_func
	then do;
		ons = ons || "stmnt_func(";
		ons = ons || binary_to_char ((node_ptr -> symbol.char_size));
		ons = ons || ") ";
	     end;
	if node_ptr -> symbol.namelist
	then ons = ons || "namelist ";
	if node_ptr -> symbol.dimensioned
	then ons = ons || "dimensioned ";
	if node_ptr -> symbol.automatic
	then ons = ons || "automatic ";
	if node_ptr -> symbol.static
	then ons = ons || "static ";
	if node_ptr -> symbol.in_common
	then ons = ons || "in_common ";
	if node_ptr -> symbol.equivalenced
	then ons = ons || "equivalenced ";
	if node_ptr -> symbol.parameter
	then ons = ons || "parameter ";
	if node_ptr -> symbol.constant
	then ons = ons || "constant ";
	if node_ptr -> symbol.named_constant
	then ons = ons || "named_constant ";
	if node_ptr -> symbol.variable
	then ons = ons || "variable ";
	if node_ptr -> symbol.in_equiv_stmnt
	then ons = ons || "in_equiv_stmnt ";
	if node_ptr -> symbol.star_extents
	then ons = ons || "star_extents ";
	if node_ptr -> symbol.descriptor
	then ons = ons || "descriptor ";

	call print_common_fields ("hash_chain");

	if node_ptr -> symbol.location ^= 0
	then call ioa_ ("^5xlocation: ^oo", node_ptr -> symbol.location);

	if node_ptr -> symbol.loop_ref_count ^= 0
	then call ioa_ ("^5xloop_ref_count: ^d", node_ptr -> symbol.loop_ref_count);

	if node_ptr -> symbol.element_size ^= 0
	then call ioa_ ("^5xelement_size: ^oo", node_ptr -> symbol.element_size);

	if node_ptr -> symbol.offset ^= 0
	then call ioa_ ("^5xoffset: ^oo", node_ptr -> symbol.offset);

	if node_ptr -> symbol.general ^= 0
	then call ioa_ ("^5xgeneral: ^oo", node_ptr -> symbol.general);

	if node_ptr -> symbol.parent ^= 0
	then call ioa_ ("^5xparent: ^oo", node_ptr -> symbol.parent);

	if node_ptr -> symbol.next_member ^= 0
	then call ioa_ ("^5xnext_member: ^oo", node_ptr -> symbol.next_member);

	if node_ptr -> symbol.v_length ^= 0
	then call ioa_ ("^5xv_length: ^oo", node_ptr -> symbol.v_length);

	if node_ptr -> symbol.dimension ^= 0
	then do;
		call ioa_ ("^5xdimension: ^oo", node_ptr -> symbol.dimension);
		if walk_chains
		then call display_node ((node_ptr -> symbol.dimension), all_fields, dont_walk);
	     end;

	if node_ptr -> symbol.initial ^= 0
	then do;
		call ioa_ ("^5xinitial: ^oo", node_ptr -> symbol.initial);
		if walk_chains & ^node_ptr -> symbol.namelist
		then do chain = node_ptr -> symbol.initial repeat polish_string (chain) while (chain > 0);
			call ioa_ ("^5x^5d * (^oo): ^a", polish_string (chain + 1), polish_string (chain + 2),
			     print_constant_value (addr (x (polish_string (chain + 2))), "1"b));
		     end;
	     end;

	if node_ptr -> symbol.runtime ^= "0"b
	then call ioa_ ("^5xruntime: ^oo", node_ptr -> symbol.runtime);

	if node_ptr -> symbol.coordinate ^= 0
	then call ioa_ ("^5xcoordinate: ^d", node_ptr -> symbol.coordinate);

	if node_ptr -> symbol.secondary ^= null & unspec (node_ptr -> symbol.secondary) ^= "0"b
	then call ioa_ ("^5xsecondary: ^p", node_ptr -> symbol.secondary);
	return;


output_node (3):					/* DIMENSION */
	if ^everything
	then return;

	if node_ptr -> dimension.assumed_size
	then call ioa_ ("^/^5xassumed_size");

	call ioa_ ("^/^5xndims: ^d", node_ptr -> dimension.number_of_dims);

	if node_ptr -> dimension.has_virtual_origin
	then if node_ptr -> dimension.variable_virtual_origin
	     then call ioa_ ("^5xv org operand: ^oo", node_ptr -> dimension.virtual_origin);
	     else call ioa_ ("^5xv org: ^d units", node_ptr -> dimension.virtual_origin);

	if node_ptr -> dimension.element_count ^= 0
	then call ioa_ ("^5xelement_count: ^d", node_ptr -> dimension.element_count);

	if node_ptr -> dimension.has_array_size
	then if node_ptr -> dimension.variable_array_size
	     then call ioa_ ("^5xarray size operand: ^oo", node_ptr -> dimension.array_size);
	     else call ioa_ ("^5xarray size: ^d units", node_ptr -> dimension.array_size);

	do chain = 1 to node_ptr -> dimension.number_of_dims;
	     call ioa_ ("^5xdimension ^d info:", chain);

	     if node_ptr -> dimension.v_bound (chain).lower
	     then do;
		     call ioa_ ("^10xlower bound operand: ^oo", node_ptr -> dimension.lower_bound (chain));
		     if walk_chains
		     then call display_node ((node_ptr -> dimension.lower_bound (chain)), all_fields, dont_walk);
		end;
	     else call ioa_ ("^10xlower bound: ^d", node_ptr -> dimension.lower_bound (chain));

	     if node_ptr -> dimension.v_bound (chain).upper
	     then do;
		     call ioa_ ("^10xupper bound operand: ^oo", node_ptr -> dimension.upper_bound (chain));
		     if walk_chains
		     then call display_node ((node_ptr -> dimension.upper_bound (chain)), all_fields, dont_walk);
		end;
	     else call ioa_ ("^10xupper bound: ^d", node_ptr -> dimension.upper_bound (chain));

	     if node_ptr -> dimension.has_dim_sizes
	     then if string (node_ptr -> dimension.v_bound (chain)) = "00"b
		then call ioa_ ("^10xsize: ^d", node_ptr -> dimension.size (chain));
		else call ioa_ ("^10xsize operand: ^oo", node_ptr -> dimension.size (chain));

	end;
	return;


output_node (4):					/* TEMPORARY */
	call ioa_ ("^2xoperand type: ^a, data type ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type));

	if node_ptr -> temporary.ref_count ^= 0
	then call ioa_ ("^5xref_count: ^d", node_ptr -> temporary.ref_count);

	if node_ptr -> temporary.ms_ref_count ^= 0
	then call ioa_ ("^5xMS ref_count: ^d", node_ptr -> temporary.ms_ref_count);

	if node_ptr -> temporary.ref_count_copy ^= 0
	then call ioa_ ("^5xref_count_copy: ^d", node_ptr -> temporary.ref_count_copy);

	if ^everything
	then return;

	call get_addressing_attributes;

	if node_ptr -> temporary.variable_length
	then ons = ons || "variable_length ";
	if node_ptr -> temporary.invariant
	then ons = ons || "invariant ";
	if node_ptr -> temporary.irreducible
	then ons = ons || "irreducible ";
	if node_ptr -> temporary.used_across_loops
	then ons = ons || "used_across_loops ";
	if node_ptr -> temporary.used_as_subscript
	then ons = ons || "used_as_subscript ";
	if node_ptr -> temporary.frozen_for_do
	then ons = ons || "frozen_for_do ";

	call print_common_fields ("loop_end_fu_pos");

	if node_ptr -> temporary.location ^= 0
	then call ioa_ ("^5xlocation: ^oo", node_ptr -> temporary.location);

	if node_ptr -> temporary.loop_ref_count ^= 0
	then call ioa_ ("^5xloop_ref_count: ^d", node_ptr -> temporary.loop_ref_count);

	if node_ptr -> temporary.length ^= 0
	then call ioa_ ("^5xchar length: ^[^oo^;^d^]", node_ptr -> temporary.variable_length,
		node_ptr -> temporary.length);

	if node_ptr -> temporary.size ^= 0
	then call ioa_ ("^5xsize in words: ^oo", node_ptr -> temporary.size);

	if node_ptr -> temporary.output_by ^= 0
	then call ioa_ ("^5xoutput_by: ^oo", node_ptr -> temporary.output_by);

	if node_ptr -> temporary.start_input_to ^= 0
	then call ioa_ ("^5xstart_input_to: ^oo", node_ptr -> temporary.start_input_to);

	if node_ptr -> temporary.end_input_to ^= 0
	then call ioa_ ("^5xend_input_to: ^oo", node_ptr -> temporary.end_input_to);
	return;


output_node (5):					/* CONSTANT */
	call ioa_ ("^2xoperand type: ^a, data type ^a, value ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type), print_constant_value (node_ptr, "0"b));

	if ^everything
	then return;

	call get_addressing_attributes;
	call print_common_fields ("hash_chain");
	return;


output_node (6):					/* LABEL */
	call ioa_ ("^2xoperand type: ^a, data type ^a, name ^d", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type), node_ptr -> label.name);

	if ^everything
	then return;

	call get_addressing_attributes;

	if node_ptr -> label.executable
	then if node_ptr -> label.format
	     then ons = ons || "declarative ";
	     else ons = ons || "executable ";
	else if node_ptr -> label.format
	then ons = ons || "format ";
	else ons = ons || "no_usage_attrs ";

	if node_ptr -> label.restore_prs
	then ons = ons || "restore_prs ";
	if node_ptr -> label.referenced_executable
	then ons = ons || "referenced_executable ";
	if node_ptr -> label.not_referencable
	then ons = ons || "not_referencable ";
	if node_ptr -> label.branched_to
	then ons = ons || "branched_to ";
	if node_ptr -> label.ends_do_loop
	then ons = ons || "ends_do_loop ";

	call print_common_fields ("hash_chain");

	if node_ptr -> label.loop_end ^= 0
	then call ioa_ ("^5xloop_end: ^oo", node_ptr -> label.loop_end);

	if node_ptr -> label.statement ^= 0
	then do;
		call ioa_ ("^5xstatement: ^oo", node_ptr -> label.statement);
		if walk_chains
		then call display_quadruples ((node_ptr -> label.statement), (node_ptr -> label.statement));
	     end;

	if node_ptr -> label.format_var ^= 0
	then do;
		call ioa_ ("^5xformat_var: ^oo", node_ptr -> label.format_var);
		if walk_chains
		then call display_node ((node_ptr -> label.format_var), all_fields, dont_walk);
	     end;
	return;


output_node (7):					/* HEADER */
	call ioa_ ("^2xoperand type: ^a, data type ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type));

	if node_ptr -> header.in_common
	then call ioa_ ("^5xcommon block: ^a", node_ptr -> header.block_name);

	if ^everything
	then return;

	call get_addressing_attributes;

/* get HEADER addressing attributes */

	if node_ptr -> header.initialed
	then ons = ons || "initialed ";
	if node_ptr -> header.even
	then ons = ons || "even ";
	if node_ptr -> header.odd
	then ons = ons || "odd ";
	if node_ptr -> header.character
	then ons = ons || "character ";
	if node_ptr -> header.automatic
	then ons = ons || "automatic ";
	if node_ptr -> header.static
	then ons = ons || "static ";
	if node_ptr -> header.in_common
	then ons = ons || "in_common ";

	call print_common_fields ("pad");

	if node_ptr -> header.length ^= 0
	then call ioa_ ("^5xlength: ^d", node_ptr -> header.length);

	if node_ptr -> header.location ^= 0
	then call ioa_ ("^5xlocation: ^oo", node_ptr -> header.location);

	if node_ptr -> header.first_element ^= 0
	then call ioa_ ("^5xfirst_element: ^oo", node_ptr -> header.first_element);

	if node_ptr -> header.last_element ^= 0
	then call ioa_ ("^5xlast_element: ^oo", node_ptr -> header.last_element);

	if walk_chains
	then do chain = node_ptr -> header.first_element repeat addr (x (chain)) -> symbol.next_member
		while (chain > 0);
		call ioa_ ("^8oo ^a", chain, addr (x (chain)) -> symbol.name);
	     end;
	return;


output_node (8):					/* CHARACTER CONSTANT */
	call ioa_ ("^2xoperand type: ^a, data type ^a(^d), value ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type), node_ptr -> char_constant.length,
	     print_constant_value (node_ptr, "1"b));

	if ^everything
	then return;

	call get_addressing_attributes;

	if node_ptr -> char_constant.no_value_stored
	then ons = ons || "no_value_stored ";

	call print_common_fields ("hash_chain");
	return;


output_node (9):					/* ARRAY_REF */
	call ioa_ ("^2xoperand type: ^a, data type ^a", operand_names (node_ptr -> node.operand_type),
	     mode_names (node_ptr -> node.data_type));

	if node_ptr -> array_ref.ref_count ^= 0
	then call ioa_ ("^5xref_count: ^d", node_ptr -> array_ref.ref_count);

	if node_ptr -> array_ref.ref_count_copy ^= 0
	then call ioa_ ("^5xref_count_copy: ^d", node_ptr -> array_ref.ref_count_copy);

	if ^everything
	then return;

	call get_addressing_attributes;

	if node_ptr -> array_ref.has_address
	then ons = ons || "has_address ";

	if node_ptr -> array_ref.variable_offset
	then ons = ons || "variable_offset ";

	if node_ptr -> array_ref.variable_length
	then ons = ons || "variable_length ";

	if node_ptr -> array_ref.invariant
	then ons = ons || "invariant ";
	if node_ptr -> array_ref.irreducible
	then ons = ons || "irreducible ";
	if node_ptr -> array_ref.used_across_loops
	then ons = ons || "used_across_loops ";

	if node_ptr -> array_ref.large_offset
	then ons = ons || "large_offset ";

	call print_common_fields ("loop_end_fu_pos");

	if node_ptr -> array_ref.location ^= 0
	then call ioa_ ("^5xlocation: ^oo", node_ptr -> array_ref.location);

	if node_ptr -> array_ref.parent ^= 0
	then call ioa_ ("^5xparent: ^oo", node_ptr -> array_ref.parent);

	if node_ptr -> array_ref.v_offset ^= 0
	then call ioa_ ("^5xv_offset: ^oo", node_ptr -> array_ref.v_offset);

	if node_ptr -> array_ref.length ^= 0
	then call ioa_ ("^5xlength: ^[^oo^;^d^]", node_ptr -> array_ref.variable_length, node_ptr -> array_ref.length);

	if node_ptr -> array_ref.output_by ^= 0
	then call ioa_ ("^5xoutput_by: ^oo", node_ptr -> array_ref.output_by);

	if node_ptr -> array_ref.start_input_to ^= 0
	then call ioa_ ("^5xstart_input_to: ^oo", node_ptr -> array_ref.start_input_to);

	if node_ptr -> array_ref.end_input_to ^= 0
	then call ioa_ ("^5xend_input_to: ^oo", node_ptr -> array_ref.end_input_to);

	if walk_chains
	then call display_node ((node_ptr -> array_ref.parent), all_fields, dont_walk);
	return;


output_node (10):					/* PROC_FRAME */
	if ^everything
	then return;

	call ioa_ ("");
	call dump_words (node_ptr, get_node_size (node_ptr));
	return;


output_node (11):					/* LIBRARY */
	if ^everything
	then return;

	if node_ptr -> library.next_library_node ^= 0
	then call ioa_ ("^5xnext_library_node: ^oo", node_ptr -> library.next_library_node);

	if node_ptr -> library.character_operand ^= 0
	then call ioa_ ("^5xcharacter_operand: ^oo", node_ptr -> library.character_operand);

	if walk_chains
	then call ioa_ ("^5xpath: ^a", print_constant_value (addr (x (node_ptr -> library.character_operand)), "0"b));
	return;


output_node (12):					/* SUBPROGRAM */
	chain = node_ptr -> subprogram.symbol;
	if chain <= 0
	then call ioa_ ("^2x^a: NO NAME!", subr_type (node_ptr -> subprogram.subprogram_type));
	else call ioa_ ("^2x^a: ^a", subr_type (node_ptr -> subprogram.subprogram_type),
		addr (x (chain)) -> symbol.name);

	if ^everything
	then return;

	ons = "";
	call ioa_ ("");

	if node_ptr -> subprogram.options.ansi_77
	then ons = ons || "ansi77 ";
	else ons = ons || "ansi66 ";

	if node_ptr -> subprogram.options.card
	then ons = ons || "card ";
	else ons = ons || "free ";

	if node_ptr -> subprogram.options.fold
	then ons = ons || "fold ";

	if ^node_ptr -> subprogram.options.ignore_articulation_blocks
	then ons = ons || "safe ";

	if node_ptr -> subprogram.options.subscriptrange
	then ons = ons || "subrg ";
	else ons = ons || "nosubrg ";

	if node_ptr -> subprogram.options.stringrange
	then ons = ons || "stringrange ";

	if node_ptr -> subprogram.options.auto_zero
	then ons = ons || "auto_zero ";
	else ons = ons || "no_auto_zero ";

	if node_ptr -> subprogram.options.do_rounding
	then ons = ons || "round ";
	else ons = ons || "truncate ";

	if node_ptr -> subprogram.options.relocatable
	then ons = ons || "rlc ";
	else ons = ons || "nrlc ";

	if ons ^= ""
	then call ioa_ ("^5xoptions: ^a", ons);

	ons = "";
	if node_ptr -> subprogram.default_is.auto
	then ons = ons || "default_is.auto ";
	if node_ptr -> subprogram.default_is.static
	then ons = ons || "default_is.static ";
	if node_ptr -> subprogram.need_PS
	then ons = ons || "need_PS ";
	if node_ptr -> subprogram.need_prologue
	then ons = ons || "need_prologue ";
	if node_ptr -> subprogram.multiple_entry
	then ons = ons || "multiple_entry ";
	if node_ptr -> subprogram.namelist_used
	then ons = ons || "namelist_used ";
	if node_ptr -> subprogram.has_parameters
	then ons = ons || "has_parameters ";

	if ons ^= ""
	then call ioa_ ("^5xattr: ^a", ons);

	if node_ptr -> subprogram.previous_subprogram ^= 0 | node_ptr -> subprogram.next_subprogram ^= 0
	then call ioa_ ("^5xprevious: ^oo, next: ^oo", node_ptr -> subprogram.previous_subprogram,
		node_ptr -> subprogram.next_subprogram);

	if node_ptr -> subprogram.common_chain ^= 0 | node_ptr -> subprogram.equiv_chain ^= 0
	then call ioa_ ("^5xcommon: ^oo, equiv: ^oo", node_ptr -> subprogram.common_chain,
		node_ptr -> subprogram.equiv_chain)
		;

	if node_ptr -> subprogram.first_symbol ^= 0 | node_ptr -> subprogram.last_symbol ^= 0
	then call ioa_ ("^5xsymbols: ^oo ^oo", node_ptr -> subprogram.first_symbol, node_ptr -> subprogram.last_symbol);

	if node_ptr -> subprogram.first_label ^= 0 | node_ptr -> subprogram.last_label ^= 0
	then call ioa_ ("^5xlabels: ^oo ^oo", node_ptr -> subprogram.first_label, node_ptr -> subprogram.last_label);

	if node_ptr -> subprogram.first_polish ^= 0 | node_ptr -> subprogram.last_polish ^= 0
	then call ioa_ ("^5xpolish: ^oo ^o", node_ptr -> subprogram.first_polish, node_ptr -> subprogram.last_polish);

	if node_ptr -> subprogram.first_quad ^= 0 | node_ptr -> subprogram.last_quad ^= 0
	then call ioa_ ("^5xquad: ^oo ^oo", node_ptr -> subprogram.first_quad, node_ptr -> subprogram.last_quad);

	if node_ptr -> subprogram.map.first ^= 0 | node_ptr -> subprogram.map.last ^= 0
	then call ioa_ ("^5xmap.first: ^oo ^oo", node_ptr -> subprogram.map.first, node_ptr -> subprogram.map.last);

	if node_ptr -> subprogram.entry_info ^= 0
	then call ioa_ ("^5xentry_info: ^oo", node_ptr -> subprogram.entry_info);

	if node_ptr -> subprogram.runtime ^= 0
	then call ioa_ ("^5xruntime: ^oo", node_ptr -> subprogram.runtime);

	prt_sw = "1"b;				/* print header if interesting bucket is found */
	do chain = 1 to hbound (node_ptr -> subprogram.storage_info, 1);

	     ft = node_ptr -> subprogram.storage_info (chain).first;
	     ls = node_ptr -> subprogram.storage_info (chain).last;
	     nx = node_ptr -> subprogram.storage_info (chain).next_loc;

	     if ft ^= 0 | ls ^= 0 | nx ^= 0
	     then do;
		     if prt_sw
		     then call ioa_ ("^/^5xbucket	first	last	next_loc");
		     prt_sw = "0"b;

		     call ioa_ ("^8d^10oo^10oo^10oo", chain, ft, ls, nx);
		end;
	end;

	if node_ptr -> subprogram.n_loops > 0
	then call ioa_ ("^5xloop_vector: ^p, n_loops: ^d, max_operators: ^d, max_sym ^d",
		node_ptr -> subprogram.loop_vector_p, node_ptr -> subprogram.n_loops,
		node_ptr -> subprogram.max_operators,
		node_ptr -> subprogram.max_sym);

	return;


output_node (13):					/* ARG_DESC */
	if ^everything
	then return;

	call ioa_ ("^/^-^8d args^/^3xNumber^-Data Type^-^-Attributes", node_ptr -> arg_desc.n_args);
	do chain = 1 to node_ptr -> arg_desc.n_args;

	     ons = "";

	     if node_ptr -> arg_desc.arg (chain).must_be.array
	     then ons = ons || "must_be.array ";
	     if node_ptr -> arg_desc.arg (chain).must_be.scalar
	     then ons = ons || "must_be.scalar ";
	     if node_ptr -> arg_desc.arg (chain).star_extents
	     then ons = ons || "star_extents ";

	     call ioa_ ("^3d ^a ^a", chain, mode_names (node_ptr -> arg_desc.arg (chain).data_type), ons);
	end;
	return;


output_node (14):					/* POINTER */
	call ioa_ ("^5xcode: ^d, var: ^d, offset: ^d, count: ^d, hash_chain: ^oo",
	     node_ptr -> pointer.code, node_ptr -> pointer.variable,
	     node_ptr -> pointer.offset, node_ptr -> pointer.count,
	     node_ptr -> pointer.hash_chain);
	return;


output_node (15):					/* MACHINE_STATE */
	if node_ptr -> machine_state.next ^= null
	then call ioa_ ("^5xnext: ^p", node_ptr -> machine_state.next);

	call ioa_ ("^/EAQ state:");
	do i = 1 to 4;				/* A, Q, EAQ, IND */

	     call ioa_ ("^/^5x^a: name ^a, number ^d.",
		eaq_regs (i),
		eaq_names (node_ptr -> machine_state.eaq (i).name),
		node_ptr -> machine_state.eaq (i).number);

	     do chain = 1 to hbound (node_ptr -> machine_state.eaq.variable, 1);
		if node_ptr -> machine_state.eaq (i).variable (chain) ^= 0
		then call ioa_ ("^10x#^2d: ^oo", chain,
			node_ptr -> machine_state.eaq (i).variable (chain));
	     end;

	end;

	if node_ptr -> machine_state.indicators_valid > 0
	then call ioa_ ("^/^5xIndicators valid for ^a.",
		eaq_regs (node_ptr -> machine_state.indicators_valid));

	call ioa_ ("^/^5xType Variable  Last used Offset^2/Index registers");
	do chain = 0 to 7;
	     call ioa_ ("^5x^5d^10oo^10oo^10x^[ global^;^]^[ reserved^;^]",
		node_ptr -> machine_state.index_regs (chain).type,
		node_ptr -> machine_state.index_regs (chain).variable,
		node_ptr -> machine_state.index_regs (chain).used,
		node_ptr -> machine_state.index_regs (chain).global,
		node_ptr -> machine_state.index_regs (chain).reserved);
	end;

	call ioa_ ("^/Base registers");
	do chain = 0 to 7;
	     call ioa_ ("^5x^5d^10oo^10oo^10d^[ global^;^]^[ reserved^;^]",
		node_ptr -> machine_state.base_regs (chain).type,
		node_ptr -> machine_state.base_regs (chain).variable,
		node_ptr -> machine_state.base_regs (chain).used,
		node_ptr -> machine_state.base_regs (chain).offset,
		node_ptr -> machine_state.base_regs (chain).global,
		node_ptr -> machine_state.base_regs (chain).reserved);
	end;

	if node_ptr -> machine_state.stack_extended
	then call ioa_ ("^/Stack is extended^[; last_dynamic_temp = ^oo^].",
		(node_ptr -> machine_state.last_dynamic_temp ^= 0),
		node_ptr -> machine_state.last_dynamic_temp);

	return;


get_addressing_attributes:
     procedure;					/* creates string from addressing attribute bits */

	ons = "";

	if node_ptr -> node.is_addressable
	then ons = ons || "is_addressable ";
	if node_ptr -> node.value_in.eaq
	then ons = ons || "value_in.eaq ";
	if node_ptr -> node.value_in.x
	then ons = ons || "value_in.x ";
	if node_ptr -> node.allocated
	then ons = ons || "allocated ";
	if node_ptr -> node.needs_pointer
	then ons = ons || "needs_pointer ";
	if node_ptr -> node.stack_indirect
	then ons = ons || "stack_indirect ";
	if node_ptr -> node.large_address
	then ons = ons || "large_address ";
	if node_ptr -> node.address_in_base
	then ons = ons || "address_in_base ";
	if node_ptr -> node.allocate
	then ons = ons || "allocate ";
	if node_ptr -> node.set
	then ons = ons || "set ";
	if node_ptr -> node.referenced
	then ons = ons || "referenced ";
	if node_ptr -> node.passed_as_arg
	then ons = ons || "passed_as_arg ";
	if node_ptr -> node.dont_update
	then ons = ons || "dont_update ";
	if node_ptr -> node.not_in_storage
	then ons = ons || "not_in_storage ";
	if node_ptr -> node.globally_assigned
	then ons = ons || "globally_assigned ";

     end /* get_addressing_attributes */;


print_common_fields:
     procedure (name2);				/* prints string and address field */

dcl	name2		char (*);

	if ons ^= ""
	then call ioa_ ("^/^5xattr: ^a", ons);
	else call ioa_ ("");
	ons = "";

	if unspec (node_ptr -> node.address) ^= "0"b
	then call ioa_ ("^5xaddress: ^wo", unspec (node_ptr -> node.address));

	if node_ptr -> node.units ^= 0
	then call ioa_ ("^5xunits: ^a", offset_unit_names (node_ptr -> node.units));

	call ioa_ ("^5xrelocation: ^b (^b)", node_ptr -> node.reloc, node_ptr -> node.reloc_hold);

	if node_ptr -> node.addr_hold ^= "0"b
	then call ioa_ ("^5xaddr_hold: ^oo", node_ptr -> node.addr_hold);

	if node_ptr -> node.next ^= 0
	then call ioa_ ("^5xnext: ^oo", node_ptr -> node.next);

	if node_ptr -> node.hash_chain ^= 0
	then call ioa_ ("^5x^a: ^[^oo^;^d^]", name2, name2 = "hash_chain", node_ptr -> node.hash_chain);
     end /* print_common_fields */;

     end display_node;

display_quadruples:
     proc (start, stop);

dcl	(start, stop)	fixed bin (18);
dcl	last		fixed bin (18);

dcl	(op, i)		fixed bin (18);
dcl	o		ptr;

	last = -1;

	do op = start repeat o -> operator.next while (last ^= stop & op > 0);
	     o = addr (quad (op));
	     last = op;

	     if o -> operator.op_code = stat_op
	     then do;
		     stat_start = binary (o -> opt_statement.start, 26);
		     stat_length = binary (o -> opt_statement.length, 9);
		     call ioa_
			(
			"^/STAT:  ^oo  ^a start ^d, length ^d
         ^/^a^/
     next ^oo, back ^oo
     first_op ^oo, prev_op ^oo, obj ^oo",
			op, decode_source_id (op, quadruple_base, "0"b), stat_start, stat_length,
			substr (source_segment, stat_start + 1, stat_length), binary (o -> opt_statement.next, 18),
			binary (o -> opt_statement.back, 18), binary (o -> opt_statement.first_operator, 18),
			binary (o -> opt_statement.prev_operator, 18), binary (o -> opt_statement.location, 18));

		     ons = "";
		     if o -> opt_statement.put_in_profile
		     then ons = "put_in_profile ";
		     else if o -> opt_statement.put_in_map
		     then ons = "put_in_map ";

		     if o -> opt_statement.referenced_backwards
		     then ons = ons || "referenced_backwards ";

		     if o -> opt_statement.referenced_by_assign
		     then ons = ons || "referenced_by_assign ";

		     if o -> opt_statement.moved
		     then ons = ons || "moved ";

		     if o -> opt_statement.removable
		     then ons = ons || "removable ";

		     call ioa_ ("^5x^a", ons);

		     if o -> opt_statement.flow_unit ^= null
		     then call ioa_ ("^5xflow_unit: ^p", o -> opt_statement.flow_unit);

		     if o -> opt_statement.has_operator_list
		     then call ioa_ ("^5xoperator_list: ^p", o -> opt_statement.operator_list);

		     if o -> opt_statement.machine_state ^= 0
		     then call ioa_ ("^5xmachine_state: ^oo", o -> opt_statement.machine_state);

		     if o -> opt_statement.label ^= 0
		     then call display_node ((o -> opt_statement.label), just_name, dont_walk);
		end;

	     else do;
		     if o -> operator.op_code >= lbound (op_names, 1) & o -> operator.op_code <= hbound (op_names, 1)
		     then call ioa_ ("^/OPERATOR: ^oo ^a^[  FREED^;^]", op, op_names (o -> operator.op_code),
			     o -> operator.freed);
		     else call ioa_ ("^/OPERATOR: ^oo ^d^[  FREED^;^]", op, binary (o -> operator.op_code, 8),
			     o -> operator.freed);

		     call display_operand ((o -> operator.output));

		     do i = 1 to o -> operator.number;
			call display_operand ((o -> operator.operand (i)));
		     end;
		end;
	end;

	return;


display_operand:
     proc (content);

dcl	content		fixed bin (18);

	if content < 0
	then call ioa_ ("^/COUNT: ^d", content + bias);
	else if content > 0
	then call display_node (content, just_name, dont_walk);
	else call ioa_ ("^/ZERO");

     end display_operand;

     end display_quadruples;

     end fort_display;

     end fort_;




		    fort_bfp_math.fortran           12/27/84  0834.4r w 12/27/84  0751.4        4338



c ******************************************
c *                                        *
c * Copyright, (C) Honeywell Limited, 1984 *
c *                                        *
c ******************************************

%global bfp;
c     =======================================
c     do nothing program that sets the global flag bfp
c     for the fort_math include file.
c
c     Written: 03/28/84 by M. Mabey
c     =======================================

%include fort_math




		    fort_cg_macros_.alm             11/10/88  1423.2rew 11/10/88  1314.2     1200168




" ******************************************************
" *                                                    *
" * 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, 452, and 463.
"  2) change(86-07-14,BWong), approve(86-07-14,MCR7442),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bug 410.
"  3) change(88-04-28,RWaters), approve(88-04-28,MCR7875),
"     audit(88-07-13,Huen), install(88-11-10,MR12.2-1209):
"     Implement SCP 6339:  removed the special case code for constants since
"     they can now be up to 128K chars long.
"                                                      END HISTORY COMMENTS


" Written:	January 1976, by G. D. Chang
"
" Modified:
"         08 Mar 86, SH - 410: Fix bug in cv_bif_to_external where offsets
"		into vector for dtan, asin, dasin and acos were out
"		of order.
"	08 Aug 85, BW - 430: Prevent emission of deallocation code for
"		automatic LA's and VLA's when they don't exist in the
"		compilation unit.
"	02 Aug 85, BW - 463: Removed code to save and restore stack
"		extents in 'quick_return' and 'make_quick_entry'.
"		This was only done when char star-extent variables
"		were concatenated.
"         12 May 95, BW - 452: Fix looping problem when a vla array is
"		incorrectly used as a format in a write statement.
"	22 Jun 84, MM - Install typeless functions support.
"	28 Mar 84, MM - Install HFP support.
"	12 Sep 83, HH - 388: Insure any logical value in the indicators
"		is stored before issuing an 'fneg'.
"	17 Jun 83, HH - 383: Replace 'scan_parameter_list' subroutine with
"		'prepare_for_namelists' subr and 'process_param_list' proc.
"	 7 June 83, TO: 381 - Fix pr0|shorten_stack for registers pr1,x1.
"	31 Jan 83, TO & HH - Install LA/VLA support.
"	10 January  1982, TO - Add 'emit_entry_defs' call to entries.
"	 3 January  1982, TO - Add DO-loop optimization of forcing 'even'
"		address of top label of loop.
"	17 Dec 82, TO - Add 'emit_profile_entry' simple operator.
"         17 Nov 82, HH - 361:  'get_format_var' operator no longer needed.
"	27 July 1982, TO - Fix check in relational operators to permit
"	     temporary nodes, such as expressions and function returns in
"	     relationals with character constants.
"	12 May 1982, HH - Add "fixedoverflow" check for multiplies.
"	 5 May 1982, TO - Add shorten stack to return from char*(*) function.
"	 1 April   1982, TO  - Add intrinsic externals for builtins.
"	28 October 1981, CRD - Inquire statement.
"	20 October 1981, CRD - Internal files.
"	27 August 1981, CRD - More general UNIT field in OPEN/CLOSE stmts.
"	21 August 1981, CRD - Blank field in OPEN statement.
"	27 July 1981, CRD - Allow format labels in assign_label operator,
"		and allow integer scalars in format operator.
"	18 June 1981, CRD - Fix unnumbered bug in complex exponentiation.
"	10 June 1981, CRD - New polish for backspace/endfile/rewind.
"	2 June 1981, CRD - Handle statement functions with 0 arguments.
"	12 May 1981, CRD - Add equiv_op, not_equiv_op.
"	23 April 1981, CRD - Fix bug 317.
"	18 March 1981, CRD - Fix bug 310.
"	13 March 1981, CRD - Modifications for assumed size arrays.
"	19 February 1981, CRD - Change check_subscript for variable lower
"		array bounds.
"	9 December 1980, CRD - Fix bug 298.
"	8 December 1980, CRD - Implement Fortran 77 block IF statement.
"	24 November 1980, CRD - Implement Fortran 77 zero trip DO loops.
"	24 November 1980, CRD - Change several I/O routines to issue load_pr
"		macros BEFORE loading the A or Q.  This is necessary as
"		loading a pointer to a character array element may use the
"		A or Q.
"	31 October 1980, CRD - Fix bug in div_rc.
"	24 October 1980, CRD - Add code for new Fortran 77 intrinsics.
"	13 October 1980, CRD - As a result of the change to manage the A, Q,
"		and EAQ separately, in_reg and return eaq_name macros no
"		longer erase the machine state entirely.  Therefore, it is
"		necessary to issue a use_eaq macro before emitting a call
"		to one of the type conversion operators.
"	10 October 1980, CRD - Fix bug whereby real and dp DO loops  did not
"		truncate loop count to integer.
"	26 September 1980, CRD - Change make_quick_entry to asert that pr1
"		contains the arg list ptr.
"	17 September 1980, CRD - Fix bug 278.  The AMAX0, MAX1, AMIN0, and
"		MIN1 intrinsics got incorrect code because of improper
"		EAQ management.
"	22 August 1980, CRD - Fix error handling for open statement.
"	13 August 1980, CRD - Add error_macro segdef.
"	24 July 1980, CRD - Fix bug in subscript processing which caused
"		non-integer subscripts to confuse the machine state.
"	16 July 1980, CRD - Key argument list consistency checking off of
"		variable_arglist bit, not needs_descriptors bit.
"	15 July 1980, CRD - Centralize call-side descriptor checking in
"		descriptor_check subroutine.  Change logic so that
"		descriptors are automatically generated for calls with
"		character mode arguments in ansi77 mode.
"	27 June 1980, CRD - Modify I/O routines to allow I/O of character
"		strings of variable length.  Put check in func_ref to
"		ensure that function is not *-length.
"	26 June 1980, CRD - Check data type of parent in substr.
"	23 June 1980, CRD - Check ansi77 mode for concatenation.
"	14 May 1980, CRD - Fix bug in ICHAR intrinsic.
"	7 March 1980, CRD - Implement concatenation.
"	1 February 1980, CRD - Fix bug in which subscripts with bad data
"		types get no error messages.  Make a similar change for
"		substring expressions.
"	24 January 1980, CRD - Add code to make_entry, make_quick_entry,
"		and make_call to allow for Fortran entries which
"		require descriptors.
"	14 Dec 1979, CRD - Add use_ind macros to relational operators, and
"		change make_entry and make_quick_entry to allow for entries
"		that require descriptors.
"	1 Nov 1979, CRD - Add mpy to single_inst table, change if_ind and
"		unless_ind macros to have eaq_name.
"	09 Aug 1979, CRD - Fix bug 221 (dmod implemented incorrectly)
"	12 Jul 1979, PES - More forgiving encode/decode statement.  The string
"		may now be an array, simple variable, or array element of any type
"		but logical.
"	09 Jul 1979, CRD - Changes to fix bug 220, in which files do not
"		get closed if there is no STOP or CALL EXIT statement in the
"		main program.
"	17 Nov 1978, RAB - Centralizes rounding decisions in "round" and
"		"store" macros.  Precedes many floating compares
"		with rounds.
"	13 Sep 1978, PES - Changes to fix bug 183, in which fortran sometimes decides that
"		external subroutine names passed out as arguments in a call should be
"		treated as character strings.
"	05 Sep 1978, PES - Changes to fix bug 179, in which real/dp function results are
"		rounded before being stored.
"	27 Jul 1978, PES - Changes to fix min and max bug. audit changes.
"	20 Jun 1978, DSL - Clean up and bug fixes from loop optimizer audit.
"		Fix macros for sign builtin functions.
"	25 May 1978, DSL - Minor bug fixes in open/close. Fix bug 159 in which
"		indicators are not set correctly before calls to "sign" BIFs
"		and for aint BIF. Fix bug 156 in which "frd" or "dfrd" is
"		required before conversion to integer.
"	02 May 1978, DSL - fix bug 153 in which macros contained a
"		dfcmp	=0.,du.
"	13 Feb 1978, DSL - Fix bug 140 in which "load_pr pr1" destroys the
"		addressability of subsequent operands. Also, changed fst to fstr in
"		div_ic code. Also converted round_dp_to_real to a function.
"	03 Feb 1978, DSL - Emergency fix to negate complex.
"	05 Jan 1978, DSL - Implement double precision to complex conversion for
"		arithmetic infix oprs and for assignment.
"	04 Jan 1978, DSL - Implement rel ops for one char const opnd and one
"		arith opnd. Fix bug in func ref (unreported) in which no warning is
"		printed if return value is char and may need descriptors.
"	27 Dec 1977, DSL - fix bug in cv_bif_to_external (136); use new macros
"		pad_char_const_to_(word dw) in assign, fix bug in func_ref (130),
"		change macros to truncate on store when appropriate, introduce use
"		of new macro, dt_jump1.
"	15 Sep 1977, DSL - interim fix to abs bif until load_for_test macro
"		is available.
"	19 Jul 1977, DSL - fix bugs in open/close.
"	14 Jul 1977, DSL - 1) fix sf def for simple references.
"		2) change implementation of open/close. 3) fix sf ref for
"		logical sf. 4) prevent parameters from reaching make_external_variable.
"	26 May 1977, GDC - allow statement functions to take character
"		arguments with character data-types.
"
	maclist	object
	include		fort_macros
	include		fort_equs

	include		stack_header
	include		stack_frame

	name		fort_cg_macros_

	segdef		operator_table
	segdef		single_inst
	segdef		interpreter_macros
	segdef		first_scan
	segdef		abort_list
	segdef		error_macro

	use		.text.

	include	fort_operator_table

	include	fort_single_inst

interpreter_macros:
	zero	check_subscript
	zero	subscript_mpy
	zero	move_eis
	zero	check_stringrange


check_subscript:
	func	3

	swap	arg1

	" arg1: upper bound
	" arg2: lower bound
	" arg3: subscript

	if	arg1,=,op1,ret_sub
	if	arg2,=,op1,ret_sub

	load	q,arg1

	use_eaq

	lda	arg2
	cwl	arg3
	tze	2,ic
	tsx0	pr0|bound_ck_signal

ret_sub:
	return	arg3


subscript_mpy:
	proc	1


	if	arg1,=,1,ret_mpy

	if_check_multiply	subscript_mpy.1

	if	arg1,=,2,qls1

subscript_mpy.1:
	mpy	arg1

	unless_check_multiply	ret_mpy
	tsx0	pr0|mpy_overflow_check

ret_mpy:	return

qls1:	emit	1

	qls	1

	return


move_eis:
	proc	2

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

	return


check_stringrange:
	proc	3

	" arg1 is length of parent
	" arg2 is index of first char in substring
	" arg3 is index of last char in substring

	use_eaq

	lda	1,dl		" Get lower bound in A
	load	q,arg1		" Get upper bound in Q
	cwl	arg2		" Check the first index
	tze	2,ic
	tsx0	pr0|signal_stringrange

	lda	arg2		" Get first index in A
	load	q,arg1		" Get length of string in Q
	cwl	arg3		" Check second index
	tze	2,ic
	tsx0	pr0|signal_stringrange

	return


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

first_scan:
	scan		continue,continue

abort_list:
	scan		continue,(continue,next)

error_macro:
	error

assign:	proc		2

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

assign_ii:
	load		q,arg2
	store		q,arg1
	return

assign_ir:
	s_call		cv_load.ri
	store		q,arg1
	return

assign_ri:
	s_call		cv_load.ir
	store		eaq,arg1
	return

assign_id:
	s_call		cv_load.di
	store		q,arg1
	return

assign_di:
	s_call		cv_load.id
	store		deaq,arg1
	return

assign_rr:
	load		eaq,arg2
	store		eaq,arg1
	return

assign_dd:
	load		deaq,arg2
	store		deaq,arg1
	return

assign_rd:
	load		deaq,arg2
	fstr		arg1
	return

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

assign_ic:
	s_call		cv_load.ri
	store		q,arg1
	return

assign_ci:
	s_call		cv_load.ir
	jump		assign_cr.01

assign_rc:
	load		eaq,arg2
	store		eaq,arg1
	return

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

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

assign_cd:
	load		deaq,arg2
	jump		assign_cr.01

assign_cc:
	load		aq,arg2
	store		aq,arg1
	return

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

assign_l:
	swap		arg1

	unless_dt		logical,logical.p

	load		a,arg1
	store		a,arg2
	return

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

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

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


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

	return

logical.p:
	print		338,arg1,op1
	return

char2.p:
	print		337,op1
	return

assign_e1:
	print		309,arg1
	return

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

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

assign_t.normal:
	unless_one_word_dt	arg1,assign_e1		" trap assignments to incorrect char variables
	load		tq,arg2
	store		tq,arg1

assign_t.return:
	return


add:	func		2

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

add_ii:
	load_top		q
	adq		arg1
	return		q

add_ir:
	swap		arg1

add_ri:
	s_call		cv_load.ir
	fad		arg1
	return		eaq

add_id:
	swap		arg1

add_di:
	s_call		cv_load.id
	dfad		arg1
	return		deaq

add_rr:
	load_top		eaq
	fad		arg1
	return		eaq

add_dd:
	load_top		deaq
	dfad		arg1
	return		deaq

add_rd:
	swap		arg1

add_dr:
	if_eaq		eaq,arg2,add_dr.1

	load		deaq,arg1
	fad		arg2
	return		deaq

add_dr.1:
	dfad		arg1
	return		deaq

add_ic:
	swap		arg1

add_ci:
	s_call		cv_load.ir
	push_temp		cmpx
	jump		add_cr.1

add_rc:
	swap		arg1

add_cr:
	push_temp		cmpx

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

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

add_cr.1:
	fad		arg1
add_cr.11:
	reset_eaq				"so store sees no rounded state
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

add_cr.2:
	fad		arg2
	jump		add_cr.11

add_dc:
	swap		arg1

add_cd:
	push_temp		cmpx

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

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

add_cd.1:
	fad		arg1
add_cd.11:
	reset_eaq					"so store sees ^ round
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

add_cd.2:
	dfad		arg2
	jump		add_cd.11

add_cc:
	push_temp		cmpx

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

	load		ieaq,arg1
	fad		arg2+1
add_cc.01:
	reset_eaq					"set ^rounded
	store		ieaq,op1,no_update
	fld		arg1
	fad		arg2
	in_reg		eaq,op1
	return		op1

add_cc.1:
	fad		arg1
add_cc.11:
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg1+1
	fad		arg2+1
	in_reg		ieaq,op1
	return		op1

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

add_cc.3:
	fad		arg2
	jump		add_cc.11

add_e1:
	error		309,arg1

add_e2:
	error		310,arg2

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

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

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

sub_ii:
	load		q,arg1
	sbq		arg2
	return		q

sub_ir:
	swap		arg1

	s_call		cv_load.ir
	fsb		arg1
	return		eaq

sub_ri:
	if_eaq		q,arg2,sub_ri.1

	if_optype		constant,conv_sub_ri

	use_eaq
	lcq		arg2
	tsx0		pr0|integer_to_real
	fad		arg1
	return		eaq

conv_sub_ri:
	convert_constant	real
	load		eaq,arg2
	emit		1
	fneg
	fad		arg1
	return		eaq

sub_ri.1:
	use_eaq
	tsx0		pr0|integer_to_real
	emit		1
	fneg
	fad		arg1
	return		eaq

sub_id:
	swap		arg1

	s_call		cv_load.id
	dfsb		arg1
	return		deaq

sub_di:
	if_eaq		q,arg2,sub_di.1

	if_optype		constant,conv_sub_di

	use_eaq
	lcq		arg2
	tsx0		pr0|integer_to_double
	dfad		arg1
	return		deaq

conv_sub_di:
	convert_constant	dp
	load		deaq,arg2
	emit		1
	fneg
	dfad		arg1
	return		deaq

sub_di.1:
	use_eaq
	tsx0		pr0|integer_to_double
	emit		1
	fneg
	dfad		arg1
	return		deaq

sub_rr:
	use_ind
	if_eaq		eaq,arg2,sub_rr.1

	load		eaq,arg1
	fsb		arg2
	return		eaq

sub_rr.1:
	emit		1
	fneg
	fad		arg1
	return		eaq

sub_dd:
	use_ind
	if_eaq		deaq,arg2,sub_dd.1

	load		deaq,arg1
	dfsb		arg2
	return		deaq

sub_dd.1:
	emit		1
	fneg
	dfad		arg1
	return		deaq

sub_rd:
	use_ind
	if_eaq		deaq,arg2,sub_rd.1

	load		eaq,arg1
	dfsb		arg2
	return		deaq

sub_rd.1:
	emit		1
	fneg
	fad		arg1
	return		deaq

sub_dr:
	use_ind
	if_eaq		eaq,arg2,sub_dr.1

	load		deaq,arg1
	fsb		arg2
	return		deaq

sub_dr.1:
	emit		1
	fneg
	dfad		arg1
	return		deaq

sub_ic:
	push_temp		cmpx

	swap		arg1

	if_optype		constant,conv_sub_ic

	swap		arg1
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_real
	jump		sub_rc.1

conv_sub_ic:
	convert_constant	real
	swap		arg1
	load		eaq,arg1
	jump		sub_rc.1

sub_ci:
	push_temp		cmpx

	swap		arg2

	if_optype		constant,conv_sub_ci

	swap		arg2
	use_eaq
	lcq		arg2
	tsx0		pr0|integer_to_real
	jump		sub_cr.10

conv_sub_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		sub_cr.1

sub_rc:
	push_temp		cmpx

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

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

sub_rc.1:
	fsb		arg2
sub_rc.11:
	reset_eaq					"set ^ rounded
	store		eaq,op1,no_update
	fld		arg2+1
	emit		1
	fneg
	in_reg		ieaq,op1
	return		op1

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

sub_cr:
	push_temp		cmpx

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

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

sub_cr.1:
	emit		1
	fneg
sub_cr.10:
	fad		arg1
sub_cr.11:
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

sub_cr.2:
	fsb		arg2
	jump		sub_cr.11

sub_dc:
	push_temp		cmpx

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

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

sub_dc.1:
	fsb		arg2
sub_dc.11:
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg2+1
	emit		1
	fneg
	in_reg		ieaq,op1
	return		op1

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

sub_cd:
	push_temp		cmpx

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

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

sub_cd.1:
	emit		1
	fneg
sub_cd.10:
	fad		arg1
sub_cd.11:
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg1+1
	in_reg		ieaq,op1
	return		op1

sub_cd.2:
	dfsb		arg2
	jump		sub_cd.11

sub_cc:
	push_temp		cmpx

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

	load		ieaq,arg1
	fsb		arg2+1
sub_cc.01:
	reset_eaq					"set ^rounded
	store		ieaq,op1,no_update
	fld		arg1
	fsb		arg2
	in_reg		eaq,op1
	return		op1

sub_cc.1:
	emit		1
	fneg
	fad		arg1
sub_cc.11:
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg1+1
	fsb		arg2+1
	in_reg		ieaq,op1
	return		op1

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

sub_cc.3:
	fsb		arg2
	jump		sub_cc.11

sub_e1:
	error		309,arg1

sub_e2:
	error		310,arg2

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

sub_tl.1:
	sbq		arg2
	return		tq

mult:	func		2

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

mult_ii:
	use_eaq
	load_top		q
	mpy		arg1

	unless_check_multiply	mult_ii.1
	tsx0		pr0|mpy_overflow_check

mult_ii.1:
	return		q

mult_ir:
	swap		arg1

mult_ri:
	s_call		cv_load.ir
	fmp		arg1
	return		eaq

mult_id:
	swap		arg1

mult_di:
	s_call		cv_load.id
	dfmp		arg1
	return		deaq

mult_rr:
	load_top		eaq
	fmp		arg1
	return		eaq

mult_dd:
	load_top		deaq
	dfmp		arg1
	return		deaq

mult_rd:
	swap		arg1

mult_dr:
	if_eaq		eaq,arg2,mult_dr.1

	load		deaq,arg1
	fmp		arg2
	return		deaq

mult_dr.1:
	dfmp		arg1
	return		deaq

mult_ic:
	swap		arg1

mult_ci:
	push_temp		cmpx

	swap		arg2

	if_optype		constant,conv_mult_ci

	swap		arg2
	push_temp		real

	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real

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

conv_mult_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		mult_cr.1

mult_rc:
	swap		arg1

mult_cr:
	push_temp		cmpx

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

	load		ieaq,arg1
	fmp		arg2
	reset_eaq					"set ^rounded
	store		ieaq,op1,no_update
	fld		arg1
	fmp		arg2
	in_reg		eaq,op1
	return		op1

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

mult_cr.2:
	reset_eaq					"set ^rounded (operand needn't be saved)
	fmp		arg2
	jump		mult_cr.11

mult_dc:
	swap		arg1

mult_cd:
	push_temp		cmpx

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

	load		ieaq,arg1
	dfmp		arg2
	reset_eaq					"set ^rounded
	store		ieaq,op1,no_update
	fld		arg1
	dfmp		arg2
	in_reg		eaq,op1
	return		op1

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

mult_cd.2:
	reset_eaq					"set ^rounded (operand needn't be saved)
	dfmp		arg2
	jump		mult_cd.11

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


mult_tl:
	load_top		tq
	dt_jump1		arg1,(mult_tl.1,mult_e1,mult_e1,mult_e1,mult_e1,mult_e1,mult_tl.1)

mult_tl.1:
	use_eaq
	mpy		arg1

	unless_check_multiply	mult_tl.2
	tsx0		pr0|mpy_overflow_check

mult_tl.2:
	return		tq

mult_e1:
	error		309,arg1

mult_e2:
	error		310,arg2

div:	func		2

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

div_ii:
	use_eaq
	load		q,arg1
	div		arg2
	return		q

div_ir:
	swap		arg1

	s_call		cv_load.ir
	fdv		arg1
	return		eaq

div_ri:
	s_call		cv_load.ir
	fdi		arg1
	return		eaq

div_id:
	swap		arg1

	s_call		cv_load.id
	dfdv		arg1
	return		deaq

div_di:
	s_call		cv_load.id
	dfdi		arg1
	return		deaq

div_rr:
	if_eaq		eaq,arg2,div_rr.1

	load		eaq,arg1
	fdv		arg2
	return		eaq

div_rr.1:
	fdi		arg1
	return		eaq

div_dd:
	if_eaq		deaq,arg2,div_dd.1

	load		deaq,arg1
	dfdv		arg2
	return		deaq

div_dd.1:
	dfdi		arg1
	return		deaq

div_rd:
	load		eaq,arg1
	dfdv		arg2
	return		deaq

div_dr:
	load		eaq,arg2
	dfdi		arg1
	return		deaq

div_ic:
	swap		arg1

	if_optype		constant,conv_div_ic

	swap		arg1
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_real
	fstr		sp|double_temp
	lda		sp|double_temp
	jump		div_rc.01

conv_div_ic:
	convert_constant	real
	swap		arg1
	jump		div_rc

div_ci:
	push_temp		cmpx

	swap		arg2

	if_optype		constant,conv_div_ci

	swap		arg2
	push_temp		real

	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real

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

conv_div_ci:
	convert_constant	real

	swap		arg2
	load		eaq,arg2
	jump		div_cr.1

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

div_cr:
	push_temp		cmpx

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

	load		ieaq,arg1
	reset_eaq					"set ^ rounded (operand not saved)
	fdv		arg2
div_cr.01:
	store		ieaq,op1,no_update
	fld		arg1
	fdv		arg2
	in_reg		eaq,op1
	return		op1

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

div_cr.2:
	fdv		arg2
	reset_eaq					"set ^rounded
	store		eaq,op1,no_update
	fld		arg1+1
	fdv		arg2
	in_reg		ieaq,op1
	return		op1

div_dc:
	swap		arg1
	call		round_dp_to_real
	swap		arg1
	jump		div_rc

div_cd:
	push_temp		cmpx

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

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

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

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

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

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

div_tl.1:
	use_eaq
	div		arg2
	return		tq

div_e1:
	error		309,arg1

div_e2:
	error		310,arg2

cv_load.ir:
	if_optype		constant,conv_ir

	load		q,op1
	use_eaq
	tsx0		pr0|integer_to_real
	s_return

conv_ir:
	convert_constant	real
	load		eaq,op1
	s_return

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

cv_load.ri:
	if_optype		constant,conv_ri
	load		eaq,op1
	round		eaq
	use_eaq
	tsx0		pr0|real_to_integer
	s_return

conv_ri:
	convert_constant	int
	load		q,op1
	s_return

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

cv_load.id:
	if_optype		constant,conv_id

	load		q,op1
	use_eaq
	tsx0		pr0|integer_to_double
	s_return

conv_id:
	convert_constant	dp
	load		deaq,op1
	s_return

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

cv_load.di:
	if_optype		constant,conv_di
	load		deaq,op1
	round		deaq
	use_eaq
	tsx0		pr0|double_to_integer
	s_return

conv_di:
	convert_constant	int
	load		q,op1
	s_return


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

"	This function expects a dp operand on the top of the stack. It "converts" it to single
"	precision by using convert_constant or indicating its value is now in the eaq. The
"	value in the eaq is not explicitly stored into a sp temp because it is assumed that
"	the next use of the eaq will force the store.

round_dp_to_real:
	func		1

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

round_dp_const:
	convert_constant	real
	return		op1

exponentiation:
	func		2

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

exponentiation_ii:
	push_temp		32

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

exponentiation_ir:
	push_temp		32

	swap		arg1

	if_optype		constant,conv_exponentiation_ir

	swap		arg1
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_real
	jump		exponentiation_rr.02

conv_exponentiation_ir:
	convert_constant	real

	swap		arg1
	jump		exponentiation_rr.01

exponentiation_ri:
	push_temp		32

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

exponentiation_id:
	push_temp		32

	swap		arg1

	if_optype		constant,conv_exponentiation_id

	swap		arg1
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_double
	jump		exponentiation_dd.02

conv_exponentiation_id:
	convert_constant	dp

	swap		arg1
	jump		exponentiation_dd.01

exponentiation_di:
	push_temp		32

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

exponentiation_rr:
	push_temp		32

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

exponentiation_dd:
	push_temp		32

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

exponentiation_rd:
	push_temp		32

	load		eaq,arg1
	jump		exponentiation_dd.02

exponentiation_dr:
	push_temp		32

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

exponentiation_ic:
	push_temp		32
	load_pr		pr2,op1
	swap		arg1

	if_optype		constant,conv_exponentiation_ic

	swap		arg1
	push_temp		cmpx
	load		q,arg1
	use_eaq
	tsx0		pr0|integer_to_real
	store		eaq,op1,no_update
	fld		=0.,du
	fst		op1+1
	ldaq		op1
	jump		exponentiation_cc.01

conv_exponentiation_ic:
	convert_constant	cmpx

	swap		arg1
	load		aq,arg1
	jump		exponentiation_cc.01

exponentiation_ci:
	push_temp		32
	load_pr		pr2,op1
	push_temp		cmpx

	swap		arg2

	if_optype		constant,conv_exponentiation_ci

	swap		arg2
	load		q,arg2
	use_eaq
	tsx0		pr0|integer_to_real
	store		eaq,op1,no_update
	fld		=0.,du
	fst		op1+1
	jump		exponentiation_cr.01

conv_exponentiation_ci:
	convert_constant	cmpx

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

exponentiation_dc:
	swap		arg1
	call		round_dp_to_real
	swap		arg1

exponentiation_rc:
	push_temp		32
	load_pr		pr2,op1

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

exponentiation_cd:
	call		round_dp_to_real

exponentiation_cr:
	push_temp		32
	load_pr		pr2,op1
	push_temp		cmpx

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

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

exponentiation_e1:
	error		309,arg1

exponentiation_e2:
	error		310,arg2

negate:	func		1		

	if_dt		int,negate_i
	if_dt		real,negate_r
	if_dt		dp,negate_d
	if_dt		cmpx,negate_c

	error		315,op1

negate_i:
	use_eaq
	lcq		op1
	return		q

negate_r:
	load		eaq,op1
	emit		1
	fneg
	return		eaq

negate_d:
	load		deaq,op1
	emit		1
	fneg
	return		deaq

negate_c:
	push_temp		cmpx

	use_ind
	if_eaq		eaq,op2,negate_c.1

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

negate_c.1:
	emit		1
	fneg
	store		eaq,op1,no_update
	load		ieaq,op2
	emit		1
	fneg
	in_reg		ieaq,op1
	return		op1

"push_var used rather than push_temp in this block to permit non-standard
"construction of do-loop in the extended range of an extended range do-loop.
do:	proc		4

	swap		arg2
	copy		arg1
	call		convert_to_cv_type
	swap		arg2

	swap		arg3
	copy		arg1
	call		convert_to_cv_type
	swap		arg3

	copy		arg1
	call		convert_to_cv_type

	push_label			" arg5 is label for top of loop
	push_label			" arg6 is label for end of loop

	swap		arg1

	if_dt		int,do_i
	if_dt		real,do_r
	jump		do_d

do_i:
	swap		arg1
	swap		arg4		" get incre on top of stack
	unless_ansi77	do_i.no_save_incre
	if_optype		constant,do_i.no_save_incre
	load		q,op1
	push_variable	int
	store		q,op1
	swap		op2
	pop		op1		" replace incre with variable

do_i.no_save_incre:
	swap		arg4		" restore correct order

	load		q,arg2
	store		q,arg1

	use_eaq

	swap		arg4
	if_optype		constant,do_i_constant
	swap		arg4

	ldq		arg3
	sbq		arg2
	div		arg4
	adq		1,dl

	push_variable	int
	store		q,arg7

	unless_ansi77	do_i.one_trip
	tmoz		arg6

do_i.one_trip:
	force_even		" optimize even address for loop
	label		arg5

	scan		continue,next

	shorten_stack

	load		q,arg4
	asq		arg1

	use_eaq

	lcq		1,dl
	asq		arg7
	tpnz		arg5

	label		arg6

	return

do_i_constant:
	swap		arg4

"	If final (to) is not a constant, it is saved before the label macro flushes it

	swap		arg3
	if_optype		constant,to_is_constant	" no need to save, it is a constant

	load		q,op1			" load value and put in temp
	pop		op1			" will replace expre with temp
	push_variable	int
	store		q,op1

to_is_constant:
	swap		arg3			" restore stack to correct order

	unless_ansi77	do_i_constant.one_trip

	load		q,arg2
	compare		q,arg3

	if_negative	arg4,do_i.zero_trip.negative
	tpnz		arg6
	jump		do_i_constant.one_trip

do_i.zero_trip.negative:
	tmi		arg6

do_i_constant.one_trip:
	force_even		" optimize even address for loop
	label		arg5

	scan		continue,next

	shorten_stack

	load		q,arg1

	use_eaq

	if_negative	arg4,do_i_negative

	push_builtin	one
	if		arg4,=,op1,do_i_1

	adq		arg4
	store		q,arg1
	use_ind
	cmpq		arg3
	tmoz		arg5

	label		arg6

	return

do_i_1:

	aos		arg1
	cmpq		arg3
	tmi		arg5

	label		arg6

	return

do_i_negative:
	adq		arg4
	store		q,arg1
	use_ind
	cmpq		arg3
	tpl		arg5

	label		arg6

	return

do_r:
	swap		arg1
	swap		arg4		" get incre on top of stack
	unless_ansi77	do_r.no_save_incre
	if_optype		constant,do_r.no_save_incre
	load		eaq,op1
	push_variable	real
	store		eaq,op1
	swap		op2
	pop		op1		" replace incre with variable

do_r.no_save_incre:
	swap		arg4		" restore correct order

	load		eaq,arg2
	store		eaq,arg1

	use_eaq

	fld		arg3
	fsb		arg2
	fdv		arg4		" subtracting -1 is the same as adding
	fsb		=-1.0,du		" +1, but -1 is the same in hex
	tsx0		pr0|real_to_integer

	push_variable	int
	store		q,arg7

	unless_ansi77	do_r.one_trip
	tmoz		arg6

do_r.one_trip:
	force_even		" optimize even address for loop
	label		arg5

	scan		continue,next

	shorten_stack

	load		eaq,arg1
	use_eaq
	fad		arg4
	store		eaq,arg1,no_update

	lcq		1,dl
	asq		arg7
	tpnz		arg5

	label		arg6

	return

do_d:
	swap		arg1
	swap		arg4		" get incre on top of stack
	unless_ansi77	do_d.no_save_incre
	if_optype		constant,do_d.no_save_incre
	load		deaq,op1
	push_variable	dp
	store		deaq,op1
	swap		op2
	pop		op1		" replace incre with variable

do_d.no_save_incre:
	swap		arg4		" restore correct order

	load		deaq,arg2
	store		deaq,arg1

	use_eaq

	dfld		arg3
	dfsb		arg2
	dfdv		arg4		" subtracting -1 is the same as adding
	fsb		=-1.0,du		" +1, but -1 is the same in hex
	tsx0		pr0|double_to_integer

	push_variable	int
	store		q,arg7

	unless_ansi77	do_d.one_trip
	tmoz		arg6

do_d.one_trip:
	force_even		" optimize even address for loop
	label		arg5

	scan		continue,next

	shorten_stack

	load		deaq,arg1
	use_eaq
	dfad		arg4
	store		deaq,arg1,no_update

	lcq		1,dl
	asq		arg7
	tpnz		arg5

	label		arg6

	return

convert_to_cv_type:
	func		2

	dt_jump		(ccv_ii,ccv_ri,ccv_di,ccv_ci,ccv_ir,ccv_rr,ccv_dr,ccv_cr,ccv_id,ccv_rd,ccv_dd,ccv_cd,ccv_ic,ccv_rc,ccv_dc,ccv_cc,ccv_e2,ccv_e1,ccv_e2,ccv_e1)

ccv_ii:
	return		arg1

ccv_ir:
	swap		arg1

	s_call		cv_load.ir
	return		eaq

ccv_ri:
	swap		arg1

	s_call		cv_load.ri
	return		q

ccv_id:
	swap		arg1

	s_call		cv_load.id
	return		deaq

ccv_di:
	swap		arg1

	s_call		cv_load.di
	return		q

ccv_rr:
	return		arg1

ccv_dd:
	return		arg1

ccv_rd:
	load		eaq,arg1
	return		deaq

ccv_dr:
	load		deaq,arg1
	return		eaq

ccv_ic:
	error		316,op1

ccv_ci:
	load		eaq,arg1
	round		eaq
	use_eaq
	tsx0		pr0|real_to_integer
	return		q

ccv_rc:
	error		316,op1

ccv_cr:
	load		eaq,arg1
	return		eaq

ccv_dc:
	error		316,op1

ccv_cd:
	load		eaq,arg1
	return		deaq

ccv_cc:
	print		316,op1
	return

ccv_e1:
	print		317,arg1
	return

ccv_e2:
	print		318,op1
	return

builtin:	func		2,abort_list_op		last assigned number = 93
"
"	The builtin code depends on 5 indexed operators. Four uses are here. The other
"	appears in the cv_bif_to_external code. Remember to change ALL five.
"

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

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

	print		319,arg1

	jump		bu_abort_list

builtin2:
	decrement		arg2,1
	scan		bu_abort_list,next

	jump_indexed	arg3,(builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.tl,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.char_ok,builtin2.char_ok,builtin2.char_ok,builtin2.char_ok,builtin2.char_ok,builtin2.char_ok,builtin2.char_ok,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.nc,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word,builtin2.one_word)

builtin2.char_ok:
	unless_dt		(int,real,dp,cmpx,char),wrong_type.p
	jump		builtin2.join

builtin2.one_word:
	unless_one_word_dt	op1,bu_dt1.p
	jump		builtin2.join

builtin2.tl:
	unless_dt		(int,real,dp,cmpx,typeless),wrong_type.p
	jump		builtin2.join

builtin2.nc:
	unless_dt		(int,real,dp,cmpx),wrong_type.p

builtin2.join:
	unless		arg2,=,0,builtin2

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

builtin_var:
	jump_indexed	arg3,(builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.1,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2,builtin_var.2)


builtin_var.1:
	scan		bu_abort_list,(next,builtin3)

	" NOTE: There are no non typeless builtins which take a variable
	" number of arguments and which also take character mode arguments.

	unless_dt		(int,real,dp,cmpx),wrong_type.p
	jump		builtin_var.1

builtin_var.2:
	scan		bu_abort_list,(next,builtin3)
	unless_one_word_dt	op1,bu_dt1.p
	jump		builtin_var.2

bu_ret_q:
	scan		continue,(continue,next)

	return		q

bu_ret_eaq:
	scan		continue,(continue,next)

	return		eaq

bu_ret_deaq:
	scan		continue,(continue,next)

	return		deaq

bu_ret_aq:
	scan		continue,(continue,next)

	return		aq

bu_ret_tq:
	scan		continue,(continue,next)

	return		tq

bu_ret_trc:
	scan		continue,(continue,next)

	return		trc

bu_ret_tnc:
	scan		continue,(continue,next)

	return		tnc

bu_ret_op1:
	scan		continue,(continue,next)

	return		op1

mm_ret_q:
	push_temp		int
	in_reg		q,op1
	use_ind
	return		op1

mm_ret_eaq:
	push_temp		real
	in_reg		eaq,op1
	use_ind
	return		op1

mm_ret_deaq:
	push_temp		dp
	in_reg		deaq,op1
	use_ind
	return		op1

mm_ret_tq:
	push_temp		typeless
	in_reg		tq,op1
	return		op1

abort_list_op:
	proc		0

bu_abort_list:
	scan		continue,(continue,next)

	error

wrong_number.p:
	print		319,arg1

	error

wrong_type.p:
	print		320,arg1,op1

	jump		bu_abort_list

wrong_char_length.p:
	print		359,op2

	jump		bu_abort_list

abs:						" builtin 01
	if_dt		int,iabs.1
	if_dt		real,abs.1
	if_dt		dp,dabs.1
	jump		cabs.1

iabs:						" builtin 02
	unless_dt		int,iabs.p
iabs.1:
	load_for_test	q,arg5
	tpl		3,ic
	erq		pr0|all_ones
	adq		1,dl
	jump		bu_ret_q

abs.1:
	load_for_test	eaq,arg5
	tpl		2,ic
	emit		1
	fneg
	jump		bu_ret_eaq

dabs:						" builtin 03
	unless_dt		dp,dabs.p
dabs.1:
	load_for_test	deaq,arg5
	tpl		2,ic
	emit		1
	fneg
	jump		bu_ret_deaq

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

iabs.p:
	jump		bu_dt5.p

dabs.p:
	jump		bu_dt5.p

cabs.p:
	jump		bu_dt5.p

alog:						" builtin 05
	if_dt		int,alog_i
	if_dt		real,alog.1
	if_dt		dp,dlog.1
	jump		clog.1

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

alog_i:
	s_call		cv_load.ir

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

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

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

dlog.p:
	jump		bu_dt5.p

clog.p:
	jump		bu_dt5.p

alog10:						" builtin 08
	if_dt		int,alog10_i
	if_dt		real,alog10.1
	if_dt		dp,dlog10.1
	jump		alog10.p

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

alog10_i:
	s_call		cv_load.ir

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

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

alog10.p:
	jump		bu_dt5.p

dlog10.p:
	jump		bu_dt5.p

atan:						" builtin 10
	if_dt		int,atan_i
	if_dt		real,atan.1
	if_dt		dp,datan.1
	jump		atan.p

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

atan_i:
	s_call		cv_load.ir

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

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

atan.p:
	jump		bu_dt5.p

datan.p:
	jump		bu_dt5.p

atan2:						" builtin 12
	dt_jump		(atan2_ii,atan2_ri,atan2_di,atan2_ci,atan2_ir,atan2_rr,atan2_dr,atan2_cr,atan2_id,atan2_rd,atan2_dd,atan2_cd,atan2_ic,atan2_rc,atan2_dc,atan2_cc,atan2_e2,atan2_e1,atan2_e2,atan2_e1)

atan2_ii:
	s_call		builtin_2args_ii
	jump		atan2.1

atan2_ir:
	s_call		builtin_2args_ir
	jump		atan2.1

atan2_ri:
	s_call		builtin_2args_ri
	jump		atan2.1

atan2_id:
	s_call		builtin_2args_id
	jump		datan2.1

atan2_di:
	s_call		builtin_2args_di
	jump		datan2.1

atan2_rr:
	jump		atan2.1

atan2_dd:
	jump		datan2.1

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

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

atan2_ic:
	jump		bu_dt6.p

atan2_ci:
	jump		bu_dt5.p

atan2_rc:
	jump		bu_dt6.p

atan2_cr:
	jump		bu_dt5.p

atan2_dc:
	jump		bu_dt6.p

atan2_cd:
	jump		bu_dt5.p

atan2_cc:
	jump		bu_dt5.p

atan2_e1:
	jump		bu_dt5.p

atan2_e2:
	jump		bu_dt6.p

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

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

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

atan2.p:
atan2_ee:
	jump		bu_dt6.p

cos:						" builtin 14
	if_dt		int,cos_i
	if_dt		real,cos.1
	if_dt		dp,dcos.1
	jump		ccos.1

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

cos_i:
	s_call		cv_load.ir

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

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

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

dcos.p:
	jump		bu_dt5.p

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

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

dim_ii:
	push_temp		int

	load		q,arg5
	use_eaq
	make_addressable	arg5,arg6
	cmpq		arg6
	tmi		2,ic
	ldq		arg6
	stq		op1
	ldq		arg5
	sbq		op1
	jump		bu_ret_q

dim_ir:
	s_call		builtin_2args_ir
	jump		dim.1

dim_ri:
	s_call		builtin_2args_ri
	jump		dim.1

dim_id:
	s_call		builtin_2args_id
	jump		ddim.1

dim_di:
	s_call		builtin_2args_di
	jump		ddim.1

dim_rr:
	jump		dim.1

dim_dd:
	jump		ddim.1

dim_rd:
	jump		rddim.1

dim_dr:
	jump		drdim.1

dim_ic:
	jump		bu_dt6.p

dim_ci:
	jump		bu_dt5.p

dim_rc:
	jump		bu_dt6.p

dim_cr:
	jump		bu_dt5.p

dim_dc:
	jump		bu_dt6.p

dim_cd:
	jump		bu_dt5.p

dim_cc:
	jump		bu_dt5.p

dim_e1:
	jump		bu_dt5.p

dim_e2:
	jump		bu_dt6.p

dim.1:
	load		eaq,arg5
	use_eaq
	make_addressable	arg5,arg6
	round		eaq
	fcmp		arg6
	tmi		2,ic
	fld		arg6
	emit		1
	fneg
	fad		arg5
	jump		bu_ret_eaq

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

ddim.1:
	load		deaq,arg5
	use_eaq
	make_addressable	arg5,arg6
	round		deaq
	dfcmp		arg6
	tmi		2,ic
	dfld		arg6
	emit		1
	fneg
	dfad		arg5
	jump		bu_ret_deaq

rddim.1:
	load		eaq,arg5
	use_eaq
	make_addressable	arg5,arg6
	round		deaq
	dfcmp		arg6
	tmi		2,ic
	dfld		arg6
	emit		1
	fneg
	fad		arg5
	jump		bu_ret_deaq

drdim.1:
	load		deaq,arg5
	use_eaq
	make_addressable	arg5,arg6
	fcmp		arg6
	tmi		2,ic
	fld		arg6
	emit		1
	fneg
	dfad		arg5
	jump		bu_ret_deaq

idim.p:
ddim.p:
	jump		bu_dt6.p

exp:						" builtin 20
	if_dt		int,exp_i
	if_dt		real,exp.1
	if_dt		dp,dexp.1
	jump		cexp.1

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

exp_i:
	s_call		cv_load.ir

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

dexp:						" builtin 21
	unless_dt		dp,dexp.p

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

cexp:						" builtin 22
	unless_dt		cmpx,cexp.p

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

dexp.p:
	jump		bu_dt5.p

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

max_ii:
	jump		g.max0

max_ir:
	s_call		builtin_2args_ir
	jump		g.amax1

max_ri:
	s_call		builtin_2args_ri
	jump		g.amax1

max_id:
	s_call		builtin_2args_id
	jump		g.dmax1

max_di:
	s_call		builtin_2args_di
	jump		g.dmax1

max_rr:
	jump		g.amax1

max_dd:
	jump		g.dmax1

max_rd:
	swap		op2
	load		eaq,op1
	round		eaq
	copy		op2
	jump		g.dmax1.loop.1

max_dr:
	swap		op2
	jump		max_rd

max_ic:
	jump		mm_dt1.p

max_ci:
	jump		mm_dt2.p

max_rc:
	jump		mm_dt1.p

max_cr:
	jump		mm_dt2.p

max_dc:
	jump		mm_dt1.p

max_cd:
	jump		mm_dt2.p

max_cc:
	jump		mm_dt1.p

max_e1:
	jump		mm_dt2.p

max_e2:
	jump		mm_dt1.p

g.max0:
	load_top		q
	use_eaq
	copy		op2
	jump		g.max0.loop.1

g.max0.loop:
	if_dt		int,g.max0.loop.1
	if_dt		real,g.max0.real
	if_dt		dp,g.max0.dp

	jump		mm_dt1.p

g.max0.real:
	tsx0		pr0|integer_to_real
	jump		g.amax1.loop.1

g.max0.dp:
	tsx0		pr0|integer_to_double
	jump		g.dmax1.loop.1

g.max0.loop.1:
	cmpq		op1
	tpl		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,g.max0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.max0.loop

g.max0.r:
	jump		mm_ret_q

g.amax1:
	load_top		eaq
	round		eaq
	copy		op2
	jump		g.amax1.loop.1

g.amax1.loop:
	if_dt		real,g.amax1.loop.1
	if_dt		int,g.amax1.int
	if_dt		dp,g.amax1.dp

	jump		mm_dt1.p

g.amax1.int:
	push_temp		real
	store		eaq,op1,no_update
	swap		op2

	s_call		cv_load.ir
	pop		op1
	jump		g.amax1.loop.1

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

g.amax1.loop.1:
	fcmp		op1
	tpl		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,g.amax1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.amax1.loop

g.amax1.r:
	jump		mm_ret_eaq

g.dmax1:
	load_top		deaq
	round		deaq
	copy		op2
	jump		g.dmax1.loop.1

g.dmax1.loop:
	if_dt		dp,g.dmax1.loop.1
	if_dt		int,g.dmax1.int
	if_dt		real,g.dmax1.real

	jump		mm_dt1.p

g.dmax1.int:
	push_temp		dp
	store		deaq,op1,no_update
	swap		op2

	s_call		cv_load.id
	pop		op1
	jump		g.dmax1.loop.1

g.dmax1.real:
	fcmp		op1
	tpl		2,ic
	fld		op1
	jump		g.dmax1.loop.2

g.dmax1.loop.1:
	dfcmp		op1
	tpl		2,ic
	dfld		op1

g.dmax1.loop.2:
	pop		op1

	if		arg2,=,2,g.dmax1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.dmax1.loop

g.dmax1.r:
	jump		mm_ret_deaq

amax0:						" builtin 24
	unless		arg2,>,1,wrong_number.p
	swap		op2
	unless_dt		int,amax0.p
	swap		op2
	unless_dt		int,amax0.p

	load_top		q
	use_eaq
	copy		op2

amax0.loop:
	cmpq		op1
	tpl		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,amax0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		int,amax0.p
	jump		amax0.loop

amax0.r:
	tsx0		pr0|integer_to_real
	jump		mm_ret_eaq

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

	load_top		eaq
	copy		op2

amax1.loop:
	fcmp		op1
	tpl		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,amax1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		real,amax1.p
	jump		amax1.loop

amax1.r:
	jump		mm_ret_eaq

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

	load_top		q
	copy		op2

max0.loop:
	cmpq		op1
	tpl		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,max0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		int,max0.p
	jump		max0.loop

max0.r:
	jump		mm_ret_q

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

	load_top		eaq
	round		eaq
	use_eaq
	copy		op2

max1.loop:
	fcmp		op1
	tpl		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,max1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		real,max1.p
	jump		max1.loop

max1.r:
	tsx0		pr0|real_to_integer
	jump		mm_ret_q

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

	load_top		deaq
	round		deaq
	copy		op2

dmax1.loop:
	dfcmp		op1
	tpl		2,ic
	dfld		op1
	pop		op1

	if		arg2,=,2,dmax1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		dp,dmax1.p
	jump		dmax1.loop

dmax1.r:
	jump		mm_ret_deaq

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

min_ii:
	jump		g.min0

min_ir:
	s_call		builtin_2args_ir
	jump		g.amin1

min_ri:
	s_call		builtin_2args_ri
	jump		g.amin1

min_id:
	s_call		builtin_2args_id
	jump		g.dmin1

min_di:
	s_call		builtin_2args_di
	jump		g.dmin1

min_rr:
	jump		g.amin1

min_dd:
	jump		g.dmin1

min_rd:
	swap		op2
	load		eaq,op1
	round		eaq
	copy		op2
	jump		g.dmin1.loop.1

min_dr:
	swap		op2
	jump		min_rd

min_ic:
	jump		mm_dt1.p

min_ci:
	jump		mm_dt2.p

min_rc:
	jump		mm_dt1.p

min_cr:
	jump		mm_dt2.p

min_dc:
	jump		mm_dt1.p

min_cd:
	jump		mm_dt2.p

min_cc:
	jump		mm_dt1.p

min_e1:
	jump		mm_dt2.p

min_e2:
	jump		mm_dt1.p

g.min0:
	load_top		q
	use_eaq
	copy		op2
	jump		g.min0.loop.1

g.min0.loop:
	if_dt		int,g.min0.loop.1
	if_dt		real,g.min0.real
	if_dt		dp,g.min0.dp

	jump		mm_dt1.p

g.min0.real:
	tsx0		pr0|integer_to_real
	jump		g.amin1.loop.1

g.min0.dp:
	tsx0		pr0|integer_to_double
	jump		g.dmin1.loop.1

g.min0.loop.1:
	cmpq		op1
	tmoz		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,g.min0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.min0.loop

g.min0.r:
	jump		mm_ret_q

g.amin1:
	load_top		eaq
	round		eaq
	copy		op2
	jump		g.amin1.loop.1

g.amin1.loop:
	if_dt		real,g.amin1.loop.1
	if_dt		int,g.amin1.int
	if_dt		dp,g.amin1.dp

	jump		mm_dt1.p

g.amin1.int:
	push_temp		real
	store		eaq,op1,no_update
	swap		op2

	s_call		cv_load.ir
	pop		op1
	jump		g.amin1.loop.1

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

g.amin1.loop.1:
	fcmp		op1
	tmoz		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,g.amin1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.amin1.loop

g.amin1.r:
	jump		mm_ret_eaq

g.dmin1:
	load_top		deaq
	round		deaq
	copy		op2
	jump		g.dmin1.loop.1

g.dmin1.loop:
	if_dt		dp,g.dmin1.loop.1
	if_dt		int,g.dmin1.int
	if_dt		real,g.dmin1.real

	jump		mm_dt1.p

g.dmin1.int:
	push_temp		dp
	store		deaq,op1,no_update
	swap		op2

	s_call		cv_load.id
	pop		op1
	jump		g.dmin1.loop.1

g.dmin1.real:
	fcmp		op1
	tmoz		2,ic
	fld		op1
	jump		g.dmin1.loop.2

g.dmin1.loop.1:
	dfcmp		op1
	tmoz		2,ic
	dfld		op1

g.dmin1.loop.2:
	pop		op1

	if		arg2,=,2,g.dmin1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	jump		g.dmin1.loop

g.dmin1.r:
	jump		mm_ret_deaq

amin0:						" builtin 30
	unless		arg2,>,1,wrong_number.p
	swap		op2
	unless_dt		int,amin0.p
	swap		op2
	unless_dt		int,amin0.p

	load_top		q
	use_eaq
	copy		op2

amin0.loop:
	cmpq		op1
	tmoz		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,amin0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		int,amin0.p
	jump		amin0.loop

amin0.r:
	tsx0		pr0|integer_to_real
	jump		mm_ret_eaq

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

	load_top		eaq
	round		eaq
	copy		op2

amin1.loop:
	fcmp		op1
	tmoz		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,amin1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		real,amin1.p
	jump		amin1.loop

amin1.r:
	jump		mm_ret_eaq

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

	load_top		q
	copy		op2

min0.loop:
	cmpq		op1
	tmoz		2,ic
	ldq		op1
	pop		op1

	if		arg2,=,2,min0.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		int,min0.p
	jump		min0.loop

min0.r:
	jump		mm_ret_q

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

	load_top		eaq
	round		eaq
	use_eaq
	copy		op2

min1.loop:
	fcmp		op1
	tmoz		2,ic
	fld		op1
	pop		op1

	if		arg2,=,2,min1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		real,min1.p
	jump		min1.loop

min1.r:
	tsx0		pr0|real_to_integer
	jump		mm_ret_q

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

	load_top		deaq
	round		deaq
	copy		op2

dmin1.loop:
	dfcmp		op1
	tmoz		2,ic
	dfld		op1
	pop		op1

	if		arg2,=,2,dmin1.r

	copy		arg2
	copy		opv
	decrement		arg2,1
	unless_dt		dp,dmin1.p
	jump		dmin1.loop

dmin1.r:
	jump		mm_ret_deaq

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

mod_ii:
	jump		mod.1

mod_ir:
	s_call		builtin_2args_ir
	jump		amod.1

mod_ri:
	s_call		builtin_2args_ri
	jump		amod.1

mod_id:
	s_call		builtin_2args_id
	jump		dmod.1

mod_di:
	s_call		builtin_2args_di
	jump		dmod.1

mod_rr:
	jump		amod.1

mod_dd:
	jump		dmod.1

mod_rd:
	jump		rdmod.1

mod_dr:
	jump		dmod.1

mod_ic:
	jump		bu_dt6.p

mod_ci:
	jump		bu_dt5.p

mod_rc:
	jump		bu_dt6.p

mod_cr:
	jump		bu_dt5.p

mod_dc:
	jump		bu_dt6.p

mod_cd:
	jump		bu_dt5.p

mod_cc:
	jump		bu_dt5.p

mod_e1:
	jump		bu_dt5.p

mod_e2:
	jump		bu_dt6.p

mod.1:
	load		q,arg5
	use_eaq
	div		arg6
	emit		1
	lrs		36
	jump		bu_ret_q

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

amod.1:
	load		eaq,arg5
	load_pr		pr2,arg6
	tsx0		pr0|fort_modfl
	free_regs
	jump		bu_ret_eaq

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

dmod.1:
	load		deaq,arg5
dmod.2:
	use_eaq
	load_pr		pr2,arg6
	tsx0		pr0|fort_dmod
	free_regs
	jump		bu_ret_deaq

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

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

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

sign_ii:
	load_pr		pr2,arg6
	load_for_test	q,arg5
	tsx0		pr0|sign_fx
	free_regs
	jump		bu_ret_q

sign_ir:
	s_call		builtin_2args_ir
	jump		sign.1

sign_ri:
	s_call		builtin_2args_ri
	jump		sign.1

sign_id:
	s_call		builtin_2args_id
	jump		dsign.1

sign_di:
	s_call		builtin_2args_di
	jump		dsign.1

sign_rr:
	jump		sign.1

sign_dd:
	jump		dsign.1

sign_rd:
	jump		rdsign.1

sign_dr:
	jump		dsign.1

sign_ic:
	jump		bu_dt6.p

sign_ci:
	jump		bu_dt5.p

sign_rc:
	jump		bu_dt6.p

sign_cr:
	jump		bu_dt5.p

sign_dc:
	jump		bu_dt6.p

sign_cd:
	jump		bu_dt5.p

sign_cc:
	jump		bu_dt5.p

sign_e1:
	jump		bu_dt5.p

sign_e2:
	jump		bu_dt6.p

sign.1:
	load_pr		pr2,arg6
	load_for_test	eaq,arg5
	tsx0		pr0|sign_fl
	free_regs
	jump		bu_ret_eaq

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

dsign.1:
	load_pr		pr2,arg6
	load_for_test	deaq,arg5
dsign.2:
	tsx0		pr0|sign_fl
	free_regs
	jump		bu_ret_deaq

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

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

	if_optype		constant,conv_bu_ii.1

	push_temp		real

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

conv_bu_ii.1:
	convert_constant	real

	swap		op2
	jump		builtin_2args_ii.1

builtin_2args_ii.1:
	if_optype		constant,conv_bu_ii.2

	push_temp		real

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

conv_bu_ii.2:
	convert_constant	real

	s_return

builtin_2args_ir:
	swap		op2

	if_optype		constant,conv_bu_ir

	push_temp		real

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

conv_bu_ir:
	convert_constant	real

	swap		op2
	s_return

builtin_2args_ri:
	if_optype		constant,conv_bu_ri

	push_temp		real

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

conv_bu_ri:
	convert_constant	real

	s_return

builtin_2args_id:
	swap		op2

	if_optype		constant,conv_bu_id

	push_temp		dp

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

conv_bu_id:
	convert_constant	dp

	swap		op2
	s_return

builtin_2args_di:
	if_optype		constant,conv_bu_di

	push_temp		dp

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

conv_bu_di:
	convert_constant	dp

	s_return

sin:						" builtin 41
	if_dt		int,sin_i
	if_dt		real,sin.1
	if_dt		dp,dsin.1
	jump		csin.1

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

sin_i:
	s_call		cv_load.ir

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

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

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

dsin.p:
csin.p:
	jump		bu_dt5.p

sqrt:						" builtin 44
	if_dt		int,sqrt_i
	if_dt		real,sqrt.1
	if_dt		dp,dsqrt.1
	jump		csqrt.1

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

sqrt_i:
	s_call		cv_load.ir

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

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

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

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

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

tanh.real:
	load		eaq,arg5

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

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


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


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

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

sinh.real:
	load		eaq,arg5

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

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


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


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

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

cosh.real:
	load		eaq,arg5

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

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


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


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

int_builtin.int:
	load		q,arg5
	jump		bu_ret_q

int_builtin.real:
	s_call		cv_load.ri
	jump		bu_ret_q

int_builtin.dp:
	s_call		cv_load.di
	jump		bu_ret_q

int_builtin.cmpx:
	s_call		cv_load.ri
	jump		bu_ret_q

int_builtin.tl:
	load		q,arg5
	jump		bu_ret_q


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


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


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

aint.int:
	s_call		cv_load.ir
	jump		bu_ret_eaq

aint.real:
	load_for_test	eaq,arg5
	tsx0		pr0|trunc_fl
	jump		bu_ret_eaq

aint.dp:
	load_for_test	deaq,arg5
	tsx0		pr0|trunc_fl
	jump		bu_ret_deaq


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


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

anint.int:
	s_call		cv_load.ir
	jump		bu_ret_eaq

anint.real:
	load_for_test	eaq,arg5
	tsx0		pr0|nearest_whole_number
	jump		bu_ret_eaq

anint.dp:
	load_for_test	deaq,arg5
	tsx0		pr0|nearest_whole_number
	jump		bu_ret_deaq


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


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

nint.int:
	load		q,arg5
	jump		bu_ret_q

nint.real:
	load_for_test	eaq,arg5
	use_eaq
	tsx0		pr0|nearest_integer
	jump		bu_ret_q

nint.dp:
	load_for_test	deaq,arg5
	use_eaq
	tsx0		pr0|nearest_integer
	jump		bu_ret_q


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


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

real_builtin.int:
	s_call		cv_load.ir
	jump		bu_ret_eaq

real_builtin.real:
	load		eaq,arg5
	jump		bu_ret_eaq

real_builtin.dp:
	load		deaq,arg5
	emit		1
	frd		0
	jump		bu_ret_eaq

real_builtin.cmpx:
	load		eaq,arg5
	jump		bu_ret_eaq


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


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


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

	load		ieaq,arg5
	jump		bu_ret_eaq

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

dble.int:
	s_call		cv_load.id
	jump		bu_ret_deaq

dble.real:
	load		eaq,arg5
	jump		bu_ret_deaq

dble.dp:
	load		deaq,arg5
	jump		bu_ret_deaq

dble.cmpx:
	load		eaq,arg5
	jump		bu_ret_deaq

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

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

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

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

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

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

cmplx.one.join:
	reset_eaq
	push_temp		cmpx
	store		eaq,op1,no_update
	fld		=0.0,du
	fst		op1+1
	return		op1

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

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

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

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

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

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

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

cmplx.two.e1:
	jump		mm_dt2.p

cmplx.two.e2:
	jump		mm_dt1.p

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

	push_temp		cmpx

	use_ind
	if_eaq		ieaq,arg5,conjg.1

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

	scan		continue,(continue,next)
	return		op1

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

	scan		continue,(continue,next)
	return		op1

conjg.p:
	jump		bu_dt5.p

tan:						" builtin 59
	if_dt		int,tan_i
	if_dt		real,tan.1
	if_dt		dp,dtan.1
	jump		tan.p

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

tan_i:
	s_call		cv_load.ir

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

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

tan.p:
	jump		bu_dt5.p

dtan.p:
	jump		bu_dt5.p

asin:						" builtin 61
	if_dt		int,asin_i
	if_dt		real,asin.1
	if_dt		dp,dasin.1
	jump		asin.p

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

asin_i:
	s_call		cv_load.ir

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

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

asin.p:
	jump		bu_dt5.p

dasin.p:
	jump		bu_dt5.p

acos:						" builtin 63
	if_dt		int,acos_i
	if_dt		real,acos.1
	if_dt		dp,dacos.1
	jump		acos.p

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

acos_i:
	s_call		cv_load.ir

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

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

acos.p:
	jump		bu_dt5.p

dacos.p:
	jump		bu_dt5.p

char_builtin:						" builtin 65
	unless_dt		int,char.p

	if_optype		constant,char.constant

	push_char_temp	1

	load		q,op2

	emit_inst		1
	qls		27

	stq		op1

	reset_eaq

	jump		bu_ret_op1

char.constant:
	int_to_char1
	jump		bu_ret_op1

char.p:
	jump		bu_dt1.p

ichar:						" builtin 66
	unless_dt		char,ichar.p

	if_optype		constant,ichar.constant

	push_temp		int

	if_aligned	op2,ichar.aligned

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

	set_in_storage	op1

	jump		bu_ret_op1

ichar.aligned:
	use_eaq

	ldq		op2

	emit_inst		1
	qrl		27

	jump		bu_ret_q

ichar.constant:
	char1_to_int
	jump		bu_ret_op1

ichar.p:
	jump		bu_dt1.p

index:						" builtin 67
	unless_dt		char,index.p
	swap		op2
	unless_dt		char,index.p

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

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

	push_length	op2

	use_eaq

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

	free_regs

	use_eaq

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

	free_regs

	jump		bu_ret_q

index.1:

	" Length of second string is known to be 1

	use_eaq

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

	arg		pr6|double_temp

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

	jump		bu_ret_q

index.2:

	" Length of second string is known to be 2

	use_eaq

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

	arg		pr6|double_temp

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

	jump		bu_ret_q

index.p:
	jump		bu_dt1.p

len:						" builtin 68
	unless_dt		char,len.p

	push_length	op1

	jump		bu_ret_op1

len.p:
	jump		bu_dt1.p

lge:						" builtin 69
	unless_dt		char,lge.p
	swap		op2
	unless_dt		char,lge.p

	use_ind

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

	jump		bu_ret_trc

lge.p:
	jump		bu_dt1.p

lgt:						" builtin 70
	unless_dt		char,lgt.p
	swap		op2
	unless_dt		char,lgt.p

	use_ind

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

	jump		bu_ret_tnc

lgt.p:
	jump		bu_dt1.p

lle:						" builtin 71
	unless_dt		char,lle.p
	swap		op2
	unless_dt		char,lle.p

	use_ind

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

	jump		bu_ret_trc

lle.p:
	jump		bu_dt1.p

llt:						"builtin 72
	unless_dt		char,llt.p
	swap		op2
	unless_dt		char,llt.p

	use_ind

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

	jump		bu_ret_tnc

llt.p:
	jump		bu_dt1.p

dprod:						" builtin 83
	swap		arg5
	unless_dt		real,dprod.p
	swap		arg5
	unless_dt		real,dprod.p
	load_top		eaq
	fmp		op2
	jump		bu_ret_deaq

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

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

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

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

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

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

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

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

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

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

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

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

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

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

xor.tl.r:
	jump		mm_ret_tq

bu_dt1.p:
	print		321,arg1,op1
	jump		bu_abort_list

bu_dt2.p:
	print		321,arg1,op2
	jump		bu_abort_list

bu_dt5.p:
	print		321,arg1,arg5
	jump		bu_abort_list

bu_dt6.p:
	print		321,arg1,arg6
	jump		bu_abort_list

mm_dt1.p:
	error		321,arg1,op1

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

logical_op2:
	error		339,op2

invalid_opnd:
	error		340,op2

not_scalar:
	error		340,op1

typeless_op1:
	error		362,op1

typeless_op2:
	error		362,op2
"
"		Begin relational operators.
"
less:	func		2

	use_ind

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

less_ii:
	if_eaq		q,arg2,less_ii.1

	load		q,arg1
	cmpq		arg2
	return		tmi

less_ii.1:
	cmpq		arg1
	return		tpnz

less_ir:
	swap		arg1

	s_call		cv_load.ir
	fcmp		arg1
	return		tmi

less_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tpnz

less_id:
	swap		arg1

	s_call		cv_load.id
	dfcmp		arg1
	return		tmi

less_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tpnz

less_rr:
	if_eaq		eaq,arg2,less_rr.1

	load		eaq,arg1
	round		eaq
	fcmp		arg2
	return		tmi

less_rr.1:
	round		eaq
	fcmp		arg1
	return		tpnz

less_dd:
	if_eaq		deaq,arg2,less_dd.1

	load		deaq,arg1
	round		deaq
	dfcmp		arg2
	return		tmi

less_dd.1:
	round		deaq
	dfcmp		arg1
	return		tpnz

less_rd:
	if_eaq		deaq,arg2,less_rd.1

	load		eaq,arg1
	dfcmp		arg2
	return		tmi

less_rd.1:
	round		deaq
	fcmp		arg1
	return		tpnz

less_dr:
	if_eaq		eaq,arg2,less_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tmi

less_dr.1:
	dfcmp		arg1
	return		tpnz

less_ic:
	error		323,arg2

less_ci:
	error		323,arg1

less_rc:
	error		323,arg2

less_cr:
	error		323,arg1

less_dc:
	error		312,arg1,arg2

less_cd:
	error		311,arg1,arg2

less_cc:
	error		328,arg1,arg2

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

less_ih:
less_rh:
less_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg2
	cmpa		arg1
	return		tnc

less_dh:
less_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg2
	cmpaq		arg1
	return		tnc

less_hh:
	use_eaq

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

	return		tnc

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

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

less_hi:
less_hr:
less_ht:
	pad_char_const_to_word	arg2

	load		a,arg2
	cmpa		arg1
	return		tnc

less_hd:
less_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg2
	cmpaq		arg1
	return		tnc

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

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

	load		tq,arg1
	cmpq		arg2
	return		tmi

less_tl.2:
	cmpq		arg1
	return		tpnz

less_or_equal:
	func		2

	use_ind

	dt_jump		(less_or_equal_ii,less_or_equal_ri,less_or_equal_di,less_or_equal_ci,less_or_equal_ir,less_or_equal_rr,less_or_equal_dr,less_or_equal_cr,less_or_equal_id,less_or_equal_rd,less_or_equal_dd,less_or_equal_cd,less_or_equal_ic,less_or_equal_rc,less_or_equal_dc,less_or_equal_cc,less_or_equal_e2,less_or_equal_e1,less_or_equal_tl,less_or_equal_tl)

less_or_equal_ii:
	if_eaq		q,arg2,less_or_equal_ii.1

	load		q,arg1
	cmpq		arg2
	return		tmoz

less_or_equal_ii.1:
	cmpq		arg1
	return		tpl

less_or_equal_ir:
	swap		arg1

	s_call		cv_load.ir
	fcmp		arg1
	return		tmoz

less_or_equal_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tpl

less_or_equal_id:
	swap		arg1

	s_call		cv_load.id
	dfcmp		arg1
	return		tmoz

less_or_equal_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tpl

less_or_equal_rr:
	if_eaq		eaq,arg2,less_or_equal_rr.1

	load		eaq,arg1
	round		eaq
	fcmp		arg2
	return		tmoz

less_or_equal_rr.1:
	round		eaq
	fcmp		arg1
	return		tpl

less_or_equal_dd:
	if_eaq		deaq,arg2,less_or_equal_dd.1

	load		deaq,arg1
	round		deaq
	dfcmp		arg2
	return		tmoz

less_or_equal_dd.1:
	round		deaq
	dfcmp		arg1
	return		tpl

less_or_equal_rd:
	if_eaq		deaq,arg2,less_or_equal_rd.1

	load		eaq,arg1
	dfcmp		arg2
	return		tmoz

less_or_equal_rd.1:
	round		deaq
	fcmp		arg1
	return		tpl

less_or_equal_dr:
	if_eaq		eaq,arg2,less_or_equal_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tmoz

less_or_equal_dr.1:
	dfcmp		arg1
	return		tpl

less_or_equal_ic:
	error		323,arg2

less_or_equal_ci:
	error		323,arg1

less_or_equal_rc:
	error		323,arg2

less_or_equal_cr:
	error		323,arg1

less_or_equal_dc:
	error		312,arg1,arg2

less_or_equal_cd:
	error		311,arg1,arg2

less_or_equal_cc:
	error		328,arg1,arg2

less_or_equal_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(less_or_equal_ih,less_or_equal_rh,less_or_equal_dh,less_or_equal_ch,logical_op2,less_or_equal_hh,less_or_equal_th)

less_or_equal_ih:
less_or_equal_rh:
less_or_equal_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg1
	cmpa		arg2
	return		trc

less_or_equal_dh:
less_or_equal_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg1
	cmpaq		arg2
	return		trc

less_or_equal_hh:
	use_eaq

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

	return		trc

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

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(less_or_equal_hi,less_or_equal_hr,less_or_equal_hd,less_or_equal_hc,logical_op1,less_or_equal_hh,less_or_equal_ht)

less_or_equal_hi:
less_or_equal_hr:
less_or_equal_ht:
	pad_char_const_to_word	arg2

	load		a,arg1
	cmpa		arg2
	return		trc

less_or_equal_hd:
less_or_equal_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg1
	cmpaq		arg2
	return		trc

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

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

	load		tq,arg1
	cmpq		arg2
	return		tmoz

less_or_equal_tl.2:
	cmpq		arg1
	return		tpl


equal:	func		2

	use_ind

	dt_jump		(equal_ii,equal_ri,equal_di,equal_ci,equal_ir,equal_rr,equal_dr,equal_cr,equal_id,equal_rd,equal_dd,equal_cd,equal_ic,equal_rc,equal_dc,equal_cc,equal_e2,equal_e1,equal_tl,equal_tl)

equal_ii:
	load_top		q
	cmpq		arg1
	return		tze

equal_ir:
	swap		arg1

equal_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tze

equal_id:
	swap		arg1

equal_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tze

equal_rr:
	load_top		eaq
	round		eaq
	fcmp		arg1
	return		tze

equal_dd:
	load_top		deaq
	round		deaq
	dfcmp		arg1
	return		tze

equal_rd:
	swap		arg1

equal_dr:
	if_eaq		eaq,arg2,equal_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tze

equal_dr.1:
	dfcmp		arg1
	return		tze

equal_ic:
	error		323,arg2

equal_ci:
	error		323,arg1

equal_rc:
	error		323,arg2

equal_cr:
	error		323,arg1

equal_dc:
	error		312,arg1,arg2

equal_cd:
	error		311,arg1,arg2

equal_cc:
	load_top		aq
	cmpaq		arg1
	return		tze

equal_e2:
	if_dt		char,equal_ah
	swap		arg1	" top is logical, so swap and test

	if_dt		logical,equal_ll
	error		313,op1

equal_ll:
	load_top		a
	cmpa		arg1
	return		tze

equal_ah:
	dt_jump1		arg1,(equal_ih,equal_rh,equal_dh,equal_ch,logical_op2,equal_hh,equal_th)

equal_ih:
equal_rh:
equal_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load_top		a
	cmpa		arg1
	return		tze

equal_dh:
equal_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load_top		aq
	cmpaq		arg1
	return		tze

equal_hh:
	use_eaq

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

	return		tze

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

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(equal_hi,equal_hr,equal_hd,equal_hc,logical_op1,equal_hh,equal_ht)

equal_hi:
equal_hr:
equal_ht:
	pad_char_const_to_word	arg2

	load_top		a
	cmpa		arg1
	return		tze

equal_hd:
equal_hc:
	pad_char_const_to_dw	arg2

	load_top		aq
	cmpaq		arg1
	return		tze

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

equal_tl.1:
	load_top		tq
	cmpq		arg1
	return		tze


not_equal:
	func		2

	use_ind

	dt_jump		(not_equal_ii,not_equal_ri,not_equal_di,not_equal_ci,not_equal_ir,not_equal_rr,not_equal_dr,not_equal_cr,not_equal_id,not_equal_rd,not_equal_dd,not_equal_cd,not_equal_ic,not_equal_rc,not_equal_dc,not_equal_cc,not_equal_e2,not_equal_e1,not_equal_tl,not_equal_tl)

not_equal_ii:
	load_top		q
	cmpq		arg1
	return		tnz

not_equal_ir:
	swap		arg1

not_equal_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tnz

not_equal_id:
	swap		arg1

not_equal_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tnz

not_equal_rr:
	load_top		eaq
	round		eaq
	fcmp		arg1
	return		tnz

not_equal_dd:
	load_top		deaq
	round		deaq
	dfcmp		arg1
	return		tnz

not_equal_rd:
	swap		arg1

not_equal_dr:
	if_eaq		eaq,arg2,not_equal_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tnz

not_equal_dr.1:
	dfcmp		arg1
	return		tnz

not_equal_ic:
	error		323,arg2

not_equal_ci:
	error		323,arg1

not_equal_rc:
	error		323,arg2

not_equal_cr:
	error		323,arg1

not_equal_dc:
	error		312,arg1,arg2

not_equal_cd:
	error		311,arg1,arg2

not_equal_cc:
	load_top		aq
	cmpaq		arg1
	return		tnz

not_equal_e2:
	if_dt		char,not_equal_ah
	swap		arg1	" top is logical, so swap and test other

	if_dt		logical,not_equal_ll
	error		313,op1

not_equal_ll:
	load_top		a
	cmpa		arg1
	return		tnz

not_equal_ah:
	dt_jump1		arg1,(not_equal_ih,not_equal_rh,not_equal_dh,not_equal_ch,logical_op2,not_equal_hh,not_equal_th)

not_equal_ih:
not_equal_rh:
not_equal_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load_top		a
	cmpa		arg1
	return		tnz

not_equal_dh:
not_equal_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load_top		aq
	cmpaq		arg1
	return		tnz

not_equal_hh:
	use_eaq

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

	return		tnz

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

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(not_equal_hi,not_equal_hr,not_equal_hd,not_equal_hc,logical_op1,not_equal_hh,not_equal_ht)

not_equal_hi:
not_equal_hr:
not_equal_ht:
	pad_char_const_to_word	arg2

	load_top		a
	cmpa		arg1
	return		tnz

not_equal_hd:
not_equal_hc:
	pad_char_const_to_dw	arg2

	load_top		aq
	cmpaq		arg1
	return		tnz


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

not_equal_tl.1:
	load_top		tq
	cmpq		arg1
	return		tnz

greater_or_equal:
	func		2

	use_ind

	dt_jump		(greater_or_equal_ii,greater_or_equal_ri,greater_or_equal_di,greater_or_equal_ci,greater_or_equal_ir,greater_or_equal_rr,greater_or_equal_dr,greater_or_equal_cr,greater_or_equal_id,greater_or_equal_rd,greater_or_equal_dd,greater_or_equal_cd,greater_or_equal_ic,greater_or_equal_rc,greater_or_equal_dc,greater_or_equal_cc,greater_or_equal_e2,greater_or_equal_e1,greater_or_equal_tl,greater_or_equal_tl)

greater_or_equal_ii:
	if_eaq		q,arg2,greater_or_equal_ii.1

	load		q,arg1
	cmpq		arg2
	return		tpl

greater_or_equal_ii.1:
	cmpq		arg1
	return		tmoz

greater_or_equal_ir:
	swap		arg1

	s_call		cv_load.ir
	fcmp		arg1
	return		tpl

greater_or_equal_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tmoz

greater_or_equal_id:
	swap		arg1

	s_call		cv_load.id
	dfcmp		arg1
	return		tpl

greater_or_equal_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tmoz

greater_or_equal_rr:
	if_eaq		eaq,arg2,greater_or_equal_rr.1

	load		eaq,arg1
	round		eaq
	fcmp		arg2
	return		tpl

greater_or_equal_rr.1:
	round		eaq
	fcmp		arg1
	return		tmoz

greater_or_equal_dd:
	if_eaq		deaq,arg2,greater_or_equal_dd.1

	load		deaq,arg1
	round		deaq
	dfcmp		arg2
	return		tpl

greater_or_equal_dd.1:
	round		deaq
	dfcmp		arg1
	return		tmoz

greater_or_equal_rd:
	if_eaq		deaq,arg2,greater_or_equal_rd.1

	load		eaq,arg1
	dfcmp		arg2
	return		tpl

greater_or_equal_rd.1:
	round		deaq
	fcmp		arg1
	return		tmoz

greater_or_equal_dr:
	if_eaq		eaq,arg2,greater_or_equal_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tpl

greater_or_equal_dr.1:
	dfcmp		arg1
	return		tmoz

greater_or_equal_ic:
	error		323,arg2

greater_or_equal_ci:
	error		323,arg1

greater_or_equal_rc:
	error		323,arg2

greater_or_equal_cr:
	error		323,arg1

greater_or_equal_dc:
	error		312,arg1,arg2

greater_or_equal_cd:
	error		311,arg1,arg2

greater_or_equal_cc:
	error		328,arg1,arg2

greater_or_equal_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(greater_or_equal_ih,greater_or_equal_rh,greater_or_equal_dh,greater_or_equal_ch,logical_op2,greater_or_equal_hh,greater_or_equal_th)

greater_or_equal_ih:
greater_or_equal_rh:
greater_or_equal_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg2
	cmpa		arg1
	return		trc

greater_or_equal_dh:
greater_or_equal_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg2
	cmpaq		arg1
	return		trc

greater_or_equal_hh:
	use_eaq

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

	return		trc

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

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(greater_or_equal_hi,greater_or_equal_hr,greater_or_equal_hd,greater_or_equal_hc,logical_op1,greater_or_equal_hh,greater_or_equal_ht)

greater_or_equal_hi:
greater_or_equal_hr:
greater_or_equal_ht:
	pad_char_const_to_word	arg2

	load		a,arg2
	cmpa		arg1
	return		trc

greater_or_equal_hd:
greater_or_equal_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg2
	cmpaq		arg1
	return		trc

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

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

	load		tq,arg1
	cmpq		arg2
	return		tpl

greater_or_equal_tl.2:
	cmpq		arg1
	return		tmoz

greater:	func		2

	use_ind

	dt_jump		(greater_ii,greater_ri,greater_di,greater_ci,greater_ir,greater_rr,greater_dr,greater_cr,greater_id,greater_rd,greater_dd,greater_cd,greater_ic,greater_rc,greater_dc,greater_cc,greater_e2,greater_e1,greater_tl,greater_tl)

greater_ii:
	if_eaq		q,arg2,greater_ii.1

	load		q,arg1
	cmpq		arg2
	return		tpnz

greater_ii.1:
	cmpq		arg1
	return		tmi

greater_ir:
	swap		arg1

	s_call		cv_load.ir
	fcmp		arg1
	return		tpnz

greater_ri:
	s_call		cv_load.ir
	fcmp		arg1
	return		tmi

greater_id:
	swap		arg1

	s_call		cv_load.id
	dfcmp		arg1
	return		tpnz

greater_di:
	s_call		cv_load.id
	dfcmp		arg1
	return		tmi

greater_rr:
	if_eaq		eaq,arg2,greater_rr.1

	load		eaq,arg1
	round		eaq
	fcmp		arg2
	return		tpnz

greater_rr.1:
	round		eaq
	fcmp		arg1
	return		tmi

greater_dd:
	if_eaq		deaq,arg2,greater_dd.1

	load		deaq,arg1
	round		deaq
	dfcmp		arg2
	return		tpnz

greater_dd.1:
	round		deaq
	dfcmp		arg1
	return		tmi

greater_rd:
	if_eaq		deaq,arg2,greater_rd.1

	load		eaq,arg1
	dfcmp		arg2
	return		tpnz

greater_rd.1:
	round		deaq
	fcmp		arg1
	return		tmi

greater_dr:
	if_eaq		eaq,arg2,greater_dr.1

	load		deaq,arg1
	round		deaq
	fcmp		arg2
	return		tpnz

greater_dr.1:
	dfcmp		arg1
	return		tmi

greater_ic:
	error		323,arg2

greater_ci:
	error		323,arg1

greater_rc:
	error		323,arg2

greater_cr:
	error		323,arg1

greater_dc:
	error		312,arg1,arg2

greater_cd:
	error		311,arg1,arg2

greater_cc:
	error		328,arg1,arg2

greater_e2:
	if_dt		logical,logical_op1
	dt_jump1		arg1,(greater_ih,greater_rh,greater_dh,greater_ch,logical_op2,greater_hh,greater_th)

greater_ih:
greater_rh:
greater_th:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_word	arg1	" the two operands remain swapped

	load		a,arg1
	cmpa		arg2
	return		tnc

greater_dh:
greater_ch:
	unless_optype	constant,invalid_opnd

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

	pad_char_const_to_dw	arg1	" the two operands remain swapped

	load		aq,arg1
	cmpaq		arg2
	return		tnc

greater_hh:
	use_eaq

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

	return		tnc

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

	swap		arg1
	unless_optype	constant,invalid_opnd
"				Operands remain swapped.
	dt_jump1		arg2,(greater_hi,greater_hr,greater_hd,greater_hc,logical_op1,greater_hh,greater_ht)

greater_hi:
greater_hr:
greater_ht:
	pad_char_const_to_word	arg2

	load		a,arg1
	cmpa		arg2
	return		tnc

greater_hd:
greater_hc:
	pad_char_const_to_dw	arg2

	load		aq,arg1
	cmpaq		arg2
	return		tnc

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

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

	load		tq,arg1
	cmpq		arg2
	return		tpnz

greater_tl.2:
	cmpq		arg1
	return		tmi

or:	func		2

	unless_dt		logical,or_e2
	swap		arg1
	unless_dt		logical,or_e1

	load_top		a
	ora		arg1
	return		a

or_e1:
	error		313,arg1

or_e2:
	error		313,arg2

and:	func		2

	unless_dt		logical,and_e2
	swap		arg1
	unless_dt		logical,and_e1

	load_top		a
	ana		arg1
	return		a

and_e1:
	error		313,arg1

and_e2:
	error		313,arg2

not:	func		1		

	unless_dt		logical,not.e

	if_eaq		ind,op1,not_ind

	load		a,op1
	era		=o400000,du
	return		a

not_ind:
	ind_jump		(not_tze,not_tnz,not_tmi,not_tpl,not_tmoz,not_tpnz,not_tnc,not_trc)

not_tze:
	return		tnz

not_tnz:
	return		tze

not_tmi:
	return		tpl

not_tpl:
	return		tmi

not_tmoz:
	return		tpnz

not_tpnz:
	return		tmoz

not_tnc:
	return		trc

not_trc:
	return		tnc

not.e:
	error		313,op1

equiv:	func		2

	unless_dt		logical,equiv.p
	swap		arg1
	unless_dt		logical,equiv.p

	use_ind

	load_top		a
	cmpa		arg1
	return		tze


not_equiv:
	func		2

	unless_dt		logical,not_equiv.p
	swap		arg1
	unless_dt		logical,not_equiv.p

	use_ind

	load_top		a
	cmpa		arg1
	return		tnz


equiv.p:
not_equiv.p:
	error		313,op1

jump:	proc		1


	shorten_stack

	tra		arg1
	return

jump_logical:
	proc		1

	unless_dt		logical,jump_logical.p

	shorten_stack	protect_indicators

	push_label

	if_eaq		ind,arg1,jump_logical_ind

	load		a,arg1


	if_ind		a,emit_tze

	cmpa		0,dl	" set the indicators

emit_tze:
	tze		op1
	jump		jl_statement

jump_logical_ind:


	ind_jump		(jump_logical_tze,jump_logical_tnz,jump_logical_tmi,jump_logical_tpl,jump_logical_tmoz,jump_logical_tpnz,jump_logical_tnc,jump_logical_trc)

jump_logical_tze:
	tnz		op1
	jump		jl_statement

jump_logical_tnz:
	tze		op1
	jump		jl_statement

jump_logical_tmi:
	tpl		op1
	jump		jl_statement

jump_logical_tpl:
	tmi		op1
	jump		jl_statement

jump_logical_tmoz:
	tpnz		op1
	jump		jl_statement

jump_logical_tpnz:
	tmoz		op1
	jump		jl_statement

jump_logical_tnc:
	trc		op1
	jump		jl_statement

jump_logical_trc:
	tnc		op1
	jump		jl_statement

jump_logical.p:
	print		324,op1
	scan		continue,next
	return

jl_statement:
	swap		arg1
	pop		op1

	scan		continue,next

	label		op1
	return

jump_arithmetic:
	proc		4

	swap		arg1

	unless_dt		(int,real,dp),jump_arithmetic.e

	shorten_stack

	if_dt		int,jump_arithmetic_i
	if_dt		real,jump_arithmetic_r
	swap		arg1

	unless_eaq	deaq,arg1,jump_arithmetic_r.1

	if_ind		deaq,jump_arithmetic.01

	fcmp		=0.,du
	in_reg		deaq,arg1

	jump		jump_arithmetic.01

jump_arithmetic_i:
	swap		arg1
	unless_eaq	q,arg1,jump_arithmetic_i.1

	if_ind		q,jump_arithmetic.01

	cmpq		0,dl
	in_reg		q,arg1

	jump		jump_arithmetic.01

jump_arithmetic_i.1:
	use_ind
	szn		arg1
	jump		jump_arithmetic.01

jump_arithmetic_r:
	swap		arg1

	unless_eaq	eaq,arg1,jump_arithmetic_r.1

	if_ind		eaq,jump_arithmetic.01

	fcmp		=0.,du
	in_reg		eaq,arg1

	jump		jump_arithmetic.01

jump_arithmetic_r.1:
	use_ind
	use_eaq			" so we dont have to invent use_eaq protect_indicators
	fszn		arg1
	jump		jump_arithmetic.01

jump_arithmetic.01:
	swap		arg1
	pop		arg4


	swap		arg2
	swap		arg1

	push_label

	swap		arg3
	if_optype		rel_constant,ja3

	copy		arg3
	swap		arg4
	pop		arg5

ja3:
	swap		arg3

	swap		arg2
	if_optype		rel_constant,ja2

	copy		arg2
	swap		arg4
	pop		arg5

ja2:
	swap		arg2

	swap		arg1
	if_optype		rel_constant,ja1

	copy		arg1
	swap		arg4
	pop		arg5

ja1:
	swap		arg1

	swap		arg3

	if		arg1,=,op1,jump_arithmetic_13
	if		arg2,=,op1,jump_arithmetic_23

	swap		arg1

	if		arg2,=,op1,jump_arithmetic_12

	swap		arg1
	swap		arg3

	tmi		arg1
	tze		arg2
	tra		arg3
	label		op1
	return

jump_arithmetic_12:
	swap		arg1
	swap		arg3

	tmoz		arg1
	tra		arg3
	label		op1
	return

jump_arithmetic_13:
	swap		arg3

	tnz		arg1
	tra		arg2
	label		op1
	return

jump_arithmetic_23:
	swap		arg3

	tpl		arg2
	tra		arg1
	label		op1
	return

jump_arithmetic.e:
	error		325,op1

jump_computed:
	proc		1

	if		arg1,<,1,jc_list.p

	copy		arg1

	push_label		"push fall_through label

	scan		jc_error,(continue,next)

	scan		continue,next

	unless_dt		(int,real,dp,cmpx),jump_computed.p

	shorten_stack

	if_dt		int,jump_computed_i
	if_dt		real,jump_computed_r
	if_dt		dp,jump_computed_d
	jump		jump_computed_r

jump_computed_i:
	load		q,op1
	jump		jc_transfer

jump_computed_r:
	s_call		cv_load.ri
	jump		jc_transfer

jump_computed_d:
	s_call		cv_load.di
	jump		jc_transfer

jc_transfer:
	pop		op1


	if_ind		q,jc_tmoz
	cmpq		0,dl

jc_tmoz:
	tmoz		arg3
	cmpq		arg1
	tpnz		arg3

	push_label
	adq		op1
	label		op1

	tra		0,ql

	pop		op1

jc_labels:
	copy		arg2
	tra		opv
	decrement		arg2,1
	if		arg2,^=,0,jc_labels

jc_ret:
	label		arg3	this is fall_through label
	return

jc_list.p:
	print		327

	scan		continue,(continue,next)
	scan		continue,next
	jump		jc_ret

jump_computed.p:
	print		326,arg1
	return

jc_error:
	print		342,op1

	scan		continue,(continue,next)
	scan		continue,next
	jump		jc_ret

jump_assigned:
	proc		1

	unless_dt		int,jump_assigned.e

	unless_array	jump_assigned.1

	print		300,op1

jump_assigned.1:
	use_ind
	shorten_stack

	ldx0		arg1

	tra		0,0
	return

jump_assigned.e:
	print		301,op1
	return

assign_label:
	proc		2

	unless_dt		int,assign_label.e
	unless_array	assign_label.1

	print		300,op1

assign_label.1:
	swap		arg1
	if_optype		rel_constant,assign_label.2

	" The label is on a format statement.

	load_pr		pr2,arg2
	sprp2		arg1
	flush_ref		arg1
	free_regs
	return

	" The label is on an executable statement.

assign_label.2:
	use_ind
	eax0		arg2
	stx0		arg1
	flush_ref		arg1
	return

assign_label.e:
	print		301,op1
	return

block_if:
	proc		2

	swap		arg1
	unless_dt		logical,block_if.p
	swap		arg1

	shorten_stack	protect_indicators

	push_label
	push_label

	" arg1: predicate
	" arg2: clause count
	" arg3: label for end of entire block IF
	" arg4: label for end of current clause

	if_eaq		ind,arg1,block_if.ind

	load		a,arg1
	if_ind		a,block_if.no_cmpa
	cmpa		0,dl

block_if.no_cmpa:
	tze		arg4
	jump		block_if.pop_predicate

block_if.ind:
	ind_jump		(block_if.tze,block_if.tnz,block_if.tmi,block_if.tpl,block_if.tmoz,block_if.tpnz,block_if.tnc,block_if.trc)

block_if.tze:
	tnz		arg4
	jump		block_if.pop_predicate

block_if.tnz:
	tze		arg4
	jump		block_if.pop_predicate

block_if.tmi:
	tpl		arg4
	jump		block_if.pop_predicate

block_if.tpl:
	tmi		arg4
	jump		block_if.pop_predicate

block_if.tmoz:
	tpnz		arg4
	jump		block_if.pop_predicate

block_if.tpnz:
	tmoz		arg4
	jump		block_if.pop_predicate

block_if.tnc:
	trc		arg4
	jump		block_if.pop_predicate

block_if.trc:
	tnc		arg4
	jump		block_if.pop_predicate

block_if.pop_predicate:

	" The predicate is no longer needed, so we can get rid of it now.
	" By doing this, we will avoid storing it.

	swap		arg1
	pop		op1
	swap		arg1

	" At this point, the stack format is
	" arg1: label for end of entire block IF
	" arg2: clause count
	" arg3: label for end of current clause

block_if_loop:
	scan		continue,(next,block_if_end)

	decrement		arg2,1
	if		arg2,=,0,block_if.no_tra
	tra		arg1

block_if.no_tra:
	label		arg3		" Mark end of clause

	if		arg2,=,0,block_if_loop
	pop		arg3
	push_label			" Get new end of clause lbl

	" The new end of clause label is passed to the first operator in
	" the new clause, which will either be an ELSE_IF or ELSE operator.

	copy		arg3
	jump		block_if_loop

block_if_end:
	label		arg1		" Mark end of block IF
	return

block_if.p:
	print		324,op1
	scan		continue,(continue,next)
	return

else_if:
	proc		2

	unless_dt		logical,else_if.p

	shorten_stack	protect_indicators

	" arg1: end of clause label
	" arg2: predicate

	if_eaq		ind,arg2,else_if.ind

	load		a,arg2
	if_ind		a,else_if.no_cmpa
	cmpa		0,dl

else_if.no_cmpa:
	tze		arg1
	return

else_if.ind:
	ind_jump		(else_if.tze,else_if.tnz,else_if.tmi,else_if.tpl,else_if.tmoz,else_if.tpnz,else_if.tnc,else_if.trc)

else_if.tze:
	tnz		arg1
	return

else_if.tnz:
	tze		arg1
	return

else_if.tmi:
	tpl		arg1
	return

else_if.tpl:
	tmi		arg1
	return

else_if.tmoz:
	tpnz		arg1
	return

else_if.tpnz:
	tmoz		arg1
	return

else_if.tnc:
	trc		arg1
	return

else_if.trc:
	tnc		arg1
	return

else_if.p:
	error		324,op1

else:
	proc		1

	" arg1: end of clause label

	" The else operator needn't do anything but pop the end of clause
	" label from the operand stack.

	return

read:	proc		2

	swap		arg1

	unless_dt		int,read.p

	swap		arg1
	load		q,arg1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_read
	free_regs
	reset_eaq
	return

read.p:
	print		302,op1
	return

write:	proc		2

	swap		arg1

	unless_dt		int,write.p

	swap		arg1
	load		q,arg1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_write
	free_regs
	reset_eaq
	return

write.p:
	print		302,op1
	return

format:	proc		1

	if_dt		char,format_c

	unless_dt		int,format.pp

	if_array		format_c

	" Must be an integer variable defined with a format value in an
	" ASSIGN statement.  The variable will contain a packed pointer
	" which locates the format string.

	reserve_regs	pr2
	lprp2		arg1
	push_builtin	ps
	spri2		op1+format_slot
	free_regs
	return

format.pp:
	error		329,arg1

format.pv:
	error		358,arg1

format_c:
	if_VLA		arg1,format.pv	" cannot be a Very Large Array
	load_pr		pr2,arg1
	push_builtin	ps
	spri2		op1+format_slot
	free_regs
	return

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

end_label:
	proc		1
	load_pr		pr5,arg1
	push_builtin	ps
	spri5		op1+end_label_slot
	free_regs
	return

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

error_label:
	proc		1

	load_pr		pr5,arg1
	push_builtin	ps
	spri5		op1+error_label_slot
	free_regs
	return

xmit_scalar:
	proc		1

	use_eaq

	load_pr		pr2,arg1

	dt_jump1		op1,(xs_i,xs_r,xs_d,xs_c,xs_l,xs_h,xs_t)

xs_i:
xs_t:
	lda		=1b18,du		=o400000
	jump		xs_transfer

xs_r:
	lda		=1b19,du		=o200000
	jump		xs_transfer

xs_d:
	lda		=1b20,du		=o100000
	jump		xs_transfer

xs_c:
	lda		=1b21,du		=o040000
	jump		xs_transfer

xs_l:
	lda		=1b22,du		=o020000
	jump		xs_transfer

xs_h:
	push_length	arg1
	lda		op1
	emit		1
	als		4
	ora		4096,du		=o010000

xs_transfer:
	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_scalar_xmit
	free_regs
	reset_eaq
	return

xmit_array:
	proc		1

	use_eaq

	load_pr		pr2,arg1

	dt_jump1		op1,(xa_i,xa_r,xa_d,xa_c,xa_l,xa_h,xa_t)

xa_i:
xa_t:
	if_VLA		op1,xa_i_VLA
	lda		=65b24,du		=o404000
	jump		xa_transfer

xa_i_VLA:
	lda		=o406000,du
	jump		xa_transfer

xa_r:
	if_VLA		op1,xa_r_VLA
	lda		=33b24,du		=o204000
	jump		xa_transfer

xa_r_VLA:
	lda		=o206000,du
	jump		xa_transfer

xa_d:
	if_VLA		op1,xa_d_VLA
	lda		=17b24,du		=o104000
	jump		xa_transfer

xa_d_VLA:
	lda		=o106000,du
	jump		xa_transfer

xa_c:
	if_VLA		op1,xa_c_VLA
	lda		=9b24,du		=o044000
	jump		xa_transfer

xa_c_VLA:
	lda		=o046000,du
	jump		xa_transfer

xa_l:
	if_VLA		op1,xa_l_VLA
	lda		=5b24,du		=o024000
	jump		xa_transfer

xa_l_VLA:
	lda		=o026000,du
	jump		xa_transfer

xa_h:
	push_length	arg1
	lda		op1
	emit		1
	als		4
	ora		6144,du		=o014000

xa_transfer:
	push_array_size	arg1
	ldq		op1

	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_array_xmit
	free_regs
	reset_eaq
	return

xmit_vector:
	proc		2

	load_pr		pr2,arg1
	load		q,arg2		" collapsed implied loop provides the count

	swap		arg1		"Note arguments remain swapped

	dt_jump1		op1,(xv_i,xv_r,xv_d,xv_c,xv_l,xv_h,xv_t)

xv_i:
xv_t:
	if_VLA		op1,xv_i_VLA
	lda		=65b24,du		=o404000
	jump		xv_transfer

xv_i_VLA:
	lda		=o406000,du
	jump		xv_transfer

xv_r:
	if_VLA		op1,xv_r_VLA
	lda		=33b24,du		=o204000
	jump		xv_transfer

xv_r_VLA:
	lda		=o206000,du
	jump		xv_transfer

xv_d:
	if_VLA		op1,xv_d_VLA
	lda		=17b24,du		=o104000
	jump		xv_transfer

xv_d_VLA:
	lda		=o106000,du
	jump		xv_transfer

xv_c:
	if_VLA		op1,xv_c_VLA
	lda		=9b24,du		=o044000
	jump		xv_transfer

xv_c_VLA:
	lda		=o046000,du
	jump		xv_transfer

xv_l:
	if_VLA		op1,xv_l_VLA
	lda		=5b24,du		=o024000
	jump		xv_transfer

xv_l_VLA:
	lda		=o026000,du
	jump		xv_transfer

xv_h:
	push_length	arg2
	lda		op1
	emit		1
	als		4
	ora		6144,du		=o014000

xv_transfer:

	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_array_xmit
	free_regs
	reset_eaq
	return

endfile:	proc		2

	swap		arg1
	unless_dt		int,endfile.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

endfile.p:
	print		302,op1
	return

rewind:	proc		2

	swap		arg1
	unless_dt		int,rewind.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

rewind.p:
	print		302,op1
	return

backspace:
	proc		2

	swap		arg1
	unless_dt		int,backspace.p

	load		q,arg2
	lda		arg1
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

backspace.p:
	print		302,op1
	return

margin:	proc		2

	unless_dt		int,margin2.p
	swap		arg1
	unless_dt		int,margin1.p
	swap		arg1

	load		q,arg1
	push_builtin	ps
	lda		arg2
	sta		op1+margin_slot
	lda		=3b27,du		=o001400
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

margin1.p:
	print		302,op1
	return

margin2.p:
	print		331,op1
	return

openfile:	proc		3

	swap		arg1
	unless_dt		int,openfile1.p
	swap		arg1
	swap		arg2
	unless_dt		char,openfile2.p
	if_array		openfile2.p
	swap		arg2
	unless_dt		char,openfile3.p
	if_array		openfile3.p

	push_length	arg2
	push_builtin	ps
	load_pr		pr2,arg2
	spri2		op1+file_name_slot
	load_pr		pr2,arg3
	spri2		op1+file_type_slot
	lda		op2
	sta		op1+string_length_slot
	lda		=5b28,du		=o001200
	load		q,arg1
	reserve_regs	(x6,pr1,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

openfile1.p:
	print		302,op1
	return

openfile2.p:
	print		332,op1
	return

openfile3.p:
	print		333,op1
	return

open:
close:
	proc		4

"			arg1 - file number expre. must be integer
"			arg2 - job_bits const generated by compiler.
"			arg3 - open/close stmnt const generated by compiler.
"			arg4 - A count. Unused in macros.

	use_eaq
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_get_area_ptr	" returns ptr in PS.buffer_p
	free_regs

"		Now add a new arg4. Swap existing arg4 with the builtin ps_area_ptr

	pop		op1		" remove useless count
	push_builtin	ps_area_ptr	" area_ptr builtin becomes arg4
	push_count	0		" index value for bit-string


	lda		arg3	" fields-specified bit string

"		Note - The first time this loop is entered, arg5 is op1.

open_loop:
	load_pr_value	pr3,arg4			" reload pr3 if not already loaded

	eax1		op1	" load value of index into xr1 for runtime code

	tsx0		pr0|ftn_open_element
	reset_eaq

open_loop.2:
	scan		open_loop.e,(next,open_return)

"		Each successful scan adds two operands to the stack.
"		     op2 - A value. See individual field for specifics.
"		     op1 - A count. The index for the individual field.
"		This scan must be executed at least once to insure that existing error_label_op and
"		iostat_op are scanned before the code at label open_return is executed.

	jump_indexed	op1,(opencase1,opencase2,opencase3,opencase4,opencase5,opencase6,opencase7,opencase8,opencase9,opencase10,opencase11,opencase12,opencase13,opencase14)

opencase1:		" status
opencase2:		" io switch
opencase3:		" attach
opencase4:		" file
opencase5:		" mode
opencase6:		" access
opencase7:		" form
opencase13:		" blank
	swap		op2			" check data type
	unless_dt		char,open_loop1.p

	push_length	op1
	load_pr		pr2,op2			" point to string
	load		q,op1			" load string's length
	pop		op2			" pop back to count (index)
	jump		open_loop

opencase8:		" recl
	swap		op2			" check data type
	unless_dt		int,open_loop2.p

	load		q,op1			" load the value
	pop		op1			" pop back to count (index)
	jump		open_loop

opencase9:		" binary
opencase10:		" prompt
opencase11:		" carriage
opencase12:		" defer
	swap		op2			" check data type

	unless_dt		logical,open_loop3.p

	load		a,op1
	pop		op1			" pop back to count (index)
	jump		open_loop

opencase14:		" unit
	swap		op2			" get unit number
	swap		arg1			" save it
	pop		op2			" pop counts
	jump		open_loop.2		" no code generated now

open_loop.e:
	print		349
	jump		abort_list

open_loop1.p:
	print		351,op1
	jump		abort_list

open_loop2.p:
	print		352,op1
	jump		abort_list

open_loop3.p:
	print		353,op1
	jump		abort_list

open_return:
	swap		arg1			" get file number expre.
	unless_dt		int,open.p		" must be integer
	load		q,op1
	lda		arg2
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

open.p:
	error		302,op1

inquire:
	proc		3

	" arg1 - job bits
	" arg2 - fields specified bit mask
	" arg3 - count (unused in macros)

	" First get pointer to work area

	use_eaq
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_get_area_ptr
	free_regs

	pop		op1		" Pop useless count
	push_builtin	ps_area_ptr	" This becomes arg3

	" First pass thru loop is for fields specified mask

	push_count	0		" Field index
	lda		arg2

inquire_loop:
	load_pr_value	pr3,arg3		" Load pr3 if necessary
	eax1		op1		" Load field index
	tsx0		pr0|ftn_inquire_element
	reset_eaq

	scan		inquire_loop.e,(next,inquire_return)

	" Each successful scan pushes two operands onto the stack:
	"    op2 - A value (unit or filename) or reference (all others)
	"    op1 - A count (the field index)

	jump_indexed	op1,(inquire_case_1,inquire_case_2,inquire_case_3,inquire_case_4,inquire_case_5,inquire_case_6,inquire_case_7,inquire_case_8,inquire_case_9,inquire_case_10,inquire_case_11,inquire_case_12,inquire_case_13,inquire_case_14,inquire_case_15,inquire_case_16,inquire_case_17,inquire_case_18,inquire_case_19,inquire_case_20,inquire_case_21,inquire_case_22,inquire_case_23,inquire_case_24,inquire_case_25,inquire_case_26)


inquire_case_4:		" file
inquire_case_6:		" access
inquire_case_7:		" form
inquire_case_13:		" blank
inquire_case_21:		" name
inquire_case_22:		" sequential
inquire_case_23:		" formatted
inquire_case_24:		" unformatted
inquire_case_26:		" direct

	" First check data type.

	swap		op2
	unless_dt		char,inquire_loop.not_char

	" Load pointer in pr2, and length in Q.

	push_length	op1
	load_pr		pr2,op2
	load		q,op1

	pop		op2		" Pop back to field index
	jump		inquire_loop


inquire_case_8:		" recl
inquire_case_19:		" number
inquire_case_25:		" nextrec

	" First check data type.

	swap		op2
	unless_dt		int,inquire_loop.not_int

	" Load pr2 with pointer to integer.

	load_pr		pr2,op1

	pop		op1		" Pop back to field index
	jump		inquire_loop


inquire_case_14:		" unit

	" First check data type.

	swap		op2
	unless_dt		int,inquire_loop.not_int

	" Load unit number in Q.

	load		q,op1

	pop		op1		" Pop back to field index
	jump		inquire_loop


inquire_case_17:		" exist
inquire_case_18:		" opened
inquire_case_20:		" named

	" First check data type.

	swap		op2
	unless_dt		logical,inquire_loop.not_logical

	" Load pr2 with pointer to logical variable.

	load_pr		pr2,op1

	pop		op1		" Pop back to field index
	jump		inquire_loop


inquire_case_1:		" Invalid inquire fields
inquire_case_2:
inquire_case_3:
inquire_case_5:
inquire_case_9:
inquire_case_10:
inquire_case_11:
inquire_case_12:
inquire_case_15:
inquire_case_16:
	print		357,op1
	jump		abort_list


inquire_loop.e:
	print		356
	jump		abort_list

inquire_loop.not_char:
	print		351,op1
	jump		abort_list

inquire_loop.not_int:
	print		352,op1
	jump		abort_list

inquire_loop.not_logical:
	print		353,op1
	jump		abort_list


inquire_return:
	push_count	0		" Dummy unit number
	load		q,op1		" Get unit in Q
	lda		arg1		" Get job bits in A
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return


closefile:
	proc		1

	unless_dt		int,closefile.p

	load		q,arg1
	lda		=3b28,du		=o000600
	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_manip
	free_regs
	reset_eaq
	return

closefile.p:
	print		302,arg1
	return

iostat:
	proc		1

	unless_dt		int,iostat.p

	push_builtin	ps
	load_pr		pr2,arg1
	spri2		op1+iostat_slot
	free_regs

	return

iostat.p:
	print		350,op1
	return

record_number:
	proc		1

	unless_dt		int,record_number.p

	load		q,arg1
	push_builtin	ps
	stq		op1+record_number_slot
	return

record_number.p:
	print		304,arg1
	return

string:
	proc		1

	unless_dt		logical,string_c

	print		305,arg1

string_c:
	load_pr		pr2,arg1
	push_builtin	ps
	spri2		op1+string_slot
	free_regs
	return

string_length:
	proc		1

	load		q,arg1
	push_builtin	ps
	stq		op1+string_length_slot
	return

read_internal_file:
write_internal_file:
	proc		1

	unless_dt		char,internal_file.p

	push_builtin	ps

	load_pr		pr2,arg1
	spri2		arg2+string_slot

	push_length	arg1
	load		q,op1
	stq		arg2+string_length_slot
	pop		op1

	swap		arg1
	if_array		internal_file.array

	stz		arg1+buffer_size_slot
	jump		internal_file.ret

internal_file.array:
	push_array_size	op1
	load		q,op1
	stq		arg1+buffer_size_slot

internal_file.ret:
	free_regs
	return


internal_file.p:
	error		303


terminate:
	proc		0

	reserve_regs	(x6,pr1,pr2,pr3,pr4,pr5,pr7)
	tsx0		pr0|ftn_terminate
	free_regs
	reset_eaq
	return

sf_def:	proc		1

	push_label
	s_func_label	arg1
	label		op1

	push_temp		int
	sxl0		arg3

	scan		sf_def.p,next

	copy		arg1

	dt_jump		(sf_def_ii,sf_def_ri,sf_def_di,sf_def_ci,sf_def_ir,sf_def_rr,sf_def_dr,sf_def_cr,sf_def_id,sf_def_rd,sf_def_dd,sf_def_cd,sf_def_ic,sf_def_rc,sf_def_dc,sf_def_cc,sf_def_e2,sf_def_e1,sf_def_e2,sf_def_e1)

sf_def_ii:
	load		q,op2
	jump		sf_def_ret

sf_def_ir:
	pop		op1
	s_call		cv_load.ir
	jump		sf_def_ret

sf_def_ri:
	pop		op1
	s_call		cv_load.ri
	jump		sf_def_ret

sf_def_id:
	pop		op1
	s_call		cv_load.id
	jump		sf_def_ret

sf_def_di:
	pop		op1
	s_call		cv_load.di
	jump		sf_def_ret

sf_def_ic:
	pop		op1
	s_call		cv_load.ir
	push_temp		real
	store		eaq,op1,no_update
	load		a,op1
	ldq		=0.,du
	jump		sf_def_ret

sf_def_ci:
	pop		op1
	s_call		cv_load.ri
	jump		sf_def_ret

sf_def_rd:
sf_def_rr:
	load		eaq,op2
	jump		sf_def_ret

sf_def_dr:
sf_def_dd:
	load		deaq,op2
	jump		sf_def_ret

sf_def_dc:
	swap		op2
	call		round_dp_to_real
	swap		op2

sf_def_rc:
	load		a,op2
	ldq		=0.,du
	jump		sf_def_ret

sf_def_cr:
	load		eaq,op2
	jump		sf_def_ret

sf_def_cd:
	load		deaq,op2
	jump		sf_def_ret

sf_def_cc:
	load		aq,op2
	jump		sf_def_ret

sf_def_e2:
	unless_dt		logical,sf_def.p0

	swap		op2
	unless_dt		logical,sf_def_e1

	load		a,op1
	jump		sf_def_ret

sf_def_e1:
	print		346,arg1
	return

sf_def_ret:
	use_ind

	lxl0		arg3
	tra		0,0

	pop		arg1		" Force all temps to be freed, then s_func_finish makes them go away

	s_func_finish

	return

sf_def.p:
	print		306,arg1
	scan		continue,next
	return

sf_def.p0:
	print		347,arg1
	return

sf:	func		2

	if		arg2,=,0,sf_no_args

	push_count	1

sf_loop:
	push_s_func_var	arg1,sf_too_many.p

	if		op2,=,1,sf_skip

	swap		arg3
	swap		op2
	swap		arg3

sf_skip:
	increment		arg3,1

	scan		sf_error_r,next

	dt_jump		(sf_ii,sf_ri,sf_di,sf_ci,sf_ir,sf_rr,sf_dr,sf_cr,sf_id,sf_rd,sf_dd,sf_cd,sf_ic,sf_rc,sf_dc,sf_cc,sf_e2,sf_e1,sf_e2,sf_e1)

sf_ii:
	load		q,op1
	stq		op2
	jump		sf_r

sf_ir:
	s_call		cv_load.ri
	stq		op2
	jump		sf_r

sf_ri:
	s_call		cv_load.ir
	store		eaq,op2,no_update
	jump		sf_r

sf_id:
	s_call		cv_load.di
	stq		op2
	jump		sf_r

sf_di:
	s_call		cv_load.id
	store		deaq,op2,no_update
	jump		sf_r

sf_rr:
	load		eaq,op1
	store		eaq,op2,no_update
	jump		sf_r

sf_dd:
	load		deaq,op1
	store		deaq,op2,no_update
	jump		sf_r

sf_rd:
	load		deaq,op1
	fstr		op2
	jump		sf_r

sf_dr:
	load		eaq,op1
	store		deaq,op2,no_update
	jump		sf_r

sf_ic:
	s_call		cv_load.ri
	stq		op2
	jump		sf_r

sf_ci:
	s_call		cv_load.ir
	store		eaq,op2,no_update
	fld		=0.,du
	fst		op2+1
	jump		sf_r

sf_rc:
	load		eaq,op1
	store		eaq,op2,no_update
	jump		sf_r

sf_cr:
	load		eaq,op1
	store		eaq,op2,no_update
	fld		=0.,du
	fst		op2+1
	jump		sf_r

sf_dc:
	load		eaq,op1
	store		deaq,op2,no_update
	jump		sf_r

sf_cd:
	load		deaq,op1
	store		eaq,op2,no_update
	fld		=0.,du
	fst		op2+1
	jump		sf_r

sf_cc:
	use_eaq
	load		aq,op1
	staq		op2
	jump		sf_r

sf_e1:
	print		334,arg1,op2
	jump		sf_error_r

sf_e2:
	if_dt		logical,sf_l
	if_dt		char,sf_h

	print		334,arg1,op1
	jump		sf_error_r

sf_l:
	swap		op2
	unless_dt		logical,sf_e1

	swap		op2

	load		a,op1
	sta		op2
	jump		sf_r

sf_h:
	swap		op2
	unless_dt		char,sf_e1

	emit_eis

	mlr		(pr),(pr),fill(040)
	desc9a		op2
	desc9a		op1
	jump		sf_r

sf_r:
	swap		arg3
	if		arg2,>=,op1,sf_loop

sf_no_args:
	push_sf_arg_count	arg1
	if		arg2,<,op1,sf_insuf.p

	push_s_func_label	arg1

	use_eaq
	reserve_regs	all-pr4
	tsx0		op1
	free_regs

	scan		continue,(continue,next)

	dt_jump1		arg1,(sf_ret_i,sf_ret_r,sf_ret_d,sf_ret_c,sf_ret_l,sf_ret_h,sf_ret_t)

sf_ret_i:
sf_ret_t:
	push_temp		int
	in_reg		q,op1
	use_ind
	return		op1

sf_ret_r:
	push_temp		real
	in_reg		eaq,op1
	use_ind
	return		op1

sf_ret_d:
	push_temp		dp
	in_reg		deaq,op1
	use_ind
	return		op1

sf_ret_c:
	push_temp		cmpx
	in_reg		aq,op1
	use_ind
	return		op1

sf_ret_l:
	push_temp		logical
	in_reg		a,op1
	use_ind
	return		op1

sf_ret_h:
	error		343,arg1

sf_error_r:
	scan		continue,(continue,next)

	error

sf_insuf.p:
	print		307,arg1
	jump		sf_error_r

sf_too_many.p:
	print		308,arg1
	jump		sf_error_r

item:	proc		0

	exit		1
	return

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

exit:	proc		0

	exit		1
	return

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

eol:	proc		0

	exit		2
	return

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

return:	proc		0

	unless_main	quick_return

	tra	pr0|fortran_end

	return

quick_return:
	push_builtin entry_info

	rtcd		op1

	return

pause:	proc		1

	use_eaq
	push_length	arg1
	if		op1,=,0,short_pause

	load_pr		pr2,arg1
	ldq		op1

	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)

pause.1:
	tsx0		pr0|fortran_pause
	free_regs
	reset_eaq
	return

short_pause:
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)
	jump		pause.1

stop:	proc		1

	use_eaq
	push_length	arg1
	if		op1,=,0,short_stop

	load_pr		pr2,arg1
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr3,pr4,pr5,pr7)

stop.1:
	tsx0		pr0|fortran_stop
	reset_regs
	reset_eaq
	return

short_stop:
	ldq		op1
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)
	jump		stop.1

subscript:
	func		2

	start_subscript

subscript_scan:
	scan		subscript_err,(next,subscript_end)

	if_dt		int,process_subscript
	if_optype		constant,convert_subscript
	unless_dt		(real,dp,cmpx),subscript_dt_err

	if_dt		dp,subscript_dp
	push_temp		int
	load		eaq,op2
	round		eaq
	use_eaq
	tsx0		pr0|real_to_integer
	in_reg		q,op1
	swap		op2
	pop		op1
	jump		process_subscript

subscript_dp:
	push_temp		int
	load		deaq,op2
	round		deaq
	use_eaq
	tsx0		pr0|double_to_integer
	in_reg		q,op1
	swap		op2
	pop		op1
	jump		process_subscript

convert_subscript:
	convert_constant	int
	jump		process_subscript

process_subscript:
	next_subscript
	jump		subscript_scan

subscript_dt_err:
	print		458,op1,arg1

subscript_err:
	subscript_error

subscript_end:
	finish_subscript

	return		op1

substr:	func	3

	" arg1 - parent of substring reference
	" arg2 - index of first character in substring
	" arg3 - index of last character in substring
	" value returned is a filled-in array_ref node

	" Make sure parent is of data type character

	swap	arg1
	unless_dt	char,substr.not_char
	swap	arg1

	" Coerce first index to integer

	swap	arg2
	s_call	coerce_substr_exp
	swap	arg2

	" Coerce last character index to integer

	s_call	coerce_substr_exp

	" Now build a substring reference and return it

	make_substring

	return	op1

substr.not_char:
	error	159,op1


coerce_substr_exp:

	if_dt	int,cse_return

	if_optype	constant,cse_convert_constant

	if_dt	(real,cmpx),cse_convert_real

	if_dt	dp,cse_convert_dp

	error	459,op1,arg1

	s_return

cse_convert_constant:
	convert_constant int
	s_return

cse_convert_real:
	push_temp	int
	load	eaq,op2
	round	eaq
	use_eaq
	tsx0	pr0|real_to_integer
	in_reg	q,op1
	swap	op2
	pop	op1
	s_return

cse_convert_dp:
	push_temp	int
	load	deaq,op2
	round	deaq
	use_eaq
	tsx0	pr0|double_to_integer
	in_reg	q,op1
	swap	op2
	pop	op1

cse_return:
	s_return

func_ref:	func		2

	s_call		evaluate_arglist

	dt_jump1		arg1,(int_func,real_func,dp_func,cmpx_func,logical_func,char_func,typeless_func)

char_func:
	push_length	arg1
	unless_optype	count,func_ref.star_extent
	push_char_temp	var

	s_call		descriptor_check

	jump		func_join

int_func:
typeless_func:
	push_temp		int
	jump		func_join

real_func:
	push_temp		real
	jump		func_join

dp_func:
	push_temp		dp
	jump		func_join

cmpx_func:
	push_temp		cmpx
	jump		func_join

logical_func:
	push_temp		logical

func_join:
	increment		arg2,1	function result becomes last arg

	set_in_storage	op1	" return value is in storage on return from func

	s_call		make_call

	return		op2		arglist temp is now op1

func_ref.star_extent:
	error		355,arg1

main:	proc		2

	emit_entry_defs
	emit		1
	oct		000000300000	" revision_1, entry_defs
	s_call		make_entry
	s_call		prepare_for_namelists
	return

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

subr:	proc		2

	emit_entry_defs
	emit		1
	oct		000000300000	" revision_1, entry_defs
	s_call		make_entry
	s_call		make_quick_entry
	s_call		prepare_for_namelists
	return

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

func:	proc		2

	emit_entry_defs
	emit		1
	oct		000000320000	" revision_1, entry_defs, func
	s_call		make_entry
	s_call		make_quick_entry
	s_call		prepare_for_namelists
	return

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

block_data:
	proc		0

	return

make_entry:
	assign_entry	arg1

	emit		1
	eax7		0

	epp2		pr7|stack_header.pl1_operators_ptr,*

	if_needs_descriptors arg1,make_et_desc
	tsp2		pr2|ext_entry
	jump		make_et_join

make_et_desc:
	tsp2		pr2|ext_entry_desc

make_et_join:
	copy		arg2
	multiply		op1,2
	zero		op1
	pop		op1

	emit		1
	zero

	emit_profile_entry		" if we will do long_profile set it up

	unless_hfp	make_et_init_auto
	tsx0		pr0|enter_HFP_mode

make_et_init_auto:
	call		init_auto

	unless_cleanup	make_et_no_cleanup	"no cleanup needed

	tsx0		pr0|fort_cleanup
	emit_cleanup_args

make_et_no_cleanup:
	push_builtin	null
	push_builtin	ps

	if		op2,=,op1,pop_ps

	load_pr		pr2,op1
	spri2		pr6|ps_ptr
	spri6		pr2|0
	free_regs

pop_ps:	pop		op2
	unless_storage_created make_et_descp		is there external storage?
	reserve_regs	all			calling external routines
	tsx0		pr0|fort_storage		request storage create/init
	emit_storage_args
	free_regs

make_et_descp:

	epp1		pr6|stack_frame.arg_ptr,*

	unless_needs_descriptors arg1,make_et_ret

	epp3		pr6|descriptor_ptr,*	Load desc ptr

make_et_ret:
	s_return

prepare_for_namelists:
	unless_namelist_used  pfn_ret

	push_builtin	star_symbol
	push_builtin	ps

	load_pr		pr2,op2
	spri2		op1+2

	set_runtime_block_loc

	adwp2		0,du
	spri2		op1+4

	free_regs
	pop		op2

pfn_ret:

	s_return

init_auto:
	proc		0

	push_builtin	auto_overlay

	push_length	op1

	if		op1,=,0,init_return

	push_builtin	auto_template

	emit_eis

	mlr		(pr),(pr),fill(0)
	desc9a		op1
	desc9a		op3

init_return:
	return

make_quick_entry:
	copy		arg1	Copy original symbol for entry
	get_quick_label	arg1	Replace arg1 with label for quick entry pt

"If storage space needs to be created then we substitute fort_return_mac for
"return_op to get the storage released at the end of the external call.

	unless_cleanup	mqe_no_storage
	epp2		pr0|fort_return_mac
	jump		mqe_end_storage

mqe_no_storage:
	epp2		pr0|return_op

mqe_end_storage:
	label		arg1
	push_builtin	entry_info

	spri2		op1	Store return pointer
	spri1		op1+2	Store arg pointer
	arg_ptr_in_pr1		Update machine state

	unless_needs_descriptors op2,mqe_no_desc
	spri3		op1+4	Store descriptor pointer
	desc_ptr_in_pr3		Update machine state

mqe_no_desc:
	swap		op2	Get original entry symbol on top
	pop		op1	Pop it off

	s_return

process_param_list:
	proc		1
	scan		abort_list,(continue,next)

	check_parameters
	return

descriptor_check:

	" Subroutine to check to see whether or not descriptors might be
	" required for a subroutine call or function reference.  In ansi66
	" mode, we print a message warning the user that descriptors might
	" be necessary.  In ansi77 mode, we go ahead and cause descriptors
	" to be used (silently).  In either mode, if the called subprogram
	" is local to this compilation, then it will already have been taken
	" care of by the storage allocator.

	" Called from func_ref (to check the function return value of
	" character valued functions) and from evaluate_arglist.

	" Assumes that arg1 is the external symbol.

	if_local		arg1,descriptor_check.return
	if_needs_descriptors arg1,descriptor_check.return
	if_ansi77		descriptor_check.set

	" Print a warning that this call might need descriptors

	print		348,arg1
	jump		descriptor_check.return

descriptor_check.set:

	" Cause descriptors to be generated for this call

	set_needs_descriptors		" arg1 implied

descriptor_check.return:
	s_return

increment_polish:
	proc		0

	skip_data

	return

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

label_operator:
	proc		1

	label		arg1

	return

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

stat:	proc		0

	shorten_stack
	stat

	return

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

call:	proc		2

"
	s_call		evaluate_arglist
	s_call		make_call

	return

evaluate_arglist:
	scan		abort_list,(next,check_args)
	if_optype		bif,conv_bif
	if_optype		external,conv_external

	unless_dt		char,evaluate_arglist

	" If argument is of data type character, check to see if we should
	" warn the user about descriptors or just use them.

	s_call		descriptor_check

	jump		evaluate_arglist

conv_bif:
	call		cv_bif_to_external
	jump		evaluate_arglist

conv_external:
	if_parameter	op1,evaluate_arglist	" parameters already are external variables

	call		make_external_variable
	jump		evaluate_arglist

check_args:
	check_arg_list
	s_return

cv_bif_to_external:
	func		1

	push_bif_index	arg1	" get index into big table
"				now get offset into vector
	push_count_indexed	op1,(38,39,40,19,2,12,21,3,13,4,14,5,15,7,17,23,41,42,43,1,11,20,0,0,0,0,0,0,0,0,0,0,0,0,57,58,10,44,45,46,6,16,22,9,18,24,8,0,47,0,0,0,0,0,48,0,0,49,26,27,28,29,30,31,0,0,32,50,0,0,0,0,36,34,37,35,33,51,52,53,54,55,56,0,0,0,0,59,60,61,62,0,0)

	if		op1,=,0,not_external_bif

	reserve_regs	(x2,pr2,pr4)
	use_eaq

	eax2		op1
	tsx0		pr0|get_math_entry

	jump		ext_join

not_external_bif:
	error		461,arg1

make_external_variable:
	func		1

	load_pr		pr2,arg1

ext_join:
	push_builtin	null_ptr
	push_temp		4

	spri2		op1
	load		aq,op2
	staq		op1+2

	free_regs
	return		op1

make_call:
	copy		arg2		get nargs

	unless_needs_descriptors	arg1,inc_for_hdr
	multiply		op1,2

inc_for_hdr:
	increment		op1,1		(for header)

	unless_parameter	arg1,double_count
	increment		op1,1		for display pointer

double_count:
	multiply		op1,2		double to get size of temp

	if_local		arg1,local_call

	push_temp		var

	store_arg_addrs

	make_descriptors

	use_eaq				" any temps that need to be saved...
	reserve_regs	indices		... must be saved now
	free_regs				we still might need xregs for > 16K addressing

	eax1		op1
	multiply		arg2,2048
	fld		arg2

	load_pr		pr2,arg1

	reserve_regs	all		all regs may be used by the call programs

	if_parameter	arg1,call_variable

	if_needs_descriptors	arg1,call_ext_desc

	tsx0		pr0|call_ext_out
	jump		call_join

call_ext_desc:
	tsx0		pr0|call_ext_out_desc
	jump		call_join

call_variable:
	if_needs_descriptors	arg1,call_variable_desc

	tsx0		pr0|call_var
	jump		call_join

call_variable_desc:
	tsx0		pr0|call_var_desc

call_join:
	free_regs
	free_descriptors
	s_return


local_call:
	if_constant_addrs	use_itp

	push_temp		var

	store_arg_addrs

	make_descriptors

	multiply		arg2,2048
	use_eaq
	fld		arg2
	staq		op1

local_join:
	load_pr		pr1,op1

	unless_needs_descriptors arg1,lc_no_desc

	lda		pr1|0	Get 2*nargs in au
	epp3		pr1|2,au	Load descriptor pointer

lc_no_desc:
	get_quick_label	arg1	replace external ref with label for quick entry point

	reserve_regs	all-pr4

	tsp2		arg1

	free_regs
	free_descriptors
	s_return

use_itp:
	gen_itp_list		replaces top of stack with constant arg list
	use_eaq
	jump		local_join

chain:	proc		3

	swap		arg1

	if_dt		char,chain2
	unless_dt		int,chain_path.p
	unless_array	chain_path.p

chain2:
	swap		arg1

	swap		arg2

	if_dt		char,chain3
	unless_dt		int,chain_sys.p
	unless_array	chain_sys.p

chain3:
	swap		arg2

	copy		arg3
	increment		op1,47
	push_temp		var

chain_fill:
	use_eaq

	ldq		arg3
	stq		op1

	emit_eis
	mlr		(pr),(pr)
	desc9a		arg1,168
	desc9a		op1+1,168

	ldaq		arg2
	staq		op1+45

	load_pr		pr2,op1
	emit		1
	eax0		0

chain_next_file:
	scan		next,(next,chain_ret)

	ldq		op1
	stq		op2+47,0
	eax0		1,0
	jump		chain_next_file

chain_ret:
	reserve_regs	(x1,x2,x3,x4,x5,x6,x7,pr1,pr2,pr3,pr4,pr5,pr7)

	tsx0		pr0|fortran_chain
	free_regs
	reset_eaq

	return

chain_path.p:
	print		335,op1
	scan		continue,(continue,next)
	return

chain_sys.p:
	print		336,op1
	scan		continue,(continue,next)
	return

endunit:	proc		0

	end_unit
	return

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

non_executable:
	proc		0
	return

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

no_op:	proc		0
	return

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

form_VLA_packed_ptr:
	func		1
	load		q,arg1
	div		pr0|VLA_words_per_seg
	emit_inst		2
	als		18
	llr		18
	return		q

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

opt_subscript:
	proc		2

	optimized_subscript
	return

left_shift:
	func		2

	load		q,arg1
	qls		arg2

	return		q

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

right_shift:
	func		2

	load		q,arg1
	qrs		arg2

	return		q

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

store_zero:
	proc		1

	stz		arg1
	flush_ref		arg1

	return

storage_add:
	proc		2

	load		q,arg2
	use_ind
	asq		arg1
	flush_ref		arg1

	return

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

storage_sub:
	proc		2

	load		q,arg2
	use_ind
	ssq		arg1
	flush_ref		arg1

	return

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

neg_storage_add:
	proc		2

	use_eaq
	lcq		arg2
	asq		arg1
	flush_ref		arg1

	return

storage_add_one:
	proc		1

	use_ind

	aos		arg1
	flush_ref		arg1

	return

namelist:	proc		1

	push_builtin	ps
	load_pr		pr2,arg1
	spri2		op1+namelist_slot

	free_regs
	return

cat:	func		2

	unless_ansi77	cat.not_ansi77

	swap		arg1
	unless_dt		char,cat.p
	swap		arg1
	unless_dt		char,cat.p

	start_cat		cat.dont_copy_arg1

	emit_eis		equal_lengths
	mlr		(pr),(pr),fill(040)
	desc9a		arg1
	desc9a		op1

cat.dont_copy_arg1:
	continue_cat

	emit_eis		equal_lengths
	mlr		(pr),(pr),fill(040)
	desc9a		arg2
	desc9a		op1

	finish_cat

	return		op1


cat.p:
	error		354,op1

cat.not_ansi77:
	error		153

lhs_fld:
	proc		4
	lhs_fld
	return

	" These should never appear in the polish.  They are only used on the
	" optimizing side.

convert_to_int: 
convert_to_real:
convert_to_dp:
convert_to_cmpx:
read_scalar:
read_array:
read_vector:
write_scalar:
write_array:
write_vector:
jump_true:
jump_false:
sub_index:
loop_end:
read_namelist:
write_namelist:
decode_string:
encode_string:
load_xreg:
load_preg:
	error	455

	end




		    fort_converter.pl1              11/10/88  1423.2r w 11/10/88  1336.9     1706544



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



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 463.
                                                   END HISTORY COMMENTS */


/* format: style3,^delnl,linecom */
fort_converter:
     proc (a_ptr);

/* Written:	Oct 77 - May 78, GDC & PES			*/

/* Modified:
   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.
   25 Oct 84, HH - 444: Remove generation of 'sub_index' operators for
		substring lengths.
   22 Jun 84, MM - Install typeless functions support.
   18 Aug 83, HH - 399: 'effectively_constant' doesn't free quads correctly.
   14 Aug 83, HH - 398: Leave loop index defined when removing implied loops
		from I/O statements.
   27 Jul 83, HH - 392: Prevent replacement of named string constants by the
		string value in 'opt_subscript_op's.
   17 Jun 83, HH - 383: Add support for 'process_param_list_op'.
   14 Apr 83, HH - 376: Move support of 'len' builtin to the code generator.
   31 Jan 83, HH - Install LA/VLA support.
   28 Nov 82, HH - 361: ASSIGNment of a format which the parser has made
	into a named constant is not handled correctly.
   11 Nov 82, HH - 363: 'optimize_vector' used 'dimension.size (i)' even
	when one of the bounds of that dimension was variable, and the
	code to unthread the final opt statement neglected to link the
	previous operator of the opt statement to the first operator.
	Also, 'optimize_vector' forgot to remove calculation of the virtual
	origin of an array that was to be written as a vector starting at
	its first word.
    5 May 82, TO   - Add runtime_stack_extent required for character*(*) function.
   25 Mar 82, TO   - Fixed navy bug 3 - "end if" not processed by "process_hold_stack_entry"
	if statement following does not have "put_in_map" set.  Typically failed
	if following statement was "else if" without code.
   16 Nov 81, MEP  - Fixed bug 343, cat now looks at subrprog options.ansi_77
   28 October 1981, CRD - Support inquire statement.
   20 October 1981, CRD - Internal files.
   3 August 1981, CRD - Fix bug 332.
   28 July 1981, CRD - Change assign_label to replace format label with
	associated format variable.
   13 July 1981, CRD - Force creation of back targets for zero trip DO loops.
   10 June 1981, CRD - New polish for backspace/endfile/rewind.
   12 May 1981, CRD - Add equiv_op, not_equiv_op.
   13 March 1981, CRD - Implement assumed size arrays.
   25 February 1981, CRD - Implement array lower bounds ^= 1.
   9 December 1980, CRD - Implement Fortran 77 block IF statement.
   19 November 1980, CRD - Implement Fortran 77 zero trip DO loops.  Also fix
	a bug in which star extent arrays only got a virtual_origin symbol
	if they had variable extents.  Also fix optimize_vector to handle
	star extent arrays correctly.
   17 August 1980, CRD - Fix bug in subscript handling.
   14 August 1980, CRD - Fix bug in handling of CHAR builtin.
   29 July 1980, CRD - Change many calls to create_constant to
	create_integer_constant instead.
   28 July 1980, CRD - Add code for LEN builtin.
   30 June 1980, MEP - Add code for substr'ing 
   23 June 1980, CRD - Add code to compute must_save_stack_extent.
   23 June 1980, CRD - Check ansi77 mode for concatenation.
   18 June 1980, CRD - Change concatenation routines to generate sub_index
	operators for the length.
   6 June 80, CRD - Changes for new concatenation representation in the quads.
   5 May 80, CRD - Rewrote compress_concat, fixing bugs.
   2 May 80, MEP+CRD - Fix bug 258.  Changed new_free_object to use currentsize
	builtin instead of size.
   1 May 80, CRD - Fix unreported bug (the main loop was not handling counts
	properly.)
   31 Mar 80, MEP - Add code to recognize the sharing of virtual origins.
   18 Dec 79, PES - Change to accept (read write)_namelist_op rather than namelist_op, to fix
	bug 249, in which the optimizer appears to ignore the fact that a namelist read sets
	the values in the namelist.  Also, make string_op an illegal input.
   17 Sept 79, RAB - change last_assigned_op from 97 to 99 for register optimizer
   13 Aug 79, RAB - change last_assigned_op from 95 to 97 in preparation for concatenation & substr
   12 Jul 79, PES - Make encode_op processing bump the ref_count of it's output operand
	if it's an array ref node.  Part of making encode/decode work as documented.
   26 Jun 79, PES - Fix bug 217, in which the appearance of a reference to an element of
	a logical array in a compound if statement condition might cause compiler
	error 446, uninitialized array subscript.
   21 Jun 79, RAB - Fix bug 216, in which the conversion rules are not properly obeyed
	for <non-integer>**<integer> in that the integer will be converted to match
	the data type of <non-integer>.
   05 Feb 79, PES - Fix bug 201, in which incorrect code is generated when optimizing
	for <expression>**<positive_integer_constant> except when the positive
	integer constant is a power of two, or one greater than a power of two.
   13 Dec 78, PES - Fix bug 199, in which implied do loops in i/o statements may
	not optimize properly if there is more than one variable contained at a
	given level of nesting.
   08 Dec 78, PES - Fix bug in handling of nested statement function invocations.
   25 Oct 78, PES - Changes for larger common blocks and arrays.
   04 Sep 78, PES - Fix bug in handling of division in subscripts, and
   bug in handling of statement functions in subscripts.
   28 Jul 78, PES - Audit changes, fix bug in handling of character string
   temporaries (167).
*/

/* In the comments, the construction <phrase> stands for a single token which is described by
   phrase; the construction <...> stands for an arbitrary number of stack entries of irrelevant nature;
   braces {} are used to enclose a group which is repeated one or more times;
   and the top of the stack is enclosed in parens--typically (<>) since the top of the stack is normally
   the first unused item rather than the last used item. */


/*   arguments   */

dcl	a_ptr		ptr;

/*   automatic   */

dcl	(
	block_if_clause_count,
	block_if_offset,
	combination_type,
	dim_size_offset,
	eol_offset,
	exit_offset,
	first_free_object	init (1),
	hold_offset,
	i,
	j,
	last_io_op,
	last_op_index,
	next_statement_index,
	n_ops,
	one,
	op_index,
	polish_offset,
	rand_data_type	(8),
	rand_node_type	(8),
	save_polish_offset,
	sf_num_args,
	sf_offset,
	sub_offset,
	temp_index,
	true_rand,
	tkx,
	virtual_origin_offset,
	work_stack_offset,
	zero
	)		fixed bin (18);

dcl	(subscript_processing, first_statement_function_done, suspend_subscript,
	calls_local_entries, concatenates_star_extents)
			bit (1) aligned init ("0"b);

dcl	1 sub_stack	aligned based (sub_stack_p),
	  2 last		fixed bin (18),
	  2 nested	bit (1),
	  2 symbol_node	ptr unaligned,
	  2 dim_node	ptr unaligned,
	  2 n_dimensions	fixed bin (18),
	  2 dimension	fixed bin (18),
	  2 element,
	    3 constant	fixed bin (18),
	    3 var		fixed bin (18),
	  2 cum,
	    3 temp	fixed bin (18),
	    3 constant	fixed bin (18),
	  2 dim,
	    3 mult	fixed bin (18),
	    3 temp	fixed bin (18),
	    3 offset	fixed bin (18);

dcl	1 sf_stack	aligned based (sf_stack_p),
	  2 last		fixed bin (18),
	  2 polish_offset	fixed bin (18),
	  2 sf		fixed bin (18),
	  2 current_arg	fixed bin (18),
	  2 cur_sf_param	fixed bin (18),
	  2 def_chain	ptr unaligned,
	  2 num_args	fixed bin (18),
	  2 arg_info	(sf_num_args refer (sf_stack.num_args)),
	    3 operand	fixed bin (18),
	    3 chain_start	fixed bin (18),
	    3 chain_end	fixed bin (18);

dcl	1 exit_stack	aligned based (exit_stack_p),
	  2 last		fixed bin (18),
	  2 op		fixed bin (18),
	  2 count		fixed bin (18),
	  2 do_label	fixed bin (18),
	  2 xmit_at_this_level
			fixed bin (18),
	  2 ptr		ptr unaligned,
	  2 zero_trip_branch
			fixed bin (18);

dcl	1 eol_stack	aligned based (eol_stack_p),
	  2 last		fixed bin (18),
	  2 op		fixed bin (18),
	  2 work_stack_offset
			fixed bin (18);

dcl	1 hold_stack	aligned based (hold_stack_p),
	  2 last		fixed bin (18),
	  2 op_code	fixed bin (18),
	  2 ptr		ptr unaligned;

dcl	stack		(0:511) fixed bin (18);

dcl	1 fort_data$builtin_name
			aligned external static structure,
	  2 number_of_names fixed bin (15),
	  2 description	(100),
	    3 name	char (8) aligned,
	    3 generic_name	bit (1) unaligned,
	    3 reserved	bit (35) unaligned,
	    3 generic_func	(4) fixed bin (18),
	    3 result_type	fixed bin (18);

declare	1 virtual_origin_list
			aligned based (virtual_origin_list_ptr),
	  2 last		fixed binary (18),
	  2 symbol_node	pointer unaligned,
	  2 element_size	fixed binary (17),
	  2 numb_of_dims	fixed binary (17),
	  2 units		fixed binary (3) unsigned;

declare	1 block_if_stack	aligned based (block_if_stack_p),
	  2 last		fixed binary (18),
	  2 n_clauses	fixed binary (18),
	  2 clause	fixed binary (18),
	  2 test_op	fixed binary (18),
	  2 n_jumps	fixed binary (18),
	  2 jump		(block_if_clause_count refer (block_if_stack.n_clauses)) fixed binary (18);

declare	1 dim_size_list	aligned based (dim_size_list_ptr),
	  2 last		fixed binary (18),
	  2 bits		aligned,
	    3 var		unaligned,
	      4 lower	bit (1) unaligned,
	      4 upper	bit (1) unaligned,
	    3 pad		bit (34) unaligned,
	  2 lower_bound	fixed binary (24),
	  2 upper_bound	fixed binary (24),
	  2 size		fixed binary (24);

dcl	(array_ptr, block_if_stack_p, dim_size_list_ptr, eol_stack_p,
	exit_stack_p, hold_stack_p, last_opt_statement, last_quad_p, opst,
	r, s, sf_stack_p, sf_substitute_ptr, shared_struc_ptr, stm_ptr,
	sub_stack_p, subp_ptr, temp_node_ptr, temp_ptr, virtual_origin_base,
	virtual_origin_list_ptr)
			ptr;

/*   based   */

dcl	p		(0:polish_max_len - 1) fixed bin (18) aligned based (polish_base),
	q		(0:quad_max_len - 1) fixed bin (18) aligned based (quadruple_base),
	w		(0:object_max_len - 1) fixed bin (18) aligned based (object_base),
	x		(0:operand_max_len - 1) fixed bin (18) aligned based (operand_base);

dcl	(polish_base, quadruple_base, object_base, operand_base)
			ptr;

dcl	(polish_max_len, quad_max_len, object_max_len, operand_max_len)
			fixed bin (18);

/*   builtin   */

dcl	(addr, binary, bit, char, currentsize, fixed, hbound, index, max, null, ptr, rel, size, string, substr, unspec)
			builtin;

/*   include files   */

%include fort_utilities;

%include fort_nodes;

%include fort_system_constants;

dcl	1 shared_globals	aligned based (shared_struc_ptr),
%include fort_shared_vars;

%include fort_options;

%include fort_opt_nodes;

	call count_cases (i);
	if i ^= last_assigned_op
	then do;
		call print_message (382, "The number of operator cases", "last_assigned_op");
		return;
	     end;

	shared_struc_ptr = a_ptr;

	polish_base = shared_globals.polish_base;
	quadruple_base = shared_globals.quadruple_base;
	object_base = shared_globals.object_base;
	operand_base = shared_globals.operand_base;

	polish_max_len = shared_globals.polish_max_len;
	quad_max_len = shared_globals.quad_max_len;
	object_max_len = shared_globals.object_max_len;
	operand_max_len = shared_globals.operand_max_len;

	eol_offset = 0;
	eol_stack_p = addr (w (eol_offset));
	hold_offset = 0;
	hold_stack_p = addr (w (hold_offset));
	sf_offset = 0;
	sf_stack_p = addr (w (sf_offset));
	exit_offset = 0;
	exit_stack_p = addr (w (exit_offset));
	sub_offset = 0;
	sub_stack_p = addr (w (sub_offset));
	virtual_origin_offset = 0;
	virtual_origin_list_ptr, virtual_origin_base = addr (w (virtual_origin_offset));
	block_if_offset = 0;
	block_if_stack_p = addr (w (block_if_offset));
	dim_size_offset = 0;
	dim_size_list_ptr = addr (w (dim_size_offset));

	one = create_integer_constant (1);

	zero = create_integer_constant (0);

	do cur_subprogram = shared_globals.first_subprogram repeat subp_ptr -> subprogram.next_subprogram
	     while (cur_subprogram > 0);

	     subp_ptr = addr (x (cur_subprogram));
	     unspec (last_opt_statement) = "0"b;
	     last_op_index = 0;
	     work_stack_offset = 0;

	     do cur_statement = subp_ptr -> subprogram.first_polish repeat fixed (stm_ptr -> statement.next, 18)
		while (cur_statement > 0);

		stm_ptr = addr (p (cur_statement));

/* Make the statement node for the current statement. */

		opst = create_opt_statement ();

		next_statement_index = fixed (stm_ptr -> statement.next, 18);
		if next_statement_index = 0
		then next_statement_index = subp_ptr -> subprogram.last_polish + 1;
		last_io_op = 0;

		calls_local_entries = "0"b;
		concatenates_star_extents = "0"b;

		polish_offset = cur_statement + size (statement);

/* Check for a label, and add it on if present.  The first test is needed as the top of the
   polish might be <increment_polish> followed by a count which happens to look like a label op. */

		if p (polish_offset) > last_assigned_op
		then if p (polish_offset + 1) = label_op
		     then do;
			     opst -> opt_statement.label = p (polish_offset);
			     addr (x (p (polish_offset))) -> label.statement = last_op_index;
			     polish_offset = polish_offset + 2;
			end;

		call process_hold_stack_entry ();
		opst -> opt_statement.processed_by_converter = "1"b;

/* Copy tokens from the polish to the working stack one at a time.  When an operator is found,
   process_operator is called to process it.  Symbols are checked to see if they are statement_function
   dummy arguments, and if so the substitution is made.  The first time a particular dummy
   argument is substituted, the quads which were used to evaluate it are rechained so they
   immediately precede its use. */

		do polish_offset = polish_offset by 1 while (polish_offset < next_statement_index);

		     stack (work_stack_offset) = p (polish_offset);
		     call bump_work_stack_offset (+1);

		     if p (polish_offset) <= last_assigned_op & p (polish_offset) > 0
		     then call process_operator ();
		     else if p (polish_offset) > 0
		     then if addr (x (stack (work_stack_offset - 1))) -> node.node_type = symbol_node
			then if addr (x (stack (work_stack_offset - 1))) -> symbol.dummy_arg
			     then do;
				     do sf_substitute_ptr = sf_stack_p
					repeat (addr (w (sf_substitute_ptr -> sf_stack.last)))
					while (sf_substitute_ptr ^= addr (w (0)));

					j = 0;

					do i = sf_substitute_ptr -> sf_stack.def_chain -> symbol.next_member
					     repeat (addr (x (i)) -> symbol.next_member) while (i ^= 0);

					     j = j + 1;
					     if i = stack (work_stack_offset - 1)
					     then go to GOT_THE_SF_VAR;
					end;
				     end;

				     call print_message (203);

GOT_THE_SF_VAR:
				     if sf_substitute_ptr ^= addr (w (0))
				     then do;
					     if sf_substitute_ptr -> sf_stack.arg_info (j).chain_start ^= 0
					     then call rechain_arg (sf_substitute_ptr, j);
					     stack (work_stack_offset - 1) =
						sf_substitute_ptr -> sf_stack.arg_info (j).operand;
					end;
				end;
		end;				/* Loop over polish for one statement */

	     end;					/* Loop over statements */

	end;					/* Loop over program units */

	if virtual_origin_offset ^= 0			/* if virtual origin list created */
	then call free_virtual_origin_list ();

	if dim_size_offset ^= 0			/* if dimension size list created */
	then call free_dim_size_list ();

	return;					/* end of converter */

process_operator:
     proc ();

dcl	op_code		fixed bin (18);

	op_code = stack (work_stack_offset - 1);
	if op_code < 0 | op_code > last_assigned_op
	then go to case (0);
	go to case (op_code);

count_cases:
     entry (number_of_cases);

dcl	number_of_cases	fixed bin (18);

	number_of_cases = hbound (case, 1);
	return;

case (0):						/*   ERROR   */

/* No such thing as operator with op_code of 0. */

	call print_message (200, char (op_code));
	return;

case (1):						/*   ASSIGN   */

/* Stack is (<>) <assign_op> <right_hand_value> <target> <...>
   Create an assignment op quad, with conversion if needed, and reduce stack
   to (<>) <...> */

	call process_assign ();
	return;

case (2):						/*   ADD   */
case (3):						/*   SUB   */
case (4):						/*   MULT   */
case (5):						/*   DIV   */

/* Stack is (<>) <binary_arith_op> <right_operand> <left_operand> <...>
   Process the operation as appropriate, and reduce stack to (<>) <result_temporary> <...> */

	call process_arith (subscript_processing & ^suspend_subscript);
	return;

case (6):						/*   EXP   */

/* Stack is (<>) <exp_op> <right_operand> <left_operand> <...>
   Process the operation and reduce stack to (<>) <result_temporary> <...> */

	call process_expo (subscript_processing & ^suspend_subscript);
	return;

case (7):						/*   NEG   */

/* Stack is (<>) <neg_op> <operand> <...>  In the case where we are not currently evaluating
   a subscript expression, or we are evaluating a subscript expression but we have a true (non-zero) operand,
   we share code with the not_op case.  If we are evaluating a subscript expression at present, and the operand
   in the stack is a zero, it indicates that the true operand of the minus is the accumulated
   subscript value in sub_stack, and we negate it directly. */

	if ^subscript_processing | suspend_subscript
	then go to case (16);
	else if stack (work_stack_offset - 2) ^= 0
	then go to case (16);
	else do;
		sub_stack.dim.offset = -sub_stack.dim.offset;
		if sub_stack.dim.temp ^= 0
		then sub_stack.dim.mult = -sub_stack.dim.mult;
		call bump_work_stack_offset (-1);
	     end;
	return;

case (8):						/*   LESS   */
case (9):						/*   LESS_OR_EQUAL   */
case (10):					/*   EQUAL   */
case (11):					/*   NOT_EQUAL   */
case (12):					/*   GREATER_OR_EQUAL   */
case (13):					/*   GREATER   */

/* Stack is (<>) <rel_op> <right_operand> <left_operand> <...>
   we will simply make sure that the data types match, then share code with logical ops. */

	call get_data_type (2);
	call conversion;

case (14):					/*   OR   */
case (15):					/*   AND   */
case (103):					/*   EQUIV   */
case (104):					/*   NOT_EQUIV   */

/* Stack is (<>) <rel_or_log_op> <right_operand> <left_operand> <...>
   Create an appropriate quad, and reduce the stack to
   (<>) <logical_temporary_result> <...> */

	op_index = create_operator (2);
	stack (work_stack_offset) = create_temporary ((logical_mode));
	call bump_work_stack_offset (+1);
	return;

case (16):					/*   NOT   */

/* Stack is (<>) <unary_minus_or_not> <operand> <...>
   Create an appropriate quad, and reduce the stack to (<>) <result_temp> <...> */

	call get_data_type (1);
	op_index = create_operator (1);
	stack (work_stack_offset) = create_temporary (rand_data_type (1));
	call bump_work_stack_offset (+1);
	return;

case (17):					/*   JUMP   */

/* Stack is (<>) <jump_op> <label> <...>
   First check to see if this is a backwards reference, and if so, flag the target stmt.
   If this jump was contained in a statement of form "if expr goto label,"
   we will simply invert the sense of the containing if jump and replace its label  with
   the label from the stack.  Otherwise, create a jump_op quad.
   In any case, the stack is reduced to (<>) <...> */

	call search_label (stack (work_stack_offset - 2));
	if exit_offset > 0
	then if exit_stack.op = jump_false_op
	     then do;
		     exit_stack.op, exit_stack.ptr -> operator.op_code = jump_true_op;
		     exit_stack.ptr -> operator.operand (2) = stack (work_stack_offset - 2);
		     call bump_work_stack_offset (-2);
		     next_free_quad = next_free_quad - size (opt_statement);
		     op_index = addr (q (last_op_index)) -> opt_statement.prev_operator;
		     last_opt_statement = ptr (quadruple_base, addr (q (last_op_index)) -> opt_statement.back);
		     last_op_index = op_index;
		end;
	     else op_index = create_operator (1);
	else op_index = create_operator (1);
	return;

case (18):					/*   JUMP_LOGICAL   */

/* Stack is (<>) <jump_logical_op> <logical_expression> <...>
   We are processing the start of a logical if.  The conditionally executed part is terminated with
   an exit_op, so push the exit stack.  Create a jump_false_op quad whose first operand
   is the jump_logical_op and whose second operand is the logical expression.
   Keep the pointer to this quad in the exit_stack so that we can replace the jump_logical_op with the
   label of the next statement when we find out what it is.  In any case, reduce the stack
   to (<>) <...> */

	call push_exit_stack ();
	exit_stack.op, stack (work_stack_offset) = jump_false_op;

/*   The j_l_op will be replaced by a label */

	call bump_work_stack_offset (+1);
	op_index = create_operator (2);
	exit_stack.count = 0;
	exit_stack.ptr = last_quad_p;
	return;

case (19):					/*   JUMP_ARITHMETIC   */

/* Stack is (<>) <jump_arithmetic_op> <label1> <label2> <label3> <expression_value> <...>
   Check the labels which were supplied to see if any of them are backward references, and if so flag the targets.
   Create a jump_arithmetic_op quad, and make a hold_stack entry to note that any labels which
   were not supplied will have to be filled in with the following statement's label.
   Reduce stack to (<>) <...> */

	do i = work_stack_offset - 4 to work_stack_offset - 2;
	     if stack (i) > last_assigned_op
	     then call search_label (stack (i));
	end;
	op_index = create_operator (4);
	call push_hold_stack ();
	hold_stack.op_code = jump_arithmetic_op;
	hold_stack.ptr = last_quad_p;
	return;

case (20):					/*   JUMP_COMPUTED   */

/* Stack is (<>) <jump_computed_op> <count (of labels)> <...>
   List of labels will be terminated with eol_op, and the expression will be terminated with exit_op,
   so push both eol_stack and exit_stack.  Stack is reduced to
   (<>) <count> <...> */

	call push_exit_stack ();
	call push_eol_stack ();
	exit_stack.op = jump_computed_op;
	exit_stack.count = stack (work_stack_offset - 1);
	return;

case (21):					/*   JUMP_ASSIGNED   */

/* Stack is (<>) <jump_assigned_op> <label_variable> <...>
   Generate jump_assigned quad with label_var as operand and reduce stack  to (<>) <...> */

	op_index = create_operator (1);
	return;

case (22):					/*   ASSIGN_LABEL   */

/* Stack is (<>) <assign_label_op> <label_variable> <label> <...>
   Create assign_label_op quad with label as operand and label_variable as output
   (This necessitates swapping them in the stack, for create_operator.)  If label_variable is
   an array reference, increment it's ref_count.  Reduce stack to (<>) <...> */

	if addr (x (stack (work_stack_offset - 3))) -> node.node_type = label_node
	then if addr (x (stack (work_stack_offset - 3))) -> label.format
	     then stack (work_stack_offset - 3) = addr (x (stack (work_stack_offset - 3))) -> label.format_var;
	stack (work_stack_offset) = stack (work_stack_offset - 2);
	stack (work_stack_offset - 2) = stack (work_stack_offset - 3);
	stack (work_stack_offset - 3) = stack (work_stack_offset);
	op_index = create_operator (1);
	call bump_work_stack_offset (-1);
	last_quad_p -> operator.output = stack (work_stack_offset);
	if stack (work_stack_offset) > last_assigned_op
	then if addr (x (stack (work_stack_offset))) -> node.node_type = array_ref_node
	     then addr (x (stack (work_stack_offset))) -> array_ref.ref_count =
		     addr (x (stack (work_stack_offset))) -> array_ref.ref_count + 1;
	return;

case (23):					/*   READ   */
case (24):					/*   WRITE   */

/* Stack is (<>) <read or write> <constant> <expression> <...>
   Create a read or write node with 2 operands, and remember in last_io_op whether we are
   currently processing a read or a write io operation.  Reduce stack to (<>) <...> */

	last_io_op = stack (work_stack_offset - 1);
	op_index = create_operator (2);
	return;

case (25):					/*   FORMAT   */
case (26):					/*   END_LABEL   */
case (27):					/*   ERROR_LABEL   */

/* Stack is (<>) <one of above 3 ops> <appropriate operand> <...>
   Create the appropriate quad and reduce stack to (<>) <...> */

	op_index = create_operator (1);
	return;

case (28):					/*   XMIT_SCALAR   */
case (29):					/*   XMIT_ARRAY   */

/* Stack is (<>) <xmit_op> <variable> <...>
   (This code is also used by xmit vector stuff, which has one extra operand...hence, n_ops.)
   If the current io_statement is a read statement, generate an appropriate read_xx node, with
   the given variable as the output.  If the variable is an array ref, increment its ref_count.
   If the current io_statement is a write statement, generate an appropriate write_xx node,
   with the given variable as an operand.
   Stack is reduced to (<>) <...> */
/* NOTE that this requires a certain ordering of the (xmit read write)_xx_ops */

	n_ops = 0;
xmit_ops:
	if last_io_op = read_op
	then do;
		stack (work_stack_offset - 1) = stack (work_stack_offset - 1) + read_scalar_op - xmit_scalar_op;
		op_index = create_operator (n_ops);
		call bump_work_stack_offset (-1);
		last_quad_p -> operator.output = stack (work_stack_offset);
		if stack (work_stack_offset) > last_assigned_op
		then if addr (x (stack (work_stack_offset))) -> node.node_type = array_ref_node
		     then addr (x (stack (work_stack_offset))) -> array_ref.ref_count =
			     addr (x (stack (work_stack_offset))) -> array_ref.ref_count + 1;
	     end;
	else do;
		stack (work_stack_offset - 1) = stack (work_stack_offset - 1) + write_scalar_op - xmit_scalar_op;
		op_index = create_operator (n_ops + 1);
	     end;
	if exit_offset ^= 0
	then if exit_stack.op = do_op
	     then exit_stack.xmit_at_this_level = exit_stack.xmit_at_this_level + 1;
	return;

case (30):					/*   XMIT_VECTOR   */

/* Stack is (<>) <xmit_vector_op> <length> <variable_start> <...>
   Set n_ops and then we can use xmit_op code above. */

	n_ops = 1;
	go to xmit_ops;

case (31):					/*   ENDFILE   */
case (32):					/*   REWIND   */
case (33):					/*   BACKSPACE   */

/* Stack is (<>) <one of above 3 ops> <job bits> <unit number> <...>
   Create an appropriate quad with two operands as given, and reduce stack to (<>) <...> */

	op_index = create_operator (2);
	return;

case (34):					/*   MARGIN   */

/* Stack is (<>) <margin_op> <expr1> <expr2> <...>
   Create an appropriate node with the 2 given operands, and reduce the stack
   to (<>) <...> */

	op_index = create_operator (2);
	return;

case (35):					/*   OPENFILE   */

/* Stack is (<>) <openfile_op> <operand1> <operand2> <operand3> <...>
   Create an openfile_op node with 3 operands, and reduce stack to (<>) <...> */

	op_index = create_operator (3);
	return;

case (36):					/*   CLOSEFILE   */
case (37):					/*   RECORD_NUMBER   */

/* Stack is (<>) <one of above 2 ops> <operand> <...>
   Create an appropriate node with 1 operand, reduce stack to (<>) <...> */

	op_index = create_operator (1);
	return;

case (38):					/*   STRING   */

/* The parse should not make these when optimizing.  Crawl off and die. */

	go to case (0);

case (39):					/*   STRING_LENGTH   */

/* Stack is (<>) <string_length_op> <operand> <...>
   Create the node with 1 operand and reduce stack to (<>) <...> */

	op_index = create_operator (1);
	return;

case (40):					/*   TERMINATE   */

/* end of io statement.  Reset last_io_op. */

	last_io_op = 0;

case (41):					/*   RETURN   */

/* Stack is (<>) <terminate or return> <...>
   Generate node with no operands, reduce stack to (<>) <...> */

	op_index = create_operator (0);
	return;

case (42):					/*   PAUSE   */
case (43):					/*   STOP   */

/* Stack is (<>) <stop or pause> <operand> <...>
   Generate node with 1 operand, reduce stack to (<>) <...> */

	op_index = create_operator (1);
	return;

case (44):					/*   ITEM   */

/* Stack is (<>) <item_op> <...>   Further details and action taken depend upon the type of
   list being processed, which information is held in eol_stack.op */

/* If current list is a subscript_op list then top of stack is
   (<>) <item_op> <subscript_expr> <array_var> <...>
   If this is the last dimension, process_1_subscript will return stack
   (<>) <array_ref_node> <...>
   Otherwise, it will return with stack (<>) <array_var> <...>
   The subscript information is accumulated in the sub_stack entry .*/

	if eol_stack.op = subscript_op
	then call process_1_subscript ();

/* If current list is  related to an open_op, close_op, or inquire_op, then top of
   stack is (<>) <item_op> {<count> <halfword>} <...>
   Throw away the item op, and increment the count of items (parse didn't count 'em).
   Stack becomes (<>) {<count> <halfword>} <...> */

	else if eol_stack.op = open_op | eol_stack.op = close_op | eol_stack.op = inquire_op
	then do;
		stack (eol_stack.work_stack_offset) = stack (eol_stack.work_stack_offset) + 1;
		call bump_work_stack_offset (-1);
	     end;

/* If the current list is related to an active statement_function reference op, then top of stack
   is (<>) <item_op> <statement_func argument> <...>
   If too many arguments have been supplied, we simply throw this one away.  Otherwise, we
   determine whether the argument data_type matches that of the corresponding dummy argument, and
   if not, generate an appropriate conversion.  The argument is remembered in the arg_info array of
   the sf_stack.  The current pointer into the quad chain is remembered as the end of the
   calculations involved in evaluating this argument and as the start of the calculations involved
   in calculating the next argument, if another is expected.  (If there were no calculations, i.e.
   an element argument, these chain ptrs are set to zero.) These chains are used to allow
   rechaining of the argument calculation in at the point of first use later on.  Both the item_op
   and the argument are popped from the stack, leaving (<>) <...> */

	else if eol_stack.op = sf_op
	then do;
		if sf_stack.cur_sf_param = 0
		then do;
			call bump_work_stack_offset (-2);
			return;
		     end;
		i = sf_stack.cur_sf_param;
		sf_stack.cur_sf_param = addr (x (i)) -> symbol.next_member;

		if addr (x (i)) -> symbol.data_type ^= addr (x (stack (work_stack_offset - 2))) -> node.data_type
		then do;
			stack (work_stack_offset - 1) = convert_to_int_op + addr (x (i)) -> symbol.data_type - 1;
			op_index = create_operator (1);
			stack (work_stack_offset) = create_temporary ((addr (x (i)) -> symbol.data_type));
			call bump_work_stack_offset (+2);
		     end;
		sf_stack.arg_info (sf_stack.current_arg).operand = stack (work_stack_offset - 2);
		if sf_stack.arg_info (sf_stack.current_arg).chain_start = last_op_index
		then sf_stack.arg_info (sf_stack.current_arg).chain_start = 0;
		else do;
			sf_stack.arg_info (sf_stack.current_arg).chain_end = last_op_index;
			sf_stack.arg_info (sf_stack.current_arg).chain_start =
			     addr (q (sf_stack.arg_info (sf_stack.current_arg).chain_start)) -> operator.next;
		     end;
		sf_stack.current_arg = sf_stack.current_arg + 1;
		if sf_stack.current_arg <= sf_stack.num_args
		then sf_stack.arg_info (sf_stack.current_arg).chain_start = last_op_index;
		call bump_work_stack_offset (-2);
	     end;

/* If the current list is related to a block IF statement, then we have
   reached the end of a clause.  If this is not the last clause of the block
   IF, then we emit a jump_op to skip the remaining clauses.  If the clause
   was started with an IF or ELSE IF, we create a hold_stack entry so that
   the conditional branch to skip the clause may be filled in.  Also, if the
   clause was started with an IF or ELSE IF, and this is not the last clause,
   then we create a dummy opt_statement operator so that the test can branch
   to the proper location. */

	else if eol_stack.op = block_if_op
	then do;
		block_if_stack.clause = block_if_stack.clause + 1;

		if block_if_stack.clause < block_if_stack.n_clauses
		then do;
			stack (work_stack_offset - 1) = 0;
			stack (work_stack_offset) = jump_op;
			call bump_work_stack_offset (+1);
			op_index = create_operator (1);
			block_if_stack.n_jumps = block_if_stack.n_jumps + 1;
			block_if_stack.jump (block_if_stack.n_jumps) = op_index;
			opst -> opt_statement.removable = "1"b;
		     end;
		else call bump_work_stack_offset (-1);

		if block_if_stack.test_op ^= 0
		then do;
			call push_hold_stack ();
			hold_stack.op_code = jump_false_op;
			hold_stack.ptr = addr (q (block_if_stack.test_op));
			if block_if_stack.clause < block_if_stack.n_clauses
			then do;
				opst = create_opt_statement ();
				opst -> opt_statement.put_in_profile = "0"b;
				opst -> opt_statement.put_in_map = "1"b;
				call process_hold_stack_entry ();
			     end;

		     end;
	     end;

/* In any other case, stack is (<>) <item_op> <some list item> <...>
   We simply toss the item op, leaving (<>) <some_list_item> <...> */

	else call bump_work_stack_offset (-1);
	return;

case (45):					/*   EXIT   */

/* Top of stack is (<>) <exit_op> <...>   Further details and action taken depend upon the type
   of operation with which this exit_op is associated.  This information is held in exit_stack. */

/* If the exit_op is related to a jump_true or jump_false op, then the top of stack
   is (<>) <exit_op> <...>    Create a hold_stack entry, indicating that we will need to fill
   in a label in the jump when we know the label of the next statement.  Throw away the exit op,
   leaving (<>) <...> */

	if exit_stack.op = jump_false_op | exit_stack.op = jump_true_op
	then do;
		call push_hold_stack ();
		hold_stack.op_code = exit_stack.op;
		hold_stack.ptr = exit_stack.ptr;
		call bump_work_stack_offset (-1);
	     end;

/* If the current exit_op is related to a jump_computed_op, it terminates the expression calculation.
   Top of stack is (<>) <exit_op> <expr> {<label>} <count> <...>   We convert the expr to integer, if it is not already,
   check each of the labels to see if it involves a backwards reference, create a
   jump_computed node with the expr, labels, and count as operands, and pop the whole mess off
   the work stack, leaving (<>) <...> */

	else if exit_stack.op = jump_computed_op
	then do;
		call get_data_type (1);
		if rand_data_type (1) ^= int_mode
		then do;
			stack (work_stack_offset - 1) = convert_to_int_op;
			op_index = create_operator (1);
			call bump_work_stack_offset (+2);
			stack (work_stack_offset - 2) = create_temporary ((int_mode));
		     end;
		stack (work_stack_offset - 1) = jump_computed_op;

		do i = 1 to exit_stack.count + bias;
		     call search_label (stack (work_stack_offset - exit_stack.count - bias - 3 + i));
		end;

		op_index = create_operator (exit_stack.count + bias + 2);
	     end;

/* If the current exit_op is related to an sf_op, it means we have been evaluating a statement_function
   reference, which is done by saving the pointer into the polish at the point of reference and resetting
   it to run through the sf_definition, which is terminated by the exit_op.  We must move the pointer
   back to the point in the polish following the reference which is being evaluated.  The top of stack
   is (<>) <exit_op> <sf_result> <...>
   We check to see if the result data type matches that of the statement function, and if not, force  conversion.
   We pop the sf_stack entry corresponding to this sf reference, since the evaluation is done.
   The exit_op is tossed, leaving (<>) <sf_result> <...> */

	else if exit_stack.op = sf_op
	then do;
		polish_offset = sf_stack.polish_offset;
		if subscript_processing
		then do;
			if stack (work_stack_offset - 2) = 0 & sf_stack.def_chain -> symbol.data_type = int_mode
			     & (sub_stack.dim.temp = 0
			     | addr (x (sub_stack.dim.temp)) -> temporary.data_type = int_mode)
			then ;
			else do;
				true_rand = 1;
				call compress_subscript ();
			     end;
		     end;

		if stack (work_stack_offset - 2) ^= 0
		then do;
			if addr (x (stack (work_stack_offset - 2))) -> node.data_type
			     ^= sf_stack.def_chain -> symbol.data_type
			then do;
				stack (work_stack_offset - 1) =
				     convert_to_int_op - 1 + sf_stack.def_chain -> symbol.data_type;
				op_index = create_operator (1);
				stack (work_stack_offset) =
				     create_temporary ((sf_stack.def_chain -> symbol.data_type));
				if sf_stack.def_chain -> symbol.data_type = char_mode
				then addr (x (stack (work_stack_offset))) -> temporary.length =
					get_char_size ((sf_stack.def_chain)) + bias;
				call bump_work_stack_offset (+1);
			     end;
			else call bump_work_stack_offset (-1);
		     end;
		else call bump_work_stack_offset (-1);
		call pop_sf_stack ();
	     end;

/*   If the current exit_op is related to a do_op,  we've reached the end of a do-group.
   Top of stack is (<>) <exit_op> <*> <incr> <upper> <lower> <index_var> <...>
   The entry <*> is a do_op if the do_index var is also being used as the iteration counter, and is a
   compiler-generated unnamed symbol if a separate counter has been generated.
   We generate code to increment the formal index variable.  If a separate counter is being used, it is also
   incremented.  Nodes are then generated to test the index variable/counter and branch back if
   not done.  If the next operation in the polish is not a statement op (i.e. if this is an implied do)
   then we must generate a pseudo-statement to follow the do_group, so as not to confuse the optimizer.
   We must also arrange for that statement or the next statement to come along to get a label, which
   is used as the target of the zero_trip_branch generated at the beginning of the loop.
   The stack is left containing (<>) <...> */

	else if exit_stack.op = do_op
	then do;
		if hold_offset ^= 0 & last_io_op = 0
		then do;
			opst = create_opt_statement ();
			opst -> opt_statement.put_in_profile = "0"b;
			opst -> opt_statement.put_in_map = "1"b;
			call process_hold_stack_entry ();
		     end;

		stack (work_stack_offset - 1) /*   increment loop variable   */,
		     stack (work_stack_offset) = stack (work_stack_offset - 6);
		stack (work_stack_offset + 1) = stack (work_stack_offset - 3);
		stack (work_stack_offset + 2) = add_op;
		call bump_work_stack_offset (+3);
		call process_arith ("0"b);

		stack (work_stack_offset) = assign_op;
		call bump_work_stack_offset (+1);
		call process_assign ();

		if stack (work_stack_offset - 1) ^= do_op
						/*   a counter   */
		then do;
			stack (work_stack_offset) /*   increment counter   */,
			     stack (work_stack_offset + 1) = stack (work_stack_offset - 1);
			stack (work_stack_offset + 2) = one;
			stack (work_stack_offset + 3) = add_op;
			call bump_work_stack_offset (+4);
			call process_arith ("0"b);

			stack (work_stack_offset) = assign_op;
			call bump_work_stack_offset (+1);
			call process_assign ();
			stack (work_stack_offset - 5) = stack (work_stack_offset);
		     end;

		stack (work_stack_offset) = stack (work_stack_offset - 5);
		stack (work_stack_offset + 1) = stack (work_stack_offset - 3);
		stack (work_stack_offset + 2) = greater_op;
		call bump_work_stack_offset (+3);
		call get_data_type (2);
		call conversion;
		op_index = create_operator (2);

		stack (work_stack_offset) = create_temporary ((logical_mode));
		call bump_work_stack_offset (+1);
		stack (work_stack_offset) = exit_stack.do_label;
		stack (work_stack_offset + 1) = jump_false_op;
		call search_label (stack (work_stack_offset));

		call bump_work_stack_offset (+2);
		op_index = create_operator (2);

		if p (polish_offset + 1) ^= stat_op
		then do;
			opst = create_opt_statement ();
			opst -> opt_statement.put_in_profile = "0"b;
			opst -> opt_statement.put_in_map = "1"b;
			if exit_stack.zero_trip_branch ^= 0
			then do;
				i, addr (q (exit_stack.zero_trip_branch)) -> operator.operand (2) =
				     create_label (last_op_index);
				addr (x (i)) -> label.referenced_executable = "1"b;
				opst -> opt_statement.label = i;
			     end;
		     end;
		else if exit_stack.zero_trip_branch ^= 0
		then do;
			call push_hold_stack ();
			hold_stack.op_code = jump_false_op;
			hold_stack.ptr = addr (q (exit_stack.zero_trip_branch));
		     end;
		call bump_work_stack_offset (-5);
	     end;

/* If an exit_op shows up under any other circumstances, it's a level 4 error.  Go bomb out!!!!! */

	else call print_message (200, "45");

/* Having processed the exit_op, pop its entry from the exit_stack. */

	call pop_exit_stack ();
	return;

case (46):					/*   EOL   */

/* Top of stack is (<>) <eol_op> <...>   Further details and action taken depend upon the type
   of operation with which this eol_op is associated.  This information is held in eol_stack.
   Note that process_eol_stack also pops the eol_stack. */

/* If the eol is associated with a jump_computed op, it terminates the list of labels.  Stack is
   (<>) <eol_op> {<label>} <count> <...>    We can't create the node until we have
   evaluated the controlling expression.  Simply throw out the eol_op and pop the eol_stack,
   leaving the stack as (<>) {<label>} <count> <...> */

	if eol_stack.op = jump_computed_op
	then do;
		call bump_work_stack_offset (-1);
		call pop_eol_stack ();
	     end;

/*   If the eol_op is associated with a chain_op, the top of the stack is
   (<>) <eol_op> {<expression>} <count> <string expr> <string expr> <...>
   Call process_eol_stack to combine the whole mess into a chain_op node, and clean up the stack.
   Stack will be left containing (<>) <...> */

	else if eol_stack.op = chain_op
	then call process_eol_stack (1, 3);

/* If the eol_op is associuated with an open or close op, the top of the stack is
   (<>) <eol_op> {<count> <halfword>} <count> <const> <const> <expr> <...>
   Call process_eol_stack to combine the whole mess into an appropriate node, and clean up the stack.
   Stack will be left containing (<>) <...> */

	else if eol_stack.op = open_op | eol_stack.op = close_op
	then call process_eol_stack (2, 4);

/* If the eol_op is associated with a call, top of the stack is
   (<>) <eol_op> {<args>} <count> <entry> <...>
   Call process_eol_stack to produce an appropriate node, and clean up the stack.
   Stack will be left containing (<>) <...> */

	else if eol_stack.op = call_op
	then call process_eol_stack (1, 2);

/* If the eol_op is associated with a process_param_list_op, top of stack is
   (<>) <eol_op> {<args>} <count> <...>
   Call process_eol_stack to produce an appropriate node, and clean up the stack.
   Stack will be left containing (<>) <...> */

	else if eol_stack.op = process_param_list_op
	then call process_eol_stack (1, 1);

/* If the eol_op is associated with a func_ref_op, the top of the stack is
   (<>) <eol_op> {<arg>} <count> <func> <...>
   Call process_eol_stack to create the func_ref_node, and create_temporary to create a temp for its output.
   Stack is left containing (<>) <function_value> <...> */

	else if eol_stack.op = func_ref_op
	then do;
		call process_eol_stack (1, 2);
		temp_node_ptr = addr (x (addr (q (op_index)) -> operator.operand (1)));
		stack (work_stack_offset) = create_temporary ((temp_node_ptr -> symbol.data_type));
		if temp_node_ptr -> symbol.data_type = char_mode
		then addr (x (stack (work_stack_offset))) -> temporary.length = get_char_size (temp_node_ptr) + bias;
		call bump_work_stack_offset (+1);
	     end;

/* If the eol_op is associated with a builtin_op, the top of the stack is
   (<>) <eol_op> {<arg>} <count> <entry> <...>
   Call process_builtin to process the stack, build a builtin_node, pop the eol_stack,
   and clean up the work stack leaving (<>) <result> <...> */

	else if eol_stack.op = builtin_op
	then do;
		call process_builtin ();
	     end;

/* If the eol_op is associated with a subscript_op, we've already done all the work when we saw the item_op.
   Top of stack is (<>) <eol_op> <array_ref_node> <...>
   We pop the sub_stack and the eol_stack, and clean up the work stack, leaving
   (<>) <array_ref_node> <...> */

	else if eol_stack.op = subscript_op
	then do;
		call bump_work_stack_offset (-1);
		call pop_sub_stack ();
		call pop_eol_stack ();
	     end;

/* If the eol_op is associated with a statement_function reference, all needed info will have been placed into the sf_stack
   by now.  The top of the stack is merely (<>) <eol_op> <...>   Process_sf_stack will cause the sf_to
   be evaluated by saving the current pointer into the polish, setting it to point back into the sf definition
   and cleaning the eol off of the work stack, leaving (<>) <...>.  The converter will process happly thru the sf definition
   generating cnodes with appropriate subscript substitutions, until it hits the exit_op
   at the end of the definition.  Then the polish pointer will be reset.  process_sf pops the eol_stack and
   pushes an entry onto the exit_stack. */

	else if eol_stack.op = sf_op
	then call process_sf ();

/* If the eol_op is associated with a block IF statement, we have reached the
   end of the entire block IF (i.e. the ENDIF statement).  The jump_ops
   which appear at the end of each clause but the last must now be filled in.
   This is accomplished by creating a hold_stack entry for the block_if_op.
   When the hold_stack entry is processed, the block_if_stack will be popped.
   The eol_stack is popped explicitly here. */

	else if eol_stack.op = block_if_op
	then do;
		call pop_eol_stack ();
		call push_hold_stack ();
		hold_stack.op_code = block_if_op;
		hold_stack.ptr = null ();
		call bump_work_stack_offset (-1);
		opst -> opt_statement.removable = "1"b;
	     end;

/* If the eol_op is associated with an inquire_op, the top of the stack is
   (<>) <eol_op> {<count> <halfword>} <count> <fields specified> <job bits> <...>
   Call process_eol_stack to combine all of this into a single operator, popping
   the eol_stack and leaving the operand stack as (<>) <...> */

	else if eol_stack.op = inquire_op
	then call process_eol_stack (2, 3);

/* Any other eol_op which may turn up is a level 4 error.  Go away and die!!! */

	else call print_message (200, "46");
	return;

case (47):					/*   DO_OP   */

/* Top of stack is (<>) <do_op> <incr> <upper> <lower> <index var> <...>
   The do group will be terminated by an exit_op, so we push the exit_stack to remember that we expect it.
   Match_index_type is called to convert the upper, lower, and incr to match the index var, if needed.
   If the increment is an integer constant (which implies index is integer) then if the upper bound is
   not constant we assign it to a frozen_for_do temporary.  If the increment is not an integer constant,
   we generate the nodes necessary to compute a counter value which will actually be used for loop control.
   If it is necessary to generate such a counter, it will replace the do_op in the stack.
   If the increment is not constant, and we are compiling in ansi77 mode, the value of the increment
   must be assigned to a frozen_for_do temporary, which replaces the original increment in the stack.
   Whether or not a counter is generated, we must compile a conditional branch to skip the entire
   loop if it should be executed zero times.  The offset of the branch is remembered in
   exit_stack.zero_trip_branch, so that the correct label may be filled in later.
   After the conditional jump is emitted, a statement op is emitted to force the creation of a new
   flow unit, which will serve as the back target of the loop.
   If last_io_op ^= 0 we are processing an implied do in an io statement.  Optimize_vector will be called
   to see if the implied do can be optimized into an xmit_vector op.  If this optimization is done
   the assorted do info will be purged from the stack, and the polish input stack will be modified to contain
   an xmit_vector_op and appropriate count and vector info.  This is the one case where the converter may
   modify the polish input.
   If this is not an implied do, or is an unoptimizable implied do, a node will be generated to initialize the loop
   variable.  If not an implied do, a hold_stack entry will be generated, to remember that the label of the
   next statement must be kept as it begins the do-group; if an implied do, a statement_node will be generated,
   and it's label remembered, for the end_of_loop code to branch back to.
   The stack will be left as is, with the possible exception of a count  (if generated) replacing the do_op. */

	call push_exit_stack ();
	exit_stack.op = do_op;
	exit_stack.xmit_at_this_level = 0;
	exit_stack.ptr = null;
	exit_stack.zero_trip_branch = 0;
	call match_index_type ();
	r = addr (x (stack (work_stack_offset - 2)));

	if r -> node.node_type = constant_node & r -> node.data_type = int_mode
	then do;
		s = addr (x (stack (work_stack_offset - 3)));
		if s -> node.node_type ^= constant_node
		then do;
			stack (work_stack_offset) = stack (work_stack_offset - 3);
			stack (work_stack_offset + 1) = assign_op;
			call bump_work_stack_offset (+2);
			op_index = create_operator (1);
			stack (work_stack_offset - 3) = create_temporary ((int_mode));
			temp_ptr -> temporary.frozen_for_do = "1"b;
		     end;
	     end;
	else do;
		if r -> node.node_type ^= constant_node
		then if subp_ptr -> subprogram.options.ansi_77
		     then do;
			     stack (work_stack_offset) = stack (work_stack_offset - 2);
			     stack (work_stack_offset + 1) = assign_op;
			     call bump_work_stack_offset (+2);
			     op_index = create_operator (1);
			     stack (work_stack_offset - 2) = create_temporary ((r -> node.data_type));
			     temp_ptr -> temporary.frozen_for_do = "1"b;
			end;

		stack (work_stack_offset) = stack (work_stack_offset - 3);
		stack (work_stack_offset + 1) = stack (work_stack_offset - 4);
		stack (work_stack_offset + 2) = sub_op;
		call bump_work_stack_offset (+3);
		call process_arith ("0"b);

		stack (work_stack_offset) = stack (work_stack_offset - 3);
		stack (work_stack_offset + 1) = div_op;
		call bump_work_stack_offset (+2);
		call process_arith ("0"b);

		if addr (x (stack (work_stack_offset - 1))) -> node.data_type ^= int_mode
		then do;
			stack (work_stack_offset) = convert_to_int_op;
			call bump_work_stack_offset (+1);
			op_index = create_operator (1);
			call bump_work_stack_offset (+1);
			stack (work_stack_offset - 1) = create_temporary ((int_mode));
		     end;

		call bump_work_stack_offset (-1);

/* replace <upper> with the loop count just computed */

		stack (work_stack_offset - 3) = stack (work_stack_offset);

/* initialize counter to zero */

		stack (work_stack_offset - 1) = create_var ();
		stack (work_stack_offset) = zero;
		stack (work_stack_offset + 1) = assign_op;
		call bump_work_stack_offset (+2);
		call process_assign ();
		call bump_work_stack_offset (+1);
	     end;
	if last_io_op ^= 0
	then do;
		save_polish_offset = polish_offset;
		call optimize_vector ();
		if polish_offset < save_polish_offset
		then return;
	     end;

/*   initialize loop variable   */

	stack (work_stack_offset) = stack (work_stack_offset - 5);
	stack (work_stack_offset + 1) = stack (work_stack_offset - 4);
	stack (work_stack_offset + 2) = assign_op;
	call bump_work_stack_offset (+3);
	call process_assign ();
	exit_stack.ptr = last_quad_p;

/* generate conditional branch for zero trip loop */

	if subp_ptr -> subprogram.options.ansi_77
	then do;
		if r -> node.node_type = constant_node & r -> node.data_type = int_mode
		then do;
			stack (work_stack_offset) = stack (work_stack_offset - 3);
			stack (work_stack_offset + 1) = stack (work_stack_offset - 4);
			if substr (r -> constant.value, 1, 1)
						/* if < 0 */
			then stack (work_stack_offset + 2) = less_or_equal_op;
			else stack (work_stack_offset + 2) = greater_or_equal_op;
		     end;
		else do;
			stack (work_stack_offset) = stack (work_stack_offset - 3);
			stack (work_stack_offset + 1) = zero;
			stack (work_stack_offset + 2) = greater_or_equal_op;
		     end;
		call bump_work_stack_offset (+3);
		op_index = create_operator (2);
		stack (work_stack_offset) = create_temporary ((logical_mode));
		stack (work_stack_offset + 1) = 0;
		stack (work_stack_offset + 2) = jump_false_op;
		call bump_work_stack_offset (+3);
		op_index = create_operator (2);
		exit_stack.zero_trip_branch = op_index;

		opst = create_opt_statement ();
		opst -> opt_statement.put_in_profile = "0"b;
		opst -> opt_statement.put_in_map = "1"b;
	     end;

	if last_io_op ^= 0
	then do;
		opst = create_opt_statement ();
		opst -> opt_statement.put_in_profile = "0"b;
		opst -> opt_statement.put_in_map = "1"b;
		opst -> opt_statement.label, i = create_label (last_op_index);
		opst -> opt_statement.referenced_backwards = "1"b;
		addr (x (i)) -> label.referenced_executable = "1"b;
		exit_stack.do_label = i;
	     end;
	else do;
		call push_hold_stack ();
		hold_stack.op_code = stat_op;
		hold_stack.ptr = opst;
	     end;
	return;

case (48):					/*   BUILTIN   */

/* Top of stack is (<>) <builtin_op> <count> <function> <...>
   Processing happens when we see the eol_op.  Push the eol_stack and pitch the builtin_op, leaving the stack as
   (<>) <count> <function> <...> */
	call push_eol_stack ();
	return;

case (49):					/*   SF   */

/* Top of stack is (<>) <sf_op> <count> <function> <...>
   Processing occurs when we see the eol_op.  Push the eol_stack and pitch the sf_op.  We must also
   create an entry in the sf_stack to hold info about the arguments as they are evaluated, and to
   remember the function name and count.  Stack becomes (<>) <...> */

	call push_eol_stack ();
	call push_sf_stack ();
	return;

case (50):					/*   SF_DEF   */

/* Nothing to do for statement function definitions.  Stack is (<>) <sf_def_op> <function> <...>
   Set symbol.initial for the function name to point to the definition in the polish.
   If this is the first sf_def, set put_in_map on the statement node
   for the jump around the definitions to 0 in order to prevent anomalies in the object listing.
   Pitch the statement node since there will be no statement.  Skip past the definition in the
   polish stack.  Clean up the work stack, leaving (<>) <...> */

	addr (x (stack (work_stack_offset - 2))) -> symbol.initial = polish_offset + 1;
	call bump_work_stack_offset (-2);
	do polish_offset = polish_offset + 1 by 1 while (p (polish_offset) ^= exit_op);
	end;

	if ^first_statement_function_done
	then unspec (addr (q (fixed (opst -> opt_statement.back, 18))) -> opt_statement.bits) = "0"b;
	first_statement_function_done = "1"b;
	next_free_quad = next_free_quad - size (opt_statement);
	op_index = addr (q (last_op_index)) -> opt_statement.prev_operator;
	last_opt_statement = ptr (quadruple_base, addr (q (last_op_index)) -> opt_statement.back);
	last_op_index = op_index;
	opst = last_opt_statement;
	profile_size = profile_size - 1;
	return;

case (51):					/*   SUBSCRIPT   */

/* Top of stack is (<>) <subscript_op> <count> <array_var> <...>
   We set up an eol_stack entry, since this construct will be terminated with an eol, and a
   sub_stack entry to keep track of the subscript calculations.  Set the subscript_processing flag
   for the arithmetic_op processing routines.  We call initialize_subscript to give the array
   its dimension sizes and virtual origin.  The stack becomes (<>) <array_var> <...> */

	call push_eol_stack ();
	call push_sub_stack ();
	subscript_processing = "1"b;
	call bump_work_stack_offset (-1);
	sub_stack.n_dimensions = stack (work_stack_offset) + bias;
	sub_stack.symbol_node = addr (x (stack (work_stack_offset - 1)));
	sub_stack.dim_node = addr (x (sub_stack.symbol_node -> symbol.dimension));
	sub_stack.dim.mult = 1;
	sub_stack.dimension = 1;
	sub_stack.cum.temp = 0;
	sub_stack.cum.constant = 0;
	sub_stack.dim.temp = 0;

	if sub_stack.symbol_node -> symbol.star_extents
	then do;
		sub_stack.element.constant = 1;
		sub_stack.element.var = sub_stack.symbol_node -> symbol.v_length;
	     end;
	else do;
		sub_stack.element.constant = sub_stack.symbol_node -> symbol.element_size;
		sub_stack.element.var = 0;
	     end;

	call initialize_subscript ((sub_stack.symbol_node));

/*  If this is a VLA, generate a quad to subtract the virtual origin from    */
/*  the base address of the VLA and leave the difference in 'cum.temp'.  We  */
/*  don't need to treat a constant virtual origin of zero specially, since   */
/*  the optimizer ignores a subtraction of zero!                             */

	if sub_stack.symbol_node -> symbol.VLA
	then do;
		stack (work_stack_offset) = sub_stack.dim_node -> dimension.VLA_base_addressor;
		if sub_stack.dim_node -> dimension.variable_virtual_origin
		then stack (work_stack_offset + 1) = sub_stack.dim_node -> dimension.virtual_origin;
		else stack (work_stack_offset + 1) =
			create_integer_constant (sub_stack.dim_node -> dimension.virtual_origin
			- sub_stack.symbol_node -> symbol.offset);
		stack (work_stack_offset + 2) = sub_op;
		call bump_work_stack_offset (+3);
		call process_arith ("0"b);
		call bump_work_stack_offset (-1);
		sub_stack.cum.temp = stack (work_stack_offset);
	     end;

	return;

case (52):					/*   FUNC_REF   */

/* Top of stack is (<>) <func_ref_op> <count> <function> <...>   Simply create an eol_stack
   entry, and pitch the func_ref_op, leaving (<>) <count> <function> <...> */

	calls_local_entries = is_local ((stack (work_stack_offset - 3)));
	call push_eol_stack ();
	return;

case (53):					/*   BLOCK_DATA   */

/* Top of stack is (<>) <block_data_op> <...>   Create a node of 0 operands, and pop the op,
   leaving (<>) <...>*/

	op_index = create_operator (0);
	return;

case (54):					/*   INCREMENT_POLISH   */

/* Top of stack is (<>) <increment_polish_op> <...  and the next item in the polish stack
   is the number of polish entries to skip over.  Move the polish pointer ahead the given
   amount, and toss the increment_polish_op, leaving the stack as (<>) <...> */

	call bump_work_stack_offset (-1);
	polish_offset = polish_offset + p (polish_offset + 1) + 1;
	if polish_offset > polish_max_len
	then call print_message (201);
	return;

case (55):					/*   MAIN   */
case (56):					/*   FUNC   */
case (57):					/*   SUBR   */

/* Top of stack is (<>) <main or func or subr> <count> <entry> <...>
   Create an appropriate quad with the 2 given operands, and reduce the
   stack to (<>) <...> */

	op_index = create_operator (2);
	return;

case (58):					/*   STAT   */
case (59):					/*   LABEL   */

/* Stat and label ops are supposed to be processed by the calling program.  If any show up here
   something foul has occurred.  Go crawl into a hole and die. */

	go to case (0);

case (60):					/*   CALL   */

/* Top of stack is (<>) <call_op> <count> <external> <...>.  Push an eol_stack
   entry, since processing has to await the list, and pop the call_op leaving
   (<>) <count> <external> <...>. */

	calls_local_entries = is_local ((stack (work_stack_offset - 3)));
	call push_eol_stack ();
	return;

case (61):					/*   CHAIN   */

/* Top of stack is (<>) <chain_op> <count> <string_expr> <string_expr> <...>.
   Push an eol_stack entry, since processing has to await the list, and pop
   the chain_op, leaving (<>) <count> <string_expr> <string_expr> <...>. */

	call push_eol_stack ();
	return;

case (62):					/*   ENDUNIT   */

/* Top of stack is (<>) <endunit_op> <...>  Make a node of 0 operands, pop the op,
   leaving (<>) <...>  and set subprogram.last_quad to point to the node. */

	op_index = create_operator (0);
	subp_ptr -> subprogram.last_quad = op_index;
	return;

case (63):					/*   NON_EXECUTABLE   */
case (64):					/*   NO_OP   */

/* Top of stack is (<>) <one of above 2 ops> <...>   Make a node of 0 operands, and pop the op,
   leaving (<>) <...> */

	op_index = create_operator (0);
	return;

case (65):					/*   INDIRECT_SCAN   */
case (66):					/*   OPT_SUBSCRIPT   */
case (67):					/*   LEFT_SHIFT   */
case (68):					/*   RIGHT_SHIFT   */
case (69):					/*   STORE_ZERO   */
case (70):					/*   STORAGE_ADD   */
case (71):					/*   STORAGE_SUB   */
case (72):					/*   NEG_STORAGE_ADD   */
case (73):					/*   STORAGE_ADD_ONE   */
case (74):					/*   NAMELIST   */

/* None of the above 10 ops is supposed to be output by the parse.  If they show up, we've
   screwed up somewhere.  Crawl off and die. */

	go to case (0);

case (75):					/*   OPEN   */
case (76):					/*   CLOSE   */

/* Top of stack is (<>) <open or close _op> <count> <constant> <constant> <expr> <...>
   Push an eol_stack entry, and toss the op, leaving the stack as
   (<>) <count> <constant> <constant> <expr> <...> */

	call push_eol_stack ();
	return;

case (77):					/*   IO_STAT   */

/* Top of stack is (<>) <iostat_op> <var> <...>   Iostat takes no operands, and uses var as its
   output.  Create a node of 0 variables, attach var as its output, and increment var's reference count if
   var is an array_ref.  Clean stack, leaving (<>) <...> */

	op_index = create_operator (0);
	call bump_work_stack_offset (-1);
	last_quad_p -> operator.output = stack (work_stack_offset);
	if stack (work_stack_offset) > last_assigned_op
	then if addr (x (stack (work_stack_offset))) -> node.node_type = array_ref_node
	     then addr (x (stack (work_stack_offset))) -> array_ref.ref_count =
		     addr (x (stack (work_stack_offset))) -> array_ref.ref_count + 1;
	return;

case (78):					/*   CONVERT_TO_INT   */
case (79):					/*   CONVERT_TO_REAL   */
case (80):					/*   CONVERT_TO_DP   */
case (81):					/*   CONVERT_TO_CMPX   */
case (82):					/*   READ_SCALAR   */
case (83):					/*   READ_ARRAY   */
case (84):					/*   READ_VECTOR   */
case (85):					/*   WRITE_SCALAR   */
case (86):					/*   WRITE_ARRAY   */
case (87):					/*   WRITE_VECTOR   */
case (88):					/*   JUMP_TRUE   */
case (89):					/*   JUMP_FALSE   */
case (90):					/*   SUB_INDEX   */
case (91):					/*   LOOP_END_OP   */

/* Last 14 ops are not output by parse.  If we see one here, it's an error. Go off and die! */

	go to case (0);

case (92):					/*   READ_NAMELIST_OP   */
case (93):					/*   WRITE_NAMELIST_OP   */

/* Top of stack is (<>) <(read write)_namelist_op> <expr> <...>   Create the node with one operand.
   Clean off the stack, leaving (<>) <...> */

	op_index = create_operator (1);
	return;

case (94):					/*   DECODE_STRING_OP   */
case (105):					/*   READ_INTERNAL_FILE   */

/* Top of stack is (<>) <decode_string_op> <operand> <...>
   Create a node of 1 operand, and clean up the stack, leaving (<>) <...> */

	op_index = create_operator (1);
	return;

case (95):					/*   ENCODE_STRING_OP   */
case (106):					/*   WRITE_INTERNAL_FILE   */

/* Top of stack is (<>) <encode_string_op> <output_operand> <...>
   Create a node of 0 operands, and fill in the output.
   Clean up the stack, leaving (<>) <...> */

	op_index = create_operator (0);
	call bump_work_stack_offset (-1);
	last_quad_p -> operator.output = stack (work_stack_offset);
	if stack (work_stack_offset) > last_assigned_op
	then if addr (x (stack (work_stack_offset))) -> node.node_type = array_ref_node
	     then addr (x (stack (work_stack_offset))) -> array_ref.ref_count =
		     addr (x (stack (work_stack_offset))) -> array_ref.ref_count + 1;
	return;

case (96):					/*   CAT_OP   */

/* Top of stack is (<>) <cat_op> <right_operand> <left_operand> <...>
   Create a quad to compute the length of the result, and run it through a
   sub_index operator.  Then create a quad for the concatenation itself.
   Linearize adjacent concatenation operators by calling compress_concat.
   The stack is left (<>) <output_temp> <...> */

	if ^subp_ptr -> subprogram.options.ansi_77
	then call print_message (153);

	concatenates_star_extents = is_star_extent ((stack (work_stack_offset - 3)))
	     | is_star_extent ((stack (work_stack_offset - 2)));

	i = get_char_size (addr (x (stack (work_stack_offset - 3))));
	if i < 0
	then i = create_integer_constant (i + bias);
	stack (work_stack_offset - 1) = i;

	i = get_char_size (addr (x (stack (work_stack_offset - 2))));
	if i < 0
	then i = create_integer_constant (i + bias);
	stack (work_stack_offset) = i;

	stack (work_stack_offset + 1) = add_op;
	call bump_work_stack_offset (+2);
	call process_arith ("0"b);
	stack (work_stack_offset) = sub_index_op;
	call bump_work_stack_offset (+1);
	op_index = create_operator (1);
	stack (work_stack_offset) = create_temporary ((int_mode));
	stack (work_stack_offset + 1) = cat_op;
	call bump_work_stack_offset (+2);
	op_index = create_operator (3);
	stack (work_stack_offset) = create_temporary ((char_mode));
	call bump_work_stack_offset (+1);
	call compress_concat ();
	return;

case (97):					/*   SUBSTR_OP   */

/* Top of stack is (<>) <substr_op><upper_bound><lower_bound><parent>...
    Create an opt_substr node in the quads with 4 operand: symbol, constant-offset,
    variable offset, and length.  All this processing is done in process_substr,
    and the stack is left as: (<>) <array_ref> ... */

	call process_substr ();
	return;

case (98):					/* LOAD_XREG_OP */
case (99):					/* LOAD_PREG_OP */

/* The parse should not create either of the last two ops.  Crawl off and die. */

	go to case (0);

case (100):					/* BLOCK_IF_OP */

/* Top of stack is (<>) <block_if_op> <clause_count> <predicate> <...>
   We push the eol_stack, since the block_if_op begins a list of clauses,
   and we push an entry onto the block_if_stack to remember various things
   about this block IF statement.  A jump_false_op based on the predicate
   is generated to skip the first clause.  The stack is left (<>) <...> */

	call push_eol_stack ();

	block_if_clause_count = stack (work_stack_offset - 1) + bias;
	call push_block_if_stack ();
	block_if_stack.clause = 0;
	block_if_stack.n_jumps = 0;

	stack (work_stack_offset - 1) = 0;
	stack (work_stack_offset) = jump_false_op;
	call bump_work_stack_offset (+1);
	op_index = create_operator (2);

	block_if_stack.test_op = op_index;

	return;

case (101):					/* ELSE_IF_OP */

/* Top of stack is (<>) <else_if_op> <predicate> <...>
   We emit a jump_false_op based on the predicate to skip this clause of
   the block IF.  The stack is left (<>) <...> */

	stack (work_stack_offset - 1) = 0;
	stack (work_stack_offset) = jump_false_op;
	call bump_work_stack_offset (+1);
	op_index = create_operator (2);
	block_if_stack.test_op = op_index;
	return;

case (102):					/* ELSE_OP */

/* The else_op takes no arguments, and does nothing except mark the beginning
   of a simple ELSE clause.  We need do nothing with it here. */

	block_if_stack.test_op = 0;
	call bump_work_stack_offset (-1);
	return;

case (107):					/* INQUIRE */

/* Top of stack is (<>) <inquire op> <count> <fields specified> <job bits> <...>
   Push an eol_stack entry, and pop the inquire op, leaving the stack as
   (<>) <count> <fields specified> <job bits> <...> */

	call push_eol_stack ();
	return;

case (108):					/* PROCESS_PARAM_LIST */

/* Top of stack is (<>) <process_param_list_op> <count> <...>
   Push an eol_stack entry and toss the operator, leaving the stack as
   (<>) <count> <...> */

	call push_eol_stack ();
	return;

case (109):					/* LHS_FLD */

/* Top of stack is (<>) <lhs_fld_op> <right_hand_side> <argument3>
   <argument2> <argument1> <...> */

	call process_lhs_fld ();
	return;

     end process_operator;

process_assign:
     proc ();

/* Called with the top of stack (<>) <assign_op> <right_side> <target> <...>
   Does appropriate things with the assignment, as indicated below, and Cleans out the stack,
   leaving (<>) <...> */

/* Get rand_data_type(1) (= data type of target), rand_data_type(2) (= data type of source), and combination_type, which is
   a function of rand_data_type(1) and rand_data_type(2) */

	call get_data_type (2);
	go to assign_l (combination_type);

assign_l (1):					/*  INTEGER = INTEGER   */
	go to no_convert;
assign_l (2):					/*  REAL = INTEGER  */
assign_l (3):					/*  DP = INTEGER  */
assign_l (4):					/*  CMPX = INTEGER  */
assign_l (5):					/*  INTEGER = REAL  */
	go to convert;
assign_l (6):					/*  REAL = REAL  */
assign_l (7):					/*  DP = REAL  */
assign_l (8):					/*  CMPX = REAL  */
	go to no_convert;
assign_l (9):					/*  INTEGER = DP  */
	go to convert;
assign_l (10):					/*  REAL = DP  */
assign_l (11):					/*  DP = DP  */
assign_l (12):					/*  CMPX = DP  */
	go to no_convert;
assign_l (13):					/*  INTEGER = CMPX  */
convert:

/* Explicit convert generated iff one side of assign is integer
   and the other side is non_integer arithmetic data_type. */

/* NOTE: This block requires a certain ordering of the convert_to_xx operators. */

	stack (work_stack_offset) = stack (work_stack_offset - 2);
	stack (work_stack_offset + 1) = convert_to_int_op - 1 + rand_data_type (1);
	call bump_work_stack_offset (+2);
	op_index = create_operator (1);
	stack (work_stack_offset - 2) = create_temporary (rand_data_type (1));

assign_l (14):					/*  REAL = CMPX  */
assign_l (15):					/*  DP = CMPX  */
assign_l (16):					/*  DP = DP  */
assign_l (17):					/*  anything = data_type>complex  */
assign_l (18):					/*  data_type>complex = data_type<=complex  */
no_convert:

/* IF the target is an array_ref, we must increment its reference count */

	if stack (work_stack_offset - 3) > last_assigned_op
	then if addr (x (stack (work_stack_offset - 3))) -> node.node_type = array_ref_node
	     then addr (x (stack (work_stack_offset - 3))) -> array_ref.ref_count =
		     addr (x (stack (work_stack_offset - 3))) -> array_ref.ref_count + 1;

/* If the assignment is of a function return value to a variable of the same data type, then we
   will simply place the target of the assignment into the output entry of the function_ref node
   and not generate an assignment node. */

	if rand_data_type (1) = rand_data_type (2)
	then do;
		call get_node_type (2);
		if rand_node_type (2) = temporary_node
		then if addr (q (addr (x (stack (work_stack_offset - 2))) -> temporary.output_by)) -> operator.op_code
			= func_ref_op
		     then if rand_data_type (1) ^= char_mode
			     | (get_char_size (addr (x (stack (work_stack_offset - 2))))
			     = get_char_size (addr (x (stack (work_stack_offset - 3)))))
			then do;
				addr (q (op_index)) -> operator.output = stack (work_stack_offset - 3);
				call bump_work_stack_offset (-3);
				return;
			     end;
	     end;

/* Make the assignment node, and clean up the stack. */

	op_index = create_operator (1);
	call bump_work_stack_offset (-1);
	last_quad_p -> operator.output = stack (work_stack_offset);
	return;
     end process_assign;

process_arith:
     proc (subscript_mode);

dcl	constant_value	fixed bin (18);
dcl	subscript_mode	bit (1) aligned;

/* Called with top of stack (<>) <+|-|/|*> <right_hand_rand> <left_hand_rand> <...>
   Does appropriate things with the binary op, and returns leaving the result in the stack,
   as (<>) <value> <...> */

	call get_data_type (2);
	call get_node_type (2);

/* If the operator is add or multiply, we'll put the operands into a consistent order
   to improve the likelihood of finding common sub_expressions. */

	if stack (work_stack_offset - 1) = add_op | stack (work_stack_offset - 1) = mult_op
	then if rand_node_type (1) > rand_node_type (2)
		| (rand_node_type (1) = rand_node_type (2)
		& stack (work_stack_offset - 3) > stack (work_stack_offset - 2))
	     then do;
		     stack (work_stack_offset) = stack (work_stack_offset - 3);
		     stack (work_stack_offset - 3) = stack (work_stack_offset - 2);
		     stack (work_stack_offset - 2) = stack (work_stack_offset);
		     call get_data_type (2);
		     call get_node_type (2);
		end;

/* If we are not currently processing a subscript expression, the two operands in the stack are
   the true operands, and we must simply create an appropriate node with 2 operands,
   with an appropriate conversion if needed, create a temporary for the output value,
   and go away. */

	if ^subscript_mode
	then do;
		call conversion;
		op_index = create_operator (2);
		stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));
		call bump_work_stack_offset (+1);
		return;
	     end;
	if stack (work_stack_offset - 1) <= 1 | stack (work_stack_offset - 1) > 5
	then call print_message (200, char (stack (work_stack_offset - 1)));

/* If we are currently processing a subscript expression, the situation becomes more complex.  In
   an effort to minimize calculation at run time, an attempt is made to pull any constant parts of
   the subscript calculation out at compile time.  To this end, thefollowing is done:

   It is assumed that the "effective element length" of the current dimension can be represented by
   the expression <constant>*<variable>, stored in sub_stack entries element.constant and
   element.var, respectively.

   It is assumed that the cumulative effective subscript, including the effect of all dimensions up
   to and including the latest one completely processed, can be represented by the expression
   <constant>+<variable>, stored in sub_stack entries cum.constant and cum.temp respectively.  This
   form was chosen because it is the form ultimately needed when the array_ref_op node is created.

   It is assumed that the current subscript being evaluated can be expressed by the expression
   <constant_multiplier>*<variable>+<constant_offset>, stored in sub_stack entries dim.mult,
   dim.temp, and dim.offset, respectively.  This expression will be refered to in the following
   documentation as the accumulated current dimension.

   A value of true binary 0 is placed in the workstack in place of a normal operand to indicate
   that the accummulated current dimension is to be used for that operand. */

/* true_rand indicates which of the 2 operands is a normal operand if the accumulated current
   dimension is one of the operands.  If both operands are true operands, true_rand is set to -1 */

	if rand_data_type (1) = 0
	then true_rand = 2;
	else if rand_data_type (2) = 0
	then true_rand = 1;
	else do;
		true_rand = -1;
		call conversion;
		call get_data_type (2);
	     end;
	call get_node_type (2);
	go to case (stack (work_stack_offset - 1) - 1);

case (1):						/*  ADD  */
	if true_rand = -1
	then do;

/* If the accumulated current dimension does not take part in the expression at all, then we have
   to see what it is.  If there is no accumulated current dimension, then we are herewith beginning
   a new dimension.  Simply stick the left_hand operand into the appropriate dim.  entry, according
   to whether it is constant or not, set true_rand to indicate that the left_hand operand is the
   accumulated current dimension, and continue.  Otherwise simply create the appropriate operator
   node and leave the result in the stack. */

		if sub_stack.dim.temp = 0 & sub_stack.dim.offset = 0
		then do;
			if effectively_constant (work_stack_offset - 3, 1, constant_value)
			then sub_stack.dim.offset = constant_value;
			else sub_stack.dim.temp = stack (work_stack_offset - 3);
			true_rand = 2;
		     end;
		else do;
			op_index = create_operator (2);
			stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));
			call bump_work_stack_offset (+1);
			return;
		     end;
	     end;

/* If the true_operand is a constant, just add its value to sub_stack.dim.offset.*/

	if effectively_constant (work_stack_offset - 4 + true_rand, true_rand, constant_value)
	then do;
		sub_stack.dim.offset = sub_stack.dim.offset + constant_value;
		call bump_work_stack_offset (-3);
	     end;

/* Or, if there is not yet a variable part of the accumulated current dimension, put the true operand
   into dim.temp */

	else if sub_stack.dim.temp = 0
	then do;
		sub_stack.dim.temp = stack (work_stack_offset - 4 + true_rand);
		call bump_work_stack_offset (-3);
	     end;

/* Otherwise create nodes to compute <dim.mult>*<dim.temp> + <true operand>, and place the result
   into dim.temp, resetting dim.mult to 1. */

	else call compress_subscript ();

/* Leave a 0 in the stack to indicate that the result is being held in the accumulated current dimension. */

	call bump_work_stack_offset (+1);
	stack (work_stack_offset - 1) = 0;
	return;

case (2):						/* SUBTRACT */
	if true_rand = -1
	then do;

/* If the accumulated current dimension does not take part in the expression at all, then we have
   to see what it is.  If there is no accumulated current dimension, then we are herewith beginning
   a new dimension.  Simply stick the left_hand operand into the appropriate dim entry, according
   to whether it is constant or not, set true_rand to indicate that the left_hand operand is the
   accumulated current dimension, and continue.  Otherwise, simply create the appropriate operator
   node and leave the result in the stack. */

		if sub_stack.dim.temp = 0 & sub_stack.dim.offset = 0
		then do;
			if effectively_constant (work_stack_offset - 3, 1, constant_value)
			then sub_stack.dim.offset = constant_value;
			else sub_stack.dim.temp = stack (work_stack_offset - 3);
			true_rand = 2;
		     end;
		else do;
			op_index = create_operator (2);
			stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));
			call bump_work_stack_offset (+1);
			return;
		     end;
	     end;

/* If the true_rand is a constant, then we check which operand it is, since - does not commute.  If
   the true operand is the right_hand side, just subtract it from dim.offset.  If the true operand
   is the left_hand side, we must negate the dim.mult entry and set dim.offset to the
      operand - dim.offset */

	if effectively_constant (work_stack_offset - 4 + true_rand, true_rand, constant_value)
	then do;
		if true_rand = 2
		then sub_stack.dim.offset = sub_stack.dim.offset - constant_value;
		else do;
			sub_stack.dim.offset = constant_value - sub_stack.dim.offset;
			if sub_stack.dim.temp ^= 0
			then sub_stack.dim.mult = -sub_stack.dim.mult;
		     end;
		call bump_work_stack_offset (-3);
	     end;

/* If the true operand is not constant, and there is no accumulated variable part, then if the true
   operand is the right_hand side, put it in dim.temp and set the dim.mult to -1.  If the true
   operand is on the left, put it in dim.temp and negate dim.offset */

	else if sub_stack.dim.temp = 0
	then do;
		sub_stack.dim.temp = stack (work_stack_offset - 4 + true_rand);
		if true_rand = 2
		then sub_stack.dim.mult = -1;
		else sub_stack.dim.offset = -sub_stack.dim.offset;
		call bump_work_stack_offset (-3);
	     end;

/* Otherwise create nodes to compute <dim.mult>*<dim.temp> and to produce the subtraction with the
   true operand.  Place the result into dim.temp, and reset dim.mult to 1 */

	else call compress_subscript ();

/* Leave a 0 in the stack to indicate that the result is being held in accumulated current
   dimension. */

	call bump_work_stack_offset (+1);
	stack (work_stack_offset - 1) = 0;
	return;

case (3):						/*  MULT  */
	if true_rand = -1
	then do;

/* If the accumulated current dimension does not take part in the expression at all, then we have
   to see what it is.  If there is no accumulated current dimension, then we are herewith beginning
   a new dimension.  Simply stick the left_hand operand into the appropriate dim entry according to
   whether it is constant or not, set true_rand to indicate that the left_hand operand is the
   accumulated current dimension, and continue.  Otherwise, simply create the appropriate operator
   node and leave the result in the stack. */

		if sub_stack.dim.temp = 0 & sub_stack.dim.offset = 0
		then do;
			if effectively_constant (work_stack_offset - 3, 1, constant_value)
			then sub_stack.dim.offset = constant_value;
			else sub_stack.dim.temp = stack (work_stack_offset - 3);
			true_rand = 2;
		     end;
		else do;
			op_index = create_operator (2);
			stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));
			call bump_work_stack_offset (+1);
			return;
		     end;
	     end;

/* If the true_rand is a constant, then simply multiply dim.offset by it, and also multiply
   dim.mult by it if dim.temp is non_zero.  (Processing is easier if mult is guaranteed to be 1
   when there is no dim.temp part.) */

	if effectively_constant (work_stack_offset - 4 + true_rand, true_rand, constant_value)
	then do;
		sub_stack.dim.offset = sub_stack.dim.offset * constant_value;
		if sub_stack.dim.temp ^= 0
		then sub_stack.dim.mult = sub_stack.dim.mult * constant_value;
		call bump_work_stack_offset (-3);
	     end;

/* Or, if the true_rand is variable and there is no variable part in the current dimension, simply
   put the operand into dim.temp, move the former dim.offset into dim.mult, and zero dim.offset. */

	else if sub_stack.dim.temp = 0
	then do;
		sub_stack.dim.mult = sub_stack.dim.offset;
		sub_stack.dim.offset = 0;
		sub_stack.dim.temp = stack (work_stack_offset - 4 + true_rand);
		call bump_work_stack_offset (-3);
	     end;

/* Otherwise, create nodes to reduce the entire accumulated current dimension to a single temp,
   perform the new multiplication, and place the result into sub_stack.dim.temp, resetting the
   dim.offset to 0 and the dim.mult to 1. */

	else call compress_subscript ();

/* Leave a 0 in the stack to indicate that the result is being held in accumulated current dimension. */

	call bump_work_stack_offset (+1);
	stack (work_stack_offset - 1) = 0;
	return;

case (4):						/* DIVIDE  */

/* Operator nodes are always generated for divisions, because the truncation effect of FORTRAN
   integer division means they've basically gotta be done where the guy wrote them to avoid
   changing the meaning of the code. */

	if true_rand = -1
	then do;

/* If the accumulated current dimension does not take part in the calculation, then we must look to
   see what it is.  If there is no accumulated current dimension, we'll create a divide_op node and
   stick the output temp into dim.temp.  If there is an accumulated current dimension, make the
   node and stick the output temp into the stack. */

		if sub_stack.dim.temp = 0 & sub_stack.dim.offset = 0
		then do;
			sub_stack.dim.temp = subscript_arith (2);
			call bump_work_stack_offset (+1);
			stack (work_stack_offset - 1) = 0;
			return;
		     end;
		else do;
			op_index = create_operator (2);
			stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));
			call bump_work_stack_offset (+1);
			return;
		     end;
	     end;

/* Or, if there is no variable part to the accumulated current dimension, we'll convert the offset
   part into the appropriate operand position in the stack, create the operator, and stick the
   result temp into dim.temp. */

	if sub_stack.dim.temp = 0
	then do;
		stack (work_stack_offset - 1 - true_rand) =
		     create_integer_constant ((sub_stack.dim.offset));
		sub_stack.dim.temp = subscript_arith (2);
		sub_stack.dim.offset = 0;
	     end;

/* Otherwise, create nodes to reduce the entire accumulated current dimension to a single temp,
   perform the division, and place the result into dim.temp, resetting dim.mult to 1 and dim.offset
   to 0. */

	else call compress_subscript ();

/* Leave a 0 in the stack to indicate the the result is being held in accumulated current dimension. */

	call bump_work_stack_offset (+1);
	stack (work_stack_offset - 1) = 0;
	return;
     end process_arith;

compress_concat:
     procedure ();

/* Attempts to combine adjacent concatenation operators into a single
        operator with many operands.  Op_index points to the (binary)
        concatenation operator that was just created. */

dcl	(cur_operator, old_operator)
			pointer;
dcl	(n, k, i)		fixed binary (18);

	cur_operator = addr (q (op_index));

/* If the first operand of the new concatenation operator is a temporary
        that was created by another concatenation operator, then splice the
        operands of the old operator into the beginning of the new one and
        unchain the old operator. */

	if addr (x (cur_operator -> operator.operand (1))) -> node.node_type = temporary_node
	then do;
		old_operator = addr (q (addr (x (cur_operator -> operator.operand (1))) -> temporary.output_by));
		if old_operator -> operator.op_code = cat_op
		then do;
			n, cur_operator -> operator.number = old_operator -> operator.number + 1;
			cur_operator -> operator.operand (n) = cur_operator -> operator.operand (3);
			cur_operator -> operator.operand (n - 1) = cur_operator -> operator.operand (2);
			do i = 1 to n - 2;
			     cur_operator -> operator.operand (i) = old_operator -> operator.operand (i);
			end;
			next_free_quad = next_free_quad + n - 3;
			call unchain_cat_op (old_operator);
		     end;
	     end;

/* If the last operand of the new concatenation operator is a temporary
        that was output by another concatenation operator, splice the operands
        of the old operator onto the end of the new one and unchain the old
        operator.  Note that the current operator is not necessarily a binary
        operator at this point. */

	n = cur_operator -> operator.number;
	if addr (x (cur_operator -> operator.operand (n - 1))) -> node.node_type = temporary_node
	then do;
		old_operator = addr (q (addr (x (cur_operator -> operator.operand (n - 1))) -> temporary.output_by));
		if old_operator -> operator.op_code = cat_op
		then do;
			k = old_operator -> operator.number;
			cur_operator -> operator.number = n + k - 2;
			cur_operator -> operator.operand (n + k - 2) = cur_operator -> operator.operand (n);
			do i = 1 to k - 1;
			     cur_operator -> operator.operand (n + i - 2) = old_operator -> operator.operand (i);
			end;
			next_free_quad = next_free_quad + k - 2;
			call unchain_cat_op (old_operator);
		     end;
	     end;

     end compress_concat;


unchain_cat_op:
     procedure (op_p);

dcl	(op_p, p)		pointer;

/* unchain_cat_op is called by compress_concat with a pointer to a
   concatenation operator node as its argument.  It removes the operator node
   from the quad chain, and releases its output temporary.  It also frees the
   sub_index operator (and its temporary) that was used for the length. */

	p = op_p;
	call unchain (addr (q (addr (x (p -> operator.operand (p -> operator.number))) -> temporary.output_by)));
	call unchain (p);
	return;

     end unchain_cat_op;

unchain:
     procedure (op_ptr);

/* Does actual unchaining and freeing for unchain_cat_op and elsewhere */

dcl	op_ptr		pointer;

	addr (q (op_ptr -> operator.next)) -> operator.back = op_ptr -> operator.back;
	addr (q (op_ptr -> operator.back)) -> operator.next = op_ptr -> operator.next;
	addr (x (op_ptr -> operator.output)) -> temporary.next = next_free_temp;
	next_free_temp = op_ptr -> operator.output;

     end unchain;

process_expo:
     proc (mode);

dcl	(base, j, k, running_base)
			fixed bin (18);
dcl	mode		bit (1) aligned;

/* process_expo is called with the stack in the form (<>) <exp_op> <base> <power> <...>.  If
   <power> is not a positive integer it generates an exp_op node, otherwise it generates a series
   of multiply nodes using Knuth's algorithm.  It returns with the stack looking like (<>) <result> <...>
   The tricky part deals with subscript computations.  If this exp op occurs inside a
   sub_script calculation, and one of the operands is the accumulated current dimension, then the
   accumulated current dimension is reduced to a single temp or constant and placed into the work
   stack; If inside a sub_script evaluation, then the result temp is placed into dim.temp and a 0
   placed into the work stack at the end of this calculation.  */

	call get_data_type (2);
	if mode & (rand_data_type (1) = 0 | rand_data_type (2) = 0)
	then do;
		if rand_data_type (1) = 0
		then true_rand = 2;
		else true_rand = 1;
		if sub_stack.dim.temp = 0
		then do;
			stack (work_stack_offset - 1 - true_rand) =
			     create_integer_constant ((sub_stack.dim.offset));
			sub_stack.dim.offset = 0;
		     end;
		else call compress_subscript ();
		call get_data_type (2);
	     end;

	if rand_data_type (2) = int_mode
	then do;
		r = addr (x (stack (work_stack_offset - 2)));
		if r -> node.node_type = constant_node
		then do;
			unspec (j) = r -> constant.value;
			if j = 0
			then do;
				stack (work_stack_offset - 3) = one;
				call bump_work_stack_offset (-2);
				return;
			     end;

			if j = 1
			then do;
				call bump_work_stack_offset (-2);
				return;
			     end;
			if j > 1
			then do;
				k = index (r -> constant.value, "1"b);
				call bump_work_stack_offset (-2);
				base, running_base = stack (work_stack_offset - 1);
				do j = k + 1 to 36;
				     stack (work_stack_offset) = running_base;
				     stack (work_stack_offset + 1) = mult_op;
				     call bump_work_stack_offset (+2);
				     call process_arith ("0"b);
				     if substr (r -> constant.value, j, 1)
				     then do;
					     stack (work_stack_offset) = base;
					     stack (work_stack_offset + 1) = mult_op;
					     call bump_work_stack_offset (+2);
					     call process_arith ("0"b);
					end;
				     running_base = stack (work_stack_offset - 1);
				end;
				return;
			     end;
		     end;
	     end;
	if rand_data_type (2) ^= int_mode
	then call conversion;

	op_index = create_operator (2);
	stack (work_stack_offset) = create_temporary (max (rand_data_type (1), rand_data_type (2)));

	if mode & sub_stack.dim.temp = 0 & sub_stack.dim.offset = 0
	then do;
		sub_stack.dim.temp = stack (work_stack_offset);
		stack (work_stack_offset) = 0;
	     end;
	call bump_work_stack_offset (+1);
     end process_expo;

get_data_type:
     proc (number);

dcl	i		fixed bin (18),
	n		fixed bin (18),
	number		fixed bin (18);
dcl	r		ptr;

/* get_data_type is called with a stack of the form (<>) <operator> {<operand>} <...> and an
   argument giving the number of operands.  The first (i.e.  leftmost) operand is the one deepest
   in the stack.  get data_type returns the data types of the "number" operands, in the array
   rand_data_type, with the first operand in rand_data_type(1), etc.  In addition, if the number of
   operands is 2, combination_type is set; this is used by the conversion handling routines when
   determining whether an explicit conversion should be generated.  An operand = to 0, representing
   the accumulated current dimension in a subscript calculation, is arbitrarily assigned a
   data_type of 0 */

	do i = 1 to number;
	     n = stack (work_stack_offset - number - 2 + i);
	     if n < 0				/*   count   */
	     then rand_data_type (i) = int_mode;
	     else if n = 0
	     then rand_data_type (i) = 0;
	     else do;
		     r = addr (x (n));
		     rand_data_type (i) = r -> node.data_type;
		end;
	end;
	if number = 2
	then if rand_data_type (2) > cmpx_mode
	     then combination_type = 17;
	     else if rand_data_type (1) > cmpx_mode
	     then combination_type = 18;
	     else combination_type = 4 * (rand_data_type (2) - 1) + rand_data_type (1);
	return;
     end get_data_type;

bump_work_stack_offset:
     proc (increment);

dcl	increment		fixed bin (18);

/* This was subroutinized to allow over and underflow checking. */

	work_stack_offset = work_stack_offset + increment;
	if work_stack_offset < 0
	then call print_message (205);
	else if work_stack_offset > hbound (stack, 1)
	then call print_message (206, char (hbound (stack, 1)));
	return;
     end bump_work_stack_offset;

effectively_constant:
     proc (offset, rand_no, value) returns (bit (1) aligned);

dcl	(offset, rand_no, value)
			fixed bin (18);
dcl	r		ptr;

/* effectively_constant checks to see if a given operand is either an integer constant, or a
   temporary which was generated by the unary negation of an integer constant.  If either case is
   true, it returns the effective positive or negative value in the third argument, and a function
   value of "1"b; otherwise, it returns a function value of "0"b.  in addition, if the operand was
   the result of negating a constant, it unchains the negate_op node from the quad chain and
   releases the temporary.  */

	r = addr (x (stack (offset)));
	if rand_data_type (rand_no) ^= int_mode
	then return ("0"b);
	if rand_node_type (rand_no) = constant_node
	then do;
		unspec (value) = r -> constant.value;
		return ("1"b);
	     end;

	if rand_node_type (rand_no) ^= temporary_node
	then return ("0"b);

	r = addr (q (r -> temporary.output_by));
	if r -> operator.op_code ^= negate_op
	then return ("0"b);
	if addr (x (r -> operator.operand (1))) -> node.node_type ^= constant_node
	then return ("0"b);

	unspec (value) = addr (x (r -> operator.operand (1))) -> constant.value;
	value = -value;
	if addr (x (r -> operator.output)) -> temporary.ref_count = 0
	then do;
		addr (x (r -> operator.output)) -> temporary.next = next_free_temp;
		next_free_temp = r -> operator.output;
		if r -> operator.next = 0
		then do;
			last_op_index, op_index = r -> operator.back;
			last_quad_p = addr (q (last_op_index));
			next_free_quad = last_quad_p -> operator.next;
			last_quad_p -> operator.next = 0;
		     end;
		else do;
			addr (q (r -> operator.next)) -> operator.back = r -> operator.back;
			addr (q (r -> operator.back)) -> operator.next = r -> operator.next;
		     end;
	     end;
	return ("1"b);
     end effectively_constant;

subscript_arith:
     proc (n) returns (fixed bin (18));

dcl	(data_type, n)	fixed bin (18);

/* subscript_arith is used by the subscript processing routines instead of process_arith, to avoid
   recursion, which would be marvelously inconvenient in this case.  It is called with the stack
   containing (<>) <binary op> <operand> <operand> <...>, or (<>) <unary op> <operand> <...>
   It creates an appropriate operator node, with conversion made explicit if appropriate, generates an
   output temp to place into the node, and places the output temp into the stack as its result.
   The stack becomes (<>) <result> <...> */

	call get_data_type (n);
	if n = 2
	then call conversion;
	op_index = create_operator (n);
	if n = 1
	then data_type = rand_data_type (1);
	else data_type = max (rand_data_type (1), rand_data_type (2));
	return (create_temporary (data_type));
     end subscript_arith;

get_node_type:
     proc (number);

dcl	(i, n, number)	fixed bin (18);
dcl	r		ptr;

/* get_node_type is called with a stack of the form (<>) <operator> {<operand>} <...> and an
   argument giving the number of operands.  The first (i.e.  leftmost) operand is the one deepest
   in the stack.  get_node_type returns the node types of the operands in the array rand_node_type.
   An operand of 0, representing the accumulated current dimension, is arbitrarily given a
   node_type of 0.  */

	do i = 1 to number;
	     n = stack (work_stack_offset - number - 2 + i);
	     if n = 0
	     then rand_node_type (i) = 0;
	     else do;
		     r = addr (x (n));
		     rand_node_type (i) = r -> node.node_type;
		end;
	end;
	return;
     end get_node_type;

compress_subscript:
     proc ();

/* compress_subscript is called when an operation must be evaluated which forces some reduction in
   the accumulated current dimension, so that it can take part in the evaluation.  It is normally
   called with the stack containing (<>) <operator> <operand1> <operand2> <...>, where one of the
   two operands is 0, indicating that the accumulated current dimension is to be used.  The return
   stack depends on the value of <operator>.  If operator is +, -, *, or / then the stack is
   cleaned off to (<>) <...>; otherwise, the returned stack is identical to the calling stack
   except that the operand which was 0 is replaced by a temp indicating the result of evaluating
   accumulated current dimension. */

/* If dim.mult is = 1, there's no need to multiply .  Stuff dim.temp into 0 operand position. */

	if sub_stack.dim.mult = 1
	then stack (work_stack_offset - 1 - true_rand) = sub_stack.dim.temp;

/* If dim.mult is -1, use negate rather than mult.  Then stuff negate_op result into 0 operand position. */

	else if sub_stack.dim.mult = -1
	then do;
		stack (work_stack_offset) = sub_stack.dim.temp;
		stack (work_stack_offset + 1) = negate_op;
		call bump_work_stack_offset (+2);
		tkx = work_stack_offset - 3 - true_rand;
		stack (tkx) = subscript_arith (1);
	     end;

/* Otherwise, generate mult_op node for <dim.mult>*<dim.temp>, and stuff the result into 0 operand place. */

	else do;
		stack (work_stack_offset) = sub_stack.dim.temp;
		stack (work_stack_offset + 1) = create_integer_constant ((sub_stack.dim.mult));
		stack (work_stack_offset + 2) = mult_op;
		call bump_work_stack_offset (+3);
		tkx = work_stack_offset - 4 - true_rand;
		stack (tkx) = subscript_arith (2);
	     end;

/* Reset dim.mult. */

	sub_stack.dim.mult = 1;

/* If the operator is not add or subtract, then add in the offset, if any, to what's been
   calculated so far, and stick this new total result temp into the original 0 result place.  Reset
   dim.offset to 0. */

	if stack (work_stack_offset - 1) ^= add_op | stack (work_stack_offset - 1) ^= sub_op
	then do;
		if sub_stack.dim.offset ^= 0
		then do;
			stack (work_stack_offset) = stack (work_stack_offset - 1 - true_rand);
			stack (work_stack_offset + 1) =
			     create_integer_constant ((sub_stack.dim.offset));
			stack (work_stack_offset + 2) = add_op;
			call bump_work_stack_offset (+3);
			tkx = work_stack_offset - 4 - true_rand;
			stack (tkx) = subscript_arith (2);
		     end;
		sub_stack.dim.offset = 0;
	     end;

/* Now, if this is one of the basic 4 ops, generate a node for it, and stuff the result into dim.temp. */

	if stack (work_stack_offset - 1) >= add_op & stack (work_stack_offset - 1) <= div_op
	then sub_stack.dim.temp = subscript_arith (2);
	return;
     end compress_subscript;

initialize_subscript:
     procedure (symbol_ptr);

/* initialize_subscript is called at the beginning of subscript processing to
   initialize the array's dimension information.  It computes the dimension
   sizes if they are constant, and allocates symbols for them if they are not.
   It computes the virtual origin if it is constant, and allocates a possibly
   shared symbol for it if it is not. */

dcl	symbol_ptr	pointer;

dcl	(s, d)		pointer;
dcl	(i, ndims)	fixed binary (3);
dcl	(sum, multiplier)	fixed binary (24);

	s = symbol_ptr;
	d = addr (x (s -> symbol.dimension));
	ndims = d -> dimension.number_of_dims;

	if ^d -> dimension.has_dim_sizes
	then do;
		do i = 1 to ndims - binary (d -> dimension.assumed_size, 1);
		     if string (d -> dimension.v_bound (i)) = "00"b
		     then d -> dimension.size (i) = d -> dimension.upper_bound (i)
			     - d -> dimension.lower_bound (i) + 1;
		     else if ^d -> dimension.v_bound (i).lower
			& d -> dimension.lower_bound (i) = 1
		     then d -> dimension.size (i) = d -> dimension.upper_bound (i);
		     else d -> dimension.size (i) = create_dim_size_var (d, i);
		end;
		d -> dimension.has_dim_sizes = "1"b;
	     end;

	if ^d -> dimension.has_virtual_origin
	then do;
		if s -> symbol.star_extents
		then do;

/* Star extent character arrays may not share virtual origins with any other
   arrays.  Always create a new symbol for the virtual origin. */

			d -> dimension.virtual_origin = create_var ();
			d -> dimension.variable_virtual_origin = "1"b;
		     end;

		else do;

/* Try to compute the virtual origin.  If it turns out to be constant, there is
   no need to create a variable for it.  If it isn't constant, we try to share
   the virtual origin symbol with other arrays that have the same shape. */

			sum = 0;
			multiplier = s -> symbol.element_size;

			do i = 1 to ndims - 1 while (d -> dimension.virtual_origin = 0);
			     if string (d -> dimension.v_bound (i)) = "00"b
			     then do;
				     sum = sum + multiplier * d -> dimension.lower_bound (i);
				     multiplier = multiplier * d -> dimension.size (i);
				end;
			     else do;
				     d -> dimension.virtual_origin = create_virtual_origin_var (s);
				     d -> dimension.variable_virtual_origin = "1"b;
				end;
			end;

			if d -> dimension.virtual_origin = 0
			then if ^d -> dimension.v_bound (ndims).lower
			     then d -> dimension.virtual_origin =
				     sum + multiplier * d -> dimension.lower_bound (ndims);
			     else do;
				     d -> dimension.virtual_origin = create_virtual_origin_var (s);
				     d -> dimension.variable_virtual_origin = "1"b;
				end;
		     end;
		d -> dimension.has_virtual_origin = "1"b;
	     end;

     end initialize_subscript;

process_builtin:
     proc ();

dcl	(bif_index, char_size, data_type, gen_bif_index, i)
			fixed bin (18);
dcl	op_p		pointer;

dcl	char_bif		fixed bin (18) static options (constant) init (65);

/* process_builtin is called to process builtin function references.  When it is called the stack
   contains (<>) {<args>} <count> <function_id> <...>.  It creates an appropriate builtin function
   node with an output temporary, cleans out the stack, adds the temp, and returns with stack
   containing (<>) <output_temp> <...> */

	bif_index = addr (x (stack (eol_stack.work_stack_offset - 1))) -> symbol.char_size;

/* If the builtin name is a generic name, we must determine which actual function to use.	*/

	if fort_data$builtin_name.description (bif_index).generic_name
	then do;
		data_type = 0;

/* for generics, set the desired function data type to the max data type of its args. */

		do i = eol_stack.work_stack_offset + 1 to work_stack_offset - 2;
		     data_type = max (data_type, addr (x (stack (i))) -> node.data_type);
		end;

/* Now choose the appropriate specific func by using data_type as subscript. */

		gen_bif_index = bif_index;
		if data_type < 1 | data_type > 4
		then bif_index = 0;
		else bif_index = fort_data$builtin_name.description (gen_bif_index).generic_func (data_type);

/* If an appropriate specific does not exist, we'll just use the one with the highest data type. */

		do i = 4 to 1 by -1 while (bif_index = 0);
		     bif_index = fort_data$builtin_name.description (gen_bif_index).generic_func (i);
		     data_type = i;
		end;

/* As usual, if any args need conversion to/from integer, we'll make them explicit. */

		do i = eol_stack.work_stack_offset + 1 to work_stack_offset - 2;
		     if addr (x (stack (i))) -> node.data_type ^= data_type
		     then if addr (x (stack (i))) -> node.data_type = int_mode | data_type = int_mode
			then do;
				stack (work_stack_offset) = stack (i);
				stack (work_stack_offset + 1) = convert_to_int_op + data_type - 1;
				call bump_work_stack_offset (+2);
				op_index = create_operator (1);
				stack (i) = create_temporary (data_type);
			     end;
		end;
	     end;

/* now we can create the builtin node and set up the output temp.  process_eol_stack also pops the
   associated eol_stack entry. */

	call process_eol_stack (1, 2);
	stack (work_stack_offset) = create_temporary (fort_data$builtin_name.description (bif_index).result_type);
	call bump_work_stack_offset (+1);

/* If this is the CHAR builtin, we have to set the length field of the output
   temporary, or else the code generator will get confused. */

	if bif_index = char_bif
	then temp_ptr -> temporary.length = 1;

	return;

     end process_builtin;

process_lhs_fld:
     proc ();

/*  Called with the top of the stack (<>) <lhs_fld> <right_hand_value>
    <argument3> <argument2> <argument1> <...>  Increments the reference
    count on the target argument (argument 3) if it is an array_ref.
    Makes the lhs_fld node, and then cleans out the stack, leaving
    (<> <...> */

dcl	target		fixed bin (18);

	if stack (work_stack_offset - 3) > last_assigned_op
	then if addr (x (stack (work_stack_offset - 3))) -> node.node_type = array_ref_node
	     then addr (x (stack (work_stack_offset - 3))) -> array_ref.ref_count =
		     addr (x (stack (work_stack_offset - 3))) -> array_ref.ref_count + 1;

/* Make the lhs_fld node; set the output to the third argument. */

	target = stack (work_stack_offset - 3);
	stack (work_stack_offset - 3) = stack (work_stack_offset - 2);
	stack (work_stack_offset - 2) = stack (work_stack_offset - 1);
	call bump_work_stack_offset (-1);
	op_index = create_operator (3);
	last_quad_p -> operator.output = target;
	return;
     end process_lhs_fld;

push_eol_stack:
     proc ();

	call bump_work_stack_offset (-1);
	eol_stack_p = addr (w (first_free_object));
	first_free_object = first_free_object + size (eol_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "eol_stack");
	eol_stack.last = eol_offset;
	eol_offset = first_free_object - size (eol_stack);
	eol_stack.op = stack (work_stack_offset);
	eol_stack.work_stack_offset = work_stack_offset - 1;
	suspend_subscript = (eol_stack.op ^= subscript_op);
	return;
     end push_eol_stack;

process_eol_stack:
     proc (units_per_item, extra_units);

dcl	(units_per_item, extra_units)
			fixed bin (18);

	stack (work_stack_offset - 1) = eol_stack.op;
	op_index = create_operator (units_per_item * (stack (eol_stack.work_stack_offset) + bias) + extra_units);
	call pop_eol_stack ();
	return;
     end process_eol_stack;

pop_eol_stack:
     proc ();

	eol_offset = eol_stack.last;
	unspec (eol_stack) = "0"b;
	eol_stack_p = addr (w (eol_offset));
	call new_free_object ();
	if eol_offset = 0
	then suspend_subscript = "0"b;
	else suspend_subscript = (eol_stack.op ^= subscript_op);
	return;
     end pop_eol_stack;

/* The hold stack is used when processing operators, such as logical jumps, which cannot be
   completely processed until the next statement node has been found.  push_hold_stack adds an
   entry to the hold_stack list, and pop_hold_stack deletes one.  */

push_hold_stack:
     proc ();

	hold_stack_p = addr (w (first_free_object));
	first_free_object = first_free_object + size (hold_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "hold_stack");
	hold_stack.last = hold_offset;
	hold_offset = first_free_object - size (hold_stack);
	return;
     end push_hold_stack;

pop_hold_stack:
     proc ();

	hold_offset = hold_stack.last;
	unspec (hold_stack) = "0"b;
	hold_stack_p = addr (w (hold_offset));
	call new_free_object ();
	return;
     end pop_hold_stack;

/* The sub_stack is used to contain special information needed for processing sub_script operators.
   push_sub_stack adds an entry to the sub_stack list, pop_sub_stack removes one.  */

push_sub_stack:
     proc ();

	sub_stack_p = addr (w (first_free_object));
	first_free_object = first_free_object + size (sub_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "sub_stack");
	sub_stack.last = sub_offset;
	sub_offset = first_free_object - size (sub_stack);
	sub_stack.nested = subscript_processing;
	return;
     end push_sub_stack;

pop_sub_stack:
     proc ();
	subscript_processing = sub_stack.nested;
	sub_offset = sub_stack.last;
	unspec (sub_stack) = "0"b;
	sub_stack_p = addr (w (sub_offset));
	call new_free_object ();
	return;
     end pop_sub_stack;

/* The exit_stack is used when processing a semantic construct which is expected to be terminated
   by an exit_op.  push_exit_stack is called when the basic operator is found, to create an
   exit_stack entry.  When the corresponding exit_op has been found and the processing completed,
   pop_exit_stack is called to pop the entry.  */

push_exit_stack:
     proc ();

	exit_stack_p = addr (w (first_free_object));
	first_free_object = first_free_object + size (exit_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "exit_stack");
	exit_stack.last = exit_offset;
	exit_offset = first_free_object - size (exit_stack);
	return;
     end push_exit_stack;

pop_exit_stack:
     proc ();

	exit_offset = exit_stack.last;
	unspec (exit_stack) = "0"b;
	exit_stack_p = addr (w (exit_offset));
	call new_free_object ();
	return;
     end pop_exit_stack;

/* The sf_stack is used when processing a statement function invocation, to keep track of the
   various arguments and other such information.  The stack is needed to handle nested definitions
   and invocations.  push_sf_stack creates and initializes the sf_stack entry, when the sf_ref node
   is found.  The count and sf id are remembered and taken from the work stack.  pop_sf_stack is
   called to clear an entry from the sf_stack list.  */

push_sf_stack:
     proc ();

	sf_stack_p = addr (w (first_free_object));
	sf_num_args = stack (work_stack_offset - 1) + bias;
	first_free_object = first_free_object + size (sf_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "sf_stack");
	sf_stack.last = sf_offset;
	sf_offset = first_free_object - size (sf_stack);
	sf_stack.sf = stack (work_stack_offset - 2);
	sf_stack.def_chain = addr (x (sf_stack.sf));
	sf_stack.current_arg = 1;
	sf_stack.num_args = sf_num_args;
	sf_stack.arg_info (sf_stack.current_arg).chain_start = last_op_index;
	sf_stack.cur_sf_param = sf_stack.def_chain -> symbol.next_member;
	call bump_work_stack_offset (-2);
	return;
     end push_sf_stack;

pop_sf_stack:
     proc ();

	sf_offset = sf_stack.last;
	sf_num_args = sf_stack.num_args;
	unspec (sf_stack) = "0"b;
	sf_stack_p = addr (w (sf_offset));
	call new_free_object ();
	return;
     end pop_sf_stack;

/* the virtual origin list is used as an optimizing feature.  
   there are three routines associated with it:
	1. an add_link routine
	2. a free chain routine- called after each subprog is processed
	3. a routine to scan the list to determine if another link need be
	inserted or if the virtual origin can occur. */

get_virtual_origin_link:
     proc;

/* like the push-pop subrs, this adds a link to the chain, the head of which 
    is the last link created */

	virtual_origin_base, virtual_origin_list_ptr = addr (w (first_free_object));
	first_free_object = first_free_object + size (virtual_origin_list);
	if first_free_object > operand_max_len
	then call print_message (202, "virtual_origin_list");
	virtual_origin_list.last = virtual_origin_offset;
	virtual_origin_offset = first_free_object - size (virtual_origin_list);
     end get_virtual_origin_link;

free_virtual_origin_list:
     proc;

/* unlike the other pop-push routines, the virtual origin list grows during 
    the processing of one subprogram.  Hence we don't pop when finished with
    an item, but free the entire list at the end of the subprog. */

	do while (virtual_origin_offset ^= 0);
	     virtual_origin_offset = virtual_origin_list.last;
	     unspec (virtual_origin_list) = "0"b;
	     virtual_origin_list_ptr = addr (w (virtual_origin_offset));
	     call new_free_object ();
	end /* loop */;
	virtual_origin_base = virtual_origin_list_ptr;
	return;
     end free_virtual_origin_list;

/* The block_if_stack is used to remember important details about block IF
   statements.  Entries are pushed on the block_if_stack when a block_if_op
   is encountered in the polish; entries are popped (after the corresponding
   ENDIF statement has been reached) by process_hold_stack_entry. */

push_block_if_stack:
     procedure ();

	block_if_stack_p = addr (w (first_free_object));
	first_free_object = first_free_object + size (block_if_stack);
	if first_free_object > operand_max_len
	then call print_message (202, "block_if_stack");
	block_if_stack.last = block_if_offset;
	block_if_stack.n_clauses = block_if_clause_count;
	block_if_offset = first_free_object - size (block_if_stack);
	return;

     end push_block_if_stack;

pop_block_if_stack:
     procedure ();

	block_if_offset = block_if_stack.last;
	unspec (block_if_stack) = "0"b;
	block_if_stack_p = addr (w (block_if_offset));
	call new_free_object ();
	return;

     end pop_block_if_stack;

/* The dim_size_list is used in the sharing of dimension size variables.
   It is similar to the virtual_origin_list in that new entries are allocated
   during the processing of a subprogram, and all entries are deleted at the
   end of each subprogram. */

get_dim_size_link:
     procedure ();

	dim_size_list_ptr = addr (w (first_free_object));
	first_free_object = first_free_object + size (dim_size_list);
	if first_free_object > operand_max_len
	then call print_message (202, "dim_size_list");
	dim_size_list.last = dim_size_offset;
	dim_size_offset = first_free_object - size (dim_size_list);

     end get_dim_size_link;


free_dim_size_list:
     procedure ();

	do while (dim_size_offset ^= 0);
	     dim_size_offset = dim_size_list.last;
	     unspec (dim_size_list) = "0"b;
	     dim_size_list_ptr = addr (w (dim_size_offset));
	     call new_free_object ();
	end;

     end free_dim_size_list;

create_virtual_origin_var:
     proc (symbol_ptr) returns (fixed binary (18));

/* procedure to allow sharing of variables for arrays with identical virtual 
    origins which have:
	1. the same element size in the same units
	2. the same number of dimensions
	3. the same lower bounds in all dimensions
	4. the same upper bounds in all dimensions but the last. */

declare	symbol_ptr	pointer /* ptr to the symbol for which a v_o is needed */;

declare	elem_size		fixed bin (17);
declare	elem_units	fixed bin (17);
declare	dim_node		pointer;
declare	num_dims		fixed bin (17);
declare	vo_sharable	bit (1);
declare	this_array	pointer;
declare	this_dim_node	pointer;
declare	this_vo_var	fixed bin (18);

	elem_size = symbol_ptr -> symbol.element_size;
	elem_units = symbol_ptr -> symbol.units;
	dim_node = addr (x (symbol_ptr -> symbol.dimension));
	num_dims = dim_node -> dimension.number_of_dims;
	virtual_origin_list_ptr = virtual_origin_base;

/* scan thru the list of virtual origins, which have already been assigned
    and are potentially sharable.  If it matches present symbol in elem_size and 
     elem_units then explore the dim node. */

	do while (virtual_origin_list_ptr ^= addr (w (0)));
	     if elem_size = virtual_origin_list.element_size
		& num_dims = virtual_origin_list.numb_of_dims
		& elem_units = virtual_origin_list.units
	     then do;				/* an examination of the dim_node */
		     this_array = virtual_origin_list.symbol_node;
		     this_dim_node = addr (x (this_array -> symbol.dimension));
		     vo_sharable =
			(dim_node -> dimension.lower_bound (num_dims)
			= this_dim_node -> dimension.lower_bound (num_dims))
			& (dim_node -> dimension.v_bound (num_dims).lower
			= this_dim_node -> dimension.v_bound (num_dims).lower);
		     do i = 1 to num_dims - 1 while (vo_sharable);
			if string (dim_node -> dimension.v_bound (i))
			     ^= string (this_dim_node -> dimension.v_bound (i))
			     | dim_node -> dimension.lower_bound (i) ^= this_dim_node -> dimension.lower_bound (i)
			     | dim_node -> dimension.upper_bound (i) ^= this_dim_node -> dimension.upper_bound (i)
			then vo_sharable = "0"b;
		     end;

		     if vo_sharable
		     then do;
			     virtual_origin_list_ptr = virtual_origin_base;
			     return (this_dim_node -> dimension.virtual_origin);
			end;
		end /*further calculation */;
	     virtual_origin_list_ptr = addr (w (virtual_origin_list.last));
	end /* walk thru list of previously assigned vo's */;

/* At this point, this array can not share a vo with any other.
   So, add its characteristics to the list, create a new variable,
   and then return. */

	this_vo_var = create_var ();
	call get_virtual_origin_link ();
	virtual_origin_list.element_size = elem_size;
	virtual_origin_list.symbol_node = symbol_ptr;
	virtual_origin_list.numb_of_dims = num_dims;
	virtual_origin_list.units = elem_units;
	virtual_origin_list_ptr = virtual_origin_base;
	return (this_vo_var);
     end create_virtual_origin_var;

create_dim_size_var:
     procedure (dim_p, dim_no) returns (fixed binary (24));

/* This procedure attempts to share variables that are created for dimension
   sizes.  The dim_size_list is scanned for a variable which could represent
   the size of the dimension described by dim_p and dim_no.  If such a variable
   is found, it is returned.  Otherwise, a new variable is created, added to
   the dim_size_list, and returned. */

dcl	(dim_p, d, p)	pointer;
dcl	(dim_no, i)	fixed binary (3);

	d = dim_p;
	i = dim_no;

	do p = dim_size_list_ptr repeat (addr (w (p -> dim_size_list.last)))
	     while (p ^= addr (w (0)));

	     if string (d -> dimension.v_bound (i)) = string (p -> dim_size_list.var)
	     then if d -> dimension.lower_bound (i) = p -> dim_size_list.lower_bound
		then if d -> dimension.upper_bound (i) = p -> dim_size_list.upper_bound
		     then return (p -> dim_size_list.size);

	end;

	call get_dim_size_link ();
	string (dim_size_list.var) = string (d -> dimension.v_bound (i));
	dim_size_list.lower_bound = d -> dimension.lower_bound (i);
	dim_size_list.upper_bound = d -> dimension.upper_bound (i);
	dim_size_list.size = create_var ();

	return (dim_size_list.size);

     end create_dim_size_var;

new_free_object:
     proc ();

/* new_free_object is called by the pop_???_stack goodies, since they all make their linked lists
   in the same segment.  It is a quick and dirty way of making sure that the stack area is kept at
   a minimal size.  */

	first_free_object =
	     max (sf_offset, exit_offset, eol_offset, hold_offset, sub_offset, virtual_origin_offset, block_if_offset,
	     dim_size_offset);
	if first_free_object = 0
	then first_free_object = 1;
	else if first_free_object = sf_offset
	then first_free_object = sf_offset + currentsize (sf_stack);
	else if first_free_object = exit_offset
	then first_free_object = exit_offset + currentsize (exit_stack);
	else if first_free_object = eol_offset
	then first_free_object = eol_offset + currentsize (eol_stack);
	else if first_free_object = hold_offset
	then first_free_object = hold_offset + currentsize (hold_stack);
	else if first_free_object = sub_offset
	then first_free_object = sub_offset + currentsize (sub_stack);
	else if first_free_object = virtual_origin_offset
	then first_free_object = virtual_origin_offset + currentsize (virtual_origin_list);
	else if first_free_object = block_if_offset
	then first_free_object = block_if_offset + currentsize (block_if_stack);
	else if first_free_object = dim_size_offset
	then first_free_object = dim_size_offset + currentsize (dim_size_list);

	return;
     end new_free_object;

conversion:
     proc ();

/* conversion is called with a stack of the form (<>) <some operator> <arg2> <arg1> <...> It checks
   to see if one, but not both, of the args is an integer, and if so generates an explicit
   conversion node to convert it to the same data type as the other argument, and replaces it in
   the stack with the output temp of the convert node.  The stack is returned in the same form as
   it was received.  */

dcl	arg_no		fixed bin (18);

	if combination_type >= 17
	then return;
	if rand_data_type (1) = int_mode
	then if rand_data_type (2) = int_mode
	     then return;
	     else arg_no = 1;
	else if rand_data_type (2) = int_mode
	then arg_no = 2;
	else return;

	stack (work_stack_offset) = stack (work_stack_offset - 4 + arg_no);
	stack (work_stack_offset + 1) = convert_to_int_op - 1 + rand_data_type (3 - arg_no);
	call bump_work_stack_offset (+2);
	op_index = create_operator (1);
	stack (work_stack_offset - 4 + arg_no) = create_temporary (rand_data_type (3 - arg_no));
	return;
     end conversion;

process_sf:
     proc ();

/* process_sf is called when we hit the eol_op terminating the polish entries for a
   statement_function invocation.  At this point the arguments for this invocation have all been
   processed and are held in the sf_stack entry, along with information about where in the quad
   chain the quads needed to evaluate any arguments which required calculation or conversion were
   put.  process_sf performs certain diddles so that the actual expansion of the statement function
   can be handled by the normal operator processing programs. */

/* First check to see if the proper number of args were supplied.  If not, we'll print an error
   message and simply replace the whole sf evaluation with an uninitialized temp to allow continued
   processing for further error checking. */

	if sf_stack.num_args ^= sf_stack.def_chain -> symbol.char_size
	then do;
		if sf_stack.num_args < sf_stack.def_chain -> symbol.char_size
		then call print_message (307, sf_stack.sf);
		else if sf_stack.num_args > sf_stack.def_chain -> symbol.char_size
		then call print_message (308, sf_stack.sf);
		call pop_eol_stack ();
		stack (work_stack_offset) = last_quad_p -> operator.output;
		stack (work_stack_offset - 1) = create_temporary ((sf_stack.def_chain -> symbol.data_type));
		last_quad_p -> operator.output = stack (work_stack_offset);
		call pop_sf_stack ();
		return;
	     end;

/* Otherwise, if everything seems ok, we'll push an exit_stack entry, since sf definitions are
   terminated by an exit_op, toss the eol_stack entry, and force expansion of the sf code by
   remembering the current location in the polish stack (polish_offset) in the sf_stack, and
   resetting the polish pointer to refer to the first polish entry of the statement function
   definition.  When the exit_op is seen, polish_offset will be restored from the sf_stack, and the
   sf_result will be in the work stack. */

	else do;
		call push_exit_stack ();
		exit_stack.op = sf_op;
		exit_stack.count = sf_stack.num_args;
		sf_stack.polish_offset = polish_offset;
		call pop_eol_stack ();
		call bump_work_stack_offset (-1);
		polish_offset = sf_stack.def_chain -> symbol.initial - 1;
	     end;
	return;
     end process_sf;

rechain_arg:
     proc (sf_ptr, sf_entry);

dcl	(sf_entry, start, stop)
			fixed bin (18);
dcl	(start_p, sf_ptr, stop_p)
			ptr;

/* rechain_arg is called if a substitution has to be made for a statement_function dummy variable,
   and sf_stack.chain_start and chain_end for the associated value are non-zero.  This indicates
   that some quads had to be genrated to evaluate the variable, and that the variable has not yet
   been used.  It was decided to be desirable not to evaluate such arguments until immediately
   before they are used, so rechain_arg unchains the argument evaluation from the place in the
   chain where it was first generated, and rechains it at the current top of the chain.  It then
   resets chain_start and end to inhibit this action if the arg is used again.  A check is made
   first to make sure that the argument is not already the last thing on the quad chain.  */

	start = sf_ptr -> sf_stack.arg_info (sf_entry).chain_start;
	stop = sf_ptr -> sf_stack.arg_info (sf_entry).chain_end;
	if stop ^= last_op_index
	then do;
		stop_p = addr (q (stop));
		start_p = addr (q (start));
		addr (q (start_p -> operator.back)) -> operator.next = stop_p -> operator.next;
		if stop_p -> operator.next ^= 0
		then addr (q (stop_p -> operator.next)) -> operator.back = start_p -> operator.back;
		addr (q (last_op_index)) -> operator.next = start;
		start_p -> operator.back = last_op_index;
		stop_p -> operator.next = 0;
		last_op_index, op_index = stop;
		last_quad_p = addr (q (stop));
	     end;
	sf_ptr -> sf_stack.arg_info (sf_entry).chain_start, sf_ptr -> sf_stack.arg_info (sf_entry).chain_end = 0;
	return;
     end rechain_arg;

process_1_subscript:
     proc ();

dcl	constant_value	fixed bin (18);
dcl	big_offset	bit (1) aligned;

/* process_1_subscript is called during subscript processing, when an item op is hit, signifying that
   a subscript has now been completely evaluated.  The top of the stack looks like
   (<>) <item_op> <subscript_value> <array_var> <...>
   process_1_subscript performs the necessary actions to incorporate the effect of the current
   subscript into the total accumulated subscript value.  If this is not the last subscript
   (dimension) the stack will be cleared off and returned as (<>) <array_var> <...>, and various
   initializations will be performed so the next dimension can be evaluated.  If this is the last
   dimension, process_1_subscript will create the opt_subscript_node and the array_ref temp, and
   will return the stack as (<>) <array_ref_node> <...> (For a discussion of the manner in which
   the subscript values are accumulated, see the comments to the process_arith subroutine.  */

/* If the <subscript_value> is 0, it means that the actual value is the accumulated current
   dimension, and we're ok; otherwise, move it into the appropriate part of the accumulated current
   dimension, so we have a standard form for further processing.  */

	if stack (work_stack_offset - 2) ^= 0
	then do;
		call get_data_type (1);
		call get_node_type (1);
		if effectively_constant (work_stack_offset - 2, 1, constant_value)
		then sub_stack.dim.offset = constant_value;
		else sub_stack.dim.temp = stack (work_stack_offset - 2);
		stack (work_stack_offset - 2) = 0;
	     end;
	call bump_work_stack_offset (-2);

/* Now the subscript is in the accumulated current dimension of sub_stack, in the form
   dim.mult*dim.temp + dim.offset.  dim.mult and dim.offset are known to be integer data_types.  If
   dim.temp is not an integer, we will call compress_subscript to force the calculation now, and
   convert the result to an integer.  After this the subscript will be in the same form, but all 3
   parts will be known to be integers.  */

	if sub_stack.dim.temp ^= 0
	then if addr (x (sub_stack.dim.temp)) -> node.data_type ^= int_mode
	     then do;
		     true_rand = -1;
		     call compress_subscript ();
		     stack (work_stack_offset + 1) = convert_to_int_op;
		     call bump_work_stack_offset (+2);
		     op_index = create_operator (1);
		     sub_stack.dim.temp = create_temporary ((int_mode));
		end;

/* Now we want to multiply the current dimensions subscript which is represented as shown above
   (known to be integer) by the effective length of one element in this dimension (i.e the number
   of words in storage which would be represented by an increase of 1 in this dimension) which is
   represented by the expression element.var*element.constant both parts of which are known to be
   integers.  This section is a collection of special cases designed to allow as much of the
   computation as possible to be done at the time of compilation.

   The result will be placed back into the dim.???  entries, leaving an expression in the same
   form, but which now represents a number of words of storage rather than a subscript.  Finally
   element.??  will be updated for the next dimension calculation.  */

	if sub_stack.element.var ^= 0
	then do;

/* if there is an element.var, but no dim.temp, then we simply set dim.mult equal to
   dim.offset*element.constant, put element.var into dim.temp, and set dim.offset to 0		*/

		if sub_stack.dim.temp = 0
		then do;
			sub_stack.dim.mult = sub_stack.dim.offset * sub_stack.element.constant;
			sub_stack.dim.temp = sub_stack.element.var;
			sub_stack.dim.offset = 0;
		     end;

/* a little hairier if there is an element.var and a dim.temp, but no dim.offset.  Then we must
   multiply dim.mult by element.constant, and create a mult_op node to multipy dim.temp by
   element.var, placing the result temp into dim.temp */

		else if sub_stack.dim.offset = 0
		then do;
			sub_stack.dim.mult = sub_stack.dim.mult * sub_stack.element.constant;
			stack (work_stack_offset) = sub_stack.dim.temp;
			stack (work_stack_offset + 1) = sub_stack.element.var;
			stack (work_stack_offset + 2) = mult_op;
			call bump_work_stack_offset (+3);
			call process_arith ("0"b);
			call bump_work_stack_offset (-1);
			sub_stack.dim.temp = stack (work_stack_offset);
		     end;

/* worst case...  there is an element.var, a dim.temp, and a dim.offset.  in that case we must
   fully evaluate the dim calculation to multiply it by element.var.

   First we generate a mult_op node to calculate dim.temp*dim.mult...unless dim.mult is 1, in which
   case this step is skipped, or -1, in which case a negate_op of dim.temp is generated instead.
   Then an add_op node to add in dim.offset is created.  Finally a mult_op node is generated to
   multiply this result by element.var The result of this operation is placed into dim.temp, and
   element.constant is placed into dim.mult.  dim.offset is zeroed.  */

		else do;
			stack (work_stack_offset) = sub_stack.dim.temp;
			call bump_work_stack_offset (+1);
			if sub_stack.dim.mult = -1
			then do;
				stack (work_stack_offset) = negate_op;
				call bump_work_stack_offset (+1);
				op_index = create_operator (1);
				stack (work_stack_offset) = create_temporary ((int_mode));
				call bump_work_stack_offset (+1);
			     end;
			else if sub_stack.dim.mult ^= 1
			then do;
				stack (work_stack_offset) =
				     create_integer_constant ((sub_stack.dim.mult));
				stack (work_stack_offset + 1) = mult_op;
				call bump_work_stack_offset (+2);
				call process_arith ("0"b);
			     end;
			stack (work_stack_offset) =
			     create_integer_constant ((sub_stack.dim.offset));
			stack (work_stack_offset + 1) = add_op;
			call bump_work_stack_offset (+2);
			call process_arith ("0"b);
			stack (work_stack_offset) = sub_stack.element.var;
			stack (work_stack_offset + 1) = mult_op;
			call bump_work_stack_offset (+2);
			call process_arith ("0"b);
			call bump_work_stack_offset (-1);
			sub_stack.dim.temp = stack (work_stack_offset);
			sub_stack.dim.mult = sub_stack.element.constant;
			sub_stack.dim.offset = 0;
		     end;

/* Time to update element entry.  If this is the last dimension, we'll skip this part.  Otherwise,
   we've got to look at dimension.dim associated with this dimension of this symbol.  (In case
   you've lost track, this is still part of the block done only if there was an element.var) */

		if sub_stack.dimension ^= sub_stack.n_dimensions
		then do;

/* if this dimension is a constant, just multiply element.constant by it.  */

			if string (sub_stack.dim_node -> dimension.v_bound (sub_stack.dimension)) = "00"b
			then sub_stack.element.constant =
				sub_stack.element.constant
				* sub_stack.dim_node -> dimension.size (sub_stack.dimension);

/* This dim not constant, gotta generate a mult_op node to multiply it times element.var, and stuff
   the result temp back into element.var */

			else do;
				stack (work_stack_offset) = sub_stack.element.var;
				stack (work_stack_offset + 1) =
				     sub_stack.dim_node -> dimension.size (sub_stack.dimension);
				stack (work_stack_offset + 2) = mult_op;
				call bump_work_stack_offset (+3);
				call process_arith ("0"b);
				call bump_work_stack_offset (-1);
				sub_stack.element.var = stack (work_stack_offset);
			     end;
		     end;
	     end;

	else do;

/* If we got here, there's no element.var...  They should all be so easy...  Just multiply dim.mult
   and dim.offset by element.constant.  */

		sub_stack.dim.mult = sub_stack.dim.mult * sub_stack.element.constant;
		sub_stack.dim.offset = sub_stack.dim.offset * sub_stack.element.constant;

/* Like above, if this is not the last dimension, we gotta update element.???  (remember, there is
   no element.var here).  If the current dimension.dim is a constant, just multiply
   element.constant by it; if it's variable, stuff it in element.var */

		if sub_stack.dimension ^= sub_stack.n_dimensions
		then do;
			if string (sub_stack.dim_node -> dimension.v_bound (sub_stack.dimension)) = "00"b
			then sub_stack.element.constant =
				sub_stack.element.constant
				* sub_stack.dim_node -> dimension.size (sub_stack.dimension);
			else sub_stack.element.var = sub_stack.dim_node -> dimension.size (sub_stack.dimension);
		     end;
	     end;

/* Now we have to add the effect of the current dimension (dim.mult*dim.temp + dim.offset,
   remember) to the offset from the array effective origin accumulated so far from the previously
   processed subscripts.  Again, it's a bunch of special cases to minimize run_time calculation. */

/* First, the simple part.  Add dim.offset into cum.constant, giving a new cum.constant */

	sub_stack.cum.constant = sub_stack.cum.constant + sub_stack.dim.offset;
	if sub_stack.dim.temp ^= 0
	then do;

/* There is also a dim.temp, if we got this far.  If dim.mult is -1, there are two possibilities.
   If there is not yet a cum.temp entry, we'll generate a negate_op of dim.temp, and stuff the
   output temp into cum.temp.  If there is already a cum.temp, we'll generate a subtract_op of
   cum.temp and dim.temp, and stuff the output into cum.temp.  */

		if sub_stack.dim.mult = -1
		then do;
			if sub_stack.cum.temp = 0
			then do;
				stack (work_stack_offset) = sub_stack.dim.temp;
				stack (work_stack_offset + 1) = negate_op;
				call bump_work_stack_offset (+2);
				op_index = create_operator (1);
				sub_stack.cum.temp = create_temporary ((int_mode));
			     end;
			else do;
				stack (work_stack_offset) = sub_stack.cum.temp;
				stack (work_stack_offset + 1) = sub_stack.dim.temp;
				stack (work_stack_offset + 2) = sub_op;
				call bump_work_stack_offset (+3);
				call process_arith ("0"b);
				call bump_work_stack_offset (-1);
				sub_stack.cum.temp = stack (work_stack_offset);
			     end;
		     end;

/* There's a dim.temp, and dim.mult was not -1.  We'll first generate a mult_op node with dim.mult
   and dim.temp (unless dim.mult is 1).  Then if cum_temp is nonzero, we'll generate an add_op node
   to add it in.  Finally we'll take the result, whatever it is, and stuff it back into cum.temp */

		else do;
			stack (work_stack_offset) = sub_stack.dim.temp;
			call bump_work_stack_offset (+1);
			if sub_stack.dim.mult ^= 1
			then do;
				stack (work_stack_offset) =
				     create_integer_constant ((sub_stack.dim.mult));
				stack (work_stack_offset + 1) = mult_op;
				call bump_work_stack_offset (+2);
				call process_arith ("0"b);
			     end;
			if sub_stack.cum.temp ^= 0
			then do;
				stack (work_stack_offset) = sub_stack.cum.temp;
				stack (work_stack_offset + 1) = add_op;
				call bump_work_stack_offset (+2);
				call process_arith ("0"b);
			     end;
			call bump_work_stack_offset (-1);
			sub_stack.cum.temp = stack (work_stack_offset);
		     end;
	     end;

/* Now we can reset dim.???  to compute the next dimension */

	sub_stack.dim.mult = 1;
	sub_stack.dim.temp = 0;
	sub_stack.dim.offset = 0;
	sub_stack.dimension = sub_stack.dimension + 1;
	if sub_stack.dimension <= sub_stack.n_dimensions
	then return;

/* That was the final dimension:  Make the opt_subscript_op node, with the
   array_ref_node as its output.  */


	if sub_stack.symbol_node -> symbol.VLA
	then do;

/*  The 'create_opt_subscript' routine requires the nodes that contain the   */
/*  constant and variable offsets of the desired element to be entered into  */
/*  the work stack.  For VLA's, the constant offset is always zero and the   */
/*  variable offset is really a packed pointer to the desired array element. */
/*  Since we originally initialized 'cum.temp' to the address of the start   */
/*  of the array minus its virtual origin, 'cum.temp' is now the address of  */
/*  the desired array element, provided that none of the subscripts of the   */
/*  element were constant.  If there were some constant subscripts, their    */
/*  effect was accumulated in 'cum.constant' and we must generate a quad to  */
/*  add it to 'cum.temp' to get the address of the desired element.  If we   */
/*  are not dealing with 256K VLA's, the addressor contains the "logical"    */
/*  address of the element and we must generate a quad to convert it to a    */
/*  physical address (i.e. a packed pointer).                                */

		stack (work_stack_offset) = zero;
		stack (work_stack_offset + 1) = sub_stack.cum.temp;
		call bump_work_stack_offset (+2);

		if sub_stack.cum.constant ^= 0
		then do;				/*  Add 'cum.constant' to the addressor.  */
			stack (work_stack_offset) = create_integer_constant ((sub_stack.cum.constant));
			stack (work_stack_offset + 1) = add_op;
			call bump_work_stack_offset (+2);
			call process_arith ("0"b);
			cum.constant = 0;
		     end;

		if ^VLA_is_256K
		then do				/*  Convert the addressor to a packed pointer.  */
			stack (work_stack_offset) = form_VLA_packed_ptr_op;
			call bump_work_stack_offset (+1);
			op_index = create_operator (1);
			stack (work_stack_offset) = create_temporary ((int_mode));
			call bump_work_stack_offset (+1);
		     end;

		big_offset = "1"b;			/*  The addressor is too big for an X register.  */
	     end;
	else do;

/* If the virtual origin of the array is a constant, just add it to cum.constant.  Move
   cum.constant and cum.temp into the work stack.  */

		if ^sub_stack.dim_node -> dimension.variable_virtual_origin
		then sub_stack.cum.constant = sub_stack.cum.constant - sub_stack.dim_node -> dimension.virtual_origin;
		stack (work_stack_offset) = create_integer_constant ((sub_stack.cum.constant));
		stack (work_stack_offset + 1) = sub_stack.cum.temp;
		call bump_work_stack_offset (+2);

/* If the virtual origin is not a constant, generate an appropriate node to subtract it from
   cum.temp This may be a negate_op if there was no cum.temp.  */

		if sub_stack.dim_node -> dimension.variable_virtual_origin
		then do;
			if stack (work_stack_offset - 1) = 0
			then do;
				stack (work_stack_offset - 1) = sub_stack.dim_node -> dimension.virtual_origin;
				stack (work_stack_offset) = negate_op;
				call bump_work_stack_offset (+1);
				op_index = create_operator (1);
				stack (work_stack_offset) = create_temporary ((int_mode));
				call bump_work_stack_offset (+1);
			     end;
			else do;
				stack (work_stack_offset) = sub_stack.dim_node -> dimension.virtual_origin;
				stack (work_stack_offset + 1) = sub_op;
				call bump_work_stack_offset (+2);
				call process_arith ("0"b);
			     end;
		     end;

/* If the variable offset might not fit into an index register, set the
   big_offset bit, which prevents a sub_index operator from being generated
   and causes the offset to be loaded into the A or Q.  We must have
   0 <= variable offset <= 262143 for an index register to be used.  Since we
   know 0 <= constant offset + variable offset <= array_size - 1, we can derive
   these two conditions for index register use:
   constant offset <= 0  AND  array_size - constant offset <= 262144.
   If either of these is not met, an index register may not be used. */

		big_offset = "0"b;
		if sub_stack.symbol_node -> symbol.units = char_units
		then if sub_stack.cum.temp ^= 0
		     then if sub_stack.symbol_node -> symbol.variable_extents
			     | sub_stack.symbol_node -> symbol.star_extents
			     | sub_stack.cum.constant > 0
			     | sub_stack.dim_node -> dimension.array_size - sub_stack.cum.constant > 262144
			then big_offset = "1"b;

/* Now if the variable part about to be used in the opt_subscript_op node is a
   temporary or array_ref (and it is not a big_offset) we've gotta run it
   through a sub_index_op node.  We must also set the output temp's
   used_as_subscript bit.  */

		if (stack (work_stack_offset - 1) ^= 0) & (^big_offset)
		then do;
			if addr (x (stack (work_stack_offset - 1))) -> node.node_type ^= symbol_node
			then do;
				stack (work_stack_offset) = sub_index_op;
				call bump_work_stack_offset (+1);
				call get_data_type (1);
				op_index = create_operator (1);
				stack (work_stack_offset) = create_temporary (rand_data_type (1));
				call bump_work_stack_offset (+1);
				temp_ptr -> temporary.bits.used_as_subscript = "1"b;
			     end;
		     end;
	     end;

/* At last we can create the opt_subscript_op node and its associated array_ref node */

	stack (work_stack_offset) = opt_subscript_op;
	call bump_work_stack_offset (+1);
	call create_opt_subscript ("0"b);
	array_ptr -> array_ref.large_offset = big_offset;
     end process_1_subscript;

process_substr:
     procedure ();

/* process_substr is called when a substr_op is hit and does all required work.
    The top of the stack is: (<>)<substr_op><upper_bound><lower_bound><parent>...
    The parent is either a symbol (i.e. substr'ing a scalar) or an array ref (i.e.the parent is an array ref).
    An opt_subscript node is placed in the quads with 4 operands: (1) symbol, (2) constant-offset,
    (3)variable-offset, (4) length.  If the parent is an array-ref, then we must merge
    the offset info with that of the substr (this is like subscript processing). */

declare	(parent_ptr, sympx, bound_ptr)
			pointer;
declare	(
	big_offset,
	bound_constant	(2),
	parent_is_array
	)		bit (1);
declare	(
	bound_index	(2),
	constant_part,
	parent_constant_part,
	parent_variable_part,
	true_parent_variable_part,
	substr_length,
	variable_part
	)		fixed binary (18);

declare	(
	bound_value	(2),
	constant_value,
	parent_constant_value
	)		fixed binary (35);

declare	int_image		fixed binary (35) based;

/* first examine the parent for any array-ref-node info */

	parent_ptr = addr (x (stack (work_stack_offset - 4)));
	if parent_ptr -> node.node_type = array_ref_node
	then do;
		parent_is_array = "1"b;
		sympx = addr (x (parent_ptr -> array_ref.parent));
		big_offset = parent_ptr -> array_ref.large_offset;
	     end;
	else do;
		parent_is_array = "0"b;
		sympx = parent_ptr;
		big_offset = "0"b;
	     end;

	if sympx -> symbol.data_type ^= char_mode
	then call print_message (159, stack (work_stack_offset - 4));

/* now examine the bounds - if constant and integer then bound is
    constant, else  it is variable and may need conversion to integer
    in this code bound_xxx (1)  refers to the lower bound and  bound_xxx(2)
    to the upper bound.   */

	call get_data_type (2);

	do i = 1 to 2;
	     bound_ptr = addr (x (stack (work_stack_offset - 4 + i)));
	     if rand_data_type (i) ^= int_mode
	     then do;

/* we have to convert to integer */

		     bound_constant (i) = "0"b;
		     stack (work_stack_offset) = stack (work_stack_offset - 4 + i);
		     stack (work_stack_offset + 1) = convert_to_int_op;
		     call bump_work_stack_offset (+2);
		     op_index = create_operator (1);
		     bound_index (i) = create_temporary ((int_mode));
		end;
	     else do;

/* data type is integer - if constant, get its value */

		     bound_constant (i) = (bound_ptr -> node.operand_type = constant_type);
		     bound_index (i) = stack (work_stack_offset - 4 + i);
		     if bound_constant (i)
		     then bound_value (i) = addr (bound_ptr -> constant.value) -> int_image;
		end;

	end /* do loop */;

/* next compute length and offset of the substr,
   remembering that length = upper_bound - lower_bound + 1, however computed */

	if bound_constant (1)
	then do;

/* lower bound is constant, so offset is also */


		constant_value = bound_value (1) - 1;
		variable_part = 0;

		if bound_constant (2)

/* if both are constant then length is constant */

		then substr_length = create_integer_constant (bound_value (2) - bound_value (1) + 1);
		else substr_length = do_arith (sub_op, create_integer_constant ((constant_value)), bound_index (2));
	     end;

	else do;

/* lowerbound is variable, so both length and offset are */

		constant_value = -1;
		variable_part = bound_index (1);

/* if the upper_bound is constant, fold "1" into its value and subtract the
   lower bound from that, else two arithmetic operations are required */

		if bound_constant (2)
		then substr_length =
			do_arith (sub_op, bound_index (1), create_integer_constant (bound_value (2) + 1));
		else substr_length = do_arith (add_op, do_arith (sub_op, bound_index (1), bound_index (2)), one);
	     end;

/* if parent is an array, merge its offset info with that of the substr,
    otherwise, merely set that for the substr */

	if parent_is_array
	then do;
		parent_constant_part = addr (q (parent_ptr -> array_ref.output_by)) -> operator.operand (2);
		parent_constant_value = addr (addr (x (parent_constant_part)) -> constant.value) -> int_image;
		true_parent_variable_part = addr (q (parent_ptr -> array_ref.output_by)) -> operator.operand (3);

		constant_part = create_integer_constant (parent_constant_value + constant_value);

		if true_parent_variable_part > 0
		then do;
			parent_variable_part = strip_sub_index (true_parent_variable_part);
			if variable_part = 0
			then variable_part = parent_variable_part;
			else variable_part = do_arith (add_op, parent_variable_part, variable_part);
		     end;

/* Make sure the variable offset still fits in an index register. */

		if ^sympx -> symbol.variable_extents & ^sympx -> symbol.star_extents
		then if variable_part ^= 0
		     then big_offset = constant_value + parent_constant_value > 0
			     | addr (x (sympx -> symbol.dimension)) -> dimension.array_size
			     - (constant_value + parent_constant_value) > 262144;

	     end;

	else do;

/*  parent is a symbol */

		constant_part = create_integer_constant ((constant_value));

	     end;

/*  if the offset is capable of being held in an index register,
    then run it thru a sub_index node & set output temp's used as subs bit */

	if ^big_offset & variable_part ^= 0
	then if addr (x (variable_part)) -> node.node_type ^= symbol_node
	     then do;
		     stack (work_stack_offset) = variable_part;
		     stack (work_stack_offset + 1) = sub_index_op;
		     call bump_work_stack_offset (+2);
		     call get_data_type (1);
		     op_index = create_operator (1);
		     variable_part = create_temporary ((int_mode));
		     temp_ptr -> temporary.bits.used_as_subscript = "1"b;
		end;

/* clean up the stack, pop on the opt_subscript_op and args, create the opt_subscript node in the quads */

	call bump_work_stack_offset (-4);
	stack (work_stack_offset) = fixed (rel (sympx), 18);
	stack (work_stack_offset + 1) = constant_part;
	stack (work_stack_offset + 2) = variable_part;
	stack (work_stack_offset + 3) = substr_length;
	stack (work_stack_offset + 4) = opt_subscript_op;
	call bump_work_stack_offset (+5);
	call create_opt_subscript ("1"b);
	array_ptr -> array_ref.large_offset = big_offset;

/* if the parent was an array with a variable part,
   unchain the old opt_subscript_node and free the sub_index operator and its temporary */

	if parent_is_array
	then do;
		if true_parent_variable_part ^= parent_variable_part & true_parent_variable_part ^= 0
		then call unchain (addr (q (addr (x (true_parent_variable_part)) -> temporary.output_by)));

		call unchain_opt_subscript (addr (q (parent_ptr -> array_ref.output_by)));
	     end;


	return;

unchain_opt_subscript:
     procedure (op_ptr);

/* Does the actual unchaining of opt_subscript_nodes and freeing of 
    array_refs */

dcl	op_ptr		pointer;

	addr (q (op_ptr -> operator.next)) -> operator.back = op_ptr -> operator.back;
	addr (q (op_ptr -> operator.back)) -> operator.next = op_ptr -> operator.next;
	addr (x (op_ptr -> operator.output)) -> array_ref.next = next_free_array_ref;
	next_free_array_ref = op_ptr -> operator.output;

     end unchain_opt_subscript;

     end process_substr;

do_arith:
     procedure (operator, operand1, operand2) returns (fixed binary (18));

/* called with a operator and the two operands -does the quad generation 
    and returns the temporary left on top of the stack by process_arith,
    however the stack itself is left unchanged by this call */

declare	(operator, operand1, operand2)
			fixed binary (18);

	stack (work_stack_offset) = operand2;
	stack (work_stack_offset + 1) = operand1;
	stack (work_stack_offset + 2) = operator;
	call bump_work_stack_offset (+3);
	call process_arith ("0"b);
	call bump_work_stack_offset (-1);
	return (stack (work_stack_offset));

     end do_arith;

create_opt_subscript:
     procedure (doing_substr);

declare	doing_substr	bit (1);
declare	num_operands	fixed binary (18);
declare	array_parent_p	pointer;
declare	char_len		fixed binary (18);

/* creates the opt_substr node and associated array ref node for a
    subscripted or substred variable  - assumes the stack looks like:
    (<>) <opt_subscript_op> [<length>] <variable_part> <constant_part> <parent>,
    the length operand only if doing_substr.  
    the stack is left as (<>) <array_ref_node> ...    */

	if doing_substr
	then num_operands = 4;
	else num_operands = 3;

	array_parent_p = addr (x (stack (work_stack_offset - num_operands - 1)));

	rand_data_type (1) = array_parent_p -> symbol.data_type;
	op_index = create_operator (num_operands);
	stack (work_stack_offset) = create_node (array_ref_node, size (array_ref));
	last_quad_p -> operator.output = stack (work_stack_offset);

	array_ptr = addr (x (stack (work_stack_offset)));
	array_ptr -> array_ref.output_by = op_index;
	array_ptr -> array_ref.operand_type = array_ref_type;
	array_ptr -> array_ref.ref_count = 0;
	array_ptr -> array_ref.data_type = rand_data_type (1);
	array_ptr -> array_ref.parent = last_quad_p -> operator.operand (1);

	if array_ptr -> array_ref.data_type = char_mode
	then do;
		char_len = get_char_size (array_parent_p);
		if char_len < 0
		then array_ptr -> array_ref.length = char_len + bias;
		else do;
			array_ptr -> array_ref.length = char_len;
			array_ptr -> array_ref.variable_length = "1"b;
		     end;
	     end;

	call bump_work_stack_offset (+1);

	return;

     end create_opt_subscript;

get_char_size:
     procedure (node_p) returns (fixed binary (18));

/* Returns the character length of the operand pointed to by
	   node_p.  Returns a count if the length is known to be constant,
	   otherwise returns an operand index. */

dcl	(node_p, p, o)	pointer;

	p = node_p;

	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;
		o = addr (q (p -> array_ref.output_by));
		if o -> operator.op_code = opt_subscript_op
		     & o -> operator.number = 4
		then return (strip_sub_index (o -> operator.operand (4)));
		else 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;
		o = addr (q (p -> temporary.output_by));
		if o -> operator.op_code = cat_op
		then return (strip_sub_index (o -> operator.operand (o -> operator.number)));
		else if p -> temporary.variable_length
		then return (p -> temporary.length);
		else return (p -> temporary.length - bias);
	     end;

	return (0);

     end get_char_size;


strip_sub_index:
     procedure (operand) returns (fixed binary (18));

/* If the operand is the output of a sub_index operator, return
	   the input of the operator.  Otherwise, just return the operand. */

dcl	(operand, op)	fixed binary (18);
dcl	o		pointer;

	op = operand;

	if addr (x (op)) -> node.node_type = temporary_node
	then do;
		o = addr (q (addr (x (op)) -> temporary.output_by));
		if o -> operator.op_code = sub_index_op
		then op = o -> operator.operand (1);
	     end;

	return (op);

     end strip_sub_index;


is_local:
     procedure (operand) returns (bit (1) aligned);

/* is_local is a predicate which returns true if the operand is
	   a subroutine or function that occurs in this compilation. */

dcl	(operand, sym)	fixed binary (18);
dcl	(p, s)		pointer;

	p = addr (x (operand));

	if (^p -> symbol.external)
	then return ("0"b);

/* Search list of entry symbols for one with the same name. */

	do sym = first_entry_name repeat (s -> symbol.next_symbol) while (sym > 0);
	     s = addr (x (sym));
	     if s -> symbol.name = p -> symbol.name
	     then return ("1"b);
	end;

	return ("0"b);

     end is_local;


is_star_extent:
     procedure (operand) returns (bit (1) aligned);

/* is_star_extent is a predicate that returns true if the operand
	   is a symbol of star extent, or a substring or array reference
	   whose parent is of star extent. */

dcl	operand		fixed binary (18);
dcl	p		pointer;

	p = addr (x (operand));

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

	if p -> node.node_type = symbol_node
	then return (p -> symbol.star_extents);
	else return ("0"b);

     end is_star_extent;

process_hold_stack_entry:
     proc ();

dcl	(i, j)		fixed bin (18);

/* The hold stack is used to remember various things that need to be done to a statement after the
   next statement node has been processed.  */

	if opst -> opt_statement.put_in_map | hold_stack.op_code = block_if_op
	then do while (hold_offset ^= 0);

/* If the statement must have a label, but doesn't, make it one.  */

		if hold_stack.op_code ^= jump_true_op
		then do;
			if opst -> opt_statement.label = 0
			then opst -> opt_statement.label = create_label (last_op_index);
			i = opst -> opt_statement.label;
			addr (x (i)) -> label.referenced_executable = "1"b;
		     end;

/* If the last statement was an if statement whose conditionally executed part was not a goto, we
   need to tell it where to jump to if the test failed.  */

		if hold_stack.op_code = jump_false_op
		then hold_stack.ptr -> operator.operand (2) = i;

/* Now is where we optimize any variety of if statement by separating the tests in compound tests.	*/

		if hold_stack.op_code = jump_false_op | hold_stack.op_code = jump_true_op
		then call optimize_if ((hold_stack.ptr));

/* If last statement was an arithmetic if, there may be unspecified labels to fill in.  */

		else if hold_stack.op_code = jump_arithmetic_op
		then do j = 2 to 4;
			if hold_stack.ptr -> operator.operand (j) < 0
			then hold_stack.ptr -> operator.operand (j) = i;
		     end;

/* If we are at the end of a block IF statement, the jump operators at the
   ends of the clauses must be filled in. */

		else if hold_stack.op_code = block_if_op
		then do;
			do j = 1 to block_if_stack.n_jumps;
			     addr (q (block_if_stack.jump (j))) -> operator.operand (1) = i;
			end;
			call pop_block_if_stack ();
		     end;

/* Last possibility is that last statement was a do statement, and this is the first statement of
   the do group.  In that case, we must remember its label.  */

		else exit_stack.do_label = i;
		call pop_hold_stack ();
	     end;
	return;
     end process_hold_stack_entry;

create_label:
     proc (i) returns (fixed bin (18));

dcl	(i, j)		fixed bin (18);

/* create_label creates a label and attaches it to the opt_statement node whose offset in the quads
   is contained in i.  It returns the offset in x (the symbol area) of the label entry created.  */

	j = create_node (label_node, size (label));
	addr (x (j)) -> label.statement = i;
	addr (x (j)) -> label.operand_type = rel_constant;
	addr (x (j)) -> label.executable, addr (x (j)) -> label.referenced, addr (x (j)) -> label.allocate,
	     addr (x (j)) -> label.set = "1"b;
	if subp_ptr -> subprogram.last_label = 0
	then subp_ptr -> subprogram.first_label = j;
	else addr (x (subp_ptr -> subprogram.last_label)) -> label.next_label = j;
	subp_ptr -> subprogram.last_label = j;
	return (j);
     end create_label;

search_label:
     proc (n);

dcl	n		fixed bin (18);

/* search_label checks to determine if a reference to a label is a backwards reference, and if so
   sets the referenced_backwards bit in the statement to which the label belongs.  The argument is
   the offset in the symbol list of the label entry to be checked.  */

	if addr (x (n)) -> label.statement ^= 0
	then if addr (q (addr (x (n)) -> label.statement)) -> opt_statement.processed_by_converter
	     then addr (q (addr (x (n)) -> label.statement)) -> opt_statement.referenced_backwards = "1"b;
	return;
     end search_label;

create_opt_statement:
     proc () returns (ptr);

dcl	i		fixed bin (18);
dcl	opst		ptr;

/* create_opt_statement is called to create and initialize an opt_statement node.  It returns a
   pointer to the node created.  Most of the initialization data is taken directly from the
   statement node in the polish.  */

	i = next_free_quad;
	next_free_quad = next_free_quad + size (opt_statement);
	if next_free_quad > quad_max_len
	then call print_message (407, "quadruple region", char (quad_max_len));
	opst = addr (q (i));
	unspec (opst -> opt_statement) = "0"b;
	if subp_ptr -> subprogram.last_polish = cur_statement
	then subp_ptr -> subprogram.last_quad = i;
	opst -> opt_statement.back = rel (last_opt_statement);
	if rel (last_opt_statement)
	then last_opt_statement -> opt_statement.next = rel (opst);
	if last_op_index ^= 0
	then addr (q (last_op_index)) -> operator.next = i;
	else subp_ptr -> subprogram.first_quad = i;

	opst -> opt_statement.prev_operator = last_op_index;
	opst -> opt_statement.op_code = stat_op;
	opst -> opt_statement.source_id = stm_ptr -> statement.source_id;
	opst -> opt_statement.length = stm_ptr -> statement.length;
	opst -> opt_statement.put_in_map = stm_ptr -> statement.put_in_map;
	opst -> opt_statement.put_in_profile = stm_ptr -> statement.put_in_profile;
	opst -> opt_statement.start = stm_ptr -> statement.start;
	opst -> opt_statement.location = stm_ptr -> statement.location;
	opst -> opt_statement.flow_unit, opst -> opt_statement.operator_list = null;

	last_op_index = i;
	last_opt_statement = opst;
	return (opst);
     end create_opt_statement;

create_operator:
     proc (n) returns (fixed bin (18));

dcl	i		fixed bin (18),
	j		fixed bin (18),
	n		fixed bin (18);

/* create_operator is called with the stack containing (<>) <operator> <arg_n> ... <arg_1> <...>
   The number of args in the stack is passed as the argument n.  create_operator creates and inits
   an appropriate size node, stuffs the operator and operands into the node from the stack,
   increments the ref_counts for any of the operator args which are array_refs or temps, Cleans the
   operator and its args from the stack, and returns the offset in the quads of the created node.
   The stack is left as (<>) <...> upon return.  */

	i = next_free_quad;
	n_operands = n;
	if n_operands > max_num_of_rands
	then call print_message (204, char (max_num_of_rands));
	next_free_quad = next_free_quad + size (operator);
	if next_free_quad > quad_max_len
	then call print_message (407, "quadruple region", char (quad_max_len));

	last_quad_p = addr (q (i));
	unspec (last_quad_p -> operator) = "0"b;
	last_quad_p -> operator.back = last_op_index;
	if last_op_index ^= 0
	then addr (q (last_op_index)) -> operator.next = i;
	if opst -> opt_statement.first_operator = 0
	then opst -> opt_statement.first_operator = i;
	last_quad_p -> operator.op_code = stack (work_stack_offset - 1);
	last_quad_p -> operator.number = n_operands;
	last_quad_p -> operator.primary = null;

	do j = 1 to n_operands;
	     last_quad_p -> operator.operand (j) = stack (work_stack_offset - n_operands - 2 + j);
	     if j > 1 | last_quad_p -> operator.op_code ^= opt_subscript_op
	     then last_quad_p -> operator.operand (j) = effective_operand (last_quad_p -> operator.operand (j));
	     if last_quad_p -> operator.operand (j) > last_assigned_op
	     then if addr (x (last_quad_p -> operator.operand (j))) -> node.node_type = temporary_node
		     | addr (x (last_quad_p -> operator.operand (j))) -> node.node_type = array_ref_node
		then addr (x (last_quad_p -> operator.operand (j))) -> temporary.ref_count =
			addr (x (last_quad_p -> operator.operand (j))) -> temporary.ref_count + 1;
	end;

	call bump_work_stack_offset (-n_operands - 1);
	last_op_index = i;
	return (i);
     end create_operator;

create_temporary:
     proc (data_type) returns (fixed bin (18));

dcl	data_type		fixed bin (18);

/* create_temporary is called specifically to create an output temp for an already created operator
   node.  It is called with the data_type to be used for the temp.  It creates a temporary node,
   places it into the output entry of the last operator node created, and returns the offset of the
   created temporary in the x (symbol) stack.  */

	temp_index = create_node (temporary_node, size (temporary));
	temp_ptr = addr (x (temp_index));
	last_quad_p -> operator.output = temp_index;
	temp_ptr -> temporary.output_by = op_index;
	temp_ptr -> temporary.operand_type = temp_type;
	temp_ptr -> temporary.ref_count = 0;
	temp_ptr -> temporary.data_type = data_type;
	temp_ptr -> temporary.addressing_bits.not_in_storage = "1"b;
	return (temp_index);
     end create_temporary;

create_var:
     proc () returns (fixed bin (18));

dcl	var		fixed bin (18);
dcl	p		ptr;

/* create_var is called when it is necessary to produce a new compiler-generated symbol.
   It creates an unnamed integer symbol entry in the symbol table, and returns the offset
   of the created entry.  */

	allocate_symbol_name = 0;
	var = create_node (symbol_node, size (symbol));
	p = addr (x (var));
	p -> symbol.data_type = int_mode;
	p -> symbol.element_size = data_type_size (int_mode);
	p -> symbol.operand_type = variable_type;
	p -> symbol.allocate, p -> symbol.referenced, p -> symbol.set, p -> symbol.by_compiler, p -> symbol.integer,
	     p -> symbol.automatic = "1"b;

/* connect the node to the symbol chain */

	addr (x (subp_ptr -> subprogram.last_symbol)) -> symbol.next_symbol = var;
	subp_ptr -> subprogram.last_symbol = var;
	return (var);
     end create_var;

create_integer_constant:
     procedure (value) returns (fixed binary (18));

dcl	value		fixed binary (19) aligned;
dcl	bit_value		bit (72) aligned;

	bit_value = unspec (value);
	return (create_constant (int_mode, bit_value));

     end create_integer_constant;

match_index_type:
     proc ();

dcl	i		fixed bin (18);
dcl	(i_ptr, c_ptr)	ptr;

/* match_index_type is called when processing do loops, with the stack containing (<>) <do_op>
   <incr> <upper> <lower> <index_var> <...> It checks the data type of incr, upper, and lower
   against the data type of index_var, the nominal control variable.  If the data types do not
   match, it will generate an explicit conversion node to convert the errant value's data type to
   match the data_type of index_var.  The stack is in identical form upon return, except that incr,
   lower, and upper all have the same data type as index_var.  */

	c_ptr = addr (x (stack (work_stack_offset - 5)));
	do i = 2 to 4;
	     i_ptr = addr (x (stack (work_stack_offset - i)));
	     if i_ptr -> node.data_type ^= c_ptr -> node.data_type
	     then do;
		     stack (work_stack_offset) = stack (work_stack_offset - i);
		     stack (work_stack_offset + 1) = convert_to_int_op + c_ptr -> node.data_type - 1;
		     call bump_work_stack_offset (+2);
		     op_index = create_operator (1);
		     stack (work_stack_offset - i) = create_temporary ((c_ptr -> node.data_type));
		end;
	end;
	return;
     end match_index_type;

optimize_if:
     proc (if_node_p) recursive;

dcl	(if_node_p, log_op_p)
			ptr;
dcl	(inverted_if, next, next_label)
			fixed bin (18);

/* optimize_if is called from the top level program to break up if statements involving logical
   operators into a series of if_nodes each of which uses a single logical value (logical variable
   or expression involving relational operators.  This may serve to eliminate unneeded computation,
   since the if statement will take effect as soon as it is known that enough of the logical
   expression has been that any further tests would have no effect.  The basic transformations used
   are:

   jump_true(target,or(a,b)) -> jump_true(target,a), jump_true(target,b)

   jump_true(target,and(a,b)) -> jump_false(next,a), jump_true(target,b)

   jump_true(target,not(a)) -> jump_false(target,a)

   jump_false(target,and(a,b)) -> jump_false(target,a), jump_false(target,b)

   jump_false(target,or(a,b)) -> jump_true(next,a), jump_false(target,b)

   jump_false(target,not(a)) -> jump_true(target,a)

   optimize_if recurses, and will unweave any arbitrary logical expression.  */

	if if_node_p -> operator.op_code = jump_false_op
	then inverted_if = jump_true_op;
	else inverted_if = jump_false_op;

/* If the test_expression is not a temp, it was a variable.  Can't do nuttin.  */

	if addr (x (if_node_p -> operator.operand (1))) -> node.node_type ^= temporary_node
	then return;

/* Otherwise get the operator used to produce the temporary.  */

	log_op_p = addr (q (addr (x (if_node_p -> operator.operand (1))) -> temporary.output_by));

/* If the op was .not., just invert the jump sense.  */

	if log_op_p -> operator.op_code = not_op
	then do;
		if_node_p -> operator.op_code = inverted_if;
		if_node_p -> operator.operand (1) = log_op_p -> operator.operand (1);
	     end;

/* If node is a jump true on an .or., or jump false on an .and., we just split it into 2 nodes with
   the same sense jump, One based on each side of the logical operator.  The left hand side will be
   put into a new jump node created by create_new_if, which will also call optimize_if to optimize
   that branch.  The right_hand side will replace the original test_expression in the original
   jump.  */

	else if (if_node_p -> operator.op_code = jump_true_op & log_op_p -> operator.op_code = or_op)
	     | (if_node_p -> operator.op_code = jump_false_op & log_op_p -> operator.op_code = and_op)
	then do;
		call create_new_if (if_node_p, (if_node_p -> operator.op_code), (if_node_p -> operator.operand (2)),
		     (log_op_p -> operator.operand (1)));
		if_node_p -> operator.operand (1) = log_op_p -> operator.operand (2);
	     end;

/* If node is a jump true on an .and., or jump false on an .or., do the same as in last case,
   except that the new jump created for the lhs is inverted in sense from the original jump.  */

	else if (if_node_p -> operator.op_code = jump_true_op & log_op_p -> operator.op_code = and_op)
	     | (if_node_p -> operator.op_code = jump_false_op & log_op_p -> operator.op_code = or_op)
	then do;

/* Find the next executable statement, and put a label on it if necessary. */

		do next = if_node_p -> operator.next repeat (fixed (addr (q (next)) -> opt_statement.next, 18))
		     while (^addr (q (next)) -> opt_statement.put_in_map);
		end;

		if addr (q (next)) -> opt_statement.label = 0
		then addr (q (next)) -> opt_statement.label = create_label (next);
		next_label = addr (q (next)) -> opt_statement.label;
		addr (x (next_label)) -> label.referenced_executable = "1"b;
		call create_new_if (if_node_p, (inverted_if), next_label, (log_op_p -> operator.operand (1)));
		if_node_p -> operator.operand (1) = log_op_p -> operator.operand (2);
	     end;

/* If we get here, node has already been reduced as far as possible.  Just return.  */

	else return;

/* Call unchain_op to throw out the no longer needed logical operator node, and optimize_if to
   optimize the new chain created from the right_hand side of the original logical operator.  */

	call unchain_op (log_op_p);
	call optimize_if ((if_node_p));
	return;

create_label:
     proc (i) returns (fixed bin (18));

dcl	(i, j)		fixed bin (18);

/* create_label creates a label and attaches it to the opt_statement node whose offset in the quads
   is contained in i.  It returns the offset in x (the symbol area) of the label entry created.
   This second copy of create label is included for the use of the if optimizing subroutines, which
   are recursive, so that the copy used by the remainder of the converter can remain a quick
   procedure.  */

	j = create_node (label_node, size (label));
	addr (x (j)) -> label.statement = i;
	addr (x (j)) -> label.operand_type = rel_constant;
	addr (x (j)) -> label.executable, addr (x (j)) -> label.referenced, addr (x (j)) -> label.allocate,
	     addr (x (j)) -> label.set = "1"b;
	if subp_ptr -> subprogram.last_label = 0
	then subp_ptr -> subprogram.first_label = j;
	else addr (x (subp_ptr -> subprogram.last_label)) -> label.next_label = j;
	subp_ptr -> subprogram.last_label = j;
	return (j);
     end create_label;

/* This copy of create_node is used only by the if optimizing subprograms.  Giving them a separate
   copy prevents create_node from becoming non_quick when it is used everywhere else in the
   converter.  */

%include fort_create_node;
unchain_op:
     proc (op_p);

dcl	op_p		ptr;

/* unchain_op is called by the if_optimizer with a pointer to a logical operator node as its
   argument.  It removes the operator node from the quad chain, and releases its output temporary. */

	addr (q (op_p -> operator.next)) -> operator.back = op_p -> operator.back;
	addr (q (op_p -> operator.back)) -> operator.next = op_p -> operator.next;
	addr (x (op_p -> operator.output)) -> temporary.next = next_free_temp;
	next_free_temp = op_p -> operator.output;
	return;
     end unchain_op;

     end optimize_if;

create_new_if:
     proc (parent_if_p, use_jump, jump_target, expression);

dcl	(b_p, f_p, parent_if_p, ti_p, ts_p)
			ptr;
dcl	(back, expression, forward, jump_target, last_st, next_st, parent_if, ti, ts, use_jump)
			fixed bin (18);

/* create_new_if is called by optimize_if to create a new operator node for the jump being created
   from the left_hand_side of a logical expression.  It is called with a pointer to the parent if
   node, the jump type to be used, the jump target to be used, and the offset in the symbols of the
   logical variable or temporary to be tested.  It creates both the operator node, and a statement
   node.  The statement node is needed so this jump will have a proper "next" when create_new_if
   calls optimize_if for this new jump node.  A label will be generated later, only if the
   statement node is actually used as a jump target.  */

	n_operands = 2;
	ti = next_free_quad;
	ti_p = addr (q (ti));
	ts = next_free_quad + size (operator);
	ts_p = addr (q (ts));
	next_free_quad = ts + size (opt_statement);
	if next_free_quad > quad_max_len
	then call print_message (407, "quadruple_region", char (quad_max_len));

	unspec (ts_p -> opt_statement) = "0"b;
	unspec (ti_p -> operator) = "0"b;
	next_st = parent_if_p -> operator.next;
	last_st = fixed (addr (q (next_st)) -> opt_statement.back, 18);
	parent_if = addr (q (next_st)) -> opt_statement.prev_operator;

/*    rechain statement chain     */

	addr (q (last_st)) -> opt_statement.next = bit (fixed (ts, 18), 18);
	ts_p -> opt_statement.back = bit (fixed (last_st, 18), 18);
	addr (q (next_st)) -> opt_statement.back = bit (fixed (ts, 18), 18);
	ts_p -> opt_statement.next = bit (fixed (next_st, 18), 18);

/*     rechain operator chain     */

	ts_p -> operator.back = ti;
	ti_p -> operator.next = ts;
	b_p = addr (x (expression));
	if b_p -> node.node_type ^= temporary_node & b_p -> node.node_type ^= array_ref_node
	then back = last_st;
	else back = b_p -> temporary.output_by;
	b_p = addr (q (back));
	forward = b_p -> operator.next;
	f_p = addr (q (forward));
	b_p -> operator.next = ti;
	ti_p -> operator.back = back;
	f_p -> operator.back = ts;
	ts_p -> operator.next = forward;

/*     fill in nodes bit by bit     */

	ts_p -> opt_statement.op_code = stat_op;
	ts_p -> opt_statement.source_id = addr (q (last_st)) -> opt_statement.source_id;
	ts_p -> opt_statement.length = addr (q (last_st)) -> opt_statement.length;
	ts_p -> opt_statement.start = addr (q (last_st)) -> opt_statement.start;
	ts_p -> opt_statement.location = stm_ptr -> opt_statement.location;
	ts_p -> opt_statement.processed_by_converter = "1"b;
	ts_p -> opt_statement.put_in_map = "1"b;
	ts_p -> opt_statement.flow_unit, ts_p -> opt_statement.operator_list = null;

	ti_p -> operator.op_code = use_jump;
	ti_p -> operator.number = 2;
	ti_p -> operator.primary = null;
	ti_p -> operator.operand (2) = jump_target;
	ti_p -> operator.operand (1) = expression;
	call optimize_if ((ti_p));
	return;
     end create_new_if;

optimize_vector:
     proc ();

dcl	(do_position, eol_position, n_dims_used, inner_do_position, i, j, n_dims, low, high, low_value, high_value,
	vector_length, vector_length_temp)
			fixed bin (18);
dcl	(low_p, high_p, r, dim_p, symb_p)
			ptr;
dcl	(optimized_something, low_is_variable, high_is_variable, high_bounds_differ, low_bounds_differ,
	must_keep_remaining_loops)
			bit (1) aligned;


/* optimize_vector is called when a do_op is hit on the stack.  At this point the stack contains
   (<>) {<do_op or counter> <incr> <lower> <upper> <index_var>} <...>
   (In the best cases there will be more than one level of do_op nesting) optimize_vector is called
   only for implied do's in i/o ops, and by the time it is called the do_op initialization stuff is
   already in the quads.  optimize_vector attempts to convert the implied do's into xmit_vectors,
   removing as many of the nested implied do's as possible.

   NOTE: This is the one section of the converter which may actually modify the polish input.  */

/* Remember where we are */

	inner_do_position, do_position = polish_offset;

/* CHECK--transmitted item must be subscripted.  This test will also toss us out if we have not yet
   hit the most deeply nested do.  */

	if p (do_position + 3) ^= subscript_op
	then go to NO_OPT_VECTOR;

/* Get number of dimensions, and figure out where the eol should be.  */

	n_dims = p (do_position + 2) + bias;
	eol_position = do_position + 4 + n_dims * 2;

/* CHECK--subscripts must not contain expressions (quick & dirty, but effective method).  */

	if p (eol_position) ^= eol_op
	then go to NO_OPT_VECTOR;

	symb_p = addr (x (p (inner_do_position + 1)));
	dim_p = addr (x (symb_p -> symbol.dimension));

	optimized_something = "0"b;

/* initial vector length is just the element size.  final vector length will be
   vector_length*vector_length_temp.  The constant and variable parts are kept separate to enable
   maximum compile time evaluation.  */

	if symb_p -> symbol.v_length = 0
	then do;
		vector_length = symb_p -> symbol.element_size;
		vector_length_temp = 0;
	     end;
	else do;
		vector_length = 1;
		vector_length_temp = symb_p -> symbol.v_length;
	     end;

	n_dims_used = 0;

/*  Check for validity at each contained level */

	must_keep_remaining_loops = "0"b;
	do i = 1 by 1 while (^must_keep_remaining_loops);

/* if work_stack_offset < 5 there are no more do_op entries in the stack.  We're done.  */

	     if work_stack_offset < 5
	     then go to NO_MORE_DIMS;

/* if the next thing down in the stack is not a do_op we're done.  */

	     if stack (work_stack_offset - 1) ^= do_op
	     then go to NO_MORE_DIMS;

/* CHECK--the subscript must be the same variable as the do index.  */

	     if p (inner_do_position + 2 + i * 2) ^= stack (work_stack_offset - 5)
	     then go to NO_MORE_DIMS;

/* CHECK--the increment must be a constant integer 1--at this point we know that this also means
   the index_var and upper and lower bounds are integer, since match_index_type was called before
   we were.  */

	     if stack (work_stack_offset - 2) ^= one
	     then go to NO_MORE_DIMS;

/* CHECK--the array item must be the only item in the list at this level.  */

	     if p (eol_position + 1 + i) ^= exit_op | exit_stack.xmit_at_this_level ^= 0
	     then go to NO_MORE_DIMS;

/* CHECK--this subscript must not be aliasable with any of the remaining subscripts */

	     do j = i + 1 to n_dims;
		if aliasable (p (inner_do_position + 2 + i * 2), p (inner_do_position + 2 + j * 2))
		then go to NO_MORE_DIMS;
	     end;

/* CHECK--contained do's must cover complete dimension--if that's true of this dimension, we'll
   keep going in this loop.  If not true of this dimension, we'll branch to ONE_MORE_DIM to see if
   this partial dimension can be taken out.  */

	     low = stack (work_stack_offset - 4);
	     high = stack (work_stack_offset - 3);
	     low_p = addr (x (low));
	     high_p = addr (x (high));

/* If we got this far, we're gonna take this level of implied do out.  */

	     optimized_something = "1"b;

/* If upper is not a constant, then it was output by an assign generated to make a frozen_for_do
   temp.  In that case we can pitch the assign_op node and the associated temp, and set high to be
   the original value before that assign was generated.  If the new high is a temp or array_ref,
   the assign would have caused its ref_count to be bumped, so we gotta decrement it.  */

	     if high_p -> node.node_type ^= constant_node
	     then do;
		     r = addr (q (high_p -> temporary.output_by));
		     if r -> operator.next ^= 0
		     then addr (q (r -> operator.next)) -> operator.back = r -> operator.back;
		     else do;
			     last_quad_p = addr (q (r -> operator.back));
			     last_op_index, op_index = r -> operator.back;
			     next_free_quad = last_quad_p -> operator.next;
			end;
		     addr (q (r -> operator.back)) -> operator.next = r -> operator.next;
		     high_p -> temporary.next = next_free_temp;
		     next_free_temp = high;
		     stack (work_stack_offset - 3), high = r -> operator.operand (1);
		     high_p = addr (x (high));
		     if high_p -> node.node_type = temporary_node | high_p -> node.node_type = array_ref_node
		     then high_p -> temporary.ref_count = high_p -> temporary.ref_count - 1;
		end;

/* Take out this level of implied do-loop.  The variables to watch are low_p
   and high_p, pointers to the symbol nodes for the lower and upper bounds,
   respectively, and low_value and high_value, which contain the bound values
   themselves if the corresponding bounds are constant.  The variables
   low_is_variable and high_is_variable serve as flags to indicate whether the
   bounds are constant or variable.  The tricky part is that we want to
   minimize run_time code -- the length used from this dim will be
   (high-low)+1, but we will compute it as either (high+1)-low or high-(low-1)
   if high or low is constant.  Have to take care not to do both (high+1) and
   (low-1) if both are constant.

   If the low or high bound of the implied do-loop is not the same as the
   corresponding array bound, this implied loop either does not or might not
   cover the entire dimension and we must set 'must_keep_remaining_loops'.  */

	     low_bounds_differ = "0"b;
	     if low_p -> node.node_type ^= constant_node
	     then do;
		     low_is_variable = "1"b;
		     low_value = 0;
		     if low ^= dim_p -> dimension.lower_bound (i)
		     then low_bounds_differ = "1"b;
		end;
	     else do;
		     low_is_variable = "0"b;
		     unspec (low_value) = low_p -> constant.value;
		     if dim_p -> dimension.v_bound (i).lower | dim_p -> dimension.lower_bound (i) ^= low_value
		     then do;
			     low_bounds_differ = "1"b;
			     if ^valid_subscript (dim_p, i, low_value)
			     then call print_message (422, low, stack (work_stack_offset - 5));
			end;
		end;

	     high_bounds_differ = "0"b;
	     if high_p -> node.node_type ^= constant_node
	     then do;
		     high_is_variable = "1"b;
		     high_value = 0;
		     if high ^= dim_p -> dimension.upper_bound (i)
		     then high_bounds_differ = "1"b;
		end;
	     else do;
		     high_is_variable = "0"b;
		     unspec (high_value) = high_p -> constant.value;
		     if dim_p -> dimension.v_bound (i).upper | dim_p -> dimension.upper_bound (i) ^= high_value
		     then do;
			     high_bounds_differ = "1"b;
			     if ^valid_subscript (dim_p, i, high_value)
			     then call print_message (422, high, stack (work_stack_offset - 5));
			end;
		end;

	     if low_bounds_differ | high_bounds_differ
	     then must_keep_remaining_loops = "1"b;

/* If both bounds are constants, we'll just do the calculation of vector length here.  */

	     if ^low_is_variable & ^high_is_variable
	     then vector_length = vector_length * (high_value - low_value + 1);

/* otherwise, move the high node into the stack.  If high_value is constant, add one before
   creating the constant node.  Then, move the low node into the stack.  If low_value is constant
   we'll subtract one before creating the constant node, unless high was also constant (shouldn't
   happen, but better to test).  generate a sub_op node to take the difference.  If both high and
   low were non-constant values, have to generate an explicit add of one.  Finally, if there is
   already a vector length temp part, generate a mult node to multiply it in.  Take the result and
   stuff it into vector_length_temp, bump the count of dimensions removed, set the appropriate
   array_ref subscript in the polish to the lower bound for later origin calculation, and call
   unthread_do to pop the exit_stack, take the do entry off the work stack, and throw out any quads
   that were generated in the do initialization for this do.  */

	     else do;
		     if ^high_is_variable
		     then do;
			     high_value = high_value + 1;
			     stack (work_stack_offset) = create_integer_constant ((high_value));
			end;
		     else stack (work_stack_offset) = high;
		     if low_is_variable | low_value ^= 1
		     then do;
			     if low_is_variable
			     then stack (work_stack_offset + 1) = low;
			     else do;
				     if high_is_variable
				     then low_value = low_value - 1;
				     stack (work_stack_offset + 1) = create_integer_constant ((low_value));
				     if high_is_variable
				     then low_value = low_value + 1;
				end;
			     stack (work_stack_offset + 2) = sub_op;
			     call bump_work_stack_offset (+3);
			     call process_arith ("0"b);
			     call bump_work_stack_offset (-1);
			end;

		     if low_is_variable & high_is_variable
		     then do;
			     stack (work_stack_offset + 1) = one;
			     stack (work_stack_offset + 2) = add_op;
			     call bump_work_stack_offset (+3);
			     call process_arith ("0"b);
			     call bump_work_stack_offset (-1);
			end;

		     if vector_length_temp ^= 0
		     then do;
			     stack (work_stack_offset + 1) = vector_length_temp;
			     stack (work_stack_offset + 2) = mult_op;
			     call bump_work_stack_offset (+3);
			     call process_arith ("0"b);
			     call bump_work_stack_offset (-1);
			end;
		     vector_length_temp = stack (work_stack_offset);
		end;
	     n_dims_used = n_dims_used + 1;
	     p (inner_do_position + 2 + n_dims_used * 2) = low;
	     call unthread_do;
	end;

/* If we haven't accomplished anything really, just go away. */

NO_MORE_DIMS:
	if ^optimized_something
	then go to NO_OPT_VECTOR;

/* Now we reduce vector_length*vector_length_temp to a single temporary node which goes back into
   vector_length_temp.  Take care not to generate any unneeded ops, though.  */

	if vector_length ^= 1
	then do;
		stack (work_stack_offset) = create_integer_constant ((vector_length));
		if vector_length_temp ^= 0
		then do;
			stack (work_stack_offset + 1) = vector_length_temp;
			stack (work_stack_offset + 2) = mult_op;
			call bump_work_stack_offset (+3);
			call process_arith ("0"b);
			call bump_work_stack_offset (-1);
		     end;
		vector_length_temp = stack (work_stack_offset);
	     end;

/* Back polish_offset up a bit for safety.  Otherwise we might overwrite something we haven't
   processed yet.  5 is a safe number, since we've eliminated at least 1 do op, which used at least
   5 polish entries.  */

	polish_offset = polish_offset - 5;

/* Finally we create a proper polish xmit_vector_op entry.  If we took out all the dimensions
   and if the last loop we took out started at the first element of that dimension, we can discard
   the array ref stuff and just use the array; otherwise move the array ref stuff, which has
   been changed from it's original form to now represent the origin for the xmit_vector, towards
   the beginning of the polish stack.  Put in the length temp and an xmit_vector_op following it.
   Finally, an increment_polish to skip over an appropriate number of eliminated exit_ops.  On
   return, we'll go back and run across this new stuff and just pretend the parse put it there.  */

	if n_dims_used = dim_p -> dimension.number_of_dims & ^low_bounds_differ
	then j = 1;
	else j = n_dims * 2 + 4;
	do i = 1 to j;
	     p (polish_offset + i) = p (inner_do_position + i);
	end;
	p (polish_offset + i) = vector_length_temp;
	i = i + 1;
	p (polish_offset + i) = xmit_vector_op;
	i = i + 1;
	if exit_offset ^= 0
	then if exit_stack.op = do_op
	     then exit_stack.xmit_at_this_level = exit_stack.xmit_at_this_level + 1;
	p (polish_offset + i) = increment_polish_op;
	p (polish_offset + i + 1) = eol_position + n_dims_used - polish_offset - i;

NO_OPT_VECTOR:
	return;

unthread_do:
     proc ();

dcl	st		fixed bin (18);
dcl	(a, o)		ptr;

/* unthread_do is called by optimize_vector to remove no longer needed do initialization code.
   If exit_stack.ptr is nonnull, it points to an assign_op followed by an opt_statement node,
   both of which will be freed.  If exit_stack.zero_trip_branch is nonzero, there are three
   items between the assign_op and the opt_statement: a comparison of some sort, a
   jump_false operator, and an opt_statement node.  These will also be freed.
   Whether or not there are any operators to be freed, unthread_do pops the exit stack and
   replaces one level of DO on the work stack by an assignment to the loop index of the final
   loop value plus one. */

	if exit_stack.ptr ^= null ()
	then do;

/* unthread the assign_op */

		a = exit_stack.ptr;
		call unthread (a);
		o = addr (x (a -> operator.operand (1)));
		if o -> node.node_type = temporary_node | o -> node.node_type = array_ref_node
		then o -> temporary.ref_count = o -> temporary.ref_count - 1;

		a = addr (q (a -> operator.next));

		if exit_stack.zero_trip_branch ^= 0
		then do;

/* unthread the comparison operator */

			call unthread (a);
			addr (x (a -> operator.output)) -> temporary.next = next_free_temp;
			next_free_temp = a -> operator.output;

			a = addr (q (a -> operator.next));

/* unthread the jump_false operator */

			call unthread (a);

			a = addr (q (a -> operator.next));

/* unthread the inner opt_statement node */

			call unthread (a);
			st = fixed (a -> opt_statement.back, 18);
			addr (q (st)) -> opt_statement.next = a -> opt_statement.next;
			st = fixed (a -> opt_statement.next, 18);
			addr (q (st)) -> opt_statement.back = a -> opt_statement.back;

			a = addr (q (a -> opt_statement.first_operator));

		     end;

/* unthread the final opt_statement node */

		st = fixed (a -> opt_statement.back, 18);
		addr (q (st)) -> opt_statement.next = a -> opt_statement.next;
		opst, last_opt_statement = addr (q (st));
		addr (x (a -> opt_statement.label)) -> label.statement = 0;
		if a -> opt_statement.first_operator = 0
		then do;
			last_op_index, op_index = a -> opt_statement.prev_operator;
			last_quad_p = addr (q (op_index));
			next_free_quad = last_quad_p -> operator.next;
			last_quad_p -> operator.next = 0;
		     end;
		else do;
			addr (q (a -> opt_statement.prev_operator)) -> operator.next =
			     a -> opt_statement.first_operator;
			addr (q (a -> opt_statement.first_operator)) -> operator.back =
			     a -> opt_statement.prev_operator;
		     end;
	     end;

	call pop_exit_stack ();

/* The stack is now (<>) <dp_op> <incr> <upper> <lower> <index var> <...>.
   Change it to (<>) <add_op> <upper> <one> <index var> <...> and process
   the add, leaving (<>) <sum> <index var> <...>.  Change that to (<>)
   <assign_op> <sum> <index var> <...>.  Process the assignment, leaving
   (<>) <...> and return. */

	call bump_work_stack_offset (-1);		/* Discard <do_op>. */
	stack (work_stack_offset - 1) = add_op;		/* Replace <incr> with <add_op>. */
	stack (work_stack_offset - 3) = one;		/* Replace <lower> with <one>. */
	call process_arith ("0"b);			/* Replace <add_op> <upper> <one> by its <sum>. */
	stack (work_stack_offset) = assign_op;
	call bump_work_stack_offset (+1);
	call process_assign;
	return;

unthread:
     procedure (op);

dcl	op		pointer;

/* unthread is called by unthread_do to remove a single operator from the quad chain.
   It is assumed that the operator is not at the end of the chain. */

	addr (q (op -> operator.next)) -> operator.back = op -> operator.back;
	addr (q (op -> operator.back)) -> operator.next = op -> operator.next;
	return;

     end unthread;

     end unthread_do;

aliasable:
     proc (offset1, offset2) returns (bit (1) aligned);

dcl	offset1		fixed bin (18),
	offset2		fixed bin (18);
dcl	p1		ptr,
	p2		ptr;

/* aliasable is called with the symbol table offsets of two variables or temps.  it returns "1"b if
   the two may be aliases of the same storage, "0"b otherwise.  */

	if offset1 = offset2
	then return ("1"b);
	p1 = addr (x (offset1));
	p2 = addr (x (offset2));
	if p2 -> node.node_type ^= symbol_node
	then return ("0"b);
	if ^p1 -> symbol.equivalenced & ^p1 -> symbol.parameter
	then return ("0"b);
	if ^p2 -> symbol.equivalenced & ^p2 -> symbol.parameter
	then return ("0"b);
	return ("1"b);
     end aliasable;

valid_subscript:
     procedure (dim_p, dim_no, value) returns (bit (1) aligned);

/* valid_subscript checks value to see if it is a valid subscript value for
   dimension dim_no of the array described by the dimension node pointed to
   by dim_p.  If the value is known to fall outside the legal range, "0"b is
   returned.  In all other cases, "1"b is returned. */

dcl	dim_p		pointer;
dcl	(dim_no, i)	fixed binary (18);
dcl	value		fixed binary (18);

	i = dim_no;

	if ^dim_p -> dimension.v_bound (i).lower
	then if value < dim_p -> dimension.lower_bound (i)
	     then return ("0"b);

	if ^dim_p -> dimension.v_bound (i).upper
	then if value > dim_p -> dimension.upper_bound (i)
	     then return ("0"b);

	return ("1"b);

     end valid_subscript;

     end optimize_vector;

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 (x (op));
		if p -> node.node_type = label_node
		then if p -> label.format
		     then do;
			     op = p -> label.format_var;
			     p = addr (x (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 fort_converter;




		    fort_data.cds                   12/27/84  0834.4r w 12/27/84  0751.7       93798



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

/* format: style3,^delnl,linecom */
fort_data:
     procedure;

/* This procedure exists in order to create the builtin function data base for
   the fortran optimizing compiler.  It is based on an earlier version by
   Jayne Keller.

Written:	04 Apr 78, PES

Modified:
	22 Jun 84, MHM -- Install typeless functions support.
	28 Oct 80, CRD -- Add rest of Fortran 77 intrinsics.
	26 Dec 79, PES -- Add new ANSI77 character-string diddling functions.
*/

dcl	create_data_segment_
			ext entry (ptr, fixed bin (35) aligned);
dcl	com_err_		entry options (variable);
dcl	1 cdsa		like cds_args aligned;
dcl	(get_temp_segments_, release_temp_segments_)
			entry (char (*), (*) ptr, fixed bin (35));
dcl	cleanup		condition;
dcl	code		fixed bin (35);
dcl	myname		char (12) init ("fort_data") static internal options (constant);
dcl	segptrs		(1) ptr init (null ());

dcl	addr		builtin;
dcl	hbound		builtin;

dcl	(
	intr		init (1),
	real		init (2),
	dp		init (3),
	cmpx		init (4),
	logical		init (5),
	character		init (6),
	typeless		init (7)
	)		internal static options (constant) fixed bin;

dcl	(i, abs, alog, alog10, amax1, amin1, amod, atan, atan2, cabs, ccos,
	cexp, cchar, clog, cos, cosh, csin, csqrt, dabs, datan, tan, dtan,
	dtanh, asin, dasin, acos, dacos, datan2, dcos, dcosh, ddim, dexp,
	dim, dlog, dlog10, dmax1, dmin1, dmod, dsign, dsin, dsinh, dsqrt,
	exp, iabs, ichar, idim, iindex, isign, len, lge, lgt, lle, llt, max,
	max0, min, min0, mod, sign, sin, sinh, sqrt, tanh, aint, dint,
	anint, dnint, nint, idnint, and, bool, compl, fld, ilr, ils, irl,
	irs, or, xor
	)		fixed bin;

%include cds_args;

/* The structure fort_data$ explains to the compiler about all acceptable
   builtin functions, both internal and external.  The fields have the
   following meanings:

   generic_name - On if this is the name of a generic function.

   generic_func - An array of indices referencing this table. One entry for
   each data type. A zero entry indicates no builtin for that data type.

   result_type - Specify attributes for result.
*/
dcl	p		ptr;

dcl	1 fort_data	based (p),
	  2 builtin_name,
	    3 number_of_names
			fixed bin (15),
	    3 description	(93),
	      4 name	char (8) aligned,
	      4 generic_name
			bit (1) unaligned,
	      4 reserved	bit (35) unaligned,
	      4 generic_func
			(4) fixed bin,
	      4 result_type fixed bin;

	on cleanup
	     call release_temp_segments_ (myname, segptrs, (0));
	call get_temp_segments_ (myname, segptrs, code);
	if code ^= 0
	then do;
		call com_err_ (code, myname, "Getting temp segments");
		return;
	     end;

	p = segptrs (1);

/* Initialize and create the data base. */

	i = 0;

	call build_entry ("abs     ", real);
	abs = i;
	call build_entry ("iabs    ", intr);
	iabs = i;
	call build_entry ("dabs    ", dp);
	dabs = i;
	call build_entry ("cabs    ", real);
	cabs = i;
	call build_entry ("alog    ", real);
	alog = i;
	call build_entry ("dlog    ", dp);
	dlog = i;
	call build_entry ("clog    ", cmpx);
	clog = i;
	call build_entry ("alog10  ", real);
	alog10 = i;
	call build_entry ("dlog10  ", dp);
	dlog10 = i;
	call build_entry ("atan    ", real);
	atan = i;
	call build_entry ("datan   ", dp);
	datan = i;
	call build_entry ("atan2   ", real);
	atan2 = i;
	call build_entry ("datan2  ", dp);
	datan2 = i;
	call build_entry ("cos     ", real);
	cos = i;
	call build_entry ("dcos    ", dp);
	dcos = i;
	call build_entry ("ccos    ", cmpx);
	ccos = i;
	call build_entry ("dim     ", real);
	dim = i;
	call build_entry ("idim    ", intr);
	idim = i;
	call build_entry ("ddim    ", dp);
	ddim = i;
	call build_entry ("exp     ", real);
	exp = i;
	call build_entry ("dexp    ", dp);
	dexp = i;
	call build_entry ("cexp    ", cmpx);
	cexp = i;
	call build_entry ("max     ", real);
	max = i;
	call build_entry ("amax0   ", real);
	call build_entry ("amax1   ", real);
	amax1 = i;
	call build_entry ("max0    ", intr);
	max0 = i;
	call build_entry ("max1    ", intr);
	call build_entry ("dmax1   ", dp);
	dmax1 = i;
	call build_entry ("min     ", real);
	min = i;
	call build_entry ("amin0   ", real);
	call build_entry ("amin1   ", real);
	amin1 = i;
	call build_entry ("min0    ", intr);
	min0 = i;
	call build_entry ("min1    ", intr);
	call build_entry ("dmin1   ", dp);
	dmin1 = i;
	call build_entry ("mod     ", intr);
	mod = i;
	call build_entry ("amod    ", real);
	amod = i;
	call build_entry ("dmod    ", dp);
	dmod = i;
	call build_entry ("sign    ", real);
	sign = i;
	call build_entry ("isign   ", intr);
	isign = i;
	call build_entry ("dsign   ", dp);
	dsign = i;
	call build_entry ("sin     ", real);
	sin = i;
	call build_entry ("dsin    ", dp);
	dsin = i;
	call build_entry ("csin    ", cmpx);
	csin = i;
	call build_entry ("sqrt    ", real);
	sqrt = i;
	call build_entry ("dsqrt   ", dp);
	dsqrt = i;
	call build_entry ("csqrt   ", cmpx);
	csqrt = i;
	call build_entry ("tanh    ", real);
	tanh = i;
	call build_entry ("int     ", intr);
	call build_entry ("aint    ", real);
	aint = i;
	call build_entry ("idint   ", intr);
	call build_entry ("float   ", real);
	call build_entry ("ifix    ", intr);
	call build_entry ("sngl    ", real);
	call build_entry ("real    ", real);
	call build_entry ("aimag   ", real);
	call build_entry ("dble    ", dp);
	call build_entry ("cmplx   ", cmpx);
	call build_entry ("conjg   ", cmpx);
	call build_entry ("tan     ", real);
	tan = i;
	call build_entry ("dtan    ", dp);
	dtan = i;
	call build_entry ("asin    ", real);
	asin = i;
	call build_entry ("dasin   ", dp);
	dasin = i;
	call build_entry ("acos    ", real);
	acos = i;
	call build_entry ("dacos   ", dp);
	dacos = i;
	call build_entry ("char    ", character);
	cchar = i;
	call build_entry ("ichar   ", intr);
	ichar = i;
	call build_entry ("index   ", intr);
	iindex = i;
	call build_entry ("len     ", intr);
	len = i;
	call build_entry ("lge     ", logical);
	lge = i;
	call build_entry ("lgt     ", logical);
	lgt = i;
	call build_entry ("lle     ", logical);
	lle = i;
	call build_entry ("llt     ", logical);
	llt = i;
	call build_entry ("cosh    ", real);
	cosh = i;
	call build_entry ("sinh    ", real);
	sinh = i;
	call build_entry ("dcosh   ", dp);
	dcosh = i;
	call build_entry ("dsinh   ", dp);
	dsinh = i;
	call build_entry ("dtanh   ", dp);
	dtanh = i;
	call build_entry ("dint    ", dp);
	dint = i;
	call build_entry ("anint   ", real);
	anint = i;
	call build_entry ("dnint   ", dp);
	dnint = i;
	call build_entry ("nint    ", intr);
	nint = i;
	call build_entry ("idnint  ", intr);
	idnint = i;
	call build_entry ("dprod   ", dp);
	and = i;
	call build_entry ("and     ", typeless);
	bool = i;
	call build_entry ("bool    ", typeless);
	compl = i;
	call build_entry ("compl   ", typeless);
	fld = i;
	call build_entry ("fld     ", typeless);
	ilr = i;
	call build_entry ("ilr     ", intr);
	ils = i;
	call build_entry ("ils     ", intr);
	irl = i;
	call build_entry ("irl     ", intr);
	irs = i;
	call build_entry ("irs     ", intr);
	or = i;
	call build_entry ("or      ", typeless);
	xor = i;
	call build_entry ("xor     ", typeless);

	p -> fort_data.number_of_names = i;

/* format: off */
/* Define the generic functions. */
/*			name	int	real	dp	complex */

	call create_generic (abs,	iabs,	abs,	dabs,	cabs);
	call create_generic (alog,	alog,	alog,	dlog,	clog);
	call create_generic (alog10,	alog10,	alog10,	dlog10,	0);
	call create_generic (atan,	0,	atan,	datan,	0);
	call create_generic (atan2,	0,	atan2,	datan2,	0);
	call create_generic (cos,	cos,	cos,	dcos,	ccos);
	call create_generic (dim,	idim,	dim,	ddim,	0);
	call create_generic (exp,	exp,	exp,	dexp,	cexp);
	call create_generic (max,	max0,	amax1,	dmax1,	0);
	call create_generic (min,	min0,	amin1,	dmin1,	0);
	call create_generic (mod,	mod,	amod,	dmod,	0);
	call create_generic (sign,	isign,	sign,	dsign,	0);
	call create_generic (sin,	sin,	sin,	dsin,	csin);
	call create_generic (sqrt,	sqrt,	sqrt,	dsqrt,	csqrt);
	call create_generic (tanh,	tanh,	tanh,	dtanh,	0);
	call create_generic (tan,	tan,	tan,	dtan,	0);
	call create_generic (asin,	asin,	asin,	dasin,	0);
	call create_generic (acos,	acos,	acos,	dacos,	0);
	call create_generic (cosh,	cosh,	cosh,	dcosh,	0);
	call create_generic (sinh,	sinh,	sinh,	dsinh,	0);
	call create_generic (aint,	aint,	aint,	dint,	0);
	call create_generic (anint,	anint,	anint,	dnint,	0);
	call create_generic (nint,	nint,	nint,	idnint,	0);

/* format: on */

build_entry:
     procedure (name, result_mode);
dcl	name		char (8) aligned,
	result_mode	fixed bin;

	i = i + 1;

	if i > hbound (p -> fort_data.description, 1)
	then do;
		call com_err_ (0, myname, "Builtin table overflow.");
		go to ABORT;
	     end;

	unspec (p -> fort_data.description (i)) = "0"b;
	p -> fort_data.description (i).name = name;
	p -> fort_data.description (i).result_type = result_mode;

     end build_entry;


/* this sets up the generic functions as needed. */
create_generic:
     proc (table_offset, int_func_offset, real_func_offset, dp_func_offset, complx_func_offset);
dcl
	(table_offset, int_func_offset, real_func_offset, dp_func_offset, complx_func_offset)
			fixed bin;

	p -> fort_data.description (table_offset).generic_name = "1"b;
	p -> fort_data.description (table_offset).generic_func (intr) = int_func_offset;
	p -> fort_data.description (table_offset).generic_func (real) = real_func_offset;
	p -> fort_data.description (table_offset).generic_func (dp) = dp_func_offset;
	p -> fort_data.description (table_offset).generic_func (cmpx) = complx_func_offset;
     end;

/* now call create_data_segment_ */

	unspec (cdsa) = "0"b;
	cdsa.have_text = "1"b;
	cdsa.sections (1).p = p;
	cdsa.sections (1).len = divide (length (unspec (fort_data)), 36, 17, 0);
	cdsa.sections (1).struct_name = "fort_data";
	cdsa.seg_name = myname;

	call create_data_segment_ (addr (cdsa), code);
	if code ^= 0
	then
	     call com_err_ (code, myname, "Creating ^a data segment", myname);

ABORT:
	call release_temp_segments_ (myname, segptrs, (0));

     end fort_data;




		    fort_defaults_.pl1              08/06/87  1146.7rew 08/06/87  1045.0      931419



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1987 *
        *                                                         *
        * Copyright, (C) Honeywell Limited, 1983                  *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 468.
  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 473, 478, and 480.
  3) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen),
     install(87-08-06,MR12.1-1069):
     Implemented SCR 6315: Added a fortran runtime error-handler argument.
                                                   END HISTORY COMMENTS */


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

/* Created:	June 1983, Michael Mabey

   Modified:
          12 May 87, RW SCP 6315 added control args -debug_io (-dbio)
                    and -no_debug_io (-ndbio)
	19 Feb 86, BW & AG - 473.a: Fix vla_auto, vla_static,
		very_large_common, la_auto, and la_static control
		arguments so they work in the following manner:
		 o vla => vla_auto, vla_static, vlc, la_auto, la_static
		   and vla_parm (unless no_vla_parm is specified)
		 o la => la_auto, la_static
		 o vla_auto | vla_static | vlc => vla_parm (unless 
		   no_vla_parm is specified)
		 o nvla disables all vla type arguments (except vla_parm
		   when vla_parm is specified) and leaves on all la type
		   arguments that are directly set.
		 o nla disables all la type arguments
		 o vla_auto => la_auto
		 o vla_static => la_static
		Move code to set maximum array sizes from
		fort_defaults_$check_global_args to ext_parse so the
		values are set properly.
	11 Dec 85, BW - 480: Check for full_optimize before setting
		subscriptrange, stringrange, and check_multiply in ansi77.
          27 Nov 85, SH - 478: Allows "-severity N" as well as "-severityN"
	09 Oct 85, BW - 473: Add vla_auto, vla_static, very_large_common,
		la_auto, and la_static control arguments.  This causes
		the following implications:
		 o vla => vla_auto, vla_parm, vla_static, vlc,
			la_auto, la_static
		 o la => la_auto, la_static
		 o vla_auto | vla_static | vlc => vla_parm
		 o nvla disables all vla type arguments that are set but
		   leaves on all la type arguments that are set.
		   Thus -vla -nvla (in this order only) => -la
		 o nla disables all la type arguments that are set
		 o whenever vla_auto is set, la_auto must be set
		 o whenever vla_static is set, la_static must be set
	12 Sept 85, BW - 468: Indicate use of "-no_auto_zero" in listing
		header.
	05 Oct 84, MM - hfp_acs: To check if a user has access to use
		HFP mode, add a dummy call to a fort_hfp_math routine
		if the "hfp" user option is specified.
          03 Aug 84, BW - 434: Allow option names of up to 32 characters.
	28 Mar 84, MM - Install HFP support.
	24 Oct 83, MM - 409: Prevent -nstrg and -nsubrg from giving an
		"incompatible args" error message when used with -optimize
	19 Sept 83, MM - 403: Fix defaulting to table if brief_table is
		specified.
*/

/* format: off */

/* Although the length of "names" is 33 in the following structure, the
   individual option names must never exceed 32 characters. */

dcl   cmd2_string_ptr	ptr;
dcl   cmd2_string_len	fixed bin(21);
dcl   code		fixed bin(35);

dcl  	01 cmd_names aligned static options (constant),
	   02 space char(1) unaligned init(" "),
	   02 names (111) char(33) unaligned init(
	"ansi66",					/* 1 */
	"ansi77",					/* 2 */
	"auto",					/* 3 */
	"auto_zero",				/* 4 */
	"binary_floating_point", "bfp",		/* 5, 6 */
	"brief", "bf",				/* 7, 8 */
	"brief_table", "bftb",			/* 9, 10 */
	"card",					/* 11 */
	"check", "ck",				/* 12, 13 */
	"check_multiply", "ckmpy",			/* 14, 15 */
	"consolidate", "cons",			/* 16, 17 */
	"debug", "db",				/* 18, 19 */
	"debug_cg",				/* 20 */
          "debug_io", "dbio",                               /* 21, 22 */
	"default_full", "dff",			/* 23, 24 */
	"default_safe", "dfs",			/* 25, 26*/
	"fold",					/* 27 */
	"free",					/* 28 */
	"full_optimize", "full_ot",			/* 29, 30 */
	"hexadecimal_floating_point", "hfp",		/* 31, 32 */
	"la_auto",				/* 33 */
	"la_static",				/* 34 */
	"large_array", "la",			/* 35, 36 */
	"line_numbers", "ln",			/* 37, 38 */
	"list", "ls",				/* 39, 40 */
	"long", "lg",				/* 41, 42 */
	"long_profile", "lpf",			/* 43, 44 */
	"map",					/* 45 */
	"nlno",					/* 46 */
	"no_auto_zero",				/* 47 */
	"no_check", "nck",				/* 48, 49 */
	"no_check_multiply", "nckmpy",		/* 50, 51 */
          "no_debug_io", "ndbio",                           /* 52, 53 */
	"no_fold",				/* 54 */
	"no_large_array", "nla",			/* 55, 56 */
	"no_line_numbers", "nln",			/* 57, 58 */
	"no_map",					/* 59 */
	"no_optimize", "not",			/* 60, 61 */
	"no_stringrange", "nstrg", "nostrg",		/* 62, 63, 64 */
	"no_subscriptrange", "nsubrg", "nosubrg",	/* 65, 66, 67 */
	"no_table", "ntb",				/* 68, 69 */
	"no_version",				/* 70 */
	"no_very_large_array", "nvla",		/* 71, 72 */
	"no_vla_parm",				/* 73 */
	"non_relocatable", "nrlc",			/* 74, 75 */
	"optimize", "ot",				/* 76, 77 */
	"profile", "pf",				/* 78 79 */
	"relocatable", "rlc",			/* 80, 81 */
	"round",					/* 82 */
	"safe",					/* 83 */
	"safe_optimize", "safe_ot",			/* 84, 85 */
	"source", "sc",				/* 86, 87 */
	"static",					/* 88 */
	"stringrange", "strg",			/* 89, 90 */
	"subscriptrange", "subrg",			/* 91, 92 */
	"super",					/* 93 */
	"symbols", "sb",				/* 94, 95 */
	"table", "tb",				/* 96, 97 */
	"time", "tm",				/* 98, 99 */
	"time_ot",				/* 100 */
	"top_down",				/* 101 */
	"truncate", "tc",				/* 102, 103 */
	"version",				/* 104 */
	"very_large_array", "vla",			/* 105, 106 */
	"very_large_common", "vlc",			/* 107, 108 */
	"vla_auto",				/* 109 */
	"vla_parm",				/* 110 */
	"vla_static");				/* 111 */
/* format: on */

/* parameters */

dcl	arg_error		aligned bit (1);
dcl	arg_fd_ptr	ptr;
dcl	arg_num		fixed bin;
dcl	arg_list_ptr	ptr;
dcl	auto_option	bit (1) aligned;
dcl	cmd_string_len	fixed bin;
dcl	cmd_string_ptr	ptr;
dcl	fd_ptr		ptr;
dcl	fixed_24		fixed bin (24);
dcl	fo_ptr		ptr;
dcl	fort_op_ptr	ptr;
dcl	global_fd_ptr	ptr;
dcl	global_fo_ptr	ptr;
dcl	op_string		char (256) varying;
dcl	print_message	entry variable options (variable);
dcl	01 shared_vars	aligned like fort_shared_variables based (shared_var_ptr);
dcl	shared_var_ptr	ptr;
dcl	static_option	bit (1) aligned;
dcl	VLA_words_per_seg	fixed bin (19);

/* automatic */

dcl	01 arg_fd		based (arg_fd_ptr) like fortran_declared;
dcl	cmd		fixed bin;
dcl	cmd_string	based (cmd_string_ptr) char (cmd_string_len);
dcl	cmd2_string	based (cmd2_string_ptr) char (cmd2_string_len);
dcl	dummy_var		bit (72);
dcl	01 fd		based (fd_ptr) like fortran_declared;
dcl	01 fo		based (fo_ptr) like fortran_options;
dcl	01 fort_op	structure based (fort_op_ptr),
	  02 user_options	aligned like fortran_options,
	  02 system_options aligned,
	    03 is_fast	bit (1) unaligned,
	    03 not_needed	bit (2) unaligned,
	    03 VLA_is_256K	bit (1) unaligned,
	    03 pad	bit (32) unaligned;
dcl	01 global_fd	based (global_fd_ptr) like fortran_declared;
dcl	01 global_fo	based (global_fo_ptr) like fortran_options;
dcl	i		fixed bin;

/* builtins */

dcl	(convert, ltrim, substr)
			builtin;
dcl	cannot_enable_HFP_mode
			condition;

/* external */

dcl	com_err_		entry options (variable);
dcl	error_table_$badopt fixed bin (35) ext static;
dcl	fort_bfp_math$conv_r_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_r_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_r_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_r_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_r_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_cp_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_i_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_r_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_dp_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_bfp_math$binop_i_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_bfp_math$binop_i_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_cp_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_dp_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_r_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_i_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_bfp_math$comp_i_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_r_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_r_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_i_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_dp_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_dp_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_dp_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_r_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_i_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_cp_cp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_bfp_math$bad_data_types
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$unary_bad_data
			ext entry (bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_bfp_math$binop_lg_lg
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$binop_ch_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_lg_lg
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$comp_ch_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$conv_ch_to_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_bfp_math$unary_no_op
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_i_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_r_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_dp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_cp_round
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_i_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_r_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_cp_to_dp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_i_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_r_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_dp_to_cp_trunc
			ext entry (bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_hfp_math$binop_i_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_i_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_r_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_dp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_cp_round
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_hfp_math$binop_i_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_i_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_r_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_dp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_cp_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_dp_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_r_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_i_cp_trunc
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_hfp_math$comp_i_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_r_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_r_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_i_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_dp_i
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_dp_r
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_dp_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_r_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_i_dp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_cp_cp
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_hfp_math$bad_data_types
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$unary_bad_data
			ext entry (bit (72), fixed bin (35)) returns (bit (72));

dcl	fort_hfp_math$binop_lg_lg
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$binop_ch_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_lg_lg
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$comp_ch_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$conv_ch_to_ch
			ext entry (fixed bin (35), bit (72), bit (72), fixed bin (35)) returns (bit (72));
dcl	fort_hfp_math$unary_no_op
			ext entry (bit (72), fixed bin (35)) returns (bit (72));
dcl	cu_$arg_ptr_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);


/* include files */

%include fort_options;
dcl	01 fort_shared_variables
			structure aligned,
%include fort_shared_vars;

	return;					/* illegal entry */

argument:
     entry (cmd_string_ptr, cmd_string_len, arg_num, arg_list_ptr, fd_ptr, arg_error);
	begin;

dcl	arg_case		(0:111) label variable init (arg_not_found, arg_ansi66, arg_ansi77, arg_auto,
			arg_auto_zero, arg_binary_floating_point, arg_binary_floating_point, arg_brief, arg_brief,
			arg_brief_table, arg_brief_table, arg_card, arg_check, arg_check, arg_check_multiply,
			arg_check_multiply, arg_consolidate, arg_consolidate, arg_debug, arg_debug, arg_debug_cg, arg_debug_io, arg_debug_io,
			arg_default_full, arg_default_full, arg_default_safe, arg_default_safe, arg_fold,
			arg_free, arg_full_optimize, arg_full_optimize, arg_hexadecimal_floating_point,
			arg_hexadecimal_floating_point, arg_la_auto, arg_la_static,
			arg_large_array, arg_large_array, arg_line_numbers,
			arg_line_numbers, arg_list, arg_list, arg_long, arg_long, arg_long_profile,
			arg_long_profile, arg_map, arg_nlno, arg_no_auto_zero, arg_no_check, arg_no_check,
			arg_no_check_multiply, arg_no_check_multiply, 
	                    arg_no_debug_io, arg_no_debug_io, arg_no_fold, arg_no_large_array,
			arg_no_large_array, arg_no_line_numbers, arg_no_line_numbers, arg_no_map, arg_no_optimize,
			arg_no_optimize, arg_no_stringrange, arg_no_stringrange, arg_no_stringrange,
			arg_no_subscriptrange, arg_no_subscriptrange, arg_no_subscriptrange, arg_no_table,
			arg_no_table, arg_no_version, arg_no_very_large_array, arg_no_very_large_array,
			arg_no_vla_parm, arg_non_relocatable, arg_non_relocatable, arg_optimize, arg_optimize,
			arg_profile, arg_profile, arg_relocatable, arg_relocatable, arg_round, arg_safe,
			arg_safe_optimize, arg_safe_optimize, arg_source, arg_source, arg_static, arg_stringrange,
			arg_stringrange, arg_subscriptrange, arg_subscriptrange, arg_super, arg_symbols,
			arg_symbols, arg_table, arg_table, arg_time, arg_time, arg_time_ot, arg_top_down,
			arg_truncate, arg_truncate, arg_version, arg_very_large_array, arg_very_large_array,
			arg_very_large_common, arg_very_large_common, arg_vla_auto, arg_vla_parm, arg_vla_static);

	     cmd = index (string (cmd_names), " " || substr (cmd_string, 2, cmd_string_len - 1) || " ");
	     if cmd ^= 0
	     then cmd = (cmd + 32) / 33;
	     goto arg_case (cmd);

arg_not_found:					/* cmd_string not found */

	     if substr (cmd_string, 1, 9) = "-severity"
	     then do;
		     if (cmd_string_len = 9)
		     then do;
			     arg_num = arg_num + 1;
			     call cu_$arg_ptr_rel (arg_num, cmd2_string_ptr, cmd2_string_len, code,
				arg_list_ptr);
			     if (code ^= 0) | (cmd2_string_len = 0)
			     then do;
				     arg_num = arg_num - 1;
				     call com_err_ (0, "new_fortran",
					"Missing Severity number (1, 2, 3, or 4).");
				     arg_error = "1"b;
				end;
			     else call parse_severity (cmd2_string);
			end;
		     else call parse_severity (substr (cmd_string, 10));
		end;

	     else if substr (cmd_string, 1, 3) = "-sv"
	     then do;
		     if (cmd_string_len = 3)
		     then do;
			     arg_num = arg_num + 1;
			     call cu_$arg_ptr_rel (arg_num, cmd2_string_ptr, cmd2_string_len, code,
				arg_list_ptr);
			     if (code ^= 0) | (cmd2_string_len = 0)
			     then do;
				     arg_num = arg_num - 1;
				     call com_err_ (0, "new_fortran",
					"Missing Severity number (1, 2, 3, or 4).");
				     arg_error = "1"b;
				end;
			     else call parse_severity (cmd2_string);
			end;
		     else call parse_severity (substr (cmd_string, 4));
		end;


	     else do;
		     call com_err_ (error_table_$badopt, "new_fortran", """^a""", cmd_string);
		     arg_error = "1"b;
		end;
	     return;

arg_ansi66:					/* "ansi66" */
	     fd.ansi66 = "1"b;
	     fd.ansi77 = "0"b;
	     return;

arg_ansi77:					/* "ansi77" */
	     fd.ansi77 = "1"b;
	     fd.ansi66 = "0"b;
	     return;

arg_auto:						/* "auto" */
	     fd.auto = "1"b;
	     fd.static = "0"b;
	     return;

arg_auto_zero:					/* "auto_zero" */
	     fd.auto_zero = "1"b;
	     fd.no_auto_zero = "0"b;
	     return;

arg_binary_floating_point:				/* "binary_floating_point", "bfp" */
	     fd.binary_floating_point = "1"b;
	     fd.hexadecimal_floating_point = "0"b;
	     return;

arg_brief:					/* "brief", "bf" */
	     fd.brief = "1"b;
	     fd.long = "0"b;
	     return;

arg_brief_table:					/* "brief_table", "bftb" */
	     fd.brief_table = "1"b;
	     fd.table = "0"b;
	     fd.no_table = "0"b;
	     return;

arg_card:						/* "card" */
	     fd.card = "1"b;
	     fd.free = "0"b;
	     return;

arg_check:					/* "check", "ck" */
	     fd.check = "1"b;
	     fd.no_check = "0"b;
	     return;

arg_check_multiply:					/* "check_multiply", "ckmpy" */
	     fd.check_multiply = "1"b;
	     fd.no_check_multiply = "0"b;
	     return;

arg_consolidate:					/* "consolidate", "cons" */
	     fd.consolidate = "1"b;
	     fd.top_down = "0"b;
	     return;

arg_debug:					/* "debug", "db" */
	     fd.debug = "1"b;
	     return;

arg_debug_cg:					/* "debug_cg" */
	     fd.debug_cg = "1"b;
	     return;

arg_debug_io:					/* "debug_io", "dbio" */
	     fd.debug_io = "1"b;
	     fd.no_debug_io = "0"b;
	     return;

arg_default_full:					/* "default_full", "dff" */
	     fd.default_full = "1"b;
	     fd.default_safe = "0"b;
	     return;

arg_default_safe:					/* "default_safe", "dfs" */
arg_safe:						/* "safe" */
	     fd.default_safe = "1"b;
	     fd.default_full = "0"b;
	     return;

arg_fold:						/* "fold" */
	     fd.fold = "1"b;
	     fd.no_fold = "0"b;
	     return;

arg_free:						/* "free" */
	     fd.free = "1"b;
	     fd.card = "0"b;
	     return;

arg_hexadecimal_floating_point:			/* "hexadecimal_floating_point", "hfp" */
	     fd.hexadecimal_floating_point = "1"b;
	     fd.binary_floating_point = "0"b;
	     return;

arg_full_optimize:					/* "full_optimize", "full_ot" */
	     fd.full_optimize = "1"b;
	     fd.safe_optimize = "0"b;
	     fd.optimize = "0"b;
	     fd.no_optimize = "0"b;
	     return;

arg_la_auto:					/* "la_auto" */
	     fd.la_auto = "1"b;
	     fd.no_large_array = "0"b;
	     return;

arg_la_static:					/* "la_static" */
	     fd.la_static = "1"b;
	     fd.no_large_array = "0"b;
	     return;

arg_large_array:					/* "large_array", "la" */
	     fd.large_array = "1"b;
	     fd.no_large_array = "0"b;
	     return;

arg_line_numbers:					/* "line_numbers", "ln" */
	     fd.line_numbers = "1"b;
	     fd.no_line_numbers = "0"b;
	     return;

arg_list:						/* "list", "ls" */
	     fd.list = "1"b;
	     fd.map = "0"b;
	     fd.no_map = "0"b;
	     return;

arg_long:						/* "long", "lg" */
	     fd.long = "1"b;
	     fd.brief = "0"b;
	     return;

arg_long_profile:					/* "long_profile", "lpf" */
	     fd.long_profile = "1"b;
	     fd.profile = "0"b;
	     return;

arg_map:						/* "map" */
	     fd.map = "1"b;
	     fd.no_map = "0"b;
	     fd.list = "0"b;
	     return;

arg_nlno:						/* "nlno" */
	     call com_err_ (0, "new_fortran", "-nlno is obsolete. Use -line_numbers.");
	     arg_error = "1"b;
	     return;

arg_no_auto_zero:					/* "no_auto_zero" */
	     fd.no_auto_zero = "1"b;
	     fd.auto_zero = "0"b;
	     return;

arg_no_check:					/* "no_check", "nck" */
	     fd.no_check = "1"b;
	     fd.check = "0"b;
	     return;

arg_no_check_multiply:				/* "no_check_multiply", "nckmpy" */
	     fd.no_check_multiply = "1"b;
	     fd.check_multiply = "0"b;
	     return;

arg_no_debug_io:					/* "no_debug_io", "ndbio" */
              fd.no_debug_io = "1"b;
	    fd.debug_io = "0"b;
	    return;

arg_no_fold:					/* "no_fold" */
	     fd.no_fold = "1"b;
	     fd.fold = "0"b;
	     return;

arg_no_large_array:					/* "no_large_array", "nla" */
	     fd.no_large_array = "1"b;
	     fd.large_array = "0"b;
	     fd.la_auto = "0"b;
	     fd.la_static = "0"b;
	     return;

arg_no_line_numbers:				/* "no_line_numbers", "nln" */
	     fd.no_line_numbers = "1"b;
	     fd.line_numbers = "0"b;
	     return;

arg_no_map:					/* "no_map" */
	     fd.no_map = "1"b;
	     fd.map = "0"b;
	     fd.list = "0"b;
	     return;

arg_no_optimize:					/* "no_optimize", "not" */
	     fd.no_optimize = "1"b;
	     fd.full_optimize = "0"b;
	     fd.safe_optimize = "0"b;
	     fd.optimize = "0"b;
	     return;

arg_no_stringrange:					/* "no_stringrange", "nstrg", "nostrg" */
	     fd.no_stringrange = "1"b;
	     fd.stringrange = "0"b;
	     return;

arg_no_subscriptrange:				/* "no_subscriptrange", "nsubrg", "nosubrg" */
	     fd.no_subscriptrange = "1"b;
	     fd.subscriptrange = "0"b;
	     return;

arg_no_table:					/* "no_table", "ntb" */
	     fd.no_table = "1"b;
	     fd.table = "0"b;
	     fd.brief_table = "0"b;
	     return;

arg_no_version:					/* "no_version" */
	     fd.no_version = "1"b;
	     fd.version = "0"b;
	     return;

arg_no_very_large_array:				/* "no_very_large_array", "nvla" */
	     fd.no_very_large_array = "1"b;
	     fd.very_large_array = "0"b;
	     fd.very_large_common = "0"b;
	     fd.vla_auto = "0"b;
	     fd.vla_static = "0"b;
	     return;

arg_no_vla_parm:					/* "no_vla_parm" */
	     fd.no_vla_parm = "1"b;
	     fd.vla_parm = "0"b;
	     return;

arg_non_relocatable:				/* "non_relocatable", "nrlc" */
	     fd.non_relocatable = "1"b;
	     fd.relocatable = "0"b;
	     return;


arg_optimize:					/* "optimize", "ot" */
	     fd.optimize = "1"b;
	     fd.full_optimize = "0"b;
	     fd.safe_optimize = "0"b;
	     fd.no_optimize = "0"b;
	     return;

arg_profile:					/* "profile", "pf" */
	     fd.profile = "1"b;
	     fd.long_profile = "0"b;
	     return;

arg_relocatable:					/* "relocatable", "rlc" */
	     fd.relocatable = "1"b;
	     fd.non_relocatable = "0"b;
	     return;

arg_round:					/* "round" */
	     fd.round = "1"b;
	     fd.truncate = "0"b;
	     return;

arg_safe_optimize:					/* "safe_optimize", "safe_ot" */
	     fd.safe_optimize = "1"b;
	     fd.full_optimize = "0"b;
	     fd.optimize = "0"b;
	     fd.no_optimize = "0"b;
	     return;

arg_source:					/* "source", "sc" */
arg_symbols:					/* "symbols", "sb" */
	     call com_err_ (0, "new_fortran", """-^a"" is obsolete. Use ""-map"".", cmd_string);
	     arg_error = "1"b;
	     return;

arg_static:					/* "static" */
	     fd.static = "1"b;
	     fd.auto = "0"b;
	     return;

arg_stringrange:					/* "stringrange", "strg" */
	     fd.stringrange = "1"b;
	     fd.no_stringrange = "0"b;
	     return;

arg_subscriptrange:					/* "subscriptrange", "subrg" */
	     fd.subscriptrange = "1"b;
	     fd.no_subscriptrange = "0"b;
	     return;

arg_super:					/* "super" */
	     call com_err_ (0, "new_fortran", """-super"" is now implied by -optimize; it will be ignored.");
	     return;

arg_table:					/* "table", "tb" */
	     fd.table = "1"b;
	     fd.no_table = "0"b;
	     fd.brief_table = "0"b;
	     return;

arg_time:						/* "time", "tm" */
	     fd.time = "1"b;
	     return;

arg_time_ot:					/* "time_ot */
	     fd.time_ot = "1"b;
	     return;

arg_top_down:					/* "top_down" */
	     fd.top_down = "1"b;
	     fd.consolidate = "0"b;
	     return;

arg_truncate:					/* "truncate", "tc" */
	     fd.truncate = "1"b;
	     fd.round = "0"b;
	     return;

arg_version:					/* "version" */
	     fd.version = "1"b;
	     fd.no_version = "0"b;
	     return;

arg_very_large_array:				/* "very_large_array", "vla" */
	     fd.very_large_array = "1"b;
	     fd.no_very_large_array = "0"b;
	     return;

arg_very_large_common:				/* "very_large_common", "vlc" */
	     fd.very_large_common = "1"b;
	     fd.no_very_large_array = "0"b;
	     return;

arg_vla_auto:					/* "vla_auto" */
	     fd.vla_auto = "1"b;
	     fd.no_very_large_array = "0"b;
	     return;

arg_vla_parm:					/* "vla_parm" */
	     fd.vla_parm = "1"b;
	     fd.no_vla_parm = "0"b;
	     return;

arg_vla_static:					/* "vla_static" */
	     fd.vla_static = "1"b;
	     fd.no_very_large_array = "0"b;
	     return;

parse_severity:
     procedure (level);

dcl	level		char (*);
dcl	level_no		fixed bin;

	level_no = index ("1234", substr (level, 1, 1));

	if substr (level, 1, 1) = "-"
	then do;
		arg_num = arg_num - 1;
		call com_err_ (0, "new_fortran", "Missing severity number (1, 2, 3, or 4) before ""^a"".", level);
		arg_error = "1"b;
	     end;

	else if level_no = 0 | substr (level, 2) ^= " "
	then do;
		call com_err_ (0, "new_fortran", "Severity must be 1, 2, 3, or 4. Not ""^a"".", level);
		arg_error = "1"b;
	     end;
	else fd.severity = level_no;
     end /* parse_severity */;
	end /* of argument entry */;

/* entry point for %global */

global:
     entry (cmd_string_ptr, cmd_string_len, fd_ptr, print_message);
	begin;

dcl	glb_case		(0:111) label variable init (glb_not_found, glb_ansi66, glb_ansi77, glb_auto,
			glb_auto_zero, glb_binary_floating_point, glb_binary_floating_point, glb_brief, glb_brief,
			glb_brief_table, glb_brief_table, glb_card, glb_check, glb_check, glb_check_multiply,
			glb_check_multiply, glb_consolidate, glb_consolidate, glb_debug, glb_debug, glb_debug_cg, glb_debug_io, glb_debug_io,
			glb_default_full, glb_default_full, glb_default_safe, glb_default_safe, glb_fold,
			glb_free, glb_full_optimize, glb_full_optimize, glb_hexadecimal_floating_point,
			glb_hexadecimal_floating_point, glb_la_auto, glb_la_static,
			glb_large_array, glb_large_array, glb_line_numbers,
			glb_line_numbers, glb_list, glb_list, glb_long, glb_long, glb_long_profile,
			glb_long_profile, glb_map, glb_nlno, glb_no_auto_zero, glb_no_check, glb_no_check,
			glb_no_check_multiply, glb_no_check_multiply,
	                    glb_no_debug_io, glb_no_debug_io, glb_no_fold, glb_no_large_array,
			glb_no_large_array, glb_no_line_numbers, glb_no_line_numbers, glb_no_map, glb_no_optimize,
			glb_no_optimize, glb_no_stringrange, glb_no_stringrange, glb_no_stringrange,
			glb_no_subscriptrange, glb_no_subscriptrange, glb_no_subscriptrange, glb_no_table,
			glb_no_table, glb_no_version, glb_no_very_large_array, glb_no_very_large_array,
			glb_no_vla_parm, glb_non_relocatable, glb_non_relocatable, glb_optimize, glb_optimize,
			glb_profile, glb_profile, glb_relocatable, glb_relocatable, glb_round, glb_safe,
			glb_safe_optimize, glb_safe_optimize, glb_source, glb_source, glb_static, glb_stringrange,
			glb_stringrange, glb_subscriptrange, glb_subscriptrange, glb_super, glb_symbols,
			glb_symbols, glb_table, glb_table, glb_time, glb_time, glb_time_ot, glb_top_down,
			glb_truncate, glb_truncate, glb_version, glb_very_large_array, glb_very_large_array,
			glb_very_large_common, glb_very_large_common, glb_vla_auto, glb_vla_parm, glb_vla_static);

	     cmd = index (string (cmd_names), " " || cmd_string || " ");
	     if cmd ^= 0
	     then cmd = (cmd + 32) / 33;
	     goto glb_case (cmd);

glb_not_found:					/* cmd_string not found */
glb_brief:					/* "brief", "bf" */
glb_brief_table:					/* "brief_table", "bftb" */
glb_check:					/* "check", "ck" */
glb_debug:					/* "debug", "db" */
glb_debug_cg:					/* "debug_cg" */
glb_debug_io:					/* "debug_io", "dbio" */
glb_full_optimize:					/* "full_optimize", "full_ot" */
glb_line_numbers:					/* "line_numbers", "ln" */
glb_list:						/* "list", "ls" */
glb_long:						/* "long", "lg" */
glb_long_profile:					/* "long_profile", "lpf" */
glb_map:						/* "map" */
glb_nlno:						/* "nlno" */
glb_no_check:					/* "no_check", "nck" */
glb_no_debug_io:					/* "no_debug_io", "ndbio" */
glb_no_line_numbers:				/* "no_line_numbers", "nln" */
glb_no_map:					/* "no_map" */
glb_no_optimize:					/* "no_optimize", "not" */
glb_no_table:					/* "no_table", "ntb" */
glb_no_version:					/* "no_version" */
glb_non_relocatable:				/* "non_relocatable", "nrlc" */
glb_optimize:					/* "optimize", "ot" */
glb_profile:					/* "profile", "pf" */
glb_relocatable:					/* "relocatable", "rlc" */
glb_safe_optimize:					/* "safe_optimize", "safe_ot" */
glb_source:					/* "source", "sc" */
glb_super:					/* "super" */
glb_symbols:					/* "symbols", "sb" */
glb_table:					/* "table", "tb" */
glb_time:						/* "time", "tm" */
glb_time_ot:					/* "time_ot" */
glb_version:					/* "version" */
	     call print_message (150, cmd_string);
	     return;

glb_ansi66:					/* "ansi66" */
	     fd.ansi66 = "1"b;
	     if fd.ansi77
	     then do;
		     call print_message (191, "%global", cmd_string, "ansi77");
		     fd.ansi77 = "0"b;
		end;
	     return;

glb_ansi77:					/* "ansi77" */
	     fd.ansi77 = "1"b;
	     if fd.ansi66
	     then do;
		     call print_message (191, "%global", cmd_string, "ansi66");
		     fd.ansi66 = "0"b;
		end;
	     return;

glb_auto:						/* "auto" */
	     fd.auto = "1"b;
	     if fd.static
	     then do;
		     call print_message (191, "%global", cmd_string, "static");
		     fd.static = "0"b;
		end;
	     return;

glb_auto_zero:					/* "auto_zero" */
	     fd.auto_zero = "1"b;
	     if fd.no_auto_zero
	     then do;
		     call print_message (191, "%global", cmd_string, "no_auto_zero");
		     fd.no_auto_zero = "0"b;
		end;
	     return;

glb_binary_floating_point:				/* "binary_floating_point", "bfp" */
	     fd.binary_floating_point = "1"b;
	     if fd.hexadecimal_floating_point
	     then do;
		     call print_message (191, "%global", cmd_string, "hexadecimal_floating_point");
		     fd.hexadecimal_floating_point = "0"b;
		end;
	     return;

glb_card:						/* "card" */
	     fd.card = "1"b;
	     if fd.free
	     then do;
		     call print_message (191, "%global", cmd_string, "free");
		     fd.free = "0"b;
		end;
	     return;

glb_check_multiply:					/* "check_mulitply", "ckmpy" */
	     fd.check_multiply = "1"b;
	     if fd.no_check_multiply
	     then do;
		     call print_message (191, "%global", cmd_string, "no_check_multiply");
		     fd.no_check_multiply = "0"b;
		end;
	     return;

glb_consolidate:					/* "consolidate", "cons" */
	     fd.consolidate = "1"b;
	     if fd.top_down
	     then do;
		     call print_message (191, "%global", cmd_string, "top_down");
		     fd.top_down = "0"b;
		end;
	     return;

glb_default_full:					/* "default_full", "dff" */
	     fd.default_full = "1"b;
	     if fd.default_safe
	     then do;
		     call print_message (191, "%global", cmd_string, "default_safe");
		     fd.default_safe = "0"b;
		end;
	     return;

glb_default_safe:					/* "default_safe", "dfs" */
glb_safe:						/* "safe" */
	     fd.default_safe = "1"b;
	     if fd.default_full
	     then do;
		     call print_message (191, "%global", cmd_string, "default_full");
		     fd.default_full = "0"b;
		end;
	     return;

glb_fold:						/* "fold" */
	     fd.fold = "1"b;
	     if fd.no_fold
	     then do;
		     call print_message (191, "%global", cmd_string, "no_fold");
		     fd.no_fold = "0"b;
		end;
	     return;

glb_free:						/* "free" */
	     fd.free = "1"b;
	     if fd.card
	     then do;
		     call print_message (191, "%global", cmd_string, "card");
		     fd.card = "0"b;
		end;
	     return;

glb_hexadecimal_floating_point:			/* "hexadecimal_floating_point", "hfp" */
	     fd.hexadecimal_floating_point = "1"b;
	     if fd.binary_floating_point
	     then do;
		     call print_message (191, "%global", cmd_string, "binary_floating_point");
		     fd.binary_floating_point = "0"b;
		end;
	     return;

glb_la_auto:					/* "la_auto" */
	     fd.la_auto = "1"b;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

glb_la_static:					/* "la_static" */
	     fd.la_static = "1"b;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

glb_large_array:					/* "large_array", "la" */
	     fd.large_array = "1"b;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

glb_no_auto_zero:					/* "no_auto_zero" */
	     fd.no_auto_zero = "1"b;
	     if fd.auto_zero
	     then do;
		     call print_message (191, "%global", cmd_string, "auto_zero");
		     fd.auto_zero = "0"b;
		end;
	     return;

glb_no_check_multiply:				/* "no_check_multiply", "nckmpy" */
	     fd.no_check_multiply = "1"b;
	     if fd.check_multiply
	     then do;
		     call print_message (191, "%global", cmd_string, "check_multiply");
		     fd.check_multiply = "0"b;
		end;
	     return;

glb_no_fold:					/* "no_fold" */
	     fd.no_fold = "1"b;
	     if fd.fold
	     then do;
		     call print_message (191, "%global", cmd_string, "fold");
		     fd.fold = "0"b;
		end;
	     return;

glb_no_large_array:					/* "no_large_array", "nla" */
	     fd.no_large_array = "1"b;
	     if fd.large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "large_array");
		     fd.large_array = "0"b;
		end;
	     if fd.la_auto
	     then do;
		     call print_message (191, "%global", cmd_string, "la_auto");
		     fd.la_auto = "0"b;
		end;
	     if fd.la_static
	     then do;
		     call print_message (191, "%global", cmd_string, "la_static");
		     fd.la_static = "0"b;
		end;
	     if fd.very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "very_large_array");
		     fd.very_large_array = "0"b;
		end;
	     if fd.vla_auto
	     then do;
		     call print_message (191, "%global", cmd_string, "vla_auto");
		     fd.vla_auto = "0"b;
		end;
	     if fd.vla_static
	     then do;
		     call print_message (191, "%global", cmd_string, "vla_static");
		     fd.vla_static = "0"b;
		end;
	     return;

glb_no_stringrange:					/* "no_stringrange", "nstrg", "nostrg" */
	     fd.no_stringrange = "1"b;
	     if fd.stringrange
	     then do;
		     call print_message (191, "%global", cmd_string, "stringrange");
		     fd.stringrange = "0"b;
		end;
	     return;

glb_no_subscriptrange:				/* "no_subscriptrange", "nsubrg", "nosubrg" */
	     fd.no_subscriptrange = "1"b;
	     if fd.subscriptrange
	     then do;
		     call print_message (191, "%global", cmd_string, "subscriptrange");
		     fd.subscriptrange = "0"b;
		end;
	     return;

glb_no_very_large_array:				/* "no_very_large_array", "nvla" */
	     fd.no_very_large_array = "1"b;
	     if fd.very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "very_large_array");
		     fd.very_large_array = "0"b;
		end;
	     if fd.very_large_common
	     then do;
		     call print_message (191, "%global", cmd_string, "very_large_common");
		     fd.very_large_common = "0"b;
		end;
	     if fd.vla_auto
	     then do;
		     call print_message (191, "%global", cmd_string, "vla_auto");
		     fd.vla_auto = "0"b;
		end;
	     if fd.vla_static
	     then do;
		     call print_message (191, "%global", cmd_string, "vla_static");
		     fd.vla_static = "0"b;
		end;
	     return;

glb_no_vla_parm:					/* "no_vla_parm" */
	     fd.no_vla_parm = "1"b;
	     if fd.vla_parm
	     then do;
		     call print_message (191, "%global", cmd_string, "vla_parm");
		     fd.vla_parm = "0"b;
		end;
	     return;

glb_round:					/* "round" */
	     fd.round = "1"b;
	     if fd.truncate
	     then do;
		     call print_message (191, "%global", cmd_string, "truncate");
		     fd.truncate = "0"b;
		end;
	     return;

glb_static:					/* "static" */
	     fd.static = "1"b;
	     if fd.auto
	     then do;
		     call print_message (191, "%global", cmd_string, "auto");
		     fd.auto = "0"b;
		end;
	     return;

glb_stringrange:					/* "stringrange", "strg" */
	     fd.stringrange = "1"b;
	     if fd.no_stringrange
	     then do;
		     call print_message (191, "%global", cmd_string, "no_stringrange");
		     fd.no_stringrange = "0"b;
		end;
	     return;

glb_subscriptrange:					/* "subscriptrange", "subrg" */
	     fd.subscriptrange = "1"b;
	     if fd.no_subscriptrange
	     then do;
		     call print_message (191, "%global", cmd_string, "no_subscriptrange");
		     fd.no_subscriptrange = "0"b;
		end;
	     return;

glb_top_down:					/* "top_down" */
	     fd.top_down = "1"b;
	     if fd.consolidate
	     then do;
		     call print_message (191, "%global", cmd_string, "consolidate");
		     fd.consolidate = "0"b;
		end;
	     return;

glb_truncate:					/* "truncate", "tc" */
	     fd.truncate = "1"b;
	     if fd.round
	     then do;
		     call print_message (191, "%global", cmd_string, "round");
		     fd.round = "0"b;
		end;
	     return;

glb_very_large_array:				/* "very_large_array", "vla" */
	     fd.very_large_array = "1"b;
	     if fd.no_very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_very_large_array");
		     fd.no_very_large_array = "0"b;
		end;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

glb_very_large_common:				/* "very_large_common", "vlc" */
	     fd.very_large_common = "1"b;
	     if fd.no_very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_very_large_array");
		     fd.no_very_large_array = "0"b;
		end;
	     return;

glb_vla_auto:					/* "vla_auto" */
	     fd.vla_auto = "1"b;
	     if fd.no_very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_very_large_array");
		     fd.no_very_large_array = "0"b;
		end;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

glb_vla_parm:					/* "vla_parm" */
	     fd.vla_parm = "1"b;
	     if fd.no_vla_parm
	     then do;
		     call print_message (191, "%global", cmd_string, "no_vla_parm");
		     fd.no_vla_parm = "0"b;
		end;
	     return;

glb_vla_static:					/* "vla_static" */
	     fd.vla_static = "1"b;
	     if fd.no_very_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_very_large_array");
		     fd.no_very_large_array = "0"b;
		end;
	     if fd.no_large_array
	     then do;
		     call print_message (191, "%global", cmd_string, "no_large_array");
		     fd.no_large_array = "0"b;
		end;
	     return;

	end /* of global entry */;


/* entry point for %option */

option:
     entry (cmd_string_ptr, cmd_string_len, fo_ptr, fd_ptr, global_fo_ptr, auto_option, static_option, print_message);
	begin;

dcl	opt_case		(0:111) label variable init (opt_not_found, opt_ansi66, opt_ansi77, opt_auto,
			opt_auto_zero, opt_binary_floating_point, opt_binary_floating_point, opt_brief, opt_brief,
			opt_brief_table, opt_brief_table, opt_card, opt_check, opt_check, opt_check_multiply,
			opt_check_multiply, opt_consolidate, opt_consolidate, opt_debug, opt_debug, opt_debug_cg, opt_debug_io, opt_debug_io,
			opt_default_full, opt_default_full, opt_default_safe, opt_default_safe, opt_fold,
			opt_free, opt_full_optimize, opt_full_optimize, opt_hexadecimal_floating_point,
			opt_hexadecimal_floating_point, opt_la_auto, opt_la_static,
			opt_large_array, opt_large_array, opt_line_numbers,
			opt_line_numbers, opt_list, opt_list, opt_long, opt_long, opt_long_profile,
			opt_long_profile, opt_map, opt_nlno, opt_no_auto_zero, opt_no_check, opt_no_check,
			opt_no_check_multiply, opt_no_check_multiply,
                              opt_no_debug_io, opt_no_debug_io, opt_no_fold, opt_no_large_array,
			opt_no_large_array, opt_no_line_numbers, opt_no_line_numbers, opt_no_map, opt_no_optimize,
			opt_no_optimize, opt_no_stringrange, opt_no_stringrange, opt_no_stringrange,
			opt_no_subscriptrange, opt_no_subscriptrange, opt_no_subscriptrange, opt_no_table,
			opt_no_table, opt_no_version, opt_no_very_large_array, opt_no_very_large_array,
			opt_no_vla_parm, opt_non_relocatable, opt_non_relocatable, opt_optimize, opt_optimize,
			opt_profile, opt_profile, opt_relocatable, opt_relocatable, opt_round, opt_safe,
			opt_safe_optimize, opt_safe_optimize, opt_source, opt_source, opt_static, opt_stringrange,
			opt_stringrange, opt_subscriptrange, opt_subscriptrange, opt_super, opt_symbols,
			opt_symbols, opt_table, opt_table, opt_time, opt_time, opt_time_ot, opt_top_down,
			opt_truncate, opt_truncate, opt_version, opt_very_large_array, opt_very_large_array,
			opt_very_large_common, opt_very_large_common, opt_vla_auto, opt_vla_parm, opt_vla_static);

	     cmd = index (string (cmd_names), " " || cmd_string || " ");
	     if cmd ^= 0
	     then cmd = (cmd + 32) / 33;
	     goto opt_case (cmd);

opt_not_found:					/* cmd_string not found */
opt_auto_zero:					/* "auto_zero" */
opt_binary_floating_point:				/* "binary_floating_point", "bfp" */
opt_brief:					/* "brief", "bf" */
opt_brief_table:					/* "brief_table", "bftb" */
opt_check:					/* "check", "ck" */
opt_consolidate:					/* "consolidate, "cons" */
opt_debug:					/* "debug", "db" */
opt_debug_cg:					/* "debug_cg" */
opt_debug_io:					/* "debug_io", "dbio" */
opt_full_optimize:					/* "full_optimize" */
opt_hexadecimal_floating_point:			/* "hexadecimal_floating_point, "hfp" */
opt_la_auto:					/* "la_auto" */
opt_la_static:					/* "la_static" */
opt_large_array:					/* "large_array", "la" */
opt_line_numbers:					/* "line_numbers", "ln" */
opt_list:						/* "list", "ls" */
opt_long:						/* "long", "lg" */
opt_long_profile:					/* "long_profile", "lpf" */
opt_map:						/* "map" */
opt_nlno:						/* "nlno" */
opt_no_auto_zero:					/* "no_auto_zero" */
opt_no_check:					/* "no_check", "nck" */
opt_no_debug_io:					/* "no_debug_io", "ndbio" */
opt_no_large_array:					/* "no_large_array", "nla" */
opt_no_line_numbers:				/* "no_line_numbers", "nln" */
opt_no_map:					/* "no_map" */
opt_no_optimize:					/* "no_optimize", "not" */
opt_no_table:					/* "no_table", "ntb" */
opt_no_version:					/* "no_version" */
opt_no_very_large_array:				/* "no_very_large_array", "nvla" */
opt_no_vla_parm:					/* "no_vla_parm" */
opt_non_relocatable:				/* "non_relocatable", "nrlc" */
opt_optimize:					/* "optimize", "ot" */
opt_profile:					/* "profile", "pf" */
opt_relocatable:					/* "relocatable", "rlc" */
opt_safe_optimize:					/* "safe_optimize", "safe_ot" */
opt_source:					/* "source", "sc" */
opt_super:					/* "super" */
opt_symbols:					/* "symbols", "sb" */
opt_table:					/* "table", "tb" */
opt_time:						/* "time", "tm" */
opt_time_ot:					/* "time_ot" */
opt_top_down:					/* "top_down" */
opt_version:					/* "version" */
opt_very_large_array:				/* "very_large_array", "vla" */
opt_very_large_common:				/* "very_large_common", "vlc" */
opt_vla_auto:					/* "vla_auto" */
opt_vla_parm:					/* "vla_parm" */
opt_vla_static:					/* "vla_static" */
	     call print_message (151, cmd_string);
	     return;

opt_ansi66:					/* "ansi66" */
	     fo.ansi_77 = "0"b;
	     fd.ansi77 = "1"b;
	     if fd.ansi66
	     then do;
		     call print_message (191, "%option", cmd_string, "ansi66");
		     fd.ansi66 = "0"b;
		end;
	     return;

opt_ansi77:					/* "ansi77" */
	     fo.ansi_77 = "1"b;
	     fd.ansi77 = "1"b;
	     if fd.ansi66
	     then do;
		     call print_message (191, "%option", cmd_string, "ansi66");
		     fd.ansi66 = "0"b;
		end;
	     return;

opt_auto:						/* "auto" */
	     auto_option = "1"b;
	     static_option = "0"b;
	     if fd.static
	     then do;
		     call print_message (191, "%option", cmd_string, "static");
		     fd.static = "0"b;
		end;
	     return;

opt_card:						/* "card" */
	     fo.card = "1"b;
	     if ^fd.no_fold
	     then fo.fold = "1"b;
	     fd.card = "1"b;
	     if fd.free
	     then do;
		     call print_message (191, "%option", cmd_string, "free");
		     fd.free = "0"b;
		end;
	     return;

opt_check_multiply:					/* "check_multiply", "ckmpy" */
	     fo.check_multiply = "1"b;
	     fd.check_multiply = "1"b;
	     if fd.no_check_multiply
	     then do;
		     call print_message (191, "%option", cmd_string, "no_check_multiply");
		     fd.no_check_multiply = "0"b;
		end;
	     return;

opt_fold:						/* "fold" */
	     fo.fold = "1"b;
	     fd.fold = "1"b;
	     if fd.no_fold
	     then do;
		     call print_message (191, "%option", cmd_string, "no_fold");
		     fd.no_fold = "0"b;
		end;
	     return;

opt_free:						/* "free" */
	     fo.card = "0"b;
	     if ^fd.fold
	     then fo.fold = "0"b;
	     fd.free = "1"b;
	     if fd.card
	     then do;
		     call print_message (191, "%option", cmd_string, "card");
		     fd.card = "0"b;
		end;
	     return;

opt_no_check_multiply:				/* "no_check_multiply", "nckmpy" */
	     fo.check_multiply = "0"b;
	     fd.no_check_multiply = "1"b;
	     if fd.check_multiply
	     then do;
		     call print_message (191, "%option", cmd_string, "check_multiply");
		     fd.check_multiply = "0"b;
		end;
	     return;

opt_default_full:					/* "default_full", "dff" */
	     if ^fd.safe_optimize
	     then fo.ignore_articulation_blocks = "1"b;
	     fd.default_full = "1"b;
	     if fd.default_safe
	     then do;
		     call print_message (191, "%option", cmd_string, "default_safe");
		     fd.default_safe = "0"b;
		end;
	     return;

opt_default_safe:					/* "default_safe", "dfs" */
opt_safe:						/* "safe" */
	     if ^fd.full_optimize
	     then fo.ignore_articulation_blocks = "0"b;
	     fd.default_safe = "1"b;
	     if fd.default_full
	     then do;
		     call print_message (901, "%option", cmd_string, "default_full");
		     fd.default_full = "0"b;
		end;
	     return;

opt_no_fold:					/* "no_fold" */
	     fo.fold = "0"b;
	     fd.no_fold = "1"b;
	     if fd.fold
	     then do;
		     call print_message (191, "%option", cmd_string, "fold");
		     fd.fold = "0"b;
		end;
	     return;

opt_no_stringrange:					/* "no_stringrange", "nstrg", "nostrg" */
	     fo.stringrange = "0"b;
	     fd.no_stringrange = "1"b;
	     if fd.stringrange
	     then do;
		     call print_message (191, "%option", cmd_string, "stringrange");
		     fd.stringrange = "0"b;
		end;
	     return;

opt_no_subscriptrange:				/* "no_subscriptrange", "nsubrg", "nosubrg" */
	     fo.subscriptrange = "0"b;
	     fd.no_subscriptrange = "1"b;
	     if fd.subscriptrange
	     then do;
		     call print_message (191, "%option", cmd_string, "subscriptrange");
		     fd.subscriptrange = "0"b;
		end;
	     return;

opt_round:					/* "round" */
	     fo.do_rounding = "1"b;
	     fd.round = "1"b;
	     if fd.truncate
	     then do;
		     call print_message (191, "%option", cmd_string, "truncate");
		     fd.truncate = "0"b;
		end;
	     return;

opt_static:					/* "static" */
	     static_option = "1"b;
	     auto_option = "0"b;
	     fd.static = "1"b;
	     if fd.auto
	     then do;
		     call print_message (191, "%option", cmd_string, "auto");
		     fd.auto = "0"b;
		end;
	     return;

opt_stringrange:					/* "stringrange", "strg" */
	     fo.stringrange = "1"b;
	     fd.stringrange = "1"b;
	     if fd.no_stringrange
	     then do;
		     call print_message (191, "%option", cmd_string, "no_stringrange");
		     fd.no_stringrange = "0"b;
		end;
	     return;

opt_subscriptrange:					/* "subscriptrange", "subrg" */
	     fo.subscriptrange = "1"b;
	     fd.subscriptrange = "1"b;
	     if fd.no_subscriptrange
	     then do;
		     call print_message (191, "%option", cmd_string, "no_subscriptrange");
		     fd.no_subscriptrange = "0"b;
		end;
	     return;

opt_truncate:					/* "truncate", "tc" */
	     fo.do_rounding = "0"b;
	     fd.truncate = "1"b;
	     if fd.round
	     then do;
		     call print_message (191, "%option", cmd_string, "round");
		     fd.round = "0"b;
		end;
	     return;
						/* end of option processing */
	end /* of option entry */;

/* entry point to set fortran options based on fortran_declared structure */

set:
     entry (fd_ptr, fo_ptr);

	if fd.ansi66
	then fo.ansi_77 = "0"b;

	if fd.ansi77
	then do;
		if ^(fd.optimize | fd.safe_optimize | fd.full_optimize)
		then
		     fo.subscriptrange, fo.stringrange, fo.check_multiply = "1"b;
		fo.ansi_77 = "1"b;
	     end;

	if fd.auto
	then fo.static_storage = "0"b;

	if fd.auto_zero
	then fo.auto_zero = "1"b;

	if fd.binary_floating_point
	then fo.hfp = "0"b;

	if fd.brief
	then fo.brief = "1"b;

	if fd.brief_table
	then fo.brief_table = "1"b;

	if fd.card
	then fo.card, fo.fold = "1"b;

	if fd.check
	then fo.check = "1"b;

	if fd.check_multiply
	then fo.check_multiply = "1"b;

	if fd.consolidate
	then fo.consolidate = "1"b;

	if fd.debug
	then fo.stop_after_cg = "1"b;

	if fd.debug_cg
	then fo.stop_after_parse, fo.stop_after_cg = "1"b;

	if fd.debug_io
          then fo.debug_io = "1"b;

	if fd.default_safe
	then fo.ignore_articulation_blocks = "0"b;
	else fo.ignore_articulation_blocks = "1"b;

	if fd.fold
	then fo.fold = "1"b;

	if fd.free
	then do;
		fo.card = "0"b;
		if ^fd.fold
		then fo.fold = "0"b;
	     end;

	if fd.full_optimize
	then fo.optimize, fo.consolidate, fo.ignore_articulation_blocks = "1"b;

	if fd.hexadecimal_floating_point
	then fo.hfp = "1"b;

	if fd.la_auto
	then fo.LA_auto = "1"b;

	if fd.la_static
	then fo.LA_static = "1"b;

	if fd.large_array
	then do;
		fo.LA_auto = "1"b;
		fo.LA_static = "1"b;
	     end;

	if fd.line_numbers
	then fo.has_line_numbers = "1"b;

	if fd.long
	then fo.brief = "0"b;

	if fd.long_profile
	then fo.profile, fo.long_profile = "1"b;

	if fd.list
	then string (fo.listing) = "1111"b;

	if fd.map
	then substr (string (fo.listing), 1, 3) = "111"b;

	if fd.no_auto_zero
	then fo.auto_zero = "0"b;

	if fd.no_check
	then fo.check = "0"b;

	if fd.no_fold
	then fo.fold = "0"b;

	if fd.no_large_array
	then do;
		fo.LA_auto = "0"b;
		fo.LA_static = "0"b;
	     end;

	if fd.no_line_numbers
	then fo.has_line_numbers = "0"b;

	if fd.no_map
	then string (fo.listing) = "0000"b;

	if fd.no_optimize
	then fo.optimize = "0"b;

	if fd.no_check_multiply
	then fo.check_multiply = "0"b;

	if fd.no_stringrange
	then fo.stringrange = "0"b;

	if fd.no_subscriptrange
	then fo.subscriptrange = "0"b;

	if fd.no_table
	then fo.table = "0"b;

/* This next bit of code is order dependant.  -no_vla and -vla_parm
	   are supposed to be independant of each other but -no_vla clears
	   fo.VLA_parm here.  This is corrected later on by -vla_parm if
	   it is set. */

	if fd.no_very_large_array
	then do;
		fo.VLA_auto = "0"b;
		fo.VLA_parm = "0"b;
		fo.VLA_static = "0"b;
		fo.VLC = "0"b;
	     end;

	if fd.no_vla_parm
	then fo.VLA_parm = "0"b;

	if fd.non_relocatable
	then fo.relocatable = "0"b;

	if fd.optimize
	then fo.optimize, fo.consolidate = "1"b;

	if fd.profile
	then fo.profile = "1"b;

	if fd.relocatable
	then fo.relocatable = "1"b;

	if fd.round
	then fo.do_rounding = "1"b;

	if fd.safe_optimize
	then do;
		fo.optimize, fo.consolidate = "1"b;
		fo.ignore_articulation_blocks = "0"b;
	     end;

	fo.severity = fd.severity;

	if fd.static
	then fo.static_storage = "1"b;

	if fd.stringrange
	then fo.stringrange = "1"b;

	if fd.subscriptrange
	then fo.subscriptrange = "1"b;

	if fd.table | (^fd.no_table & ^fo.optimize & ^fd.brief_table)
	then fo.table = "1"b;

	if fd.time
	then fo.time = "1"b;

	if fd.time_ot
	then fo.time_optimizer = "1"b;

	if fd.top_down
	then fo.consolidate = "0"b;

	if fd.truncate
	then fo.do_rounding = "0"b;

	if fd.very_large_array
	then do;
		fo.VLA_auto = "1"b;
		if ^fd.no_vla_parm
		then fo.VLA_parm = "1"b;
		fo.VLA_static = "1"b;
		fo.VLC = "1"b;
		fo.LA_auto = "1"b;
		fo.LA_static = "1"b;
	     end;

	if fd.very_large_common
	then do;
		fo.VLC = "1"b;
		if ^fd.no_vla_parm
		then fo.VLA_parm = "1"b;
	     end;

	if fd.vla_auto
	then do;
		fo.VLA_auto = "1"b;
		if ^fd.no_vla_parm
		then fo.VLA_parm = "1"b;
		fo.LA_auto = "1"b;
	     end;

	if fd.vla_parm
	then do;
		if ^fd.no_vla_parm
		then fo.VLA_parm = "1"b;
	     end;

	if fd.vla_static
	then do;
		fo.VLA_static = "1"b;
		if ^fd.no_vla_parm
		then fo.VLA_parm = "1"b;
		fo.LA_static = "1"b;
	     end;

	return;					/* end of entry set */

/* entry point for checking argument conflicts */

check_args:
     entry (fd_ptr, arg_error);
	begin;

	     if fd.very_large_array & fd.no_large_array
	     then call incompatible_args ("-very_large_array", "-no_large_array");

	     if fd.vla_auto & fd.no_large_array
	     then call incompatible_args ("-vla_auto", "-no_large_array");

	     if fd.vla_static & fd.no_large_array
	     then call incompatible_args ("-vla_static", "-no_large_array");

	     if fd.line_numbers & fd.card
	     then call incompatible_args ("-card", "-line_numbers");

	     if fd.optimize
	     then do;
		     if fd.subscriptrange
		     then call incompatible_args ("-optimize", "-subscriptrange");
		     if fd.stringrange
		     then call incompatible_args ("-optimize", "-stringrange");
		end;

	     if fd.safe_optimize
	     then do;
		     if fd.subscriptrange
		     then call incompatible_args ("-safe_optimize", "-subscriptrange");
		     if fd.stringrange
		     then call incompatible_args ("-safe_optimize", "-stringrange");
		end;

	     if fd.full_optimize
	     then do;
		     if fd.subscriptrange
		     then call incompatible_args ("-full_optimize", "-subscriptrange");
		     if fd.stringrange
		     then call incompatible_args ("-full_optimize", "-stringrange");
		end;
	     return;
incompatible_args:
     procedure (first_arg, second_arg);

dcl	(first_arg,
	second_arg)	char (*);

	call com_err_ (0, "new_fortran", "The options ""^a"" and ""^a"" are mutually incompatible.", first_arg,
	     second_arg);
	arg_error = "1"b;
	return;
     end /* incompatible_args */;
	end /* of the arg_check entry */;

/* entry point to resolve global/argument conflicts */

check_global_args:
     entry (global_fd_ptr, arg_fd_ptr, print_message);
	begin;

	     if arg_fd.binary_floating_point & global_fd.hexadecimal_floating_point
	     then do;
		     call print_message (192, "-binary_floating_point", "hexadecimal_floating_point");
		     global_fd.hexadecimal_floating_point = "0"b;
		end;
	     else if arg_fd.hexadecimal_floating_point & global_fd.binary_floating_point
	     then do;
		     call print_message (192, "-hexadecimal_floating_point", "binary_floating_point");
		     global_fd.binary_floating_point = "0"b;
		end;

/* In order to check if HFP mode is allowed, we generate a bogus call to
fort_hfp_math$conv_r_to_i_round.  If the user does not have access to use HFP
mode, the condition "cannot_enable_HFP_mode" will be signaled.  This is
admittedly a grotty way to do the test.  */

	     if arg_fd.hexadecimal_floating_point | global_fd.hexadecimal_floating_point
	     then do;
		     on cannot_enable_HFP_mode
			begin;
			     call print_message (522);
			end;
		     dummy_var = fort_hfp_math$conv_r_to_i_round ("0"b, 0);
		     revert cannot_enable_HFP_mode;
		end;

	     if arg_fd.optimize | arg_fd.safe_optimize | arg_fd.full_optimize
	     then do;
		     if global_fd.stringrange
		     then do;
			     if arg_fd.optimize
			     then call print_message (192, "-optimize", "stringrange");
			     else if arg_fd.safe_optimize
			     then call print_message (192, "-safe_optimize", "stringrange");
			     else if arg_fd.full_optimize
			     then call print_message (192, "-full_optimize", "stringrange");
			     global_fd.stringrange = "0"b;
			end;
		     if global_fd.subscriptrange
		     then do;
			     if arg_fd.optimize
			     then call print_message (192, "optimize", "subscriptrange");
			     else if fd.safe_optimize
			     then call print_message (192, "-safe_optimize", "subscriptrange");
			     else if fd.full_optimize
			     then call print_message (192, "-full_optimize", "subscriptrange");
			     global_fd.subscriptrange = "0"b;
			end;
		end;

	     if arg_fd.stringrange & global_fd.no_stringrange
	     then do;
		     call print_message (192, "-stringrange", "no_stringrange");
		     global_fd.no_stringrange = "0"b;
		end;
	     else if arg_fd.no_stringrange & global_fd.stringrange
	     then do;
		     call print_message (192, "-no_stringrange", "stringrange");
		     global_fd.stringrange = "0"b;
		end;

	     if arg_fd.subscriptrange & global_fd.no_subscriptrange
	     then do;
		     call print_message (192, "-subscriptrange", "no_subscriptrange");
		     global_fd.no_subscriptrange = "0"b;
		end;
	     else if arg_fd.no_subscriptrange & global_fd.subscriptrange
	     then do;
		     call print_message (192, "-no_subscriptrange", "subscriptrange");
		     global_fd.subscriptrange = "0"b;
		end;

	     if arg_fd.auto_zero & global_fd.no_auto_zero
	     then do;
		     call print_message (192, "-auto_zero", "no_auto_zero");
		     global_fd.no_auto_zero = "0"b;
		end;
	     else if arg_fd.no_auto_zero & global_fd.auto_zero
	     then do;
		     call print_message (192, "-no_auto_zero", "auto_zero");
		     global_fd.auto_zero = "0"b;
		end;

	     if arg_fd.round & global_fd.truncate
	     then do;
		     call print_message (192, "-round", "truncate");
		     global_fd.truncate = "0"b;
		end;
	     else if arg_fd.truncate & global_fd.round
	     then do;
		     call print_message (192, "-truncate", "round");
		     global_fd.round = "0"b;
		end;

	     if arg_fd.card & global_fd.free
	     then do;
		     call print_message (192, "-card", "free");
		     global_fd.free = "0"b;
		end;
	     else if arg_fd.free & global_fd.card
	     then do;
		     call print_message (192, "-free", "card");
		     global_fd.card = "0"b;
		end;

	     if arg_fd.fold & global_fd.no_fold
	     then do;
		     call print_message (192, "-fold", "no_fold");
		     global_fd.no_fold = "0"b;
		end;
	     else if arg_fd.no_fold & global_fd.fold
	     then do;
		     call print_message (192, "-no_fold", "fold");
		     global_fd.fold = "0"b;
		end;

	     if arg_fd.ansi66 & global_fd.ansi77
	     then do;
		     call print_message (192, "-ansi66", "ansi77");
		     global_fd.ansi77 = "0"b;
		end;
	     else if arg_fd.ansi77 & global_fd.ansi66
	     then do;
		     call print_message (192, "-ansi77", "ansi66");
		     global_fd.ansi66 = "0"b;
		end;

	     if arg_fd.check_multiply & global_fd.no_check_multiply
	     then do;
		     call print_message (192, "-check_multiply", "no_check_multiply");
		     global_fd.no_check_multiply = "0"b;
		end;
	     else if arg_fd.no_check_multiply & global_fd.check_multiply
	     then do;
		     call print_message (192, "-no_check_multiply", "check_multiply");
		     global_fd.check_multiply = "0"b;
		end;

	     if arg_fd.consolidate & global_fd.top_down
	     then do;
		     call print_message (192, "-consolidate", "top_down");
		     global_fd.top_down = "0"b;
		end;
	     else if arg_fd.top_down & global_fd.consolidate
	     then do;
		     call print_message (192, "-top_down", "consolidate");
		     global_fd.consolidate = "0"b;
		end;

	     if arg_fd.default_full & global_fd.default_safe
	     then do;
		     call print_message (192, "-default_full", "default_safe");
		     global_fd.default_safe = "0"b;
		end;
	     else if arg_fd.default_safe & global_fd.default_full
	     then do;
		     call print_message (192, "-default_safe", "default_full");
		     global_fd.default_full = "0"b;
		end;

	     if arg_fd.auto & global_fd.static
	     then do;
		     call print_message (192, "-auto", "static");
		     global_fd.static = "0"b;
		end;
	     else if arg_fd.static & global_fd.auto
	     then do;
		     call print_message (192, "-static", "auto");
		     global_fd.auto = "0"b;
		end;

	     if arg_fd.large_array & global_fd.no_large_array
	     then do;
		     call print_message (192, "-large_array", "no_large_array");
		     global_fd.no_large_array = "0"b;
		end;
	     else if arg_fd.no_large_array & global_fd.large_array
	     then do;
		     call print_message (192, "-no_large_array", "large_array");
		     global_fd.large_array = "0"b;
		end;

	     if arg_fd.la_auto & global_fd.no_large_array
	     then do;
		     call print_message (192, "-la_auto", "no_large_array");
		     global_fd.no_large_array = "0"b;
		end;
	     else if arg_fd.no_large_array & global_fd.la_auto
	     then do;
		     call print_message (192, "-no_large_array", "la_auto");
		     global_fd.la_auto = "0"b;
		end;

	     if arg_fd.la_static & global_fd.no_large_array
	     then do;
		     call print_message (192, "-la_static", "no_large_array");
		     global_fd.no_large_array = "0"b;
		end;
	     else if arg_fd.no_large_array & global_fd.la_static
	     then do;
		     call print_message (192, "-no_large_array", "la_static");
		     global_fd.la_static = "0"b;
		end;

	     if arg_fd.no_large_array & global_fd.very_large_array
	     then do;
		     call print_message (192, "-no_large_array", "-very_large_array");
		     global_fd.very_large_array = "0"b;
		end;
	     else if arg_fd.very_large_array & global_fd.no_large_array
	     then do;
		     call print_message (192, "-very_large_array", "-no_large_array");
		     global_fd.no_large_array = "0"b;
		end;

	     if arg_fd.no_large_array & global_fd.vla_auto
	     then do;
		     call print_message (192, "-no_large_array", "-vla_auto");
		     global_fd.vla_auto = "0"b;
		end;
	     else if arg_fd.vla_auto & global_fd.no_large_array
	     then do;
		     call print_message (192, "-vla_auto", "-no_large_array");
		     global_fd.no_large_array = "0"b;
		end;

	     if arg_fd.no_large_array & global_fd.vla_static
	     then do;
		     call print_message (192, "-no_large_array", "-vla_static");
		     global_fd.vla_static = "0"b;
		end;
	     else if arg_fd.vla_static & global_fd.no_large_array
	     then do;
		     call print_message (192, "-vla_static", "-no_large_array");
		     global_fd.no_large_array = "0"b;
		end;

	     if arg_fd.very_large_array & global_fd.no_very_large_array
	     then do;
		     call print_message (192, "-very_large_array", "no_very_large_array");
		     global_fd.no_very_large_array = "0"b;
		end;
	     else if arg_fd.no_very_large_array & global_fd.very_large_array
	     then do;
		     call print_message (192, "-no_very_large_array", "very_large_array");
		     global_fd.very_large_array = "0"b;
		end;

	     if arg_fd.very_large_common & global_fd.no_very_large_array
	     then do;
		     call print_message (192, "-very_large_common", "no_very_large_array");
		     global_fd.no_very_large_array = "0"b;
		end;
	     else if arg_fd.no_very_large_array & global_fd.very_large_common
	     then do;
		     call print_message (192, "-no_very_large_array", "very_large_common");
		     global_fd.very_large_common = "0"b;
		end;

	     if arg_fd.vla_auto & global_fd.no_very_large_array
	     then do;
		     call print_message (192, "-vla_auto", "no_very_large_array");
		     global_fd.no_very_large_array = "0"b;
		end;
	     else if arg_fd.no_very_large_array & global_fd.vla_auto
	     then do;
		     call print_message (192, "-no_very_large_array", "vla_auto");
		     global_fd.vla_auto = "0"b;
		end;

	     if arg_fd.vla_parm & global_fd.no_vla_parm
	     then do;
		     call print_message (192, "-vla_parm", "no_vla_parm");
		     global_fd.no_vla_parm = "0"b;
		end;
	     else if arg_fd.no_vla_parm & global_fd.vla_parm
	     then do;
		     call print_message (192, "-no_vla_parm", "vla_parm");
		     global_fd.vla_parm = "0"b;
		end;

	     if arg_fd.vla_static & global_fd.no_very_large_array
	     then do;
		     call print_message (192, "-vla_static", "no_very_large_array");
		     global_fd.no_very_large_array = "0"b;
		end;
	     else if arg_fd.no_very_large_array & global_fd.vla_static
	     then do;
		     call print_message (192, "-no_very_large_array", "vla_static");
		     global_fd.vla_static = "0"b;
		end;

	     return;
	end /* of global_arg_check entry */;

/* entry point to create fortran options string */

options_string:
     entry (fort_op_ptr, op_string, VLA_words_per_seg);

	op_string = "";
	if fort_op.ansi_77
	then op_string = op_string || "ansi77 ";
	else op_string = op_string || "ansi66 ";
	if fort_op.hfp
	then op_string = op_string || "hexadecimal_floating_point ";
	else op_string = op_string || "binary_floating_point ";
	if fort_op.is_fast
	then op_string = op_string || "fast ";
	if fort_op.has_line_numbers
	then op_string = op_string || "line_numbers ";
	if fort_op.table
	then op_string = op_string || "table ";
	if fort_op.subscriptrange
	then op_string = op_string || "subscriptrange ";
	if fort_op.stringrange
	then op_string = op_string || "stringrange ";
	if fort_op.brief_table
	then op_string = op_string || "brief_table ";
	if fort_op.profile & ^fort_op.long_profile
	then op_string = op_string || "profile ";
	if fort_op.profile & fort_op.long_profile
	then op_string = op_string || "long_profile ";
	if fort_op.do_rounding
	then op_string = op_string || "round ";
	else op_string = op_string || "truncate ";
	if fort_op.check_multiply
	then op_string = op_string || "check_multiply ";
	if fort_op.LA_auto & fort_op.LA_static
	then op_string = op_string || "LA ";
	else if fort_op.LA_auto
	then op_string = op_string || "LA_AUTO ";
	else if fort_op.LA_static
	then op_string = op_string || "LA_STATIC ";
	if fort_op.VLA_auto | fort_op.VLA_parm | fort_op.VLA_static | fort_op.VLC
	then do;
		if VLA_words_per_seg = 262144
		then fort_op.VLA_is_256K = "1"b;
		else fort_op.VLA_is_256K = "0"b;
		if fort_op.VLA_auto & fort_op.VLA_parm & fort_op.VLA_static & fort_op.VLC
		then do;
			if fort_op.VLA_is_256K
			then op_string = op_string || "VLA/256K ";
			else op_string = op_string || "VLA ";
		     end;
		else do;
			if fort_op.VLA_auto
			then do;
				if fort_op.VLA_is_256K
				then op_string = op_string || "VLA_AUTO/256K ";
				else op_string = op_string || "VLA_AUTO ";
			     end;
			if fort_op.VLA_parm
			then do;
				if fort_op.VLA_is_256K
				then op_string = op_string || "VLA_PARM/256K ";
				else op_string = op_string || "VLA_PARM ";
			     end;
			if fort_op.VLA_static
			then do;
				if fort_op.VLA_is_256K
				then op_string = op_string || "VLA_STATIC/256K ";
				else op_string = op_string || "VLA_STATIC ";
			     end;
			if fort_op.VLC
			then do;
				if fort_op.VLA_is_256K
				then op_string = op_string || "VLC/256K ";
				else op_string = op_string || "VLC ";
			     end;
		     end;
	     end;

	if fort_op.optimize
	then do;
		if fort_op.ignore_articulation_blocks
		then op_string = op_string || "full_optimize ";
		else op_string = op_string || "safe_optimize ";
		if ^fort_op.consolidate
		then op_string = op_string || "top_down ";
	     end;
	if fort_op.time
	then op_string = op_string || "time ";
	if fort_op.time_optimizer
	then op_string = op_string || "time_ot ";
	if fort_op.card
	then op_string = op_string || "card ";
	else if fort_op.fold
	then op_string = op_string || "fold ";
	if fort_op.brief
	then op_string = op_string || "brief ";
	if fort_op.check
	then op_string = op_string || "check ";
	if fort_op.static_storage
	then op_string = op_string || "static ";
	if (^fort_op.relocatable)
	then op_string = op_string || "non_relocatable ";
	if fort_op.auto_zero
	then op_string = op_string || "auto_zero ";
	else op_string = op_string || "no_auto_zero ";
	if fort_op.list
	then op_string = op_string || "list ";
	else if fort_op.map
	then op_string = op_string || "map ";
	if fort_op.severity > 0
	then do;
		op_string = op_string || "severity";
		op_string = op_string || ltrim (convert (op_string, fort_op.severity));
		op_string = op_string || " ";
	     end;
	if fort_op.stop_after_parse
	then op_string = op_string || "debug_cg ";
	else if fort_op.stop_after_cg
	then op_string = op_string || "debug ";
	else if fort_op.debug_io
          then op_string = op_string || "debug_io ";

	if length (op_string) > 0
	then op_string = substr (op_string, 1, length (op_string) - 1);

	return;					/* end of options_string entry */

init_shared_vars:
     entry (shared_var_ptr);

	if shared_vars.user_options.hfp
	then do;
		shared_vars.binop_round (1, 1) = fort_hfp_math$binop_i_i_round;
		shared_vars.binop_round (1, 2) = fort_hfp_math$binop_i_r_round;
		shared_vars.binop_round (1, 3) = fort_hfp_math$binop_i_dp_round;
		shared_vars.binop_round (1, 4) = fort_hfp_math$binop_i_cp_round;
		shared_vars.binop_round (1, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (1, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (2, 1) = fort_hfp_math$binop_r_i_round;
		shared_vars.binop_round (2, 2) = fort_hfp_math$binop_r_r_round;
		shared_vars.binop_round (2, 3) = fort_hfp_math$binop_r_dp_round;
		shared_vars.binop_round (2, 4) = fort_hfp_math$binop_r_cp_round;
		shared_vars.binop_round (2, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (2, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (3, 1) = fort_hfp_math$binop_dp_i_round;
		shared_vars.binop_round (3, 2) = fort_hfp_math$binop_dp_r_round;
		shared_vars.binop_round (3, 3) = fort_hfp_math$binop_dp_dp_round;
		shared_vars.binop_round (3, 4) = fort_hfp_math$binop_dp_cp_round;
		shared_vars.binop_round (3, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (3, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (4, 1) = fort_hfp_math$binop_cp_i_round;
		shared_vars.binop_round (4, 2) = fort_hfp_math$binop_cp_r_round;
		shared_vars.binop_round (4, 3) = fort_hfp_math$binop_cp_dp_round;
		shared_vars.binop_round (4, 4) = fort_hfp_math$binop_cp_cp_round;
		shared_vars.binop_round (4, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (4, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (5, 1) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (5, 2) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (5, 3) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (5, 4) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (5, 5) = fort_hfp_math$binop_lg_lg;
		shared_vars.binop_round (5, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 1) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 2) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 3) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 4) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_round (6, 6) = fort_hfp_math$binop_ch_ch;

		shared_vars.binop_trunc (1, 1) = fort_hfp_math$binop_i_i_trunc;
		shared_vars.binop_trunc (1, 2) = fort_hfp_math$binop_i_r_trunc;
		shared_vars.binop_trunc (1, 3) = fort_hfp_math$binop_i_dp_trunc;
		shared_vars.binop_trunc (1, 4) = fort_hfp_math$binop_i_cp_trunc;
		shared_vars.binop_trunc (1, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (1, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (2, 1) = fort_hfp_math$binop_r_i_trunc;
		shared_vars.binop_trunc (2, 2) = fort_hfp_math$binop_r_r_trunc;
		shared_vars.binop_trunc (2, 3) = fort_hfp_math$binop_r_dp_trunc;
		shared_vars.binop_trunc (2, 4) = fort_hfp_math$binop_r_cp_trunc;
		shared_vars.binop_trunc (2, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (2, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (3, 1) = fort_hfp_math$binop_dp_i_trunc;
		shared_vars.binop_trunc (3, 2) = fort_hfp_math$binop_dp_r_trunc;
		shared_vars.binop_trunc (3, 3) = fort_hfp_math$binop_dp_dp_trunc;
		shared_vars.binop_trunc (3, 4) = fort_hfp_math$binop_dp_cp_trunc;
		shared_vars.binop_trunc (3, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (3, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (4, 1) = fort_hfp_math$binop_cp_i_trunc;
		shared_vars.binop_trunc (4, 2) = fort_hfp_math$binop_cp_r_trunc;
		shared_vars.binop_trunc (4, 3) = fort_hfp_math$binop_cp_dp_trunc;
		shared_vars.binop_trunc (4, 4) = fort_hfp_math$binop_cp_cp_trunc;
		shared_vars.binop_trunc (4, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (4, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 1) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 2) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 3) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 4) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 5) = fort_hfp_math$binop_lg_lg;
		shared_vars.binop_trunc (5, 6) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 1) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 2) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 3) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 4) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 5) = fort_hfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 6) = fort_hfp_math$binop_ch_ch;

		shared_vars.comp_parm (1, 1) = fort_hfp_math$comp_i_i;
		shared_vars.comp_parm (1, 2) = fort_hfp_math$comp_i_r;
		shared_vars.comp_parm (1, 3) = fort_hfp_math$comp_i_dp;
		shared_vars.comp_parm (1, 4) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (1, 5) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (1, 6) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (2, 1) = fort_hfp_math$comp_r_i;
		shared_vars.comp_parm (2, 2) = fort_hfp_math$comp_r_r;
		shared_vars.comp_parm (2, 3) = fort_hfp_math$comp_r_dp;
		shared_vars.comp_parm (2, 4) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (2, 5) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (2, 6) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (3, 1) = fort_hfp_math$comp_dp_i;
		shared_vars.comp_parm (3, 2) = fort_hfp_math$comp_dp_r;
		shared_vars.comp_parm (3, 3) = fort_hfp_math$comp_dp_dp;
		shared_vars.comp_parm (3, 4) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (3, 5) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (3, 6) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (4, 1) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (4, 2) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (4, 3) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (4, 4) = fort_hfp_math$comp_cp_cp;
		shared_vars.comp_parm (4, 5) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (4, 6) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (5, 1) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (5, 2) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (5, 3) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (5, 4) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (5, 5) = fort_hfp_math$comp_lg_lg;
		shared_vars.comp_parm (5, 6) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 1) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 2) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 3) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 4) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 5) = fort_hfp_math$bad_data_types;
		shared_vars.comp_parm (6, 6) = fort_hfp_math$comp_ch_ch;

		shared_vars.conv_round (1, 1) = fort_hfp_math$unary_no_op;
		shared_vars.conv_round (1, 2) = fort_hfp_math$conv_r_to_i_round;
		shared_vars.conv_round (1, 3) = fort_hfp_math$conv_dp_to_i_round;
		shared_vars.conv_round (1, 4) = fort_hfp_math$conv_cp_to_i_round;
		shared_vars.conv_round (1, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (1, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (2, 1) = fort_hfp_math$conv_i_to_r_round;
		shared_vars.conv_round (2, 2) = fort_hfp_math$unary_no_op;
		shared_vars.conv_round (2, 3) = fort_hfp_math$conv_dp_to_r_round;
		shared_vars.conv_round (2, 4) = fort_hfp_math$conv_cp_to_r_round;
		shared_vars.conv_round (2, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (2, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (3, 1) = fort_hfp_math$conv_i_to_dp_round;
		shared_vars.conv_round (3, 2) = fort_hfp_math$conv_r_to_dp_round;
		shared_vars.conv_round (3, 3) = fort_hfp_math$unary_no_op;
		shared_vars.conv_round (3, 4) = fort_hfp_math$conv_cp_to_dp_round;
		shared_vars.conv_round (3, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (3, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (4, 1) = fort_hfp_math$conv_i_to_cp_round;
		shared_vars.conv_round (4, 2) = fort_hfp_math$conv_r_to_cp_round;
		shared_vars.conv_round (4, 3) = fort_hfp_math$conv_dp_to_cp_round;
		shared_vars.conv_round (4, 4) = fort_hfp_math$unary_no_op;
		shared_vars.conv_round (4, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (4, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (5, 1) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (5, 2) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (5, 3) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (5, 4) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (5, 5) = fort_hfp_math$unary_no_op;
		shared_vars.conv_round (5, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 1) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 2) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 3) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 4) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_round (6, 6) = fort_hfp_math$conv_ch_to_ch;

		shared_vars.conv_trunc (1, 1) = fort_hfp_math$unary_no_op;
		shared_vars.conv_trunc (1, 2) = fort_hfp_math$conv_r_to_i_trunc;
		shared_vars.conv_trunc (1, 3) = fort_hfp_math$conv_dp_to_i_trunc;
		shared_vars.conv_trunc (1, 4) = fort_hfp_math$conv_cp_to_i_trunc;
		shared_vars.conv_trunc (1, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (1, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (2, 1) = fort_hfp_math$conv_i_to_r_trunc;
		shared_vars.conv_trunc (2, 2) = fort_hfp_math$unary_no_op;
		shared_vars.conv_trunc (2, 3) = fort_hfp_math$conv_dp_to_r_trunc;
		shared_vars.conv_trunc (2, 4) = fort_hfp_math$conv_cp_to_r_trunc;
		shared_vars.conv_trunc (2, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (2, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (3, 1) = fort_hfp_math$conv_i_to_dp_trunc;
		shared_vars.conv_trunc (3, 2) = fort_hfp_math$conv_r_to_dp_trunc;
		shared_vars.conv_trunc (3, 3) = fort_hfp_math$unary_no_op;
		shared_vars.conv_trunc (3, 4) = fort_hfp_math$conv_cp_to_dp_trunc;
		shared_vars.conv_trunc (3, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (3, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (4, 1) = fort_hfp_math$conv_i_to_cp_trunc;
		shared_vars.conv_trunc (4, 2) = fort_hfp_math$conv_r_to_cp_trunc;
		shared_vars.conv_trunc (4, 3) = fort_hfp_math$conv_dp_to_cp_trunc;
		shared_vars.conv_trunc (4, 4) = fort_hfp_math$unary_no_op;
		shared_vars.conv_trunc (4, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (4, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 1) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 2) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 3) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 4) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 5) = fort_hfp_math$unary_no_op;
		shared_vars.conv_trunc (5, 6) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 1) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 2) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 3) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 4) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 5) = fort_hfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 6) = fort_hfp_math$conv_ch_to_ch;
	     end;
	else do;
		shared_vars.binop_round (1, 1) = fort_bfp_math$binop_i_i_round;
		shared_vars.binop_round (1, 2) = fort_bfp_math$binop_i_r_round;
		shared_vars.binop_round (1, 3) = fort_bfp_math$binop_i_dp_round;
		shared_vars.binop_round (1, 4) = fort_bfp_math$binop_i_cp_round;
		shared_vars.binop_round (1, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (1, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (2, 1) = fort_bfp_math$binop_r_i_round;
		shared_vars.binop_round (2, 2) = fort_bfp_math$binop_r_r_round;
		shared_vars.binop_round (2, 3) = fort_bfp_math$binop_r_dp_round;
		shared_vars.binop_round (2, 4) = fort_bfp_math$binop_r_cp_round;
		shared_vars.binop_round (2, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (2, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (3, 1) = fort_bfp_math$binop_dp_i_round;
		shared_vars.binop_round (3, 2) = fort_bfp_math$binop_dp_r_round;
		shared_vars.binop_round (3, 3) = fort_bfp_math$binop_dp_dp_round;
		shared_vars.binop_round (3, 4) = fort_bfp_math$binop_dp_cp_round;
		shared_vars.binop_round (3, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (3, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (4, 1) = fort_bfp_math$binop_cp_i_round;
		shared_vars.binop_round (4, 2) = fort_bfp_math$binop_cp_r_round;
		shared_vars.binop_round (4, 3) = fort_bfp_math$binop_cp_dp_round;
		shared_vars.binop_round (4, 4) = fort_bfp_math$binop_cp_cp_round;
		shared_vars.binop_round (4, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (4, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (5, 1) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (5, 2) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (5, 3) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (5, 4) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (5, 5) = fort_bfp_math$binop_lg_lg;
		shared_vars.binop_round (5, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 1) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 2) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 3) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 4) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_round (6, 6) = fort_bfp_math$binop_ch_ch;

		shared_vars.binop_trunc (1, 1) = fort_bfp_math$binop_i_i_trunc;
		shared_vars.binop_trunc (1, 2) = fort_bfp_math$binop_i_r_trunc;
		shared_vars.binop_trunc (1, 3) = fort_bfp_math$binop_i_dp_trunc;
		shared_vars.binop_trunc (1, 4) = fort_bfp_math$binop_i_cp_trunc;
		shared_vars.binop_trunc (1, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (1, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (2, 1) = fort_bfp_math$binop_r_i_trunc;
		shared_vars.binop_trunc (2, 2) = fort_bfp_math$binop_r_r_trunc;
		shared_vars.binop_trunc (2, 3) = fort_bfp_math$binop_r_dp_trunc;
		shared_vars.binop_trunc (2, 4) = fort_bfp_math$binop_r_cp_trunc;
		shared_vars.binop_trunc (2, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (2, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (3, 1) = fort_bfp_math$binop_dp_i_trunc;
		shared_vars.binop_trunc (3, 2) = fort_bfp_math$binop_dp_r_trunc;
		shared_vars.binop_trunc (3, 3) = fort_bfp_math$binop_dp_dp_trunc;
		shared_vars.binop_trunc (3, 4) = fort_bfp_math$binop_dp_cp_trunc;
		shared_vars.binop_trunc (3, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (3, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (4, 1) = fort_bfp_math$binop_cp_i_trunc;
		shared_vars.binop_trunc (4, 2) = fort_bfp_math$binop_cp_r_trunc;
		shared_vars.binop_trunc (4, 3) = fort_bfp_math$binop_cp_dp_trunc;
		shared_vars.binop_trunc (4, 4) = fort_bfp_math$binop_cp_cp_trunc;
		shared_vars.binop_trunc (4, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (4, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 1) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 2) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 3) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 4) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (5, 5) = fort_bfp_math$binop_lg_lg;
		shared_vars.binop_trunc (5, 6) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 1) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 2) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 3) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 4) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 5) = fort_bfp_math$bad_data_types;
		shared_vars.binop_trunc (6, 6) = fort_bfp_math$binop_ch_ch;

		shared_vars.comp_parm (1, 1) = fort_bfp_math$comp_i_i;
		shared_vars.comp_parm (1, 2) = fort_bfp_math$comp_i_r;
		shared_vars.comp_parm (1, 3) = fort_bfp_math$comp_i_dp;
		shared_vars.comp_parm (1, 4) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (1, 5) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (1, 6) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (2, 1) = fort_bfp_math$comp_r_i;
		shared_vars.comp_parm (2, 2) = fort_bfp_math$comp_r_r;
		shared_vars.comp_parm (2, 3) = fort_bfp_math$comp_r_dp;
		shared_vars.comp_parm (2, 4) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (2, 5) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (2, 6) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (3, 1) = fort_bfp_math$comp_dp_i;
		shared_vars.comp_parm (3, 2) = fort_bfp_math$comp_dp_r;
		shared_vars.comp_parm (3, 3) = fort_bfp_math$comp_dp_dp;
		shared_vars.comp_parm (3, 4) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (3, 5) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (3, 6) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (4, 1) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (4, 2) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (4, 3) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (4, 4) = fort_bfp_math$comp_cp_cp;
		shared_vars.comp_parm (4, 5) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (4, 6) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (5, 1) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (5, 2) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (5, 3) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (5, 4) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (5, 5) = fort_bfp_math$comp_lg_lg;
		shared_vars.comp_parm (5, 6) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 1) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 2) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 3) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 4) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 5) = fort_bfp_math$bad_data_types;
		shared_vars.comp_parm (6, 6) = fort_bfp_math$comp_ch_ch;

		shared_vars.conv_round (1, 1) = fort_bfp_math$unary_no_op;
		shared_vars.conv_round (1, 2) = fort_bfp_math$conv_r_to_i_round;
		shared_vars.conv_round (1, 3) = fort_bfp_math$conv_dp_to_i_round;
		shared_vars.conv_round (1, 4) = fort_bfp_math$conv_cp_to_i_round;
		shared_vars.conv_round (1, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (1, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (2, 1) = fort_bfp_math$conv_i_to_r_round;
		shared_vars.conv_round (2, 2) = fort_bfp_math$unary_no_op;
		shared_vars.conv_round (2, 3) = fort_bfp_math$conv_dp_to_r_round;
		shared_vars.conv_round (2, 4) = fort_bfp_math$conv_cp_to_r_round;
		shared_vars.conv_round (2, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (2, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (3, 1) = fort_bfp_math$conv_i_to_dp_round;
		shared_vars.conv_round (3, 2) = fort_bfp_math$conv_r_to_dp_round;
		shared_vars.conv_round (3, 3) = fort_bfp_math$unary_no_op;
		shared_vars.conv_round (3, 4) = fort_bfp_math$conv_cp_to_dp_round;
		shared_vars.conv_round (3, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (3, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (4, 1) = fort_bfp_math$conv_i_to_cp_round;
		shared_vars.conv_round (4, 2) = fort_bfp_math$conv_r_to_cp_round;
		shared_vars.conv_round (4, 3) = fort_bfp_math$conv_dp_to_cp_round;
		shared_vars.conv_round (4, 4) = fort_bfp_math$unary_no_op;
		shared_vars.conv_round (4, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (4, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (5, 1) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (5, 2) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (5, 3) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (5, 4) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (5, 5) = fort_bfp_math$unary_no_op;
		shared_vars.conv_round (5, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 1) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 2) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 3) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 4) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_round (6, 6) = fort_bfp_math$conv_ch_to_ch;

		shared_vars.conv_trunc (1, 1) = fort_bfp_math$unary_no_op;
		shared_vars.conv_trunc (1, 2) = fort_bfp_math$conv_r_to_i_trunc;
		shared_vars.conv_trunc (1, 3) = fort_bfp_math$conv_dp_to_i_trunc;
		shared_vars.conv_trunc (1, 4) = fort_bfp_math$conv_cp_to_i_trunc;
		shared_vars.conv_trunc (1, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (1, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (2, 1) = fort_bfp_math$conv_i_to_r_trunc;
		shared_vars.conv_trunc (2, 2) = fort_bfp_math$unary_no_op;
		shared_vars.conv_trunc (2, 3) = fort_bfp_math$conv_dp_to_r_trunc;
		shared_vars.conv_trunc (2, 4) = fort_bfp_math$conv_cp_to_r_trunc;
		shared_vars.conv_trunc (2, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (2, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (3, 1) = fort_bfp_math$conv_i_to_dp_trunc;
		shared_vars.conv_trunc (3, 2) = fort_bfp_math$conv_r_to_dp_trunc;
		shared_vars.conv_trunc (3, 3) = fort_bfp_math$unary_no_op;
		shared_vars.conv_trunc (3, 4) = fort_bfp_math$conv_cp_to_dp_trunc;
		shared_vars.conv_trunc (3, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (3, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (4, 1) = fort_bfp_math$conv_i_to_cp_trunc;
		shared_vars.conv_trunc (4, 2) = fort_bfp_math$conv_r_to_cp_trunc;
		shared_vars.conv_trunc (4, 3) = fort_bfp_math$conv_dp_to_cp_trunc;
		shared_vars.conv_trunc (4, 4) = fort_bfp_math$unary_no_op;
		shared_vars.conv_trunc (4, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (4, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 1) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 2) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 3) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 4) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (5, 5) = fort_bfp_math$unary_no_op;
		shared_vars.conv_trunc (5, 6) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 1) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 2) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 3) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 4) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 5) = fort_bfp_math$unary_bad_data;
		shared_vars.conv_trunc (6, 6) = fort_bfp_math$conv_ch_to_ch;
	     end;

	do i = 1 to 6;
	     shared_vars.negate_round (i) = shared_vars.binop_round (i, i);
	     shared_vars.negate_trunc (i) = shared_vars.binop_trunc (i, i);
	end;
	return;					/* end of init_shared_vars */

     end /* fort_defaults_ */;




		    fort_display.pl1                12/27/84  0834.4rew 12/27/84  0751.7       61614



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

/* format: style3,^delnl,ifthenstmt,^indattr,indcom,indend,^inditerdo,^indnoniterdo,indnoniterend,linecom */
fort_display:
     proc options (variable);

	/* Written:	June 1976 eew

Modified:
	31 January 1977 David Levin - fix bug with "display" cmd.
	24 February 1977 Gabriel Chang - to display the quadruple region.
	25 October 1978 Paul Smee - changes for large common and arrays.
*/

dcl	display_entries$fdisplay entry (ptr) external static variable;

dcl	com_err_ entry options (variable);
dcl	cu_$arg_count entry (fixed bin);
dcl	cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl	cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl	arg_ptr ptr;
dcl	code fixed bin (35);
dcl	p_name char (12) aligned int static options (constant) init ("fort_display");

dcl	(i, nargs, arg_len) fixed bin;
dcl	j fixed bin (18);
dcl	arg_error bit (1) aligned;
dcl	decimal_base bit (1) aligned;
dcl	have_value bit (1) aligned;
dcl	starting_offset_set bit (1) aligned;
dcl	stopping_offset_set bit (1) aligned;
dcl	two_args bit (1) aligned;

dcl	an_arg char (arg_len) based (arg_ptr);

dcl	(addr, string, unspec, verify) builtin;

dcl	1 command_structure structure aligned,
%include fort_command_structure;

	/* Begin by initializing. */

	arg_error = "0"b;				/* check all arguments, but remember errors. */
	decimal_base = "0"b;			/* numeric base is octal by default */
	have_value = "0"b;				/* no numeric field encountered yet. */
	two_args = "0"b;				/* Off - one arg only; ON - one or two */
	starting_offset_set = "0"b;
	stopping_offset_set = "0"b;

	unspec (command_structure) = "0"b;

	/* Now get user arguments */

	call cu_$arg_count (nargs);

	if nargs = 0
	then do;					/* no user arguments, use default */
	     operator.display = "1"b;
	     end;

	/* process all user arguments */

	else do;

	     do i = 1 to nargs;

		call cu_$arg_ptr (i, arg_ptr, arg_len, code);
						/* get next argument string */

		if operator.declaration & dcl_name = ""
		then dcl_name = an_arg;

		else if an_arg = "dec"
		then if have_value
		     then do;
			call com_err_ (0, p_name, "Numeric value preceded ""dec"" keyword.");
			arg_error = "1"b;
			end;
		     else decimal_base = "1"b;

		else if an_arg = "op" | an_arg = "operand"
		then region.operand = "1"b;

		else if an_arg = "pl" | an_arg = "polish"
		then region.polish = "1"b;

		else if an_arg = "quad" | an_arg = "qd"
		then region.quadruple = "1"b;

		else if an_arg = "display" | an_arg = "ds"
		then if (string (operator.with_argument) ^= "0"b) & ^operator.display
		     then do;
			call com_err_ (0, p_name, "^a conflicts with previous argument", an_arg);
			arg_error = "1"b;
			end;
		     else two_args, operator.display = "1"b;

		else if an_arg = "walk"
		then options.walk = "1"b;

		else if an_arg = "dump"
		then operator.dump = "1"b;

		else if an_arg = "st"
		then if string (operator.with_argument) ^= "0"b
		     then do;
			call com_err_ (0, p_name, "^a conflicts with previous argument", an_arg);
			arg_error = "1"b;
			end;
		     else decimal_base, operator.stmnt = "1"b;

		else if an_arg = "dcl"
		then if string (operator.with_argument) ^= "0"b
		     then do;
			call com_err_ (0, p_name, "^a conflicts with previous argument", an_arg);
			arg_error = "1"b;
			end;
		     else operator.declaration = "1"b;

		else if an_arg = "cur_statement" | an_arg = "cur_stmnt" | an_arg = "cur_st"
		then operator.cur_stmnt = "1"b;

		else if an_arg = "brief" | an_arg = "bf"
		then options.brief = "1"b;

		else if an_arg = "consts"
		then operator.list_word_consts = "1"b;

		else if an_arg = "char_consts"
		then operator.list_char_constants = "1"b;

		else if an_arg = "lib_names"
		then operator.list_lib_names = "1"b;

		else if an_arg = "summary"
		then operator.node_summary = "1"b;

		else if an_arg = "bucket"
		then if string (operator.with_argument) ^= "0"b
		     then do;
			call com_err_ (0, p_name, "^a conflicts with previous argument", an_arg);
			arg_error = "1"b;
			end;
		     else decimal_base, two_args, operator.bucket = "1"b;

		else if substr (an_arg, 1, 10) = "subprogram" | an_arg = "subpgm"
		then operator.list_subprograms = "1"b;

		else if verify (substr (an_arg, 1, 1), "0123456789") = 0
		then do;
		     have_value = "1"b;

		     if string (region) = "0"b then region.operand = "1"b;

		     if string (operator.with_argument) = "0"b then operator.display = "1"b;

		     if decimal_base
		     then j = cv_dec_check_ (an_arg, code);
		     else j = cv_oct_check_ (an_arg, code);

		     if code ^= 0 | j < 0
		     then do;
			call com_err_ (0, p_name, "Syntax error in numeric constant. ^a", an_arg);
			arg_error = "1"b;
			end;

		     if starting_offset_set
		     then if stopping_offset_set | ^two_args
			then do;
			     call com_err_ (0, p_name, "Too many numeric constants.");
			     arg_error = "1"b;
			     end;
			else do;
			     stopping_offset = j;
			     stopping_offset_set = "1"b;
			     end;
		     else do;
			starting_offset = j;
			stopping_offset = j;
			starting_offset_set = "1"b;
			end;
		     end;

		else if an_arg = ""			/* ignore null arguments */
		then ;

		else do;
		     call com_err_ (0, p_name, "Unrecognized argument, ^a.", an_arg);
		     arg_error = "1"b;
		     end;
		end;				/* loop thru arguments */

	     /* validate our input */

	     if operator.declaration
	     then do;
		if dcl_name = ""
		then do;
		     call com_err_ (0, p_name, "No name given.");
		     arg_error = "1"b;
		     end;

		if have_value | decimal_base
		then do;
		     call com_err_ (0, p_name, "dcl conflicts with other arguments.");
		     arg_error = "1"b;
		     end;
		end;

	     else if operator.dump
	     then if string (region) = "0"b
		then region.operand = "1"b;
		else ;

	     else if have_value			/* remaining tests assume no value given */
	     then ;

	     else if string (operator.number_arg) ^= "0"b /* must have arg */
	     then do;
		call com_err_ (0, p_name, "No number given.");
		arg_error = "1"b;
		end;

	     else if string (operator.without_args) = "0"b
	     then do;
		call com_err_ (0, p_name, "No operator given.");
		arg_error = "1"b;
		end;

	     end;					/* do block for user arguments */

	if ^arg_error then call display_entries$fdisplay (addr (command_structure));

     end fort_display;




		    fort_eval_parm.pl1              11/10/88  1423.2r w 11/10/88  1336.9      120627



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



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 456.
                                                   END HISTORY COMMENTS */


/* format: style2 */
fort_eval_parm:
     procedure (p, target_id, error_code);

/* Procedure to do compile-time fortran expression evaluation.  Args are:

	p		pointer to parameter structure, holding most of the useful info  (IN-OUT)
	target_id		string identifying item being evaluated (for errors)  (IN)
	error_code	success/failure indicator	(OUT)

Written:
	July 1979 -- PES

Modified:
          03 June 1985 - BW - 456: Fix out_of_bounds error when error_code = -3.
	23 March 1981 - MEP - Add new parameters to keep track of parse's stack and alter character allocation.  
		Alter the calling sequence and internal logic, so that FEP creates the constant nodes, not the caller.
	27 July 1980 - MEP --  Changes to allow evaluation of F77 character mode parameter stuff.
	14 Sep 1979 -- PES -- Change to make result_data_type=0 mean don't convert result.
*/

%include fort_system_constants;
%include fort_nodes;
	declare 1 shared_globals	 aligned based (shared_ptr),
%include fort_shared_vars;
%include fort_options;
%include fort_parameter;

	declare p			 pointer;
	declare target_id		 character (*);
	declare error_code		 fixed binary (35);

	declare 1 parm_stk		 (0:700) aligned based (addr (stack (stack_index))),
		2 data_type	 fixed binary (4) unaligned,
		2 location	 fixed binary (18) unaligned,
						/* valid if char */
		2 pad1		 bit (12),
		2 value		 bit (72) unaligned;/* valid if ^ char */

	declare shared_ptr		 pointer;
	declare start_of_polish	 fixed binary (18);
	declare end_of_polish	 fixed binary (18);
	declare result_data_type	 fixed binary (4);
	declare result_location	 fixed binary (18);
	declare desired_data_type	 fixed binary (4);
	declare rounding		 bit (1);
	declare max_stack		 fixed binary (18);
	declare stack_index		 fixed binary (18);

	declare (mode1, mode2)	 fixed binary (4) unsigned unaligned;
	declare based_value		 bit (72) based;

	declare (max_s_ndx, s_ndx)	 fixed binary;
	declare local_error_code	 fixed binary (35);
	declare i			 fixed binary;

	declare OS		 (0:operand_max_len - 1) bit (36) aligned based (operand_base);
	declare polish_string	 (0:polish_max_len - 1) fixed bin (19) aligned based (polish_base);
	declare stack		 (0:object_max_len - 1) bit (36) aligned based (object_base);

	declare polish_base		 pointer;
	declare object_base		 pointer;
	declare operand_base	 pointer;
	declare data_ptr		 pointer;

	declare (addr, currentsize, fixed, length, max, null, rel, size, substr)
				 builtin;

	declare (fixedoverflow, overflow, underflow, zerodivide)
				 condition;

	begin;					/* Because some noodge declared a var named
						   error in an include file
						   Begin block can be removed when
						   pl1 bug 1758 is fixed */

	     declare error		      condition;

	     shared_ptr = p -> parameter.shared_pointer;
	     desired_data_type = p -> parameter.desired_data_type;
	     rounding = p -> parameter.rounding;
	     start_of_polish = p -> parameter.start_of_polish;
	     end_of_polish = p -> parameter.end_of_polish;
	     stack_index = p -> parameter.stack_index;
	     max_stack = p -> parameter.max_stack;

	     on fixedoverflow go to fixedoverflow_condition;
	     on overflow go to overflow_condition;
	     on underflow go to underflow_condition;
	     on zerodivide go to zerodivide_condition;
	     on error go to error_condition;

	     if desired_data_type < 0 | desired_data_type > last_assigned_mode
						/* illegal data types */
	     then do;
		     error_code = -1;
		     call print_message (170);
		     call finish_up;
		     return;
		end;

	     local_error_code = 0;
	     s_ndx, max_s_ndx = 0;

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

/* error codes returned by the evaluation functions:

	 0 -- all ok
	-1 -- bad data types
	-2 -- operation not yet implemented
	-3 -- a non-constant operand was encountered
	-4 -- fixedoverflow condition was signalled
	-5 -- overflow condition was signalled
	-6 -- underflow condition was signalled
	-7 -- zerodivide condition was signalled
	-8 -- error condition was signalled
	-9 -- invalid operator encountered
*/

	     do i = start_of_polish to end_of_polish while (local_error_code = 0);

		if polish_string (i) > last_assigned_op
		then do;

/* it must be an operand and better be a constant */

			data_ptr = addr (OS (polish_string (i)));
			if data_ptr -> node.node_type = constant_node
			then do;

				parm_stk (s_ndx).data_type = data_ptr -> constant.data_type;
				parm_stk (s_ndx).value = data_ptr -> constant.value;
				s_ndx = s_ndx + 1;
				max_s_ndx = max (max_s_ndx, s_ndx);
			     end;

			else if data_ptr -> node.node_type = char_constant_node
			then do;
				parm_stk (s_ndx).data_type = char_mode;
				parm_stk (s_ndx).location = polish_string (i);
				s_ndx = s_ndx + 1;
				max_s_ndx = max (max_s_ndx, s_ndx);
			     end;

			else do;
				call print_message (171, addr (OS (polish_string (i))) -> symbol.name, target_id);
				local_error_code = -3;
			     end;
		     end;

		else if polish_string (i) = negate_op
		then do;
			if parm_stk (s_ndx - 1).data_type = char_mode
			then call bad_data_type;
			else if rounding
			then addr (parm_stk (s_ndx - 1).value) -> based_value =
				negate_round (parm_stk (s_ndx - 1).data_type)
				(6, addr (parm_stk (s_ndx - 1).value) -> based_value,
				addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);

			else addr (parm_stk (s_ndx - 1).value) -> based_value =
				negate_trunc (parm_stk (s_ndx - 1).data_type)
				(6, addr (parm_stk (s_ndx - 1).value) -> based_value,
				addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);
		     end;

		else if polish_string (i) > 1 & polish_string (i) < 7
						/* binary arithmetic  operators */
		then do;
			if parm_stk (s_ndx - 1).data_type = char_mode | parm_stk (s_ndx - 2).data_type = char_mode
			then call bad_data_type;
			else if rounding
			then addr (parm_stk (s_ndx - 2).value) -> based_value =
				binop_round (parm_stk (s_ndx - 2).data_type, parm_stk (s_ndx - 1).data_type)
				(polish_string (i) - 1, addr (parm_stk (s_ndx - 2).value) -> based_value,
				addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);

			else addr (parm_stk (s_ndx - 2).value) -> based_value =
				binop_trunc (parm_stk (s_ndx - 2).data_type, parm_stk (s_ndx - 1).data_type)
				(polish_string (i) - 1, addr (parm_stk (s_ndx - 2).value) -> based_value,
				addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);

			parm_stk (s_ndx - 2).data_type =
			     max (parm_stk (s_ndx - 1).data_type, parm_stk (s_ndx - 2).data_type);
			s_ndx = s_ndx - 1;
		     end;

		else if polish_string (i) > 7 & polish_string (i) < 14
						/* comparisons */
		then do;
			mode1 = parm_stk (s_ndx - 1).data_type;
			mode2 = parm_stk (s_ndx - 2).data_type;
			if mode1 ^= char_mode & mode2 ^= char_mode
			then do;
				addr (parm_stk (s_ndx - 2).value) -> based_value =
				     comp_parm (parm_stk (s_ndx - 2).data_type, parm_stk (s_ndx - 1).data_type)
				     (polish_string (i) - 1, addr (parm_stk (s_ndx - 2).value) -> based_value,
				     addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);

				parm_stk (s_ndx - 2).data_type = logical_mode;
				s_ndx = s_ndx - 1;
			     end;
			else if mode1 = char_mode & mode2 = char_mode
			then do;
				parm_stk (s_ndx - 2).value =
				     comp_chars (polish_string (i), (parm_stk (s_ndx - 2).location),
				     (parm_stk (s_ndx - 1).location));
				parm_stk (s_ndx - 2).data_type = logical_mode;
				s_ndx = s_ndx - 1;
			     end;
			else call bad_data_type;
		     end;

		else if polish_string (i) = not_op
		then if parm_stk (s_ndx - 1).data_type = logical_mode
		     then substr (parm_stk (s_ndx - 1).value, 1, 1) = ^substr (parm_stk (s_ndx - 1).value, 1, 1);
		     else call bad_operation;

		else if polish_string (i) = or_op | polish_string (i) = and_op
		then if parm_stk (s_ndx - 1).data_type = logical_mode & parm_stk (s_ndx - 1).data_type = logical_mode
		     then do;
			     if polish_string (i) = or_op
			     then parm_stk (s_ndx - 2).value =
				     parm_stk (s_ndx - 2).value | parm_stk (s_ndx - 1).value;
			     else parm_stk (s_ndx - 2).value =
				     parm_stk (s_ndx - 2).value & parm_stk (s_ndx - 1).value;
			     s_ndx = s_ndx - 1;
			end;
		     else call bad_operation;

		else if polish_string (i) = cat_op
		then do;
			if parm_stk (s_ndx - 2).data_type = char_mode & parm_stk (s_ndx - 1).data_type = char_mode
			then do;
				parm_stk (s_ndx - 2).location =
				     concat_char_cons ((parm_stk (s_ndx - 2).location),
				     (parm_stk (s_ndx - 1).location));
				s_ndx = s_ndx - 1;
			     end;
			else call bad_data_type;
		     end;

		else call bad_operation;

	     end;

	     if local_error_code = 0 & desired_data_type ^= 0 & desired_data_type ^= char_mode
	     then if rounding
		then addr (parm_stk (s_ndx - 1).value) -> based_value =
			conv_round (desired_data_type, parm_stk (s_ndx - 1).data_type)
			(addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);
		else addr (parm_stk (s_ndx - 1).value) -> based_value =
			conv_trunc (desired_data_type, parm_stk (s_ndx - 1).data_type)
			(addr (parm_stk (s_ndx - 1).value) -> based_value, local_error_code);

	     else if local_error_code = -1
	     then call print_message (172, target_id);

	     else if local_error_code = -2
	     then call print_message (173, target_id);

	     else if local_error_code = -3
	     then do;
		     error_code = local_error_code;
		     call finish_up;
		     return;
		end;

	     if desired_data_type ^= 0
	     then p -> parameter.result_data_type = desired_data_type;
	     else p -> parameter.result_data_type = parm_stk (s_ndx - 1).data_type;

	     if p -> parameter.result_data_type = char_mode
	     then p -> parameter.result_location = parm_stk (s_ndx - 1).location;
	     else p -> parameter.result_location =
		     create_constant ((p -> parameter.result_data_type), (parm_stk (s_ndx - 1).value));

	     error_code = local_error_code;

	     call finish_up;
	     return;

fixedoverflow_condition:
	     call print_message (174, "fixedoverflow", target_id);
	     error_code = -4;
	     call finish_up;
	     return;

overflow_condition:
	     call print_message (174, "overflow", target_id);
	     error_code = -5;
	     call finish_up;
	     return;

underflow_condition:
	     call print_message (174, "underflow", target_id);
	     error_code = -6;
	     call finish_up;
	     return;

zerodivide_condition:
	     call print_message (174, "zerodivide", target_id);
	     error_code = -7;
	     call finish_up;
	     return;

error_condition:
	     call print_message (174, "error", target_id);
	     error_code = -8;
	     call finish_up;
	     return;

	end;

finish_up:
     procedure;

	p -> parameter.max_stack = max (max_stack, binary (rel (addr (parm_stk (max_s_ndx))), 18));
	revert fixedoverflow, overflow, underflow, zerodivide, error;

     end finish_up;

comp_chars:
     procedure (op_id, oper1, oper2) returns (bit (72) aligned);

/* do the pl1 character comparisons, used to be in fort_parm_math */

	declare op_id		 fixed binary (19);
	declare (oper1, oper2)	 fixed binary (18);
	declare (ch1, ch2)		 pointer;

	ch1 = addr (OS (oper1));
	ch2 = addr (OS (oper2));
	goto comparison (op_id);

comparison (8):					/* less_op */
	return (ch1 -> char_constant.value < ch2 -> char_constant.value);

comparison (9):					/* less_or_equal_op */
	return (ch1 -> char_constant.value <= ch2 -> char_constant.value);

comparison (10):					/* equal_op */
	return (ch1 -> char_constant.value = ch2 -> char_constant.value);

comparison (11):					/* not_equal_op */
	return (ch1 -> char_constant.value ^= ch2 -> char_constant.value);

comparison (12):					/* greater_or_equal_op */
	return (ch1 -> char_constant.value >= ch2 -> char_constant.value);

comparison (13):					/* greater_op */
	return (ch1 -> char_constant.value > ch2 -> char_constant.value);

     end comp_chars;

concat_char_cons:
     procedure (ch1, ch2) returns (fixed binary (18));

/*  procedure to do the concatenation and store the result in a temp char_cons */

	declare (ch1, ch2)		 fixed binary (18);

	return (create_char_constant (addr (OS (ch1)) -> char_constant.value || addr (OS (ch2)) -> char_constant.value))
	     ;

     end concat_char_cons;

bad_data_type:
     procedure ();
	call print_message (176, target_id);
	local_error_code = -3;
	return;
     end bad_data_type;


bad_operation:
     procedure ();
	call print_message (175, target_id);
	local_error_code = -9;
	return;
     end bad_operation;


     end fort_eval_parm;




		    fort_hfp_math.fortran           12/27/84  0834.4r w 12/27/84  0751.7        4338



c ******************************************
c *                                        *
c * Copyright, (C) Honeywell Limited, 1984 *
c *                                        *
c ******************************************

%global hfp;
c     =======================================
c     do nothing program that sets the global flag hfp
c     for the fort_math include file.
c
c     Written: 03/28/84 by M. Mabey
c     =======================================

%include fort_math




*/
                                          -----------------------------------------------------------


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

*/