



		    alm.pl1                         06/09/89  1001.8rew 06/09/89  0807.5       93924



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Rewritten to use the new alm_ subroutine.
  2) change(86-11-14,JRGray), approve(86-11-14,MCR7568),
     audit(86-11-21,RWaters), install(86-11-26,MR12.0-1228):
     Also MCR7572. Modified to update the version field to 7.3 .
  3) change(87-04-22,JRGray), approve(87-07-03,MCR7689),
     audit(87-07-09,RWaters), install(87-11-02,MR12.2-1001):
     Modified for fix for alm 19: change version field to 7.4 .
  4) change(88-03-21,JRGray), approve(88-08-05,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     Modified for Symbol Table support, updated version.
  5) change(89-04-17,JRGray), approve(89-04-17,MCR8078), audit(89-04-18,Huen),
     install(89-06-09,MR12.3-1055):
     Modified to allow for archive component pathnames.
                                                   END HISTORY COMMENTS */


alm:     proc;
/* Completely rewritten August 4 1985 by R. Gray to fix various bugs, 
   and call the new alm_ subroutine.
*/

dcl	usage_string char(31) int static options(constant) init("Usage: alm path {-control_args}");

dcl	alm_ entry(ptr, ptr, fixed bin, fixed bin(35));
dcl	com_err_ entry options(variable);
dcl	cu_$arg_count entry(fixed bin, fixed bin(35));
dcl	cu_$arg_ptr entry(fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl	expand_pathname_$component_add_suffix entry(char(*), char(*), char(*), char(*), char(*), fixed bin(35));
dcl	find_source_file_ entry (char(*), char(*), char(*), ptr, fixed bin(24), fixed bin(35));
dcl	get_wdir_ entry returns(char(168));
dcl	ioa_ entry options(variable);
dcl	terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35));
dcl	tssi_$clean_up_file entry(ptr, ptr);
dcl	tssi_$clean_up_segment entry(ptr);
dcl	tssi_$get_file entry(char(*), char(*), ptr, ptr, ptr, fixed bin(35));
dcl	tssi_$get_segment entry(char(*), char(*), ptr, ptr, fixed bin(35));
dcl	tssi_$finish_segment entry(ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));
dcl	tssi_$finish_file entry(ptr, fixed bin, fixed bin(24), bit(36) aligned, ptr, fixed bin(35));

dcl	(addr, after, before, char, hbound, ltrim, null, rtrim, substr) builtin;

dcl	argument_ptr ptr;
dcl	argument_len fixed bin(21);
dcl	argument_count fixed bin;
dcl	argument char(argument_len) based(argument_ptr);
dcl	cleanup condition;

dcl	error_table_$badopt external static fixed bin(35);
dcl	error_table_$noarg external static fixed bin(35);
dcl	error_table_$too_many_args external static fixed bin(35);

dcl	alm_severity_ external static fixed bin;

dcl	(dirname, working_dir) char(168);
dcl	ec fixed bin(35);
dcl	(entryname, compname) char(33);	/* length is 33 instead of 32 to insure trailing blank */
dcl	(i, j) fixed bin;
dcl	(object_aclinfo_ptr, list_aclinfo_ptr) ptr;
dcl	objectname char(32);

dcl	01 alm_arguments, 	/* like alm_args */
	  02 version char(8),
	  02 arg_count fixed bin,
	  02 arg(400),
	    03 arg_ptr ptr,
	    03 len fixed bin(21);

dcl	01 global_info like alm_info;

%include alm_info;

	/* initialization of alm_info structure */
	global_info.version = ALM_INFO_V1;
	global_info.symbols = "1"b;	/* default include symbols in list */
	global_info.brief = "0"b;
	global_info.list = "0"b;
	global_info.table = "0"b;
	global_info.brief_table = "0"b;
	global_info.target = "";

	global_info.generator = "alm";
	global_info.gen_number = 8;
	global_info.gen_version = "ALM Version 8.14 March 1989";
	global_info.gen_created = 0; /* alm_ will calculate this field */

	global_info.option_string = "";
	global_info.source_path = "";
	global_info.source_entryname = "";
	global_info.source_ptr = null();
	global_info.source_bc = 0;
	global_info.object_ptr = null();
	global_info.object_bc = 0;
	global_info.list_fcb_ptr = null();
	global_info.list_component_ptr = null();
	global_info.list_bc = 0;
	global_info.list_component = 0;

	alm_arguments.version = ALM_ARGS_V1;
	alm_arguments.arg_count = 0;

	alm_severity_ = 5;
	object_aclinfo_ptr = null();
	list_aclinfo_ptr = null();
	call cu_$arg_count(argument_count, ec);
	if ec ^= 0 then call error(ec, "");


	do i = 1 to argument_count;
	     call cu_$arg_ptr(i, argument_ptr, argument_len, ec);
	     if ec ^= 0 then call error(ec, "Argument #" || ltrim(char(i)));
	     if substr(argument, 1, 1) ^= "-"
	     then if global_info.source_path = "" then global_info.source_path = argument;
	     else call error(0, "Only one pathname can be specified");
	     else if argument = "-list" | argument = "-ls" then global_info.list = "1"b;
	     else if argument = "-no_list" | argument = "-nls" then global_info.list = "0"b;
	     else if argument = "-symbols" | argument = "-sb" then global_info.symbols = "1"b;
	     else if argument = "-no_symbols" | argument = "-nsb" then global_info.symbols = "0"b;
	     else if argument = "-brief" | argument = "-bf" then global_info.brief = "1"b;
	     else if argument = "-no_brief" | argument = "-nbf" then global_info.brief = "0"b;
	     else if argument = "-table" | argument = "-tb" then global_info.table = "1"b;
	     else if argument = "-no_table" | argument = "-ntb" then global_info.table = "0"b;
	     else if argument = "-brief_table" | argument = "-bftb" then global_info.brief_table = "1"b;
	     else if argument = "-no_brief_table" | argument = "-nbftb" then global_info.brief_table = "0"b;
	     else if argument = "-arguments" | argument = "-ag" then do;
		alm_arguments.arg_count = argument_count - i;
		if alm_arguments.arg_count > hbound(alm_arguments.arg, 1) then call error(error_table_$too_many_args, char(alm_arguments.arg_count));
		do j = 1 to alm_arguments.arg_count;
		     call cu_$arg_ptr(i + j, alm_arguments.arg_ptr(j), alm_arguments.len(j), ec);
		     if ec ^= 0 then call error(ec, "Argument #" || ltrim(char(i + j)));
		end;
		i = argument_count;
	     end;
	     else if argument = "-target" | argument = "-tgt" then do;
		i = i + 1;
		call cu_$arg_ptr(i, argument_ptr, argument_len, ec);
		if ec ^= 0 then call error(ec, "Target value.");
		global_info.target = argument;
	     end;
	     else call error(error_table_$badopt, argument);
	end;

	if global_info.source_path = "" then call error(error_table_$noarg, usage_string);
	/* get absolute pathname. Can't use absolute_pathname_ cause it hates archives */
	call expand_pathname_$component_add_suffix(global_info.source_path, "alm", dirname, entryname, compname, ec);
	if ec ^= 0 then call error(ec, global_info.source_path);
	if compname = "" then global_info.source_path = rtrim(dirname, "> ") || ">" || rtrim(entryname);
	else global_info.source_path = rtrim(dirname, "> ") || ">" || before(entryname, ".archive ") || "::" || rtrim(compname);

	if global_info.target = "" then global_info.option_string = ""; else global_info.option_string = "-target " || global_info.target || " ";
	if global_info.list then global_info.option_string = global_info.option_string || "list ";
	if global_info.symbols then global_info.option_string = global_info.option_string || "symbols ";
	if global_info.brief then global_info.option_string = global_info.option_string || "brief ";
	if global_info.table then global_info.option_string = global_info.option_string || "table ";
	if global_info.brief_table then global_info.option_string = global_info.option_string || "brief_table ";
	if alm_arguments.arg_count > 0 then do;
		global_info.option_string = global_info.option_string || "-arguments ";
		do i = 1 to alm_arguments.arg_count;
			argument_ptr = alm_arguments.arg_ptr(i);
			argument_len = alm_arguments.len(i);
			global_info.option_string = global_info.option_string || argument || " ";
		  end;
	  end;


	call find_source_file_(global_info.source_path, "alm", global_info.source_entryname,
	  global_info.source_ptr, global_info.source_bc, ec);
	if ec^=0 then call error(ec, global_info.source_path);

on	cleanup call clean_up;

	working_dir = get_wdir_();
	objectname = before(global_info.source_entryname || " ", ".alm ");
	objectname = before(objectname, ".ex ");
	call tssi_$get_segment(working_dir, objectname, global_info.object_ptr,  object_aclinfo_ptr, ec);
	if ec^=0 then call error(ec, "While accessing object segment.");

	if global_info.list then do;
		call tssi_$get_file(working_dir, rtrim(objectname) || ".list",
		  global_info.list_component_ptr, list_aclinfo_ptr, global_info.list_fcb_ptr, ec);
		if ec^=0 then call error(ec, "While accessing listing file.");
	  end;

	if ^global_info.brief then call ioa_("ALM "  ||
	  before(after(global_info.gen_version, "Version "), " "));

	call alm_(addr(global_info), addr(alm_arguments), alm_severity_, ec);
	if ec ^= 0 then call com_err_(ec, "alm", global_info.source_path);

	if global_info.list_fcb_ptr ^= null() then do;
		call tssi_$finish_file(global_info.list_fcb_ptr, global_info.list_component,
		  global_info.list_bc, "101"b, list_aclinfo_ptr, ec);
		if ec^=0 then call error(ec, "While finishing with listing file.");
	  end;

	call tssi_$finish_segment(global_info.object_ptr, global_info.object_bc,
	  "110"b, object_aclinfo_ptr, ec);
	if ec^=0 then call error(ec, "While finishing with object segment.");

	call terminate_file_(global_info.source_ptr, global_info.source_bc, "001"b, ec);
	if ec^=0 then call error(ec, "While terminating source segment.");
abort:	return;

error:     proc(code, string);
dcl	code fixed bin(35);
dcl	string char(*);

	call com_err_(code, "alm", string);
	call clean_up;
	goto abort;
end error;

clean_up:	proc;
	if list_aclinfo_ptr ^= null() then call tssi_$clean_up_file(global_info.list_fcb_ptr, list_aclinfo_ptr);
	if object_aclinfo_ptr ^= null() then call tssi_$clean_up_segment(object_aclinfo_ptr);
	if global_info.source_ptr ^= null() then call terminate_file_(global_info.source_ptr, 0, "001"b, 0);
end clean_up;

end alm;




		    alm_.pl1                        10/17/88  1013.9r w 10/17/88  0938.3      109341



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Written to be a general subroutine level interface to ALM.
  2) change(86-11-24,JRGray), approve(86-11-24,MCR7507),
     audit(86-11-25,RWaters), install(86-11-26,MR12.0-1228):
     Changed (PBF) to properly return error_codes for various error conditions.
                                                   END HISTORY COMMENTS */

alm_:	proc(ALM_INFO_PTR, ALM_ARGS_PTR, severity, code);

/*	This procedure was written to provide a generalized subroutine
	interface to ALM. This will allow various subsystems and compiler
	to utilize ALM.
*/

/*	P A R A M E T E R S	*/
dcl	(ALM_INFO_PTR, ALM_ARGS_PTR) ptr parameter;
dcl	severity fixed bin parameter;
dcl	code fixed bin(35) parameter;

/*	S T A T I C   S E C T I O N	*/
dcl	recursive bit(1) static init("0"b);

/*	A U T O M A T I C   S E C T I O N       */
dcl	argument char(argument_len) based(argument_ptr);
dcl	argument_len fixed bin(21);
dcl	argument_ptr ptr;
dcl	bit_count fixed bin(24);
dcl	caller_ptr ptr;
dcl	canonical_str char(24);
dcl	date char(24) aligned;
dcl	decor fixed bin(35);
dcl	default_str char(24);
dcl	first_time_thru bit(1);
dcl	(i, n) fixed bin;
dcl	no_target_given bit(1) init("0"b);
dcl	target_value fixed bin;
dcl	temp_ptrs(2) ptr init((2) null);
dcl	trimmed_entryname char(32);

dcl	cleanup condition;
dcl	null builtin;

dcl	alm_cross_reference_ entry;
dcl	alm_include_file_$first_file entry(char(*));
dcl	alm_merge_$alm_merge_ entry;
dcl	clock_ entry returns(fixed bin(71));
dcl	com_err_ entry options(variable);
dcl	cu_$caller_ptr entry returns(ptr);
dcl	date_time_ entry(fixed bin(71), char(*) aligned);
dcl	get_group_id_ entry returns(char(32) aligned);
dcl	get_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));
dcl	glpl_$genlas entry;
dcl	hcs_$get_max_length_seg entry(ptr, fixed bin(19), fixed bin(35));
dcl	hcs_$status_mins entry(ptr, fixed bin(2), fixed bin(24), fixed bin(35));
dcl	lstman_$blkasn entry(fixed bin(17), fixed bin(17), fixed bin(17), fixed bin(17)) returns(fixed bin(17));
dcl	make_alm_object_map_ entry(fixed bin(26));
dcl	make_object_map_ entry(ptr, fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(35));
dcl	mexp_$cleanup entry;
dcl	mexp_$init entry(fixed bin(35));
dcl	object_info_$brief entry(ptr, fixed bin(24), ptr, fixed bin(35));
dcl	pakbit_$pakbit_ entry;
dcl	pass1_$pass1_ entry( fixed bin(35), fixed bin(17), bit(1), bit(1));
dcl	pass2_$pass2_ entry( fixed bin(35), fixed bin(17), bit(1), bit(1));
dcl	postp1_$postp1_ entry;
dcl	postp2_$postp2_ entry;
dcl	prlst_$prlst_ entry(char(*));
dcl	prnter_$general_abort entry(char(*));
dcl	release_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));
dcl	system_type_ entry(char(*), char(*), fixed bin(17), fixed bin(35));

dcl	eb_data_$abort_assembly external static label;
dcl	eb_data_$alm_arg_ptr ptr ext;
dcl	eb_data_$alm_arg_count fixed bin ext;
dcl	eb_data_$curr_char_no fixed bin(17) external;
dcl	eb_data_$lavptr ptr ext;	/* ptr to ALM's scratch segment of list structures */
dcl	eb_data_$list_component external fixed bin;
dcl	eb_data_$listing_max_length fixed bin(19) ext;
dcl	eb_data_$mexp_argno fixed bin ext;
dcl	1 eb_data_$oulst external, 2 oulst char(68) aligned;
dcl	eb_data_$per_process_static_sw fixed bin ext;
dcl	eb_data_$varcom_size external fixed bin(17);
dcl	eb_data_$who_am_I char(12) external;
dcl	error_table_$null_info_ptr fixed bin(35) external;
dcl	error_table_$request_pending fixed bin(35) external;
dcl	error_table_$translation_aborted fixed bin(35) external;
dcl	error_table_$translation_failed fixed bin(35) external;
dcl	error_table_$unimplemented_version fixed bin(35) external;
dcl	error_table_$zero_length_seg fixed bin(35) external;
dcl	new_sthedr_$generator external static char(8);
dcl	new_sthedr_$gen_number external static fixed bin;

dcl	01 OBJECT_INFO like object_info;

%include alm_info;
%include alm_data;
%include alm_options;
%include concom;
%include erflgs;
%include lstcom;
%include object_info;
%include objnfo;
%include segnfo;
%include std_symbol_header;
%include sthedr;
%include system_types;
%include varcom;

	severity = 5;
	alm_info_ptr = ALM_INFO_PTR;
	alm_args_ptr = ALM_ARGS_PTR;
	if alm_info_ptr = null | alm_args_ptr = null then do;
		code = error_table_$null_info_ptr;
		return;
	  end;
	if alm_info.version ^= ALM_INFO_V1 | alm_args.version ^= ALM_ARGS_V1 then do;
		code = error_table_$unimplemented_version;
		return;
	  end;
	if recursive then do;
		code = error_table_$request_pending;
		return;
	  end;
	if alm_info.source_ptr = null | alm_info.object_ptr = null then do;
		code = error_table_$null_info_ptr;
		return;
	  end;
	if alm_info.source_bc = 0 then do;
		code = error_table_$zero_length_seg;
		return;
	  end;

	new_sthedr_$generator = alm_info.generator;
	new_sthedr_$gen_number = alm_info.gen_number;
	new_sthedr_$alm_version_name = alm_info.gen_version;
	if alm_info.gen_created = 0 then do;
		caller_ptr = ptr(cu_$caller_ptr(), 0);
		call hcs_$status_mins(caller_ptr, (0), bit_count, code); /* get bit count for next call */
		if code ^= 0 then sthedr_$alm_creation_date = clock();
		else do;
		            OBJECT_INFO.version_number = object_info_version_2;
			  call object_info_$brief(caller_ptr, bit_count, addr(OBJECT_INFO), code); /* get creation date */
			  if code ^= 0 then sthedr_$alm_creation_date = clock();
			  else sthedr_$alm_creation_date = OBJECT_INFO.symbp -> std_symbol_header.object_created;
		  end;
	  end;
	else sthedr_$alm_creation_date = alm_info.gen_created;
	new_sthedr_$alm_creation_date = sthedr_$alm_creation_date;

on        cleanup call cleanup_handler;
	recursive = "1"b;

	if alm_info.brief then tquietsw = 1;
	else tquietsw = 0;

	if alm_info.list then do;
		tnolst = 0;
		call hcs_$get_max_length_seg(alm_info.list_component_ptr, eb_data_$listing_max_length, code);
		if code ^=0 then call complain("Unable to get max length of listing segment.");
	  end;
	else tnolst = 1;

	if alm_info.symbols then tnoxref = tnolst;	/* only set when there is to be a list */
	else tnoxref = 1;

	if alm_info.target = "" then target_value = L68_SYSTEM;
	/* target = SYSTEM_TYPE_NAME(L68_SYSTEM); This did something once... */
	else do;
		call system_type_((alm_info.target), canonical_str, target_value, code);
		if code ^= 0 then call complain(alm_info.target);
	  end;


	tcheckcompatibility = 0;
	tnewmachine, tnewcall, tnewobject = 1;

	trimmed_entryname = before(alm_info.source_entryname || " ", ".alm ");
	trimmed_entryname = before(trimmed_entryname, ".ex ");


	call get_temp_segments_("alm_", temp_ptrs, code);
	if code^=0 then call complain("Unable to get temp segments.");
	eb_data_$lavptr = temp_ptrs(1);
	eb_data_$segnfo.scrtch = temp_ptrs(2);
	eb_data_$abort_assembly = abort;

	eb_data_$segnfo.text = alm_info.object_ptr;
	eb_data_$segnfo.source = alm_info.source_ptr;
	eb_data_$segnfo.list = alm_info.list_component_ptr;
	eb_data_$segnfo.list_fcb = alm_info.list_fcb_ptr;
	eb_data_$segnfo.srclen = divide(alm_info.source_bc, 9, 21, 0);
	eb_data_$segnfo.lstlen = 0;
	eb_data_$list_component = 0;
	eb_data_$alm_arg_count = alm_args.arg_count;
	eb_data_$alm_arg_ptr = addr(alm_args.arg);
	eb_data_$mexp_argno = 0;
	severity = 4;		/* in case of aborts */

/* - - - - - - - - - Begin processing the assembly - - - - - - - - */
	do i = 1 to eb_data_$varcom_size;	/* clear all of varcom */
		brk(i) = 0;
	  end;
	brk(1), nbrk(1) = ibsp;	/* set the break characters */
	stkc = 40;	/* set up the stack counter */
	nboxes = 211;	/* set up the number of boxes */	/*THIS COULD BE DONE STATICALLY INSTAIN eb_data_ */
	ndpcls = addr(pclst);	/* set up the ends of the lists */
	ndltls = addr(litlst);	/* "            "             " */
	ndlkls = addr(lnklst);	/* "            "             " */
	ndtvls = addr(tvlst);	/* "            "             " */
	do i = 1 to 36;		/* clear the error flags */
		flgvec(i) = 0;
	  end;
	tfatal = 0;		/* most severe error */
	eb_data_$per_process_static_sw = 0;

	call glpl_$genlas;			/* initialize free storage */

	sthedr_$seg_name = trimmed_entryname;
	new_sthedr_$comment = alm_info.option_string;
	new_sthedr_$user_id = get_group_id_();
	sthedr_$time_of_translation, new_sthedr_$time_of_translation = clock_();

	call date_time_(sthedr_$time_of_translation, date);
	call prlst_$prlst_("ASSEMBLY LISTING OF SEGMENT " || alm_info.source_path);
	call prlst_$prlst_("ASSEMBLED ON:	" || date);
	call prlst_$prlst_("OPTIONS USED:	" || alm_info.option_string);
	call prlst_$prlst_("ASSEMBLED BY:	" || new_sthedr_$alm_version_name);
	call date_time_(sthedr_$alm_creation_date, date);
	call prlst_$prlst_("ASSEMBLER CREATED:	" || date);
	call prlst_$prlst_("");		/* add a blank line */

	txtlen, itxpc, ilkpc, istpc, idfpc, itxcnt, ilkcnt, istcnt, idfcnt = 0;
	eb_data_$curr_char_no = 0;
	myblk = lstman_$blkasn(1, 0, 0, 0);
	tpass1 = 1;
	call alm_include_file_$first_file(trimmed_entryname);
	binlin = 0;
	call mexp_$init(code);
	if code ^= 0 then goto abort;

	/* The next few lines initialize decor to the current system type.
	   The decor_name array(data1)is built by alm_table_tool, who checks
	   that decor names and system_type_ names are in correspondence */

	call system_type_("", default_str, (0), code);
	do n = 1 to hbound(data1.decor, 1) while(rtrim(default_str) ^= data1.decor(n).name);
	  end;
	if n > hbound(data1.decor, 1)
	    then call prnter_$general_abort("Assembler error. Please notify assembler maintanence personel.");
	decor = data1.decor(n).number;

	call pass1_$pass1_(decor, target_value, no_target_given, first_time_thru);
	call mexp_$cleanup;

	tpass1 = 0;
	tpost1 = 1;
	call postp1_$postp1_;

	tpost1 = 0;
	eb_data_$curr_char_no = 0;
	tpass2 = 1;
	source_printed = ""b;
	call alm_include_file_$first_file(trimmed_entryname);
	binlin = 0;
	call mexp_$init(code);
	if code ^= 0 then goto abort;
	call pass2_$pass2_(decor, target_value, no_target_given, first_time_thru);
	/* pass2_ will check each instruction for compatibility with the decor value */
	call mexp_$cleanup;

	tpass2 = 0;
	tpostp = 1;
	source = addr(oulst); begin_line = 1; srclen = 68;	/*fudge the source pointer for prnam*/
	call postp2_$postp2_;

	tpostp = 0;
	call pakbit_$pakbit_;
	call alm_merge_$alm_merge_;
	if tnoxref = 0 then call alm_cross_reference_();
	severity = tfatal;
	if tfatal < 3 then call prlst_$prlst_("

NO FATAL ERRORS");
	else call prlst_$prlst_("

FATAL ERRORS ENCOUNTERED");

abort:	if code=0 then call release_temp_segments_("alm_", temp_ptrs, code);
	else call release_temp_segments_("alm_", temp_ptrs, 0);

	if tnewobject = 0 then do;
		 call make_object_map_(text, itxpc, ilkpc, istpc, txtlen/* in bits */, code);
		if code^=0 then call complain("An error was encountered in completing the object segment" || alm_info.source_entryname);
	  end;
	else call make_alm_object_map_(txtlen);
	alm_info.object_bc = eb_data_$segnfo.txtlen;

	if tnolst = 0 then do;
		alm_info.list_bc = eb_data_$segnfo.lstlen * 9;
		alm_info.list_component = eb_data_$list_component;
	  end;
	recursive = "0"b;
	if code = 0 then
	     if severity = 3 then code = error_table_$translation_failed;
	     else if severity = 4 then code = error_table_$translation_aborted;
	return;

abandon_assembly:
	recursive = "0"b;
	severity = 4;
	return;

cleanup_handler:	proc;
	if temp_ptrs(1) ^= null() then call release_temp_segments_("alm_", temp_ptrs, 0);
	call mexp_$cleanup;
	recursive = "0"b;
end cleanup_handler;

complain:	proc(message);
dcl	message char(*);

	if tquietsw ^= 1 then call com_err_(code, eb_data_$who_am_I, message);
	goto abandon_assembly;
end complain;

end alm_;




		    alm_cross_reference_.pl1        10/17/88  1013.9r w 10/17/88  0938.2       60741



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


/* This routine writes the cross reference table into the listing for ALM.
   The data is accumulated by table_ in a list structure addressable through
   the global (varcom) cell symbol_tree_rel.  This module merely formats
   the information and calls prlst_ for each line.

   First written on 07/23/72 at 20:41:52 by R F Mabee.
   Modified on 11/22/72 at 22:39:54 by R F Mabee. 
   Modified to change tree_recurse subprocedure from recursive to iterative one
	  on 02/10/76 by Eugene E Wiatrowski		*/

alm_cross_reference_: procedure;

 declare	com_err_ entry options(variable);

 declare	1 word based aligned,
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;

 declare	eb_data_$lavptr external static pointer;

 declare	cv_bin_$dec external entry (fixed binary, char (*)),
	cv_bin_$oct external entry (fixed binary, char (*)),
	prlst_ external entry (char (*));


 declare	(pointer, addr, substr, char, fixed, bit, length, convert) builtin;


% include	alm_xref_nodes;

% include	alm_include_file_info;

% include	alm_list_beads;

% include	varcom;

% include	concom;


/* Main procedure, print heading and recurse over tree. */

	if symbol_tree_rel = 0 then return;
	call prlst_ ("               MULTICS ASSEMBLY CROSS REFERENCE LISTING

   Value        Symbol                   Source file   Line number
");
	call tree_recurse ((symbol_tree_rel));
	return;

tree_recurse: procedure (tree_rel);		/*  walks the cross-reference tree. */

 declare	(tree_rel,subtree_rel,stack_offset)	 fixed binary (17);

 declare	tree_ptr 		pointer;

declare	returning		bit(1) aligned;

declare	stack(1000)	fixed bin;

	stack_offset = 0;
	returning = "0"b;

	do while(tree_rel > 0);
	   tree_ptr = pointer(eb_data_$lavptr,tree_rel);
	   subtree_rel = tree_ptr -> symbol_tree_node.low_sublist;

	   if subtree_rel > 0 & ^ returning
	      then do;
		 /* push on stack */
		 if stack_offset < hbound(stack,1)
		    then do;
			stack_offset = stack_offset + 1;
			stack(stack_offset) = tree_rel;
			end;
		    else do;
			call com_err_(0,"alm","cross-reference tree too big to display");
			return;
			end;
		 end;
	      else do;
		 call do_symbol(tree_ptr);
		 subtree_rel = tree_ptr -> symbol_tree_node.high_sublist;
		 if subtree_rel = 0
		    then do;
			/* pop the stack */
			if stack_offset > 0
			   then do;
				subtree_rel = stack(stack_offset);
				stack_offset = stack_offset - 1;
				end;
			returning = "1"b;
			end;
		    else returning = "0"b;
		 end;
	   tree_rel = subtree_rel;
	end;

	end;

do_symbol: procedure (tree_ptr);		/* Put out name, value, and referencing line numbers for one symbol. */
 declare	tree_ptr pointer;

 declare	line_rel bit (18), line_ptr pointer,
	name_ptr pointer, name_len fixed binary,
	line_no fixed binary, file_no fixed binary, last_file_no fixed binary,
	value fixed binary, buf_len fixed binary, buf_len_two fixed binary,
	buffer char (140) varying, numbuf char (12);

 declare	1 acc based aligned,
	  2 len bit (9) unaligned,
	  2 str char (32) unaligned;


	line_rel = tree_ptr -> symbol_tree_node.line_list_forward_rel;
	if line_rel = "0"b then return;

	if substr (tree_ptr -> symbol_tree_node.flags, 1, 3) = "110"b
	then value = fixed (tree_ptr -> symbol_tree_node.origin, 18);	/* Location counter node - print origin. */
	else value = fixed (tree_ptr -> symbol_tree_node.value, 18);
	if substr (tree_ptr -> symbol_tree_node.flags, 1, 3) = "001"b
	   then if tree_ptr -> symbol_tree_node.location_counter ^= "0"b then do;
		name_ptr = pointer (eb_data_$lavptr, tree_ptr -> symbol_tree_node.location_counter);
		value = value + fixed (name_ptr -> location_counter_bead.origin, 18);
		end;

	if substr (tree_ptr -> symbol_tree_node.flags, 1, 3) = "010"b
	then numbuf = "";	/* No useful value in external symbol node. */
	else if substr (tree_ptr -> symbol_tree_node.flags, 1, 3) = "000"b
	then numbuf = "";	/* Or in undefined symbol node. */
	else call cv_bin_$oct (value, numbuf);
	buffer = numbuf || (4)" ";

	name_ptr = pointer (eb_data_$lavptr, tree_ptr -> symbol_tree_node.name_rel);
	name_len = fixed (name_ptr -> acc.len, 9);
	if name_len < 24 then buf_len = 41;		/* Adjust beginning of next field to 6-character boundary. */
	else buf_len = 23 + name_len - mod (name_len, 6);
	buffer = buffer || substr (name_ptr -> acc.str, 1, name_len);
	buffer = char (buffer, buf_len);

	last_file_no = 0;

line_loop:	line_ptr = pointer (eb_data_$lavptr, line_rel);
		line_no = line_ptr -> line_node.line_no;
		file_no = convert (file_no, addr (line_no) -> word.left);
		line_no = convert (line_no, addr (line_no) -> word.right);

		line_rel = line_ptr -> line_node.forward_rel;

		if file_no ^= last_file_no then do;
			name_ptr = pointer (eb_data_$lavptr, file_no);
			name_len = index (name_ptr -> source_info.search_name, " ") - 1;
			if name_len <= 0 then name_len = length (name_ptr -> source_info.search_name);

		/* Strip off .alm, .incl suffixes if present. */

			if name_len > 4
			   then if substr (name_ptr -> source_info.search_name, name_len - 3, 4) = ".alm"
			   	 then name_len = name_len - 4;
			if name_len > 5
			   then if substr (name_ptr -> source_info.search_name, name_len - 4, 5) = ".incl"
				 then name_len = name_len - 5;

			if length (buffer) > buf_len then do;
				call prlst_ ((buffer));
				buffer = char ("", buf_len);
				end;
			if name_len < 12 then buf_len_two = buf_len + 12;	/* Adjust position to 6-character boundary. */
			else buf_len_two = buf_len + 6 + name_len - mod (name_len, 6);

			buffer = buffer || substr (name_ptr -> source_info.search_name, 1, name_len) || ":";
			buffer = char (buffer, buf_len_two);
			last_file_no = file_no;
			end;

		else if length (buffer) >= 120
		        then if line_rel ^= "0"b then do;	/* Avoid single entry on last line. */
			call prlst_ ((buffer));
			buffer = char ("", buf_len_two);
			end;

		call cv_bin_$dec (line_no, numbuf);
		buffer = buffer || substr (numbuf, 8, 5);
		if line_rel ^= "0"b then do;
			buffer = buffer || ",";
			goto line_loop;
			end;
	/* End of line_loop. */
	call prlst_ (buffer || ".");
	end;
end;




		    alm_definitions_.pl1            10/17/88  1013.9r w 10/17/88  0938.3      153306



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support the new "init"link" pseudo and to allow for
     blocks that are to be joined to the definition section.
  2) change(86-11-14,JRGray), approve(86-11-14,MCR7568),
     audit(86-11-21,RWaters), install(86-11-26,MR12.0-1228):
     Modified to backpatch the address of definitions into entry sequences
     associated with the 'ext_entry' pseudo-operation.
                                                   END HISTORY COMMENTS */


alm_definitions_$assign_definitions: procedure;

/* Separated from postp2_, November 1970, R H Campbell. */
/* Modified 2 December 1970, R H Campbell. */
/* Modified for new object segment format March 31 1972, R F Mabee. */
/* Entry fix_entries added 6 May 1972 by R F Mabee. */
/* Last modified on 06/13/72 at 21:06:41 by R F Mabee. */
/* This procedure is called to put out the
   symbolic definition region (to either text or link).
   The arrangement of the output information is determined by the
   two flags tprot (for transfer vector and error call) and
   tmvdef (for moving definitions to the linkage file).
   Tprot should imply tmvdef.
   If the definitions are to go in the linkage file,
   a pre-pass must be made to assign locations
   before the information is put out
   because the links must be assigned first. */

dcl (addr, bin, bit, convert, divide, index, hbound, length, mod, null, pointer, rel, string, substr, unspec) builtin;
						/* AUTOMATIC VARIABLES */
dcl  iright fixed bin (18);
dcl  irword;
dcl  itemp;
dcl  code fixed bin (35);
dcl  cleanup condition;
dcl  lnkorg;
dcl  ndefs fixed bin static;
dcl  htc fixed bin;
dcl  htp (1) ptr;
dcl  no_items bit (1);				/* Flag to show no detail items printed for heading. */
dcl  nwrds fixed bin (26);
dcl  rlkdef fixed bin;
dcl  rright fixed bin (26);
dcl (j, k) pointer;
dcl (namlnk, symlnk) pointer;
dcl (rsydef, trp, val) fixed bin (26);
dcl (seg, xnam) bit (18);

dcl  text_word(0:261119) fixed bin(35) based(eb_data_$segnfo.text);

dcl 1 symht based (htp (1)) aligned,
    2 size fixed bin,
    2 table (0 refer (symht.size)),
     (3 defp bit (18),
      3 pad bit (18)) unal;

declare 1 segname aligned,
        2 acc_length bit (9) unaligned,
        2 acc_string char (32) unaligned;
declare  segname_overlay bit (297) aligned based (addr (segname));

declare (backward_thread, zero_word_ptr, segname_def_blk) fixed bin;
						/* Headings placed in listing (watch for form-feeds). */
dcl  ff_NAME_DEFINITIONS_FOR_ENTRY_POINTS_AND_SEGDEFS_nl static character (47)
     aligned initial ("NAME DEFINITIONS FOR ENTRY POINTS AND SEGDEFS
");
dcl  nl_EXTERNAL_NAMES_nl static character (16) aligned initial ("
EXTERNAL NAMES
");
dcl  nl_HASH_TABLE_nl static char (24) aligned initial ("
DEFINITIONS HASH TABLE
");
dcl  nl_INTERNAL_EXPRESSION_WORDS_nl static character (27) aligned initial ("
INTERNAL EXPRESSION WORDS
");
dcl  nl_NO_EXTERNAL_NAMES static character (18) aligned initial ("
NO EXTERNAL NAMES");
dcl  nl_NO_TRAP_POINTER_WORDS static character (22) aligned initial ("
NO TRAP POINTER WORDS");
dcl  nl_TRAP_POINTER_WORDS_nl static character (20) aligned initial ("
TRAP POINTER WORDS
");
dcl  nl_TYPE_PAIR_BLOCKS_nl static character (18) aligned initial ("
TYPE PAIR BLOCKS
");
						/* EXTERNAL DATA */
dcl (eb_data_$stnam, eb_data_$typr2 (5)) external fixed bin (26);
dcl  eb_data_$lavptr external pointer;
						/* EXTERNAL ENTRIES */
dcl  prlst_$prlst_ entry (character (*) aligned);
dcl  prnam_$prnam_ entry (pointer);
dcl  putout_$putblk entry (fixed bin (26), pointer, fixed bin (26), fixed bin (26), pointer);
dcl  putout_$putwrd entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26));
dcl (get_temp_segments_, release_temp_segments_) entry (char (*), dim (*) ptr, fixed bin (35));
dcl  prnter_ entry (char (*));
dcl  prnter_$abort1 entry;
						/* EXTERNAL FUNCTIONS */
dcl  twop18 static fixed bin (26) initial (1000000000000000000b);
						/* INCLUDE FILES */

%	include alm_lc;

%	include alm_list_beads;

/* miscellaneous whole words for use with relocation processing */

%	include alm_relocation_bits;

%	include concom;

%	include segnfo;

/* common for symbol table header processing. */

%	include sthedr;

%	include varcom;

/* END OF DECLARATIONS */
/*  */
/* initialize defc to 21 */
/* to account for the 21 words required by symbol table, */
/* rel_text, rel_link, and rel_symbol definitions. */
	defc = 21;
						/* put code of 1 in 5th word of lpdefs node since now */
						/* in link segment - as defs are in .link. */
	pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.section = "000000000000000001"b; /* eb_data_$ilink */
						/* assign map, entries, and segdefs. */
	j = pointer (eb_data_$lavptr, xdflst);
	do while (rel (j));
	     defc = defc + 2;
	     j = pointer (eb_data_$lavptr, j -> external_definition_bead.next);
	end;
	defc = defc + 1;
						/* Assign other names in name list. */
	j = pointer (eb_data_$lavptr, namlst);
	do while (rel (j));
	     defc = defc + divide (bin (pointer (eb_data_$lavptr, j -> name_bead.name) -> acc.lg, 9) + 4, 4, 26, 0);
	     j = pointer (eb_data_$lavptr, j -> name_bead.next);
	end;
						/* assign trap words. */
	j = pointer (eb_data_$lavptr, trplst);
	do while (rel (j));
	     j -> trap_bead.location = bit (bin (defc, 18), 18);
	     defc = defc + 1;
	     j = pointer (eb_data_$lavptr, j -> trap_bead.next);
	end;
						/* assign type - pair blocks. */
	j = pointer (eb_data_$lavptr, blklst);
	do while (rel (j));
	     defc = defc + 2;
	     j = pointer (eb_data_$lavptr, j -> type_pair_bead.next);
	end;
						/* assign expression words. */
	j = pointer (eb_data_$lavptr, explst);
	do while (rel (j));
	     j -> expression_bead.location = bit (bin (defc, 18), 18);
	     defc = defc + 1;
	     j = pointer (eb_data_$lavptr, j -> expression_bead.next);
	end;
						/* set defcnt, and go to put out links. */
	defcnt = defc;
	return;					/* Return to caller. */
						/*  */
alm_definitions_$fix_entries: entry;

/* This entry is used to calculate where definitions for entry points will be placed
   so the entry sequences can reference them as required by new object segment format. */

	defc = 7;					/* 3-header, 3-segname def'n, 1-first word of acc segname string. */
	itemp = index (sthedr_$seg_name, " ") - 1;
	if itemp < 0 then itemp = length (sthedr_$seg_name);
	defc = defc + divide (itemp, 4, 26, 0);		/* Rest of acc segname string. */

	j = pointer (eb_data_$lavptr, xdflst);
	ndefs = 0;
	do while (rel (j));
	     k = pointer (eb_data_$lavptr, j -> external_definition_bead.entry_bead_ptr);
	     if rel (k) then k -> entry_bead.link_no = bit (bin (defc, 18));
	     defc = defc + 3;
	     k = pointer (eb_data_$lavptr, j -> external_definition_bead.name);
	     k = pointer (eb_data_$lavptr, k -> name_bead.name);
	     defc = defc + divide (bin (k -> acc.lg, 9) + 4, 4, 26, 0);
	     j = pointer (eb_data_$lavptr, j -> external_definition_bead.next);
	     ndefs = ndefs + 1;
	end;

	defc = defc + 7;				/* 7 words for symbol_table def */
	return;
						/*  */
alm_definitions_$emit_definitions:			/* part 2, put out definition words. */
	entry (lnkorg, rlkdef, rsydef);		/* Returns place to store defs. of rel_link and rel_symbol. */
	call prlst_$prlst_ (ff_NAME_DEFINITIONS_FOR_ENTRY_POINTS_AND_SEGDEFS_nl);
	htc = defc;
	defc = 0;
	curlc = lpdefs;

	call putout_$putwrd (defc, (defc + 3) * twop18, i66, ildefs); /* definitions header. */
	call putout_$putwrd (defc, htc * twop18 + 110000000000000000b, i66, ildefs);
						/* Unused bits in definitions header must have ignore flag. */

	zero_word_ptr = defc;			/* Convenient word full of zeros. */
	call putout_$putwrd (defc, 0, i66, 0);

	backward_thread = zero_word_ptr;		/* End of thread, zero word. */

	segname_def_blk = defc;			/* Address of class-3 segname definition. */
	segname_overlay = ""b;
	itemp = index (sthedr_$seg_name, " ") - 1;
	if itemp < 0 then itemp = length (sthedr_$seg_name);
	segname.acc_length = bit (bin (itemp, 9));
	substr (segname.acc_string, 1, itemp) = sthedr_$seg_name;
	nwrds = divide (itemp, 4, 26, 0) + 1;
	call putout_$putwrd (defc, (3 + nwrds + defc) * twop18 + backward_thread, i66, ildefs + idefpt);
						/* class-3, segname definition. */
	call putout_$putwrd (defc, zero_word_ptr * twop18 + 100000000000000011b, i66, ildefs);
	call putout_$putwrd (defc, (defc + 1) * twop18 + defc + 1 + nwrds, i66, ildefs + idefpt);
	call putout_$putblk (defc, addr (segname), i3333, nwrds, null ());

/* create the definitions hash table tmeplate */
	on cleanup
	     call release_temp_segments_ ("ALM definitions hash table", htp, code);
	call get_temp_segments_ ("ALM definitions hash table", htp, code);
	if code ^= 0 then do;
	     call prnter_ ("
Unable to make definitions hash table template segment.
");
	     call prnter_$abort1 ();
	end;
	symht.size = hlen (ndefs);

/* put out map and entry and segdef names. */
	backward_thread = segname_def_blk;
	j = pointer (eb_data_$lavptr, xdflst);
	do while (rel (j));
	     namlnk = pointer (eb_data_$lavptr, j -> external_definition_bead.name);
	     symlnk = pointer (eb_data_$lavptr, namlnk -> name_bead.name);
	     nwrds = divide (bin (symlnk -> acc.lg, 9) + 4, 4, 17);
	     val = convert (val, j -> external_definition_bead.location);
	     k = pointer (eb_data_$lavptr, j -> external_definition_bead.location_counter);
	     if rel (k) then
		do;
		val = val + bin (k -> location_counter_bead.origin, 18);
		irword = bin (k -> location_counter_bead.section, 18);
	     end;

	     if bin(j -> external_definition_bead.class, 18) > 7 then do;
		text_word(val-1) = text_word(val-1) + twop18 * defc;
	       end;
	     val = val * twop18 + bin (j -> external_definition_bead.class, 18);

	     trp = backward_thread + twop18;
	     backward_thread = defc;
	     rright = idefpt;
	     val = val + 100000000000000000b;
	     if j -> external_definition_bead.entry_bead_ptr then val = val + 001000000000000000b;

	     call hash ();

	     call putout_$putwrd (defc, (2 + nwrds + defc) * twop18 + trp, i66, ildefs + rright);
	     call putout_$putwrd (defc, val, i66, ibits (irword) * twop18);
	     call putout_$putwrd (defc, (defc + 1) * twop18 + segname_def_blk, i66, ildefs + idefpt);

/* Save name address in case it is used in a link reference. See "EXTERNAL NAMES" stuff. */
	     namlnk -> name_bead.section = "000000000000000001"b;
	     namlnk -> name_bead.location = bit (bin (defc, 18), 18);

	     call prnam_$prnam_ (symlnk);
	     call putout_$putblk (defc, symlnk, i3333, nwrds, null);
	     j = pointer (eb_data_$lavptr, j -> external_definition_bead.next);
	end;

/* produce the header definition. */
	symlnk = addr (eb_data_$stnam);
	call hash ();

	val = zero_word_ptr * twop18 + backward_thread;
	rright = idefpt;
	call putout_$putwrd (defc, val, i66, ildefs + rright);
	val = bin (pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin, 18) * twop18 + 2;
	val = val + 100000000000000000b;
	call putout_$putwrd (defc, val, i66, ilsymb);
	call putout_$putwrd (defc, (defc + 1) * twop18 + segname_def_blk, i66, ildefs + idefpt);
	call prnam_$prnam_ (symlnk);
	call putout_$putblk (defc, symlnk, i3333, 4, null);

/* put out the definitions hash table */
	call prlst_$prlst_ (nl_HASH_TABLE_nl);
	call putout_$putwrd (defc, bin (symht.size, 26), i66, 0);
	do itemp = 1 to symht.size;
	     unspec (val) = string (symht.table (itemp));
	     if symht.defp (itemp) then
		call putout_$putwrd (defc, val, i66, ildefs);
	     else
		call putout_$putwrd (defc, val, i66, 0);
	end;
	call release_temp_segments_ ("ALM definitions hash table", htp, code);

/* punch out all other assigned names. */
	no_items = "1"b;				/* Set flag: we haven't printed anything yet. */
	j = pointer (eb_data_$lavptr, namlst);
	do while (rel (j));
	     if j -> name_bead.section = ""b then	/* Was name already put out in segdef's? If not, put it out now. */
		do;
		if no_items then			/* Have we printed the heading yet? */
		     call prlst_$prlst_ (nl_EXTERNAL_NAMES_nl);
		no_items = ""b;			/* Clear flag. */
		symlnk = pointer (eb_data_$lavptr, j -> name_bead.name);
		nwrds = divide (bin (symlnk -> acc.lg, 9) + 4, 4, 17);
		j -> name_bead.location = bit (bin (defc, 18), 18);
		call prnam_$prnam_ (symlnk);
		call putout_$putblk (defc, symlnk, i3333, nwrds, null);
	     end;
	     j = pointer (eb_data_$lavptr, j -> name_bead.next);
	end;
	if no_items then				/* Were any names printed? */
	     call prlst_$prlst_ (nl_NO_EXTERNAL_NAMES);

/* punch out trap pointer words. */
	if (trplst = 0) then
	     call prlst_$prlst_ (nl_NO_TRAP_POINTER_WORDS);
	else
	do;
	     call prlst_$prlst_ (nl_TRAP_POINTER_WORDS_nl);
	     j = pointer (eb_data_$lavptr, trplst);
	     do while (rel (j));
		iright = convert (iright, j -> trap_bead.argument); /* Get link number of argument. */
		rright = 0;			/* Assume no argument supplied. */
		if iright ^= 0 then			/* Was there, in fact, one? */
		     do;				/* Yes. */
		     iright = iright + lnkorg;	/* Yes make up pointer to link location. */
		     rright = ilblok;		/* Set up relocation bits. */
		end;
		j -> trap_bead.location = bit (bin (defc, 18), 18);
		call putout_$putwrd (defc,
		     (bin (j -> trap_bead.call, 18) + lnkorg) * twop18 + iright,
		     i66, ilblok * twop18 + rright);
		j = pointer (eb_data_$lavptr, j -> trap_bead.next);
	     end;
	end;

/* punch out type - pair blocks. */
	call prlst_$prlst_ (nl_TYPE_PAIR_BLOCKS_nl);
	j = pointer (eb_data_$lavptr, blklst);
	do while (rel (j));
	     j -> type_pair_bead.location = bit (bin (defc, 18), 18);
	     trp = convert (trp, j -> type_pair_bead.trap);
	     rright = 0;
	     if (trp ^= 0) then do;
		rright = idefpt;
		if (fixed(j->type_pair_bead.type,18) = 5) then do;
			rright = 27; /* 33 octal special defn reloc */
			trp = trp - 1; /* 1 was added to allow for special rel of 0 */
		  end;
		else trp = convert (trp, pointer (eb_data_$lavptr, trp) -> trap_bead.location);
	     end;
	     itemp = convert (itemp, j -> type_pair_bead.type);
	     call putout_$putwrd (defc, itemp * twop18 + trp, i66, rright);
	     seg = j -> type_pair_bead.segment;
	     if itemp = 3 then
		go to type_3_or_4;
	     if itemp = 4 then			/* */
type_3_or_4:	seg = pointer (eb_data_$lavptr, seg) -> name_bead.location;
	     xnam = j -> type_pair_bead.symbol;
	     if xnam then
		xnam = pointer (eb_data_$lavptr, xnam) -> name_bead.location;
	     call putout_$putwrd (defc, bin (seg || xnam, 26), i66, eb_data_$typr2 (itemp));
	     j = pointer (eb_data_$lavptr, j -> type_pair_bead.next);
	end;

/* punch out internal expression words. */
	call prlst_$prlst_ (nl_INTERNAL_EXPRESSION_WORDS_nl);
	j = pointer (eb_data_$lavptr, explst);
	do while (rel (j));
	     j -> expression_bead.location = bit (bin (defc, 18), 18);
	     val = convert (val, j -> expression_bead.expression);
	     k = pointer (eb_data_$lavptr, j -> expression_bead.location_counter);
	     rright = 0;
	     if rel (k) then
		do;
		val = val + bin (k -> location_counter_bead.origin, 18);
		rright = ibits (bin (k -> location_counter_bead.section, 18));
	     end;
	     call putout_$putwrd (defc,
		bin (pointer (eb_data_$lavptr,
		j -> expression_bead.type_pair) -> type_pair_bead.location, 18) * twop18 + val,
		i66, ildefs + rright);
	     j = pointer (eb_data_$lavptr, j -> expression_bead.next);
	end;

/*  */

hlen: proc (s) returns (fixed bin);

dcl  s fixed bin;					/* required hash buckets */

dcl  s1 fixed bin,					/* minimum hash table size desired */
     i fixed bin;					/* iteration variable */

dcl  sizes (11) fixed bin static options (constant) init
	(13, 27, 53, 89, 157, 307, 503, 733, 1009, 1451, 2003);


	s1 = s * 1.25e0;				/* Allow for 25% of buckets to be empty. */
	do i = 1 to hbound (sizes, 1);		/* Pick an appropriate sizes. */
	     if s1 <= sizes (i) then
		return (sizes (i));
	end;
	return (s1);				/* Default for very large hash tables. */


     end hlen;



hash: proc;

dcl  word fixed bin (35) based;			/* first word of name */


	itemp = mod (symlnk -> word, symht.size) + 1;
	do while (symht.defp (itemp));
	     itemp = mod (itemp, symht.size) + 1;
	end;
	symht.defp (itemp) = bit (bin (defc, 18));


     end hash;



     end alm_definitions_$assign_definitions;




		    alm_eis_parse_.pl1              10/17/88  1013.9r w 10/17/88  0937.6       77517



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

/*  EIS multi-word instruction pseudo-operations are handled by this module.  */
/*  Last modified on 08/06/73 at 12:32:40 by R F Mabee.  */
/*  First written on 14 January 1973 by R F Mabee.  */

alm_eis_parse_$instruction: procedure (binop, flags, rleft) returns (fixed bin (35));

 declare	(binop, flags, rleft) fixed bin (26);	/*  Parameters.  */

 declare	modifiers (3) fixed bin (26), mf_count fixed bin (26), (i, j) fixed bin (26),
	(eis_length, eis_offset, eis_scale) fixed bin (26),
	right_half fixed bin (18),
	(basno, value, admod, b29, iaddr) fixed bin (26);

dcl	ixvrvl_notag fixed bin (26) init (0) int static;

 declare	left_half bit (18);

 declare	utils_$and ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	utils_$makins ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (35)),
	expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	varevl_$varevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26))
									returns (fixed bin),
	getid_$getid_ ext entry,
	inputs_$next ext entry,
	getbit_$getbit_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26));


 declare	eb_data_$lavptr external pointer,
	1 eb_data_$eis_flag_keys (3) aligned external,
	  2 one fixed bin,
	  2 two fixed bin,
	  2 three fixed bin,
	1 eb_data_$eis_value_keys (3) aligned external,
	  2 one fixed bin,
	  2 two fixed bin,
	1 eb_data_$eis_mf (3) aligned external,
	  2 key fixed bin,
	  2 mbz bit (29) unaligned,
	  2 bits bit (7) unaligned,
	eb_data_$rlist (0:15) external aligned fixed bin;

 declare	1 glpl_words (0:262143) aligned based (eb_data_$lavptr),
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;

/*  Include files.  */

% include varcom;

% include concom;

% include erflgs;

% include codtab;


/*  End of include files. /*  Beginning of entry alm_eis_parse_$instruction.  */

	modifiers (*) = 0;
	mf_count = 0;
	left_half = ""b;

eis_loop:	call getid_$getid_;
	if brk (1) = ilpar then do;
		if sym (1) = 0 then do;	/*  Modifier field - starts with "(".  */
			if mf_count >= 3 then prntf = 1;
			else mf_count = mf_count + 1;
			call getid_$getid_;
			modifiers (mf_count) = get_eis_modifier ();
			end;
		else do;			/*  Keyword with parenthesized subexpression.  */
			do j = 1 to 3 while (sym (1) ^= eb_data_$eis_value_keys (j).one); end;
			if sym (2) ^= eb_data_$eis_value_keys (j).two then prntf = 1;
			call getid_$getid_;
			if expevl_$expevl_ (1, value, iaddr) = 0 then prnte = 1;	/*  Force octal.  */
			if iaddr ^= 0 then prntr = 1;
			if j = 1 then substr (left_half, 1, 9) = bit (fixed (value, 9));	/*  MASK  */
			else if j = 2 then substr (left_half, 6, 4) = bit (fixed (value, 4));	/*  BOOL  */
			else if j = 3 then if flags ^= 0				/*  FILL  */
				then substr (left_half, 1, 1) = bit (fixed (value, 1));	/*  Bit instruction.  */
				else substr (left_half, 1, 9) = bit (fixed (value, 9));	/*  Char instruction.  */
			else prntf = 1;
			end;

		if brk (1) = irpar then call getid_$getid_;
		else prnte = 1;
		end;
	else do;
		do j = 1 to 3 while (sym (1) ^= eb_data_$eis_flag_keys (j).one); end;
		if sym (2) ^= eb_data_$eis_flag_keys (j).two then prntf = 1;
		if j = 1 then substr (left_half, 1, 1) = "1"b;		/*  ASCII  */
		else if j = 2 then substr (left_half, 10, 1) = "1"b;	/*  ENABLEFAULT  */
		else if j = 3 then substr (left_half, 11, 1) = "1"b;	/*  ROUND  */
		else prntf = 1;
		end;

	if brk (1) = icomma then goto eis_loop;
	if brk (1) ^= isp & brk (1) ^= inl then prnte = 1;

	if mf_count > 1 then do;			/*  Stuff modifiers into appropriate fields.  */
		substr (left_half, 12, 7) = bit (fixed (modifiers (2), 7));
		if mf_count = 3 then substr (left_half, 3, 7) = bit (fixed (modifiers (3), 7));
		end;

	rleft = 0;				/*  Always absolute.  */
	return (utils_$makins (0, fixed (left_half, 18), binop, 0, 0) + modifiers (1));


/*  /*  Internal routine to process an EIS modifier field.  */

get_eis_modifier: procedure returns (fixed bin);

 declare	(i, value, iaddr) fixed bin (26), modifier bit (7);

	modifier = "0"b;
mod_loop:
	/*  First search for special keywords "pr", "id", "rl".  */
	do i = 1 to 3;
		if sym (1) = eb_data_$eis_mf (i).key then do;
			modifier = modifier | eb_data_$eis_mf (i).bits;
			goto out;
			end;
		end;

	/*  Then search for register name.  */
	do i = 0 to 15;
		if sym (1) = eb_data_$rlist (i) then do;
			modifier = modifier | bit (fixed (i, 7));
			goto out;
			end;
		end;

	/*  Not a reserved word; it must be a user-defined name or boolean expression.  */
	if expevl_$expevl_ (1, value, iaddr) = 0 then prnte = 1;
	if iaddr ^= 0 then prntr = 1;
	modifier = modifier | bit (fixed (value, 7));

out:	if brk (1) = icomma then do;
		call getid_$getid_ ();
		goto mod_loop;
		end;

	return (fixed (modifier, 7));
	end;


/*/*  Routine to evaluate EIS descriptor pseudo-ops.  */

alm_eis_parse_$descriptor: entry (type, byte_size, n_format, rleft) returns (fixed bin (35));

 declare	(type, byte_size, n_format) fixed bin;		/*  Parameters.  */

	if varevl_$varevl_ (ixvrvl_notag, basno, value, admod, b29, iaddr) = 0 then prnte = 1;
	if iaddr = 0 then rleft = 0;			/*  Compute relocation code and absolute value.  */
	else do;
		value = value + fixed (glpl_words (iaddr + 3).left, 18);
		call getbit_$getbit_ (iaddr, basno, b29, rleft);
		rleft = rleft * 262144;
		end;
	if admod ^= 0 then prntr = 1;
	if b29 ^= 0 then value = utils_$and (value, 32768 - 1) + basno * 32768;	/*  Squeeze base in.  */

	eis_length, eis_offset, eis_scale = 0;
	if brk (1) = ilpar then do;			/*  Offset field.  */
		call getid_$getid_;
		if expevl_$expevl_ (0, eis_offset, iaddr) = 0 then prnte = 1;
		if iaddr ^= 0 then prntr = 1;
		if eis_offset < 0 | eis_offset * byte_size > 35 then do;
			prnte = 1;
			eis_offset = 0;
			end;
		if brk (1) = irpar then call getid_$getid_;
		else prnte = 1;
		end;

	if brk (1) ^= icomma then goto desc_out;
	call getid_$getid_;				/*  length field.  */
	do i = 0 to 15;	/*  Is it a register name?  */
		if sym (1) = eb_data_$rlist (i) then do;
			eis_length = i;
			goto out;
			end;
		end;

	/*  Otherwise it is a constant expression for the length.  */
	if expevl_$expevl_ (0, eis_length, iaddr) = 0 then prnte = 1;
	if iaddr ^= 0 then prntr = 1;
	if type = 3 then j = 64; else j = 4096;	/*  max value of length field.  */
	if eis_length < 0 | eis_length >= j then do;
		prnte = 1;
		eis_length = j - 1;
		end;

out:	if brk (1) ^= icomma then goto desc_out;
	if type ^= 3 then prntf = 1;			/*  Scale factor field exists only in numeric descriptors.  */
	call getid_$getid_;
	if expevl_$expevl_ (0, eis_scale, iaddr) = 0 then prnte = 1;
	if iaddr ^= 0 then prntr = 1;
	if eis_scale < -32 | eis_scale > 31 then do;
		prnte = 1;
		eis_scale = 0;
		end;
	if eis_scale < 0 then eis_scale = eis_scale + 64;	/*  force into six bits.  */

desc_out:
	if brk (1) ^= isp & brk (1) ^= inl then prntf = 1;

	if type = 2 then				/*  Bit descriptor.  */
		right_half = (divide (eis_offset, 9, 2, 0) * 16 + mod (eis_offset, 9)) * 4096 + eis_length;
	else do;
		if byte_size = 9 then eis_offset = eis_offset * 2;
		if type = 1 then do;		/*  Alphanumeric descriptor.  */
			if byte_size = 9 then j = 0;
			else if byte_size = 6 then j = 1;
			else j = 2;
			right_half = (eis_offset * 8 + j * 2) * 4096 + eis_length;
			end;
		else do;				/*  numeric descriptor.  */
			if byte_size = 9 then j = 0; else j = 1;
			right_half = (eis_offset * 8 + j * 4 + n_format) * 4096
							+ eis_scale * 64 + eis_length;
			end;
		end;

	return (value * 262144 + right_half);
	end;




		    alm_include_file_.pl1           10/17/88  1013.9rew 10/17/88  0929.4      115974



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




/****^  HISTORY COMMENTS:
  1) change(87-04-28,JRGray), approve(87-07-03,MCR7689),
     audit(87-07-09,RWaters), install(87-11-02,MR12.2-1001):
     Modified to remember more source file info (alm 19).
  2) change(87-04-28,JRGray), approve(87-07-03,MCR7689),
     audit(87-07-09,RWaters), install(87-11-02,MR12.2-1001):
     Fixed to calculate bit_count correctly (srclen is in chars not words).
                                                   END HISTORY COMMENTS */


/* This module keeps track of include files for ALM so that it can properly expand source programs by itself. */
/* modified on 08/10/72 at 19:48:21 by R F Mabee. */
/* Modified for macro processing 3/22/77 by Noel I. Morris	*/
/* Created new on 05/20/72 at 11:13:19 by R F Mabee. */

 alm_include_file_: procedure; /* Main entry never referenced. */


% include varcom;

% include segnfo;

% include alm_include_file_info;

% include	lstcom;


 declare	segment_pointer pointer, error_code fixed binary(35),
	bit_count fixed binary, file_name char (256);

 declare	1 eb_data_$tsym external static aligned,	/* This is the name of the desired input file. */
	  2 acc_length bit (9) unaligned,
	  2 acc_string char (32) unaligned;

dcl  eb_data_$macro_depth fixed bin ext,
     eb_data_$include_number fixed bin ext,
     eb_data_$include_control bit (110) aligned ext;

dcl  source_file_number fixed bin static;	/* Main source = 0, first include = 1 */

dcl 1 eb_data_$macro_stack (100) aligned ext,
    2 source_pointer ptr unal,
    2 source_length fixed bin (26),
    2 curr_char_no fixed bin (26),
    2 macro bit (1) unal,
    2 begin_offset fixed bin (15),
    2 count fixed bin (18) unal;


 declare	null builtin, addr builtin, rel builtin, fixed builtin,
	divide builtin, mod builtin, pointer builtin, substr builtin;

 declare	eb_data_$curr_char_no fixed binary external static,
	eb_data_$lavptr pointer external static,
	eb_data_$who_am_I char (12) external static;

 declare	find_include_file_$initiate_count external entry (char (*), pointer, char (*), fixed binary,
							pointer, fixed binary (35)),
	translator_info_$component_get_source_info external entry (ptr, char (*), char (*), char(*),
				fixed binary (71), bit (36) aligned, fixed binary),
	mexp_$reset_macro external entry,
	com_err_ external entry options(variable),
	prlst_ external entry (char (*)),
	prwrd_$source_only ext entry,
	prnter_ external entry (char (*)),
	prnter_$abort1 external entry,
	glpl_$setblk external entry (fixed binary, fixed binary) returns (fixed binary),
	prnter_$no_end_card external entry;



first_file: entry (main_program_name);
 declare	main_program_name char (*);

/* first_file is called at the beginning of each pass to cause the initial name node
   to be created (pass one) and pointers reset generally.  */

	include_index = 0;
	eb_data_$macro_depth = 0;
	eb_data_$include_number = 0;
	source_file_number = 0;
	eb_data_$include_control = "0"b;
	if tpass1 ^= 0 then do;		/*  First pass, make base node for main source. */
					/*  On second pass, base of name list is still available. */
		include_info_stack = null ();
		segment_pointer = source;
		bit_count = srclen * 9;	/* srclen is in chars */
		call make_new_node ();
		include_info_stack -> source_info.search_name = main_program_name || ".alm";
		include_name_list_base = include_info_stack;
		end;
	else do;
		source = include_name_list_base -> source_info.source_pointer;
		srclen = include_name_list_base -> source_info.source_length;
		end;

	/*  Set other list pointers to base node in either pass. */

	include_name_list_top, include_info_stack = include_name_list_base;
	begin_line = 0;
	return;

alm_include_file_$pass1: entry;

/* This entry is called by pass1_ to find an include file whose name is lying in tsym. */
/* It must do a full search to find the segment. */


	/* Stop accidental recursion by placing an upper limit on depth of nested include files. */

	if include_index > 10 then do;
		call prnter_ ("
Include file nesting depth limit (10) exceeded.
");
		call prnter_$abort1 ();
		end;

	include_index = include_index + 1;


	/* Generate full entry name, find file in libraries. */

	file_name = substr (acc_string, 1, fixed (acc_length, 9)) || ".incl.alm";
	call find_include_file_$initiate_count ("alm", source, file_name, bit_count, segment_pointer, error_code);
	if error_code ^= 0 then do;
		call com_err_ (error_code, eb_data_$who_am_I, file_name);
		call prlst_ ("
Include file missing:  " || file_name || "
");
		call prnter_$abort1 ();
		end;

	/*  Stack per-file information and thread in new filename node. */

	source_file_number = source_file_number + 1;
	eb_data_$include_number = source_file_number;
	call make_new_node ();
	source = segment_pointer;
	srclen = divide (bit_count, 9, 17, 0);
	include_name_list_top -> source_info.names_list_pointer = include_info_stack;
	include_name_list_top = include_info_stack;
	include_info_stack -> source_info.search_name = file_name;

	return;


alm_include_file_$pass2: entry;

/* This entry is called by pass2_ to find an include file. */
/* It can use segment pointer and length saved by alm_include_file_$pass1. */


	/*  Step along name thread to get entry for next input file. */
	/*  Update stacked info for old input file. */

	include_name_list_top = include_name_list_top -> source_info.names_list_pointer;
	include_name_list_top -> source_info.stack_back_pointer = include_info_stack;
	eb_data_$include_number = include_name_list_top -> source_info.source_number;
	include_info_stack = include_name_list_top;
	include_index = include_index + 1;

	call safe_store ();

	/*  Verify that this is the right file. */

	file_name = substr (acc_string, 1, fixed (acc_length, 9)) || ".incl.alm";
	if include_name_list_top -> source_info.search_name ^= file_name then do;
		call prnter_ ("
Phase error in include file processing.
");
		call prnter_$abort1 ();
		end;

	source = include_name_list_top -> source_info.source_pointer;
	srclen = include_name_list_top -> source_info.source_length;

	return;


alm_include_file_$macro: entry (macp, maclen);

/* Called with macro expansion to be inserted in source. */

dcl  macp ptr,
     maclen fixed bin;

	if eb_data_$curr_char_no ^= begin_line & tpass2 = 1 then
	     call prwrd_$source_only;

	call macro_safestore;
	eb_data_$macro_stack (eb_data_$macro_depth).macro = "1"b;
	eb_data_$macro_stack (eb_data_$macro_depth).count = 1;

	return;


alm_include_file_$insert: entry (macp, maclen, iters);

/* Called with other than macro expansion to be inserted in source. */

dcl  iters fixed bin;

	call macro_safestore;
	eb_data_$macro_stack (eb_data_$macro_depth).macro = "0"b;
	eb_data_$macro_stack (eb_data_$macro_depth).count = iters;

	return;


alm_include_file_$pop: entry;

/* Called because current input segment is exhausted. Returns having reset pointers etc. to previous input. */
/* If there is no more input data, the END card must be missing.  That is cause enough to abort. */


	if substr (eb_data_$include_control, 1, 1) then do;  /* If macro processing ... */
	     eb_data_$macro_stack (eb_data_$macro_depth).count = eb_data_$macro_stack (eb_data_$macro_depth).count - 1;
	     if eb_data_$macro_stack (eb_data_$macro_depth).count > 0 then do;
		eb_data_$curr_char_no = 0;
		begin_line = 0;
	     end;
	     else do;
		source = eb_data_$macro_stack (eb_data_$macro_depth).source_pointer;
		srclen = eb_data_$macro_stack (eb_data_$macro_depth).source_length;
		eb_data_$curr_char_no = eb_data_$macro_stack (eb_data_$macro_depth).curr_char_no;
		begin_line = eb_data_$curr_char_no - eb_data_$macro_stack (eb_data_$macro_depth).begin_offset;
		if eb_data_$macro_stack (eb_data_$macro_depth).macro then
		     call mexp_$reset_macro;

		eb_data_$macro_depth = eb_data_$macro_depth - 1;
		if eb_data_$macro_depth = 0 then
		     binlin = binlin + 1;
		eb_data_$include_control = substr (eb_data_$include_control, 2) || "0"b;
	     end;
	     source_printed = (eb_data_$curr_char_no ^= begin_line);
	end;
	else if include_index <= 0 then call prnter_$no_end_card ();
	else do;

		source = include_info_stack -> source_info.savep;
		srclen = include_info_stack -> source_info.savel;
		eb_data_$curr_char_no = include_info_stack -> source_info.curr_char_no;
		binlin = include_info_stack -> source_info.line_number;
		begin_line = include_info_stack -> source_info.line_begin_offset;
		source_printed = (eb_data_$curr_char_no ^= begin_line);

/* Retrieve old input state from push-down list. */

		include_info_stack = include_info_stack -> source_info.stack_back_pointer;
		eb_data_$include_number = include_info_stack -> source_info.source_number;
		include_index = include_index - 1;
		eb_data_$include_control = substr (eb_data_$include_control, 2) || "0"b;

		end;

	return;


make_new_node: procedure;

/*  This internal procedure creates a new source_info node for the current input segment. */


 declare	errcode fixed binary, rel_pointer fixed binary, words_needed fixed binary, new_pointer pointer;

 declare	map_entry_work_space (100);	/*  Copied into new block by glpl_$setblk. */

 declare  dirname		char(256),
	(entname, compname)	char(32);


	/*  Get space for node. */

	new_pointer = addr (map_entry_work_space);	/*  For address arithmetic to be defined. */
	words_needed = fixed (rel (addr (new_pointer -> source_info.last_word)), 18) - fixed (rel (addr (new_pointer -> source_info.first_word)), 18) + 2;
	rel_pointer = glpl_$setblk (map_entry_work_space (1), words_needed);

	/*  Make sure block address is even. */

	if mod (rel_pointer, 2) ^= 0 then rel_pointer = rel_pointer + 1;

	/*  Start filling in structure. */

	new_pointer = pointer (eb_data_$lavptr, rel_pointer);
	new_pointer -> source_info.source_number = source_file_number;

	call translator_info_$component_get_source_info (segment_pointer, dirname, entname, compname,
			new_pointer -> source_info.dtm, new_pointer -> source_info.uid, errcode);
	if errcode ^= 0 then do;
		call com_err_ (errcode, eb_data_$who_am_I, "Unable to get source file status. Assembly will continue.");
		tfatal = 1;
		end;

	if compname = "" then new_pointer -> source_info.pathname = rtrim (dirname, "> ") || ">" || entname;
	else new_pointer -> source_info.pathname = rtrim (dirname, "> ") || ">" || before (entname, ".archive") ||
		"::" || compname;
	new_pointer -> source_info.source_pointer = segment_pointer;
	new_pointer -> source_info.source_length = divide (bit_count, 9, 17);

	new_pointer -> source_info.names_list_pointer = null ();
	new_pointer -> source_info.stack_back_pointer = include_info_stack;

	include_info_stack = new_pointer;

	call safe_store ();

	return;
	end;


safe_store: procedure;

/*  This internal procedure puts current location in current file into current stack node,
    and resets the current position to the beginning of the (next) file.  */


	include_info_stack -> source_info.savep = source;
	include_info_stack -> source_info.savel = srclen;
	include_info_stack -> source_info.curr_char_no = eb_data_$curr_char_no;
	include_info_stack -> source_info.line_number = binlin;
	include_info_stack -> source_info.line_begin_offset = begin_line;

	eb_data_$curr_char_no = 0;

	binlin = 1;
	begin_line = 0;
	source_printed = "0"b;

	eb_data_$include_control = "0"b || eb_data_$include_control;

	return;
	end;


macro_safestore: proc;

/* This internal procedure pushes info onto the macro stack and
   prepares to handle insertion of expanded macro.	*/

	if eb_data_$macro_depth = 0 then
	     binlin = binlin - 1;
	eb_data_$macro_depth = eb_data_$macro_depth + 1;
	if eb_data_$macro_depth > 100 then do;
	     call prnter_ ("
Macro depth limit (100) exceeded.
");
	     call prnter_$abort1 ();
	end;

	eb_data_$macro_stack (eb_data_$macro_depth).source_pointer = source;
	eb_data_$macro_stack (eb_data_$macro_depth).source_length = srclen;
	eb_data_$macro_stack (eb_data_$macro_depth).curr_char_no = eb_data_$curr_char_no;
	eb_data_$macro_stack (eb_data_$macro_depth).begin_offset = eb_data_$curr_char_no - begin_line;

	source = macp;
	srclen = maclen;
	eb_data_$curr_char_no = 0;
	begin_line = 0;
	source_printed = "0"b;

	eb_data_$include_control = "1"b || eb_data_$include_control;

	return;


	end;


end;




		    alm_merge_.pl1                  10/17/88  1013.9r w 10/17/88  0937.5       30213



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


 

/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Extended to allow for joining to the definition section.
                                                   END HISTORY COMMENTS */


alm_merge_:	procedure ;

/*        Modified for separate static on 06/15/75 by Eugene E Wiatrowski      */
/*	Modified on 05/25/72 at 03:43:42 by R F Mabee.
	by RFM on 21 March 1972 for new object segment format.
	by NA on July 3, 1970 at 1144 */
  
	/* this procedure appends the linkage and symbol portion of the object
	  into the final object segment followed by the standard map of the object */ 

dcl  linkage_hdr_size init(8) fixed bin(26) aligned  internal static;

%	include	objnfo;

%	include	segnfo;

%	include	sthedr;

%	include	varcom;

dcl (itxpci, iword, mapbgn, itemp, i) fixed bin (17) aligned ;

dcl object_$object_ external entry ( fixed bin(17), fixed bin(17) );

dcl eb_data_$stat_len ext fixed bin(26);
dcl eb_data_$separate_static ext bit(1) aligned;

dcl object_$getolk external entry ( fixed bin(17), fixed bin(17) );

dcl object_$getost external entry ( fixed bin(17), fixed bin(17) );

dcl object_$getodf external entry ( fixed bin(17), fixed bin(17) );

dcl object_$getbdf external entry ( fixed bin(17), fixed bin(17), fixed bin(17));

dcl eb_data_$ifence ext fixed bin (17) aligned ;

	itxpci = text_section_length;

	if idfpc > 0 then do;
		itemp = idfpc - 1;
		do i = 0 to itemp;
			call object_$getodf(i, iword);
			call object_$object_(itxpci, iword);
			itxpci = itxpci + 1;
		  end;
		new_definition_length = new_definition_length + idfpc;
		text_section_length = itxpci;
	  end;

	if eb_data_$separate_static
	   then do;
	        itemp = (eb_data_$stat_len + ilkpc) - 1;
	        new_static_offset = itxpci;
	        new_static_length = eb_data_$stat_len;
	        new_link_offset = eb_data_$stat_len + itxpci;
	        end;
	   else do;
	        itemp = ilkpc - 1 ;
	        new_static_offset = itxpci + linkage_hdr_size;
	        new_static_length = eb_data_$stat_len;
	        new_link_offset = itxpci;
	        end;

	new_link_length = ilkpc;

		/* append the linkage portion of the object */
link_loop:
	do i = 0 to itemp ;
	call object_$getolk(i,iword) ;
	call object_$object_(itxpci,iword) ;
	itxpci = itxpci + 1 ;
end link_loop ;

		/* append the symbol portion of the object */
	itemp = istpc - 1 ;

	new_symbol_offset = itxpci;
	new_symbol_length = istpc;

symbol_loop:
	do i = 0 to itemp ;
	call object_$getost(i,iword) ;
	call object_$object_(itxpci,iword) ;
	itxpci = itxpci + 1 ;
end symbol_loop ;

	txtlen = itxpci;

end alm_merge_;




		    alm_source_map_.pl1             10/17/88  1013.9rew 10/17/88  0929.4       42966



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




/****^  HISTORY COMMENTS:
  1) change(87-04-28,JRGray), approve(87-07-03,MCR7689),
     audit(87-07-09,RWaters), install(87-11-02,MR12.2-1001):
     Updated to use the latest source_info structure (alm 19).
                                                   END HISTORY COMMENTS */


/*  This segment contains routines to generate standard object segment source map identifying
    the source files which went into this compilation.  An additional entry point counts
    the words used for the source map so that space can be allocated in advance.  */

/*  Created on 06/20/72 at 20:34:31 by R F Mabee. */
/*  Modified on 06/22/72 at 11:51:34 by R F Mabee. */
/* Modified for macro expansion 3/24/77 by Noel I. Morris	*/
/* Modified to fix bugs phx5126 and phx6042 on 5/12/81 by EBush */


alm_source_map_$count_map_words: procedure (nwords);

/*  This entry returns the number of words to be reserved for the source map. */


 declare	nwords fixed bin;

 declare	temp pointer, (i, j) fixed bin (26),
	code fixed bin (35);

 declare	nnames fixed bin internal static;		/*  Saved from count entry to putout entry. */

 declare	twop18 fixed bin (26) internal static initial (262144);	/*  Constant. */

 declare	prnam_$prnam_ external entry (pointer),
	putout_$putblk external entry (fixed bin, pointer, fixed bin (26), fixed bin, pointer),
	putout_$putwrd external entry (fixed bin, fixed bin, fixed bin (26), fixed bin (35)),
	hcs_$terminate_noname external entry (ptr, fixed bin (35));

 declare	null builtin, substr builtin, divide builtin, length builtin, rtrim builtin;


%include	alm_include_file_info;

%include	varcom;

%include	concom;


	nwords, nnames = 0;		/*  Count names, words containing names. */

	temp = include_name_list_base;
	do while (temp ^= null ());	/*  Run down list. */
		i = length (rtrim (temp -> source_info.pathname));

		temp -> source_info.source_map_offset = nwords;
		temp -> source_info.source_map_length = i;

		nwords = nwords + divide (i + 3, 4, 26, 0);

		temp = temp -> source_info.names_list_pointer;
		nnames = nnames + 1;
		end;

	nwords = nwords + nnames * 4 + 2;	/*  Two word header, four word array entries. */

	return;


alm_source_map_$put_out_map: entry (ispc);

/*  This entry sticks source map in object at ispc in current lc.  */


 declare	ispc fixed bin;

 declare	map_base fixed bin;

 declare	1 acc_temp aligned,
	  2 count bit (9) unaligned,
	  2 string char (256) unaligned;


	map_base = ispc + 2 + nnames * 4;		/*  Two word header plus a four word entry pointing to each name. */
	call putout_$putwrd (ispc, 1, i66, 0);		/*  Version number of structure. */
	call putout_$putwrd (ispc, nnames, i66, 0);

	temp = include_name_list_base;
	do while (temp ^= null ());
/*****************************************************************************/
	/* The first source_ptr in this chain is apparently a ptr to the
	   source program segment. Thus, to avoid bugs 5126,6042, we bypass
             the termination step for it so that the source is not prematurely
             terminated. */
/****************************************************************************/
	     if temp ^= include_name_list_base
		then call hcs_$terminate_noname (temp-> source_info.source_pointer, code);
						/* Terminate file and ignore error code. */
		call putout_$putwrd (ispc, (temp -> source_info.source_map_offset + map_base) * twop18 + temp -> source_info.source_map_length, i66, 0);
		call putout_$putblk (ispc, addr (temp -> source_info.uid), i66, 1, null ());
		call putout_$putblk (ispc, addr (temp -> source_info.dtm), i66, 2, null ());
		temp = temp -> source_info.names_list_pointer;
		end;

	temp = include_name_list_base;
	do while (temp ^= null ());
		acc_temp.count = bit (fixed (min (temp -> source_info.source_map_length, 68), 9));
		acc_temp.string = temp -> source_info.pathname;
		call prnam_$prnam_ (addr (acc_temp));
		call putout_$putblk (ispc, addr (temp -> source_info.pathname), i66, divide (temp -> source_info.source_map_length + 3, 4, 26, 0), null ());
		temp = temp -> source_info.names_list_pointer;
		end;

	end;




		    alm_symtab_.pl1                 10/17/88  1013.9rew 10/17/88  0929.6      354132



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-08-02,JRGray), approve(88-08-05,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     These routines remember and emit structures necessary for symbol table
     support.
                                                   END HISTORY COMMENTS */

/*	These procedures are used to build up information in the symbol
	section of object segments. */
alm_symtab_:	proc;
dcl	program_name char(11) static options(constant) init("alm_symtab_");
dcl	(name, string, type) char(*) parameter;
dcl	sc_dtcm fixed bin(71) parameter;
dcl	sc_uid bit(36) aligned parameter;
dcl	(st_length, st_line, st_loc, st_num, st_offset) fixed bin(35) parameter;
dcl	(admod, b29, basno, iaddr, offset, pc, value, word_count) fixed bin(26) parameter;

dcl	(addr, before, bit, divide, fixed, hbound, index, length, max, mod, null, rtrim, size, substr, verify) builtin;

dcl	alm_source_map_$count_map_words entry(fixed bin(26));
dcl	alm_source_map_$put_out_map entry(fixed bin(26));
dcl	getbit_ entry(fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26));
dcl	get_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));
dcl	ioa_ entry options(variable);
dcl	putout_$putblk entry(fixed bin(26), ptr, fixed bin(26), fixed bin(26), ptr);
dcl	putout_$putwrd entry(fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26));
dcl	release_temp_segments_ entry(char(*), (*) ptr, fixed bin(35));

dcl	(source_data_ptr, symbol_data_ptr) ptr static;
dcl	temp_ptrs(3) ptr init((3) null()) static;

dcl	(context, current_block, current_source, current_statement, first_token, forward) fixed bin static;
dcl	(max_allocated, max_block, max_source) fixed bin static;
dcl	sc_string_len fixed bin(21) static;
dcl	source_stack(1:255) fixed bin static;
dcl	stack_level fixed bin static;
dcl	(start_pl1_sb, start_sc, start_sc_strings, start_statement, start_symbol) fixed bin static;

dcl	ec fixed bin(35);
dcl	i fixed bin(21);
dcl	s fixed bin;

dcl	eb_data_$lavptr external ptr;
dcl	1 glpl_words(0:261119) based(eb_data_$lavptr),
	  2 (left, right) fixed bin(18) unsigned unaligned;

dcl	word(261120) fixed bin(26) based;

dcl	symbol_data(261120) fixed bin(35) based(symbol_data_ptr);
dcl	1 source_data based(source_data_ptr),
	  2 sc_map(0:255),
	    3 pathname unaligned,
	      4 (offset, size) fixed bin(18) unsigned unaligned,
	    3 uid bit(36) aligned,
	    3 dtm fixed bin(71),
	  2 sc_strings char(256 * 256),
	  2 st_map(121000),
	    3 location fixed bin(18) unsigned unaligned,
	    3 source_id unaligned,
	      4 file fixed bin(8) unsigned unaligned,
	      4 line fixed bin(14) unsigned unaligned,
	      4 statement fixed bin(5) unsigned unaligned,
	    3 source_info unaligned,
	      4 start fixed bin(18) unsigned unaligned,
	      4 length fixed bin(9) unsigned unaligned;

dcl	(CHAR init(21), DOUBLE init(4), ENUMTYPE init(55), ENUMVALUE init(56),
	 FLOAT init(3), FUNCTION init(26), INT init(1), LONG init(2), PTR init(13),
	 STRUCTURE init(17), TYPEREF init(54), UINT init(33), ULONG init(34), UNION init(57))
	     fixed bin int static options(constant);

initialize:	entry;	/* initializes static variables and creates tempsegs */
	/* first temp-segment is for source and statement info.
	   second tempseg is for runtime_symbol info: symbols, tokens, blocks.
	   third segment is for relocation info associated with symbol info. */
	call get_temp_segments_(program_name, temp_ptrs, ec);
	source_data_ptr = temp_ptrs(1);
	symbol_data_ptr = temp_ptrs(2);
	context = 0;
	current_block = 0;
	current_source = 0;
	current_statement = 0;
	first_token = 0;
	forward = 0;	/* no forward references */
	max_allocated = 0;
	max_block = 0;
	max_source = -1;	/* source zero is the first source */
	sc_string_len = 0;
	stack_level = 0;
	return;

block:	entry(string);	/* creates runtime_block & stores it in tree */
	if context ^= 0 then call error("New block encountered while in symbol context.");
	context = 0;
	call open_block(string, current_block);
	return;

end_block:	entry;	/* closes out current runtime_block */
	if context ^= 0 then call error("end_block encountered while in symbol context.");
	if current_block = 0 then call error("Mismatched end_block.");
	else call close_block(current_block);
	return;

enum:	entry(string);	/* Starts definition of enumeration type */
	call open_context(string, ENUMTYPE, context);
	return;

end_enum:	entry;	/* closes out enumeration definitions */
	if context = 0 then call error("end_enum encountered while not in symbol context.");
	else call close_context(context);
	return;

source:	entry(string, sc_uid, sc_dtcm);	/* start source program: path, uid & dtcm */

	max_source = max_source + 1;
	current_source = max_source;
	stack_level = stack_level + 1;
	source_stack(stack_level) = current_source;

	sc_map(current_source).offset = divide(sc_string_len, 4, 17, 0);
	i = length(rtrim(string));
	sc_map(current_source).size = i;
	sc_map(current_source).uid = sc_uid;
	sc_map(current_source).dtm = sc_dtcm;

	i = i + mod(4000 - i, 4);	/* pad length to fill last word */
	substr(sc_strings, sc_string_len+1, i) = string;	/* store path in list containing all paths */
	sc_string_len = sc_string_len + i;
	return;

end_source:	entry;	/* end of source program */
	if stack_level = 0 then call error("'end_source' encountered with no source active.");
	else do;
	     stack_level = stack_level - 1;
	     current_source = source_stack(stack_level);
	  end;
	return;

	/* source line info associated with alm location */
statement:	entry(st_loc, st_offset, st_length, st_line, st_num);
	current_statement = current_statement + 1;
	st_map(current_statement).location = st_loc;
	st_map(current_statement).source_info.start = st_offset;
	st_map(current_statement).source_info.length = st_length;
	st_map(current_statement).source_id.line = st_line;
	st_map(current_statement).source_id.file = current_source;
	st_map(current_statement).source_id.statement = st_num;
	return;

structure:	entry(string);	/* starts definition of structure */
	call open_context(string, STRUCTURE, context);
	return;

end_structure:	entry;	/* closes of structure definition */
	if context = 0 then call error("end_structure encountered while not in symbol context.");
	else call close_context(context);
	return;

	/* defines information about a runtime symbol */
symbol:	entry(name, type, basno, value, admod, b29, iaddr, offset);
	call define_symbol(name, type, basno, value, admod, b29, iaddr, offset, s);
	return;

union:	entry(string);	/* Starts definition of union type */
	call open_context(string, UNION, context);
	return;

end_union:	entry;	/* closes definition of union */
	if context = 0 then call error("end_union encountered while not in symbol context.");
	else call close_context(context);
	return;

count_words:	entry(word_count);	/* returns length of symbol_table info */
	if max_source < 0 then do;	/* only info is map of alm sources */
	     call alm_source_map_$count_map_words(word_count);
	     return;
	  end;

	start_sc = new_sthedr_$hdrlen;
	start_sc_strings = start_sc + 2 + (max_source+1) * 4;
	start_pl1_sb = start_sc_strings + divide(sc_string_len + 3, 4, 17, 0);
	if max_allocated = 0 & current_statement = 0 then do;
	     start_symbol = 0;
	     start_statement = 0;
	     word_count = start_pl1_sb - new_sthedr_$hdrlen;
	  end;
	else do;
	     if context ^= 0 then call error("Missing end_(enum structure union) statement.");
	     if current_block ^= 0 then call error("Missing end_block.");
	     new_sthedr_$source_and_area.area_offset = bit(fixed(start_pl1_sb, 18), 18);
	     start_symbol = start_pl1_sb + size(pl1_symbol_block) + divide(length(rtrim(sthedr_$seg_name))+3, 4, 17, 0);
	     start_statement = start_symbol + max_allocated;
	     word_count = start_statement + (current_statement+1)*2 - new_sthedr_$hdrlen;
	  end;
	return;

emit:	entry(pc);	/* emits symbol_table info & releases storage */
	if max_source < 0 then call alm_source_map_$put_out_map(pc);
	else call emit_symtab;

cleanup:	entry;		/* release storage */
	if temp_ptrs(1) ^= null() then call release_temp_segments_(program_name, temp_ptrs, ec);
	return;
/* ===================== Internal Procedures =================== */

/* This procedure prints out an error message and sets the S error Flag */
error:	proc(string);
dcl	string char(*);

	prnts = 1;	/* set flag for S (symbol) error */
	call ioa_("Symbol Table Error: ^a", string);
end error;

/* This procedure allocates a block in the symbol_data tempseg */
allocate_storage:	proc(size, offset);
dcl	(size, offset) fixed bin parameter;

	if max_allocated + size > hbound(symbol_data, 1) then do;
	     call error("Symbol Table Overflow.");
	     max_allocated = 0;
	  end;
	offset = max_allocated + 1;
	max_allocated = max_allocated + size;
end allocate_storage;

/* This procedure returns the offset of a specified runtime token. It will
   create the token if one doesn't already exist. */
get_token:       proc(name, offset);
dcl	name char(*) parameter;
dcl	offset fixed bin(17) parameter;
dcl	(t, last_t) fixed bin;
dcl	t_ptr ptr;
dcl	l fixed bin;

	offset = 0;
	l = length(name);
	if l = 0 then return;

	/* to optimize set token list and search via it */
	last_t = 0;
	t = first_token;
	do while(t > 0 );
	     t_ptr = addr(symbol_data(t));
	     if t_ptr -> runtime_token.size > l then goto create_token;
	     else if t_ptr -> runtime_token.size = l then 
	       if t_ptr -> runtime_token.string > name then goto create_token;
	       else if t_ptr -> runtime_token.string = name then do;	/* found it */
		offset = t;
		return;
	       end;
	     last_t = t;
	     if t_ptr -> runtime_token.next = 0 then t = 0;
	     else t = t_ptr -> runtime_token.next + t;
	  end;
create_token:
	call allocate_storage(divide(l+4, 4, 17, 0) + 1, t); /* new token */
	t_ptr = addr(symbol_data(t));
	t_ptr -> runtime_token.size = l;
	t_ptr -> runtime_token.string = name;
	if last_t = 0 then do;
	     if first_token ^= 0 then t_ptr -> runtime_token.next = first_token - t;
	     first_token = t;
	  end;
	else do;
	     if addr(symbol_data(last_t)) -> runtime_token.next ^= 0 then
		t_ptr -> runtime_token.next = addr(symbol_data(last_t)) -> runtime_token.next + last_t - t;
	     addr(symbol_data(last_t)) -> runtime_token.next = t - last_t;
	  end;
	offset = t;
end get_token;

/* This procedure creates a runtime_block. It will create a runtime_token 
   if necessary and insert the block into the runtime_block tree.
   Note: runtime_blocks are linked into a circular list whose parent
   points to the last runtime_block. This form is converted into a standard
   linked list by the close_block routine */
open_block:	proc(name, block);
dcl	name char(*);
dcl	(block, b, bot, t) fixed bin;
dcl	b_ptr ptr;

	if max_allocated>1 & current_block=0 then call error("Multiple blocks declared at the global level.");
	call allocate_storage(size(runtime_block) - 1, b);	/* -1 because no owner field */
	b_ptr = addr(symbol_data(b));
	if name = "" then do;
	     max_block = max_block + 1;
	     b_ptr -> runtime_block.number = max_block;
	     if block = 0 then b_ptr -> runtime_block.type = 4;
	     else do;	/* quick block */
		b_ptr -> runtime_block.type = 3;
		call allocate_storage(1, 0);	/* room for owner */
		b_ptr -> runtime_block.owner_flag = "1"b;
		b_ptr -> runtime_block.quick = "1"b;
		if addr(symbol_data(block)) -> runtime_block.owner_flag then
		     b_ptr -> runtime_block.owner = addr(symbol_data(block)) -> runtime_block.owner + block - b;
		else b_ptr -> runtime_block.owner = block - b;
	       end;
	  end;
	else do;
	     call get_token(name, t);
	     b_ptr -> runtime_block.name = t-b+1; /* points to runtime_token.name */
	     b_ptr -> runtime_block.type = 1;
	  end;
	b_ptr -> runtime_block.flag = "1"b;
	b_ptr -> runtime_block.standard = "1"b;
	b_ptr -> runtime_block.first = current_statement;	/* adjust later for start of statement map */
	if current_block = 0 then b_ptr -> runtime_block.father = 0;
	else do;
	     b_ptr -> runtime_block.father = current_block - b;
	     bot = addr(symbol_data(current_block)) -> runtime_block.son;
	     if bot ^= 0 then do;
		bot = bot + current_block;
		b_ptr -> runtime_block.brother = addr(symbol_data(bot)) -> runtime_block.brother + bot - b;
		addr(symbol_data(bot)) -> runtime_block.brother = b - bot;
	       end;
	     addr(symbol_data(current_block)) -> runtime_block.son = b - current_block;
	  end;
	block = b;
end open_block;

/* This routine finishes a runtime block by converting its children from a
   circular list into a regular list and then pops out to the parent block */
close_block:	proc(block);
dcl	(block, bot) fixed bin;
dcl	b_ptr ptr;

	if block = 0 then return;
	b_ptr = addr(symbol_data(block));
	b_ptr -> runtime_block.last = current_statement;
	bot = b_ptr -> runtime_block.son;
	if bot ^= 0 then do;	/* convert list from circular to bounded */
	     bot = bot + block;
	     b_ptr -> runtime_block.son = addr(symbol_data(bot)) -> runtime_block.brother + bot - block;
	     addr(symbol_data(bot)) -> runtime_block.brother = 0;
	  end;

	if b_ptr -> runtime_block.father = 0 then block = 0;
	else block = b_ptr -> runtime_block.father + block;
end close_block;

/* This procedure opens a context. It creates a symbol node for the
   context, links it into the current context and updates the context. */
open_context:	proc(name, type, context);
dcl	name char(*);
dcl	(type, context, s) fixed bin;

	call create_symbol(name, s);
	if s = 0 then return;         /* abort */
	addr(symbol_data(s)) -> runtime_symbol.type = type;
	if addr(symbol_data(s)) -> runtime_symbol.level = 0 then
	     addr(symbol_data(s)) -> runtime_symbol.level = 1;
	if context = 0 then call thread_symbol_into_block(s, current_block);
	else call add_symbol_in_context(s, context);
	context = s;
end open_context;

/* This procedure ends a context. It converts a end pointed circular
   linked list into a start pointed bounded linked list */
close_context:	proc(context);
dcl	(bot, context, top) fixed bin;

	bot = addr(symbol_data(context)) -> runtime_symbol.son;
	if bot ^= 0 then do;	/* list is not empty */
	     bot = bot + context;
	     top = addr(symbol_data(bot)) -> runtime_symbol.brother + bot;
	     addr(symbol_data(bot)) -> runtime_symbol.brother = 0;
	     addr(symbol_data(context)) -> runtime_symbol.son = top - context;
	  end;
	context = addr(symbol_data(context)) -> runtime_symbol.father + context;	/* leave context */
	if context = current_block then context = 0;
end close_context;

/* This procedure creates a runtime_symbol, creating/accessing a runtime_token as necessary */
create_symbol:	proc(name, s);
dcl	name char(*) parameter;
dcl	s fixed bin parameter;
dcl	(dcladdr, t) fixed bin;
dcl	s_ptr ptr;

	if name = "" then do;
	     call allocate_storage(5, s);
	     s_ptr = addr(symbol_data(s));
	  end;
	else do;
	     call get_token(name, t);
	     call allocate_storage(5, s);
	     s_ptr = addr(symbol_data(s));
	     s_ptr -> runtime_symbol.name = t - s + 1;
	     dcladdr = addr(symbol_data(t)) -> runtime_token.dcl;
	     if dcladdr ^= 0 then s_ptr -> runtime_symbol.next = dcladdr + t - s;
	     addr(symbol_data(t)) -> runtime_token.dcl = s - t;
	  end;
	s_ptr -> runtime_symbol.flag = "1"b;
	s_ptr -> runtime_symbol.aligned = "1"b;
	s_ptr -> runtime_symbol.simple = "1"b;
end create_symbol;

/* This procedure searchs for the runtime_symbol node associated with a name */
find_symbol:	proc(name, context, in_symbol_context) returns(fixed bin);
dcl	name char(*) parameter;
dcl	context fixed bin;
dcl	in_symbol_context bit(1);
dcl	(b, c, first, o, s, t) fixed bin;

	o = context;
	if in_symbol_context then do;	/* check in symbol contexts (containing structs, unions, enums) */
	     c = 0;
	     do while(o ^= 0);	/* end of list when zero offset */
		c = c + o;
		s = c;
		o = addr(symbol_data(c)) -> runtime_symbol.son;
		first = s + o;		/* remember for test for end of circular list */
		do while(o ^= 0 );	/* find name in symbol table */
		     s = s + o;
		     t = addr(symbol_data(s)) -> runtime_symbol.name;
		     o = addr(symbol_data(s)) -> runtime_symbol.brother;
		     if s+o = first then o = 0;	/* end of circular list */
		     if t ^= 0 then
		       if addr(symbol_data(s+t-1)) -> runtime_token.string = name then return(s);
		  end;
		o = addr(symbol_data(c)) -> runtime_symbol.father;
		if c+o = current_block then o = 0;	/* not found */
		if addr(symbol_data(c)) -> runtime_symbol.level > 1 then o = 0;
	       end;
	     o = c + addr(symbol_data(c)) -> runtime_symbol.father;	/* containing block */
	  end;

	b = 0;	/* OK now look in the runtime_blocks */
	do while(o ^= 0);
	     b = b + o;
	     s = b;
	     o = addr(symbol_data(b)) -> runtime_block.start;
	     do while(o ^= 0 );	/* find name in symbol table */
		s = s + o;
		t = addr(symbol_data(s)) -> runtime_symbol.name;
		o = addr(symbol_data(s)) -> runtime_symbol.brother;
		if t ^= 0 then
		  if addr(symbol_data(s+t-1)) -> runtime_token.string = name then return(s);
	       end;
	     o = addr(symbol_data(b)) -> runtime_block.father;
	  end;
	return(0);	/* no runtime_symbol with specified name */
end find_symbol;

/* This procedure returns the storage requirement associated with one element of a runtime_symbol */
symbol_element_size:	proc(s) returns(fixed bin);
dcl	(first, i, m, o, s, sz, t) fixed bin;

	if s = 0 then return(0);
	t = addr(symbol_data(s)) -> runtime_symbol.type;
	sz = addr(symbol_data(s)) -> runtime_symbol.size;
	if t = INT | t = LONG then return(sz + 1);
	if t = FLOAT| t = DOUBLE then return(sz + 9);
	if t = PTR then return(72);
	if t = UINT | t = ULONG then return(sz);
	if t = CHAR then return(sz * 9);
	if t = ENUMTYPE | t = ENUMVALUE then return(sz + 1);
	if t = STRUCTURE then do;	/* size of structure = last element: offset + size */
	     o = addr(symbol_data(s)) -> runtime_symbol.son;
	     i = s;
	     if o = 0 then return(0);	/* empty structure */
	     if ^addr(symbol_data(s+o)) -> runtime_symbol.simple &
	        addr(symbol_data(s+o)) -> runtime_symbol.offset ^= 0
	       then i = s+o;	/* attempt to take size of open structure */
	     else do while(o ^= 0);
		i = i + o;
		o = addr(symbol_data(i)) -> runtime_symbol.brother;
	       end;

	     m = addr(symbol_data(i)) -> runtime_symbol.offset;
	     if addr(symbol_data(i)) -> runtime_symbol.type ^= UNION &	/* here? must be typedefs */
	       addr(symbol_data(i)) -> runtime_symbol.type ^= STRUCTURE then m = m + symbol_size(i);
	     return(72 * divide(m+71, 72, 17, 0));
	  end;
	if t = UNION then do;
	     m = 0;
	     i = s;
	     o = addr(symbol_data(i)) -> runtime_symbol.son;
	     /* it is an error to try to figure out size of something that
	     is not fully defined, but just in case prevent infinite loops */
	     first = i + o;		/* used for circular list end test */
	     do while(o ^= 0);
		i = i + o;
		o = addr(symbol_data(i)) -> runtime_symbol.brother;
		if i + o = first then o = 0;	/* prevent infinite loops when scanning circular lists */
		if addr(symbol_data(i)) -> runtime_symbol.type ^= UNION &
		   addr(symbol_data(i)) -> runtime_symbol.type ^= STRUCTURE
		     then m = max(m, symbol_size(i));	/* unions & structure here are really typedefs */
	       end;
	     return(72 * divide(m+71, 72, 17, 0));
	  end;
	if t = TYPEREF then
	     if addr(symbol_data(s)) -> runtime_symbol.son = 0 then return(0);
	     else return(symbol_size(s + addr(symbol_data(s)) -> runtime_symbol.son));
	return(0);
end symbol_element_size;

/* This procedure returns the storage requirement associated with a runtime_symbol */
symbol_size:	proc(s) returns(fixed bin);
dcl	(i, s, sz) fixed bin;
dcl	s_ptr ptr;

	sz = symbol_element_size(s);
	if sz = 0 then return(0);
	s_ptr = addr(symbol_data(s));
	do i = 1 to s_ptr -> runtime_symbol.ndims;
	     sz = sz * (s_ptr -> runtime_symbol.bounds(i).upper - s_ptr -> runtime_symbol.bounds(i).lower + 1);
	  end;
	return(sz);
end symbol_size;

/* This procedure fill out the multiplier field of array runtime_symbols */
compute_array_data:	proc(s);
dcl	(i, s, sz) fixed bin;
dcl	s_ptr ptr;

	s_ptr = addr(symbol_data(s));
	if s_ptr -> runtime_symbol.ndims <= 0 then return;
	sz = symbol_element_size(s);
	if sz = 0 then return;
	s_ptr -> runtime_symbol.array_units = 1;	/* bit units */
	do i = s_ptr -> runtime_symbol.ndims to 1 by -1;
	     s_ptr -> runtime_symbol.bounds(i).multiplier = sz;
	     sz = sz * (s_ptr -> runtime_symbol.bounds(i).upper - s_ptr -> runtime_symbol.bounds(i).lower + 1);
	  end;
end compute_array_data;

/* This procedure links a runtime_symbol as the last son of the runtime_symbol 'context' */
add_symbol_in_context:	proc(s, c);
dcl	(bot, c, offset, s, t) fixed bin;
dcl	(b_ptr, c_ptr, s_ptr) ptr;

	if c = 0 then return;	/* no papa? no can do... */
	s_ptr = addr(symbol_data(s));
	c_ptr = addr(symbol_data(c));
	s_ptr -> runtime_symbol.level = c_ptr -> runtime_symbol.level + 1;
	s_ptr -> runtime_symbol.father = c-s;
	bot = c_ptr -> runtime_symbol.son;
	if bot ^= 0 then do;
	     bot = bot + c;
	     b_ptr = addr(symbol_data(bot));
	     s_ptr -> runtime_symbol.brother = b_ptr -> runtime_symbol.brother + bot - s;
	     b_ptr -> runtime_symbol.brother = s - bot;

	     if c_ptr -> runtime_symbol.type = STRUCTURE then do; /* fill in offset */
		if s_ptr -> runtime_symbol.simple then do;
		     call allocate_storage(2, 0);
		     s_ptr -> runtime_symbol.simple = "0"b;
		  end;

		if b_ptr -> runtime_symbol.simple then offset = 0;
		else offset = b_ptr -> runtime_symbol.offset;
		if b_ptr -> runtime_symbol.type ^= STRUCTURE &	/* in this context must be typedef */
		   b_ptr -> runtime_symbol.type ^= UNION then offset = offset + symbol_size(bot);
		if s_ptr -> runtime_symbol.aligned then do;	/* align the data */
		     t = s_ptr -> runtime_symbol.type;
		     if t = LONG | t = DOUBLE | t = PTR | t = STRUCTURE then offset = 72 * divide(offset + 71, 72, 17, 0);
		     else if t = CHAR then offset = 9 * divide(offset + 8, 9, 17, 0);
		     else offset = 36 * divide(offset + 35, 36, 17, 0);
		  end;

		s_ptr -> runtime_symbol.offset = offset;
		s_ptr -> runtime_symbol.units = 1;
	       end;
	  end;
	c_ptr -> runtime_symbol.son = s - c;
end add_symbol_in_context;

/* This procedure takes a runtime_symbol node and inserts it into the
   linked list of runtime_symbols in a specified block */
thread_symbol_into_block:	proc(s, b);
dcl	(b, ct, ctl, i, j, last_s, slot, s, t, tl) fixed bin;
dcl	(b_ptr, s_ptr, t_ptr) ptr;

	if b = 0 then do;
	     call error("Attempt to link symbol when not in a runtime_block.");
	     return;
	  end;

	s_ptr = addr(symbol_data(s));
	b_ptr = addr(symbol_data(b));
	s_ptr -> runtime_symbol.father = b-s;

	last_s = 0;	/* symbol that should precede new symbol */
	t = s_ptr -> runtime_symbol.name;
	if t ^= 0 then do;	/* find list location by finding last_s */
	     t = t + s - 1;
	     t_ptr = addr(symbol_data(t));
	     tl = t_ptr -> runtime_token.size;
	     j = b_ptr -> runtime_block.start;
	     if j ^= 0 then if ^ordered_symbols(s, b+j) then last_s = b+j;

	     i = 2;	/* check symbol chain first, setting chain if necessary */
	     do slot = 1 to 4 while(tl >= i);
		i = i + i;	/* min length of current slot */
		j = b_ptr -> runtime_block.chain(slot);
		if j = 0 then b_ptr -> runtime_block.chain(slot) = s-b;
		else do;	/* compare with symbol */
		     ct = addr(symbol_data(j+b)) -> runtime_symbol.name+j+b - 1;
		     ctl = addr(symbol_data(ct)) -> runtime_token.size;
		     if ctl > tl then b_ptr -> runtime_block.chain(slot) = s-b;
		     else if ctl < tl then last_s = j+b;
		     else if addr(symbol_data(ct)) -> runtime_token.string >
			t_ptr -> runtime_token.string then b_ptr -> runtime_block.chain(slot) = s-b;
		     else last_s = j+b;
		  end;
	       end;

	     j = last_s;	/* search through rest of list finding preceding symbol */
	     last_s = 0;
	     do while(j ^= 0);
		if ordered_symbols(last_s + j, s) then do;
		     last_s = last_s + j;
		     j = addr(symbol_data(last_s)) -> runtime_symbol.brother;
		  end;
		else j = 0;
	       end;
	  end;

	if last_s = 0 then do;	/* put at beginning of list */
	     if b_ptr -> runtime_block.start ^= 0 then
		s_ptr -> runtime_symbol.brother = b + b_ptr -> runtime_block.start - s;
	     b_ptr -> runtime_block.start = s-b;
	  end;
	else do;	/* insert in list */
	     if addr(symbol_data(last_s)) -> runtime_symbol.brother ^= 0 then
		s_ptr -> runtime_symbol.brother = last_s + addr(symbol_data(last_s)) -> runtime_symbol.brother - s;
	     addr(symbol_data(last_s)) -> runtime_symbol.brother = s - last_s;
	  end;
end thread_symbol_into_block;

ordered_symbols:	proc(s1, s2) returns(bit(1));	/* returns true if s1 should be ordered before s2 */
dcl	(s1, s2, t1, t2, t1l, t2l) fixed bin;

	t1 = addr(symbol_data(s1)) -> runtime_symbol.name;
	if t1 = 0 then return("1"b);
	t2 = addr(symbol_data(s2)) -> runtime_symbol.name;
	if t2 = 0 then return("0"b);
	t1 = s1 + t1 - 1;
	t2 = s2 + t2 - 1;
	t1l = addr(symbol_data(t1)) -> runtime_token.size;
	t2l = addr(symbol_data(t2)) -> runtime_token.size;
	if t1l < t2l then return("1"b);
	if t1l > t2l then return("0"b);
	return( addr(symbol_data(t1)) -> runtime_token.string <= addr(symbol_data(t2)) -> runtime_token.string);
end ordered_symbols;

define_symbol:    proc(name, type, basno, value, admod, b29, iaddr, offset, top);
dcl	(name, type) char(*) parameter;
dcl	(admod, b29, basno, iaddr, offset, value) fixed bin(26) parameter;
dcl	reloc fixed bin(26);
dcl	(i, key, s, top) fixed bin;
dcl	s_ptr ptr;
dcl	remainder char(80);
dcl	token char(80) varying;

dcl	valid_chars(0:15) char(80) varying int static options(constant)
	  init(("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"),
	     "", ")", "0123456789", (2)("0123456789]"), (10)("0123456789"));
dcl	01 type_name_info int static options(constant),
	  02 blank char(1) init(" "),
	  02 names(10) char(16) init(".int .short", ".uint .ushort",
		".long", ".ulong", ".char", ".uchar", ".float", ".double",
		".label", ".enum");
dcl	type_names char(10*16+1) based(addr(type_name_info));
dcl	01 type_info(10) internal static options(constant),
	  02 type fixed bin init(1, 33, 2, 34, 21, 21, 3, 4, 24, 56),
	  02 default_size fixed bin init(35, 36, 71, 72, 1, 1, 27, 63, 0, 35);

	call create_symbol(name, s);
	if s = 0 then return;	/* couldn't allocate: abort */
	top = s;	/* return top of type chain */
	s_ptr = addr(symbol_data(s));

	/* set location information remembering relocation info */
	reloc = 0;	/* absolute relocation */
	if iaddr = 0 then s_ptr -> runtime_symbol.location = value;
	else do;	/* address is relative to location counter */
	     s_ptr -> runtime_symbol.location = value + glpl_words(iaddr+3).left;
	     call getbit_(iaddr, basno, 0 /* b29 = 0 always use 18 bit relocation */, reloc);
	     temp_ptrs(3) -> glpl_words(s+2).left = reloc;	/* relocation info */
	  end;

	/* relocation info maps directly to some classes of storage */
	if reloc = itext then s_ptr -> runtime_symbol.class = 12;
	else if reloc = ilink then s_ptr -> runtime_symbol.class = 5;
	else if reloc = isymbl then s_ptr -> runtime_symbol.class = 11;
	else do;	/* figure it out the hard way */
	     if admod = 16 then	/* indirect flag */
		if basno = 7 then do;    /* parameter */
		     s_ptr -> runtime_symbol.class = 9;
		     s_ptr -> runtime_symbol.location = s_ptr -> runtime_symbol.location / 2;
		  end;
		else s_ptr -> runtime_symbol.class = 8;	/* indirect parameter?? */
	     else if basno = 6 then s_ptr -> runtime_symbol.class = 1;
	  end;

	if offset ^= 0 then do;	/* explicitly fill in offset field */
	     call allocate_storage(2, 0);
	     s_ptr -> runtime_symbol.simple = "0"b;
	     s_ptr -> runtime_symbol.aligned = "0"b;
	     s_ptr -> runtime_symbol.packed = "1"b;
	     if mod(offset, 9) = 0 then do;
		s_ptr -> runtime_symbol.offset = divide(offset, 9, 26, 0);
		s_ptr -> runtime_symbol.units = 2;	/* byte */
	       end;
	     else do;
		s_ptr -> runtime_symbol.offset = offset;
		s_ptr -> runtime_symbol.units = 1;	/* bit */
	       end;
	  end;


	remainder = type;
	do while(remainder ^= "");	/* fill in type related info */
	     key = index("*(:[,0123456789", substr(remainder, 1, 1));
	     i = verify(substr(remainder, 2), valid_chars(key));
	     if i < 1 then i = length(remainder) - 1;
	     token = substr(remainder, 1, i);
	     remainder = substr(remainder, i + 1);

	     if key = 0 then do;	/* Type Name */
		i = divide(15 + index(type_names, " " || token || " "), 16, 17, 0);
		if i > 0 then do;	/* C type */
		     s_ptr -> runtime_symbol.type = type_info(i).type;
		     s_ptr -> runtime_symbol.size = type_info(i).default_size;
		     if type_info(i).type = CHAR then do;
			s_ptr -> runtime_symbol.aligned = "0"b;
			s_ptr -> runtime_symbol.packed = "1"b;
			s_ptr -> runtime_symbol.decimal = (token = ".char");
		       end;
		  end;

		else do;	/* type reference */
		     s_ptr -> runtime_symbol.type = TYPEREF;
		     if context ^= 0 then i = find_symbol((token), context, "1"b);
		     else i = find_symbol((token), current_block, "0"b);
		     if i = 0 then do;	/* forward reference */
			s_ptr -> runtime_symbol.size = forward;
			forward = s;	/* chain through size field */
			call get_token((token), i);
			s_ptr -> runtime_symbol.son = i;	/* remember name */
		       end;
		     else do;
			if addr(symbol_data(i)) -> runtime_symbol.type = ENUMTYPE & i = context
			  then s_ptr -> runtime_symbol.type = ENUMVALUE;
			else s_ptr -> runtime_symbol.son = i-s;
		       end;
		  end;
	       end;
	     else if key <= 2 then do; 	/* pointer or function & type... */
		if key = 1 then s_ptr -> runtime_symbol.type = PTR;	/* ptr */
		else s_ptr -> runtime_symbol.type = FUNCTION;		/* function */
		if s = top then
		     if context = 0 then call thread_symbol_into_block(s, current_block);
		     else call add_symbol_in_context(s, context);
		call compute_array_data(s);
		call create_symbol("", i);
		addr(symbol_data(i)) -> runtime_symbol.level = s_ptr -> runtime_symbol.level;
		s_ptr -> runtime_symbol.son = i - s;
		s = i;
		s_ptr = addr(symbol_data(s));
		if context ^= 0 then s_ptr -> runtime_symbol.father = context - s;
		else s_ptr -> runtime_symbol.father = current_block - s;
	       end;
	     else if key = 3 then do;	/* size information */
		s_ptr -> runtime_symbol.aligned = "0"b;
		s_ptr -> runtime_symbol.packed = "1"b;
		s_ptr -> runtime_symbol.size = fixed(substr(token, 2));
	       end;
	     else if key <= 5 then do;	/* bounds info */
		if s_ptr -> runtime_symbol.simple then do;
		     s_ptr -> runtime_symbol.simple = "0"b;
		     call allocate_storage(2, 0);
		  end;
		call allocate_storage(3, 0);
		s_ptr -> runtime_symbol.ndims = s_ptr -> runtime_symbol.ndims + 1;
		s_ptr -> runtime_symbol.bounds(s_ptr -> runtime_symbol.ndims).upper =
		     fixed(before(substr(token, 2), "]")) - 1;
	       end;
	     else s_ptr -> runtime_symbol.type = fixed(token);	/* explicit type */
	  end;
	if s = top then
	     if context = 0 then call thread_symbol_into_block(s, current_block);
	     else call add_symbol_in_context(s, context);
	call compute_array_data(s);
end define_symbol;

/* This procedure emits all the structures that have been previously
   defined into the symbol table of the object. */
emit_symtab:	proc;	/* IN-OUT (pc) */
dcl	(i, j) fixed bin(26);
dcl	seg_name_size fixed bin(26);
dcl	temp_string char(8);
dcl	twop18 fixed bin(26) int static options(constant) init(262144);
dcl	token(0:5) fixed bin;	/* used to fill out token list in runtime_blocks */

	do i = 0 to max_source;	/* fix up offsets of source strings */
	     sc_map(i).pathname.offset = sc_map(i).pathname.offset + start_sc_strings;
	  end;

	call putout_$putwrd(pc, 1, i66, 0);		/* source_map.version */
	call putout_$putwrd(pc, (max_source+1), i66, 0);	/* source_map.number */
	call putout_$putblk(pc, addr(sc_map), i66, (max_source+1)*4, null());

	call putout_$putblk(pc, addr(sc_strings), i66, divide(sc_string_len, 4, 26, 0), null());

	if current_statement = 0 & max_allocated = 0 then return;

	/* pl1_symbol_block */
	j = length(rtrim(sthedr_$seg_name));
	seg_name_size = divide(j + 3, 4, 26, 0);
	call putout_$putwrd(pc, 1, i66, 0);	/* version */
	temp_string = "pl1info ";
	call putout_$putblk(pc, addr(temp_string), i66, 2, null());
	call putout_$putwrd(pc, fixed("100000000000"b3,35), i66, 0);	/* flags: map */
	call putout_$putwrd(pc, 0, i66, 0);	/* greatest severity */
	call putout_$putwrd(pc, start_symbol * twop18, i66, 0);	/* root, profile */
	i = start_statement * twop18 + start_statement + (current_statement+1)*2;
	call putout_$putwrd(pc, i, i66, 0);	/* map: first, last */
	call putout_$putwrd(pc, (pc + 1) * twop18 + j, i66, 0);	/* segname: offset, length */
	call putout_$putblk(pc, addr(sthedr_$seg_name), i66, seg_name_size, null());

	/* output symbol information */
	if max_allocated > 0 then do;
	     call resolve_forward_references;
	     call make_token_list;
	     call adjust_block_offsets(1);
	     call putout_$putblk(pc, symbol_data_ptr, i66, (max_allocated), temp_ptrs(3));
	  end;

	/* can't allocate statement map as a block because of relocation */
	do i = 1 to current_statement;	/* statement map */
	     call putout_$putwrd(pc, addr(st_map(i)) -> word(1), i66, iltext);
	     call putout_$putwrd(pc, addr(st_map(i)) -> word(2), i66, 0);
	  end;
	/* last statement map entry is special */
	call putout_$putwrd(pc, (itxpc-1)*twop18 + 262143, i66, iltext);
	call putout_$putwrd(pc, 261632*twop18, i66, 0);
	return;	/* end emit_symtab */

/* This procedure scans through the linked list of runtime tokens
   creating the hashed list that is used by runtime_blocks */
make_token_list:	proc;
dcl	(l, o, slot, t) fixed bin;
dcl	t_ptr ptr;

	token(*) = 0;
	slot = 0;
	l = 1;
	t = 0;
	o = first_token;
	do while(o ^= 0);
	     t = t + o;
	     t_ptr = addr(symbol_data(t));
	     o = t_ptr -> runtime_token.next;
	     do while(t_ptr -> runtime_token.size >= l);
		token(slot) = t;
		slot = slot + 1;
		l = l + l;
		if slot > hbound(token, 1) then return;
	       end;
	  end;
end make_token_list;

/* This procedure recursively adjusts offset values for the runtime_block
   tree. It adjusts the values for the token hash list and statement map values */
adjust_block_offsets:	proc(b);
dcl	b fixed bin parameter;
dcl	b_ptr ptr;
dcl	i fixed bin;

	b_ptr = addr(symbol_data(b));
	b_ptr -> runtime_block.header = 1-b-start_symbol;
	if b_ptr -> runtime_block.father = 0 then b_ptr -> runtime_block.father = 1 - b - start_symbol;
	do i = 0 to 5 while(token(i) ^= 0);
	     b_ptr -> runtime_block.token(i) = token(i) - b;
	  end;
	b_ptr -> runtime_block.map.first = b_ptr -> runtime_block.map.first*2 + start_statement-b-start_symbol+1;
	b_ptr -> runtime_block.map.last = b_ptr -> runtime_block.map.last*2 + start_statement-b-start_symbol+1;
	if b_ptr -> runtime_block.brother ^= 0 then
	     call adjust_block_offsets(b_ptr -> runtime_block.brother + b);
	if b_ptr -> runtime_block.son ^= 0 then
	     call adjust_block_offsets(b_ptr -> runtime_block.son + b);
end adjust_block_offsets;

resolve_forward_references:	proc;
dcl	(s, i) fixed bin;
dcl	s_ptr ptr;

	s = forward;
	do while(s ^= 0);
	     s_ptr = addr(symbol_data(s));
	     i = find_symbol(addr(symbol_data(s_ptr -> runtime_symbol.son)) -> runtime_token.string,
		s_ptr->runtime_symbol.father+s, (s_ptr->runtime_symbol.level > 0));
	     if i = 0 then call ioa_("Type has been referenced but not defined: ^a",
		 addr(symbol_data(s_ptr -> runtime_symbol.son)) -> runtime_token.string);
	     else s_ptr -> runtime_symbol.son = i - s;
	     s = s_ptr -> runtime_symbol.size;	/* link through size field */
	     s_ptr -> runtime_symbol.size = 35;	/* reasonable but useless value */
	  end;
end resolve_forward_references;

end emit_symtab;

/* runtime symbol structures */

dcl	1 runtime_symbol	aligned based,
	2 flag		unal bit(1),	/* always "1"b for Version II */
	2 use_digit	unal bit(1),	/* if "1"b and units are half words units are really digits */
	2 array_units	unal fixed bin(2) unsigned,
	2 units		unal fixed bin(2) unsigned,	/* addressing units */
	2 type		unal fixed bin(6) unsigned,	/* data type */
	2 level		unal fixed bin(6) unsigned,	/* structure level */
	2 ndims		unal fixed bin(6) unsigned,	/* number of dimensions */
	2 bits		unal,
	  3 aligned	bit(1),
	  3 packed	bit(1),
	  3 simple	bit(1),
	  3 decimal	bit(1),
	2 scale		unal fixed bin(7),	/* arithmetic scale factor */
	2 name		unal fixed bin(17),	/* rel ptr to acc name */
	2 brother		unal fixed bin(17),	/* rel ptr to brother entry */
	2 father		unal fixed bin(17),	/* rel ptr to father entry */
	2 son		unal fixed bin(17),	/* rel ptr to son entry */
	2 address		unal,
	  3 location	fixed bin(17),		/* location in storage class */
	  3 class		unsigned fixed bin(4),		/* storage class */
	  3 next		fixed bin(13),		/* rel ptr to next of same class */
	2 size		fixed bin(35),	/* encoded string|arith size */
	2 offset		fixed bin(35),	/* encoded offset from address */
	2 virtual_org	fixed bin(35),
	2 bounds(1),
	  3 lower		fixed bin(35),	/* encoded lower bound */
	  3 upper		fixed bin(35),	/* encoded upper bound */
	  3 multiplier	fixed bin(35);	/* encoded multiplier */

dcl	1 runtime_bound	based,
	2 lower		fixed bin(35),
	2 upper		fixed bin(35),
	2 multiplier	fixed bin(35);

dcl	1 runtime_block	aligned based,
	2 flag		unal bit(1),	/* always "1"b for Version II */
	2 quick		unal bit(1),	/* "1"b if quick block */
	2 fortran		unal bit(1),	/* "1"b if fortran program */
	2 standard	unal bit(1),	/* "1"b if program has std obj segment */
	2 owner_flag	unal bit(1),	/* "1"b if block has valid owner field */
	2 skip		unal bit(1),
	2 type		unal fixed bin(6) unsigned,	/* = 0 for a block node */
	2 number		unal fixed bin(6) unsigned,	/* begin block number */
	2 start		unal fixed bin(17),	/* rel ptr to start of symbols */
	2 name		unal fixed bin(17),	/* rel ptr to name of proc */
	2 brother		unal fixed bin(17),	/* rel ptr to brother block */
	2 father		unal fixed bin(17),	/* rel ptr to father block */
	2 son		unal fixed bin(17),	/* rel ptr to son block */
	2 map		unal,
	  3 first		fixed bin(17),		/* rel ptr to first word of map */
	  3 last		fixed bin(17),		/* rel ptr to last word of map */
	2 entry_info	unal fixed bin(17),	/* info about entry of quick block */
	2 header		unal fixed bin(17),	/* rel ptr to symbol header */
	2 chain(4)	unal fixed bin(17),	/* chain(i) is rel ptr to first symbol
					   on start list with length >= 2**i */
	2 token(0:5)	unal fixed bin(17),	/* token(i) is rel ptr to first token
					   on list with length >= 2 ** i */
	2 owner		unal fixed bin(17);	/* rel ptr to owner block */

dcl	1 runtime_token	aligned based,
	2 next		unal fixed bin(17),	/* rel ptr to next token */
	2 dcl		unal fixed bin(17),	/* rel ptr to first dcl of this token */
	2 name,				/* ACC */
	  3 size		unal unsigned fixed bin (9), /* number of chars in token */
	  3 string	unal char(n refer(runtime_token.size));
/* end of rutime symbol structures */

%include concom;
%include erflgs;
%include objnfo;
%include pl1_symbol_block;
%include relbit;
%include sthedr;

end alm_symtab_;




		    alm_table_tool.pl1              10/17/88  1013.9rew 10/17/88  0929.4      290673



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




/****^  HISTORY COMMENTS:
  1) change(86-11-04,JRGray), approve(86-11-04,MCR7507),
     audit(86-11-05,RWaters), install(86-11-12,MR12.0-1202):
     Modified to transparently handle history comments in the 'include' files.
  2) change(88-09-07,JRGray), approve(88-09-07,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     Modified to remind that this program must be compiled with -table. Also
     fixed Capitalization problems.
                                                   END HISTORY COMMENTS */


att:alm_table_tool: proc options(variable);

/* Note: as this program calls cds, it must be compiled with -table */

/* alm_table_tool takes as input two include files, a table of [instructions X
decors] (DECOR_TABLE.incl.pl1) and a list of opcode defining ALM macros
(defops.incl.alm) from oplook_.alm, and produces as output a new version of
defops.incl.alm and two external static data structures: alm_data2, a bit
table denoting decor_class/decor compatibility, and alm_data1, a decor name
table used to assign numeric codes to the decors.  Both structures are
referenced by pass1_ and pass2_. 

     alm_table_tool is currently implemented as a command.

           Usage: alm_table_tool PATH1 PATH2

           where PATH1 is DECOR_TABLE.incl.pl1
                                 and
                 PATH2 is defops.incl.alm

	DECOR_TABLE.incl.pl1 and defops.incl.alm must conform to certain
standards to be accepted by alm_table_tool.  Since there are already current
versions of both, one simple way to avoid running afoul of these standards is
to make changes to the existing versions consistent with their current form.
At this writing, DECOR_TABLE.incl.pl1 is %included as a huge PL1 comment in
alm_table_tool itself.  Defops.incl.alm is %included in oplook_.alm.

     Assumptions about DECOR_TABLE.incl.alm:

	alm_table_tool assumes that the entire include file is a pl1
comment.  It assumes that the table consists of two parts, the first preceded
by the keyword "NAMES:" and the second preceded by the keyword "TABLE:".  It
assumes that the names section consists of a series of definitions separated
by whitespace.  Each definition consists of a dummy name (any character string
except "table") followed immediately by a colon, and a series of synonyms
(separated by whitespace and terminated by a semicolon).  In the table
section, there must be one column for each dummy name in the names section,
headed by that dummy name.  alm_table_tool uses the dummy names only to
coordinate synonyms with table columns.  Any name that is to be used as an
operand to the decor pseudo-op should be included as a synonym to some dummy
name in the names section.  alm_table_tool assumes that there is a "|"
delimiter between each column header and one after the last header.  It
assumes the "-------------------------------------------" boundary follows.
For each row, it assumes a "|" delimiter after the instruction name, one
between each row/column intersection, and one at the end of the row.  (Just
the kind of thing you'd expect).  If a given instruction is not in a given
decor, then whitespace should appear at the intersection of the instruction's
row and decor's column on the table, otherwise an "X" should appear
(alm_table_tool will also accept "x").  alm_table_tool assumes that a row
terminates with a new_line character.



     Assumptions about defops.incl.alm:

          alm_table_tool assumes that "defop" is the name of the macro, that
there are no spaces between members of the operand list, and that the last
operand of every defop denotes decor class.  If one finds it desirable to
alter any of these features of the macro, one should also alter alm_table_tool
to handle the change.  alm_table_tool also assumes that the defop segment it
receives as input has nothing else but defop macros in it.


      alm_table_tool's output:

          alm_table_tool writes new versions of defops.incl.alm, alm_data1,
and alm_data2 in the working directory.  Oplook_.alm must be reassembled to
incorporate the new defop macros.  Alm_data1 and alm_data2, which are
referenced by pass1_.pl1 and pass2_.pl1, need merely be replaced
in bound_alm by the new versions.  Pass1_.pl1 and pass2_.pl1 need not be
recompiled.    


IMPLEMENTATION STRATEGY:

	Each instr in DECOR_TABLE.incl.pl1 is a memeber of exactly one decor
class. A decor class is simply a compound predicate stating which set of
decors its members belong to. Since a row in the DECOR_TABLE is a vector with
a boolean (yes or no) slot for each decor, unique values of this vector denote
unique decor classes. alm_table_tool thus establishes an initial numbering of
decor classes by letting the binary value of the boolean vector number the
class denoted by that vector. Thus:

		| A | B | C | D |
	----------|-----------------
	 instr	| X |   | X |   |   

tells us that instr is in decor class "1010" = 9;

	Since not all possible classes are likely to be used (not all
possible bit patterns are represented by some row), the classes are then
renumbered so that if n classes are used they are numbered from 0 to n-1.
The table of decor_class/decor compatibilty (alm_data2) is then simply built
by "stacking" the bit patterns for each class on top of each other with class
0 at the top and class n-1 at the bottom. The class no for each instr (derived
from the bit pattern of its row in the table) is then placed in the
appropriate field for each instr in the defop macros of defops.incl.alm. The
main passes of the assembler will check instr/decor compatibility by first
calling oplook_ to get the decor_class for a given instr, and then taking the
decor_class as a row index and the current decor as a column index into
alm_data2.

/* DECOR_TABLE.incl.pl1 */

%include DECOR_TABLE;



    /* LOCAL ERROR HANDLER */
         on  local_error goto return_point;

    /* IN CASE OF INTERUPT */
         on cleanup call clean_up;

    /* GET TABLE AND DEFOP SEG PTRS  */
        call cu_$arg_count(arg_no);
        if arg_no ^=2
           then do;
                   call com_err_$suppress_name(0,this_pgm,"Usage: alm_table_tool table_seg_path defops_seg_path");
                   return;
                end;

        call cu_$arg_ptr(1,arg1p,arg1l,code);
        if code ^=0 | arg1 = ""
            then do;
                   call com_err_(error_table_$noarg,this_pgm);
                   return;
                 end;

        call cu_$arg_ptr(2,arg2p,arg2l,code);
        if code ^=0
            then do;
                   call com_err_(code,this_pgm,"while in cu_$arg_ptr");
                   return;
                 end;

        call expand_pathname_(arg1,dir_name,entry_name,code);
        if code ^=0
            then do;
                    call com_err_(code,this_pgm,arg1,"while in expand_pathname_");
                    return;
                 end;

        call hcs_$initiate_count(dir_name,entry_name,"",bit_ct,0,table_ptr,code);
        if table_ptr = null
            then do;
                    call com_err_(code,this_pgm,"while in hsc_$initiate_count");
                    return;
                 end;

        table_length = divide(bit_ct+8,9,24,0);

        call expand_pathname_(arg2,dir_name,entry_name,code);
        if code ^=0
            then do;
                    call com_err_(code,this_pgm,arg2);
                    return;
                 end;

        call hcs_$initiate_count(dir_name,entry_name,"",bit_ct,0,defops_ptr,code);
        if defops_ptr = null
            then do;
                    call com_err_(code,this_pgm,"while in hcs_$initiate_count");
                 end;

        defops_length = divide(bit_ct+8,9,24,0);


    /* COLLECT DECOR NAMES and INITIALIZE VARIABLES */

        call get_first_symbol(table,cursor,current_symbol);
        if substr(current_symbol,1,2) ^= "/*"
            then do;
	          call com_err_(0,this_pgm,"First symbol must be pl1 comment.");
		signal local_error;
	       end;
        if length(current_symbol) > 2
            then current_symbol = substr(current_symbol,3);
	  else call get_next_symbol(table,cursor,current_symbol);

/* Skip over comments that don't begin with "names:" or "NAMES:" */
        do while(current_symbol ^= "NAMES:" & current_symbol ^= "names:" & current_symbol ^= "");
	   do while(current_symbol ^= "*/" & current_symbol ^= " ");
		call get_next_symbol(table,cursor,current_symbol);
	     end;
	   if current_symbol = "*/" then do;
		call get_next_symbol(table, cursor, current_symbol);
		if substr(current_symbol, 1, 2) ^= "/*" then do;
		     call com_err_(0,this_pgm,"First symbol must be pl1 comment.");
		     signal local_error;
		  end;
		if length(current_symbol) > 2 then current_symbol = substr(current_symbol, 3);
		else call get_next_symbol(table,cursor,current_symbol);
	     end;
	end;

        if current_symbol ^="NAMES:" & current_symbol ^= "names:"
            then do;
	          call com_err_(0,this_pgm,"First non-comment symbol of DECOR_TABLE.incl must be ""NAMES:""");
		signal local_error;
	       end;


       do n = 1 to hbound(temp_array,1);
           temp_array(n).ptr = null;
       end;
       n = 0;

       call get_next_symbol(table,cursor,current_symbol);
       do while(current_symbol ^= "TABLE:" & current_symbol ^= "table:");
           n = n + 1;
	 if n > hbound(temp_array,1)
	     then do;
	             call com_err_(0,this_pgm,"Number of dummy names supplied excedes current maximum of ^d.",hbound(temp_array,1));
		   signal local_error;
		end;
           temp_array(n).name = substr(current_symbol,1,length(current_symbol)-1);
	 call get_next_symbol(table,cursor,current_symbol);
	 
           end_of_synonyms = "0"b;
           do while(^end_of_synonyms);
	     ptr_saver = temp_array(n).ptr;
	     allocate chain_node in(chain_space) set(temp_array(n).ptr);
	     temp_array(n).ptr -> chain_node.next = ptr_saver;
	     temp_array(n).ptr -> chain_node.name = current_symbol;
	     if index(temp_array(n).ptr -> chain_node.name,";")^=0
	         then do;
	                 temp_array(n).ptr -> chain_node.name = substr(temp_array(n).ptr -> chain_node.name,1,length(temp_array(n).ptr -> chain_node.name)-1);
		       end_of_synonyms = "1"b;
		    end;
               call get_next_symbol(table,cursor,current_symbol);
	     if current_symbol = ";"
	         then do;
	                 end_of_synonyms = "1"b;
		       call get_next_symbol(table,cursor,current_symbol);
		    end;
           end;

        end;



        call get_next_symbol(table,cursor,current_symbol); /* get symbol after
"TABLE:" */
        table_position = cursor;    /* save table position */
        line = current_line(table,cursor);
        call get_first_symbol((line),cursor,current_symbol); /* resets cursor relative to top line of table */
        table_position = table_position - cursor; /* so table_position equals beginning of line */
        if current_symbol ^= "|"
            then do;
	         call com_err_(0,this_pgm,"""|"" must be first character in table.");
	         signal local_error;
	       end;
        call get_next_symbol((line),cursor,current_symbol);


/* COUNT DECORS FORM COLUMN HEADINGS AND COORDINATE WITH NAMES */

    /* initialize */
        DEC_no = 0;
        m = 0;

        do while(current_symbol ^= "");
            DEC_no = DEC_no + 1;

         /* chase chain */

            do n= 1 to hbound(temp_array,1) while(current_symbol ^= temp_array(n).name);
	  end;
	  if current_symbol ^= temp_array(n).name
	      then do;
	             call com_err_(0,this_pgm,"""^a"" has not been defined in the NAMES section.",current_symbol);
		   signal local_error;
		 end;
            temp_ptr = temp_array(n).ptr;
	  do while(temp_ptr ^= null);
	      m = m + 1;
	      allocate name_stack;
	      name_stack.name = temp_ptr -> chain_node.name;
	      name_stack.number = DEC_no;
	      temp_ptr = temp_ptr -> chain_node.next;
	  end;

	  call get_next_symbol((line),cursor,current_symbol);
	  if current_symbol ^= "|"
	      then do;
	              if current_symbol = ""
	                 then message = "Top line of table must end with ""|"" delimiter";
		       else message = "Some column in table is missing a ""|"" delimiter";
		    call com_err_(0,this_pgm,message);
		    signal local_error;
		 end;
           call get_next_symbol((line),cursor,current_symbol);
        end;

/* CREATE ALM_DATA1 */

begin; /* so alm_data1 can get the extents just computed */

	/* FORMAT OF ALM_DATA1 */
          /* changes to this fromat should be propogated to alm_data.incl.pl1 */

     dcl 1 alm_data1,
	 2 structure,
	   3 num_of_names fixed init(allocation(name_stack)),
	   3 decor_name (allocation(name_stack)),
	     4 name  char(24) varying,
	     4 number fixed bin(35);
     dcl (n,m) fixed;

        m = allocation(name_stack);
        do n = m to 1 by -1;
            alm_data1.structure.decor_name(n).name = name_stack.name;
	  alm_data1.structure.decor_name(n).number = name_stack.number;
	  free name_stack;
        end;

        cds_argsA.sections(1).p = addr(alm_data1);
        cds_argsA.sections(1).len = size(alm_data1);
        cds_argsA.sections(1).struct_name = "alm_data1";
        cds_argsA.seg_name = "alm_data1";
        cds_argsA.num_exclude_names = 0;
        cds_argsA.exclude_array_ptr = null;
        cds_argsA.switches.defs_in_link = "0"b;
        cds_argsA.switches.separate_static = "0"b;
        cds_argsA.switches.have_text = "1"b;
        cds_argsA.switches.have_static = "0"b;
        cds_argsA.switches.pad = "0"b;

        call create_data_segment_(addr(cds_argsA),code);
        if code ^= 0
            then do;
	          call com_err_(code,this_pgm,"while creating alm_data1");
		signal local_error;
	       end;

end; /* begin block */        



/* DIGEST TABLE INFO */

        array_size = 2**DEC_no;
        cursor = cursor + table_position ;  /* reset relative to table */


    /* skip stuff */
         call get_next_symbol(table,cursor,current_symbol);
         if substr(current_symbol,1,5) ^= "-----"
             then do;
		 call com_err_(0,this_pgm,"Expecting ""---..."", found ""^a"".^/   Current line is:^/^a",current_symbol,current_line(table,cursor));
                     signal local_error;
                  end;
         call get_next_symbol(table,cursor,current_symbol);



begin;
       dcl  bit_string          bit(DEC_no*DEC_no*2) varying init(""b);
       dcl class_array(0:array_size-1) bit(1) unaligned;
       dcl bit_register(DEC_no) bit(1) unaligned;
       dcl bit_register_overlay bit(DEC_no) defined bit_register;

   /* PROCESS INSTRUCTIONS */
        class_array = "0"b;
        do while(current_symbol ^= "*/");
            allocate instruction; 
            instruction.name = current_symbol;
            last_symbol = current_symbol;
            call get_next_symbol(table,cursor,current_symbol);
            if current_symbol ^= "|"
                then do;
		   call com_err_(0,this_pgm,"Instruction table is defective. Just processed ""^a"", expecting ""|"", found ""^a"".^/   Current line is:^/^a",last_symbol,current_symbol,current_line(table,cursor));
                       signal local_error;
                     end;
            slot_no = 0;
            bit_register = "0"b;
            do while(current_symbol = "|" );
	      slot_no = slot_no + 1;
                call get_next_symbol(table,cursor,current_symbol);
                if current_symbol = "X" | current_symbol = "x"
                    then do;
                            bit_register(slot_no) = "1"b;
                            call get_next_symbol(table,cursor,current_symbol);
                            if current_symbol ^= "|"
                                then do;
				call com_err_(0,this_pgm,"Instruction table is defective. Just processed ""X"", expecting ""|"", found ""^a"".^/   Current line is:^/^a",current_symbol,current_line(table,cursor));
                                        signal local_error;
                                     end;
                         end;
            end;
            if slot_no ^= DEC_no + 1
	      then if slot_no < DEC_no + 1
	              then do;
			  call com_err_(0,this_pgm,"Unrecognized symbol ""^a"" in current line:^/^a^/    or previous line has too few columns.",current_symbol,current_line(table,cursor));
			   signal local_error;
			end;   
                         else do;
			   call com_err_(0,this_pgm,"Too many columns in the line at or near this one:^/^a",current_line(table,cursor-3));
			   signal local_error;
			end;
            instruction.number = binary(bit_register_overlay); 
            class_array(instruction.number) = "1"b;
        end; 

        call get_next_symbol(table,cursor,current_symbol);

	/* Skip over comments */
        do while(substr(current_symbol, 1, 2) = "/*");
	   if length(current_symbol) > 2 then current_symbol = substr(current_symbol, 3);
	   else call get_next_symbol(table,cursor,current_symbol);
	   do while(current_symbol ^= "*/");
	        call get_next_symbol(table,cursor,current_symbol);
	        if current_symbol = "" then do;
		   call com_err_(0,this_pgm,"DECOR_TABLE.incl.pl1 end while in comment.");
		   signal local_error;
		 end;
	     end;
	   call get_next_symbol(table,cursor,current_symbol);
	end;

        if current_symbol ^= ""
            then do;
	          call com_err_(0,this_pgm,"""^a"" was found at the end of DECOR_TABLE.incl, outside of the pl1-comment delimiters.",current_symbol);
		signal local_error;
	       end;



    /* COUNT NO OF DECOR CLASSES */

        no_of_classes = 0;
        do n = 0 to array_size-1;
            if class_array(n)
                then no_of_classes = no_of_classes + 1;
	      if no_of_classes > current_max_of_classes
	          then do;
		        call com_err_(0,this_pgm,"Number of unique intersections of decors excedes current maximum of ^d.",current_max_of_classes);
		        signal local_error;
		     end;
        end;
        hash_no = closest_prime(no_of_classes);


     begin;
       dcl  hash_table(0:hash_no) ptr;
       dcl 1 hash_entry  based(hash_entry_ptr),
             2 instr_no     fixed bin(17),
             2 class_no     fixed bin(17),
             2 next         ptr;
       dcl hash_entry_ptr   ptr;

	/* FORMAT OF ALM_DATA2 */
          /* changes to this format should be propogated to alm_data.incl.pl1 */

      dcl 1 alm_data2,
	  2 structure,
	    3 num_of_classes_less_1  fixed init(no_of_classes-1),
	    3 num_of_decors   fixed init(DEC_no),
	    3 compatible (0:no_of_classes-1) bit(DEC_no);

    /* BUILD HASH TABLE */
        hash_table = null;
        clsnum = -1; /* clsnum is incremented before it is used; the first class no. will be 0 */


        do n = 0 to array_size-1;
            if class_array(n) /* if there is such a class */
                then do;
                         clsnum = clsnum + 1;

                         hash_index = mod(n,hash_no);
                         if hash_table(hash_index) = null
                             then do; /* create and link new entry */
                                     allocate hash_entry;
                                     hash_table(hash_index) = hash_entry_ptr;
                                  end;
                         else do; /* go to the end and create new entry */
                                 ptr1 = hash_table(hash_index);
                                 do while(ptr1 -> hash_entry.next ^= null);
                                     ptr1 = ptr1 -> hash_entry.next;
                                 end;
                                 allocate hash_entry;
                                 ptr1 -> hash_entry.next = hash_entry_ptr;
                              end;
                       /* put_info_in_new_entry */ 
                         hash_entry.instr_no = n;
                         hash_entry.class_no = clsnum;
                         hash_entry.next = null;

		/*  fill in alm_data2's rows */
                         alm_data2.structure.compatible(clsnum) = substr(bit(n,17),17 - DEC_no + 1);
                     end;
           end;



     /* WRITE ALM_DATA2 */

        cds_argsA.sections(1).p = addr(alm_data2);
        cds_argsA.sections(1).len = size(alm_data2);
        cds_argsA.sections(1).struct_name = "alm_data2";
        cds_argsA.seg_name = "alm_data2";
        cds_argsA.num_exclude_names = 0;
        cds_argsA.exclude_array_ptr = null;
        cds_argsA.switches.defs_in_link = "0"b;
        cds_argsA.switches.separate_static = "0"b;
        cds_argsA.switches.have_text = "1"b;
        cds_argsA.switches.have_static = "0"b;
        cds_argsA.switches.pad = "0"b;

        call create_data_segment_(addr(cds_argsA),code);
        if code ^= 0
            then do;
	          call com_err_(code,this_pgm,"while creating alm_data2");
		signal local_error;
	       end;



     /* TRANSLATE INSTRUCTION NO'S TO DECOR CLASS NO'S */
           do while(allocation(instruction) ^=0); 
               allocate instruction2;
               instruction2 = instruction; 
               free instruction;
               hash_index = mod(instruction2.number ,hash_no);
               ptr1 = hash_table(hash_index);
               do while(ptr1 -> hash_entry.instr_no ^= instruction2.number);
                   ptr1 = ptr1 -> hash_entry.next;
               end;
               instruction2.number = ptr1 -> hash_entry.class_no;
           end; 

     end; /*  begin block */


     /* PUT DECOR CLASS NO's IN DEFOPS */
          working_dir = get_wdir_();
	call hcs_$make_seg(working_dir,"defops.incl.alm","",10,dont_care,code);
	if code ^= 0
	    then do;
	            call com_err_(code,this_pgm,"while trying to write defops.incl.alm");
	            signal local_error;
	         end;

          open file(defops_incl_alm) title("vfile_ "||rtrim(working_dir)||">defops.incl.alm") output;

          call get_first_symbol(defops,cursor,current_symbol);

/* Skip over leading comments */
	do while(current_symbol ^= "" & substr(current_symbol, 1, 1) = """");
	     comment_length = index(substr(defops, cursor), new_line) - 1;
	     if comment_length = 0 then comment_length = defops_length - cursor + 1;
	     put file(defops_incl_alm) skip edit(substr(defops, cursor, comment_length)) (a);
	     cursor = cursor + comment_length;
	     call get_next_symbol(defops,cursor,current_symbol);
	  end;

          macro_line = current_symbol||"     ";
          do while(current_symbol ^="");
              if allocation(instruction2) = 0
                  then do;
		      call com_err_(0,this_pgm,"There are more defops than entries in the table.");
                          signal local_error;
                       end;
              call get_next_symbol(defops,cursor,current_symbol);
              if index(current_symbol,instruction2.name) ^=1
                  then  do;
		       call com_err_(0,this_pgm,"Defop and table entries don't match.^/  Current defop entry is ""^a"".^/  Current table entry is ""^a"".",current_symbol,instruction2.name);
                           signal local_error;
                        end;
              begin;
                    dcl significance fixed bin(17),
                        char_num char(2) varying,
                        last_comma  fixed bin(17),
                        untouched_part   char(100) varying;
                    significance = verify(char(instruction2.number)," ");
                    char_num = substr(char(instruction2.number),significance);
                    last_comma = search(reverse(current_symbol),",") - 1;
                    untouched_part = substr(current_symbol,1,length(current_symbol) - last_comma);
                    macro_line = macro_line||untouched_part||char_num;
                    put file(defops_incl_alm) skip edit(macro_line) (x(10),a);
              end;
              free instruction2;
              call get_next_symbol(defops,cursor,current_symbol);

	/* Skip over comments */
	     do while(current_symbol ^= "" & substr(current_symbol, 1, 1) = """");
		comment_length = index(substr(defops, cursor), new_line) - 1;
		if comment_length = 0 then comment_length = defops_length - cursor + 1;
		put file(defops_incl_alm) skip edit(substr(defops, cursor, comment_length)) (a);
		cursor = cursor + comment_length;
		call get_next_symbol(defops,cursor,current_symbol);
	       end;

              macro_line = current_symbol||"     ";
          end;

          put file(defops_incl_alm) skip;
	close file(defops_incl_alm);



end;  /* of begin block */

return_point:  call clean_up;



     /* SUBROUTINES */
               
       closest_prime: proc(n) returns(fixed bin(17));
                      dcl n    fixed bin(17);
                      return(n);
       end closest_prime;

       get_first_symbol: proc(text,cursor,ret_arg);
                         dcl text   char(*) ,
                             ret_arg char(*) varying,
                             cursor  fixed bin(35),
                             extent  fixed bin(35);
                         cursor = verify(text,white_space);
                         if cursor = 0
                             then ret_arg = "";
                         else do;
                                 extent = search(substr(text,cursor),white_space)-1;
                                 if extent = -1
                                     then ret_arg = substr(text,cursor);
                                 else ret_arg = substr(text,cursor,extent);
                              end;
       end get_first_symbol;

       get_next_symbol: proc(text,cursor,symbol);
                         dcl text   char(*) ,
                             symbol char(*) varying,
                             cursor  fixed bin(35),
                             extent  fixed bin(35),
                             (temp_ptr,temp_ptr2)  fixed bin(35);
                         extent = search(substr(text,cursor),white_space);
                         if extent =0
                             then symbol = "";
                         else do;
                                 temp_ptr = cursor + extent - 1;
                                 temp_ptr2 = verify(substr(text,temp_ptr),white_space);
                                 if temp_ptr2 = 0
                                     then symbol = "";
                                 else do;
                                         cursor = temp_ptr + temp_ptr2 - 1;
                                         extent = search(substr(text,cursor),white_space) - 1;
                                         if extent = -1
                                              then symbol = substr(text,cursor);
                                         else symbol = substr(text,cursor,extent);
                                      end;
                              end;
       end get_next_symbol;

      current_line:proc(text,cursor) returns(char(300) varying);
              dcl text      char(*) ,
	        cursor    fixed bin(35);
	    dcl (n,new_cursor,extent)         fixed bin(35);

	    n = index(reverse(substr(text,1,cursor)),new_line);
	    if n=0
	        then new_cursor = 1; /* this is the first line */
	    else new_cursor = cursor - n +2;
	    extent = index(substr(text,new_cursor),new_line);
	    if extent = 0
	        then return( substr(text,new_cursor) ); /* last line */
	    else return( substr(text,new_cursor,extent) );
     end current_line;




    clean_up: proc;
                 do while(allocation(instruction) ^=0);
                     free instruction;
                 end;
                 do while(allocation(instruction2) ^=0);
                     free instruction2;
                 end;
	       do while(allocation(name_stack)^=0);
	           free name_stack;
	       end;
	       close file(defops_incl_alm);
    end clean_up;



     /* DECLARATIONS */

      dcl (arg1l,arg2l)                       fixed bin(21),
          (arg1p,arg2p,table_ptr,defops_ptr)  pointer,
          code                                fixed bin(35),
          arg1                                char(arg1l) based(arg1p),
          arg2                                char(arg2l) based(arg2p),
          table                               char(table_length)   based(table_ptr),
          defops                              char(defops_length)  based(defops_ptr),
          bit_ct                              fixed bin(24),
          dir_name                            char(168),
          entry_name                          char(32),
          arg_no                              fixed bin,
          null                                builtin,
	this_pgm                            char(14) init("alm_table_tool"),
          error_table_$noarg                  fixed bin(35) ext static,
          cu_$arg_ptr                         entry (fixed bin,ptr,fixed bin(21),fixed bin(35)),
          com_err_                            entry() options(variable),
          com_err_$suppress_name              entry() options(variable),
          cu_$arg_count                       entry(fixed bin),
          hcs_$initiate_count                 entry(char(*),char(*),char(*),fixed bin(24),fixed bin(2),ptr,fixed bin(35)),
          expand_pathname_                    entry (char(*),char(*),char(*),fixed bin(35)),
          cursor             fixed bin(35),
	DEC_no		fixed bin(17),
          current_symbol                      char(200) varying;
      dcl 1 instruction controlled,
            2 name   char(10) varying,
            2 number fixed bin(17);
      dcl 1 instruction2 controlled,
            2 name    char(10) varying,
            2 number   fixed bin(17);
     dcl (slot_no,no_of_classes,clsnum,hash_no)   fixed bin(17);

       dcl local_error condition;
       dcl white_space char(5) init("	 
");
       dcl ptr1                ptr,
           table_length        fixed bin(23),
           defops_length       fixed bin(23),
           array_size          fixed bin(17),
           last_symbol         char(200) varying,
           n                   fixed bin(17),
           hash_index          fixed bin(17),
	 table_position      fixed bin(17),
           macro_line          char(100) varying,
           declaration         char(200) varying,
	 length_of_pseudop   fixed bin (17) internal static init(8) options(constant),
	 decor_name(16)      char(length_of_pseudop) varying,
	 message             char(100) varying,
	 line                char(300) varying;
  dcl      1 temp_array(100),
             2 name   char(24) varying,
	   2 ptr    ptr;

  dcl      1 chain_node  based,
             2 name    char(24) varying,
	   2 next    ptr;

  dcl	 1 name_stack controlled,
  	   2 name char(24) varying,
	   2 number fixed bin(35);

  dcl	 comment_length fixed bin;
  dcl	 new_line char(1) int static options(constant) init("
");
  dcl 	 current_max_of_classes  fixed   internal static options(constant) init(16);
  dcl      working_dir  char(168) ;
  dcl      get_wdir_  entry  returns(char(168));
  dcl      hcs_$make_seg  entry (char(*),char(*),char(*),fixed bin(5),ptr, fixed bin(35));
  dcl      create_data_segment_ entry (ptr, fixed bin(35));
  dcl     dont_care  ptr;
  dcl      chain_space area(1024);
  dcl     end_of_synonyms bit(1);
  dcl   (temp_ptr,ptr_saver)     ptr;
  dcl      (m,j)     fixed bin;
  dcl	(addr,allocation,binary,bit,char,divide,empty,hbound,index,length,
	mod,reverse,rtrim,search,size,substr,verify) builtin;

  %include  cds_args;
  dcl     1 cds_argsA  like cds_args;
  dcl   cleanup  condition;
  dcl   defops_incl_alm  file;
end alm_table_tool;




		    ascevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.0       53361



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


/* ASCEVL_ - program to evaluate the ACI, ACC, and BCI pseudo-ops.
   Returns the converted string and word count, and next break. */

ascevl_$accevl:
     procedure (rslts) returns (fixed binary);

/*	Modified 3/6/77 by NIM to implement ac4 pseudo-op.
	Modified 740830 by PG to allow optional length field to specify padding. Program was rewritten.
   Modified on 01/15/73 at 01:59:12 by R F Mabee.
   by R F Mabee on 15 January 1973 to add BCD strings.
   by R F Mabee on 16 August 1972 to fix some bugs in listing ACC statements.
   by RHG on 23 Sept 1970 to call inputs_$ascii_literal */

/* PARAMETERS */

declare  rslts (42) fixed binary (35) parameter;

/* BUILTINS */

declare (addr, bin, bit, ceil, copy, divide, floor, hbound, length, mod, substr) builtin;

/* EXTERNAL ENTRIES CALLED BY ASCEVL */

declare  inputs_$next external entry,
         inputs_$ascii_literal external entry,
         inputs_$nxtnb external entry,
         varevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
         fixed bin (26)) returns (fixed bin (26));

/* AUTOMATIC DATA USED BY ASCEVL */

declare (pad_length, pad_start, delta, n_words, max_length, out, chars_per_word) fixed bin;
declare  quote fixed binary (35);
declare (acc_type, too_long) bit (1) aligned;
declare (basno, value, admod, b29, iaddr) fixed bin (26);
declare  string_ptr ptr;

/* BASED STRUCTURES */

declare  ascii (1:168) based (string_ptr) unaligned bit (9),
         ascii_string char (168) based (string_ptr) unaligned,
         bcd (1:252) based (string_ptr) unaligned bit (6),
         bcd_string bit (252*6) based (string_ptr) unaligned,
         asc4 bit (42*36) based (string_ptr) unaligned;

/* EXTERNAL DATA */

declare  eb_data_$bcd_table (0:127) external unaligned bit (6);

/* INCLUDE FILES FOR ASCEVL */

% include varcom;
% include concom;
% include codtab;
% include erflgs;

/* program */

						/* ACC pseudo-op. */
	chars_per_word = 4;
	max_length = hbound (ascii (*), 1);
	acc_type = "1"b;
	go to begin;

ascevl_$acievl:					/* ACI pseudo-op. */
	entry (rslts) returns (fixed binary);
	chars_per_word = 4;
	max_length = hbound (ascii (*), 1);
	acc_type = "0"b;
	go to begin;

ascevl_$ac4evl:					/* AC4 pseudo-op. */
	entry (rslts) returns (fixed binary);
	chars_per_word = 8;
	max_length = divide (length (asc4), 4.5, 17, 0);
	acc_type = "0"b;
	go to begin;

ascevl_$bcdevl:					/* BCI pseudo-op. */
	entry (rslts) returns (fixed binary);
	chars_per_word = 6;
	max_length = hbound (bcd (*), 1);
	acc_type = "0"b;

begin:
	too_long = "0"b;

	if acc_type then
	     out = 2;
	else
	     out = 1;				/* skip over count position if acc */

	string_ptr = addr (rslts);			/* where to store chars */

	call inputs_$nxtnb;
	quote = brk (2);				/* use the actual ASCII character as the bounding character in binary */

	do while ("1"b);
	     call inputs_$ascii_literal;		/* get next character */
	     if brk (2) = quote then do;		/* if termination character */
		call inputs_$next;			/* get next character */
		if brk (2) ^= quote then do;		/* two termination chars in a row means insert one of them */

/* check for optional length field. */
		     if brk (1) = icomma then do;
			if (varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then
			     go to undefined_symbol_error;

			if iaddr ^= 0 then
			     go to lc_error;

			if value > max_length then do;
			     too_long = "1"b;
			     value = max_length;
			end;

			delta = value - out + 1;

			if delta < 0 then
			     too_long = "1"b;
			else if delta > 0 then do;	/* avoid stupid IPR fault */
			     if chars_per_word = 4 then
				substr (ascii_string, out, delta) = " ";
			     else if chars_per_word = 6 then
				substr (bcd_string, 6 * out - 5, 6 * delta) = copy ("20"b3, delta);
			     else do;
				pad_start = floor (out * 4.5) - 3;
				pad_length = ceil (value * 4.5) + 1 - pad_start;
				substr (asc4, pad_start, pad_length) = "0"b;
			     end;
			     out = out + delta;
			end;
		     end;
error_return:
		     n_words = divide (out - 1 + chars_per_word - 1, chars_per_word, 18, 0);
		     delta = chars_per_word * n_words - out + 1;

		     if delta > 0 then		/* avoid IPR fault */
			if chars_per_word = 4 then
			     substr (ascii_string, out, delta) = (3) ""; /* \000 */
			else if chars_per_word = 6 then
			     substr (bcd_string, 6 * out - 5, 6 * delta) = (30)"0"b;
			else
			     substr (asc4, floor (out * 4.5) - 3, floor (4.5 * delta)) = "0"b;

		     if acc_type then
			ascii (1) = bit (bin (out - 2, 9), 9);

		     if too_long then
			prnte = 1;

		     return (n_words);
		end;
	     end;

	     if out > max_length then
		too_long = "1"b;
	     else do;
		if chars_per_word = 4 then		/* put this char in result string */
		     ascii (out) = bit (bin (brk (2), 9), 9);
		else if chars_per_word = 6 then
		     bcd (out) = eb_data_$bcd_table (brk (2));
		else do;
		     pad_start = ceil (out * 4.5) - 3;
		     if mod (out, 2) ^= 0 then
			substr (asc4, pad_start - 1, 1) = "0"b;
		     substr (asc4, pad_start, 4) = substr (unspec (brk (2)), 33, 4);
		end;
		out = out + 1;
	     end;
	end;

lc_error:
	prnte = 1;
	go to error_return;

undefined_symbol_error:
	prntu = 1;
	go to error_return;

     end ascevl_$accevl;




		    decevl_.pl1                     10/24/88  1634.8r w 10/24/88  1358.5       77418



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



/****^  HISTORY COMMENTS:
  1) change(86-09-03,Oke), approve(86-09-03,MCR7543), audit(86-09-30,JRGray),
     install(86-10-08,MR12.0-1180):
     Extend decimal input
     processing to permit 1 or 2 word values.  User explicitly requests
     double precision integer decimal input by using a "L" suffix.
     Previously only single word values were generated, with no detected
     errors.  Permits double-word decimal literals to be generated.  Needed
     by the C compiler.
                                                   END HISTORY COMMENTS */

/* Evaluate decimal literal field, return results and break.

   Fixed and real constants may be single or double precision.  Decevl is
   called from pass1 and pass2 (for dec pseudo-op) and by litevl (for
   literals).  The parameter type is used by litevl in case of du or dl
   modifier requiring a truncation of results.  Note that according to bsa
   standards, fields may be separated by commas or blanks.  Machine language
   subroutines are used to manipulate the double precision words.

   Last modified:
	by RHG on 22 sept 1970 to handle multi-line ascii literals properly
   Last modified:
	by BLW on 8 Sept 1973 to use accurate conversion routines.  Machine
	language subroutine is no longer used to manipulate double precision
	words.  decevl_ was converted to version 2 pl1 with minimum changes
	needed.
   Modified 7 July 1980 by M. N. Davidoff to issue "E" diagnostic instead of raising size, also cleaned it up some.
*/
/* format: style2 */
decevl_:
     procedure (rslts, type) returns (fixed bin (35));

	declare rslts		 (10) fixed bin (35);
	declare type		 fixed bin (26);

/* automatic */

	declare 1 attr,
		2 binary		 bit (1),
		2 double		 bit (1),
		2 float		 bit (1);
	declare binpt		 fixed bin (26);
	declare buffer		 char (64);
	declare double		 bit (1) aligned;
	declare first		 bit (1) aligned;
	declare next_sw		 bit (1) aligned;
	declare prec		 fixed bin (35);
	declare saw_point		 bit (1) aligned;
	declare scale		 fixed bin (26);
	declare 1 x_structure	 aligned,		/* NOTE: x must start on an even boundary. */
		2 pad1_for_alignment fixed bin (71),
		2 x		 (3) fixed bin (26);
	declare xp		 fixed bin (26);

/* based */

	declare 1 brk_overlay	 aligned based (addr (brk (2))),
		2 skip		 char (3) unal,
		2 ch		 char (1) unal;
	declare 1 number		 aligned based (addr (buffer)),
		2 sign		 char (1) unal,
		2 digit		 (prec) char (1) unal,
		2 skip		 bit (1) unal,
		2 exponent	 fixed bin (7) unal;

/* builtin */

	declare (addr, byte, divide, length, max, min, rank, string, substr, unspec)
				 builtin;

/* condition */

	declare (overflow, size)	 condition;

/* external static */

	declare eb_data_$iasc	 fixed bin (35) external static;
	declare eb_data_$iflt	 fixed bin (35) external static;
	declare eb_data_$ifxd	 fixed bin (35) external static;
	declare eb_data_$iint	 fixed bin (35) external static;

/* entry */

	declare assign_		 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	declare inputs_$ascii_literal	 entry;
	declare inputs_$next	 entry;
	declare inputs_$nxtnb	 entry;

%include varcom;
%include erflgs;
%include codtab;
%include std_descriptor_types;

/* program */

	double = ""b;			/* Assume single prec int */
	xp = 0;
	saw_point = "0"b;
	string (attr) = ""b;
	first = "1"b;
	prec = 0;
	scale = 0;
	binpt = 71;
	number.sign = "+";

	on overflow, size goto return_from_size;

/* main loop for collecting digits, check for sign, point, and a, b, d, or e
   fields following number. */

	do while ("1"b);
	     next_sw = "1"b;

	     if brk (1) = inum
	     then do;
		     if attr.float
		     then scale = scale + 1;

		     prec = prec + 1;
		     number.digit (prec) = ch;
		end;

	     else if brk (1) = ipoint
	     then do;
		     saw_point = "1"b;
		     attr.float = "1"b;
		end;

	     else if brk (1) = iminus
	     then number.sign = "-";

	     else if brk (1) = iplus
	     then ;

	     else
label_220:
		if brk (1) = ilet
	     then begin;
		     declare char		      char (1) aligned;

/* letter encountered, evaluate b, d, or e field. */

		     char = byte (brk (2));

		     if char = "a" & ^attr.binary & ^attr.float & number.sign ^= "-"
		     then begin;
			     declare chars		      char (32);
			     declare i		      fixed bin;
			     declare word_count	      fixed bin;

			     declare char_array	      (8) char (4) defined (chars);

/* ascii literal, pack characters into rslts and return count. */

			     call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
				2 * real_fix_dec_9bit_ls_dtype, prec);

			     type = eb_data_$iasc;
			     x (2) = min (x (2), length (chars));
			     word_count = max (divide (x (2) + 3, 4, 17), 1);
			     unspec (chars) = ""b;

			     do i = 1 to x (2);
				call inputs_$ascii_literal;
				substr (chars, i, 1) = byte (brk (2));
			     end;

			     do i = 1 to word_count;
				unspec (rslts (i)) = unspec (char_array (i));
			     end;

			     call inputs_$next;

			     return (word_count);
			end;

		     else if char = "b" & ^attr.binary
		     then do;
			     attr.binary = "1"b;
			     binpt = evaluate_integer_field ();
			end;

		     else if char = "L" & ^double
			then do;
			     call inputs_$next;
			     double = "1"b;
			end;
		     else do;
			     if char = "d"
			     then attr.double = "1"b;

			     else if char ^= "e"
			     then prnte = 1;	/* TRUE */

			     attr.float = "1"b;
			     xp = evaluate_integer_field ();
			end;

		     goto label_220;
		end;

	     else if ^first
	     then do;

/* end of field, convert number to proper format, set type, return results and
   break, and set value to number of words. */

		     if ^attr.binary & ^attr.float
		     then do;
			     type = eb_data_$iint;
			     call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
				2 * real_fix_dec_9bit_ls_dtype, prec);

/* if requested precision double then we supply two words. */

			     if double then do;
				rslts (1) = x (1);
				rslts (2) = x (2);
				return (2);
			     end;

/* Original assumption - return just a single word. */

			     rslts (1) = x (2);

			     return (1);
			end;

		     number.exponent = xp - scale;

		     if attr.binary
		     then do;
			     type = eb_data_$ifxd;

			     if prnte ^= 1
			     then call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, (71 - binpt) * 1f18b + 71,
				     addr (buffer), 2 * real_flt_dec_9bit_dtype, prec);
			end;

		     else do;
			     type = eb_data_$iflt;
			     call assign_ (addr (x (1)), 2 * real_flt_bin_2_dtype, 63, addr (buffer),
				2 * real_flt_dec_9bit_dtype, prec);
			end;

		     rslts (1) = x (1);
		     rslts (2) = x (2);

		     if attr.double
		     then return (2);
		     else return (1);
		end;

	     else do;
		     call inputs_$nxtnb;
		     next_sw = "0"b;
		end;

	     if next_sw
	     then call inputs_$next;

	     first = "0"b;
	end;

/* A size condition occured.  This was probably in assign_, but could have
   been in evaluate_integer_field.  Just return something so the rest of the
   program will get parsed.  If the size condition occured in the call to
   assign_ in the ascii literal, or during evaluate_integer_field, the current
   input character is not advanced passed this literal so other syntax errors
   on the input line may result. */

return_from_size:
	prnte = 1;				/* TRUE */
	type = eb_data_$iint;
	rslts (1) = 0;

	return (1);

evaluate_integer_field:
     procedure returns (fixed bin (26));

	declare int		 fixed bin (26);
	declare sign		 fixed bin;

	sign = 1;
	int = 0;
	first = "0"b;

	call inputs_$next;
	do while (brk (1) = iplus | brk (1) = iminus | brk (1) = inum);
	     if brk (1) = iminus
	     then sign = -1;

	     else if brk (1) = inum
	     then int = 10 * int + brk (2) - rank ("0");

	     call inputs_$next;
	end;

	return (sign * int);
     end evaluate_integer_field;

     end decevl_;




		    eb_data_.alm                    10/17/88  1013.9rew 10/17/88  0938.3      171027



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

" HISTORY COMMENTS:
"  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
"     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
"     Modified to allow for *heap links, joining to definition section,
"     and to store the list_component number.
"                                                      END HISTORY COMMENTS


name	eb_data_

"		data segment for 
"		the Multics GE-645 Assembler

"		originally coded by N. Adleman
"		on December 2, 1969

"		Modified 14 July 1980 by M. N. Davidoff to remove ia, ib, id and ie
"			which were only used by decevl_.
"		modified for macro processing 3/23/77 by Noel I. Morris
"                   modified for prelinking on 06/15/75 by Eugene E Wiatrowski
"	          modified 01/74 by E Stone to add listing_max_length
"		modified on 09/13/73 at 15:42:36 by R F Mabee.
"		modified on 09/13/73 at 15:41:46 by R F Mabee. Fixed bug in rpt_terminators.
"		modified on 07/28/73 at 23:36:27 by R F Mabee. Added constant tables for EIS, etc.
"		modified on 07/06/72 at 21:59:07 by R F Mabee. Reformatted itlist for modevl_, to add itp modifier.
"		modified on 04/30/72 at 23:59:31 by R F Mabee. Changed new call, stretched objnfo.
"		modified on 04/16/72 at 14:00:28 by R F Mabee. Added new call/save/return to use operators.
"		by RHG on 17 Sept 1970 to allow "f1","f2","f3" as modifiers rather than "f","fi","fj"
"		by RHG on 9 September for new listing package and
"			additional varcom required by cleavage of pass1
"		by RHG on 11 August 1970 at 0523 to fix CODTAB to get rid of prec_$prec_
"		by RHG on 8 August 1970 at 0035 to remove symbol table header
"		by NA on August 4, 1970 at 1011 to remove the ribbon shift characters from who_am_I

"		This data segment retains pure
"		data in the text portion and impure
"		data in the linkage portion


	use	pure	in the text
	use	impure	in the linkage

	org	0


%	include	stack_header


	use	pure
	segdef	varcom_size
varcom_size:	zero	0,end_varcom-varcom
	use	pure
	segdef	concom	pure from fortran-coded eplbsa
concom:	null
basnos:	oct	0,1,2,3,4,5,6,7
clunk:	oct	0
clint:	oct	100000
clext:	oct	200000
clbas:	oct	300000
clstk:	oct	400000
clndx:	oct	500000
clmlc:	oct	600000
fdef:	oct	1
fnul:	oct	2
fphs:	oct	4
fset:	oct	10
frel:	oct	020
fabs:	oct	040
fbol:	oct	100
fcom:	oct	200
find:	oct	400
flocrf:	oct	100021
fequrf:	oct	100041
fbolrf:	oct	100101
fsetrf:	oct	100051
fbasrf:	oct	200041
fsegrf:	oct	200041
fsthof:	oct	400041
fndxrf:	oct	500041
fmlcrf:	oct	600041
onesev:	oct	7
twosev:	oct	77
thrsev:	oct	777
forsev:	oct	7777
fivsev:	oct	77777
sixsev:	oct	777777
allsev:	oct	777777777777
	segdef	bases
bases:	null		POSTP2
symbas:	acc	"ap"
	acc	"ab"
	acc	"bp"
	acc	"bb"
	acc	"lp"
	acc	"lb"
	acc	"sp"
	acc	"sb"
mir:	arg	0,*n
mri:	arg	0,n*
mdu:	arg	0,du
mdl:	arg	0,dl
mxo:	arg	0,0
mx1:	arg	0,1
mpc:	arg	0,ic
mpci:	arg	0,ic*
mfi:	oct	46
mits:	oct	43
mitb:	oct	41
ixtern:	aci	"XTRN"
intern:	aci	"NTRN"
iassgn:	aci	"ASGN"
iserch:	aci	"SRCH"
ixvrvl:	aci	"XVRL"
ixvrvp:	aci	"XVRP"
invrvl:	aci	"NVRL"
invrvp:	aci	"NVRP"
ibvrvl:	aci	"BVRL"
ibvrvp:	aci	"BVRP"
iaccvl:	aci	"ACCV"
iacivl:	aci	"ACIV"
mcmpq:	cmpq	0
mcmpx0:	cmpx0	0
mldaq:	ldaq	0
mldq:	ldq	0
mldx0:	ldx0	0
mnopdu:	nop	0,du
mstcd:	stcd	0
mtra:	tra	0
mtnc:	tnc	0
mtnz:	tnz	0
meabsp:	easpsp	0
meapap:	eppap	0
meapbp:	eppbp	0
meaplp:	epplp	0
meapsp:	eppsp	0
mstpap:	spriap	0
mstpbp:	spribp	0
mstplp:	sprilp	0
mstpsp:	sprisp	0
i1542:	aci	"1542"
i642:	aci	"642 "
i3333:	aci	"3333"
i66:	aci	"66  "



ibb:	aci	"    "
ibsp:	aci	"    "
null:	oct	0
smxer:	acc	"mxerror"
sentry:	acc	"entry"
sretrn:	acc	"return"
dzero:	oct	0,0
ixvrvl_notag:	aci	"XTAG"
 
	use	pure
	segdef	ib6
ib6:	aci	" 6  "
	use	pure
	use	pure
	segdef	codtab	pure data
codtab:	null
"NOTE: the last character of the codtab entries are for use as the precedence by expevl_
	aci	"NUL2"	000,null
	aci	"SOH2"	001, start of header
	aci	"STX2"	002, start of text
	aci	"ETX2"	003,end of text
	aci	"EOT2"	004,end of transmission
	aci	"ENQ2"	005,inquiry: who are you
	aci	"ACK2"	006, acknowledge
	aci	"BEL2"	007, bell
	aci	"BS 2"	010, backspace
	aci	"SP 2"	011, horizontal tab same as space (040)
	aci	"NL 2"	012, new line
	aci	"VT 2"	013, vertical tab
	aci	"SP 2"	014, form feed same as space (040)
	aci	"NL 2"	015, carrier return same as new-line (012)
	aci	"SO 2"	016, shift out
	aci	"SI 2"	017, shift in
	aci	"DLE2"	020, data link escape
	aci	"DC12"	021, device control 1
	aci	"DC22"	022, device control 2
	aci	"DC32"	023, device control 3
	aci	"DC42"	024, device control 4
	aci	"NAK2"	025, negative acknowledge
	aci	"SYN2"	026, synchronous idle
	aci	"ETB2"	027, end of transmission block
	aci	"CAN2"	030, cancel
	aci	"EOM2"	031, end of medium
	aci	"SUB2"	032, start of special sequence
	aci	"ESC2"	033, escape
	aci	"FS 2"	034, file separator
	aci	"GS 2"	035, group separator
	aci	"RS 2"	036, record separator
	aci	"US 2"	037, unit separator
	aci	"SP 2"	040, space
	aci	"!  2"	041, exclamation point
	aci	"QUO2"	042, quotation mark
	aci	"#  2"	043, number sign
	aci	"$  2"	044, dollar sign
	aci	"SP 2"	045, per cent sign, treated like space.
	aci	"&  2"	046, ampersand
	aci	"'  2"	047, apostrophe
	aci	"(  3"	050, left parenrhesis
	aci	")  4"	051, right parenthesis
	aci	"*  6"	052, star
	aci	"+  5"	053, plus
	aci	",  2"	054, comma
	aci	"-  5"	055, minus
	aci	".  2"	056, point
	aci	"/  6"	057, slash
	aci	"dig2"	060-071, ten digits	0
	aci	"dig2"	1
	aci	"dig2"	2
	aci	"dig2"	3
	aci	"dig2"	4
	aci	"dig2"	5
	aci	"dig2"	6
	aci	"dig2"	7
	aci	"dig2"	8
	aci	"dig2"	9
	aci	":  2"	072, colon
	aci	"NL 2"	073, semi-colon same as new-line (012)
	aci	"<  2"	074, left pointed bracket
	aci	"=  2"	075, equal sign
	aci	">  2"	076, right pointed bracket
	aci	"?  2"	077, question mark
	aci	"@  2"	100, at sign
	aci	"ltr2"	101-132	26 Upper case Letters	A
	aci	"ltr2"	B     WHICH ARE TREATED THE SAME AS LOWER CASE LETTERS
	aci	"ltr2"	C
	aci	"ltr2"	D
	aci	"ltr2"	E
	aci	"ltr2"	F
	aci	"ltr2"	G
	aci	"ltr2"	H
	aci	"ltr2"	I
	aci	"ltr2"	J
	aci	"ltr2"	K
	aci	"ltr2"	L
	aci	"ltr2"	M
	aci	"ltr2"	N
	aci	"ltr2"	O
	aci	"ltr2"	P
	aci	"ltr2"	Q
	aci	"ltr2"	R
	aci	"ltr2"	S
	aci	"ltr2"	T
	aci	"ltr2"	U
	aci	"ltr2"	V
	aci	"ltr2"	W
	aci	"ltr2"	X
	aci	"ltr2"	Y
	aci	"ltr2"	Z
	aci	"[  2"	133, left square bracket
	aci	"\  2"	134, reverse slash
	aci	"]  2"	135, right square bracket
	aci	"^  6"	136, circumflex
	aci	"ltr2"	137, underline same as letters (uppers and lowers) 
	aci	"`  2"	140, grave accent
	aci	"ltr2"	141-172 Lower case Letters	a
	aci	"ltr2"	b
	aci	"ltr2"	c
	aci	"ltr2"	d
	aci	"ltr2"	e
	aci	"ltr2"	f
	aci	"ltr2"	g
	aci	"ltr2"	h
	aci	"ltr2"	i
	aci	"ltr2"	j
	aci	"ltr2"	k
	aci	"ltr2"	l
	aci	"ltr2"	m
	aci	"ltr2"	n
	aci	"ltr2"	o
	aci	"ltr2"	p
	aci	"ltr2"	q
	aci	"ltr2"	r
	aci	"ltr2"	s
	aci	"ltr2"	t
	aci	"ltr2"	u
	aci	"ltr2"	v
	aci	"ltr2"	w
	aci	"ltr2"	x
	aci	"ltr2"	y
	aci	"ltr2"	z
	aci	"{  2"	173, left brace
	aci	"|  2"	174, vertical line
	aci	"}  2"	175, right brace
	aci	"~  2"	176, tilde
	aci	"PAD2"	177, pad character

	use	pure
	segdef	relbit	pure data
relbit:	null
iabsol:	dec	0	absolute
	dec	16	text
imtext:	dec	17	negative text
	dec	18	link segment
imlink:	dec	19	negative link segment
ilkptr:	dec	20	linkage pointer...lp
idefpt:	dec	21	definition pointer
isymbl:	dec	22	symbol
imsymb:	dec	23	negative symbol
ilblok:	dec	24	linkage block
imblok:	dec	25	negative linkage block
iselfr:	dec	26	self relative
iresv1:	dec	27	unused
iresv2:	dec	28	unused
iresv3:	dec	29	unused
iresv4:	dec	30	unused
iescap:	dec	31	escape
iltext:	zero	16,0	glwrd(itext,0)
illink:	zero	18,0	glwrd(ilink,0)
ilsymb:	zero	22,0	glwrd(isymbl,0)
ildefs:	zero	21,0	glwrd(idefpt,0)
ibits:	oct	20	itext
	oct	22	ilink
	oct	26	isymbl

	use	pure
	segdef	mxsave,nmxsav	pure data
mxsave:	null
nmxsav:	dec	2		"mastermode save
	ldx0	sp|8
	ldi	sp|21

	use	pure
	segdef	retlst,nretls	normal return
retlst:	null
nretls:	dec	3		"pure data
	lpri	sp|16,*
	lreg	sp|8
	rtcd	sp|20

	segdef	new_retlst,new_nretls	" normal return, new version February 1972.
new_retlst:	null
new_nretls:	dec	1
	tra	sb|stack_header.return_op_ptr,*		" go to system return operator.

	segdef	short_retlst,short_nretls	" short return (no save done).
short_retlst:	null
short_nretls:	dec	1
	tra	sb|stack_header.ret_no_pop_op_ptr,*		" go to system short return operator.

	segdef	new_getlp,new_ngetlp		" sequence to load linkage pointer while in text.
new_ngetlp:	null
new_getlp:	dec	1
	tspbp	sb|stack_header.entry_op_ptr,*

	use	pure	
	segdef	anames,atext,alink,asym,astat,asys,aheap
anames:	null
atext:	acc	"*text"		pass1, pass2
alink:	acc	"*link"		"
asym:	acc	"*symbol"		"
	bss	,2
astat:	acc	"*static"		"
asys:	acc	"*system"		"
aheap:	acc	"*heap"		"
	segdef	atext2,alink2,asym2,astatic2,asystem2,adef2
atext2:	acc	"text"		pass1
alink2:	acc	"link"		"
asym2:	acc	"symbol"		"
astatic2: acc       "static"            "
asystem2:	acc	"system"		"
adef2:	acc	"definition"	"
 
 
 
	use	pure
	segdef	itext,ilink,isym,istatic,idefs
itext:	oct	0
ilink:	oct	1
isym:	oct	2
istatic:  oct       4
idefs:	oct	10

	use       impure
	segdef    stat_len
stat_len: oct       0
	segdef    separate_static
separate_static:
	oct       0
	segdef	entry_bound
entry_bound:
	oct	0
	segdef	entrybound_bit
entrybound_bit:
	oct	0



	use       pure
	segdef	ion,ioff,iobject,isave,irestore,unwind
ion:	acc	"on"		PASS1,PASS2
ioff:	acc	"off"		"
iobject:	acc	"object"
isave:	acc	"save"
irestore:	acc	"restore"
unwind:	acc	"unwinder_"	pass2

	segdef	mstaq,mx7,maos,meax0,meax7,stnam
mstaq:	staq	0		pass2
mx7:	oct	000000000017	pass2
maos:	aos	0		postp2
meax0:	eax0	0
meax7:	eax7	0
stnam:	acc	"symbol_table"

	segdef	calseq
calseq:	acc	"(call_sequence)"

	segdef	entseq
entseq:	acc	"(entry_sequence)"

	segdef	itxnam,ilknam,isynam
itxnam:	acc	"rel_text"
ilknam:	acc	"rel_link"
isynam:	acc	"rel_symbol"


	segdef	blanks
blanks:	acc	"       "	7 ascii blanks	postp2

	segdef	typr2
typr2:	oct	000000000000
	oct	000000000025
	oct	000025000000
	oct	000025000025
	oct	000000000025

	segdef	rho,twop18
rho:	oct	314151126535		table
twop18:	oct	000001000000

	segdef	ilend
ilend:	aci	"lnd1"		expevl_
	segdef	ineg,inot
ineg:	aci	"neg7"		expevl_
inot:	aci	"not7"		expevl, procedure table

	segdef	l0r0,l1r0,l2r0,l3r0
l0r0:	oct	0		LSTMAN
l1r0:	oct	000001000000
l2r0:	oct	000002000000
l3r0:	oct	000003000000

	segdef	rlist
rlist:	acc	"n"		MODEVL
	acc	"au"
	acc	"qu"
	acc	"du"
	acc	"ic"
	acc	"al"
	acc	"ql"
	acc	"dl"
	acc	"x0"
	acc	"x1"
	acc	"x2"
	acc	"x3"
	acc	"x4"
	acc	"x5"
	acc	"x6"
	acc	"x7"

	segdef	itlist_
itlist_:	zero	0,end_itlist-*
	acc	"f1";	oct	40
	acc	"itb";	oct	41
	acc	"itp";	oct	41
	acc	"its";	oct	43
	acc	"sd";	oct	44
	acc	"scr";	oct	45
	acc	"f2";	oct	46
	acc	"f3";	oct	47
	acc	"ci";	oct	50
	acc	"i";	oct	51
	acc	"sc";	oct	52
	acc	"ad";	oct	53
	acc	"di";	oct	54
	acc	"dic";	oct	55
	acc	"id";	oct	56
end_itlist:	acc	"idc";	oct	57

	segdef	jba,jbi,jbm,jbo,jbv,ibtb,ibts,ibtp,jbh
	segdef	iasc,ifxd,iint,ioct,ivfd,imach
	segdef	iitb,iits,ierr,iflt
jba:	oct	141	a	LITEVL
jbi:	oct	151	i
jbm:	oct	155	m
jbo:	oct	157	o
jbv:	oct	166	v
jbh:	oct	150	h
ibtb:	acc	"tb"	LITEVL
ibts:	acc	"ts"	LITEVL
ibtp:	acc	"tp"	LITEVL
iasc:	aci	".asc"
ifxd:	aci	".fxd"
iint:	aci	".int"
ioct:	aci	".oct"
ivfd:	aci	".vfd"
imach:	aci	".mch"
iitb:	aci	".itb"
iits:	aci	".its"
ierr:	aci	".err"
iflt:	aci	".flt"	DECEVL

	segdef	nlpads,ipads
ipads:	oct	177177177177
nlpads:	oct	012177177177

	segdef	mb28,mb29,zerbuf

mb28:	oct	200
mb29:	oct	100
zerbuf:	oct	0,0,0,0,0,0,0,0,0,0
	oct	0,0,0,0,0,0,0,0,0,0
	oct	0,0,0,0,0,0,0,0,0,0

	segdef	eis_flag_keys,eis_value_keys,eis_mf
eis_flag_keys:
	acc	"ascii";	oct	0
	acc	"enablefault"
	acc	"round";	oct	0
eis_value_keys:
	acc	"mask"
	acc	"bool"
	acc	"fill"
eis_mf:
	acc	"pr";	oct	100
	acc	"rl";	oct	40
	acc	"id";	oct	20

	segdef	rpt_terminators
rpt_terminators:
	acc	"tze"
	acc	"tnz"
	acc	"tmi"
	acc	"tpl"
	acc	"trc"
	acc	"tnc"
	acc	"tov"

	segdef	bcd_table
bcd_table:
	oct	777777777777,777777777777,777777777777,777777777777	" NUL to ETB.
	oct	777777777777,777720777613,537432573555,546073523361	" CAN to /.
	oct	000102030405,060710111556,367516171421,222324252627	" 0 to G.
	oct	303141424344,454647505162,636465666770,711237344072	" H to _.
	oct	572122232425,262730314142,434445464750,516263646566	" ` to w.
	oct	677071774077,777777777777				" x to PAD.

"
	use	impure	in the linkage

	use	impure
 
	even	"for use of sym in LDAQ instructions
 
	segdef	varcom,tsym	impure from fortran coded eplbsa
varcom:	null
	bss	var_pad,4
tsym:	null	overlayed with SYM
	bss	var_pad2,350
end_varcom:
 
	even		"ITS pointers follow
	use	impure
	segdef	objnfo
objnfo:	bss	objnfo,24	impure from fortran called eplbsa
	use	impure
	segdef	segnfo
	even		ITS pointers follow
segnfo:	bss	segnfo,13	impure from fortran coded eplbsa
	use	impure
	segdef	erflgs,erflgs_overlay,flgvec	impure data
erflgs:	null
erflgs_overlay:	null	18prntX words and 18 TSTSW words overlayed with FLGVEC
flgvec:	bss	flgvec,36

	use	impure
	segdef	lstcom
lstcom:	null
	bss	tnolst,1

	use	impure
	segdef	mxpro	impure data
mxpro:	dec	2
	cmpx0	0,0
	tnc	0,0

	use	impure
	segdef	slcall,nslcal	impure data
slcall:	null
nslcal:	dec	5
	spri	sp|0
	sreg	sp|8
	eppap	0
	stcd	sp|20
	tra	0

	segdef	new_slcall,new_nslcal	" New call, same as old as of February 1972.
new_slcall:	null
new_nslcal:	dec	7
	spri	sp|0
	eppap	0		" load arg list.
	eppbp	0		" load thing to call.
	sreg	sp|32
	tsplp	sb|stack_header.call_op_ptr,*		" go to system call operator.
	lpri	sp|0
	lreg	sp|32

	segdef	short_slcall,short_nslcal
short_slcall:	null		" Short (no bases/regs saved or restored) slave call macro.
short_nslcal:	dec	3
	eppbp	0
	tsplp	sb|stack_header.call_op_ptr,*
	epplp	sp|24,*		" Restore linkage pointer.

	use	impure
	segdef	mxcall,nmxcal	impure data
mxcall:	null
nmxcal:	dec	11
	spri	sp|0
	sreg	sp|8
	eppap	lp|0
	spriap	sp|20
	eppap	0
	sti	sp|21
	ldq	0
	stq	sp|22
	ldq	sp|13
	ldi	sp|21
	tra	0

	use	impure
	segdef	mxclbk,nmxclb	impure data
mxclbk:	null
nmxclb:	dec	7
	ldq	sp|22
	cmpq	0
	tnz	0
	stz	sp|22
	ldq	sp|13
	ldx0	sp|8
	ldi	sp|21

	use	impure
	segdef	relocn	impure data
relocn:	null
mxpbit:	oct	0	2 words
	oct	000020000000
nslbit:	oct	0	5 words
	oct	0
	oct	777777000000
	oct	0
	oct	777777000000
mxcbit:	oct	0	11 words
	oct	0
	oct	000024000000
	oct	0
	oct	777777000000
	oct	0
	oct	000020000000
	oct	0
	oct	0
	oct	0
	oct	777777000000
mxlbit:	oct	0	7 words
	oct	777777000000
	oct	777777000000
	oct	0
	oct	0
	oct	0
	oct	0
mxsbit:	oct	0	2 words
	oct	0
mslbit:	oct	0	6 words
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
mrtbit:	oct	0	3 words
	oct	0
	oct	0
merbit:	oct	0	11 words
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	000024000000

new_mrtbit:	oct	0	" Relocation bits for new return operator.
	bss	,2		" Padding in case it grows.
new_mslbit:	oct	0	" New slave save.
	oct	0
	bss	,4		" More padding.
new_nslbit:	oct	0	" New slave call.
	oct	777777000000
	oct	777777000000
	oct	0
	oct	0
	oct	0
	oct	0
	bss	,3		" Call particularly likely to grow.
short_mrtbit:	oct	0	" New short return.
	bss	,2		" Padding.
new_entbit:	oct	000025000000	" New entry sequence.
	oct	0
	oct	000020000000
	bss	,2		" Padding.
short_nslbit:	oct	777777000000		" New short slave call.
		oct	0
		oct	0
		bss	,3		" Padding.
new_getbit:	oct	0		" New in-text find linkage pointer.
	bss	,4		" Padding.


	use	impure
	segdef	slsave,nslsav	impure data
slsave:	null
nslsav:	dec	6		"slave mode save
	eppbp	sp|18,*
	sprisp	bp|16
	eppbp	bp|-
	spribp	bp|18
	eppsp	bp|0
	spriap	sp|26

	segdef	new_slsave,new_nslsav	" New save operator, February 1972.
new_nslsav:	null
new_slsave:	dec	2
	eax7	0
	tspbp	sb|stack_header.push_op_ptr,*		" go to system save operator.

	segdef	new_entlst,new_nentls
new_entlst:	null
new_nentls:	dec	3
	oct	0
	tspbp	sb|stack_header.entry_op_ptr,*
	tra	-

	use	impure
	segdef	ertlst,nertls	alternate return  impure data
ertlst:	null
nertls:	dec	11
	spri	sp|0
	sreg	sp|8
	fld	=2b25,dl
	staq	sp|0
	ldaq	sp|0
	staq	sp|0
	eppap	sp|0
	ldaq	sp|12
	ldi	sp|21
	stcd	sp|20
	tra	0

	use	impure
	segdef	lctext	impure data
lctext:	null
	bss	lptext,1
	acc	".text."
	use	impure
	segdef	lchead	impure data
lchead:	null
	bss	lphead,1
	acc	".lkhead."

	use	impure
	segdef	lcsect	impure data
lcsect:	null
	bss	lpsect,1
	acc	".lksect."

	use	impure
	segdef	lclit	impure data
lclit:	null
	bss	lplit,1
	acc	".lit."

	use	impure
	segdef	lcdefs	impure data
lcdefs:	null
	bss	lpdefs,1
	acc	".defs."

	use	impure
	segdef	lctv	impure data
lctv:	null
	bss	lptv,1
	acc	".TV."

	use	impure
	segdef	lccall	impure data
lccall:	null
	bss	lpcall,1
	acc	".ec."

	use	impure
	segdef	lcst	impure data
lcst:	null
	bss	lpst,1
	acc	".st."

	use	impure
	segdef	lcrtx	impure data
lcrtx:	null
	bss	lprtx,1
	acc	".reltx."

	use	impure
	segdef	lcrlk	impure data
lcrlk:	null
	bss	lprlk,1
	acc	".rellk."

	use	impure
	segdef lcrst	impure data
lcrst:	null
	bss	lprst,1
	acc	".relst."

	segdef	lcentries
lcentries:	null
	bss	lpentries,1
	acc	".entries."

	use	impure
	segdef	labarg	impure data
labarg:	null
	bss	gralal,1

	use	impure
	segdef	lccom	impure data
lccom:	null
	bss	moccl,6

	use	impure
	segdef	curlc	impure data
curlc:	null
	bss	clruc,1

	segdef	oulst
oulst:	bss	oulst,17

	use	impure
	use	impure
	segdef	lavptr
	even
lavptr:	null
	its	-1,1	holds pointer to the segment for the list management routines
 
	even
	segdef	who_am_I,abort_assembly
abort_assembly:
	its -1,1
	its -1,1
	bss	label_unused,2
who_am_I:	aci	"alm         "	(must be 12 characters)
	segdef	curr_char_no	for INPUTS
curr_char_no:	dec	-1	the current character in the source segment

	even
	segdef	mexp_env_ptr	for macro expander
mexp_env_ptr:
	its	-1,1

	segdef	alm_arg_ptr
alm_arg_ptr:
	its	-1,1

	segdef	macro_depth
macro_depth:
	dec	0

	segdef	include_number
include_number:
	bss	,1

	segdef	include_control
include_control:
	bss	,(110+35)/36

	segdef	mexp_argno
mexp_argno:
	bss	,1

	segdef	alm_arg_count
alm_arg_count:
	bss	,1

	segdef	macro_listing_control
macro_listing_control:
	bss	,1

	segdef	macro_stack
macro_stack:
	bss	,4*100

	segdef	macro_linect
macro_linect:
	dec	0



	segdef	dig
dig:	vfd	8/27,28/0		for DECSUB


	segdef	alm_options	" Options passed from command to others.
alm_options:	bss	,3	" tnewcall, tnewmachine, tnewobject.
		bss	,3	" tcheckcompatibility, tquietsw, tfirstreftrap.
		bss	,3	" tnoxref, two spare cells.

	segdef	listing_max_length	" Maximum length of listing component
listing_max_length:
	bss	,1

	segdef	list_component	" Component number of listing
list_component:
	bss	,1

	segdef	per_process_static_sw
per_process_static_sw:
	bss	,1

	join	/text/pure
	join	/link/impure
	end




		    expevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.8       97236



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


expevl_:
     proc (tbool, inexp, lc, expevl_answer) ;

/*
   Modified 740821 by PG to allow stack-references wherever references are allowed.
   Modified on 12/07/72 at 20:29:45 by R F Mabee. Fixed up prntr problem for good.
   Modified by RHG on 17 August 1970 at 1614 to clean up some bad code
   by RHG on 11 August 1970 at 0537 to get rid of return value (make it a parameter)
   by RHG on 10 August 1970 at 2139 to allow "^" as substitute for "/" in bool expressions
   by RHG on 10 August 1970 at 2032 to eliminate calls to prec_ and utils_$(and or xor)
   by Nate Adleman on June 28, 1970 at 2006 for the new CODTAB
*/

/* EXPEVL:   evaluate internal expressions for MA */

/*   internal expression evaluation routine. this routine evaluates */
/*   expressions consisting entirely of internal references using a */
/*   stack technique. nested expressions are allowed as normal */
/*   subexpressions, and evaluation is done on either an arithmetic */
/*   or boolean operator interpretation. the stack is an internal */
/*   array of nstk( = 100) locations, sufficient for most expressions. */

/* modifications by wagner for multiple location counters, */
/* june 13, 1967. returns in lc the address of the assignment */
/* table entry for the location counter to which inexp is relative. */
/* if call has tbool =  1;	(TRUE) then caller must ignore lc. */

/* a second stack, lstk, runs parallel to stk. lstk(i) is-- */

/*   lc  if stk(i) is relative to a location counter. */
/*   0  if stk(i) is absolute. */
/*   garbage  if stk(i) is an operator. */

/* then at each arithmetic operator there must be a check */
/* that operands are of consistent types. */



/* INCLUDE FILES USED BY EXPEVL */

% include varcom;
% include concom;
% include erflgs;
% include codtab;
% include curlc;
/*  */
/* EXTERNAL ENTRIES USED BY EXPEVL */

declare  getid_$getid_ external entry,
         inputs_$next external entry ;

/* EXTERNAL FUNCTIONS USED BY EXPEVL */

declare  glpl_$clh external entry (fixed bin) returns (fixed bin),
         glpl_$crh external entry (fixed bin) returns (fixed bin),
         table_$table_ external entry (fixed bin (26), fixed bin (26), fixed bin, fixed bin (26), fixed bin) returns (fixed bin (26));


/* EXTERNAL DATA USED BY EXPEVL */

declare (eb_data_$ilend, eb_data_$ineg, eb_data_$inot) ext fixed bin (35);


/* AUTOMATIC DATA USED BY EXPEVL */

declare  expevl_answer fixed bin (35) ;
	

declare (inexp, i, lc, l1, l2, lstk (100), op, rprec,
         stk (100), tbad, tbool, val, vlc, radix, brk_temp) fixed bin (17);

declare  nstk fixed bin internal static init (100);

/*  */
/* - - - - - NORMAL ENTRY, break in brk, and perhaps symbol in xsym. */

label_100:
	radix = 10 -tbool - tbool ;			/* set the radix for numeric constants to 8 or 10 */
	expevl_answer = 1;				/* TRUE */;
	tbad = 0;					/* FALSE */;
	i = 1;
	stk (1) = eb_data_$ilend;
	go to label_210;

/*   re-entry to get next identifier. */
label_200:
	call getid_$getid_;
label_210:
	if (brk (1) = inum) then go to label_230;
	if (sym (1) = 0) then go to label_300;

/*   not number nor void, look up symbol in assignment table. */
label_220:
	if (table_$table_ (iserch, sym (1), val, clint, vlc) ^= 0) then go to label_400;
	if (table_$table_ (iserch, sym (1), val, clmlc, vlc) ^= 0) then go to label_400;
	if (table_$table_ (iserch, sym (1), val, clstk, vlc) ^= 0) then go to label_400;
label_225:
	prntu = 1;				/* TRUE */;
	expevl_answer = 0;				/* FALSE */;
	go to label_400;

/*   number, convert to binary. */
label_230:
	unspec (val) = unspec (brk (2)) & "000000000000000000000000000000001111"b; /* val = utils_$and( brk(2), 15) */
	vlc = 0;
label_240:
	call inputs_$next;
	if (brk (1) ^= inum) then go to label_400;
	val = radix * val + fixed (unspec (brk (2)) & "000000000000000000000000000000001111"b, 17, 0) ;
	go to label_240;

/*   unary operator, check which and process. */
label_300:
	brk_temp = brk (1);				/* set brk_temp which is not abnormal so pl1 can optimize */
	if (brk_temp = iplus) then go to label_310;
	if (brk_temp = iminus) then go to label_320;
	if (brk_temp = istar) then go to label_330;
	if (brk_temp = islash) then go to label_340;
	if (brk_temp = icflx) then go to label_340;
	if (brk_temp = ilpar) then go to label_350;
	go to label_360;

/*   ignore unary plus. */
label_310:
	go to label_200;

/*   replace unary minus by _$neg_$, put instack, and . */
label_320:
	i = i+1;
	stk (i) = eb_data_$ineg;
	go to label_200;

/*   unary star is symbol for this location. */
label_330:
	val = pc;
	vlc = curlc;
	call getid_$getid_;
	if (sym (1) ^= 0) then go to label_800;
	go to label_400;

/*   unary slash for booleans means not. */
label_340:
	i = i+1;
	stk (i) = eb_data_$inot;
	go to label_200;

/*   simply insert ( and scan. */
label_350:
	i = i+1;
	stk (i) = ilpar;
	go to label_200;

/*   unknown break, val is zero and treat as binary end. */
label_360:
	val = 0;
	vlc = 0;
	go to label_400;


/*   binary operator, insert operand, and check precedence of */
/*   operator. if current precedence greater than last operator, */
/*   insert new operator in stack, otherwise, begin evaluating */
/*   operators up the stack. parentheses and end of field are */
/*   treated in special ways. */

label_400:
	if (i > (nstk-4)) then go to label_800;
	i = i+1;
	stk (i) = val;
	lstk (i) = vlc;
label_410:
	unspec (rprec) = unspec (brk (1)) & "000000000000000000000000000000001111"b; /* rprec = utils_$and(brk(1), 15); */
label_420:
	op = stk (i-1);
	if fixed (unspec (op) & "000000000000000000000000000000001111"b, 17, 0) >= rprec then goto label_460;
	if (brk (1) = irpar) then go to label_450;
	if (rprec <= 4) then go to label_440;

/*   precedence greater, insert operator in stack. */
label_430:
	i = i+1;
	stk (i) = brk (1);
	go to label_200;

/*   end terminator, check results and return answer. */
label_440:
	if (i ^= 2) then go to label_800;
	go to label_900;

/*   right parenthesis processed only after ops evaluated. */
label_450:
	if (op = eb_data_$ilend) then go to label_440;
	if (op ^= ilpar) then go to label_800;
	i = i-1;
	stk (i) = stk (i+1);
	lstk (i) = lstk (i+1);
	call getid_$getid_;
	if (sym (1) ^= 0) then go to label_800;
	go to label_410;

/*   work operators up stack until precedence is in order. */
/*   seperate evaluators for boolean and arithmetic operators. */
label_460:
	if (tbool ^= 0) then go to label_600;

/*   arithmetic operator, branch on type. */
label_500:
	l1 = lstk (i-2);
	l2 = lstk (i);
	if (op = iplus) then go to label_510;
	if (op = iminus) then go to label_520;
	if (op = istar) then go to label_530;
	if (op = islash) then go to label_540;
	if (op = eb_data_$ineg) then go to label_550;
	if (op = eb_data_$ilend) then go to label_900;
	go to label_800;

/*   evaluate binary +. */
label_510:
	stk (i-2) = stk (i-2)+stk (i);
	if (l1 ^= 0 & l2 ^= 0) then tbad = 1;		/* TRUE */;
	if (l1+l2 = 0) then vlc = 0;
	if (l1 ^= 0) then vlc = l1;
	if (l2 ^= 0) then vlc = l2;
	go to label_700;

/*   evaluate binary -. */

/*   special patch has been added to permit */
/*   the evaluation of a difference when the */
/*   symbols are both relocatable and in the */
/*   same segment but are defined under different */
/*   location counters. in this case the result */
/*   is modified by adding the difference between */
/*   the origins of the two location counters. */
label_520:
	stk (i-2) = stk (i-2)-stk (i);
	if (^(tpass2 ^= 0 & l1 ^= 0 & l2 ^= 0)) then go to label_525;
	if (glpl_$crh (l1+4) ^= glpl_$crh (l2+4)) then tbad = 1; /* TRUE */;
	stk (i-2) = stk (i-2) + (glpl_$clh (l1+3)-glpl_$clh (l2+3));
	vlc = 0;
	go to label_700;
label_525:
	

	if (l2 ^= 0 & l1 ^= l2) then tbad = 1;		/* TRUE */;
	if (l1+l2 = 0) then vlc = 0;
	if (l1 ^= 0 & l2 = 0) then vlc = l1;
	if (l1 ^= 0 & l2 ^= 0) then vlc = 0;
	go to label_700;

/*   evaluate binary *. */
label_530:
	stk (i-2) = stk (i-2)*stk (i);
	if (l1+l2 ^= 0) then tbad = 1;		/* TRUE */;
	vlc = 0;
	go to label_700;

/*   evaluate binary /. */
label_540:
	if (stk (i) ^= 0) then stk (i-2) = divide (stk (i-2), stk (i), 17, 0);
	if (l1+l2 ^= 0) then tbad = 1;		/* TRUE */;
	vlc = 0;
	go to label_700;

/*   evaluate unary -. */
label_550:
	stk (i-1) = -stk (i);
	if (lstk (i) ^= 0) then tbad = 1;		/* TRUE */;
	vlc = 0;
	go to label_710;


/*   boolean operator, branch on type. */
label_600:
	if (op = iplus) then go to label_610;
	if (op = iminus) then go to label_620;
	if (op = istar) then go to label_630;
	if (op = islash) then go to label_640;
	if (op = icflx) then go to label_640;
	if (op = eb_data_$inot) then go to label_650;
	if (op = eb_data_$ilend) then go to label_900;
	go to label_800;

/*   evaluate boolean .or. function. */
label_610:
	unspec (stk (i-2)) = unspec (stk (i-2)) | unspec (stk (i)) ;
	go to label_700;

/*   evaluate boolean .xor. function. */
label_620:
	unspec (stk (i-2)) = bool (unspec (stk (i-2)), unspec (stk (i)), "0110"b) ;
	go to label_700;

/*   evaluate boolean .and. function. */
label_630:
	unspec (stk (i-2)) = unspec (stk (i-2)) & unspec (stk (i)) ;
	go to label_700;

/*   evaluate boolean .and not. function. */
label_640:
	unspec (stk (i-2)) = unspec (stk (i-2)) & ^unspec (stk (i)) ;
	go to label_700;

/*   evaluate boolean .not. function. */
label_650:
	stk (i-1) = -1 - stk (i) ;
	go to label_710;


/*   termination for binary operator evaluation, reduce stack */
/*   level, and go test new operator. */
label_700:
	lstk (i-2) = vlc;
	i = i-2;
	if (i >= 2) then go to label_420;
	go to label_800;

/*   termination for unary operations in stack. */
label_710:
	lstk (i-1) = vlc;
	i = i-1;
	if (i >= 2) then go to label_420;
	go to label_800;


/*   phase error return. */
label_800:
	prntf = 1;				/* TRUE */
	expevl_answer = 0;				/* FALSE */
label_810:
	inexp = 0;
	lc = 0;
	return ;


/*   normal termination return, answer is stk(2). */
label_900:
	inexp = stk (2);
	if (tbad ^= 0) then go to label_910;
	lc = lstk (2);
	return ;

/* invalid operator-operand modes somewhere in evaluation */
label_910:
	lc = 0;
	if tpass1 = 0 then prntr = 1;
	expevl_answer = 0;				/* FALSE */;
	return ;


     end expevl_;




		    getbit_.pl1                     10/17/88  1013.9rew 10/17/88  0938.8       23958



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support special definition relocation (part of join to
     definition section support).
                                                   END HISTORY COMMENTS */


getbit_:
	procedure (iaddr, basno, b29, relwrd);

          /* Modified for separate static on 06/15/75 by Eugene E Wiatrowski */
	/* Modified on 11/02/72 at 18:46:27 by R F Mabee. */
	/* Modified on 2 November 1972 by R F Mabee to allow linkage relocation on any base reference. */
	/* Modified on 6 May 1972 by R F Mabee to distinguish linkage relocation from internal static. */
	/* Modified by NA on June 23, 1970 at 1956 for ext entry dcln's */

 declare	 (iaddr, basno, b29, relwrd, itemp) fixed binary (26);
 declare   eb_data_$separate_static ext bit(1) aligned;

% include relbit;

% include	lcsect;

% include	alm_options;

 declare	glpl_$crh external entry (fixed bin (26)) returns (fixed bin (26));


	relwrd = 0;
	if iaddr = 0 then return;

	itemp = glpl_$crh (iaddr+4);

	if b29 = 0
/* If 18-bit address field. */
	then if itemp = 1 then if tnewobject = 0 then relwrd = ilink;
			   else if iaddr = lpsect then relwrd = ilink;	/* Reference to links. */
			   else relwrd = ilblok;	/* New 18-bit internal static address. */
	     else relwrd = ibits (itemp + 1);	/* Text or symbol section. */
/* Else 15-bit address field. */
	else if itemp = 1 then if tnewobject = 0 then relwrd = ilkptr;
			else if iaddr = lpsect then relwrd = ilkptr;	/* 15-bit reference to links. */
			else relwrd = imblok;	/* New internal static 15-bit address. */
	     else;		/* Base reference, not in linkage section, absolute. */

	if itemp = 8 then relwrd = 27; /* defn (33 octal) */
	else if itemp = 4
	   then if eb_data_$separate_static
	        	 then if b29 = 0
		         then relwrd = ilblok;
		         else relwrd = imblok;

	return;

end getbit_;




		    getid_.alm                      10/17/88  1013.9r w 10/17/88  0938.2        7065



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

"Transfer vector for getid_
	name	getid_
	entry	getid_,setid,getnam
getid_:	tra	<inputs_>|[getid]
setid:	tra	<setid_>|[setid_]
getnam:	tra	<inputs_>|[getname]
	end




		    glpl_.alm                       10/17/88  1013.9rew 10/17/88  0938.2       33534



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name	glpl_		GE-list-processing-language.
"	an adaptation of flpl and mlpl to the ge-645 to be used
"	with the fortran compiler, especially for the eplbsa
"	assembler.	j.w.poduska, november 1965.


" Last modified on 11/12/72 at 01:07:44 by R F Mabee.
" Modified on 11 November 1972 by R F Mabee to fix short return and bb reference for followon.
"	by RHG on 26 Sept 1970 to combine storage_control_ back in
"	by RHG on 2 Sept 1970 for new listing package
"	by RHG on 28 August 1970 at 1420 to make ersblk do nothing
"	by NA on June 28, 1970 at 2022


	equ	nextf,64
	equ	first_free,65
	equ	lavlth,261120	length of free storage segment

	temp	t(2)


	entry	crh
crh:
	ldq	ap|2,*
	ldq	<eb_data_>|[lavptr],*ql
	anq	=o777777,dl
	stq	ap|4,*
	short_return		" short return as there is no save at entries


	entry	clh
clh:
	ldq	ap|2,*
	ldq	<eb_data_>|[lavptr],*ql
	qrl	18
	stq	ap|4,*
	short_return


	entry	cllh
cllh:
	ldq	ap|2,*
	eppbp	<eb_data_>|[lavptr],*
	ldq	bp|0,ql
	ldq	bp|0,qu
	qrl	18
	stq	ap|4,*
	short_return


"	routines for storing and modifying link-words.

	entry	storl		store left half.
storl:	lxl1	ap|2,*		get the offset into the free storage segment
	lxl0	ap|4,*		get the word to be stored
	stx0	<eb_data_>|[lavptr],*1 store it
	short_return		and return


	entry	storr		store right half.
storr:	lxl1	ap|2,*		get the offset into the free storage segment
	lxl0	ap|4,*		get the word to be stored
	sxl0	<eb_data_>|[lavptr],*1 store it in the right half
	short_return		and return


	entry	slwrd		store total link word.
slwrd:
	lxl7	ap|2,*		get word pointer,
	lda	ap|4,*		get left half,
	ldq	ap|6,*		get right half,
	qlr	18		and position word in ac.
	llr	18		..
	sta	<eb_data_>|[lavptr],*7
	short_return		and return to caller.


	entry	glwrd		construct link word and return.
glwrd:
	lda	ap|4,*		get right half,
	ldq	ap|2,*		and left half,
	alr	18		and form word in mq.
	llr	18		..
	stq	ap|6,*		return in the third argument
	short_return		and return lword to caller.


"	routines for reading total words


	entry	cwrd		read contents of total word.
cwrd:
	ldq	ap|2,*		get word pointer,
	ldq	<eb_data_>|[lavptr],*ql
	stq	ap|4,*
	short_return		and return to caller.


"	routines for manipulating blocks of information.


	entry	genlas		generate the free storage list.
genlas:
	lda	first_free,dl	get the address of the first word in the scratch segment
	eppbp	<eb_data_>|[lavptr],*
	sta	bp|nextf		store it in the uninit pointer
	short_return		and return


	entry	setblk		get a block of free storage.
setblk:	eppbp	<eb_data_>|[lavptr],*
	epbpbb	bp|0		" Should turn into epbpbb on 645F, harmless here.
	ldq	bp|nextf		get next free location
	stq	ap|6,*		return it
	eppbp	bp|0,ql		reset bp to point to the new block
	adq	ap|4,*		add the number of words requested
	stq	bb|nextf		save the new next free
	cmpq	lavlth,dl		check for overflowing scratch segment
	tpl	<prnter_>|[no_storage] complain if overflow
	ldq	ap|4,*		get the count again
	qls	2		multiply by 2
	eppap	ap|2,*		ap -> data words
	mlr	(pr,rl),(pr,rl)	move the data
	desc9a	ap|0,ql
	desc9a	bp|0,ql
	short_return
	short_return		and return if done

	end




		    inputs_.alm                     10/17/88  1013.9r w 10/17/88  0938.2      142110



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name	inputs_
	entry	next
	entry	nxtnb
	entry	next_statement
	entry	next_statement_nolist
	entry	run_statement
	entry	run_statement_nolist
	entry	ascii_literal
	entry	getid
	entry	getname
	entry	get_ptr

" Input routines for ALM.
" Modified 3/23/77 by Noel I. Morris for macro processing.
" Modified 7/16/76 by N. I. Morris to use EIS.
" Modified 740821 by PG to treat input chars as bit (9) instead of bit (7).
" Modified on 07/29/73 at 02:57:04 by R F Mabee.
" Fixed code sequence that pops stack without returning, March 1973, R F Mabee.
" Changed short return sequence to use macro, 11 November 1972, R F Mabee.
" 23 July 1972 - made inputs_$next_statement count lines for xref. R F Mabee.
" Changed to call alm_include_file_ at end of file instead of prnter_$no_end_card.
" This is for include file processing. 19 May 1972, R F Mabee.
"
	equ	brk,0
	equ	sym,4
	equ	begin_line,48
	equ	tpass2,50
	equ	binlin,65
	equ	source_printed,283

	bool	inl,012
	bool	isp,040
	bool	icomma,54
	bool	ipoint,56
	bool	inum,60
	bool	irpb,76
	bool	ilet,101

	include	segnfo

	include	stack_header
"
	use	static_data
	even
bpsave:	its	-1,1
x7save:	dec	0
char:	bss	,1
tctally:	bss	,1

	use	text_section

	join	/text/text_section/link/static_data

" 

get_ptr:	eppbb	eb_data_$segnfo+source,*
	spribb	ap|2,*		return source pointer
	lda	eb_data_$curr_char_no
	ldq	eb_data_$segnfo+srclen
	sta	ap|4,*		return curr_char_no
	stq	ap|6,*		return source length
	stz	ap|8,*		set sw for at nl
	lda	eb_data_$varcom+brk
	cmpa	eb_data_$codtab+inl	if this is so, mexp must
	tnz	return		be told that there are
	lda	=o400000,du	no args on line.
	sta	ap|8,*

	short_return

" 

next:	tsx7	set_char
	tsx7	get_char
return:	short_return



nxtnb:	lda	eb_data_$varcom+brk
	cmpa	eb_data_$codtab+inl
	tze	return

mornb:	tsx7	set_char
	tct	(pr,al,rl)
	desc9a	bb|0,ql
	arg	nxtnbtab
	arg	lp|tctally

	ada	lp|tctally
	ana	=o77777777
	sta	eb_data_$curr_char_no

	tsx7	set_char		get one more
	tsx7	get_char
	cmpa	eb_data_$codtab+isp
	tze	mornb
	tra	return

" 

run_statement_nolist:
	lda	=o400000,du	get "1"b
	sta	eb_data_$varcom+source_printed  suppress printing of source
	tra	run_statement

next_statement_nolist:
	lda	=o400000,du
	sta	eb_data_$varcom+source_printed
next_statement:
	ldaq	eb_data_$varcom+brk
next_statement_loop:
	cmpa	eb_data_$codtab+inl
	tze	check_nl

run_statement:
	tsx7	set_char
	tct	(pr,al,rl)
	desc9a	bb|0,ql
	arg	nxtsttab
	arg	lp|tctally

	ada	lp|tctally
	ana	=o77777777
	sta	eb_data_$curr_char_no

	tsx7	set_char
	tsx7	get_char
	tra	next_statement_loop

check_nl:	cmpq	=o12,dl
	tnz	return
	szn	eb_data_$varcom+source_printed
	tnz	printed
	szn	eb_data_$varcom+tpass2
	tze	printed1		" Don't try to print listing during pass1.
	save			"save because we are going to call out
	call	prwrd_$source_only
	eppbp	sp|0
	eppsp	sp|16,*		undo the save
	spribp	sb|stack_header.stack_end_ptr
printed1:	szn	eb_data_$macro_linect
	tze	printed
	aos	eb_data_$macro_linect
printed:	ldq	eb_data_$curr_char_no
	stq	eb_data_$varcom+begin_line
	stz	eb_data_$varcom+source_printed
	szn	eb_data_$include_control  " if not in macro expansion
	tmi	*+2
	aos	eb_data_$varcom+binlin  " inputs_ always counts lines.
	tra	return



ascii_literal:
	tsx7	set_char
	tsx7	get_char
	tra	check_nl

" 

get_char:	mrl	(pr,al),(pr),fill(0)
	desc9a	bb|0,1
	desc9a	lp|char,4

	ldq	lp|char
	aos	eb_data_$curr_char_no
	anq	=o777,dl			just one char, please
	canq	=o600,dl			if ascii
	tze	3,ic			then top bits are off
	lda	eb_data_$codtab	else pretend it's ascii NUL char
	tra	2,ic
	lda	eb_data_$codtab,ql
	staq	eb_data_$varcom+brk
	tra	0,7



set_char:	lda	eb_data_$curr_char_no
	ldq	eb_data_$segnfo+srclen
	sbq	eb_data_$curr_char_no
	tmoz	source_eof

	eppbb	eb_data_$segnfo+source,*
	tra	0,7



source_eof:
				" We have run out of this segment
" Try to revert from include file.
" alm_include_file_$pop will not return
" if there is nothing more to read.
	stx7	lp|x7save		" This is necessary because save uses index 7 and bp.
	spribp	lp|bpsave
	save			" Save because we are going to make a call
	call	alm_include_file_$pop
	eppbp	sp|0
	eppsp	sp|16,*		" Undo the save
	spribp	sb|stack_header.stack_end_ptr
	ldx7	lp|x7save
	eppbp	lp|bpsave,*
	tra	set_char		" Try whole read again.

" 

getid:	eax6	getidtab
	tra	getid_work

getname:	eax6	getnametab
	tra	getid_work



getid_work:
	eppbp	eb_data_$varcom+sym	get address of sym where we will return results

	ldaq	eb_data_$varcom+brk	get the current character
	cmpa	eb_data_$codtab+inl	check for end of statement
	tze	clear		return if so
	cmpa	eb_data_$codtab+isp	check for space as last break
	tnz	chk_sym		if not, get next char and continue

	tsx7	set_char
	tct	(pr,al,rl)
	desc9a	bb|0,ql
	arg	nxtnbtab
	arg	lp|tctally

	ada	lp|tctally
	ana	=o77777777
	sta	eb_data_$curr_char_no

chk_sym:	tsx7	set_char
	tsx7	get_char
	cmpa	eb_data_$codtab+ilet  check for legal first char (letter or . or _)
	tze	putin	"
	cmpa	eb_data_$codtab+ipoint  "
	tze	putin	"
	cmpx6	getnametab,du	check if we came in through getname
	tnz	clear		if not we have the terminator already
	cmpa	eb_data_$codtab+inl	make sure we are not at end of statement
	tze	return

putin:	tsx7	set_char
	sba	1,dl		back up 1 char
	adq	1,dl
	cmpq	31,dl		scan only 31 chars
	tmoz	*+2
	ldq	31,dl

	tct	(pr,al,rl)
	desc9a	bb|0,ql
	arg	0,6
	arg	lp|tctally

	ldq	lp|tctally
	mlr	(pr,al,rl),(pr),fill(0)
	desc9a	bb|0,ql
	desc9a	bp|0(1),31
	qls	27
	stbq	bp|0,40		insert count

	ada	lp|tctally
	ana	=o77777777
	sta	eb_data_$curr_char_no

	tra	next


clear:	mlr	(),(pr),fill(0)	clear sym
	desc9a	*,0
	desc9a	bp|0,32

	tra	return

" 

nxtnbtab:
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/0,9/1,9/1,9/0,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/0,9/1,9/1,9/1,9/1,9/0,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1


" 

nxtsttab:
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/1,9/0,9/0,9/1,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/1,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0


" 

getidtab:
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/0,9/1
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/1,9/1,9/1,9/1,9/0

	vfd	9/1,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1

	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1
	vfd	9/1,9/1,9/1,9/1,9/1,9/1,9/1,9/1


" 

getnametab:
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/1,9/1,9/0,9/1,9/1,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/1,9/0,9/0,9/0,9/0,9/1,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/1,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/1,9/0,9/0,9/1,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0

	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0
	vfd	9/0,9/0,9/0,9/0,9/0,9/0,9/0,9/0


	end




		    litevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.8      100449



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


litevl_:
	procedure (ad, admod, txtern);

/* Modified 740820 by PG to fix ancient bug (from the FORTRAN version, apparently) whereby
   parameters of the itsevl and itbevl entries were used as temporaries by the code of other entries! */
/*	Modified on 08/06/73 at 12:56:08 by R F Mabee.
	by R F Mabee in June 1973 to add BCD literals.
	by R F Mabee on 22 November 1972 to allow user-defined internal symbols as base names in ITB.
	by R F Mabee on 2 November 1972 to fix bugs with parentheses around literals.
	by R F Mabee on 13 June 1972 to change followon pointer format and repair clobbered source.
	by RHG on 22 Sept 1970 to check for nl or; during aci literal
*/

/* LITEVL:
	routine to evaluate literal constants in variable field. */
/*	octal, decimal, and vfd literals are evaluated and tabulated */
/*      litevl also checks for dl or du modifier for immediate operand. */
/*      for this reason decevl (called by litevl) must return type */
/*      of literal evaluated. */


/* INCLUDE FILES USED BY LITEVL */

% include concom;
% include varcom;
% include codtab;
% include erflgs;
% include lclit;
% include alm_options;

/* END OF THE INCLUDE FILES */
/**/

/* PARAMETERS */

declare xrslts (8) fixed bin(35);

/* EXTERNAL ENTRIES USED BY LITEVL */

declare	utils_$putach ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
	getbit_$getbit_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
	getid_$getid_ ext entry,
	inputs_$next ext entry,
	utils_$makins ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	modevl_$modevl_ ext entry (fixed bin (26)) returns (fixed bin (26)),
	expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	vfdevl_$vfdevl_ ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	octevl_$octevl_ ext entry (fixed bin (26)) returns (fixed bin (26)),
	decevl_$decevl_ ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	utils_$ls ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	utils_$rs ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	utils_$and ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	glpl_$setblk ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
	glpl_$storr ext entry (fixed bin (26), fixed bin (26)) ,
	glpl_$crh ext entry (fixed bin (26)) returns (fixed bin (26)),
	glpl_$clh ext entry (fixed bin (26)) returns (fixed bin (26)),
	glpl_$cwrd ext entry (fixed bin) returns (fixed bin),
	glpl_$glwrd ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26));


/* EXTERNAL DATA USED BY LITEVL */

declare	(eb_data_$jba,	eb_data_$jbi,	eb_data_$jbm,	eb_data_$jbo,
	eb_data_$jbv,	eb_data_$ibtb,	eb_data_$ibts,	eb_data_$iasc,
	eb_data_$ibtp,	eb_data_$jbh,
	eb_data_$ifxd,	eb_data_$iint,	eb_data_$ioct,	eb_data_$ivfd,
	eb_data_$imach,	eb_data_$iitb,	eb_data_$iits,	eb_data_$ierr ) ext fixed bin (35);

 declare	eb_data_$bcd_table (0:127) ext unaligned bit (6);

declare	 eb_data_$lavptr ext ptr;
 

/* AUTOMATIC DATA USED BY LITEVL */

declare	 (ad,	admod,	ipair (2)) fixed bin (26);
declare (ipmod,	iprht,	ipval,	j,	junk,	k,	lcptr,	nprime,	tbscl, lcptrx,
	txtern,	 rleft, xn,	bcdlet,	type,	flags,	i,	iaddr,	ipbas ) fixed bin (26);
dcl iplft fixed bin (26);
declare	parentheses fixed binary;	/* Count of nesting parentheses to be paired at end. */

declare	1 literal aligned,
	2 (block (2),rslts (8)) fixed bin (26);

declare	 n fixed bin (26) defined block (2);

declare	its_or_itb_entry bit (1) aligned initial ("0"b);	/* make sure it always has a good value */

/* BASED OVERLAYS USED BY LITEVL */

declare	1 word based aligned,
	  2 left   bit (18) unaligned,
	  2 right  bit (18) unaligned;

 declare	bcd (1:6) based unaligned bit (6);




/*      main entry, get next character and branch on literal type. */
	tbscl = 0 /*FALSE*/;	/*This was not in the Fortran -- tres, tres mal code */
	parentheses = 0;
label_100:
	call inputs_$next;
	lcptr = 0;
	if (brk (1) = inum | brk (1) = iplus | brk (1) = iminus | brk (1) = ipoint)
	then do;
		/* must be a decimal or aci literal */

		n = decevl_$decevl_ (rslts (1), type);
		go to label_400;
	     end;

	if (brk (1) = ilet) then goto label_300;
	if (brk (1) ^= ilpar) then goto label_370;
	parentheses = parentheses + 1;
	goto label_100;

/*      break is letter, branch on type. */
label_300:
	if (brk (2) = eb_data_$jba) then goto label_310;
	if (brk (2) = eb_data_$jbo) then goto label_320;
	if (brk (2) = eb_data_$jbv) then goto label_330;
	if (brk (2) = eb_data_$jbm) then goto label_335;
	if brk (2) = eb_data_$jbh then goto label_bcd;

	if (brk (2) ^= eb_data_$jbi) then goto label_305;
	call getid_$getid_;
	if (brk (1) ^= ilpar) then goto label_370;
	parentheses = parentheses + 1;
	if (sym (1) = eb_data_$ibtb) then goto label_340;
	if (sym (1) = eb_data_$ibts) then goto label_355;
	if sym (1) = eb_data_$ibtp then goto label_340;
label_305:
	goto label_370;

/*      routine for aci literal. */
label_310:
	n = 1;
	type = eb_data_$iasc;
	rslts (1) = 0;
	do i = 1 to 4;
	     call inputs_$next;
	     if brk (1) = inl then goto label_400;
	     call utils_$putach (rslts (1),i,brk (2));
	end;

	call inputs_$next;
	goto label_400;

/*	routine for bcd literal. */
label_bcd:
	n = 1;
	type = eb_data_$iasc;
	rslts (1) = 0;
	do i = 1 to 6;
		call inputs_$next;
		if brk (1) = inl then goto label_400;
		addr (rslts (1)) -> bcd (i) = eb_data_$bcd_table (brk (2));
		end;
	call inputs_$next;
	goto label_400;

/*      routine for octal literals. */
label_320:
	n = octevl_$octevl_ (rslts (1));
	type = eb_data_$ioct;
	goto label_400;

/*      routine for variable field literals. */
label_330:
	n = vfdevl_$vfdevl_ (rslts (1),flags);
	lcptr = flags;
	type = eb_data_$ivfd;
	goto label_400;

/*      machine literals not yet coded. */
label_335:
	goto label_370;

/*      entry for itb type literal. */
itbevl:	entry (ipair, xrslts);

	its_or_itb_entry = "1"b;			/* note that we came in here */

	tbscl = 1;	/*TRUE*/
label_340:
	iprht = mitb;
	type = eb_data_$iitb;
	call getid_$getid_;
	if (^ (sym (1) ^= 0  &  brk (1) = icomma)) then goto label_350;
	do i = 1 to 8;
	     if (sym (1)  ^=  symbas (i)) then goto label_345;
	     iplft = 32768* (i-1);
	     goto label_360;
label_345:
	end;

	if table_$table_ (iserch,sym (1),iplft,clint,junk) ^= 0 then goto label_357;
label_350:
	junk = expevl_$expevl_ (0, iplft, iaddr );
	if (iaddr ^= 0) then prntr = 1;	/*TRUE*/
label_357:
	iplft = 32768*iplft;
	goto label_360;

/*      entry for its type literals. */
itsevl:	entry (ipair, xrslts);

	its_or_itb_entry = "1"b;			/* note that we came in here */

	tbscl = 1;	/*TRUE*/
label_355:
	iprht = mits;
	type = eb_data_$iits;
	call getid_$getid_;
	junk = expevl_$expevl_ (0, iplft, iaddr );
	if (iaddr ^= 0) then prntr = 1;	/*TRUE*/
	if tnewmachine ^= 0 then iplft = utils_$and (iplft, (fivsev));
label_360:
	if (brk (1) ^= icomma) then goto label_370;
	call getid_$getid_;
	junk = expevl_$expevl_ (0, ipval, iaddr );
	rleft = 0;
	if (iaddr  =  0) then goto label_361;
	ipval = ipval + glpl_$clh (iaddr+3);
	if (tbscl ^= 0  |  iaddr  =  0) then goto label_363;
	rslts (1) = 0;
	rslts (2) = glpl_$glwrd (iaddr,0);
	lcptr = glpl_$setblk (rslts (1),2);
	goto label_361;
label_363:
	call getbit_$getbit_ (iaddr,ipbas,/* ipb29 */  0 ,rleft);
label_361:
	ipmod = 0;
	if (brk (1) ^= icomma) then goto label_362;
	ipmod = modevl_$modevl_ (brk (1) );
label_362:

	rslts (1) = glpl_$glwrd (iplft,iprht);
	rslts (2) = utils_$makins (ipbas,ipval,0,/* ipb29 */  0 ,ipmod);
	n = 2;
	if (tbscl = 0) then goto label_400;
label_365:
	ipair (1) = rslts (1);
	ipair (2) = rslts (2);
	rslts (1) = 0;
	rslts (2) = glpl_$glwrd (rleft,0);
	go to return_from_its_itb;

/*	illegal literal type. */
label_370:
	n = 1;
	rslts (1) = 0;
	rslts (2) = 0;
	rleft = 0;
	type = eb_data_$ierr;
	prntf = 1;	/*TRUE*/
	if (tbscl ^= 0) then goto label_365;
	rslts (1) = 0;
	rslts (2) = 0;
	call inputs_$next;
	goto label_400;

/*	entry to define a literal in ext vector. */
litasn:	entry (ad, xrslts, xn, lcptrx );

	lcptr = lcptrx;
	n = xn;
	if (n > 8) then n = 8;
	do i = 1 to n;
	     rslts (i) = xrslts (i);
	end;
	goto label_500;


/*	literal evaluated, check for du or dl modifier. */
label_400:
	admod = 0;
	do while (parentheses > 0 & brk (1) = irpar);	/* Pair off parends. */
		call inputs_$next ();
		parentheses = parentheses - 1;
		end;
	if (brk (1) ^= icomma | txtern = 0 | parentheses ^= 0) then goto label_500;
	admod = modevl_$modevl_ (brk (1) );
	if (n >= 2) then goto label_500;
	if (admod ^= mdu  &  admod ^= mdl) then goto label_500;
	if (type = eb_data_$imach | type = eb_data_$ivfd | type = eb_data_$ioct
	| type = eb_data_$iint | type = eb_data_$ifxd) then goto label_410;
		ad = utils_$rs (rslts (1),18);
		goto label_420;
label_410:

		ad = utils_$and (rslts (1),sixsev);
label_420:

	n = 0;
	goto label_700;


/*	search literal list for this literal and assign if not there. */
/*	funny business because of equivalence between n and block (2) */
/*	and desire to put lcptr in left half of block (2). */
label_500:
	j = litlst;
	nprime = n;
	block (2) = glpl_$glwrd (lcptr,n);
	litc = glpl_$crh (lplit+1);
label_510:
	if (j = 0) then goto label_540;
	if (glpl_$cwrd (j+1) ^= nprime) then goto label_530;
do_520:	do k = 1 to nprime;
	if (glpl_$cwrd (j+k+1) ^= rslts (k)) then goto label_530;
label_520:	end do_520;
		ad = glpl_$clh (j);
	goto label_700;
label_530:
	j = glpl_$crh (j);
	goto label_510;

/*	not found in list, assign this literal. */
label_540:
	if (nprime > 1  &  mod (litc,2) ^= 0) then litc = litc+1;
	block (1) = utils_$ls (litc,18);
	j = glpl_$setblk (block (1),nprime+2);
	ndltls -> word.right = addr (j ) -> word.right;
	ndltls = ptr (eb_data_$lavptr, j );
	ad = litc;
	litc = litc+nprime;


/*	final return section. */
label_700:
	call glpl_$storr (lplit+1,litc);

	/* if we came in the itbevl or itsevl entries, we must simulate passing "rslts" by reference.
	   (since rslts is not a parameter to all entry points, but is used as a temporary in all
	   entry points, we cannot just make it a real parameter. sigh!) */

return_from_its_itb:
	if its_or_itb_entry
	then do;
		xrslts (1) = rslts (1);
		xrslts (2) = rslts (2);
	     end;

	return;

	end litevl_;




		    lstman_.pl1                     10/17/88  1013.9rew 10/17/88  0939.0      109809



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support *heap exernal variables.
                                                   END HISTORY COMMENTS */


lstman_:	procedure (dummy);
  
/*	Last modified on 08/28/72 at 18:24:08 by R F Mabee.
	Made blkasn call table_ to enter names in xref tree, 27 July 1972, R F Mabee.
	Modified to put new object format entry sequence in text, 21 March 1972, R F Mabee.
	by Paul Green on June 23, 1970 at 2255
	by Noel I. Morris on March 1, 1977 for *system links	*/
  
/*		list manipulating routines for eplbsa.
	lstman has eight entries and handles reference lists for eplbsa.


	the eight entries are as follows:
	   namasn(xsym)  for assigning eplbsa names to definition region,
	   blkasn(type,snlnk,xnlnk,trptr)  for assigning type-pairs,
	   trpasn(trpcal,trparg)  for assigning trap words,
	   lnkasn(blklnk,inexp,admod)  for assigning link pairs,
	   eptasn(eploc,epnlnk,epllnk)  for assigning entry points,
	   sdfasn(sdloc,sdnlnk)  for assigning segment definitions,
	   outasn(xspc,rtnpt)  for mm or xo calls,
	   calser(calpc,outlnk)  to search call list.
	in addition, various counts are maintained by these routines
	for use by postp2 in outputting the definitions. */
 

%	include	varcom;
%	include	alm_options;
%	include	alm_lc;
%	include	erflgs;
%	include	concom;
/* END OF THE INCLUDE FILES FOR LSTMAN */
/**/

dcl (	glpl_$clh		ext entry ( fixed bin(26) ),
	glpl_$crh		ext entry ( fixed bin(26) ),
	glpl_$cwrd	ext entry ( fixed bin (26) ),
	glpl_$glwrd	ext entry ( fixed bin (26), fixed bin (26) ),
	glpl_$setblk	ext entry ( fixed bin(26), fixed bin(26) ),
	table_ external entry (fixed binary (26), fixed binary, fixed binary, fixed binary, fixed binary),
	utils_$nswrds	ext entry ( fixed bin (26) )
		) returns ( fixed bin(26));

dcl ( 	words(5),	xsym(8),	type,	nwrds,	xnlnk,	trptr,	trpcal,	trparg,	blklnk,
	inexp,	admod,	eploc,	epnlnk,	epllnk,	sdloc,	snlnk,	xspc,	rtnpt,
	calpc,	outlnk,	explnk,	tvrtn,	tvno,	tvlnk,	epelnk,	eptlc,	sdlc,
	rtnlc,	etrap,	eclass,	sdtrap,	sclass,	k,	j,	iad,	lc,	
	l,	ii,	lnkout,	namlnk,	link,	sdnlnk,	dummy	) fixed bin (26) ;

 declare	temp_ptr pointer;

dcl (eb_data_$l0r0, eb_data_$l1r0, eb_data_$l2r0, eb_data_$l3r0 ) ext fixed bin (17) ;
 declare	eb_data_$atext (2) fixed binary external static,
	eb_data_$alink (2) fixed binary external static,
	eb_data_$asym (2) fixed binary external static,
	eb_data_$astat (2) fixed binary external static,
	eb_data_$asys (2) fixed binary external static,
	eb_data_$aheap (2) fixed binary external static;

 declare	eb_data_$new_nentls external fixed binary;

dcl eb_data_$lavptr ext pointer;

 declare	based_word fixed binary based aligned;
dcl 1 word based  aligned,
   2 left char(2) unaligned,
   2 right char(2) unaligned;

 declare	twop18 fixed binary (26) internal static initial (1000000000000000000b);

/* The following variables are used to assign the return arguments for each routine, since PL/I
   has a difficult time determining which position gets the returns value, since it has to figure
   out which entry was entered, and how many args it had. We can do it much better this way */

dcl (	namrtn,	blkretn,	trapretn,	lnkretn,	eptretn,	sdfretn,	outretn,	calretn ) fixed bin (17);


/*
	j = namasn, maintain list of external names with no duplications.
	note possibility of   entry x $, x   lda .x.1.x. $, but resultant
	x entry in table is unique.
					*/
namasn:	entry(xsym, namrtn);

label_1000:
	  nwrds = utils_$nswrds(xsym(1)) ;
		if nwrds  ^=  0  then go to  label_1010 ;
	   prntf =  1 ; 
	namrtn = 0;
	return;

label_1010:
	  j = namlst ;


label_1020:
	  if j  =  0 then go to label_1050 ;
		link = glpl_$clh(j) ;

label_1030:
	do  k = 1 to nwrds ;
	  if (xsym(k)  ^=  glpl_$cwrd(link+k-1)) then go to label_1040 ;
end label_1030 ;

	namrtn = j;
	return;
 
label_1040:
  	j = glpl_$crh(j) ;
	go to label_1020 ;
 
label_1050:
	namlnk = glpl_$setblk(xsym(1),nwrds) ;
	words(1) = glpl_$glwrd(namlnk,namlst) ; 
	words(2) = 0 ; 
	namlst = glpl_$setblk(words(1),2) ; 
	namrtn = namlst;
	return;
    

/*
	j = blkasn, maintain list of type-pair blocks, note that
	type 3 or 4 block with zero segment pointer refers to the text
	segment associated with this block. */
 
blkasn:	entry( type, snlnk, xnlnk, trptr, blkretn );

/* Put segname and entryname in cross reference tree. */
	if tnoxref ^= 0 then goto label_2000;

	if type = 3 | type = 4 then ii = table_ (iassgn, glpl_$clh (snlnk), 0, 0, 0);	/* Segname is valid. */
	else if type = 1 | type = 5 then do;	/* Self-reference, fabricate name. */
		if snlnk = 0 then temp_ptr = addr (eb_data_$atext (1));
		else if snlnk = 1 then temp_ptr = addr (eb_data_$alink (1));
		else if snlnk = 2 then temp_ptr = addr (eb_data_$asym (1));
		else if snlnk = 4 then temp_ptr = addr (eb_data_$astat (1));
		else if snlnk = 5 then temp_ptr = addr (eb_data_$asys (1));
		else if snlnk = 6 then temp_ptr = addr (eb_data_$aheap (1));
		ii = table_ (iassgn, temp_ptr -> based_word, 0, 0, 0);
		end;

	if type = 2 | type = 4 | type = 5 then ii = table_ (iassgn, glpl_$clh (xnlnk), 0, 0, 0);	/* Valid entry name. */

label_2000:
	words(2) = glpl_$glwrd(type,trptr) ; 
	words(3) = glpl_$glwrd(snlnk,xnlnk) ; 

label_2010:
	j = blklst;		/* blklst is index of lastest "block" created. */

label_2020:
	  if (j  =  0) then go to label_2200 ;	/* search blklst, if found, return index, if not, add it on. */
	/* ignore presence of trptr in search */
	if (type  =  glpl_$clh(j+1)  &  words(3)  =  glpl_$cwrd(j+2)) then go to label_2100 ;
	j = glpl_$crh(j) ;
	go to label_2020 ; 
  
label_2100:
	blkretn = j;
	return;
  
label_2200:
	words(1) = blklst ;
	blklst = glpl_$setblk(words(1),3) ;
	blkretn = blklst;
	return;

  
	/*
	j  =  trpasn, maintain list of trap pointer words. */
  
trpasn:	entry (trpcal, trparg, trapretn );

label_3000:
	words(2) = glpl_$glwrd(trpcal,trparg) ; 
  
label_3010:
	j = trplst ;
  
label_3020:
	if (j  =  0) then go to label_3200 ; 
	if (words(2)  =  glpl_$cwrd(j+1)) then go to label_3100 ; 
	j = glpl_$crh(j) ; 
	go to label_3020 ; 
  
label_3100:
	trapretn = j;
	return;
  
label_3200:
	words(1) = trplst ; 
	trplst = glpl_$setblk(words(1),2) ; 
	trapretn = trplst;
	return;
  
  
	/*	xlnkno = lnkasn, enter normal link pair words into link list.
  
	explst entries are of the form--
	0,next
	ptr to type-pair block,value of internal expressison
	0,ptr to location counter for inexp.
	--the lh of first word is filled in during postp2 with the
	absolute address of the internal expression word.  this
	address is then used in the second word of the link
	pair. */
  
lnkasn:	entry (blklnk,inexp,admod,lc, lnkretn ) ; 

label_4000:
	words(2) = glpl_$glwrd(blklnk,inexp) ; 
	iad = lc ; 
  
label_4010:
	j = explst ;

label_4020:
	if (j  =  0) then go to label_4200 ;
	if (words(2)  =  glpl_$cwrd(j+1) & glpl_$crh(j+2)  =  iad) then go to label_4100 ; 
	j = glpl_$crh(j) ; 
	go to label_4020 ; 
  
label_4100:
	explnk = j ; 
	go to label_4300 ; 
  
label_4200:
	words(1) = explst ; 
	words(3) = iad ; 
	explst = glpl_$setblk(words(1),3) ; 
	explnk = explst ; 
	words(2) = glpl_$glwrd(explnk,admod) ; 
	go to label_4500 ; 
  
label_4300:
	words(2)   =  glpl_$glwrd(explnk,admod) ;

label_4310:
	j = lnklst ; 
	l  =  0 ;

label_4320:
	if j  =  0 then go to label_4500 ; 

	 ii  =  glpl_$clh(j) ; 
	 if ( ii < 3) then go to label_4330 ; 
	    l = l+2 ; 
	   go to label_4340 ; 
label_4330:
	if ( words(2)   =   glpl_$cwrd(j+1)  &  ii   =   1 ) then go to label_4400 ; 
	if  ii   =   1  then l  =  l+2 ; 
	 if(ii   ^=   2 ) then go to label_4340 ; 
	if tnewobject = 0 then l  =  l + 6 ; 
label_4340:
	j = glpl_$crh(j) ; 
	go to label_4320 ; 
  
label_4400:
	lnkretn = l;
	return;
  
label_4500:
	words(1) = eb_data_$l1r0 ; 
	link = glpl_$setblk(words(1),2) ; 
	ndlkls -> word.right = addr(link) -> word.right;
	ndlkls = ptr( eb_data_$lavptr,link );
	lnkretn = lnkno;			/* this saves having to subtract the 2 again */
	lnkno = lnkno+2 ; 
	return;
  
  
	 /*  xlnkno = eptasn, enter entry points into link structure list. */
  
eptasn:	entry(eploc,epnlnk,epllnk,eptlc,etrap,eclass, eptretn );
  
label_5000:
	tvno = tvcnt ; 	/* add to transfer vector */
	tvcnt = tvcnt+1 ; 
  
	words(1)  =  eb_data_$l0r0 ; 
	words(2) = glpl_$glwrd(tvno,eploc) ; 
	words(3) = glpl_$glwrd(eptlc,tinhib) ; 
	tvlnk = glpl_$setblk(words(1),3) ; 
	ndtvls -> word.right = addr(tvlnk) -> word.right;
	ndtvls = ptr( eb_data_$lavptr,tvlnk );
  
label_5100:
	words(1) = eb_data_$l2r0 ; 
	words(2) = glpl_$glwrd(epllnk,tvno) ; 
	 words(3)  =  glpl_$glwrd(tvlnk,tinhib) ; 
	epelnk = glpl_$setblk(words(1),3) ; 
	ndlkls->word.right = addr(epelnk)->word.right;
	ndlkls = ptr( eb_data_$lavptr, epelnk);
  
label_5200:
	if epnlnk  =  0 then go to label_5300 ;     
	words(1) = glpl_$glwrd(epnlnk,xdflst) ; 
	if tnewobject = 0 then do;
		words(2) = glpl_$glwrd(lnkno,eclass) ; 
		words(3) = glpl_$glwrd(etrap,(lpsect)) ; 
		end;
	else do;
		words (2) = glpl_$glwrd (entrieslc + 1, 0);
		words (3) = glpl_$glwrd (etrap, (lpentries));
		end;
	words (4) = epelnk * twop18;
	xdflst = glpl_$setblk (words (1), 4); 
 
label_5300:
   
  
	 /*   the length of the entry sequence is 6 words for both
	 mastermode and slave programs. */
	eptretn = lnkno;
	if tnewobject = 0 then lnkno  =  lnkno + 6; 
	else entrieslc = entrieslc + eb_data_$new_nentls;
	return;
  
  
		/* j  =  sdfasn, enter segdef information into definition list. */
  
sdfasn:	entry( sdloc, sdnlnk, sdlc, sdtrap, sclass, sdfretn );

label_6000:
	if tprot  ^=  0 then prntx  =  1 ;

label_6100:
	words(1) = glpl_$glwrd(sdnlnk,xdflst) ; 
	words(2) = glpl_$glwrd(sdloc,sclass) ; 
	words(3) = glpl_$glwrd(sdtrap,sdlc) ; 
	words (4) = 0;
	xdflst = glpl_$setblk (words (1), 4) ; 
	sdfretn = xdflst ;
	return;
  
  
		/* j   =  outasn, enter information of mm or xo  call into link list. */
	    	/* final format of block in link list is,
	   (3,next),(traout),(mylnk,tvno),(spc,lpaswd) */
  
outasn:	entry (xspc,rtnpt,rtnlc, outretn );

label_7000:
	tvno = tvcnt ; 
	tvcnt = tvcnt+1 ; 
	words(1) = eb_data_$l0r0 ; 
	words(2) = glpl_$glwrd(tvno,rtnpt) ; 
	words(3) = glpl_$glwrd(rtnlc,tinhib) ; 
	tvlnk = glpl_$setblk(words(1),3) ; 
	ndtvls -> word.right = addr( tvlnk ) -> word.right;
	ndtvls = ptr( eb_data_$lavptr, tvlnk);
  
	/* assign outlst block */
label_7100:
	words(1) = eb_data_$l3r0 ; 
	words(2) = eb_data_$l0r0 ; 
	words(3) = glpl_$glwrd(mylnk,tvno) ; 
	words(4) = glpl_$glwrd(xspc,0) ; 
	words(5) = tinhib ; 
	lnkout = glpl_$setblk(words(1),5) ; 
	ndlkls -> word.right = addr( lnkout ) -> word.right;
	ndlkls = ptr( eb_data_$lavptr, lnkout);
	lnkno = lnkno+2 ; 
	outretn = lnkout ;
	return;
  
  
		/* j  =  calser, search call list for calpc, return lstlnk and outlnk. */
  
calser:	entry (calpc,outlnk, calretn );

label_8000:
	j = lnklst ;
  
	l = 0 ;

label_8010:
	if j  =  0 then go to label_8200 ;
	if (glpl_$clh(j)  ^=  3) then go to label_8020 ; 
	   if (glpl_$clh(j+3)  =  calpc) then go to label_8100 ; 
	   l = l+2 ; 
	   go to label_8030 ; 

label_8020:
	ii  =  glpl_$clh(j) ; 
	if ( ii   =   1 ) then l  =  l + 2 ; 
	 if ii  ^=   2  then go to label_8030 ; 
	 l  =  l + 6 ; 

label_8030:
	j = glpl_$crh(j) ; 
	go to label_8010 ; 
  
		/* found, set lstman and outlnk, then return. */
label_8100:
  
	outlnk = l ; 
	calretn = j;
	return;
  
	/* not found, return with zeroes */
label_8200:
	outlnk = 0 ; 
	calretn = 0;
	return;
  
  
end lstman_;




		    make_alm_object_map_.pl1        10/17/88  1013.9r w 10/17/88  0938.8       28800



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


/* Procedure to put new format object map into object segment for ALM.
   Created on 05/06/72 at 17:23:51 by R F Mabee.
   Modified on 05/20/72 at 13:28:34 by R F Mabee.  
   Modified for new object map on 06/15/75 by Eugene E Wiatrowski. */

make_alm_object_map_: procedure (bit_count);
 declare	bit_count fixed binary;

% include	object_map;

% include	segnfo;

% include	objnfo;

declare	eb_data_$entry_bound ext fixed bin(18);
declare	eb_data_$entrybound_bit ext bit(1);
declare	eb_data_$separate_static ext bit(1) aligned;
declare   eb_data_$per_process_static_sw ext fixed bin;
declare	(object_map_pointer,end_ptr) pointer;


	object_map_pointer = pointer (text, txtlen);

	object_map_pointer -> object_map.decl_vers = object_map_version_2;
	object_map_pointer -> object_map.identifier = "obj_map ";
	object_map_pointer -> object_map.text_offset = bit (fixed (new_text_offset, 18));
	object_map_pointer -> object_map.text_length = bit (fixed (new_text_length, 18));
	object_map_pointer -> object_map.definition_offset = bit (fixed (new_definition_offset, 18));
	object_map_pointer -> object_map.definition_length = bit (fixed (new_definition_length, 18));
	object_map_pointer -> object_map.linkage_offset = bit (fixed (new_link_offset, 18));
	object_map_pointer -> object_map.linkage_length = bit (fixed (new_link_length, 18));
	object_map_pointer -> object_map.static_offset = bit (fixed (new_static_offset, 18));
	object_map_pointer -> object_map.static_length = bit (fixed (new_static_length, 18));
	object_map_pointer -> object_map.symbol_offset = bit (fixed (new_symbol_offset, 18));
	object_map_pointer -> object_map.symbol_length = bit (fixed (new_symbol_length, 18));
	object_map_pointer -> object_map.break_map_offset = ""b;
	object_map_pointer -> object_map.break_map_length = ""b;
	if eb_data_$entrybound_bit
	   then object_map_pointer -> object_map.entry_bound = bit(eb_data_$entry_bound,18);

	string (object_map_pointer -> object_map.format) = ""b;
	object_map_pointer -> object_map.format.relocatable = "1"b;
	object_map_pointer -> object_map.format.procedure = "1"b;
	object_map_pointer -> object_map.format.standard = "1"b;
	object_map_pointer -> object_map.format.separate_static = eb_data_$separate_static;
	object_map_pointer -> object_map.format.perprocess_static = (eb_data_$per_process_static_sw ^= 0);

	end_ptr = addrel(object_map_pointer,size(object_map_pointer -> object_map));
	end_ptr -> map_ptr = rel(object_map_pointer);
	bit_count = fixed (rel (end_ptr), 18) * 36 + 36;
	end;




		    mexp_.pl1                       10/17/88  1013.9rew 10/17/88  0938.9      463635



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to change argument passing conventions. This is part of the
     changes for calling via the new subroutine "alm_".
                                                   END HISTORY COMMENTS */


mexp_$ignore: procedure ();
	return;

/* This program is a simple macro expander for alm programs. */

/* Last modified to list skipped iftarget code as comments by E. N. Kittlitz on 8/17/83 */
/* Last modified for changes requested by MTR 175 by EBush on 3/26/81 */
/* Modified to implement "iftarget" and "intarget" by EBush on 2/5/81 */
/* First written "about '70, '71" by Steve Webber, as stand-alone program. */
/* Integrated with ALM, fully EIS-ed, resubroutinized by Bernard Greenberg 3/25/77
   Also implemented functions 14-22 at that time, and shared-seg buffer stack. */


dcl  next fixed bin (21),
     code fixed bin (35),
     entry_no fixed bin (21),
     WHITE char (2) static init ("	 ") options (constant),
     ENDS char (4) static init ("();
") options (constant),
     TERMS char (2) static init (";
") options (constant),
     discard fixed bin,
     vc char (12) var,
     convert_binary_integer_$octal_string entry (fixed bin) returns (char (12) var),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
     c char (1) aligned,
    (addr, substr, ptr, unspec, index, null, length) builtin,
     gtsname char (32) static options (constant) init ("ALM macro expander"),
    (no_exargs, no_ifargs) fixed bin,
     alm_finished_the_line bit (1) aligned,
     cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
     cu_$arg_list_ptr entry returns (ptr),
     error_table_$noarg fixed bin(35) external,
     ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned),
     targ char (128) var,
     cbuf1 char (200), cb1b char (cb1l) based (addr (cbuf1)), cb1l fixed bin,
     temp_ap ptr, temp_al fixed bin (21),
     input_arg char (temp_al) based (temp_ap),
     arg_1 char (args (1).len) based (substaddr (il, args (1).start)),
     QUOTE char (1) aligned static init (""""),
     max_char_count fixed bin (21),
     sys_info$max_seg_size ext static fixed bin (35),
     COMMA_NL char (2) static init (",
") options (constant),
     NL char (1) static init ("
") options (constant),
     SIGNATURE char (14) static init ("ALM assembly: ") options (constant);

/* 

   TABLE OF MEXP CONTROL CODES and INDICES.

   Keep the vars HERE_FOR_DOCU(1 2) declared under MEXP_CTL_CHARS.
   They document the char/index relation.

*/
dcl  MEXP_CTL_CHARS char (22) init ("1puni()xUAlKk&=[];sFfR") static options (constant);
dcl  HERE_FOR_DOCU1 char (22) init ("0000000001111111111222") static options (constant);
dcl  HERE_FOR_DOCU2 char (22) init ("1234567890123456789012") static options (constant);
dcl  TRIVIAL_ENCODES char (9) init ("punxUKksR") static options (constant);
dcl  COMPARISON_CHARS char (4) init ("^=><") static options (constant);
dcl  COMPARISON_ENCODE char (12) init ("= ^=< <=> >=") static options (constant);
dcl (EQ init (1), NE init (2), LT init (3), LE init (4), GT init (5), GE init (6)) static options (constant);
dcl  type_NORMAL fixed bin static options (constant) init (1);
dcl  type_PREV_UNIQUE fixed bin static options (constant) init (2);
dcl  type_UNIQUE fixed bin static options (constant) init (3);
dcl  type_NEXT_UNIQUE fixed bin static options (constant) init (4);
dcl  type_ITERATE fixed bin static options (constant) init (5);
dcl  type_OPEN fixed bin static options (constant) init (6);
dcl  type_CLOSE fixed bin static options (constant) init (7);
dcl  type_ITER_INDEX fixed bin static options (constant) init (8);
dcl  type_SPEC_UNIQUE fixed bin static options (constant) init (9);
dcl  type_COMMAND_ARG fixed bin static options (constant) init (10);
dcl  type_LENGTH fixed bin static options (constant) init (11);
dcl  type_NARGS fixed bin static options (constant) init (12);
dcl  type_NITER fixed bin static options (constant) init (13);
dcl  type_NULL fixed bin static options (constant) init (14);
dcl  type_COMPARE fixed bin static options (constant) init (15);
dcl  type_STARTCOND fixed bin static options (constant) init (16);
dcl  type_ENDCOND fixed bin static options (constant) init (17);
dcl  type_ELSE fixed bin static options (constant) init (18);
dcl  type_SELECT fixed bin static options (constant) init (19);
dcl  type_FARGS_MACRO fixed bin static options (constant) init (20);
dcl  type_FARGS_ITER fixed bin static options (constant) init (21);
dcl  type_RANGECTL fixed bin static options (constant) init (22);
dcl  type_MAXTYPE fixed bin static options (constant) init (22);

/* WARNING: All internal procedures other than deferr, experr, and genabort must be kept quick, especially
   substaddr. This implies that the three above-named routines, which have formline_ arguments,
   and must therefore be non-quick, must never call any subroutines in this program, or they become
   non-quick. */



/*  */

/*  Declarations for ALM environment integration. */

dcl (envp, sfap) ptr;
dcl  acode fixed bin (35);				/* return code for Multics errors */
dcl  hashx fixed bin (17);				/* macro name hash index */

dcl 1 bct based (envp) aligned,			/* control structure */
    2 sfap ptr init (null ()),			/* ptr to system_free_area */
    2 nsegs fixed bin init (2),			/* number of tempsegs gotten */
    2 curexpseg fixed bin init (2),			/* cur seg for expansions */
    2 macroptr (0:126) ptr,				/* non-initted hash table of macros */
    2 hashx_used bit (127) aligned init ("0"b),		/* 0 => macroptr(x) not valid */
    2 curlevel fixed bin init (0),			/* level of macros handed out */
    2 macfree fixed bin init (0),			/* rel index to macro free def seg */
    2 outstack (100),				/* segx-ptr of macros handed out */
      3 segx fixed bin (13) unal,			/* seg index of expansion buffer */
      3 charx fixed bin (21) unal,			/* index of first char of that exp. */
    2 segarray (10) ptr init ((10) null ()),		/* temp seg array */
    2 segarray_free (10) fixed bin (21) init ((10) 1),	/* charx of first unused char in each buffer tempseg */
    2 unique_generator fixed bin init (0),
    2 unique_generator1 fixed bin init (0),
    2 unique_changed bit (1) init ("0"b);		/* "1"b if used &U in this expansion */

dcl 1 arguments(eb_data_$alm_arg_count) based(eb_data_$alm_arg_ptr),
     2 arg_ptr ptr,
     2 arg_len fixed bin(21);

dcl  segarray_of_one (1) ptr auto;
dcl  segarray_of_two ptr dim (2) based (addr (bct.segarray));
dcl  system_free_area area based (sfap);

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

dcl (inputs_$run_statement, inputs_$run_statement_nolist, inputs_$next_statement, inputs_$next_statement_nolist) ext entry;
dcl  inputs_$get_ptr entry (ptr, fixed bin (21), fixed bin (21), bit (1) aligned);
dcl  alm_include_file_$macro entry (ptr, fixed bin (21)),
     alm_include_file_$pop entry;

dcl  prnter_$macro_error entry (char (*), char (*));
dcl  prnter_$general_abort entry (char (*));
dcl  eb_data_$mexp_env_ptr ptr external,
     eb_data_$macro_linect fixed bin ext,
     eb_data_$mexp_argno fixed bin ext,
     eb_data_$alm_arg_count fixed bin ext,
     eb_data_$alm_arg_ptr ptr ext;

%include system_types;
%include varcom;

/*  */
mexp_$init: entry (acode);

/* Called by ALM at pass1/pass2 init. Allocate control structure, get 2 temp segs. First
   contains macro definition blocks, second is first expansion output buffer. */

	sfap = get_system_free_area_ ();		/* set up to alloc bct */
	allocate bct in (system_free_area);
	bct.sfap = sfap;				/* for later free */
	eb_data_$mexp_env_ptr = envp;
	eb_data_$macro_linect = 0;
	call get_temp_segments_ (gtsname, segarray_of_two, acode);
	return;

mexp_$cleanup: entry;				/* relinquish temp segs */

/* Called by ALM at pass1/pass2 end, and on cleanup condition. Release control structure and
   temp segs. */

	envp = eb_data_$mexp_env_ptr;
	if envp = null then return;
	call release_temp_segments_ (gtsname, bct.segarray, (0));
	sfap = bct.sfap;
	free bct in (system_free_area);
	eb_data_$mexp_env_ptr = null ();
	return;

/*  */

dcl (nparens, i, ci, start, stop, j, iterate) fixed bin (21),
     found_number bit (1) aligned,
     si fixed bin (21),
     mbptr ptr,					/* Ptr to macro structure */
     save_free fixed bin (21),
     val fixed bin,
     semict fixed bin,				/* Count of ALM statements by which to run ALM */
     t fixed bin (21),
     type fixed bin,
     nargs fixed bin,				/* Number of macro args */
     nchars fixed bin (21),
     ia fixed bin,
     ml char (macro_len) based (mp),			/* The Macro Definition Text. */
     macro_len fixed bin (21),
     ob char (max_char_count) based (obp),		/* The Output Buffer */
     currob char (next - 1) based (obp),		/* Currently filled portion of Output Buffer */
     il char (nchars) based (tp),			/* The Input Source */
     end_index fixed bin (21),
    (save_segx, save_segx1, save_curlev) fixed bin, (save_charx, save_charx1) fixed bin (21),
     match bit (1) aligned,
     iftarget_cond bit (1) aligned,
    (var_start, var_end) fixed bin (21),
     opcode char (32) aligned,
     iftarget_str  char(24) varying,
     iftarget_error  fixed bin(35),
     iftarget_value fixed bin(17),
     system_type_ external entry(char(*), char(*), fixed bin(17), fixed bin(35)),
     com_err_      external entry options(variable),
     eb_data_$who_am_I   external static char(12),
     iterate_arg_no fixed bin (21),
    (obp, mp, tp) ptr;

/*  */

/* Data structure used by expander---  macro is structure in temp seg (1). */

dcl 1 ifargs (0: 99) aligned like args;			/* Ptr/len array for pseudoop args */

dcl 1 iterargs (0: 99) aligned like args based (iap), iap ptr; /* Bound to either args or exargs for &( */

dcl 1 exargs (0: 99) aligned like args;			/* Ptr/len array for decomposed argument */

dcl 1 args (0: 99) aligned,				/* Ptr/len array for macro args */
    2 start fixed bin (21),
    2 len fixed bin (21);

dcl 1 macro based (mbptr) aligned,			/* Definition of a macro, in tempseg (1) */
    2 next_macro ptr unal,				/* Hash thread on name. */
    2 startchar fixed bin (21),			/* charx of 1st char, for exp-time err recov. */
    2 sourcelen fixed bin (21),			/* Length of def in chars, for ditto. */
    2 sourcep ptr unal,				/* Ptr to sourceseg/expansion of def */

    2 pad bit (14) unal,
    2 num_entries fixed bin (21) unal,			/* Number of entries in macro.entry */

    2 name char (32),				/* Macro name */
    2 entry (1000),					/* One entry for control seq and tex up to it. */
      3 type fixed bin,				/* Type of control sequence, see tbl above */
      3 value_1 fixed bin (13) unal,			/* Encoded info, value depends on type of ctl seq */
      3 first_char fixed bin (21) unal,			/* charx of text preceding ctl seq, always valid */

      3 value_2 fixed bin (13) unal,			/* Encoded info, value depends on type of ctl seq */
      3 n_chars fixed bin (21) unal;			/* Number of chars of text preceding ctl seq, c/b 0. */

/*  */

mexp_$define_macro: entry (a_opcode);			/* define a macro. */

/* Define a macro. ALM has already picked up the name, and passed it to us, and validated the syntax
   of the statement, which means that inputs_ is at the end of the statement. We let ALM decompose the
   "macro" statement so that ALM's rules on valid symbols and delimiters, which will be used when
   macro is used as opcode, can be applied. */

	envp = eb_data_$mexp_env_ptr;			/* access control frame */

	do i = 1 to bct.curlevel;			/* If source for definition lies in macro expansion,
						   make sure than no buffer space occupied by
						   outstanding macro expansions is ever freed/re-used. */
						/* This ensures the validity of ptr/len's to be encoded. */
	     bct.outstack.segx (i) = bct.curexpseg;
	     bct.outstack.charx (i) = bct.segarray_free (bct.curexpseg);
	end;

	call get_ptrs;				/* Find out where alm is, oughtta be next sta. */

	call get_hashx ((a_opcode));			/* Compute hash index */

	call define_macro (a_opcode, (tp), stop + 1, nchars - stop); /* do it */
	return;

/*  */
define_macro: proc (mname, mpstart, cistart, amacrolen);

dcl  mp ptr, cifin fixed bin (21);
dcl  bad_macro bit (1);
dcl (almpos, lasteralmpos) fixed bin (21);
dcl  amacrolen fixed bin (21);
dcl  condthread fixed bin, condstack (10) fixed bin;
dcl  mname char (*), cistart fixed bin (21), mpstart ptr, ciprev fixed bin (21);

dcl  ml char (macro_len) based (mp) aligned;
dcl (condlevel, itercondlevel) fixed bin;
dcl  c2 char (2);

dcl  start fixed bin (21);
dcl  in_iteration fixed bin;


	     in_iteration = 0;			/* Not inside ()'s */
	     bad_macro = "0"b;			/* No known problems, don't trash def. */
	     condthread = -1;			/* Not in []'s */
	     condlevel = 0;				/* Zero levels of outsdg []'s */
	     macro_len = amacrolen;			/* random arg copy, is remaining source len. */

	     eb_data_$macro_linect = 1;		/* Triggers inputs_ to increment this,
						   and prwrd_ to print it when > 0. */
	     mbptr = ptr (bct.segarray (1), bct.macfree); /* This is where def block goes. */
	     macro.name = mname;			/* Copy name to defblock */

	     mp = mpstart;				/* Copy to automatic */
	     macro.sourcep = mp;			/* All parms in def block rel to this value */

	     almpos, macro.startchar = cistart;		/* Almpos for deferr, startchar for experr. */
	     lasteralmpos = -1;			/* For deferr. */
	     ci = cistart - 1;			/* Prime scan. */

/* Break up macro definition text into control sequences separated by text. Each element in
   macro.entry defines a control sequence and the text preceding it. */

	     do entry_no = 1 by 1;			/* iterate until macro defined */

/* Locate the next &--- countrol sequence. If there's none, &end must be missing. */

		start = ci+1;			/* get start of the current element */
		t = index (substr (ml, start), "&");
		if t = 0 | t = macro_len - start + 1 then do;
		     call deferr ("No &end");
		     go to FIN_MACRO;
		end;

		ci = ci + t;

		macro.entry (entry_no).first_char = start;

/* Encode the location (rel to macro.sourcep) and length (could be 0) of fixed text which
   PRECEDES control sequence, for each sequence. */

		macro.entry (entry_no).n_chars = ci-start;

		c = substr (ml, ci+1, 1);		/* copy next character -- might be argument number */
		si = 2;				/* More general case */

		type = index (MEXP_CTL_CHARS, c);	/* Find type index */
		if type <= type_NORMAL then do;
		     type = type_NORMAL;		/* Try for number> */
		     si = 1;
		     macro.entry (entry_no).value_1 = get_numeric_value_could_be_0 ();
		     if ^found_number then do;
			if substr (ml, ci, 4) = "&end" then go to FIN_MACRO;
			t = index (COMPARISON_CHARS, c);
			if t > 0 then go to compare_op;
			else call deferr_g ("Undefined substitution type: &^a", c);
		     end;
		     if macro.entry (entry_no).value_1 = 0 then call deferr_g ("&0 is not supported");
		     ci = ci - 1;			/* Back up  a little. */
		end;
		else if index (TRIVIAL_ENCODES, c) > 0 then; /* All work done here. */
		else if type = type_ITERATE then if in_iteration <= 0 then
			call deferr_g ("""&i"" occured outside of iteration bounds");
		     else;
		else if type = type_COMPARE then do;
compare_op:	     c2 = substr (ml, ci + 1, 2);
		     if c2 = "^=" | c2 = ">=" | c2 = "<=" then ci = ci + 1;
		     if c = "^" & c2 ^= "^=" then
			call deferr_g ("Illegal conditional construct: &^a", c2);
		     if substr (c2, 2, 1) ^= "=" then substr (c2, 2, 1) = " ";
		     macro.entry (entry_no).value_1 = (index (COMPARISON_ENCODE, c2) + 1)/2;
		     type = type_COMPARE;
		end;
		else if type = type_STARTCOND then do;	/* [ */
		     if condlevel >= hbound (condstack, 1) then
			call deferr_g ("Conditional depth exceeds ^d", hbound (condstack, 1));
		     condlevel = condlevel + 1;

/* Save previous cond-thread in condstack at appropriate level. Start a thread of ['s and ;'s at this
   level, so that we can back-fill entry.val_1 in [ or ; to next ; or ], so expander can skip. */

		     condstack (condlevel) = condthread;
		     condthread = entry_no;
		end;
		else if type = type_ENDCOND then do;	/* ] */
		     if condlevel = 0 then call deferr_g ("Unbalanced brackets");
		     macro.entry (condthread).value_1 = entry_no;
		     macro.entry (entry_no).value_1 = -1;
		     condthread = condstack (condlevel);
		     condlevel = condlevel - 1;
		     if in_iteration >0 & condlevel + 1 = itercondlevel then go to icerr;
		end;
		else if type = type_ELSE then do;	/* ; */
		     if condlevel = 0 then call deferr_g ("Semicolon outside of brackets");
		     macro.entry (condthread).value_1 = entry_no;
		     condthread = entry_no;
		     if in_iteration > 0 & itercondlevel = condlevel then go to icerr;
		end;
		else if type = type_OPEN then do;	/* Start of iteration */
		     save_free = entry_no;
		     macro.entry (entry_no).value_1 = get_numeric_value ();
		     if in_iteration > 0 then call deferr_g ("Illegal recursive iteration");
		     in_iteration = 1;
		     itercondlevel = condlevel;
		end;
		else if type = type_CLOSE then do;	/* end of iteration */
		     in_iteration = in_iteration - 1;
		     if in_iteration < 0 then call deferr_g ("Unbalanced iteration clause");
		     if itercondlevel ^= condlevel then
icerr:			call deferr_g ("Illegal intertwining of conditionals and iteration");
		     macro.entry (entry_no).value_1 = save_free;
		     macro.entry (save_free).value_2 = entry_no;
		end;
		else if type = type_COMMAND_ARG | type = type_LENGTH
						/* Required simple number, &A, &l */
		then macro.entry (entry_no).value_1 = get_numeric_value ();
		else if type = type_NULL
		then macro.entry (entry_no).n_chars = macro.entry (entry_no).n_chars + 1;

		else if type = type_FARGS_MACRO | type = type_FARGS_ITER then do; /* sequence of args */
		     c = substr (ml, ci + 2, 1);
		     if c = "q" | c = "Q" then do;
			ci = ci + 1;
			macro.entry (entry_no).value_2 = 1;
		     end;
		     else macro.entry (entry_no).value_2 = 0;
		     macro.entry (entry_no).value_1 = get_numeric_value ();
		     if type = type_FARGS_ITER & in_iteration <= 0 then call deferr_g ("&f used outside of iteration");
		end;
		else call genabort ("ALM internal problem. Contact assembler maintainers.");

deferr_nlexit:	macro.entry (entry_no).type = type;
		ci = ci + 1;

	     end;


FIN_MACRO:
	     if in_iteration ^= 0 then call deferr ("Unbalanced iteration");
	     if condlevel > 0 then call deferr ("Unbalanced conditional");
	     cifin = ci + 1;			/* Prime the loop */
	     macro.sourcelen = cifin - cistart + 1;	/* Used by experr to count lines */

/* Figure out where ALM input scanner is, in case deferr ran some statements by, and run all
   remaining ALM statements in macro definition by, until the statement with the &end has been run by. */

	     call get_ptrs;				/* set ci to 1st char after invoc */
	     do while (tp = mpstart & cifin >= ci);
		call inputs_$run_statement;		/* Skip stuff for ALM */
		ciprev = ci;			/* save beginning of line previous line */
		call get_ptrs;
	     end;
	     eb_data_$macro_linect = 0;		/* no more macrodef */

	     macro.entry (entry_no).n_chars = macro.entry (entry_no).n_chars - (cifin - ciprev) + 1;
						/* This causes partial line to &end to be skipped. */
	     if bad_macro then do;			/* Any problems => null definition */
		entry_no = 1;
		macro.entry (1).n_chars = 0;
	     end;

	     macro.entry (entry_no).type = type_NULL;	/* indicates no expansion */
	     macro.num_entries = entry_no;
	     macro.next_macro = bct.macroptr (hashx);

/* Thread macro definition into correct hash bucket. */

	     bct.macroptr (hashx) = mbptr;
	     bct.macfree = fixed (rel (addr (macro.entry (entry_no + 1))));
	     return;


get_numeric_value: proc returns (fixed bin);

		return (max (1, get_numeric_value_could_be_0 ()));

	     end get_numeric_value;

get_numeric_value_could_be_0: proc returns (fixed bin);

/* Collect up-to-3-digit decimal number at il|ci+(1 0r 2) to that + 2. */

dcl  c char (1) aligned;

		i = 0;				/* initialize return value */
		found_number = "0"b;
		do ci = ci to ci+2;
		     c = substr (ml, ci+si, 1);
		     if c < "0" | c > "9" then go to r;
		     found_number = "1"b;
		     i = i*10 + bin (unspec (c), 9) - 48;
		end;
r:		if i > hbound (args, 1) then do;
		     call deferr ("Definition time parameter (^d) may not be larger than ^d", i, hbound (args, 1));
		     i = 0;
		end;
		return (i);

	     end;

/*  */

deferr:	     proc options (variable, non_quick);	/* general def error. */

/* Report any problem in definition. Run ALM past any statments in definition that haven't been
   so run yet, so that D error comes out on right line. Set "bad_macro" sw, so that null
   definition results, so expander won't blow up on known bad definition. Calling deferr_g
   causes non-local go-to to next definition control sequence. */

		gsw = "0"b;

deferr_g:		entry options (variable);


dcl  jx fixed bin (21), cha char (1);
dcl  gsw bit (1) init ("1"b);

		call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);
						/* generate remark */

		do while ("1"b);
		     jx = search (substr (ml, almpos), TERMS);
		     if jx = 0 then cha = NL; else cha = substr (ml, almpos + jx - 1, 1);
		     if cha = NL & almpos + jx > ci then do;
			eb_data_$erflgs_overlay.prntd = 1;
			if lasteralmpos ^= almpos then call inputs_$run_statement;
			eb_data_$erflgs_overlay.prntd = 0; /* could be pass 1, ya know */
						/* so keep errs off coll. tape */
			lasteralmpos = almpos;
			bad_macro = "1"b;
			call prnter_$macro_error
			     ("Macro definition error: " || cb1b || " in macro " || rtrim (macro.name) || ".",
			     "**** **** **** ERROR IN MACRO DEFINITION: " || cb1b || ".");
			if gsw then go to deferr_nlexit;
			else return;
		     end;
		     if lasteralmpos ^= almpos then call inputs_$run_statement;
		     almpos = almpos + jx;
		end;

	     end deferr;

	end define_macro;
						/*  */
mexp_$mexp_: entry (a_opcode, errflag, target_value, no_target_given, first_time_thru );
	   dcl a_opcode            char(*),
	       errflag             fixed bin(1),
                 target_value        fixed bin(17),
	       (no_target_given,
	       first_time_thru)     bit (1),      parameter;

/* Called by pass1_/pass2_. The input scanner (inputs_) has scanned an opcode, and the break after it.
   ALM opcode-looker (oplook_) does not know, or claims not to know about the opcode. Value of
   opcode is a parameter to us. The vbl "errflag" is used to tell ALM that we never heard of it
   either. Target_value comes all the way from alm_ and is used to decide iftarget conditionals. */


	opcode = a_opcode;				/* Get into stack */
	errflag = 0;				/* Set up for ALM. */
	envp = eb_data_$mexp_env_ptr;
	semict = 0;				/* ALM lines to skip */

	call get_ptrs;
	var_start = -1;				/* Set up for no var field */
	if ^alm_finished_the_line then do;		/* If line not done, ... */
	     call skip_to_next_line;

	     ci = start;				/* initialize scanning index */
	     call sob;				/* skip over blanks */

	     c = substr (il, ci, 1);			/* pick up the next character of the line */

	     if ^(c = QUOTE | c = NL | c = ";") then do;
		var_start = ci;			/* save start of var field */
		call soc;				/* skip over non-white characters */
		var_end = ci - 1;			/* save last char of variable field */
		if ci > stop then var_end = var_end - 1;
	     end;
	end;

/* See if the opcode is a macro name */

	call get_hashx (opcode);

	do mbptr = bct.macroptr (hashx) repeat macro.next_macro while (mbptr ^= null);
	     if macro.name = opcode then do;		/* we have found a macro to expand */
		call make_new_outbuf;
		call expand_macro;			/* mbptr implied arg */
		call push_mexp_output_upon_alm;
		return;
	     end;
	end;


/*  */
/* See if the opcode is conditional-assembly pseudo-op */

	if opcode = "ife" | opcode = "ine" | opcode = "ifarg" | opcode = "ifint" | opcode = "inint"
	| opcode = "inarg" | opcode = "iftarget" | opcode = "intarget" then do;

/* Get extents of argument list, collect them. Run ALM past all of argument-list statements. */

	     iftarget_cond = substr (opcode, 3) = "target";
	     if var_start < 0 then goto BAD_PSEUDO;	/* must have args for INE and IFE */
	     call make_new_outbuf;
	     j = index (substr (il, stop), "ifend");	/* search for end of conditional data */
	     if j <= 0 then do;			/* bad use of pseudo-op */
BAD_PSEUDO:	eb_data_$erflgs_overlay.prntf = 1;
		return;
	     end;
	     if bct.curlevel = 0 then call inputs_$next_statement;
	     else call inputs_$next_statement_nolist;
	     end_index = stop + j;			/* save position of ifend */
	     call scan_args (ifargs, no_ifargs, var_start, var_end-var_start+1, code);
	     do j = 1 to semict;
		if bct.curlevel = 0 then call inputs_$run_statement;
		else call inputs_$run_statement_nolist;
	     end;
	     if code ^= 0 then go to BAD_PSEUDO;

/* Based upon the opcode, figure out if code is to be skipped or output. Set "match" accordingly. */

	     targ = substr (il, ifargs (1).start, ifargs (1).len);
	     if opcode = "ifarg" | opcode = "inarg" then do; /* Check command arg */
		match = "0"b;			/* default is no match */
		do ia = eb_data_$mexp_argno + 1 to eb_data_$alm_arg_count while (^match);
		     temp_ap = arguments(ia).arg_ptr;
		     temp_al = arguments(ia).arg_len;
		     if input_arg = targ then match = "1"b;
		end;
		if opcode = "inarg" then match = ^match;
	     end;
	     else if opcode = "ifint" | opcode = "inint" then do;
		discard = cv_dec_check_ ((targ), code); /* check for decimal number */
		match = (code = 0);			/* match if arg is decimal integer */
		if opcode = "inint" then match = ^match;
	     end;
	     else if opcode = "iftarget" | opcode = "intarget" then do;

		if no_target_given
		    then do;
		            if tpass1 = 1
			       then prnta = 1;
			  target_value = L68_SYSTEM;
			  if first_time_thru
			       then do;
			             call com_err_(0,eb_data_$who_am_I,"Attempted use of ""iftarget"" or ""intarget"" without providing a value via ""-target"".");
				   first_time_thru = "0"b;
				  end;
                             end;
		iftarget_str = targ;
		call system_type_((iftarget_str),(""),iftarget_value,iftarget_error);
		if iftarget_error ^=0 & tpass1 = 1
		    then do;
		            eb_data_$erflgs_overlay.prntf = 1;
			  iftarget_value = L68_SYSTEM;
		         end;
		match = (target_value = iftarget_value);
		if opcode = "intarget"
		    then match = ^match;
               end;
	     else do;
		if targ = substr (il, ifargs (2).start, ifargs (2).len) then
		match = "1"b; else match = ""b;
		if opcode = "ine" then match = ^match;	/* inverse meaning for INE case */
	     end;

/* Having figured out whether code will be skipped or output, run ALM past the conditional
   code, outputting ALM statements if code is to be output. */

	     call skip_to_next_line;			/* Prime the loop. */
	     do while (stop <= end_index);		/* Stop when ifend line eaten. */
		if ^match & iftarget_cond then call outptr (addr (QUOTE), 1);
		if match | iftarget_cond then call outptr (substaddr (il, start), stop - start + 1);
		call skip_to_next_line;
		call inputs_$run_statement_nolist;
	     end;
	     call inputs_$run_statement_nolist;
	     if iftarget_cond then do;
		call outptr (addr (QUOTE), 1); 
		call outptr (substaddr (il, start), stop - start + 1);
	     end;
	     if substr (il, end_index + 4, 5) = "_exit" & match & bct.curlevel > 0
	     then do;				/* pop curr. macro. */

/* This  save-and-restore song and dance is needed for the following reason: Calling
   alm_include_file$pop will cause the top regnant expansion (the one the ifend_exit alludes to)
   to pop available buffer space to start below that expansion, which is below the
   expansion we just produced, which isn't regnant yet.  We can't push our ife output
   until this old thing is off the stack, or they'd pop in the wrong order. */

		save_segx = bct.curexpseg;
		save_charx = bct.segarray_free (save_segx);
		call alm_include_file_$pop;		/* pop mexp and alm */
		save_segx1 = bct.curexpseg;
		save_charx1 = bct.segarray_free (save_segx1);
		save_curlev = bct.curlevel;
		bct.curexpseg = save_segx;
		bct.segarray_free (save_segx) = save_charx;
		call push_mexp_output_upon_alm;	/* Do it. */
		if bct.curlevel ^= save_curlev then do; /* Make it ss that pop this pops hole. */
		     bct.outstack (bct.curlevel).segx = save_segx1;
		     bct.outstack (bct.curlevel).charx = save_charx1;
		end;
		return;
	     end;
	     call push_mexp_output_upon_alm;
	     return;
	end;

/*  */


	if opcode = "warn" then do;			/* Assembly-time msg */
	     if var_start > 0 then call scan_args (args, nargs, var_start, var_end - var_start +1, code);
	     else args (1).len = 0;
	     if var_start ^> 0 | code ^= 0 then eb_data_$erflgs_overlay.prntf = 1;
	     call inputs_$next_statement;
	     do j = 1 to semict;
		call inputs_$run_statement;
	     end;
	     temp_ap = addr (arg_1); temp_al = length (arg_1);
						/* This little bit of obscurity
						   keeps substaddr from being non-quicked,
						   cause compiler would call it after
						   stack was extended for catenate. */
	     call prnter_$macro_error (SIGNATURE || input_arg, input_arg);
	     return;
	end;


/* No macros or pseudos match, return an error. */

	errflag = 1;
	return;

/*  */

expand_macro: procedure;

/* The value of "opcode" has been found to be a macro name. The vbl "mbptr" points
   to the macro definition block.  The output buffer "ob" has been setup. Run ALM
   past the invocation, and produce the expansion into ob. */

dcl  selector_eno fixed bin;
dcl  tcode fixed bin (35);
dcl  arg_offset fixed bin;
dcl (outstanding_select, outstanding_range) bit (1);
dcl (selector_ob_charpos, range_ob_charpos) fixed bin (21);
dcl  select_answer fixed bin;
dcl  found_d_error_lying_there bit (1);

	     mp = macro.sourcep;
	     outstanding_select, outstanding_range = "0"b;
	     found_d_error_lying_there = (eb_data_$erflgs_overlay.prntd ^= 0);
						/* If this is pass2, all errors that we are going to find
						   were already found by us in pass1,  and collated
						   on coll. tape entry for 1st sta of invoc. */
	     call inputs_$next_statement;		/* Skip over first line of invocation. */

	     if bct.unique_changed then do;		/* did we use it last macro? */
		bct.unique_generator1 = bct.unique_generator1 + 1;
		bct.unique_changed = ""b;
	     end;

/* Now pick off any args from the input source, save pointers to them */

	     if var_start > 0 then call scan_args (args, nargs, var_start, var_end-var_start+1, tcode);
	     else args (*).len, nargs, tcode = 0;

	     do j = 1 to semict;			/* Run ALM over breaks scan_args saw. */
		call inputs_$run_statement;
	     end;
	     if tcode ^= 0 then do;
		eb_data_$erflgs_overlay.prntf = 1;
		return;
	     end;
	     args.len (0) = 0;			/* For good luck. */
	     iterate = 0;				/* in case &x is used and iteration isn't */

/* Now expand each element in array- first the text, then the expansions. */

	     do entry_no = 1 to macro.num_entries;
		call outptr (substaddr (ml, (macro.entry (entry_no).first_char)),
		     (macro.entry (entry_no).n_chars));
		val = macro.entry (entry_no).value_1;	/* extract value for this type of element */
		type = macro.entry (entry_no).type;	/* also extract type of element */
		if type < 1 | type > type_MAXTYPE then
		     call genabort ("ALM internal error. Contact assembler maintainers.");
		go to XP (type);
XP (1):						/* Normal argument expansion (&1, &2, etc.) */
		if val <= nargs
		then call outptr (substaddr (il, args.start (val)), args.len (val));
		go to A;

XP (2):						/* Previous unique (&p) */
		i = bct.unique_generator;
		go to UNIQUE;
XP (3):						/* Unique symbol (&u) */
		bct.unique_generator = bct.unique_generator + 1;
		i = bct.unique_generator;		/* get value for symbol */
UNIQUE:		call ouch ("...");
UNIQUE1:		vc = convert_binary_integer_$octal_string (i + 1e27b); /* convert to char */
		call ouch (substr (vc, 6, 5));
		go to A;
XP (4):						/* next unique (&n) */
		i = bct.unique_generator + 1;
		go to UNIQUE;
XP (5):						/* iterate arg (&i) */
		call outptr (substaddr (il
		     , iterargs (iterate + arg_offset).start),
		     iterargs (iterate + arg_offset).len);
		go to A;
XP (6):						/* Start of iteration (&() */
		save_free = entry_no;
		iterate = 1;			/* Value of &x, index ito iter set. */
		if outstanding_range then do;		/* &R was used, iter over mac arglist. */
		     iap = addr (args);		/* use real args */
		     call get_ob_rangeargs (arg_offset, no_exargs);
		     if arg_offset > 0 then arg_offset = arg_offset - 1;
		     if no_exargs = 0 then no_exargs = 99999;
		     else if no_exargs < arg_offset - 1 then no_exargs = 1;
		     else no_exargs = no_exargs - arg_offset;
		     no_exargs = min (no_exargs, nargs - arg_offset);
		end;
		else do;				/* No &R, iterate over pieces of macro arg */
		     iterate_arg_no = val;
		     i = args (iterate_arg_no).len;
		     if i > 0 then do;
			call scan_args (exargs, no_exargs, args (iterate_arg_no).start, i, tcode);
			if tcode ^= 0 then call experr
			     ("Internal unbalanced parentheses in arg ^d in iteration", iterate_arg_no);
		     end;
		     else no_exargs = 0;		/* null arg => no iterations */
		     iap = addr (exargs);
		     arg_offset = 0;
		end;
ANY_ARGS_Q:	if no_exargs < iterate then
		     entry_no = macro.entry (save_free).value_2;
		go to A;
XP (7):						/* End of iteration (&)) */
		iterate = iterate + 1;
		entry_no = save_free;
		go to ANY_ARGS_Q;
XP (8):						/* Iteration index (&x) */
		call outnum ((iterate));
		go to A;
XP (9):						/* Special unique (&U) */
		i = bct.unique_generator1;
		call ouch (".._");
		bct.unique_changed = "1"b;
		go to UNIQUE1;
XP (10):						/* Command arg (&A) */
		if val <= eb_data_$mexp_argno | val > eb_data_$alm_arg_count then code = error_table_$noarg;
		else do;
		     temp_ap = arguments(val + eb_data_$mexp_argno).arg_ptr;
		     temp_al = arguments(val + eb_data_$mexp_argno).arg_len;
		     call outptr (temp_ap, temp_al);
		  end;
		go to A;
XP (11):						/* Arg length (&l) */
		call outnum (args (val).len);
		go to A;
XP (12):						/* Number of args (&K) */
		call outnum ((nargs));
		go to A;
XP (13):						/* Number of iteration args (&k) */
		call outnum ((no_exargs));
		go to A;
XP (14):						/* Null expansion (&& or end of macro) */
		go to A;
XP (15):						/* Comparison ops */
XP (19):						/* Selector ops (&s)  */
		if outstanding_select then call experr ("Unused selection");
		outstanding_select = "1"b;
		selector_ob_charpos = next;		/* Save for evaluator. */
		selector_eno = entry_no;
		go to A;
XP (16):						/* Open conditional (&[) */
		if ^outstanding_select then do;
		     call experr ("Brackets with no previous selector operation");
		     select_answer = 1;
		end;
		else call pull_apart_select_input;
		do i = 1 by 1 while (i < select_answer);
		     if macro.entry (entry_no).value_1 <= 0 then i = select_answer;
		     else entry_no = macro.entry (entry_no).value_1;
		end;
		go to A;
XP (17):						/* End of conditional (&])  */
		go to A;
XP (18):						/* Select else (&;) */
		do entry_no = entry_no repeat (macro.entry (entry_no).value_1)
			while (macro.entry (entry_no).value_1 > 0);
		end;
		go to A;
XP (20):						/* Fargs-macro (&F)  */
		call output_fargs (args, nargs);
		go to A;
XP (21):						/* Fargs-iter (&f) */
		call output_fargs (exargs, no_exargs);
		go to A;
XP (22):						/* Iter over args. (&R) */
		if outstanding_range
		then call experr ("Unused range specifier");
		outstanding_range = "1"b;
		range_ob_charpos = next;
		go to A;
A:
	     end;

	     return;

/*  */
output_fargs:  proc (aaray, ct);

/* Used to output sequence of args, for &F and &f requests. val2 is 1 for FQ/fq */


dcl 1 aaray (0:99) aligned,
    2 start fixed bin (21),
    2 len fixed bin (21);

dcl  ct fixed bin;
dcl  qsw bit (1);
dcl  k fixed bin;

		qsw = (macro.entry (entry_no).value_2 = 1);
		do k = macro.entry (entry_no).value_1 to ct by 1;
		     if qsw then call ouch ("(");
		     call outptr (substaddr (il, aaray (k).start), (aaray (k).len));
		     if qsw then call ouch (")");
		     if k < ct then call ouch (",");
		end;
	     end output_fargs;

/*  */

pull_apart_select_input: proc;			/* Gets stuff out of output buffer to make selector clauses. */

/* Used to get whatever input is needed out of expansion (ob) for &[. Defines based/adjustable "ebuf"
   as portion of ob between where it was when selector appeared (selector_ob_charpos) and the &[. */

dcl  ep ptr, ebuf char (elen) based (ep), elen fixed bin (21);
dcl (s, t1, t2) fixed bin;
dcl  comx fixed bin;

		ep = substaddr (ob, selector_ob_charpos);
		elen = length (currob) - selector_ob_charpos + 1;

		if macro.entry (selector_eno).type = type_SELECT then
		     select_answer = collect_ob_num (1, elen);
		else do;
		     comx = index (ebuf, ",");
		     if comx = 0 then do;
			call experr ("No comma for conditional after expansion");
			select_answer = 0;
		     end;
		     else do;
			s = macro.entry (selector_eno).value_1; /* Type of comparison */
						/* Remember that EQ and NE are char, others num. */
			if s <= NE then do;		/* String compares, &=, &^= */
			     if substr (ebuf, 1, comx - 1) = substr (ebuf, comx + 1) then select_answer = 1;
			     else select_answer = 2;
			     if s = NE then select_answer = 3 - select_answer; /* NE inverts test */
			end;
			else do;			/* Numeric compares, EQ and NE dont get used. */
			     t1 = collect_ob_num (1, comx - 1);
			     t2 = collect_ob_num (comx + 1, elen);
			     if ((t1 = t2) & s = EQ) | ((t1 ^= t2) & s = NE) | ((t1 < t2) & s = LT)
			     | ((t1 <= t2) & s = LE) | ((t1 > t2) & s = GT) | ((t1 >= t2) & s = GE)
			     then select_answer = 1;	/* TRUE */
			     else select_answer = 2;	/* FALSE */
			end;
		     end;
		end;
		next = selector_ob_charpos;
		outstanding_select = "0"b;
		return;

get_ob_rangeargs:	entry (v1, v2);			/* collect m and n, as in &Rm,n into v1, v2 */

dcl (v1, v2) fixed bin;

		ep = substaddr (ob, range_ob_charpos);
		elen = length (currob) - range_ob_charpos + 1;
		comx = index (ebuf, ",");
		if comx = 0 then comx = elen + 1;
		v1 = collect_ob_num (1, comx - 1);
		v2 = collect_ob_num (comx + 1, elen);
		next = range_ob_charpos;
		outstanding_range = "0"b;
		return;

/*  */
collect_ob_num:	proc (fx, lx) returns (fixed bin);

/* This routine collects a decimal number at ebuf|fx until ebuf|lx, returning it. Note
   that cases of no digits, bad input, and large number of leading zeros are handled. */

dcl (i, fx, lx) fixed bin (21);
dcl  d fixed bin init (0), c char (1) aligned;

		     do i = fx to lx;
			c = substr (ebuf, i);
			if c < "0" | c > "9" then do;
			     call experr ("Bad numeric input to selector");
			     return (0);
			end;
			d = 10*d + fixed (unspec (c), 9) - 48;
		     end;
		     return (d);

		end collect_ob_num;

	     end pull_apart_select_input;

experr:	     proc options (variable, non_quick);	/* expansion error */

/* Called by all expansion-time errors with formline_ arguments.   Tries to figure out what
   _l_i_n_e of macro def contains the  error, as ALM lists the expanded lines way after we have
   the whole expansion out the door, and user needs some hint.  For this purpose
   only is macro.startchar maintained. */


dcl  apos fixed bin (21), alct fixed bin (18);
dcl  vs char (200) varying;
dcl  nlx fixed bin (21);
dcl  mdef char (macro.sourcelen + macro.startchar - 1) based (macro.sourcep);
dcl  zzzzz9 pic "zzzzz9";
dcl  errpos fixed bin (21);

		if ^found_d_error_lying_there		/* if this is news, .e., pass 1 */
		then eb_data_$erflgs_overlay.prntd = 1; /* then make an error */

		call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);

		errpos = macro.entry (entry_no).first_char + macro.entry (entry_no).n_chars;
		apos = macro.startchar;
		nlx = index (substr (mdef, apos), NL);
		do alct = 1 by 1 while (^(nlx = 0 | apos + nlx > errpos));
		     nlx = index (substr (mdef, apos), NL);
		     apos = apos + nlx;
		end;

		zzzzz9 = alct;
		vs = cb1b || " in line " || ltrim (zzzzz9) || " of macro " || rtrim (macro.name) || ".";
		call prnter_$macro_error ("Macro expansion error: " || vs,
		     "**** **** **** MACRO EXPANSION ERROR: " || vs);
		return;

	     end experr;

	end expand_macro;
						/*  */
mexp_$reset_macro: entry;

/* ALM calls this when the ALM input scanner, inputs_, runs off the end of something that was
   given to him by push_mexp_output_upon_alm below. */


	envp = eb_data_$mexp_env_ptr;
	call pop_mexp_level;
	return;


push_mexp_output_upon_alm: procedure;

/* Redefine free space in segment containing ob not to include ob. Stack  the description
   of what free space will be when this is popped (which is what it is now). Tell ALM
   to push the string "ob" upon its input stack. ALM will call mexp_$reset_macro
   when he (the input scanner, inputs_) runs off the end of it. */


	     if bct.curlevel >= hbound (bct.outstack, 1) then
		call genabort ("Macro depth exceeds ^d.", bct.curlevel);
	     if length (currob) <= 0 then return;	/* Don't output empty buffers */
	     if substr (currob, length (currob), 1) ^= NL then call ouch (NL);
						/* Make sure lines dont spill, listing happens. */
	     call alm_include_file_$macro (addr (currob), length (currob));
	     bct.curlevel = bct.curlevel + 1;
	     bct.outstack (bct.curlevel).segx = bct.curexpseg;
	     bct.outstack (bct.curlevel).charx = bct.segarray_free (bct.curexpseg);
	     bct.segarray_free (bct.curexpseg) = bct.segarray_free (bct.curexpseg) + length (currob);
	     return;

	end push_mexp_output_upon_alm;

pop_mexp_level: procedure;

/* Return current expansion's space to free space in its segment. If this brings us
   to bottom of segment other than the first, go back a segment, for free space now starts
   there. */


	     if bct.curlevel = 0 then
		call genabort ("Macro stack underflow. Contact assembler maintainers.");

	     bct.curexpseg = bct.outstack (bct.curlevel).segx;
	     bct.segarray_free (bct.curexpseg) = bct.outstack (bct.curlevel).charx;
	     bct.curlevel = bct.curlevel - 1;
	     if bct.curexpseg > 2 & bct.segarray_free (bct.curexpseg) = 1
	     then bct.curexpseg = bct.curexpseg - 1;
	     return;

	end pop_mexp_level;


/*  */


/* This procedure, with all its entries, generates all text in the
   output buffer, ob. It takes responsibility for moving it when it
   must be grown. */

outptr:	proc (aoutp, aoutl);			/* Output aoutp->char(aoutl) to ob */

dcl (aoutp, outp) ptr;
dcl  outstring char (outl) based (outp);
dcl  save_obp ptr, save_obl fixed bin (21);
dcl (aoutl, outl) fixed bin (21);
dcl  str char (*);
dcl  num fixed bin (21);
dcl  zzzzzzz9 picture "zzzzzzz9";
dcl  cbuf char (8);

	     outl = aoutl;
	     outp = aoutp;
	     go to outpr_join;

ouch:	     entry (str);				/* Output value of "str" to ob */

	     outl = length (str);
	     outp = addr (str);
	     go to outpr_join;

outnum:	     entry (num);				/* Output canonical number to ob */

	     zzzzzzz9 = num;
	     outl = length (ltrim (zzzzzzz9));
	     cbuf = ltrim (zzzzzzz9);
	     outp = addr (cbuf);


outpr_join:
	     if length (outstring) = 0 then return;

	     if length (currob) + length (outstring) > length (ob) then do;
		save_obp = addr (currob);
		save_obl = length (currob);
		call make_new_outbuf$force;
		next = save_obl + 1;
		currob = save_obp -> currob;
	     end;

	     substr (ob, next, length (outstring)) = outstring;
	     next = next + length (outstring);

	     return;

	end outptr;

/* 
*/
substaddr: proc (chs, ix) returns (ptr);
dcl  chxa (length (chs)) char (1) unal based;		/* for char addressing */
dcl  chs char (*), ix fixed bin (21);
	     return (addr (addr (chs) -> chxa (ix)));
	end substaddr;

make_new_outbuf: proc;

/* This procedure  defines the based/adjustable output buffer "ob" as the remainder of the
   current output buffer segment. If $force is called, it is because a string that
   outptr/ouch/outnum wants to put in ob won't fit. So ob is redefined to the next
   buffer segment, and the old ob copied. The vbl "next" is the next available char pos
   in current ob. */


dcl  segx fixed bin;
dcl  force bit (1);

	     force = "0"b;
	     go to mnob_join;

make_new_outbuf$force: entry;

	     force = "1"b;
mnob_join:

	     segx = bct.curexpseg;
	     if force then segx, bct.curexpseg = segx + 1;
	     if bct.segarray (segx) = null then do;
		call get_temp_segments_ (gtsname, segarray_of_one, (0));
		bct.segarray (segx) = segarray_of_one (1);
	     end;
	     obp = substaddr (bct.segarray (segx) -> ob, bct.segarray_free (segx));
	     max_char_count = sys_info$max_seg_size * 4 - bct.segarray_free (segx) + 1;
	     next = 1;

	end make_new_outbuf;
						/*  */

scan_args: proc (array, no_args, firstx, count, acode);

/* This routine scans the "count" chars at il|firstx according to the rules of
   macro arguments. Processing of nested parens, line breaks and continuations, and
   commas is all done here. */


dcl 1 array (0: 99) aligned,
    2 first fixed bin (21),
    2 size fixed bin (21);

dcl  acode fixed bin (35);

dcl  c2 char (2) aligned;

dcl  no_args fixed bin,
    (firstx, count, arg_start, last) fixed bin (21);

	     array (*).size = 0;
	     acode = 0;
	     arg_start, ci = firstx;
	     last = ci + count - 1;
	     no_args = 0;
GET_ANOTHER_ARG:
	     c2 = substr (il, ci-1, 2);
	     if c2 = COMMA_NL | c2 = ", " | c2 = ",	" | c2 = ",""" | c2 = ",;" then do;
						/* Continue on next ALM statement. */
		if addr (array) ^= addr (exargs) then	/* At top level */
		     call skip_to_next_line;
		else do;
		     stop = stop - 1;
		     start = ci + 1;
		end;
		if stop > nchars then return;
		semict = semict + 1;		/* schedule almrunning */
		if stop > nchars then return;
		t = verify (substr (il, start, stop-start+1), WHITE)-1; /* skip white space */
		if t < 0 then ci = stop+1;
		else ci = start + t;
		arg_start = ci;			/* save start of variable field */
		call soc;				/* skip to end of variable field */
		if stop = ci-1 then last = ci-2;
		else last = ci-1;
		ci = arg_start;
		goto GET_ANOTHER_ARG;
	     end;

	     else if substr (il, ci, 1) = "(" then do;	/* watch out for args with parens */
		nparens = 1;			/* skip till no more parens at this level */
		do ci = ci+1 to last while (nparens > 0);
		     if substr (il, ci, 1) = "(" then nparens = nparens + 1;
		     else if substr (il, ci, 1) = ")" then nparens = nparens - 1;
		end;
		if nparens > 0 then do;
		     acode = 1;
		     return;
		end;

		no_args = no_args + 1;
		array.first (no_args) = arg_start+1;	/* copy information about where the arg is */
		array.size (no_args) = ci - arg_start - 2;
		goto NEXT_ARG;
	     end;

	     else do;				/* argument didn' start with paren */
		t = index (substr (il, ci, last-ci+1), ",")-1;
		if t < 0 then ci = last + 1;
		else ci = ci + t;

		no_args = no_args + 1;
		array.first (no_args) = arg_start;
		array.size (no_args) = ci - arg_start;
NEXT_ARG:		ci, arg_start = ci+1;
		if arg_start <= last+1 then goto GET_ANOTHER_ARG;
	     end;
	     return;


	end scan_args;
						/*  */


skip_to_next_line: proc;

/* This procedure sets "stop" to be the charindex of the last char of the
   (possibly multi-ALM-statement) macro or pseudoop invocation.  The
   only legal ALM-statement breaks are those in parens. The vbl "semict" is incremented
   to tell larger routines how many times to call inputs_$run/next_statement to
   skip ALM's input scanner (inputs_) over that many ALM statements. Note:
   If _w_e don't know that some semicolon-containing thing is actually an ACC string
   etc., ALM doesn't know _e_i_t_h_e_r, annd considers it a statement break, 'cause
   he's skipping statements, not semanticating them. */


	     start = stop+1;			/* get start of next line */
dcl  nparens fixed bin;

	     nparens = 0;
	     stop = start;
more:	     t = search (substr (il, stop), ENDS)-1;
	     if t < 0 then do;
		stop = nchars + 1;
		return;
	     end;
	     stop = stop + t;
	     if substr (il, stop, 1) = "(" then nparens = nparens + 1;
	     else if substr (il, stop, 1) = ")" then nparens = nparens - 1;
	     else if substr (il, stop, 1) = ";" & nparens > 0 then semict = semict + 1;
	     else if substr (il, stop, 1) = NL & nparens > 0 then semict = semict + 1;
						/* Ignore statement breaks inside parens */
	     else return;
	     stop = stop + 1;
	     go to more;

	end;

get_hashx: procedure (name);				/* Generate hash index */

dcl  name char (32) aligned;
dcl  fb35 fixed bin (35), (mod, abs) builtin;

	     unspec (fb35) = bool (substr (unspec (name), 1, 36), bool (substr (unspec (name), 37, 36),
		bool (substr (unspec (name), 73, 36), substr (unspec (name), 109, 36), "0110"b), "0110"b), "0110"b);

	     hashx = abs (mod (fb35, 127));
	     if ^substr (bct.hashx_used, hashx + 1, 1) then do;
		substr (bct.hashx_used, hashx + 1, 1) = "1"b;
		bct.macroptr (hashx) = null;
	     end;
	     return;

	end;
						/*  */
sob:	proc;

/* This procedure moves ci to first non-white character. */


	     t = verify (substr (il, ci, stop-ci+1), WHITE)-1;
	     ci = ci + t;
	     return;

	end;
soc:	proc;

/* This procedure moves ci over non-white characters to next whitespace. */


dcl  nparens fixed bin;

	     nparens = 0;
more:	     t = search (substr (il, ci, stop-ci+1), "()	 """)-1;
	     if t < 0 then do;
		ci = stop+1;
		return;
	     end;
	     ci = ci + t;
	     c = substr (il, ci, 1);
	     if c = "(" then nparens = nparens + 1;
	     else if c = ")" then nparens = nparens - 1;
	     else if nparens = 0 then return;
	     ci = ci + 1;
	     goto more;

	end;



get_ptrs:	proc;					/* Set mexp ptrs from ALM */

/* This procedure sets our variables from ALM's input scanner, inputs_. Inputs_
   usually scans up to and beyond a break. We set variables to first char he hasn't
   scanned. "alm_finished_the_line" is inputs_'s "ibrk = inl" state, in which
   he has scanned the last semi/nl on a statement, but inputs_$next_statement
   hasn't been called yet. */


dcl (offset, sourcelen) fixed bin (21);

	     call inputs_$get_ptr (tp, offset, sourcelen, alm_finished_the_line);

	     nchars = offset + sourcelen;
	     stop = offset;
	     ci, start = stop + 1;
	     return;
	end get_ptrs;

/*  */

genabort:	proc options (variable, non_quick);

	     call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, cbuf1, cb1l, "0"b, "0"b);
	     call prnter_$general_abort (cb1b);
	end genabort;
						/*  */
%include erflgs;
     end mexp_$ignore;




		    modevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.8       42021



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


 modevl_: 
     procedure ( dummy /* normally BRK */ ) returns ( fixed bin(17) );
/*
	Last modified on 07/06/72 at 22:26:10 by R F Mabee.
		by RFM on 6 July 1972 to add itp modifier.
		by RHG on 17 Sept 1970 to fix bug in octal modifiers
		by RHG on 28 August 1970 at 0916 to allow octal modifiers
		by Nate Adleman on June 28, 1970 at 2037 for the new CODTAB
*/
		/* MODEVL:   evaluate address modifier, if any. */

		/* Possible modifier types are: (r), *(r), (r)*, and (it).
		   all modifiers are tested, but note that the index
		   pseudo - operation is not yet coded. However, all 645
		   modifiers are included. */

/* INCLUDE FILES USED BY MODEVL */


% include codtab;
% include concom;
% include erflgs;
% include varcom;


/* EXTERNAL ENTRIES USED BY MODEVL */

declare	getid_$getid_ ext entry,
	inputs_$next ext entry ;

/* EXTERNAL FUNCTIONS USED BY MODEVL */

declare	table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin, fixed bin (26), fixed bin) returns (fixed bin (26)),
	utils_$and ext entry (fixed bin, fixed bin) returns (fixed bin) ;


/* EXTERNAL DATA USED BY MODEVL */

declare ( eb_data_$itlist_ (0:20), eb_data_$rlist(0:15) ) external fixed bin(17);

/* AUTOMATIC DATA USED BY MODEVL */

declare ( i, ixr, junk, modevl_answer, dummy ) fixed bin (17) ;

/*  */
/*  -   -   -   -   -   -   -   -   -  PROGRAM STARTS HERE  -   -   -   -   -   -   -   -   -   -   -   -   -  */

/* get first identifier and break and check for star. */
label_100: 
	call getid_$getid_;
	modevl_answer = 0;
	if (brk(1) = istar) then go to label_200;
	if (sym(1) = 0) then go to label_300;
	go to label_400;


/* star encountered, check for *(r) or (r)* modifier. */
label_200: 
	if (sym(1) = 0) then go to label_210;
	modevl_answer = 16;
	call inputs_$next;
	go to label_230;
label_210: 

	call getid_$getid_;
	if (brk(1) ^= inum) then go to label_215;
	modevl_answer = brk(2) + 8;	/* actually brk(2)-"0"+56 */
	if modevl_answer >= 64 then goto non_octal;	/* make sure digit was octal */
	go to get_next;
label_215: 
	if (sym(1) ^= 0) then go to label_220;
	modevl_answer = 16;
	go to modevl_return;
label_220: 

	modevl_answer = 48;


/* register involved, search rlist for it. */
label_230: 

label_240: 
	do i = 0 to 15;
	     if (sym(1)  ^=  eb_data_$rlist(i)) then go to label_250;
	     modevl_answer = modevl_answer + i;
	     go to modevl_return;
label_250:     
	end label_240;



/* not in rlist, search table for index assignment. */
label_260: 
	if (table_$table_(iserch,sym(1),ixr,clint,junk) = 0) then go to label_280;
	modevl_answer = modevl_answer + ixr + 8;
	go to modevl_return;

/* we get here when we were expecting an octal digit but got 8 or 9 */

non_octal:	prnt7 = 1;

/* undefined modifier, set flag and exit with null register. */
label_280: 
	prntt = 1;				/* TRUE */
	go to label_310;


/* no *, no sym, check for digit. */
label_300: 
	if (brk(1) ^= inum) then go to label_310;
	modevl_answer = brk(2) - 40;	/* actually brk(2)-"0"+8 */
	if modevl_answer >= 16 then goto non_octal;	/* check digit was actually octal */
	call inputs_$next;
	if brk(1) = inum then	/*check for another digit*/
		do;
		if brk(2) >= 56 then goto non_octal;	/*check digit was actually octal*/
		modevl_answer = 8*modevl_answer+brk(2)-112;
		goto get_next;
		end;
	if (brk(1) ^= istar) then go to modevl_return;
	modevl_answer = modevl_answer + 16;
	go to get_next;


/* null modifier, zero and exit. */
label_310: 
	modevl_answer = 0;
	go to modevl_return;


/* no star, check in it list first. */
label_400: 

	do i = 1 to eb_data_$itlist_ (0) by 2;		/* Length in first word; name, value in word pairs after. */
	     if (sym(1)  ^=  eb_data_$itlist_ (i)) then go to label_410;
	     modevl_answer = eb_data_$itlist_ (i + 1);
	     go to modevl_return;
label_410:     
	end label_400;

/* not in itlist, go check rlist. */
	modevl_answer = 0;
	go to label_240;

get_next:	call inputs_$next;

modevl_return: 

	return( modevl_answer );



     end modevl_ ;




		    new_sthedr_.alm                 10/17/88  1013.9rew 10/17/88  0929.5       34083



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

" HISTORY COMMENTS:
"  1) change(86-09-30,Oke), approve(86-09-30,MCR7543), audit(86-09-30,JRGray),
"     install(86-10-08,MR12.0-1180):
"     Allow ALM to support double word constants.
"  2) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
"     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
"     Modified to allow for access and modification of translator (generator)
"     info.
"  3) change(88-08-02,JRGray), approve(88-08-05,MCR7952),
"     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
"     Modified to make source_and_area info externally accessable. This is
"     part of extended symbol table support.
"                                                      END HISTORY COMMENTS


" New object segment format symbol table header skeleton for ALM.
" The version numbers must be updated any time that any part of ALM is changed.
" Note: The version numbers in here are now overwritten by alm_

" Created on 03/16/72 at 00:35:06 by R F Mabee.
" Modified 740905 by PG and ARD for installation of Version 4.5 (Version 2 PL/I).
" Modified March 1, 1977 by Noel I. Morris for installation of Version 5.1
" Modified March 24, 1977 by Noel I. Morris for installation of Version 6.0
" Modified 8 August 1980 by M. N. Davidoff for Version 6.3
" Modified 29 April 1981 by EBush for Version 6.4
" Modified November 1982 by C. Hornig for version 6.6
" Modified September 18 1985 by JRGray to support the setting of translator names

	name	new_sthedr_

	use	impure
	join	/link/impure

	segdef	new_sthedr_
	segdef	alm_creation_date,time_of_translation
	segdef	alm_version_name,user_id,comment
	segdef	text_and_link_boundaries
	segdef	source_and_area
	segdef	truncate_info
	segdef	block_size
	segdef	rel_bits_ptrs
	segdef	gen_number,generator

new_sthedr_:
sthead:	dec	1		" decl_vers
	aci	"symbtree"	" identifier
gen_number:
	dec	4		" gen_version_number
alm_creation_date:
	dec	0,0		" gen_creation_time
time_of_translation:
	dec	0,0		" object_creation_time
generator:
	aci	"alm     "	" generator
	zero	alm_version_name-sthead,32	" gen_version_name
	zero	user_id-sthead,32	" userid
	zero	comment-sthead,64	" comment
text_and_link_boundaries:
	zero	0,0		" text_boundary, link_boundary
source_and_area:
	zero	source_map-sthead,0	" source_map, area_pointer
block_size:
	zero	0,-		" sectionbase_backpointer, block_size
rel_bits_ptrs:
	zero	0,-		" next_block_thread, rel_text
	zero	0,0		" rel_def, rel_link
truncate_info:
	zero	0,0		" rel_symbol, default_truncate
	zero	-,0		" optional_truncate, padding

" End of the fixed format part of the symbol table header.
" The rest of this information is pointed to from above.

alm_version_name:	aci	"ALM Version  6.7  October 1986",32

user_id:		aci	" ",32

comment:		aci	" ",64

		even
source_map:	null			" Compound structure is built here.

" End of the symbol table header skeleton.
" The next object is used by alm to find out how long the header is.

	use	pure
	join	/text/pure

	segdef	hdrlen
hdrlen:	zero	0,source_map-sthead

" Relocation information for the symbol table header.
" Everything is absolute in the header;" postp2_ assumes it.

	segdef	relocinfo
relocinfo:
	bss	,source_map-sthead

	end




		    object_.alm                     10/17/88  1013.9rew 10/17/88  0938.3       86256



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

" HISTORY COMMENTS:
"  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
"     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
"     Modified to allow for joining information to the definition section.
"                                                      END HISTORY COMMENTS


name                          object_
"Original programmer:         Nate Adleman???
"Language:                    alm
"Translated by                Richard H. Gumpertz
"Last modified on 11/12/72    by R. F. Mabee
"                             11 Nov 1972 by R. F. Mabee to fix short return
"                             26 Sept 1970 by RHG to add name pseudo-op
"                             17 Sept 1970 at 0115 by RHG for new listing package
"                             11 August 1970 at 0543 by RHG--total rewrite for new scratch segment layout
"
%include segnfo
"
"The text data words are written directly into the object segment.
"The remaining data and relocation information is written into the scratch segment.

"The scratch segment is accessed by the use of two pl1 type overlays.
"Note that text_overlay fits into the padding of link_and_sym_overlay.



"First the overlay used in writing the text relocation bits:
"          dcl 1 text_overlay based ( addrel (eb_data_$segnfo.scrtch, 2*pc) ),
"              2 pad bit (9),
"              2 text_left_reloc bit (9),
"              2 pad bit (9),
"              2 text_right,reloc bit (9);

"Now the overlay used in writing the link and symbol data words and relocation bits:
"          dcl 1 link_and_sym_overlay based( addrel (eb_data_$segnofo.scrtch, 8*pc) ),
"              2 link_left_reloc bit(9),
"              2 pad bit(9),
"              2 link_right_reloc bit(9),
"              2 pad bit(9),
"              2 link_data_word bit(36),
"              2 sym_left_reloc bit(9),
"              2 pad bit (9),
"              2 sym_right_reloc bit(9)
"              2 pad bit(9)
"              2 sym_data_word bit(36),
"              2 def_left_reloc bit(9),
"              2 pad bit (9),
"              2 def_right_reloc bit(9),
"              2 pad bit(9),
"              2 def_data_word bit(36);
"
"The following entries write the object words into various segments.
"Calls are of the format:
"         call obj___(pc,word)
"         where word is the word to be written.




"The following entry writes the text object words:
          entry      object_
object_:
          lda        ap|2,*     get the program counter
          ldq        segnfo+text,*al     look at the current object word
          tnz        <prnter_>|[phsmsg]  if non-zero, we probably have a phase error in the object segment
          ldq        ap|4,*     get word to be written
          stq        segnfo+text,*al   write it
exit:
          short_return




"The following entry writes the link object words:
          entry     objlk
objlk:
          lda       ap|2,*     get the pc
          als       3          multiply it by 8
objwri:   eppbp     segnfo+scrtch,*al    do the addrel in the structure link_and_sym_overlay
          ldq       bp|1       look at current object word
          tnz       <prnter_>|[phsmsg]   if non-zero, we probably have a phase error
          ldq       ap|4,*     get the word to be written
          stq       bp|1       write it
          tra       exit-*,ic and return




"The following entry writes the symbol table object words:
          entry     objst
objst:
          lda       ap|2,*  get the pc
          als       3         multiply by 8
          ada       =2,dl     add offset to indicate symbol data word
          tra       objwri-*,ic         and join objik to write

"The following entry writes the definition object words:
          entry     objdf
objdf:
          lda       ap|2,*  get the pc
          als       3         multiply by 8
          ada       =4,dl     add offset to indicate definition data word
          tra       objwri-*,ic         and join objik to write
"
"The following entries read a word from the linkage or symbol table object segments.
"Calls are of the format:
"           call geto__(pc,word)
"           where word is the variable in which the value is to be returned.




"The following entry reads a word from the linkage object segment
          entry     getolk
getolk:
          lda       ap|2,*   get the pc
          als       3        multiply it by 8
objrea:   eppbp     segnfo+scrtch,*al   do the addrel in the structure link_and_sym_overlay
          ldq       bp|1     get the object word
          stq       ap|4,*   return it into the second argument
          tra       exit-*,ic and return




"The following entry reads a word from the symbol table object segment:
          entry     getost
getost:
          lda       ap|2,*      get the pc
          als       3           multiply it by 8
          ada       =2,dl       add offset to indicate symbol data word
          tra       objrea-*,ic            continue as above

"The following entry reads a word from the definition object segment:
          entry     getodf
getodf:
          lda       ap|2,*      get the pc
          als       3           multiply it by 8
          ada       =4,dl       add offset to indicate definition data word
          tra       objrea-*,ic            continue as above
"
"The following entries write the relocation bits to the text, linkage, or symbol relocation words
"Calls are of the format:
"         call wrb_(pc,relwrd)
"         where relwrd contains lbits in its left half and rbits in its right half.




"The following entry writes the text relocation information.
          entry     wrbtx
wrbtx:
          lda       ap|2,*    get the pc
          als       1         multiply it by 2
          eppbp     segnfo+scrtch,*al   do the addrel in the structure text_overlay
          ldq       ap|4,*    get the word to be written
          stbq      bp|0,ic*  actually 24 modifier -- store the bits in the two subfields
          tra       exit-*,ic and return




"The following entry writes the linkage relocation information.
          entry     wrblk
wrblk:
          lda       ap|2,*    get the pc
          als       3	multiply by 8
relwri:   eppbp     segnfo+scrtch,*al   do the addrel in the structure link_and_sym_overlay
          ldq       ap|4,*    get the word to be written
          qls       9         position it
          stbq      bp|0,ci   actually 50 modifier -- store the bits in the two subfields
          tra       exit-*,ic and return




"The following entry writes the symbol relocation information.
          entry     wrbst
wrbst:
          lda       ap|2,*     get the pc
          als       3	multiply by 8
          ada       =2,dl      add offset to indicate symbol bits
          tra       relwri-*,ic          join wrblk to write

"The following entry writes the definition relocation information.
          entry     wrbdf
wrbdf:
          lda       ap|2,*     get the pc
          als       3	multiply by 8
          ada       =4,dl      add offset to indicate definition bits
          tra       relwri-*,ic          join wrblk to write
"
"The following entries read the relocation bits for the text, linkage, or symbol table.
"Calls are of the format:
"         call getb__(pc,lbits,rbits)




"The following entry gets the text relocation bits:
          entry     getbtx
getbtx:
          lda       ap|2,*    get the pc
          als       1         multiply by 2
          lda       segnfo+scrtch,*al get the word we want
          lrl       18        position the bit fields
relrea1:  qrl       18        "                 "
          anaq      mask      mask out the unwanted bits
          sta       ap|4,*    return left_bits
          stq       ap|6,*    return right_bits
          tra       exit-*,ic and return




"The following entry gets the link relocation bits:
          entry     gtblk
gtblk:
          lda       ap|2,*    get the pc
          als       3         multiply it by 8
relrea2:  lda       segnfo+scrtch,*al   get the word we want
          lrl       27        position the bit fields
          tra       relrea1-*,ic       and join getbtx to get the bits





"The following entry gets the symbol relocation bits.
          entry     getbst
getbst:
          lda       ap|2,*     get the pc
          als       3	multiply by 8
          ada       =2,dl      add offset to indicate symbol bits
          tra       relrea2-*,ic         and join gtblk to get the bits


"The following entry gets the definition relocation bits.
          entry     getbdf
getbdf:
          lda       ap|2,*     get the pc
          als       3	multiply by 8
          ada       =4,dl      add offset to indicate definition bits
          tra       relrea2-*,ic         and join gtblk to get the bits



          even                force us to an even boundary for the anaq
mask:     oct       777,777   this is the mask for recovering the relocation bits
"
	end




		    octevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.7       30096



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



/****^  HISTORY COMMENTS:
  1) change(86-09-03,Oke), approve(86-09-03,MCR7543), audit(86-09-30,JRGray),
     install(86-10-08,MR12.0-1180):
     Extend octal input
     processing to permit 1 or 2 word values.  Double precision is selected
     if an "L" suffix is supplied.  Previously >12 digits wasg an F error,
     now an "F" error is >12 digits if single, >24 digits if double.  Permits
     double-word octal literals and constants to be generated.
                                                   END HISTORY COMMENTS */

octevl_:
	procedure( rslts ) returns ( fixed bin(17) );

/* OCTEVL:     evaluates octal literal field and returns results and brk. */
/* octevl returns one word if no "L" suffix, two words if "L" suffix  */
/* supplied.  Modifier done by litevl. */
/*  note that according to bsa conventions, no negative sign is */
/*  allowed in octal fields, and fields may be separated by */
/*  commas followed by blanks. */

	/* Last modified by Nate Adleman on June 28, 1970 at 2104 for the new CODTAB */

/* INCLUDE FILES USED BY OCTEVL */

% include varcom;
% include erflgs;
% include codtab;

/* AUTOMATIC DATA USED BY OCTEVL */

declare double bit (1);
declare nochrs fixed bin(17) ;
dcl rslts(2) fixed bin (35);
dcl num bit (72) aligned;
dcl num_array (2) fixed bin (35) unaligned based (addr (num));
/* EXTERNAL ENTRIES CALLED BY OCTEVL */

declare	inputs_$next ext entry,
	inputs_$nxtnb ext entry ;


/* EXTERNAL FUNCTIONS USED BY OCTEVL */

declare	utils_$and ext entry (fixed bin(26), fixed bin(26)) returns (fixed bin(26)) ;
 
 
/**/
/* - - - - - - - - - PROGRAM STARTS HERE - - - - - - - - */

	/* setup num and get next character */

label_100:
	double = ""b;
	num = "0"b;
	nochrs = 0;
	call inputs_$nxtnb;

/*   conversion loop. */

label_110:
	if (brk(1) ^= inum) then go to label_150;

/*   check to see that only octal digits are in the expression */
/* by  seeing if the digit is greater than 7 */
/* 55 is 067 octal which is the ascii character 7 */

	if  brk(2) > 55 then  prnt7 = 1;	/*TRUE*/

/* now check to see that there are  no more than 12 characters */
/* in the expression */

	nochrs = nochrs + 1;
	if  nochrs > 24  then prntf = 1;	/*TRUE*/
	num = substr (num, 4, 69) || bit (fixed (brk(2)-48, 3));
	call inputs_$next;
	go to label_110;

/*   set results and return to caller. */

label_150:
	if byte(brk(2)) = "L" then do;
	     double = "1"b;
	     call inputs_$next;
	end;
	if ^double then do;
	     if nochrs > 12 then prntf = 1;	/*TRUE*/
	     rslts(1) = num_array (2);
	     return(1);
	end;

/* return two words. */

	rslts(1) = num_array (1);
	rslts(2) = num_array (2);
	return (2);
	end octevl_ ;




		    oplook_.alm                     10/17/88  1013.9r w 10/17/88  0938.1       60984



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

"	name	oplook_		Look up op in table and return 645 machine code.

"                   Modified  on 09/30/80 by E Bush to implement decors.
"                   Modified  on 06/15/75 by Eugene E Wiatrowski
"		Modified on 08/08/73 at 22:20:48 by R F Mabee.
"		Modified in June 1973 by R F Mabee to add EIS and related instructions.
"		Modified on 12 November 1972 by R F Mabee to fix short return for followon.
"		Modified on 08/17/72 at 23:00:38 by R F Mabee. Added 6180 opcodes.
"		Modified 12 November 1970, R H Campbell, for lam, fstr.

"		The table is maintained alphabetically in two tables.
"		The first table contains double word entries
"		of the ASCII opcode, left justified.
"		The second table contains the binary equivalence,
"		either as an opcode or a pseudo-op number.
"		The search procedure is a
"		binary search with termination on the end of the list.


	equ	sym,4

	entry	oplook_		Entry to find opcode.
	entry	reset		Entry to reset at start of each pass.
	entry	redefine		Entry to redefine op as macro.



	use	executable

oplook_:
	stz	ap|2,*		Clear all returned values.
	stz	ap|4,*
	stz	ap|6,*

	tsx7	lookop		Look up opcode
	tra	opnfnd		Error return.
	ldx1	valtbl,au		Get the type field.
	sxl1	ap|4,*		Deposit it.
	lxl1	valtbl,au		Get the opcode.
	sxl1	ap|6,*		Deposit it.
exit:	short_return		Do a short return because we did no save on entry.

opnfnd:	null			Op-code not found.
	aos	ap|2,*		Set bad op flag.
	tra	exit		Then return to caller.


lookop:	eppbp	eb_data_$varcom+sym	bp -> symbol for comparison
	lda	bp|0		First word of symbol in A.
	arl	36-9		Get count field in AL.
	cmpa	8,dl		More than 7 characters?
	tpl	look_long		If so, special lookup.

	ldaq	bp|0		Symbol to match must be on an even word.
	lls	9		Shift out the character count.
	eax0	0		xr0 used as ptr into optable.
	eax1	cycles		xr1 used as ptr into table of xr mods.
stepup:	adx0	powers,1		Go higher.
	cmpx0	num_ops*2,du	Check for too high.
	tmi	loop		If OK try it, otherwise backup.
backup:	sbx0	powers,1		Go lower.
loop:	eax1	-1,1		Decrement loop counter.
	tmi	0,7		Op not found.
	cmpaq	optbl,0		Look for first word of op.
	tmi	backup		ASCII symbol < table -- go lower.
	tnz	stepup		ASCII symbol > table entry, go higher.
"				We have the right entry -- get the info on it.
	eaa	0,0		Move the pointer to a.
	ars	1		Divide it by two, valtbl entries are one word long.
opfnd:	sztl	(),(pr,au),bool(05)	Test for redefinition.
	descb	*,0
	descb	lp|undefined_op_list,1
	tnz	0,7		If redefined, say it's not found.
	tra	1,7		Take successful return.

look_long:
	eax0	n_long_ops*6-6	Initialize table pointer.
long_loop:
	eppbb	long_op_table,0	bb -> table entry
	lda	bb|0		Get table entry in AU.
	cmpc	(pr),(pr)		compare with symbol
	desc9a	bp|0,20
	desc9a	bb|1,20
	tze	opfnd		Got'cha.

	eax0	-6,0		Step to next entry.
	tpl	long_loop		If more, loop.
	tra	0,7		If not, op not found.

"	Table of numbers to increase and decrease index by powers of two.

powers:	zero	0,0		End of the line, not there.
	zero	2,0
	zero	4,0
	zero	8,0
	zero	16,0
	zero	32,0
	zero	64,0
	zero	128,0
	zero	256,0
	zero	512,0
	zero	1024,0
	equ	cycles,*-powers-1	Maximum number of comparisons.



reset:	eax0	num_ops		Number of operations in X0.
	csl	(),(pr,rl),bool(00)	Reset undefined op list.
	descb	*,0
	descb	lp|undefined_op_list,x0

	short_return


redefine:	tsx7	lookop		Find opcode.
	tra	exit		If not found, just return.

	csl	(),(pr,au),bool(17)	Turn on undefined bit.
	descb	*,0
	descb	lp|undefined_op_list,1

	short_return


"	Operations table follows.

	segdef	opcode_table
opcode_table:			" This definition is provided so other tools
				" can use the assembler's data base.
	zero	0,num_ops*2
	zero	optbl-opcode_table,valtbl-opcode_table


	use	op_mnemonic
	even			Make sure we are even for the cmpaq.
	equ	optbl,*-2		Minus 2 because we can't access the first entry.

	use	op_value
	equ	valtbl,*-1	Corresponding offset for valtbl.

	use	long_ops
	equ	long_op_table,*
	set	n_long_ops,0


" Format of entry:
" In op_mnemonic, double word containing first 7 characters
" of mnemonic, left justified and zero filled.
" In op_value, single word containing 18 bit pseudo-op
" index (zero for normal instruction), 10 bit opcode written
" as 9 + 1 (as in 6140 EPS-1), 4 bits of flags, and 4 bits
" of decor class. For "desc" instructions, last 4 bits of 10
" bit opcode field denote operand formats.

" The decor class denotes the intersection of decors in which  the
" instruction is valid.
       



" OPCODE DEFINING MACROS.


	maclist	off

	macro	mnem
	use	op_mnemonic
	maclist	on,save
	aci	"&1"
	maclist	object
&<=&l1,4&[	acc	""
&]
&>&l1,8&[	warn	(Mnemonic "&1" is longer than 8 characters.)
&]
	maclist	restore
	&end

	macro	defop		mnemonic,type,args
	mnem	&1
	&2op	&F3
	&end

	macro	defmac		macname,args
	maclist	on,save
	macro	&1op
	use	op_value
	maclist	on,save
	vfd	18/&2,o9/&3,1/&4,o4/&5,o4/&6

	maclist	restore
	&&end

	maclist	restore
	&end

          defmac    ,0,&1,&2,&3,&4      code,bit27,flags,decor_class
          defmac    pseud,&1,0,0,0,&2   value,decor_class
	defmac	rpt,52,&1,0,&2,&3	,abcbits,decor_class
	defmac	ar,53,&1,1,&2,&3	opcode,flags,decor_class
	defmac	pr,44,0,0,0,&1      decor_class
	defmac	xr,43,0,0,0,&1      decor_class
	defmac	eis,54,&1,1,&2,&3	opcode,bitop,decor_class

	macro	longop
	pseudop	&1,&3
	set	op_index,*-valtbl-1
	use	long_ops
	maclist	on,save
	zero	op_index
	acc	"&2"
	maclist	object
&<=&l2,11&[	acc	""
&]
&<=&l2,15&[	acc	""
&]
&>&l2,19&[	warn	(Long mnemonic "&2" is longer than 19 characters.)
&]
	maclist 	on

	maclist	restore
	set	n_long_ops,n_long_ops+1
	&end

	macro	descop		bytesize,type,decor_class
	use	op_value
	maclist	on,save
	ife	&2,a
	vfd	18/55,o6/0,o4/0,4/&1,o4/&3
	ifend
	ife	&2,b
	vfd	18/56,o6/0,o4/0,4/1,o4/&3
	ifend
	ife	&2,fl
	vfd	18/57,o6/0,o4/0,4/&1,o4/&3
	ifend
	ife	&2,ls
	vfd	18/57,o6/0,o4/1,4/&1,o4/&3
	ifend
	ife	&2,ts
	vfd	18/57,o6/0,o4/2,4/&1,o4/&3
	ifend
	ife	&2,ns
	vfd	18/57,o6/0,o4/3,4/&1,o4/&3
	ifend

	maclist	restore
	&end






	include  defops





	use	op_mnemonic
	equ	num_ops,(*-optbl)/2


	use	static
	join	/link/static

undefined_op_list:
	bss	,(num_ops+35)/36	bit table of redefined ops


	end




		    pakbit_.pl1                     10/17/88  1013.9rew 10/17/88  0938.9       63306



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to allow blocks to be joined to the definition section.
                                                   END HISTORY COMMENTS */


pakbit_:	procedure ;

/*        Modified for separate static on 06/15/75 by Eugene E Wiatrowski    */
/*	Modified on 03/21/72 at 09:45:38 by R F Mabee.
	by RFM on 21 March 1972 for relocation bits structure version (part of new object format).
	by RHG on 8 August 1970 to suppress listing of relocation bits
*/
  
	/* This procedure collects and packs the words of relocation bits
	   and then outputs them to the assembler's scratch segment */

% include concom ;
%	include	alm_options;
% include objnfo ;
%include segnfo;

dcl (buff, j, nl, n, nr, i, ik, rpc, bits, itemp) fixed bin (26) ; 
dcl (lbits, rbits) fixed bin (26); 

dcl eb_data_$stat_len ext fixed bin(26);
dcl eb_data_$separate_static ext bit(1) aligned;

dcl pakrtn label local;

dcl
	object_$objst ext entry (fixed bin (26), fixed bin (26)),
	object_$getbtx ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
	object_$gtblk ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
	object_$getbdf ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
	object_$getbst ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) );

dcl	iword fixed bin(26),
	01 word aligned based(addr(iword)),
		02 (left, right) fixed bin(18) unsigned unaligned;

dcl	tx_word(0:262143) fixed bin(26) aligned based(eb_data_$segnfo.text);

dcl	01 lk_sym_def_overlay (0:32767) based(eb_data_$segnfo.scrtch),
	  02 (lk_rel, lk_word, st_rel, st_word, df_rel, df_word, pad1, pad2) fixed bin(26) aligned;

dcl (utils_$or, utils_$ls, utils_$rs) external entry ( fixed bin (26), fixed bin (26) ) returns ( fixed bin (26) );

 declare	reloc_vers internal static fixed bin (26) initial (1);

	/* output text count */
	rpc = istpc ;
	if tnewobject ^= 0 then do;
		call object_$objst (rpc, reloc_vers);
		rpc = rpc + 1;
		end;

	call object_$objst( rpc, itxcnt ) ;

	rpc = rpc + 1 ;

	lbits = 0 ;

	rbits = 0 ;

	bits = 0 ;

	j = 0 ;

	buff = 0 ;

	pakrtn = label_975 ;

	itemp = itxpc - 1 ;

text_loop:	
	do i = 0 to  itemp ;
		call object_$getbtx(i, lbits, rbits ) ;
		iword = tx_word(i);

		go to label_5000 ;
label_975:
		tx_word(i) = iword;

end text_loop ;



	/* output the last word if there is more in the buffer */

	if j = 0 then go to label_1000 ;

	call object_$objst(rpc,buff ) ;

	rpc = rpc + 1 ;


	/* output the linkage bits count */

label_1000:

	if tnewobject ^= 0 then do;
		call object_$objst (rpc, reloc_vers);
		rpc = rpc + 1;
		end;
	
	/* output the linkage bits count */

	call object_$objst( rpc, ilkcnt ) ;

	rpc = rpc + 1 ;

	lbits = 0 ;

	rbits = 0 ;

	bits = 0 ;

	j = 0 ;

	buff = 0 ;

	pakrtn = label_1075 ;


          /* no need to generate relocation bits for separate static section */

	if eb_data_$separate_static
	   then do;
	        itemp = (eb_data_$stat_len + ilkpc) - 1;
	        ik = eb_data_$stat_len;
	        end;
	   else do;
	        itemp = ilkpc - 1;
	        ik = 0;
	        end;

link_loop:

	do i = ik to itemp ;

		call object_$gtblk (i, lbits, rbits ) ;
		iword = lk_word(i);

		go to label_5000 ;

label_1075:
		lk_word(i) = iword;

end link_loop ;


	/* output the last word of the linkage buffer */

	if j = 0 then go to label_1200 ;

	call object_$objst(rpc, buff ) ;

	rpc = rpc + 1 ;

	/* process the definition relocation bits */

label_1200:
	j = 0 ;
	buff = 0 ;
	lbits = 0 ;
	rbits = 0 ;
	bits = 0 ;

	if tnewobject ^= 0 then do;
		call object_$objst (rpc, reloc_vers);
		rpc = rpc + 1;
		end;

	/* output the definition relocation bits count then the definition bits */

	call object_$objst(rpc, idfcnt ) ;
	rpc = rpc + 1 ;

	pakrtn = label_1250;	/* process internal definitions */

	do i = itxpc to itxpc+new_definition_length-1;
		call object_$getbtx(i, lbits, rbits);
		iword = tx_word(i);
		goto label_5000;
label_1250:
		tx_word(i) = iword;
	  end;

	pakrtn = label_1275 ;	/* add explicit definition section */
	itemp = idfpc - 1 ;

definition_loop:
	do i = 0 to itemp ;
		call object_$getbdf(i, lbits, rbits ) ;
		iword = df_word(i);
		go to label_5000 ;
label_1275:
		df_word(i) = iword;
	end definition_loop ;

	if j = 0 then go to label_1100 ;

	call object_$objst(rpc, buff ) ;

	rpc = rpc + 1 ;



	/* process the symbol relocation bits */

label_1100:

	j = 0 ;

	buff = 0 ;

	lbits = 0 ;

	rbits = 0 ;

	bits = 0 ;


	if tnewobject ^= 0 then do;
		call object_$objst (rpc, reloc_vers);
		rpc = rpc + 1;
		end;

	/* output the symbol relocation bits count then the symbol bits */


	call object_$objst(rpc, istcnt ) ;

	rpc = rpc + 1 ;

	pakrtn = label_1175 ;

	itemp = istpc - 1 ;

symbol_loop:

	do i = 0 to itemp ;

		call object_$getbst(i, lbits, rbits ) ;
		iword = st_word(i);

		go to label_5000 ;

label_1175:
		st_word(i) = iword;

end symbol_loop ;





	istpc = rpc ;
	if j = 0 then return ;
	call object_$objst(istpc, buff ) ;
	istpc = istpc + 1 ;

	return ;		/* as all bits have been processed */





	/* internal routine to process relocation bits patterns as retrieved by the GETxxx routines */
	/* The patterns are contained in the right halves of full words ( in lbits and rbits ).
		This internal routine concatenates the relocation bits and outputs them when a full word is filled. */ 



label_5000:
	if lbits = 27 /* 33o */ then do; /* relocate definition offsets */
		lbits = 21 /* 25o */; /* true defn relocation */
		word.left = word.left + new_definition_length;
	  end;
	if rbits = 27 /* 33o */ then do; /* relocate definition offsets */
		rbits = 21 /* 25o */; /* true defn relocation */
		word.right = word.right + new_definition_length;
	  end;

	nl = 1 ;

	nr = 1 ;

	if lbits ^= 0 then nl = 5 ;

	if rbits ^= 0 then nr = 5 ;

	n = nl + nr ;

	bits = utils_$or(utils_$ls(lbits,nr), rbits ) ;

	if ( j + n ) > 36 then go to label_5050 ;

	buff = utils_$or(buff,utils_$ls(bits,36-n-j)) ;

	j = j + n ;

	go to label_5080 ;

label_5050:

	buff = utils_$or(buff,utils_$rs(bits,n-(36-j))) ;

	call object_$objst(rpc,buff) ;

	buff = 0 ;

	rpc = rpc + 1 ;

	j = j + n - 36 ;

	buff = utils_$ls(bits,36-j) ;

label_5080:

	/* return to the proper main loop */

	go to pakrtn ;

end pakbit_;




		    pass1_.pl1                      10/17/88  1013.9rew 10/17/88  0929.5      366048



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




/****^  HISTORY COMMENTS:
  1) change(86-09-30,Oke), approve(86-09-30,MCR7543), audit(86-09-30,JRGray),
     install(86-10-08,MR12.0-1180):
     Allow ALM to support double word constants.
  2) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support severity, *heap references, the "init_link" pseudo,
     and joining to the symbol section.
  3) change(86-11-14,JRGray), approve(86-11-14,MCR7568),
     audit(86-11-21,RWaters), install(86-11-26,MR12.0-1228):
     Also MCR7572. Modified to add support for the three new pseudo-ops: ext_entry,
     oct_unal, and dec_unal.
  4) change(88-03-21,JRGray), approve(88-08-05,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     Changed for symbol table support. Add labels for 12 new pseudos that are
     ignored in pass1.
                                                   END HISTORY COMMENTS */


pass1_: 
     procedure(decor,target_value,no_target_given,first_time_thru); /* decor is initialized and passed from alm_6180_ ; 
					     target_value, no_target_given come from alm_ via alm_6180_ */

		/* 
		   pass1 is the first pass of the Multics assembler .

		   pass1 is primarily concerned with assigning symbol definitions
		   so that pass2 of the assembler can generate the binary output.
		   pass1 causes several tables to be generated and maintained,
		   including the assignment table (for internal symbols) and
		   the external name table, segment name table, trap word
		   table, link table, literal table, etc. no collation tape
		   is written, but the pc at the end of each statement is
		   recorded in a list for comparison in pass2, any discrepancy
		   is a phase error.
		   multiple location counters added
		   by J. D. Mills, 1 June 1967.


	Modified to support *heap links by R Gray and W Anderson on 2/05/86.
	Modified for changes to decor processing requested by MTR 175  on 3/25/81 by EBush.
	Modified to implement -target on 2/5/81 by EBush.
	Modified for decor processing 12/30/80 by E Bush
	Modified for macro processing 3/23/77 by Noel I. Morris
          Modified for prelinking on 06/15/75 by Eugene E Wiatrowski
	Modified 740905 by PG and ARD to extend ACC/ACI/BCI to 167/168/252 characters.
	Modified on 07/28/73 at 23:48:28 by R F Mabee.
	by RFM in June 1973 to add EIS instructions including multi-word operands.
	by RFM on 9 November 1972 to avoid reserving space for text entry sequence in old object format.
	by RFM on 21 July 1972 to fix R error on call to internal symbol.
	by RFM on 21 March 1972 for new object segment format.
	by RFM on 4 March to add new call/save/return operators.
	by RHG on 2 June 1971 to suppress "N" flag for undefined op code (should be "O")
	by RHG on 2 April 1971 to make rem=null if there was a label
			   to allow "bss ,exp" with no label specified
	by RHG on 17 Sept 1970 for new listing package
	by RHG on 7 August 1970 at 0545 for new sthead (name pseudo-op)
	by NA on July 14, 1970 at 1710 for the proper use of search_return
			and to call expevl_ as a function not a regular subroutine
		    */

/* "Common" variables initialized in eb_data_ */


%include varcom;
%include concom;
%include erflgs;
%include codtab;
%include sthedr;
%include mxpro;
%include lstcom;
%include labarg;
%include alm_lc;
%include alm_options;
%include alm_data;
/**/
/* EXTERNAL ENTRIES CALLED BY PASS1 */

 dcl		getid_		ext entry,
		getid_$getnam	ext entry,
		inputs_$next	ext entry,
		inputs_$next_statement	ext entry,
		inputs_$nxtnb	ext entry,
		utils_$pckflg	ext entry ( fixed bin (26) ),
		alm_include_file_$pass1 ext entry,
		alm_include_file_$insert ext entry (ptr, fixed bin (26), fixed bin (26)),
		alm_include_file_$pop ext entry,
		inputs_$get_ptr ext entry (ptr, fixed bin (26), fixed bin (26), bit (1) aligned),
		mexp_		ext entry (char (*), fixed bin (26), fixed bin(17), bit(1), bit(1)),
		mexp_$define_macro	ext entry (char (*)),
		oplook_$reset	ext entry,
		oplook_$redefine	ext entry,
		getid_$setid	ext entry ( fixed bin (26)),
		glpl_$slwrd	ext entry ( fixed bin (26), fixed bin (26), fixed bin (26)),
		glpl_$storl	ext entry ( fixed bin (26), fixed bin (26)),
		glpl_$storr	ext entry ( fixed bin (26), fixed bin (26)),
		system_type_	ext entry ( char(*), char(*), fixed bin, fixed bin(35));

/* EXTERNAL FUNCTIONS CALLED BY PASS1 */

 dcl	(	ascevl_$accevl	ext entry (fixed bin (26)),
		ascevl_$acievl	ext entry (fixed bin (26)),
		ascevl_$ac4evl	ext entry (fixed bin (26)),
		ascevl_$bcdevl	ext entry (fixed bin (26)),
		expevl_		ext entry ( fixed bin (26), fixed bin (26), fixed bin (26)),
		lstman_$blkasn	ext entry ( fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
		glpl_$cwrd	ext entry ( fixed bin (26)),
		glpl_$glwrd	ext entry ( fixed bin (26), fixed bin(26)),
		decevl_		ext entry ( fixed bin (26), fixed bin (26))) returns (fixed bin (26));
dcl	(	utils_$exadrs	ext entry ( fixed bin (26), fixed bin (26)),
		lstman_$lnkasn	ext entry ( fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
		lstman_$outasn	ext entry ( fixed bin (26), fixed bin (26), fixed bin (26)),
		utils_$ls ext entry (fixed bin (26), fixed bin (26)),
		utils_$rs		ext entry ( fixed bin (26), fixed bin (26)),
		lstman_$namasn	ext entry ( fixed bin (26)),
		utils_$nswrds	ext entry ( fixed bin )) returns (fixed bin (26));
dcl	(	octevl_		ext entry ( fixed bin (26)),
		oplook_$oplook_	ext entry ( fixed bin (26), fixed bin (26)),
		glpl_$setblk	ext entry ( fixed bin (26), fixed bin (26) ),
		table_		ext entry ( fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
					  fixed bin (26)),
		lstman_$trpasn	ext entry ( fixed bin (26), fixed bin (26)),
		varevl_		ext entry ( fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
					  fixed bin (26), fixed bin (26)),
		vfdevl_$vfdcnt	ext entry ( fixed bin (26), fixed bin (26))
			) returns ( fixed bin (26));



/* AUTOMATIC VARIABLES USED BY PASS1 */
 dcl	(binop, flags, i, iaddr, iflag, itype, iwhat, j, junk, k, link, mul, n, newrho, nwrds, option,
	basno, value, b29, admod, pcblk (3), class, type, xnlnk, ptrcal, ptrarg, trplnk, blklnk, symlnk,
	rslts (42), newval, oldval, tbss, tderr, stat_or_link ) fixed bin (26);
dcl	label_flag	bit (1) aligned;
dcl	end_statement_flag 	bit (1) aligned;
dcl	dup_ptr ptr init (null ()),
	temp_ptr ptr,
	dup_count fixed bin (26),
	dup_start fixed bin (26),
	dup_string (0:262143) char (1) unal based (dup_ptr);
dcl       operand    char(32) varying;
dcl	canonical_operand char(24);
dcl	code	fixed bin(35);
dcl	(stkclst, stkctop) fixed bin(26);		/* used to remember stackframe sizes */
dcl	ext_entry_count fixed bin;
dcl	remember_sym(8) fixed bin(26);	/* used to remember sym */

/* LABEL VARIABLE */
 dcl	search_return label local;

 dcl	static_in_linkage bit(1) initial("0"b);
 


 

/* EXTERNAL DATA USED BY PASS1 */
 dcl	(eb_data_$itext, eb_data_$ilink, eb_data_$isym, eb_data_$istatic, eb_data_$idefs, eb_data_$ioff, eb_data_$ion,
	eb_data_$nertls, eb_data_$nmxcal, eb_data_$nmxclb, eb_data_$nmxsav, eb_data_$nretls,
	eb_data_$nslcal, eb_data_$nslsav,
	eb_data_$new_nslcal, eb_data_$new_nslsav, eb_data_$new_nretls, eb_data_$short_nretls,
	eb_data_$new_nentls, eb_data_$short_nslcal, eb_data_$new_ngetlp,
	eb_data_$atext2 (2), eb_data_$alink2 (2), eb_data_$asym2 (2), eb_data_$astatic2 (2), eb_data_$asystem2 (2),
	eb_data_$adef2 (2),
	eb_data_$tsym, eb_data_$atext (2), eb_data_$alink (2), eb_data_$asym (2), eb_data_$asys (2), eb_data_$aheap(2),
	eb_data_$astat (2)) ext fixed bin (26);

 dcl	eb_data_$separate_static ext bit(1);
dcl	eb_data_$entrybound_bit ext bit(1);
dcl	eb_data_$macro_depth fixed bin (26) ext;


/* PARAMETERS */

dcl       decor fixed bin(35); /* passed from alm_6180_ */
dcl	target_value fixed bin(17); /* ditto */
dcl	(no_target_given,first_time_thru) bit(1); /* likewise */



/* OVERLAY FOR SETTING HALF WORDS */

 dcl	1 word based aligned,
	  2 (left,right) bit (18) unaligned;

 dcl	1 glpl_words (0:262143) based (eb_data_$lavptr) aligned,
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;

 dcl	1 acc aligned based,
	  2 length bit (9) unaligned,
	  2 string char (32) unaligned;

 dcl	eb_data_$lavptr external pointer;
 dcl	eb_data_$per_process_static_sw fixed bin external;



/* entry to subroutine, set up variables before main loop. */


label_100: 
	pc = 0;
	labarg = 0;
	tfirstreftrap = 0;
	ext_entry_count = 0;
	eb_data_$separate_static,
	eb_data_$entrybound_bit,
	static_in_linkage = "0"b;
 
 

/* Initialize system location counters. */

	junk = table_ (iassgn, lctext (1), 0, fmlcrf, iaddr);
	ulclst, ulcend, curlc, lptext = iaddr;

	junk = table_ (iassgn, lcst (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, ulclst);
	call glpl_$storl (ulclst+2, iaddr);
	ulclst, lpst = iaddr;
	call glpl_$storr (lpst+4, eb_data_$isym);

	junk = table_ (iassgn, lcdefs (1), 0, fmlcrf, iaddr);
	tlclst, dlclst, lpdefs = iaddr;

	junk = table_ (iassgn, lclit (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, tlclst);
	call glpl_$storl (tlclst+2, iaddr);
	tlclst, lplit = iaddr;
	call glpl_$storl (lplit+4, 2);

	junk = table_ (iassgn, lcentries (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr + 2, tlclst);
	call glpl_$storl (tlclst + 2, iaddr);
	tlclst, lpentries = iaddr;

	junk = table_ (iassgn, lccall (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, tlclst);
	call glpl_$storl (tlclst+2, iaddr);
	tlclst, lpcall = iaddr;

	junk = table_ (iassgn, lctv (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, tlclst);
	call glpl_$storl (tlclst+2, iaddr);
	tlclst, lptv = iaddr;

	junk = table_ (iassgn, lcsect (1), 0, fmlcrf, iaddr);
	llclst, lpsect = iaddr;
	call glpl_$slwrd (lpsect+4, 2, eb_data_$ilink);

	junk = table_ (iassgn, lchead (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, llclst);
	call glpl_$storl (llclst+2, iaddr);
	llclst, lphead = iaddr;
	call glpl_$storr (lphead+4, eb_data_$ilink);

	junk = table_ (iassgn, lcrst (1), 0, fmlcrf, iaddr);
	slclst, lprst = iaddr;
	call glpl_$storr (lprst+4, eb_data_$isym);

	junk = table_ (iassgn, lcrlk (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, slclst);
	call glpl_$storl (slclst+2, iaddr);
	slclst, lprlk = iaddr;
	call glpl_$storr (lprlk+4, eb_data_$isym);

	junk = table_ (iassgn, lcrtx (1), 0, fmlcrf, iaddr);
	call glpl_$storr (iaddr+2, slclst);
	call glpl_$storl (slclst+2, iaddr);
	slclst, lprtx = iaddr;
	call glpl_$storr (lprtx+4, eb_data_$isym);

	/* make stackframe_size list */
	stkctop = glpl_$setblk(0, 1);
	stkclst = stkctop;

	binlin = 1;
	call oplook_$reset;

/* main loop re-entry, assign any symbols in location field. */

label_200: 
	label_flag = "0"b;
label_210:
	spc = pc;
	brk (1) = isp;
	call getid_;
	if (brk (1) ^= icol) then goto label_300;
	if (eb_data_$tsym ^= 0) then junk = table_ (iassgn,sym (1),spc,flocrf,curlc);
	label_flag = "1"b;
	goto label_210;

/* get operator and test for pseudo-operation. */

label_300: 
	if sym (1) ^= 0 then goto label_302;
	if brk (1) = inl then goto label_870;
	if brk (1) = iquot then goto label_870;
label_302:
	binop = oplook_$oplook_ ( iflag, itype );
	if iflag ^= 0 then do;
	     call mexp_ (substr (addr (sym (1)) -> acc.string, 1, bin (addr (sym (1)) -> acc.length, 9)), iflag, target_value, no_target_given,first_time_thru);
	     if iflag ^= 0 then go to label_3200;
	     else go to label_3030;
	end;
	if (brk (1) = isp /*iht ditto*/	|	brk (1) =inl /* icr and isc ditto*/ )  then goto label_305;

/* then there is an error in this statement. */
	goto label_3200;

label_305: 

	goto label_vector (itype);


/* control group of pseudo operations. */

/* end card, simply return to caller of pass1.
   reset inhibit flag for pass2 first. */


label_vector (1):		/* end */
label_450: 
	tinhib = 0;				/* FALSE */

/* check for lpst at head of unjoined lc list. if there, move
   to head of symbol segment lc list. */
	if (ulclst ^= lpst) then goto label_460;
	ulclst = fixed (glpl_words (ulclst + 2).right, 18);
	if (ulclst ^= 0) then call glpl_$storl (ulclst + 2,0);
	call glpl_$storr (lpst + 2,slclst);
	call glpl_$storl (slclst + 2,lpst);
	slclst = lpst;

/* set up system location counter maximum lengths for
   absolutizing in postp1. */

label_460: 

	if (tprot ^= 0 ) then call glpl_$storr (lptv + 3,tvlth);
	if (tcall ^= 0 ) then call glpl_$storr (lpcall + 3,eb_data_$nslcal + 1);

/* length of header is 8. */
	call glpl_$storr (lphead + 3, 8);

/* Likewise update entry count into entries section. */
	if tnewobject ^= 0 then call glpl_$storr (lpentries + 3, (tvlth - ext_entry_count) * eb_data_$new_nentls);
		/* ext_entry already adjusts text section length */

	/* remember amount of stack space currently allocated */
	call glpl_$slwrd(stkclst, stkc, 0);
	stkc = stkctop;	/* stkc is used to transmit top of stkclst to pass2 */

/* save the current value of pc in curlc. */
	call glpl_$storr (curlc + 1,pc);

	return;


/* include statement, use new source file. */

label_vector (50):		/* include */
label_include:
	if dup_ptr ^= null () then go to label_3100;
	call getid_ ();
	if eb_data_$tsym = 0 then goto label_3100;
	call inputs_$next_statement ();
	call alm_include_file_$pass1 ();
	goto label_200;

/* use pseudo-operation, use new location counter. */

label_vector (2):		/* use */
label_500: 
	call getid_;
	if ( eb_data_$tsym = 0) then goto label_3100;

/* save current value of old location counter. */
	call glpl_$storr (curlc + 1,pc);

/* use new lc as the current lc. */
	if (table_ (iserch,sym (1),pc,fmlcrf,curlc) ^= 0) then goto label_3010;


/* not found so initialize a new location counter. */
	pc = 0;
	junk = table_ (iassgn,sym (1),pc,fmlcrf,curlc);


/* put new lc at end of ulclst. no problems with empty
   list since list initialized with some system lc's. */
	call glpl_$storr (ulcend + 2,curlc);
	call glpl_$storl (curlc + 2,ulcend);
	ulcend = curlc;
	goto label_3010;

/* org pseudo-operation. set the pc to the value of the expression. */

label_vector (3):		/* org */
label_525: 
	if varevl_ (invrvl,basno,value,admod,b29,iaddr) = 0 then goto label_3110;
	if (iaddr ^= 0) then goto label_3300;
	if pc > fixed (glpl_words (curlc + 3).right, 18) then call glpl_$storr (curlc + 3, pc);
	pc = value;
	goto label_3010;

/* join pseudo-op. move lc nodes from unjoined
   lc list to one of the joined lc lists. */

label_vector (4):		/* join */
label_550: 
	call inputs_$nxtnb;
	if (brk (1) ^= islash) then goto label_3100;

label_555: 
	call getid_;
	if (brk (1) ^= islash | eb_data_$tsym = 0) then goto label_3100;
	if (sym (1) = eb_data_$atext2 (1) & sym (2) = eb_data_$atext2 (2)) then goto label_565;
	if (sym (1) = eb_data_$alink2 (1) & sym (2) = eb_data_$alink2 (2)) 
	   then do;
	        static_in_linkage = "1"b;
	        goto label_570;
	        end;
	if (sym (1) = eb_data_$asym2 (1) & sym (2) = eb_data_$asym2 (2)) then goto label_575;
	if (sym (1) = eb_data_$astatic2 (1) & sym (2) = eb_data_$astatic2 (2)) 
	   then do;
	        eb_data_$separate_static = "1"b;
	        goto label_570;
	        end;
	if (sym (1) = eb_data_$adef2 (1) & sym (2) = eb_data_$adef2 (2)) then goto label_593;

	prntu = 1;				/* TRUE */

label_560: 
	call inputs_$next;
	if (brk (1) = islash) then goto label_555; /* parse join */
	if (brk (1) = isp | brk (1) = inl) then goto label_3020; /* next statement */
	goto label_560;

/* join text location counters. */

label_565: 
	call getid_;
	search_return = label_566;
	goto label_580;

label_566: 
	if (iaddr = 0) then goto label_569;
	call glpl_$storr (iaddr + 4,eb_data_$itext);
	call glpl_$storl (iaddr + 2, fixed (glpl_words (lptv + 2).left, 18));
	call glpl_$storr (iaddr + 2,lptv);
	if (tlclst ^= lptv) then goto label_567;
	tlclst = iaddr;
	goto label_568;

label_567: 

	call glpl_$storr (fixed (glpl_words (lptv + 2).left, 18) + 2, iaddr);

label_568: 

	call glpl_$storl (lptv + 2,iaddr);

label_569: 
	if (brk (1) = icomma) then goto label_565;
	if (brk (1) = islash) then goto label_555; /* parse join */
	goto label_3020; /* next statement */

/* join link location counters. */

label_570: 
	call getid_;
	search_return = label_571;
	goto label_580;

label_571: 
	if (iaddr = 0) then goto label_574;
	if eb_data_$separate_static
	   then stat_or_link = eb_data_$istatic;
	   else stat_or_link = eb_data_$ilink;
	call glpl_$storr (iaddr + 4,stat_or_link);
	call glpl_$storl (iaddr + 2, fixed (glpl_words (lpsect + 2).left, 18));
	call glpl_$storr (iaddr + 2,lpsect);

/* since lphead is alsays left of lpsect we
   do not need to test for llclst = lpsect. */
	call glpl_$storr (fixed (glpl_words (lpsect + 2).left, 18) + 2, iaddr);
	call glpl_$storl (lpsect + 2,iaddr);

label_574: 
	if (brk (1) = icomma) then goto label_570;
	if (brk (1) = islash) then goto label_555; /* parse join */
	goto label_3020; /* next statement */

/* join symbol location counters. */

label_575: 
	call getid_;
	search_return = label_576;
	goto label_580;

label_576: 
	if (iaddr = 0) then goto label_579;
	call glpl_$storr (iaddr + 4,eb_data_$isym);
	call glpl_$storl (iaddr + 2, fixed (glpl_words (lprtx + 2).left, 18));
	call glpl_$storr (iaddr + 2,lprtx);
	if (slclst ^= lprtx) then goto label_577;
	slclst = iaddr;
	goto label_578;

label_577: 

	call glpl_$storr (fixed (glpl_words (lprtx + 2).left, 18) + 2, iaddr);

label_578: 

	call glpl_$storl (lprtx + 2,iaddr);

label_579: 
	if (brk (1) = icomma) then goto label_575;
	if (brk (1) = islash) then goto label_555; /* parse join */
	goto label_3020; /* next statement */

/* join definition location counters. */

label_593: 
	call getid_;
	search_return = label_594;
	goto label_580;

label_594: 
	if (iaddr = 0) then goto label_597;
	call glpl_$storr (iaddr + 4,eb_data_$idefs);
	call glpl_$storl (iaddr + 2, fixed (glpl_words (lpdefs + 2).left, 18));
	call glpl_$storr (iaddr + 2,lpdefs);
	if (dlclst ^= lpdefs) then goto label_595;
	dlclst = iaddr;
	goto label_596;

label_595: 

	call glpl_$storr (fixed (glpl_words (lpdefs + 2).left, 18) + 2, iaddr);

label_596: 

	call glpl_$storl (lpdefs + 2,iaddr);

label_597: 
	if (brk (1) = icomma) then goto label_593;
	if (brk (1) = islash) then goto label_555; /* parse join */
	goto label_3020; /* next statement */
				/* internal routine to search for a lc on the
				   unjoined location counter list. if found it is
				   disconnected from ulclst and a ptr (iaddr) to
				   it is returned. if not found iaddr = 1; TRUE, and prntu = 1; TRUE. */

label_580: 
	j = ulclst;
	if table_ (iserch, sym (1), junk, fmlcrf, i) = 0 then goto label_583;

label_582: 
	if (j ^= 0) then goto label_584;
label_583:
	prntu = 1;				/* TRUE */
	iaddr = 0;
	goto search_return;

label_584: 
	if j ^= i then goto label_592;

	iaddr = j;
	if (iaddr = ulcend) then ulcend = fixed (glpl_words (iaddr + 2).left, 18);
	if (j ^= ulclst) then goto label_588;
	ulclst = fixed (glpl_words (j + 2).right, 18);
	goto label_590;

label_588: 

	call glpl_$storr (fixed (glpl_words (j + 2).left, 18) + 2, fixed (glpl_words (j + 2).right, 18));

label_590: 

	if fixed (glpl_words (j + 2).right, 18) = 0 then goto search_return;
	call glpl_$storl (fixed (glpl_words (j + 2).right, 18) + 2, fixed (glpl_words (j + 2).left, 18));
	goto search_return;


label_592: 
	j = fixed (glpl_words (j + 2).right, 18);
	goto label_582;

/* even pseudo-operation, force pc to even location. */

label_vector (5):		/* even */
label_600: 
	pc = spc + mod (spc,2);
	iflag = 2;
	goto label_690;

/* odd pseudo-operation, force pc to odd location. */

label_vector (6):		/* odd */
label_630: 
	pc = spc + mod (spc + 1,2);
	iflag = 2;
	goto label_690;

/* eight pseudo-operation, force pc to zero mod eight. */

label_vector (7):		/* eight */
label_660: 
	pc = 8*divide ( (spc + 7),8,26,0);		/* originally ==> pc = 8* ( (spc+7)/8); */
	iflag = 8;
	goto label_690;

/* sixty-four pseudo-operation. set the pc to zero mod 64. */

label_vector (8):		/* sixtyfour */
label_680: 
	pc = 64*divide ( (spc + 63),64,26,0);		/* originally ==> pc = 64* ( (spc+63)/64); */
	iflag = 64;

label_690: 
	oldval = fixed (glpl_words (curlc + 4).left, 18);
	newval = iflag;
	if (oldval = 0) then goto label_699;
	if (mod (newval,oldval) = 0) then goto label_699;
	newval = oldval;
	if (mod (newval,iflag) = 0) then goto label_699;
	newval = oldval*iflag;

label_699: 
	call glpl_$storl (curlc + 4,newval);
	goto label_3010;

/* movdef pseudo-operation. move the definitions to the link segment */

label_vector (11):		/* movdef */
label_755: 
	tmvdef = 1;				/* TRUE */
	tnewobject = 0;				/* Can't move defs in new format. */
	goto label_3010;



/* decor pseudo-operation:  claims that all intructions are compatible with the decor named by its operand */

label_vector (62):             /* decor */
label_decor:
          call getid_;
	operand = substr(addr(sym(1)) -> acc.string,1,bin(addr(sym(1)) -> acc.length,9));
	call system_type_((operand),canonical_operand,(0),code);
	if code ^=0
	    then prntf = 1;
	else do;
		   /* a match is assured in this following lookup routine
		    only if the operand names supplied to alm_table_tool
		    (when it created the "data1" array) are a subset of
		    the canonical strings for system_type_. Alm_table_tool
		    will check for this correspondence for you. */

		   
          	do n = 1 to hbound(data1.decor,1) while(rtrim(canonical_operand) ^= data1.decor(n).name);
          	end;
		decor = data1.decor(n).number;
	     end;

	goto label_3010;


/* error pseudo-operation, sets fatal error flag, causing "Translation failed" message. */

label_vector (63):		/* error */
label_error:
	tfatal = 3;	/* severity 3 error */
	goto label_3010;


/* firstref pseudo-operation, specifies trap procedure on first entry reference. */

label_vector (48):		/* firstref */
label_firstref:
	if tfirstreftrap ^= 0 then prntm = 1;
	tfirstreftrap = 1;
	if varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
	if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
	first_ref_trap_proc_linkno = value;
	if brk (1) = ilpar then do;
		if varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
		if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
		first_ref_trap_arg_linkno = value;
		if brk (1) ^= irpar then goto label_3100;
		end;
	else first_ref_trap_arg_linkno = 0;
	goto label_3010;

/* inhibit pseudo-operation, set inhibit mode on or off. */

label_vector (12):		/* inhibit */
label_760: 
	call getid_;
	if ( eb_data_$tsym = 0) then goto label_765;
	if (sym (1) = eb_data_$ion) then goto label_770;
	if (sym (1) = eb_data_$ioff) then goto label_775;
	goto label_3010;


label_765: 
	tinhib = 1 - tinhib;	/* tinhib = ^tinhib */
	goto label_3010;


label_770: 
	tinhib = 1;				/* TRUE */
	goto label_3010;


label_775: 
	tinhib = 0;				/* FALSE */
	goto label_3010;

/* name pseudo-operation, record the name of this segment. */

label_vector (14):		/* name */
label_820: 
	if (mynam ^= 0) then goto label_3100;
	call getid_$getnam;
	if ( eb_data_$tsym = 0) then goto label_3100;
	sthedr_$seg_name = substr (addr (sym (1)) -> acc.string, 1, fixed (addr (sym (1)) -> acc.length, 9));
	goto label_3010;

/* null pseudo-operation, do nothing. */

label_vector (15):		/* null */
label_850: 
	goto label_3010;

/* rem pseudo-operation, same as null, if there was a label on the statement */

label_vector (16):		/* rem */
label_870: 
	if label_flag then goto label_850;
	call inputs_$next_statement;
	goto label_200;


/* symbol defining pseudo-operations. */

/* basref pseudo-operation, define external symbols. */


label_vector (17):		/* basref */
label_900: 
	if ( eb_data_$tsym = 0) then goto label_910;
	if (table_ (iserch,sym (1),value,clbas,junk) ^= 0) then goto label_915;
	do i = 1 to 8;				/* To label_905 */
	     if (sym (1) ^= symbas (i)) then goto label_905;
	     value = i-1;
	     goto label_915;

label_905:     
	end;					/* the do-group */
	if (table_ (iserch,sym (1),basno,clint,junk) ^= 0) then goto label_915;
	goto label_3130;


label_910: 
	if (varevl_ (invrvp,basno,value,admod,b29,iaddr) = 0) then goto label_3120;
	if (iaddr ^= 0) then goto label_3300;


label_915: 
	link = utils_$exadrs (value,0);
	type = 2;
	class = fbasrf;

/* re-entry from segref pseudo-operation. */

label_920: 
	call getid_;
	xnlnk = lstman_$namasn (sym (1));

label_930: 
	ptrcal = 0;
	ptrarg = 0;
	trplnk = 0;
	tderr = 0;				/* FALSE */
	if (brk (1) ^= ilpar) then goto label_970;
	if (varevl_ (ixvrvl,basno,ptrcal,admod,b29,iaddr) ^= 0) then goto label_935;
	if (tprot = 1 & b29 = 0) then tvlth = tvlth + 1;
	tderr = 1;				/* TRUE */
	goto label_945;

label_935: 
	if (b29 ^= 0) then goto label_945;
	if (tprot = 1 ) then goto label_940;
	ptrcal = lstman_$lnkasn (myblk,ptrcal,admod,iaddr);
	goto label_945;

label_940: 

	tvlth = tvlth + 1;
	tderr = 1;				/* TRUE */

label_945: 
	if (brk (1) ^= ilpar) then goto label_960;
	if (varevl_ (ixvrvl,basno,ptrarg,admod,b29,iaddr) ^= 0) then goto label_950;
	tderr = 1;				/* TRUE */
	goto label_955;

label_950: 

	if (b29 = 0) then ptrarg = lstman_$lnkasn (myblk,ptrarg,admod,iaddr);


label_955: 
	if (brk (1) = irpar) then call inputs_$next;


label_960: 
	if (brk (1) = irpar) then goto label_965;
	tderr = 1;				/* TRUE */
	goto label_980;


label_965: 
	call inputs_$next;
	if (tderr = 1) then goto label_980;
	trplnk = lstman_$trpasn (ptrcal,ptrarg);

label_970: 
	junk = table_ (iassgn, fixed (glpl_words (xnlnk).left, 18), lstman_$blkasn (type, link, xnlnk, trplnk),
							class, junk);


label_980: 
	if (brk (1) = icomma) then goto label_920;
	goto label_3010;

/* bool pseudo-operation, assign boolean equivalence to symbol. */

label_vector (18):		/* bool */
label_1000: 
	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then goto label_3100;
	if (varevl_ (ibvrvl,basno,value,admod,b29,iaddr) = 0) then goto label_3120;
	if (iaddr ^= 0) then goto label_3300;
	junk = table_ (iassgn,symlnk,value,fbolrf,junk);
	goto label_3010;

/* equ pseudo-operation, assign arithmetic equivalence to symbol. */

label_vector (19):		/* equ */
label_1100: 
	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then goto label_3100;

label_1110: 
	if (varevl_ (invrvl,basno,value,admod,b29,iaddr) = 0) then goto label_3120;
	class = flocrf;
	if (iaddr = 0) then class = fequrf;
	junk = table_ (iassgn,symlnk,value,class,iaddr);
	goto label_3010;

/* link pseudo-operation, define link number of external reference. */

label_vector (20):		/* link */
label_1200: 
	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then goto label_3100;
	if (varevl_ (ixvrvl,basno,value,admod,b29,iaddr) = 0) then goto label_3120;
	if (b29 = 0) then value = lstman_$lnkasn (myblk,value,admod,iaddr);
	junk = table_ (iassgn,symlnk,value,flocrf,lpsect);
	goto label_3010;

		/* associate init info with link */
label_vector (65):		/* init_link */
	goto label_3010;	/* skip in pass1 */

/* set pseudo-operation, assign resettable_ equ type symbol. */

label_vector (21):		/* set */
label_1250: 
	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then goto label_3100;
	if (varevl_ (invrvl,basno,value,admod,b29,iaddr) = 0) then goto label_3120;
	if (iaddr ^= 0) then goto label_3300;
	junk = table_ (iassgn,symlnk,value,fsetrf,junk);
	goto label_3010;

/* segref pseudo-operation, define external symbols with pointers. */

label_vector (22):		/* segref */
label_1300: 
	call getid_$getnam;
	if (brk (1) ^= icomma) then goto label_3100;
	class = fsegrf;
	if (sym (1) ^= eb_data_$atext (1) | sym (2) ^= eb_data_$atext (2)) then goto label_1310;
	type = 5;
	link = 0;
	goto label_920;

label_1310: 
	if (sym (1) ^= eb_data_$alink (1) | sym (2) ^= eb_data_$alink (2)) then goto label_1320;
	type = 5;
	link = 1;
	goto label_920;

label_1320: 
	if (sym (1) ^= eb_data_$asym (1) | sym (2) ^= eb_data_$asym (2)) then goto label_1330;
	type = 5;
	link = 2;
	goto label_920;

label_1330: 
	if (sym (1) ^= eb_data_$astat (1) | sym (2) ^= eb_data_$astat (2)) then goto label_1340;
	type = 5;
	link = 4;
	goto label_920;

label_1340: 
	if (sym (1) ^= eb_data_$asys (1) | sym (2) ^= eb_data_$asys (2)) then goto label_1350;
	type = 5;
	link = 5;
	goto label_920;

label_1350: 
	if (sym (1) ^= eb_data_$aheap (1) | sym (2) ^= eb_data_$aheap (2)) then goto label_1360;
	type = 5;
	link = 6;
	goto label_920;

label_1360: 
	type = 4;
	link = lstman_$namasn (sym (1));
	goto label_920;

/* temp and tempd pseudo-operations, define symbols in stack. */

label_vector (23):		/* temp */
label_1400: 
	mul = 1;
	goto label_1510;


label_vector (24):		/* tempd */
label_1500: 
	mul = 2;
	stkc = stkc + mod (stkc,2);
	goto label_1510;


label_vector (25):		/* temp8 */
label_1505: 
	mul = 8;
	stkc = 8*divide ( (stkc + 7),8,26,0);		/* originally ==> stkc = 8* ( (stkc + 7)/8); */


label_1510: 
	call getid_$setid (symlnk);
	if (symlnk ^= 0) then goto label_1520;
	prntf = 1;				/* TRUE */
	goto label_1550;

label_1520: 
	value = 1;
	if (brk (1) ^= ilpar) then goto label_1540;
	if (varevl_ (invrvp,basno,value,admod,b29,iaddr) = 0) then goto label_1525;
	if (iaddr = 0) then goto label_1530;
	prntr = 1;				/* TRUE */

label_1525: 
	prnts = 1;				/* TRUE */
	goto label_1550;

label_1530: 
	if (brk (1) = irpar) then call inputs_$next;

label_1540: 
	if (table_ (iassgn,symlnk,stkc,fstkrf,junk) = 0) then prnts = 1; /* TRUE */
	stkc = stkc + value*mul;

label_1550: 
	if (brk (1) = icomma) then goto label_1510;
	goto label_3010;



/* generative class of pseudo-operations. */

/* acc and aci pseudo-operations, ascii code generators. */
/* also bci pseudo-operation to generate 6-bit codes. */

label_vector (26):		/* acc */
label_1600: 
	n = ascevl_$accevl (rslts (1));
	goto label_1710;

label_vector (27):		/* aci */
label_1700: 
	n = ascevl_$acievl (rslts (1));
	goto label_1710;


label_vector (13):		/* bci */
label_bci:
	n = ascevl_$bcdevl (rslts (1));
	go to label_1710;


label_vector (59):		/* ac4 */
label_ac4:
	n = ascevl_$ac4evl (rslts (1));


label_1710: 
	pc = pc + n;
	goto label_3010;

/* dec pseudo-operation, integer, fixed, and floating point. */

label_vector (28):		/* dec */
label_1800: 
	n = decevl_ (rslts (1),type);
	if (n >= 2) then pc = pc + mod (pc,2);
	pc = pc + n;
	if (brk (1) = icomma) then goto label_1800;
						/* verify the break character for dec pseudo-op */
	goto label_1920;

/* dec_unal pseudo-operation, integer, fixed, and floating point unaligned. */

label_vector (66):		/* dec_unal */
label_1801:
	n = decevl_ (rslts (1),type);
	pc = pc + n;
	if (brk (1) = icomma) then goto label_1801;
						/* verify the break character for dec pseudo-op */
	goto label_1920;

/* oct pseudo-operation, octal number generator. */

label_vector (29):		/* oct */
label_1900: 
	n = octevl_ (rslts (1));
	if (n >= 2) then pc = pc + mod (pc,2);
	pc = pc + n;
	if (brk (1) = icomma) then goto label_1900;
						/* verify the break characters */
	goto label_1920;

/* oct_unal pseudo-operation, unaligned octal number generator. */

label_vector (67):		/* oct_unal */
label_1901: 
	n = octevl_ (rslts (1));
	pc = pc + n;
	if (brk (1) = icomma) then goto label_1901;
						/* verify that the break characters for dec and oct
						   are legitimate at this point */

label_1920: 
	if ( brk (1) = inl | brk (1) = isp ) then goto label_3010;
	goto label_3100;

/* vfd pseudo-operation, variable field data generator. */

label_vector (30):		/* vfd */
label_2000: 
	pc = pc + vfdevl_$vfdcnt (rslts (1),flags);
	goto label_3010;

/* mod pseudo-operation. force location counter mod expression. */

label_vector (31):		/* mod */
label_2020: 
	call getid_;
	junk =  expevl_ (0,value,iaddr);			/* 0 ==> FALSE */
	if (iaddr ^= 0) then prntr = 1;		/* TRUE */
	iflag = value;
	pc = value*divide ( (spc + value-1),value,26,0);	/* originally ==> pc = value* ( (spc + value-1)/value); */
	goto label_690;


/* storage allocating pseudo-operations. */

/* bfs pseudo-operation, block followed by symbol. */

label_vector (32):		/* bfs */
label_2100: 
	tbss = 0;					/* FALSE */
	goto label_2210;

/* bss pseudo-operation, block started by symbol. */

label_vector (33):		/* bss */
label_2200: 
	tbss = 1;					/* TRUE */

label_2210: 
	call getid_$setid (symlnk);
	if (brk (1) ^= icomma) then goto label_3100;
	if (varevl_ (invrvl,basno,value,admod,b29,iaddr) = 0) then goto label_3110;
	if (iaddr = 0) then goto label_2220;
	prntr = 1;				/* TRUE */
	goto label_3120;

label_2220: 
	pc = pc + value;
	if (b29 ^= 0 ) then goto label_3100;
	if symlnk = 0 then goto label_3010;		/* allow bss ,exp with no symbol specified */
	value = pc;
	if (tbss = 1) then value = spc;
	junk = table_ (iassgn,symlnk,value,flocrf,curlc);
	goto label_3010;

/* zero pseudo-operation, ignore in pass1. */

label_vector (34):		/* zero */
label_2350: 
	pc = spc + 1;
	goto label_3010;

/* its and itb pseudo-operations, set pc even, and add two. */

label_vector (35):		/* itb */
label_2400: 


label_vector (36):		/* its */
label_2450: 
	pc = (spc + mod (spc,2)) + 2;

/* correction here 3/12/69 */
	iflag = 2;
	goto label_690;


/* subroutine linkage pseudo-operations. */

/* call pseudo-operation, call subroutine with args and returns. */

label_vector (37):		/* call */
label_2500: 
	junk = varevl_ (ixvrvl,basno,value,admod,b29,iaddr);
	prntr = 0;
	if (tprot = 1 & b29 ^= 0) then goto label_2510;
	if tnewcall ^= 0 then pc = spc + eb_data_$new_nslcal;
	else pc = spc + eb_data_$nslcal;
	goto label_3010;

label_2510: 
	junk = lstman_$outasn (spc,spc + eb_data_$nmxcal,curlc);
	tcall = 1;				/* TRUE */
	tstsw (1) = 1;				/* TRUE */
	tvlth = tvlth + 1;
	pc = spc + eb_data_$nmxcal + eb_data_$nmxclb;
	goto label_3010;

/* short_call pseudo-operation, call without save. */

label_vector (51):		/* short_call */
label_short_call:
	pc = spc + eb_data_$short_nslcal;
	goto label_3010;

/* entry pseudo-operation, count symbols in pass1. */

label_vector (38):		/* entry */
label_2600: 
	call getid_;
	if ( eb_data_$tsym = 0) then goto label_3100;
	tvlth = tvlth + 1;
	if (brk (1) = icomma) then goto label_2600;
						/* this entry statement is processed. */
	goto label_3010;

/* ext_entry pseudo_operation Usage: ext_entry elabel,stackframe_size,clabel,dlabel,function */

label_vector (64):
label_2610:
/* first arg, entrypoint label */
	call getid_;
	if eb_data_$tsym = 0 then goto label_3100;	/* field error */

	/* remember amount of stack space currently allocated */
	i = stkclst;
	stkclst = glpl_$setblk(0, 1);
	call glpl_$slwrd(i, stkc, stkclst);

	stkc = 64;	/* initial ext_entry stackframe size */
	ext_entry_count = ext_entry_count + 1;
	tvlth = tvlth + 1;
	pc = pc + 7;	/* leave room for entry seq and entry code */
	if brk(1) ^= icomma then goto label_3010;
/* second arg stacksize */
	junk = varevl_(invrvl, basno, i, admod, b29, iaddr);
	if brk(1) ^= icomma then goto label_3010;
/* third arg code_sequence label */
	call getid_;
	remember_sym = sym;
	if brk(1) = icomma then do;
/* fourth argument dlabel */
	     call getid_;
	     if sym(1) ^= 0 then pc = pc + 1;	     /* has descriptors */
	  end;
	/* set value of optional internal label */
	if remember_sym(1) > 0 then junk = table_(iassgn, remember_sym(1), pc-6, flocrf, curlc);
	goto label_3010;    /* done */

/* return pseudo-operation, return control to caller. */

label_vector (39):		/* return */
label_2700: 
	if tnewcall ^= 0 then pc = spc + eb_data_$new_nretls;
	else pc = spc + eb_data_$nretls;
	call inputs_$nxtnb;
	if (brk (1) ^= iques) then goto label_3010;
	pc = spc + eb_data_$nertls;
	if (labarg ^= 0) then goto label_3010;
	stkc = stkc + mod (stkc,2);
	labarg = stkc;
	stkc = stkc + 4;
	goto label_3010;

/* short_return pseudo-operation, return from entry that did no save. */

label_vector (46):		/* short_return */
label_short_return:
	if tnewcall = 0 then prnto = 1;
	pc = spc + eb_data_$short_nretls;
	goto label_3010;

/* save pseudo-operation, stack setup for subroutine call. */

label_vector (41):		/* save/push */
label_2800: 
	if tnewcall ^= 0 then pc = spc + eb_data_$new_nslsav;
	else pc = spc + eb_data_$nslsav;
	if (tprot = 1) then pc = pc + eb_data_$nmxsav;
	goto label_3010;

/* segdef pseudo-operation, ignored in pass1. */

label_vector (42):		/* segdef */
label_2900: 
	goto label_3010;

/* setlp pseudo-op.... ignored in pass1. */

label_vector (45):		/* setlp */
label_2970: 
	pc = pc + 1;
	goto label_3010;

/* getlp pseudo-operation, calculate linkage pointer using lot (new call/save/return). */

label_vector (49):		/* getlp */
label_getlp:
	pc = spc + eb_data_$new_ngetlp;
	goto label_3010;

label_vector (58):
label_entrybound:
	eb_data_$entrybound_bit = "1"b;
	goto label_3010;

label_vector (9):		/* dup */
label_dup:
	if dup_ptr ^= null () then go to label_3120;
	if varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0 then go to label_3120;
	if iaddr ^= 0 then go to label_3300;
	if value <= 0 then go to label_3120;
	dup_count = value - 1;
	call inputs_$next_statement;
	call inputs_$get_ptr (dup_ptr, dup_start, junk, end_statement_flag);
	go to label_3030;

label_vector (10):		/* dupend */
label_dupend:
	if dup_ptr = null () then go to label_3120;
	call inputs_$get_ptr (temp_ptr, i, j, end_statement_flag);
	if temp_ptr ^= dup_ptr then go to label_3100;
	i = begin_line;			/* Really want beginning of line. */
	call inputs_$next_statement;
	if dup_count > 0 then
	     call alm_include_file_$insert (addr (dup_string (dup_start)), i - dup_start, dup_count);
	dup_ptr = null ();
	go to label_3020;

label_vector (61):
label_ppstatic:
	eb_data_$per_process_static_sw = 1;
	go to label_3020;

label_vector (68):	/* block */
label_vector (69):	/* end_block */
label_vector (70):	/* enum */
label_vector (71):	/* end_enum */
label_vector (72):	/* source */
label_vector (73):	/* end_source */
label_vector (74):	/* statement */
label_vector (75):	/* structure */
label_vector (76):	/* end_structure */
label_vector (77):	/* symbol */
label_vector (78):	/* union */
label_vector (79):	/* end_union */

	goto label_3010;	/* ignored in pass1_ */


label_vector (60):
label_macro:
	call getid_;
	if eb_data_$tsym = 0 then goto label_3100;
	call oplook_$redefine;
	call inputs_$next_statement;
	call mexp_$define_macro (substr (addr (sym (1)) -> acc.string, 1, bin (addr (sym (1)) -> acc.length, 9)));
	go to label_3030;

label_vector (40):
label_maclist:
	go to label_3020;


/* INSTRUCTION PROCESSING BEGINS HERE. */

label_vector (52):		/* rpt, rpd, rpl */
label_repeat:
label_vector (53):		/* awd, swd, abd, sbd, etc. */
label_eis_single:
label_vector (54):		/* mvn, cmpb, ad2d, etc. */
label_eis_multiple:
label_vector (55):		/* desc9a, desc6a, desc4a */
label_eis_desca:
label_vector (56):		/* descb */
label_eis_descb:
label_vector (57):		/* desc9ts, desc4ls, etc. */
label_eis_descn:
label_vector (43):		/* eax, canx, etc. */
label_get_index:
label_vector (44):		/* eap, sprp, etc. */
label_get_base:

/* normal instructions. */

label_vector (0):		/* Normal instruction. */
label_3000: 
	pc = spc + 1;
						/* pseudo-operation re-entry to reset u flag. */

label_3010: 
	prntu = 0;				/* FALSE */
						/* pseudo-operation re-entry with u flag not reset. */

label_3020: 
	call inputs_$next_statement;

label_3030:
	pcblk (1) = utils_$ls (pc,18);
	call utils_$pckflg (pcblk (2));
	pcblk (3) = utils_$ls (curlc,18);
	link = glpl_$setblk (pcblk (1),3);
	ndpcls -> word.right = addr (link) -> word.right;
	ndpcls = ptr (eb_data_$lavptr,link);

	goto label_200;


/* error return for pseudo-operations. */

/* field (f) error. */

label_3100: 
	prntf = 1;				/* TRUE */
	goto label_3010;

/* phase (p) error. */

label_3110: 
	prntp = 1;				/* TRUE */
	goto label_3010;

/* symbol (s) definition error. */

label_3120: 
	prnts = 1;				/* TRUE */
	goto label_3010;

/* undefined (u) symbol error. */

label_3130: 
	prntu = 1;				/* TRUE */
	goto label_3020;	/* next statement */


/* re-entry for undefined pseudo-operations. */

label_3200: 
	prnto = 1;				/* TRUE */
	goto label_3010;

/* re-entry for relocation (r) error. */

label_3300: 
	prntr = 1;				/* TRUE */
	goto label_3010;

     end pass1_;




		    pass2_.pl1                      10/17/88  1013.9rew 10/17/88  0929.5      546507



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




/****^  HISTORY COMMENTS:
  1) change(86-09-30,Oke), approve(86-09-30,MCR7543), audit(86-09-30,JRGray),
     install(86-10-08,MR12.0-1180):
     Allow ALM to support double word constants.
  2) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support severity, *heap references, and the "init_link"
     pseudo.
  3) change(86-11-14,JRGray), approve(86-11-14,MCR7568),
     audit(86-11-21,RWaters), install(86-11-26,MR12.0-1228):
     Also MCR7572. Modified to add support for the three new pseudo-ops:
     ext_extry, oct_unal, and dec_unal.
  4) change(88-08-02,JRGray), approve(88-08-05,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     Modified to support new Symbol Table Pseudo-Ops.
                                                   END HISTORY COMMENTS */


pass2_: 
     procedure( decor,target_value,no_target_given,first_time_thru );  /* decor is passed in from alm_6180_, set in pass1_ ; 
                                                                          target_value and no_target_given come from alm
							    via alm_6180_; first_time_thru comes from alm_6180_ */


/*  pass2 second pass of the Multics assembler for the GE - 645 and Honeywell 6180.  */


/*  pass2 is primarily concerned with generating binary output.
   pass2 processes all operations and pseudo-operations for
   the binary  (text) output that they produce. All such output
   is generated and put out in the output file along with an
   assembly listing. Some pseudo-operations are only concerned
   the generating information about the linkage and are
   treated accordingly. The post - processor will handle the
   external reference information and put out the linkage and symbol
   segments and the linkage part of the text segment.

	Modified to support *heap links by R Gray and W Anderson on 2/05/86.
	Modified for changes requested by MTR 175 on 3/25/81 by EBush
	Modified to implement -target on 2/5/81 by EBush
	Modified for decor pseudo-op on 12/30/80 by E Bush
	Modified for "vfd" pseudo-op on 12/15/75 by Eugene E Wiatrowski
          Modified for prelinking on 06/15/75 by Eugene E Wiatrowski
	Modified on 08/07/73 at 23:58:43 by R F Mabee.
	by RFM in June 1973 to add EIS instructions, etc.
	by RFM on 2 May 1972 adding getlp, short_call, and include pseudo-ops.
	by RFM on 24 March 1972 for new object segment format.
	by RFM on 5 March 1972 to add new call/save/return operators.
	by RHG on 4 June 1971 to fix "rem" pseudo-op
	by RHG 0n 3 June 1971 to fix clearing of flags (upkflg does orsa not sta)
	by RHG on 2 June 1971 to produce "N" flag for "file" pseudo-op
	by RHG on 25 May 1971 to clear flags in rem pseudo-op
	by RHG on 2 May 1971 to fix bug in last_p2pcl initialization
	by RHG on 2 April 1971 to have "eight,sixtyfour,mod" all produce nop's rather than 0's
			   to allow bss ,x where no label is specified before the ,
			   to cause r error when save is given a relocatable arg
			   to clean up the processing of the rem pseudo-op
   R H Campbell, 29 October 1970, for inhibit bit in ITS/ITB pseudo-ops.
   by RHG on 17 Sept 1970 for new listing package
   by RHG on 6 August 1970 at 2321 to not set sthedr from name pseudo-op
   by NA on June 28, 1970 at 2123 for the new CODTAB.
	  */					/*  INCLUDE FILES  */



% include varcom;

% include concom;

% include erflgs;

% include codtab;

% include alm_prototypes;

% include relbit;

% include labarg;

% include alm_lc;

% include sthedr;

% include alm_options;

% include alm_data;

	/*  END OF THE INCLUDE FILES  */		/*    */

/*  PARAMETERS */

dcl       decor fixed bin(35); /* passed from  alm_6180_, set in pass1_ */
dcl	target_value  fixed bin(17);
dcl	(no_target_given,first_time_thru) bit(1);


/* CONDITIONS */

dcl	cleanup condition;


/*  BASED STORAGE DECLARATIONS  */

 dcl	long_int_based fixed bin(71) based unaligned;

 dcl	1 word based aligned,
	  2 (left, right) bit (18) unaligned;

 dcl	1 glpl_words (0:262143) based (eb_data_$lavptr) aligned,
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;

 dcl	1 acc_string based ( addr (sym (1))) aligned,
	  2 length fixed bin (9) unsigned unaligned,
	  2 chars char (acc_string.length) unaligned;

 dcl	1 opcode_overlay based aligned,
	  2 filler bit (18) unaligned,
	  2 opcode bit (10) unaligned,
	  2 flags bit (4) unaligned,		/*  Any value pass2_ might need.  */
	  2 iclass bit (4) unaligned;		/*  Intersection of decors in which it is valid */

 dcl      1 descop_overlay based aligned,
            2 filler bit(24) unaligned,
	  2 format bit(4)  unaligned,
	  2 flags  bit(4)  unaligned,
	  2 decor  bit(4)  unaligned;

/*  EXTERNAL ENTRIES USED BY PASS2  */

dcl  alm_symtab_$block entry(char(*)),
     alm_symtab_$cleanup entry,
     alm_symtab_$end_block entry,
     alm_symtab_$end_enum entry,
     alm_symtab_$end_source entry,
     alm_symtab_$end_structure entry,
     alm_symtab_$end_union entry,
     alm_symtab_$enum entry(char(*)),
     alm_symtab_$initialize entry,
     alm_symtab_$source entry(char(*), bit(36) aligned, fixed bin(71)),
     alm_symtab_$statement entry(fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26)),
     alm_symtab_$structure entry(char(*)),
     alm_symtab_$symbol entry(char(*), char(*), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26), fixed bin(26)),
     alm_symtab_$union entry(char(*)),
     getid_$getid_ ext entry,
     getid_$getnam ext entry,
     getid_$setid ext entry (fixed bin (26)),
     getbit_$getbit_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     inputs_$next ext entry,
     inputs_$nxtnb ext entry,
     inputs_$next_statement ext entry,
     inputs_$next_statement_nolist ext entry,
     litevl_$itbevl ext entry (fixed bin (26), fixed bin (26)),
     utils_$upkflg ext entry (fixed bin),
     utils_$abort ext entry,
     litevl_$itsevl ext entry (fixed bin (26), fixed bin (26)),
     litevl_$litasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     prwrd_$source_only ext entry,
     prnter_$prnter_ ext entry (char (*)),
     putout_$putwrd ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     prwrd_$prwrd_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
     putout_$putlst ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26), fixed bin (26)),
     glpl_$slwrd ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
     glpl_$storl ext entry (fixed bin (26), fixed bin (26)),
     glpl_$storr ext entry (fixed bin (26), fixed bin (26));
 dcl	alm_include_file_$pass2 ext entry,
	alm_include_file_$insert ext entry (ptr, fixed bin (26), fixed bin (26)),
	alm_include_file_$pop ext entry,
	expand_pathname_$component entry(char(*), char(*), char(*), char(*), fixed bin(35)),
	initiate_file_$component entry(char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
	inputs_$get_ptr entry (ptr, fixed bin (26), fixed bin (26), bit (1) aligned),
	mexp_	 ext entry (char (*), fixed bin (17), fixed bin(17), bit(1), bit(1)),
	mexp_$define_macro ext entry (char (*)),
	oplook_$reset ext entry,
	oplook_$redefine  entry,
	system_type_   entry (char(*), char(*), fixed bin, fixed bin(35)),
	terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35)),
	translator_info_$component_get_source_info entry(ptr, char(*), char(*), char(*), fixed bin(71), bit(36) aligned, fixed bin(35));

/*  EXTERNAL FUNCTIONS CALLED BY PASS2  */

dcl (ascevl_$accevl ext entry (fixed bin (26)),
     ascevl_$acievl ext entry (fixed bin (26)),
     ascevl_$ac4evl ext entry (fixed bin (26)),
     ascevl_$bcdevl ext entry (fixed bin (26)),
     expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
     lstman_$blkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     glpl_$cwrd ext entry (fixed bin (26)),
     glpl_$glwrd ext entry (fixed bin (26), fixed bin (26)),
     decevl_$decevl_ ext entry (fixed bin (26), fixed bin (26)),
     lstman_$eptasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26), fixed bin (26)),
     utils_$exadrs ext entry (fixed bin (26), fixed bin (26)),
     lstman_$lnkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     lstman_$outasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
     lstman_$calser ext entry (fixed bin (26), fixed bin (26)),
     lstman_$sdfasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26), fixed bin (26)),
     lstman_$namasn ext entry (fixed bin (26)),
     utils_$rs ext entry (fixed bin (26), fixed bin (26)),
     utils_$and ext entry (fixed bin (26), fixed bin (26)),
     utils_$makins ext entry (fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26), fixed bin (26)),
     octevl_$octevl_ ext entry (fixed bin (26)),
     oplook_$oplook_ ext entry (fixed bin, fixed bin (26)),
     table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26)),
     lstman_$trpasn ext entry (fixed bin (26), fixed bin (26)),
     varevl_$varevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
     fixed bin (26), fixed bin (26)),
     vfdevl_$vfdevl_ ext entry (fixed bin (26), fixed bin (26)),
     vfdevl_$vfdcnt ext entry (fixed bin (26), fixed bin (26))
     ) returns (fixed bin (26));
 dcl	alm_eis_parse_$descriptor ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin  (26)),
	alm_eis_parse_$instruction ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin  (26));

/*  AUTOMATIC VARIABLES  */

dcl (rleft, rright, rslts (128), binop, flags, basno, value, b29, admod, class, instruction_class,
     type, xnlnk, ptrarg, ptrcal, trplnk, blklnk, symlnk, zleft, zright, rrslts (128), option,
     argout, traout, tderr, tbss, tlc, i, iaddr, ik, iloc, irtblk, itemp, itype, j, junk,
     k, lcl, lcloc, lcr, link, lnkorg, lpaswd, n, name, nobits, nowrds, last_p2pcl) fixed bin (26);

 dcl	link_not_found bit(1);
 dcl	termination_conditions bit (7);
 dcl	full_word_temp fixed bin (26);
 dcl	stkclst fixed bin(26);	/* used to remember calculated stackframe sizes */
 dcl	dup_ptr ptr init (null ()),
	temp_ptr ptr,
	dup_count fixed bin (26),
	dup_start fixed bin (26),
	dup_string (0:262143) char (1) unal based (dup_ptr),
	tmacl bit (2) aligned,
	operand char(32) varying,
	canonical_operand char(24),
	code	fixed bin(35),
	unique_id	bit(36) aligned,
	dtcm fixed bin(71),
	(path, var_name, var_type) char(256) varying,
	(st_offset, st_length, st_line, st_num) fixed bin(26);

dcl  trprtn label local;

dcl	label_flag bit (1) aligned;
dcl	end_statement_flag bit (1) aligned;

/*  EXTERNAL STATIC VARIABLES IN THE ASSEMBLER'S DATA SEGMENT  */

dcl (eb_data_$unwind (3), eb_data_$atext (2), eb_data_$alink (2), eb_data_$asym (2), eb_data_$astat (2), eb_data_$asys (2),
     eb_data_$aheap (2),
     eb_data_$mstaq, eb_data_$ion, eb_data_$ioff, eb_data_$mx7, eb_data_$ib6,
     eb_data_$isave, eb_data_$irestore, eb_data_$iobject,
     eb_data_$nmxsav, eb_data_$tsym, eb_data_$anl) ext fixed bin (26),
     eb_data_$rpt_terminators (7) external fixed bin (35);		/*  Contain three-letter ACC names.  */
 dcl	eb_data_$lavptr external pointer;
dcl	eb_data_$entry_bound ext fixed bin(26);
dcl	eb_data_$macro_depth ext fixed bin (26),
	eb_data_$macro_listing_control bit (36) aligned ext;

	/* fixed bin sym code for 'function' */
dcl	(ifun1 init(1100540526), ifun2 init(13318017647), ifun3 init(14763950080))
	     int static options(constant) fixed bin(35);




/*  entry to subroutine, set up variables before main loop.  */

label_100: 
	pc = 0;








/*  clear buffer for relocation bits  */

label_110: 

	rrslts (*) = 0;	/*initialize*/
	curlc = lptext;
	tvorg = fixed (glpl_words (lptv + 3).left, 18);
	lnkorg = fixed (glpl_words (lpsect + 3).left, 18);
	call glpl_$storr (lplit + 1, litc);
on	cleanup	call alm_symtab_$cleanup;
	call alm_symtab_$initialize;
	litorg = fixed (glpl_words (lplit + 3).left, 18);
	lreter = fixed (glpl_words (lpcall + 3).left, 18);

	/* retrieve remembered value of stackframe size */
	stkclst = stkc;	/* stkc is used to pass this value from pass1 */
	stkc = fixed(glpl_words(stkclst).left);
	stkclst = fixed(glpl_words(stkclst).right);

	stkc = 16 * (divide (stkc + 15, 16, 17, 0));
	p2pcl = pclst;
	binlin = 1;
	eb_data_$macro_listing_control = (36)"0"b;
	call oplook_$reset;

/*  main loop re - entry, setup flags and check symbol assignment.  */

label_200: 
	spc = pc;
	tpc = fixed (glpl_words (p2pcl).left, 18);
	tlc = fixed (glpl_words (p2pcl + 2).left, 18);
	call utils_$upkflg (glpl_$cwrd (p2pcl + 1));
	last_p2pcl = p2pcl;
	p2pcl = fixed (glpl_words (p2pcl).right, 18);
	value = 0;

	label_flag = ""b;
label_220: 
	brk (1) = isp;
	call getid_$getid_;
	if (brk (1) ^= icol) then go to label_300;
	if (eb_data_$tsym ^= 0) then if (table_$table_ (iassgn, sym (1), pc, flocrf, curlc) = 0) then prnts = 1;
	label_flag = "1"b;
	go to label_220;

/*  get operator and test for pseudo operation.  */

label_300: 
	if eb_data_$tsym ^= 0 then go to label_301;
	if brk (1) = inl then go to label_870;
	if brk (1) = iquot then go to label_870;
label_301: 
	binop = oplook_$oplook_ (prnto, itype);
	if prnto ^= 0 then do;
	     call mexp_ (addr (sym (1)) -> acc_string.chars, prnto, target_value, no_target_given,first_time_thru);
	     if prnto ^= 0 then go to label_3200;
	     else go to label_200;
	end;
	if (brk (1) = isp | brk (1) = inl) then go to label_305;

/*  there was an illegal character after the op or pseudo-op  */
	prnto = 1;
	go to label_3200;

label_305:
	instruction_class = fixed (addr (binop) -> opcode_overlay.iclass, 4);
	if ^data2.compatible(instruction_class,decor)
	    then prntb = 1;
 
	go to label_vector (itype);



/*  control group of pseudo operations.  */

/*  end pseudo-operation, scan to end of card, and return to caller.  */


label_vector (1):		/*  end  */
label_450: 

	if label_flag then call prwrd_$prwrd_(spc+fixed (glpl_words(curlc+3).left, 18),0,ibb); else call prwrd_$source_only;
	return;

/*  include statement, use new source file.  */

label_vector (50):		/*  include  */
label_include:
	call getid_$getid_ ();
	if eb_data_$tsym = 0 then goto label_3100;
	call prwrd_$source_only ();
	call inputs_$next_statement ();
	call alm_include_file_$pass2 ();
	goto label_220;

/*  use pseudo-operation, use another location counter.  */

label_vector (2):		/*  use  */
label_500: 

	call getid_$getid_;
	if (eb_data_$tsym = 0) then go to label_3100;

/*  save current value of old location counter.  */
	call glpl_$storr (curlc + 1, pc);

/*  use new lc as the current lc.  */
	if (table_$table_ (iserch, sym (1), pc, fmlcrf, curlc) ^= 0) then go to label_3010;
	call prnter_$prnter_ ("fatal error in PASS2 in symbol table search for USE lc");
	call utils_$abort;


/*  org pseudo-operation. set the value of the pc.  */

label_vector (3):		/*  org  */
label_525: 

	if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3110;
	if (iaddr ^= 0) then go to label_3300;
	pc = value;
	go to label_3200;

/*  join pseudo-op. ignored in pass2.  */

label_vector (4):		/*  join  */
label_550: 

	go to label_3010;

/*  even pseudo-operation, force pc to even location.  */

label_vector (5):		/*  even  */
label_600: 

	if (mod (spc, 2) ^= 0) then
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	go to label_3010;

/*  odd pseudo-operation, force pc to odd location.  */

label_vector (6):		/*  odd  */
label_630: 

	if (mod (spc, 2) = 0) then
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	go to label_3010;

/*  eight pseudo-operation, force pc to zero mod eight.  */

label_vector (7):		/*  eight  */
label_660: 

	if (mod (pc, 8) = 0) then go to label_3010;
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	go to label_660;

/*  sixtyfour pseudo-operation, force pc to zero mod 64.  */

label_vector (8):		/*  sixtyfour  */
label_680: 

	if (mod (pc, 64) = 0) then go to label_3010;
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	go to label_680;

/*  movdef pseudo-operation. ignored in pass two.  */

label_vector (11):		/*  movdef  */
label_755: 
label_vector (61):		/* ppstatic */

	go to label_3300;



/* decor pseudo-operation:  just like pass1_ */

label_vector (62):             /* decor */
label_decor:

          call getid_$getid_();
	operand = addr(sym(1)) -> acc_string.chars;
	call system_type_((operand),canonical_operand,(0),code);
	if code ^=0
	   then prntf = 1;
	else do;
	          do n = 1 to hbound(data1.decor,1) while(rtrim(canonical_operand) ^= data1.decor(n).name);
	          end;
		decor = data1.decor(n).number;
	     end;

	goto label_3300;


/* error pseudo-operation, sets fatal error flag, causing "Translation failed" message. */

label_vector (63):		/* error */
label_error:
	tfatal = 3;	/* severity 3 error */
	goto label_3300;



/*  firstref pseudo-operation, first reference trap procedure specified.  */

label_vector (48):		/*  firstref  */
label_firstref:
	if tfirstreftrap ^= 1 then prntp = 1;
	if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
	if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
	if first_ref_trap_proc_linkno ^= value then prntu = 1;
	first_ref_trap_proc_linkno = first_ref_trap_proc_linkno + fixed (glpl_words (lpsect + 3).left, 18);
	if brk (1) = ilpar then do;
		if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120;
		if b29 = 0 then value = lstman_$lnkasn (myblk, value, admod, iaddr);
		if first_ref_trap_arg_linkno ^= value then prntu = 1;
		first_ref_trap_arg_linkno = first_ref_trap_arg_linkno + fixed (glpl_words (lpsect + 3).left, 18);
		end;
	else if first_ref_trap_arg_linkno ^= 0 then prntu = 1;
	goto label_3300;

/*  inhibit pseudo-operation, set inhibit mode on or off.  */

label_vector (12):		/*  inhibit  */
label_760: 

	call getid_$getid_;
	if (eb_data_$tsym = 0) then go to label_765;
	if (sym (1) = eb_data_$ion) then go to label_770;
	if (sym (1) = eb_data_$ioff) then go to label_775;
	prntf = 1;
	go to label_3300;


label_765: 

	if tinhib = 1 then
	tinhib = 0;
	else tinhib = 1;
	go to label_3300;


label_770: 

	tinhib = 1;
	go to label_3300;


label_775: 

	tinhib = 0;
	go to label_3300;

/*  name pseudo-operation, ignored in pass2.  */

label_vector (14):		/*  name  */
label_820: 

	goto label_3300;

/*  null pseudo-operation, print location only.  */

label_vector (15):		/*  null  */
label_850: 

	go to label_3300;

/*  rem pseudo-operation, print no octal listing.  */

label_vector (16):		/*  rem  */
label_870: 

	if label_flag then goto label_850;
	do i = 1 to 36;	/*  clear all the flags  */
	     flgvec(i) = 0;
	end;
	p2pcl = last_p2pcl;
	go to label_3040;


/*  symbol defining pseudo-operations.  */

/*  basref pseudo-operation, check definitions of pass1.  */

label_vector (17):		/*  basref  */
label_900: 

	call getid_$getid_;
	if (eb_data_$tsym = 0) then go to label_910;
	if (table_$table_ (iserch, sym (1), value, clbas, junk) ^= 0) then go to label_915;

label_905: 

	do i = 1 to 8;
	     if (sym (1) ^= symbas (i)) then
	     go to label_905a;
	     value = i - 1;
	     go to label_915;

label_905a:    

	end label_905;
	if (table_$table_ (iserch, sym (1), basno, clint, junk) ^= 0) then go to label_915;
	go to label_3130;


label_910: 

	if (varevl_$varevl_ (invrvp, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	if (iaddr ^= 0) then go to label_3300;


label_915: 

	link = utils_$exadrs (value, 0);
	type = 2;
	class = fbasrf;

/*  re - entry from segref pseudo-operation.  */

label_920: 

	call getid_$getid_;
	xnlnk = lstman_$namasn (sym (1));

label_930: 

	trprtn = label_970;
	tderr = 0;
	trplnk = 0;

label_933: 

	if (brk (1) ^= ilpar) then go to label_970;
	ptrcal = 0;
	ptrarg = 0;
	if (varevl_$varevl_ (ixvrvl, basno, ptrcal, admod, b29, iaddr) ^= 0) then go to label_935;
	tderr = 1;
	go to label_945;

label_935: 

	if (b29 ^= 0) then go to label_945;
	if tprot = 1 then go to label_940;
	ptrcal = lstman_$lnkasn (myblk, ptrcal, admod, iaddr);
	go to label_945;

label_940: 

	ptrcal = lstman_$eptasn (ptrcal, 0, mylnk, curlc, 0, 1);

label_945: 

	if (brk (1) ^= ilpar) then go to label_960;
	if (varevl_$varevl_ (ixvrvl, basno, ptrarg, admod, b29, iaddr) ^= 0) then go to label_950;
	tderr = 1;
	go to label_955;

label_950: 

	if (b29 = 0) then
	ptrarg = lstman_$lnkasn (myblk, ptrarg, admod, iaddr);

label_955: 

	if (brk (1) = irpar) then
	call inputs_$next;

label_960: 

	if (brk (1) = irpar) then go to label_965;
	tderr = 1;
	go to trprtn;

label_965: 

	call inputs_$next;
	if (tderr ^= 0) then go to trprtn;
	trplnk = lstman_$trpasn (ptrcal, ptrarg);
	go to trprtn;


label_970: 

	if (tderr = 0) then go to label_975;
	prntf = 1;
	go to label_980;

label_975: 

	if (table_$table_ (iassgn, fixed (glpl_words (xnlnk).left, 18), lstman_$blkasn (type, link, xnlnk, trplnk), class,
	junk) = 0) then
	prnts = 1;

label_980: 

	if (brk (1) = icomma) then go to label_920;
	go to label_3300;

/*  bool pseudo-operation, check boolean symbol assignment.  */

label_vector (18):		/*  bool  */
label_1000: 

	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
	if (varevl_$varevl_ (ibvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	if (iaddr ^= 0) then go to label_3300;
	if (table_$table_ (iassgn, symlnk, value, fbolrf, junk) = 0) then go to label_3120;
	go to label_3200;

/*  equ pseudo-operation, check arithmetic symbol assignment.  */

label_vector (19):		/*  equ  */
label_1100: 

	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
	if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	class = fequrf;
	if (iaddr ^= 0) then
	class = flocrf;
	if (table_$table_ (iassgn, symlnk, value, class, iaddr) = 0) then go to label_3120;
	if (iaddr = 0) then go to label_3200;

/*  set value to absolute value.  */
	value = value + fixed (glpl_words (iaddr + 3).left, 18);
	go to label_3200;

/*  link pseudo-operation, check link number assignment.  */

label_vector (20):		/*  link  */
label_1200: 

	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
	if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	if (b29 = 0) then
	value = lstman_$lnkasn (myblk, value, admod, iaddr);
	if (table_$table_ (iassgn, symlnk, value, flocrf, lpsect) = 0) then go to label_3120;

/*  set value to its absolute value for printing.  */
	value = value + fixed (glpl_words (lpsect + 3).left, 18);
	go to label_3200;

/*  init_link pseudo-operation, associate init info with link.  */

label_vector (65):		/*  init_link	name, extexpression  */

	call getid_$getid_;
          if (eb_data_$tsym = 0) then go to label_3100;
	if (table_$table_ (iserch, sym(1), value, flocrf, lcloc) = 0) then go to label_3130;
          if (brk(1) ^= icomma) then go to label_3100;
	itemp = value + fixed(glpl_words(lcloc+3).left,18);
	if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	j = lnklst; /* search for the appropriate link */
          link_not_found = "1"b;
          i = 1;
          do while (link_not_found);
             if (fixed(glpl_words(j).left,18) = 2) then 
     	      j = fixed(glpl_words(j).right, 18);
             else do;
                if (i <= value/2) then do;
        	         j = fixed(glpl_words(j).right, 18);
                   i = i + 1;
                   end;
                else link_not_found = "0"b; 
                end;
             end;
	j = fixed(glpl_words(j+1).left, 18); /* find expression word */
	j = fixed(glpl_words(j+1).left, 18); /* find type pair */
	glpl_words(j+1).right = bit(fixed(itemp+1, 18), 18); /* set init label to loc + 1 */
          
	go to label_3200;

/*  set pseudo-operation, assign resettable equivalence.  */

label_vector (21):		/*  set  */
label_1250: 

	call getid_$setid (symlnk);
	if (brk (1) ^= icomma | symlnk = 0) then go to label_3100;
	if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3120;
	if (iaddr ^= 0) then go to label_3300;
	if (table_$table_ (iassgn, symlnk, value, fsetrf, junk) = 0) then go to label_3120;
	go to label_3200;

/*  segref pseudo-operation, check definitions of pass1.  */

label_vector (22):		/*  segref  */
label_1300: 

	call getid_$getnam;
	if (brk (1) ^= icomma) then go to label_3100;
	class = fsegrf;
	if (sym (1) ^= eb_data_$atext (1) | sym (2) ^= eb_data_$atext (2)) then go to label_1310;
	type = 5;
	link = 0;
	go to label_920;

label_1310: 

	if (sym (1) ^= eb_data_$alink (1) | sym (2) ^= eb_data_$alink (2)) then go to label_1320;
	type = 5;
	link = 1;
	go to label_920;

label_1320: 

	if (sym (1) ^= eb_data_$asym (1) | sym (2) ^= eb_data_$asym (2)) then go to label_1330;
	type = 5;
	link = 2;
	go to label_920;

label_1330: 

	if (sym (1) ^= eb_data_$astat (1) | sym (2) ^= eb_data_$astat (2)) then go to label_1340;
	type = 5;
	link = 4;
	go to label_920;

label_1340: 

	if (sym (1) ^= eb_data_$asys (1) | sym (2) ^= eb_data_$asys (2)) then go to label_1350;
	type = 5;
	link = 5;
	go to label_920;

label_1350: 
	if (sym (1) ^= eb_data_$aheap (1) | sym (2) ^= eb_data_$aheap (2)) then go to label_1360;
	type = 5;
	link = 6;
	go to label_920;

label_1360: 

	type = 4;
	link = lstman_$namasn (sym (1));
	go to label_920;

/*  temp and tempd pseudo-operations, ignored in pass2.  */

label_vector (23):		/*  temp  */
label_1400: 


label_vector (24):		/*  tempd  */
label_1500: 

	go to label_3010;

label_vector (25):		/*  temp8  */
label_1505: 

	go to label_3010;


/*  generative class of pseudo-operations.  */

/*  acc and aci pseudo-operations, ascii code generators.  */
/*  also bci pseudo-operation to generate 6-bit character codes.  */
/*  absolute relocation bits always  */

label_vector (26):		/*  acc  */
label_1600: 
	n = ascevl_$accevl (rslts (1));
	go to label_1710;

label_vector (27):		/*  aci  */
label_1700: 
	n = ascevl_$acievl (rslts (1));
	goto label_1710;

label_vector (13):		/*  bci  */
label_bci:
	n = ascevl_$bcdevl (rslts (1));
	go to label_1710;

label_vector (59):
label_ac4:
	n = ascevl_$ac4evl (rslts (1));

label_1710: 
	do i = 1 to n;
	     rrslts (i) = 0;
	end label_1710;
	call putout_$putlst (pc, rslts (1), i3333, n, rrslts (1));
	go to label_3010;

/*  dec pseudo-operation, integer, fixed, and floating point.  */
/*  absolute relocation bits always.  */

label_vector (28):		/*  dec  */
label_1800: 

	n = decevl_$decevl_ (rslts (1), type);
	if (n >= 2 & mod (pc, 2) ^= 0) then
	call putout_$putwrd (pc, 0, i66, 0);
	rrslts (1) = 0;
	rrslts (2) = 0;
	call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
	if (brk (1) = icomma) then go to label_1800;
	go to label_3010;

/*  dec_unal pseudo-operation, integer, fixed, and floating point unaligned.  */
/*  absolute relocation bits always.  */

label_vector (66):		/*  dec_unal  */
label_1801: 

	n = decevl_$decevl_ (rslts (1), type);
	rrslts (1) = 0;
	rrslts (2) = 0;
	call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
	if (brk (1) = icomma) then go to label_1801;
	go to label_3010;

/*  oct pseudo-operation, octal number generator.  */
/*  absolute relocation bits always.  */

label_vector (29):		/*  oct  */
label_1900: 

	n = octevl_$octevl_ (rslts (1));
	if (n >= 2 & mod (pc, 2) ^= 0) then
	call putout_$putwrd (pc, 0, i66, 0);
	rrslts (1) = 0;
	rrslts (2) = 0;
	call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
	if (brk (1) = icomma) then go to label_1900;
	go to label_3010;

/* oct_unal pseudo-operation, unaligned octal number generator.  */
/*  absolute relocation bits always.  */

label_vector (67):		/* oct_unal  */
label_1901: 

	n = octevl_$octevl_ (rslts (1));
	rrslts (1) = 0;
	rrslts (2) = 0;
	call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
	if (brk (1) = icomma) then go to label_1901;
	go to label_3010;

/*  vfd pseudo-operation, variable field data generator.  */

label_vector (30):		/*  vfd  */
label_2000: 

	prnte = 0;

label_2001: 

          rrslts(*) = 0;
	n = vfdevl_$vfdevl_ (rslts (1), flags);
	if (flags = 0) then go to label_2015;

label_2010: 

	do k = 1 to n;
	     lcl = fixed (glpl_words (flags + k - 1).left, 18);
	     lcr = fixed (glpl_words (flags + k - 1).right, 18);
	     zleft = utils_$rs (rslts (k), 18);
	     zright = utils_$and (rslts (k), sixsev);
	     rleft = 0;
	     rright = 0;
	     if (lcl = 0) then
	     go to label_2003;
	     zleft = zleft + fixed (glpl_words (lcl + 3).left, 18);
	     call getbit_$getbit_ (lcl, 0, 0, rleft);

label_2003:    

	     if (lcr = 0) then
	     go to label_2005;
	     zright = zright + fixed (glpl_words (lcr + 3).left, 18);
	     call getbit_$getbit_ (lcr, 0, 0, rright);

label_2005:    

	     rslts (k) = glpl_$glwrd (zleft, zright);
	     rrslts (k) = glpl_$glwrd (rleft, rright);
	end label_2010;

label_2015: 

	call putout_$putlst (pc, rslts (1), i66, n, rrslts (1));
	go to label_3010;

/*  mod pseudo-operation. force the location counter mod expression.  */

label_vector (31):		/*  mod  */
label_2020: 

	call getid_$getid_;
	junk = expevl_$expevl_ (0, value, iaddr);
	if iaddr ^= 0 then prntr = 1;

label_2025: 

	if (mod (pc, value) = 0) then go to label_3010;
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	go to label_2025;


/*  storage allocating pseudo-operations.  */

/*  bfs pseudo-operation, block followed by symbol.  */

label_vector (32):		/*  bfs  */
label_2100: 

	tbss = 0;
	go to label_2210;

/*  bss pseudo-operation, block started by symbol.  */

label_vector (33):		/*  bss  */
label_2200: 

	tbss = 1;

label_2210: 

	call getid_$setid (symlnk);
	if (brk (1) ^= icomma) then go to label_3100;
	if (varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then go to label_3110;
	if (iaddr = 0) then go to label_2220;
	prntr = 1;
	go to label_3120;

label_2220: 

	pc = spc + value;
	if (b29 ^= 0 ) then prntf = 1;
	value = pc;
	if (tbss = 1) then
	value = spc;
	if symlnk ^= 0 then if (table_$table_ (iassgn, symlnk, value, flocrf, curlc) = 0) then prnts = 1;
	call prwrd_$prwrd_ (value + fixed (glpl_words (curlc + 3).left, 18), 0, ibb);
	go to label_3010;

/*  zero pseudo-operation, generate double address word.  */

label_vector (34):		/*  zero  */
label_2350: 

	junk = varevl_$varevl_ (invrvl, basno, zleft, admod, b29, iaddr);
	call getbit_$getbit_ (iaddr, basno, b29, rleft);
	if (iaddr ^= 0) then
	zleft = zleft + fixed (glpl_words (iaddr + 3).left, 18);
	rright, zright = 0;
	if (brk (1) = icomma) then
	do;
	     junk = varevl_$varevl_ (invrvl, basno, zright, admod, b29, iaddr);
	     call getbit_$getbit_ (iaddr, basno, b29, rright);
	     if (iaddr ^= 0) then
	     zright = zright + fixed (glpl_words (iaddr + 3).left, 18);
	end;
	call putout_$putwrd (pc, glpl_$glwrd (zleft, zright), i66, glpl_$glwrd (rleft, rright));
	go to label_3010;

/*  itb pseudo-operation, generate link pair.  */

label_vector (35):		/*  itb  */
label_2400: 

	call litevl_$itbevl (rslts (1), rrslts (1));
	go to label_2455;

/*  its pseudo-operation, generate link pair.  */

label_vector (36):		/*  its  */
label_2450: 

	call litevl_$itsevl (rslts (1), rrslts (1));

label_2455: 

	if (mod (spc, 2) ^= 0) then
	call putout_$putwrd (pc, (mnopdu), i642, 0);
	call putout_$putlst (pc, rslts (1), i66, 2, rrslts (1)); /*  I66 format is fudge to avoid inhibit bit.  */
	go to label_3010;


/*  subroutine linkage pseudo-operations.  */

/*  call pseudo-operation, call subroutine with args and returns.  */

label_vector (37):		/*  call  */
label_2500: 

	junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
	call getbit_$getbit_ (iaddr, basno, b29, rleft);

	addr (nslbit (5)) -> word.left , addr (new_nslbit (3)) -> word.left = addr (rleft) -> word.right;

	if (iaddr ^= 0) then
	value = value + fixed (glpl_words (iaddr + 3).left, 18);
	traout = utils_$makins (basno, value, mtra, b29, admod);
	new_slcall (3) = utils_$makins (basno, value, new_slcall (3), b29, admod);
	if (brk (1) = ilpar) then go to label_2510;
	call litevl_$litasn (value, dzero (1), 2, 0);
	argout = utils_$makins (0, value + fixed (glpl_words (lplit + 3).left, 18), meapap, 0, 0);
	nslbit (3), new_nslbit (2) = iltext;
	go to label_2520;

label_2505: 


/*  mm/xo call with no args  */
/*  ap points to  */
	argout = utils_$makins (6, 30, meapap, 1, 0);
	nslbit (3), new_nslbit (2) = iltext;
	go to label_2520;

label_2510: 

	junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
	call getbit_$getbit_ (iaddr, basno, b29, rleft);

	addr (nslbit (3)) -> word.left, addr (new_nslbit (2)) -> word.left = addr (rleft) -> word.right;

	if (iaddr ^= 0) then
	value = value + fixed (glpl_words (iaddr + 3).left, 18);
	argout = utils_$makins (basno, value, meapap, b29, admod);

label_2520: 

	if (tstsw (1) ^= 0) then go to label_2550;
	slcall (3), new_slcall (2) = argout;
	slcall (5) = traout;
	if tnewcall ^= 0 then call putout_$putlst (pc, new_slcall (1), i642, new_nslcal, new_nslbit (1));
	else call putout_$putlst (pc, slcall (1), i642, nslcal, nslbit (1));
	go to label_3140;

/*  mastermode calls changed per bd.7.03, july 14, 1967.  */
/*  lpaswd is simply the transfer vector number as a literal.  */
/*  the call is made from text segment.  */
/*  return is made to the link segment.  */
/*  j.d.mills 12 july 67  (please compare dates.)  */


label_2550: 

	j = lstman_$calser (spc, link);
	link = link + fixed (glpl_words (lpsect + 3).left, 18);
	call litevl_$litasn (lpaswd, fixed (glpl_words (j + 2).right, 18), 1, 0);
	mxcall (3) = utils_$makins (lp, link, meapap, 1, 0);
	mxcall (5) = argout;
	mxcbit (5) = nslbit (3);
	mxcall (7) = utils_$makins (0, lpaswd + fixed (glpl_words (lplit + 3).left, 18), mldq, 0, 0);
	mxcall (11) = traout;
	mxcbit (11) = nslbit (5);
	call putout_$putlst (pc, mxcall (1), i642, nmxcal, mxcbit (1));

	mxclbk (2) = utils_$makins (0, lpaswd + fixed (glpl_words (lplit + 3).left, 18), mcmpq, 0, 0);
	mxlbit (2) = iltext;
	mxclbk (3) = utils_$makins (0, lreter, mtnz, 0, 0);
	mxlbit (3) = iltext;
	call putout_$putlst (pc, mxclbk (1), i642, nmxclb, mxlbit (1));
	go to label_3140;

/*  short_call pseudo-operation, call without saving any registers.  */

label_vector (51):		/*  short_call  */
label_short_call:	/*  AP already set to arg list.  */
	junk = varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr);
	call getbit_$getbit_ (iaddr, basno, b29, rleft);
	addr (short_nslbit (1)) -> word.left = addr (rleft) -> word.right;
	if iaddr ^= 0 then value = value + fixed (glpl_words (iaddr + 3).left, 18);
	short_slcall (1) = utils_$makins (basno, value, short_slcall (1), b29, admod);
	call putout_$putlst (pc, short_slcall (1), i642, short_nslcal, short_nslbit (1));
	goto label_3140;

/*  entry pseudo-operation, enter symbol into entry point table.  */

label_vector (38):		/*  entry  */
label_2600: 

	call getid_$getid_;
	if (eb_data_$tsym = 0) then go to label_3100;
	if (table_$table_ (iserch, sym (1), value, flocrf, lcloc) = 0) then go to label_3130;
	link = mylnk;
	name = lstman_$namasn (sym (1));

/*  ft2 has xr7 modif.  -  int expr. word has  */
/*  absol 0  (no location counter) for a value.  */
	if (tprot = 0) then if tnewobject = 0 then
	link = lstman_$lnkasn (lstman_$blkasn (1, fixed (glpl_words (lcloc + 4).right, 18), 0, 0), 0, eb_data_$mx7, 0);
	else link = 0;
	trplnk = 0;
	if (brk (1) ^= ilpar) then go to label_2620;
	tmvdef = 1;
	tderr = 0;
	trprtn = label_2610;
	go to label_933;

label_2610: 

	if (tderr ^= 0) then
	prntf = 1;

label_2620: 

	class = 1;
	if (brk (1) ^= ilsb) then go to label_2640;
	call getid_$getid_;
	if (expevl_$expevl_ (0, class, iaddr) = 0) then
	prntr,prntf = 1;
	if (iaddr ^= 0) then
	prntr = 1;
	if (brk (1) = irsb) then go to label_2630;
	prntf = 1;
	go to label_2640;

label_2630: 

	call inputs_$next;

label_2640: 

	junk = lstman_$eptasn (value, name, link, lcloc, trplnk, class);
	if (brk (1) = icomma) then go to label_2600;
	if (lcloc = 0) then go to label_3200;
	value = value + fixed (glpl_words (lcloc + 3).left, 18);
	go to label_3200;

/* ext_entry pseudo_operation Usage: ext_entry elabel,stackframe_size,clabel,dlabel,function */

label_vector (64):
label_2641:
	call getid_$getid_;
	if eb_data_$tsym = 0 then goto label_3100;	/* field error */
	j = bin("000240000"b3, 26);	/* default entry seq flags: rev1, variable */

	/* retrieve calculated stackframe size */
	stkc = fixed(glpl_words(stkclst).left);
	stkclst = fixed(glpl_words(stkclst).right);
	i = stkc;	/* use calculated value as default stackframe size */

	if table_$table_(iserch, sym(1), value, flocrf, lcloc) = 0 then goto label_3130; /* undefined error */
	if lcloc = 0 then goto label_3200;
	value = value + fixed(glpl_words(lcloc+3).left, 18); /* addr(elabel) */
	name = lstman_$namasn(sym(1));
	if brk(1) ^= icomma then goto label_2642;	/* emit code */
	/* second arg stackframe size */
	junk = varevl_$varevl_(invrvl, basno, k, admod, b29, iaddr);
	if junk ^= 0 & k ^= 0 then i = k;
	if iaddr ^= 0 then prntr = 1;
	if brk(1) ^= icomma then goto label_2642;	/* emit code */
	call getid_$getid_;
	/* third argument clabel, skip in this pass */
	if brk(1) ^= icomma then goto label_2642;	/* emit code */
	call getid_$getid_;
	/* fourth argument descriptor label */
	if sym(1) ^= 0 then do;
	     if table_$table_(iserch, sym(1), j, flocrf, iaddr) = 0 then goto label_3130;	/* undefined */
	     if iaddr^=0 then j = j + fixed(glpl_words(iaddr+3).left, 18);
	     call putout_$putlst(pc, 262144 * j, i66, 1, iltext);
	     j = bin("000300000"b3, 26);	/* entry seq flags rev1, has_descriptors */
	  end;
	if brk(1) ^= icomma then goto label_2642;	/* emit code */
	call getid_$getid_;
	/* fifth argument, function */
	if sym(1) ^= 0 then do;
	     if (sym(1) ^= ifun1) | (sym(2) ^= ifun2) | (sym(3) ^= ifun3) then goto label_3130; /* undefined symbol */
	     else  j = j + bin("000020000"b3, 26); /* entry seq flags function */
	  end;

label_2642:	/* emit structures and code for entry sequence */
	class = fixed(glpl_words(curlc + 4).right, 18) + fixed("100000"b3, 18);	/* entry flag */
	junk = lstman_$sdfasn (pc + 1 + fixed(glpl_words(curlc+3).left, 18), name, curlc, 0, class);

	/*	def_relp(filled in later), flags	*/
	call putout_$putlst(pc, j, i66, 1, ildefs);

	/*	eax7	stack_size	*/
	i = 16 * divide(i + 15, 16, 18, 0);	/* mod 16 boundary */
	call putout_$putlst(pc, i*262144 + bin("627000"b3, 19), i66, 1, 0);

	/*	epp2	pr7|28,*	*/
	call putout_$putlst(pc, bin("700034352120"b3, 36), i66, 1, 0);

	/*	tsp2	pr2|549	*/
	call putout_$putlst(pc, bin("201045272100"b3, 36), i66, 1, 0);

	/*	offset sequence	*/
	call putout_$putlst(pc, 0, i66, 1, 0);
	call putout_$putlst(pc, 0, i66, 1, isymbl);

	/*	tra	label (value)	*/
	call putout_$putlst(pc, value * 262144 + bin("710000"b3, 26), i66, 1, iltext);
	goto label_3010;    /* done */


/*  return pseudo-operation, return control to caller.  */

label_vector (39):		/*  return  */
label_2700: 

	call getid_$getid_;
	if (brk (1) ^= iques) then go to label_2720;
	junk = varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr);
	if (iaddr = 0) then go to label_2710;
	pc = spc + nertls;
	go to label_3300;


label_2710: 

	ertlst (5) = utils_$makins (ap, 2 * value, mldaq, 1, 0);
	ertlst (6) = utils_$makins (sp, labarg + 2, eb_data_$mstaq, 1, 0);
	ertlst (7) = utils_$makins (sp, labarg, meapap, 1, 0);
	irtblk = lstman_$blkasn (4, lstman_$namasn (eb_data_$unwind (1)), lstman_$namasn (eb_data_$unwind (1)), 0);
	ertlst (11) = utils_$makins (lp, lstman_$lnkasn (irtblk, 0, 0, 0) + fixed (glpl_words (lpsect + 3).left, 18),
								mtra, 1, mri);
	call putout_$putlst (pc, ertlst (1), i642, nertls, merbit (1));
	go to label_3140;

/*  normal return sequence.  */

label_2720: 

	if tnewcall ^= 0 then call putout_$putlst (pc, new_retlst (1), i642, new_nretls, new_mrtbit (1));
	else call putout_$putlst (pc, retlst (1), i642, nretls, mrtbit (1));
	go to label_3140;

/*  short_return pseudo-operation, return with no previous save.  */

label_vector (46):		/*  short_return  */
label_short_return:
	if tnewcall = 0 then prnto = 1;
	call putout_$putlst (pc, short_retlst (1), i642, short_nretls, short_mrtbit (1));
	goto label_3140;

/*  save pseudo-operation, stack setup for subroutine call.  */

label_vector (41):		/*  save/push  */
label_2800: 

	junk = varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr);
	if (value = 0) then go to label_2810;
	if (iaddr = 0) then go to label_2805;
	prntr = 1;
	if tnewcall ^= 0 then pc = spc + new_nslsav;
	else pc = spc + nslsav;
	if tprot = 1 then
	pc = pc + eb_data_$nmxsav;
	go to label_3300;

label_2805: 

	value = 8 * (divide (value + 7, 8, 17, 0));
	go to label_2820;

label_2810: 

	value = stkc;
	basno, admod, b29 = 0;

label_2820: 

	if tnewcall ^= 0 then if tprot = 0 then do;
		value = 16 * divide (value + 15, 16, 17, 0);
		new_slsave (1) = utils_$makins (basno, value, new_slsave (1), b29, admod);
		call putout_$putlst (pc, new_slsave (1), i642, new_nslsav, new_mslbit (1));
		goto label_3140;
		end;

	slsave (3) = utils_$makins (bp, value, meapbp, 1, 0);
	slsave (4) = utils_$makins (bp, 18 - value, mstpbp, 1, 0);
	slsave (5) = utils_$makins (bp, - value, meabsp, 1, 0);
	if tprot = 1 then
	call putout_$putlst (pc, mxsave (1), i642, eb_data_$nmxsav, mxsbit (1));
	call putout_$putlst (pc, slsave (1), i642, nslsav, mslbit (1));
	go to label_3140;

/*  segdef pseudo-operation, put symbol on external definition list.  */

label_vector (42):		/*  segdef  */
label_2900: 

	call getid_$getid_;
	if (eb_data_$tsym = 0) then go to label_3100;
	if (table_$table_ (iserch, sym (1), value, flocrf, lcloc) = 0) then go to label_3130;
	name = lstman_$namasn (sym (1));
	trplnk = 0;
	if (brk (1) ^= ilpar) then go to label_2920;
	tmvdef = 1;
	tderr = 0;
	trprtn = label_2910;
	go to label_933;

label_2910: 

	if (tderr = 1) then
	prntf = 1;

label_2920: 

	class = fixed (glpl_words (lcloc + 4).right, 18);
	if (brk (1) ^= ilsb) then go to label_2940;
	call getid_$getid_;
	if (expevl_$expevl_ (0, class, iaddr) = 0) then
	prntr,prntf = 1;
	if (iaddr ^= 0) then
	prntr = 1;
	if (brk (1) = irsb) then go to label_2930;
	prntf = 1;
	go to label_2940;

label_2930: 

	call inputs_$next;

label_2940: 

	junk = lstman_$sdfasn (value, name, lcloc, trplnk, class);
	if (brk (1) = icomma) then go to label_2900;
	if (lcloc = 0) then go to label_3200;
	value = value + fixed (glpl_words (lcloc + 3).left, 18);
	go to label_3200;


	/* block	indicate the start of a program block for statement map */
label_vector (68):	/* block	{block_name} */
	call getid_$getid_;
	if eb_data_$tsym = 0 then call alm_symtab_$block("");
	else call alm_symtab_$block( addr(sym(1)) -> acc_string.chars );
	goto label_3140;	/* all done */

	/* end_block	indicate the end of a program block for statement map */
label_vector (69):	/* end_block */
	call alm_symtab_$end_block;
	goto label_3140;	/* all done */

	/* enum	indicate start of enumerated-type symbol table dcls */
label_vector (70):	/* enum */
	call getid_$getid_;
	var_name = addr(sym(1)) -> acc_string.chars;
	do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
	     var_name = var_name || addr(brk(2)) -> dup_string(3);
	     call getid_$getid_;
	     var_name = var_name || addr(sym(1)) -> acc_string.chars;
	  end;
	if var_name = "" then goto label_3100;	/* field error */
	else call alm_symtab_$enum( (var_name) );
	goto label_3140;	/* all done */

	/* end_enum	indicate end of enum symbol table dcls */
label_vector (71):	/* end_enum */
	call alm_symtab_$end_enum;
	goto label_3140;	/* all done */

	/* source	indicate the current source for statement map */
label_vector (72):	/* source	<source_path> */
	unique_id = "0"b;
	dtcm = 0;
	call getid_$getid_;	/* get first part of path */
	path = addr(sym(1)) -> acc_string.chars;
	do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);	/* get rest of path */
	     path = path || addr(brk(2)) -> dup_string(3);	/* add break char */
	     call getid_$getid_;
	     path = path || addr(sym(1)) -> acc_string.chars;	     /* add next word */
	  end;
	if path = "" then goto label_3100;	/* field error */
	if brk(1) = icomma then do;	/* get unique id and dtcm */
	     n = octevl_$octevl_ (rslts (1));
	     if n >=2 then goto label_3100; /* number too big, field error */
	     unique_id = unspec(rslts(1));
	     if brk(1) ^= icomma then goto label_3100; /* missing dtcm, field error */
	     n = decevl_$decevl_(rslts(1), type);
	     if n = 1 then dtcm = rslts(1);
	     else dtcm = addr(rslts(1)) -> long_int_based;
	  end;
	else begin;	/* no dtcm & unique_id figure it out ourselves */
	dcl	(dirname char(256), entryname char(32), compname char(32)) automatic;
	dcl	seg_ptr ptr;
	dcl	code fixed bin(35);

	     seg_ptr = null();
	     call expand_pathname_$component((path), dirname, entryname, compname, code);
	     if code ^= 0 then goto label_2950;	     /* forget it */
	on     cleanup call terminate_file_(seg_ptr, 0, "001"b, 0);
	     call initiate_file_$component(dirname, entryname, compname, "100"b, seg_ptr, 0, code);
	     if code ^= 0 then goto label_2950;	     /* forget it */
	     call translator_info_$component_get_source_info(seg_ptr, dirname, entryname, compname, dtcm, unique_id, code);
	     if code ^= 0 then goto label_2950;	     /* can't figure it out */
	     call terminate_file_(seg_ptr, 0, "001"b, code);
	     path = rtrim(dirname, "> ") || ">" || rtrim(entryname, " ");
	     if compname ^= "" then path = path || "::" || compname;
	  end;
label_2950:
	call alm_symtab_$source((path), unique_id, dtcm);
	goto label_3140;	/* all done */

	/* end_source	indicate end of source segment for statement map */
label_vector (73):	/* end_source */
	call alm_symtab_$end_source;
	goto label_3140;	/* all done */

	/* statement	<st_offset>,<len>,<line_no>{,<stmnt_no>} */
label_vector (74):	/* statement */
	junk = varevl_$varevl_(invrvl, basno, st_offset, admod, b29, iaddr);
	if iaddr ^= 0 then prntr = 1;
	if brk(1) ^= icomma then goto label_3100;	/* field error */
	junk = varevl_$varevl_(invrvl, basno, st_length, admod, b29, iaddr);
	if iaddr ^= 0 then prntr = 1;
	if brk(1) ^= icomma then goto label_3100;	/* field error */
	junk = varevl_$varevl_(invrvl, basno, st_line, admod, b29, iaddr);
	if iaddr ^= 0 then prntr = 1;
	if brk(1) = icomma then do;	/* optional statement num */
	     junk = varevl_$varevl_(invrvl, basno, st_num, admod, b29, iaddr);
	     if iaddr ^= 0 then prntr = 1;
	  end;
	else st_num = 1;	/* if not specified, then statement num = 1 */
	call alm_symtab_$statement(pc + fixed(glpl_words(curlc+3).left, 18),
	     st_offset, st_length, st_line, st_num);
	goto label_3140;

	/* structure	indicate start of structure symbol table dcls */
label_vector (75):	/* structure	<structure_name> */
	call getid_$getid_;
	var_name = addr(sym(1)) -> acc_string.chars;
	do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
	     var_name = var_name || addr(brk(2)) -> dup_string(3);
	     call getid_$getid_;
	     var_name = var_name || addr(sym(1)) -> acc_string.chars;
	  end;
	if var_name = "" then goto label_3100;	/* field error */
	else call alm_symtab_$structure( (var_name) );
	goto label_3140;	/* all done */

	/* end_structure	indicate end of structure symbol table dcls */
label_vector (76):	/* end_structure */
	call alm_symtab_$end_structure;
	goto label_3140;	/* all done */

label_vector (77):	/* symbol	<symbol_name>,<symbol_type>{,location} */
	call getid_$getid_;	/* name */
	var_name = addr(sym(1)) -> acc_string.chars;
	do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
	     var_name = var_name || addr(brk(2)) -> dup_string(3);
	     call getid_$getid_;
	     var_name = var_name || addr(sym(1)) -> acc_string.chars;
	  end;
	if var_name = "" then goto label_3100;	/* field error */

	call getid_$getid_;	/* type */
	var_type = addr(sym(1)) -> acc_string.chars;
	i = 0;	/* nesting level for '[' ... ']' pairs */
	do while(brk(1) ^= inl & (brk(1) ^= icomma | i > 0) & brk(1) ^= iquot);
	     if brk(1) = ilsb then i = i + 1;	/* another '[' */
	     else if brk(1) = irsb then i = i - 1;	/* matching ']' */
	     var_type = var_type || addr(brk(2)) -> dup_string(3);
	     if brk(1) ^= ilsb & brk(1) ^= icomma & brk(1) ^= icol then do;
		call getid_$getid_;
		var_type = var_type || addr(sym(1)) -> acc_string.chars;
	       end;
	     else do;
		call getid_$getid_;
		/* if the identifier has a symbolic value use it */
		junk = table_$table_(iserch, sym(1), value, flocrf, lcloc);
		if junk=0 then var_type = var_type || addr(sym(1)) -> acc_string.chars;
		else do;
		     if lcloc ^= 0 then value = value + fixed(glpl_words(lcloc+3).left, 18);
		     var_type = var_type || ltrim(char(value));
		  end;
	       end;
	  end;
	if var_type = "" | i > 0 then goto label_3100;	/* field error */

	/* location {optional} */
	i = 0;	/* initial offset = 0 bits */
	if brk(1) = icomma then do;
	     if varevl_$varevl_(ixvrvl, basno, value, admod, b29, iaddr) = 0 then goto label_3120; /* S error */
	     if brk(1) = ilpar then do;	/* bit offset */
		if varevl_$varevl_(invrvp, 0, i, 0, 0, 0) = 0 then goto label_3120;	/* S error */
	       end;
	     if basno = 0 & value = 0 & admod = 0 & b29 = 0 & iaddr = 0 & i = 0 then goto label_3100; /* F error */
	     call alm_symtab_$symbol((var_name), (var_type), basno, value, admod, b29, iaddr, i);
	  end;
	else call alm_symtab_$symbol((var_name), (var_type), 0, 0, 0, 0, 0, 0);
	goto label_3140;	/* all done */


	/* union	indicate start of union symbol table dcls */
label_vector (78):	/* union	<union_name> */
	call getid_$getid_;
	var_name = addr(sym(1)) -> acc_string.chars;
	do while(brk(1) ^= icomma & brk(1) ^= inl & brk(1) ^= iquot);
	     var_name = var_name || addr(brk(2)) -> dup_string(3);
	     call getid_$getid_;
	     var_name = var_name || addr(sym(1)) -> acc_string.chars;
	  end;
	if var_name = "" then goto label_3100;	/* field error */
	else call alm_symtab_$union( (var_name) );
	goto label_3140;	/* all done */

	/* end_union	indicate end of union symbol table dcls */
label_vector (79):	/* end_union */
	call alm_symtab_$end_union;
	goto label_3140;	/* all done */


/*  setlp pseudo - op.  */
/*  generate eaplp -*, ic with 3a relocation bits.  */

label_vector (45):		/*  setlp  */
label_2970: 

	call putout_$putwrd (pc, utils_$makins (0, - fixed (glpl_words (curlc + 3).left, 18) - pc, meaplp, 0, mpc),
								i642, glpl_$glwrd (imlink, 0));
	go to label_3010;

/*  getlp pseudo-operation, set LP from lot.  */

label_vector (49):		/*  getlp  */
label_getlp:
	call putout_$putlst (pc, new_getlp (1), i642, new_ngetlp, new_getbit (1));
	goto label_3140;



/*  EIS multi-word instruction operand descriptors are generated by these pseudo-ops.  */

label_vector (55):		/*  desc9a, desc6a, desc4a  */
label_eis_desca:
	type = 1;
	goto desc_common;

label_vector (56):		/*  descb  */
label_eis_descb:
	type = 2;
	goto desc_common;

label_vector (57):		/*  desc9fl, desc4us, etc.  */
label_eis_descn:
	type = 3;

desc_common:
	nobits = fixed (addr (binop) -> descop_overlay.flags, 4);	/*  9, 6, 4, or 1  */
	class = fixed (addr (binop) -> descop_overlay.format, 4);	/*  Numeric operand format (fixed vs. float, etc.).  */
	full_word_temp = alm_eis_parse_$descriptor (type, nobits, class, rleft);
	call putout_$putwrd (pc, full_word_temp, i66, rleft);
	goto label_3015;


label_vector (52):		/*  rpt, rpd, rpl  */
label_repeat:		/*  repeat type instructions rpt, rpd, and rpl.  Format is:
				RPT	tally,delta,term1,term2,...
			   where term_i are the names of the conditional transfer instructions
			   that test the states to be terminated on.  The A, B, and C bits are
			   kept in the opcode_overlay.flags field (viz. RPD, RPDA, RPTX).  */

	call getid_$getid_;
	if expevl_$expevl_ (0, zleft, iaddr) = 0 then prnte = 1;
	if iaddr ^= 0 then prntr = 1;
	if brk (1) = icomma then do;
		call getid_$getid_;
		if expevl_$expevl_ (0, zright, iaddr) = 0 then prnte = 1;
		if iaddr ^= 0 then prntr = 1;
		if zright < 0 | zright > 63 then prnte = 1;
		end;
	else zright = 1;			/*  delta defaults to 1.  */

	termination_conditions = ""b;
	do i = 1 to 7 while (brk (1) = icomma);
		call getid_$getid_;
		do j = 1 to 7;
			if sym (1) = eb_data_$rpt_terminators (j) then do;
				substr (termination_conditions, j, 1) = "1"b;
				goto rpt_out;
				end;
			end;
		prntu = 1;
	rpt_out:	end;

	zleft = zleft * 1024 + fixed (addr (binop) -> opcode_overlay.flags || termination_conditions, 11);
	itemp = tinhib;		/*  Processor manual calls for RPT to have inhibit flag on always.  */
	tinhib = 1;
	call putout_$putwrd (pc, utils_$makins (0, zleft, binop, 0, zright), i642, 0);
	tinhib = itemp;
	goto label_3015;


label_vector (53):		/*  awd, swd, abd, sbd, etc.  */
label_eis_single:		/*  single word EIS instructions awd, abd, etc.  Format is:
				AWD	base|offset,tag
			   where base is required, in order to select a target register.
			   For AWDX, etc., the opcode_overlay.flags field is non-zero to indicate
			   that bit 29 should be turned off.  (This makes add into clear-and-add, etc.)  */

	if varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0 then prnte = 1;
	if b29 = 0 then do;		/*  Base number _m_u_s_t be specified.  */
		prnte = 1;
		b29 = 1;
		end;
	if iaddr = 0 then rleft = 0;		/*  calculate relocation bits.  */
	else do;
		value = value + fixed (glpl_words (iaddr + 3).left, 18);
		call getbit_$getbit_ (iaddr, basno, b29, rleft);
		rleft = rleft * 262144;
		end;

	full_word_temp = utils_$makins (basno, value, binop, b29, admod);
	if addr (binop) -> opcode_overlay.flags then full_word_temp = full_word_temp - 64;	/*  turn b29 OFF  */
	call putout_$putwrd (pc, full_word_temp, i642, rleft);
	goto label_3015;

label_vector (54):		/*  mvn, cmpb, ad2d, etc.  */
label_eis_multiple:		/*  EIS instructions with multi-word operand descriptors, MLR, CMPB, etc.
			   The instruction word contains up to three tags for the operands
			   and several kinds of flags and numeric values.  */

	flags = fixed (addr (binop) -> opcode_overlay.flags, 4);		/*  Non-zero if FILL field is only one bit wide.  */
	full_word_temp = alm_eis_parse_$instruction (binop, flags, rleft);
	call putout_$putwrd (pc, full_word_temp, i642, rleft);
	goto label_3015;


label_vector (44):		/*  eap, sprp, etc.  */
label_get_base:		/*  normal base register instructions written as:
				EAP	bp,ap|2,*
			   This is so symbolic names can be used for base registers.  */

	rslts (1) = sym (1); rslts (2) = sym (2);	/*  Save opcode name.  */
	call getid_$getid_;
	do itemp = 0 to 7;		/*  Search for predefined base register name first.  */
		if sym (1) = symbas (itemp + 1) then goto got_index;
		end;
	goto get_index;		/*  join common code.  */

label_vector (43):		/*  eax, canx, etc.  */
label_get_index:		/*  normal index register instructions written with separate register name as above.  */
	rslts (1) = sym (1); rslts (2) = sym (2);	/*  As above. */
	call getid_$getid_;

get_index:
	if expevl_$expevl_ (0, itemp, iaddr) = 0 then prnte = 1;
	if iaddr ^= 0 then prntr = 1;

got_index:
	if itemp < 0 | itemp > 7 then do;
		prnte = 1;
		itemp = 0;
		end;
	sym (1) = rslts (1); sym (2) = rslts (2);	/*  Put opcode name back.  */
		/*  Fudge opcode name to contain register number.  */
	j = addr (sym) -> acc_string.length + 1;
	addr (sym) -> acc_string.length = j;
	substr (addr (sym) -> acc_string.chars, j, 1) = substr ("01234567", itemp + 1, 1);
	if brk (1) = icomma then brk (1) = isp;/*fix equ bug*/
	goto label_301;			/*  Go re-evaluate opcode.  */

label_vector (58):
label_entrybound:
	eb_data_$entry_bound = spc + fixed(glpl_words(curlc + 3).left, 18);
	goto label_3010;


/*  NORMAL INSTRUCTIONS  */

label_vector (0):		/*  Normal instruction.  */
label_3000: 
	if (varevl_$varevl_ (ixvrvl, basno, value, admod, b29, iaddr) = 0) then prnte = 1;
	rleft = 0;
	if (iaddr = 0) then go to label_3008;
	value = value + fixed (glpl_words (iaddr + 3).left, 18);

/*  determine the proper relocation bits  */

	call getbit_$getbit_ (iaddr, basno, b29, rleft);

/*  the following statement left justifies the reloc. bits  */
/*  and avoids a call to glpl_$glwrd (rleft, 0) for each instruction.  */

	rleft = rleft * 262144;

label_3008: 

	call putout_$putwrd (pc, utils_$makins (basno, value, binop, b29, admod), i642, rleft);
	goto label_3015;

/*  re - entry from pseudo-operation processing.  */

label_3010: 
	call prwrd_$source_only;
label_3015: 

	if (pc = tpc & curlc = tlc) then go to label_3040;
	call prnter_$prnter_ ("fatal phase error in pass2.");
	call utils_$abort;



/*  skip over comment portion of card  */

label_3040: 

	call inputs_$next_statement;
	go to label_200;


/*  error return for pseudo-operations.  */

/*  field (f) error.  */

label_3100: 

	prntf = 1;
	go to label_3200;

/*  phase (p) error.  */

label_3110: 

	prntp = 1;
	go to label_3200;

/*  symbol (s) definition error.  */

label_3120: 

	prnts = 1;
	go to label_3200;

/*  undefined (u) symbol error.  */

label_3130: 

	prntu = 1;
	go to label_3200;

/*  variable length macro phase error.  */

label_3140: 

	if curlc = tlc then go to label_3150;
	call prnter_$prnter_ ("fatal multiple location counter mismatch in pass2.");
	call utils_$abort;

label_3150: 

	if pc = tpc then go to label_3040;
	prntp = 1;
	pc = tpc;
	go to label_3040;


label_vector (9):		/* dup */
label_dup:
	if dup_ptr ^= null () then go to label_3120;
	if varevl_$varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0 then go to label_3120;
	if iaddr ^= 0 then go to label_3300;
	if value <= 0 then go to label_3120;
	dup_count = value - 1;
	call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), value, eb_data_$ib6);
	call inputs_$next_statement;
	call inputs_$get_ptr (dup_ptr, dup_start, junk, end_statement_flag);
	go to label_200;

label_vector (10):		/* dupend */
label_dupend:
	if dup_ptr = null () then go to label_3120;
	call inputs_$get_ptr (temp_ptr, i, j, end_statement_flag);
	if temp_ptr ^= dup_ptr then go to label_3100;
	i = begin_line;			/* Really want beginning of line. */
	call inputs_$next_statement;
	if dup_count > 0 then
	     call alm_include_file_$insert (addr (dup_string (dup_start)), i - dup_start, dup_count);
	dup_ptr = null ();
	go to label_200;

label_vector (60):
label_macro:
	call getid_$getid_;
	if eb_data_$tsym = 0 then goto label_3100;
	call oplook_$redefine;
	call inputs_$next_statement;
	call mexp_$define_macro (addr (sym (1)) -> acc_string.chars);
	go to label_200;

label_vector (40):
label_maclist:
	call getid_$getid_;
	if eb_data_$tsym = eb_data_$ion then
	     tmacl = "00"b;
	else if eb_data_$tsym = eb_data_$ioff then
	     tmacl = "11"b;
	else if eb_data_$tsym = eb_data_$iobject then
	     tmacl = "10"b;
	else if eb_data_$tsym = eb_data_$irestore then do;
	     eb_data_$macro_listing_control = substr (eb_data_$macro_listing_control, 3);
	     go to end_maclist;
	end;
	else go to label_3100;

	if brk (1) = icomma then do;
	     call getid_$getid_;
	     if eb_data_$tsym = eb_data_$isave then
		eb_data_$macro_listing_control = tmacl || eb_data_$macro_listing_control;
	     else go to label_3100;
	end;

	else substr (eb_data_$macro_listing_control, 1, 2) = tmacl;

end_maclist:
	if eb_data_$macro_depth > 0 then do;
	     call inputs_$next_statement_nolist;
	     go to label_200;
	end;
	else go to label_3300;



/*  possible phase error, print flags, loc, and value.  */

label_3200: 

	if (pc = tpc) then go to label_3210;
	prntp = 1;
	pc = tpc;

label_3210: 

	call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), value, eb_data_$ib6);
	go to label_3040;

/*  printer for no-valued pseudo-operations, print flags and loc.  */

label_3300: 

	call prwrd_$prwrd_ (spc + fixed (glpl_words (curlc + 3).left, 18), 0, ibb);
	go to label_3015;


     end pass2_;




		    postp1_.pl1                     10/17/88  1013.9rew 10/17/88  0938.9       80289



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


	

/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to allow for joining to the definition section.
                                                   END HISTORY COMMENTS */


postp1_:		procedure ;
	
	/*  modified for separate static on 06/15/75 by Eugene E Wiatrowski  */
	/*  modified on 03/30/72 at 23:52:53 by R F Mabee. */
	 
	/*   post pass1 processor for eplbsa. ;
	 postp1 has the job of originating all lcs.
	counters. each location counter has an entry in the 
	assignment table as follows--  
	  
	  zero   name,next in hash table   
	  vfd 15/flags,3/class,18/current value 
	  zero left join,right join  
	  zero origin,max value    
	  vfd 15/unused,1/sixty-four,1/eight,1/even,18/segment   
	  
		postp1 does not see the assignment table, but instead,
	four lists strung together with the left and right  
	join pointers--    
	  
	  ulclst  location counters never join#ed    
	  tlclst  text segment location counters     
	  llclst  link segment location counters     
	  slclst  symbol segment location counters    
	  dlclst  definition segment location counters    
	  
	in addition ulcend points to the end of ulclst.   
	  
	postp1 first moves ulclst to the beginning of tlclst,
	then goes down the three remaining lists filling in 
	#origin#. it uses only the following information out
	of the entry--     
	  
	  right join     
	  max value
		  current value   
	  sixty-four     
	  eight  
	  even   
	  
	the field #segment# just duplicates the information 
	given by membership in the appropriate list.     
	  
	late addition to the work of postp1-- check max against current
	value to save work for mills.  
	  
	later addition--set current value to zero. */ 
	  
dcl eb_data_$stat_len ext fixed bin(26);
dcl eb_data_$separate_static ext bit(1);
	  
	  
	  
dcl  linkage_done bit(1) aligned;
	dcl ( text, radix, maxv, curv, cur, mode, jut, splice, j, symbol, definition, mods, link) fixed bin (26) ;

% include alm_lc;
	  
	/* EXTERNAL FUNCTIONS */
 
declare	glpl_$clh ext entry (fixed bin) returns (fixed bin),
	glpl_$crh ext entry (fixed bin) returns (fixed bin) ;
	  
	/* EXTERNAL ENTRIES */
 
declare	glpl_$storr ext entry (fixed bin (26), fixed bin (26)),
	glpl_$storl ext entry (fixed bin (26), fixed bin (26)),
	putxt_$putxt_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
	pulnk_$pulnk_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
	pudef_$pudef_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
	pusmb_$pusmb_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) ;

	% include concom ;
	% include varcom;
	  
	  
	/*	put ulclst onto the beginning of tlclst. */     
	  
	   if (ulclst = 0) then go to label_100;
	 call glpl_$storl(tlclst+2,(ulcend)) ;
	 call glpl_$storr(ulcend+2,(tlclst)) ;
	 tlclst = ulclst;
	 ulclst = 0;
	 ulcend = 0;
	itxtmod, ilnkmod = 2;
label_100:	  
	  
	/* go through the text location counters assigning 
	  origins, etc. */   
	  
	   text = 0;
	   cur = tlclst;
label_1000:	 if (cur = 0) then go to label_1999;   
	  
	   mods = glpl_$clh(cur+4) ;  
	   curv = glpl_$crh(cur+1) ;  
	   maxv = glpl_$crh(cur+3) ;  
	  
	   radix = 1; 
	   if (mods ^= 0) then radix = mods; 
	  
		jut = text - divide(text,radix,26,0) * radix ;
	   if (jut = 0) then go to label_1200 ;   
	   splice = radix-jut ;  
	 
label_1100:	
	   do j = 1 to splice ; 
	     call putxt_$putxt_(text+j-1,mnopdu,0) ;    
  
end label_1100 ;
	 
	text = text + splice ;
  
label_1200:	  
	  
	/* check max vs. current values. */
		  
	   if (curv < maxv) then go to label_1300 ; 
	 	maxv = curv; 
	 	call glpl_$storr(cur+3,maxv); 
label_1300:	

	/* Accumulate per-segment mod (boundary) info. */

	if mods ^= 0 then if itxtmod = 0 then itxtmod = mods;
			else if mod (mods, itxtmod) = 0 then itxtmod = mods;
			else if mod (itxtmod, mods) ^= 0 then itxtmod = itxtmod * mods;
	  
	/* set origin */
	 
	   call glpl_$storl(cur+3,text); 
	   text = text+maxv ;   
	  
	/* set current value to zero */  
	  
	   call glpl_$storr(cur+1,0) ;
	  
	/* and loop around */
	  
	   cur = glpl_$crh(cur+2); 
	   go to label_1000; 
label_1999:	

	/*  For the case of separate static we have to change the list
	    of location counters of the form:

		L = (slc1  lc1 ... lci ... lcn  slc2)

	    where slc1 and slc2 are two system-location counters
	    and (lc1 ... lci ... lcn) is a list posibly empty of user
	    defined location counters

	    into two separate lists:
				a) L1 = (lc1 ... lci ... lcn)
			and       b) L2 = (slc1  slc2).             */

	  
	 /* go through the link location counters assigning 
	  origins, etc. */   
	  
	   link = 0; 
	   eb_data_$stat_len = 0;
	   if eb_data_$separate_static
	      then do;
		 cur = lpsect;
		 cur = glpl_$clh(cur+2);
		 call glpl_$storr(cur+2,0);
		 cur = llclst;
		 cur = glpl_$crh(cur+2);
		 call glpl_$storl(cur+2,0);
		 end;
	      else cur = llclst; 

	   linkage_done = "0"b;

label_2000:	 if (cur = 0) then go to label_2888; 
	  
	   mods = glpl_$clh(cur+4) ; 
	   curv = glpl_$crh(cur+1) ;  
	   maxv = glpl_$crh(cur+3) ;  
	  
	   radix = 1; 
	   if (mods ^= 0) then radix = mods; 
	  
		jut = link - divide(link,radix,26,0) * radix ;
	   if (jut = 0) then go to label_2200; 
	   splice = radix-jut; 
	 
label_2100:	
	   do j = 1 to splice ; 
	      call pulnk_$pulnk_(link+j-1,mnopdu,0) ;   
  
end label_2100 ;
	 
	link = link + splice ;
  
label_2200:	
	  
	/* check max vs. current values. */
	  
	   if (curv < maxv) then go to label_2300 ; 
	 	maxv = curv;
	 	call glpl_$storr(cur+3,maxv);
label_2300:	  

	if mods ^= 0 then if ilnkmod = 0 then ilnkmod = mods;
			else if mod (mods, ilnkmod) = 0 then ilnkmod = mods;
			else if mod (ilnkmod, mods) ^= 0 then ilnkmod = ilnkmod * mods;
	  
	/* set origin */
	  
	   call glpl_$storl(cur+3,link); 
	   link = link+maxv; 
	  
	/* set current value to zero. */  
	  
	   call glpl_$storr(cur+1,0) ;
	  
	/* and loop around */
	  
	   cur = glpl_$crh(cur+2); 
	   go to label_2000; 
label_2888:
	   if eb_data_$separate_static
	      then do;
		 if linkage_done then goto label_2999;
		 cur = llclst;
		 call glpl_$storr(cur+2,lpsect);
		 call glpl_$storl(lpsect+2,cur);
		 eb_data_$stat_len = link + mod(link,2);
		 link = 0;
		 linkage_done = "1"b;
		 goto label_2000;
		 end;

label_2999:	  
	  
	/* now go through and do the same for symbol    
	  segment location counters. */  
	  
	   symbol = 0 ; 
	   cur = slclst; 
label_3000:	 if (cur = 0) then go to label_3999; 
	  
	   mods = glpl_$clh(cur+4) ; 
	   curv = glpl_$crh(cur+1) ;  
	   maxv = glpl_$crh(cur+3) ;  
	  
	   radix = 1 ; 
	   if (mods ^= 0) then radix = mods; 
	  
		jut = symbol - divide(symbol, radix, 26, 0 ) * radix ;
	   if (jut = 0) then go to label_3200; 
	   splice = radix-jut; 
label_3100:	
	   do j = 1 to splice ; 
	     call pusmb_$pusmb_(symbol+j-1,mnopdu,0) ;  
  
end label_3100 ;
	 
	symbol = symbol + splice ;
  
label_3200:	
	  
	/* check max vs. current values. */
	  
	   if (curv < maxv) then go to label_3300 ; 
	 maxv = curv; 
	 call glpl_$storr(cur+3,maxv); 
label_3300:	
	  
	/* set origin */
	  
	   call glpl_$storl(cur+3,symbol); 
	   symbol = symbol+maxv ; 
	  
	/* set current value to zero. */  
	  
	   call glpl_$storr(cur+1,0) ;
	  
	/* and loop around */
	  
	   cur = glpl_$crh(cur+2); 
	   go to label_3000; 

label_3999:	
	/* definition section */
	definition = 0;
	cur = dlclst;
label_4000:
	if (cur = 0) then goto label_4999;
	mods = glpl_$clh(cur+4);
	curv = glpl_$crh(cur+1) ;  
	maxv = glpl_$crh(cur+3) ;  
	  
	radix = 1; 
	if (mods ^= 0) then radix = mods; 
	  
	jut = definition - divide(definition,radix,26,0) * radix ;
	if (jut = 0) then go to label_4200 ;
	splice = radix - jut;

	do j = 1 to splice;
		 call pudef_$pudef_(definition+j-1,mnopdu,0);
	  end;
	definition = definition + splice;
label_4200:
	if curv < maxv then goto label_4300;
	     maxv = curv;
	     call glpl_$storr(cur+3,maxv);

label_4300:
	call glpl_$storl(cur+3,definition);
	definition = definition + maxv;
	call glpl_$storr(cur+1,0);
	cur = glpl_$crh(cur+2);
	goto label_4000;

label_4999:
	/* and that seems to be all */
	  
end postp1_ ;




		    postp2_.pl1                     10/17/88  1013.9rew 10/17/88  0929.5      245079



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to allow for joining to the definition section.
  2) change(88-08-02,JRGray), approve(88-08-05,MCR7952),
     audit(88-09-30,WAAnderson), install(88-10-17,MR12.2-1169):
     Modified to call alm_symtab_ as part of symbol table support.
                                                   END HISTORY COMMENTS */


/* post pass2 processor for the eplbsa assembler. */

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

postp2_:
     procedure;

/* Postp2 is called after pass two to generate non-source output.
   There are three regions to this subroutine,
   one to append information
   to the text segment (literals, etc), one to put out the
   symbolic definition region (to either text or link) and one to
   put out the linkage file
   (including entry and call interludes).
   The arrangement of the output information is determined by the
   two flags tprot (for transfer vector and error call) and
   tmvdef (for moving definitions to the linkage file).
   Tprot should imply tmvdef.
   If the definitions are to go in the linkage file,
   a pre-pass must be made to assign locations
   before the information is put out
   because the links must be assigned first. */
/* Modified for separate static on 06/15/75 by Eugene E Wiatrowski */
/* Modified on 07/25/72 at 04:13:13 by R F Mabee.
   by RFM on 6 May 1972 to add definition pointer to entry point.
   by RFM on 21 March 1972 for new object segment format.
   by RHG on 15 May 1971 to fix last fix
   by RHG on 1 April 1971 to fix making itxlen even.
   November 1970, R H Campbell, for cleavage.
   by RHG on 17 Sept 1970 for new listing package
   by RHG on 11 August 1970 at 1345 to fix bug in rel_symbol link
   by RHG on 7 August 1970 at 0107 for new symbol table header
   */
/* AUTOMATIC VARIABLES USED BY POST_PASS_2 */
dcl (argout, calblk, iexp1,
     ilc, ilnkno, ioffst,
     isegno, ispc, itemp, itxlen, ival, l, 
     ldef, statlen, lnklen,
     lword (4), nwrds, rblock (10), rleft, rlkdef,
     rright, rsydef, val, words (4)) fixed bin (26) ;
dcl  iaddr fixed bin (18);
dcl (ientlc, ientpc) pointer;
dcl  iexp pointer;
dcl (ileft, iright) fixed bin (18);
dcl (isym, iname) pointer;
dcl (j, k) pointer;
dcl (lcl, lcptr, lcr) pointer;
dcl  lnkorg fixed bin (26);
declare  header_done bit (1) aligned;
						/* Headings placed in listing (watch for form-feeds). */
dcl  SYMBOL_TABLE_HEADER_nl static character (25) aligned initial ("SYMBOL TABLE HEADER
     ");
dcl  ff_ERROR_RETURN_CALL_nl static character (23) aligned initial ("ERROR RETURN CALL
     ");
dcl  ff_LINKAGE_INFORMATION_nl static character (27) aligned initial ("LINKAGE INFORMATION
     ");
dcl  ff_LITERALS_nl static character (15) aligned initial ("LITERALS
     ");
dcl  nl_NO_LITERALS_nl static character (18) aligned initial ("
NO LITERALS
     ");
dcl  ff_SYMBOL_INFORMATION_nl static character (25) aligned initial ("SYMBOL INFORMATION
     ");
dcl  ff_TRANSFER_VECTOR_nl static character (22) aligned initial ("TRANSFER VECTOR
     ");
dcl  ff_ENTRY_SEQUENCES_nl internal static char (22) aligned initial ("ENTRY SEQUENCES
");
dcl  nl_FIRST_REFERENCE_TRAP_LIST_nl internal static char (32) aligned initial ("
FIRST REFERENCE TRAP LIST
");
						/* EXTERNAL DATA USED BY POST_PASS_2 */
						/* eb_data_$bases is overlayed with eb_data_$symbas */
dcl (eb_data_$anames (0: 5), eb_data_$bases (0: 7), eb_data_$blanks (2),
     eb_data_$calseq (4), eb_data_$entseq (5),
     eb_data_$maos, eb_data_$meax0,
     eb_data_$meax7) external fixed bin (26);
dcl  eb_data_$lavptr external pointer;
dcl  eb_data_$stat_len ext fixed bin(26);
dcl  eb_data_$separate_static external bit(1);
						/* EXTERNAL ENTRIES CALLED BY POST_PASS_2 */
dcl  alm_definitions_$assign_definitions entry;
declare  alm_definitions_$fix_entries ext entry;
declare  alm_symtab_$count_words ext entry(fixed bin(26));
declare  alm_symtab_$emit ext entry(fixed bin(26));

dcl  alm_definitions_$emit_definitions entry (fixed bin (26), fixed bin (26), fixed bin (26));
dcl  litevl_$litasn entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26));
dcl  prlst_$prlst_ entry (character (*) aligned);
dcl  prnam_$prnam2 entry (pointer, pointer);
dcl  prnam_$prnam_ entry (pointer);
dcl  prnter_$abort1 entry;
dcl  prnter_$prnter_ entry (character (*) aligned);
dcl  pulnk_$lnkcnt entry (fixed bin (26));
dcl  pulnk_$pulnk_ entry (fixed bin (26), fixed bin (26), fixed bin (26));
dcl  pudef_$pudef_ entry (fixed bin (26), fixed bin (26), fixed bin (26));
dcl  pudef_$defcnt entry (fixed bin (26));
dcl  pusmb_$symcnt entry (fixed bin (26));
dcl  putout_$putblk entry (fixed bin (26), pointer, fixed bin (26), fixed bin (26), pointer);
dcl  putout_$putlst entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26));
dcl  putout_$putwrd entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26));
dcl  putxt_$putxt_ entry (fixed bin (26), fixed bin (26), fixed bin (26));
dcl  putxt_$txtcnt entry (fixed bin (26));
						/* EXTERNAL FUNCTIONS CALLED BY POST_PASS_2 */
dcl (lstman_$blkasn entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     lstman_$lnkasn entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
     lstman_$namasn entry (fixed bin (26)),
     utils_$makins entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26))
     ) returns (fixed bin);
						/* LABEL VARIABLES USED IN POST_PASS_2 */
dcl  control_1020 (3) label local static;
dcl  control_1030 (5) label local static;
dcl  first_time bit (1) static initial ("1"b);
dcl  twop18 static fixed bin (19) initial (1000000000000000000b);
dcl  deforg fixed bin;
declare  symtab_words fixed bin(26);
dcl (null, convert, fixed) builtin;

/* INCLUDE FILES */
%	include alm_lc;

%	include alm_list_beads;

/* multiple word bit patterns for standard sequences */
%	include alm_prototypes;

/* miscellaneous whole words for use with relocation processing */
%	include alm_relocation_bits;

%	include concom;

%	include objnfo;

/* common for symbol table header processing. */
%	include sthedr;

%	include varcom;

%	include alm_options;

/* END OF DECLARATIONS */
/*  */
/* POST_PASS_TWO PROGRAM STARTS HERE. */
	if first_time /* in the process */ then
	     do;					/* initialize the labels & stuff */
	     control_1020 (1) = label_1030;		/* Normal link pair. */
	     control_1020 (2) = label_1040;		/* Entry point. */
	     control_1020 (3) = label_1070;		/* Call out. */
	     control_1030 (1) = label_1031;		/* Type 1 link: <*section>|x */
	     control_1030 (2) = label_1032;		/* Type 2 link: base|[symbol] */
	     control_1030 (3) = label_1033;		/* Type 3 link: <segment>|x */
	     control_1030 (4) = label_1034;		/* Type 4 link: <segment>|[symbol] */
	     control_1030 (5) = label_1035;		/* Type 5 link: <*section>|[symbol] */
	     first_time = "0"b;
	end;

	if dlclst > 0 then do;	/* calculate length of explicit definitions */
		curlc = dlclst;
		idfpc = 0;
		j = pointer(eb_data_$lavptr, curlc);
		do while(j->location_counter_bead.right_join ^= "0"b);
			idfpc = idfpc + convert(idfpc, j->location_counter_bead.max_value);
			curlc = convert(curlc, j->location_counter_bead.right_join);
			j = pointer(eb_data_$lavptr, curlc);
		  end;
	  end;
						/* part 2 of postp2. */
						/* Put out terminal information in the text segment. */
						/* output order is transfer vector, error call, and literals. */
						/* In addition if (tmvdef), all definitions are preassigned. */
	lnkorg = convert (lnkorg, pointer (eb_data_$lavptr, lpsect) -> location_counter_bead.origin);
	if (tprot ^= 0) then
	     do;
	     call prlst_$prlst_ (ff_TRANSFER_VECTOR_nl);
	     pc = 0;
	     curlc = lptv;
	     j = pointer (eb_data_$lavptr, tvlst);
	     do while (rel (j));
		tinhib = convert (tinhib, j -> transfer_vector_bead.inhibit);
		val = convert (val, j -> transfer_vector_bead.location);
		k = pointer (eb_data_$lavptr, j -> transfer_vector_bead.location_counter);
		if rel (k) then
		     val = val + fixed (k -> location_counter_bead.origin, 18);
		call putout_$putwrd (pc, utils_$makins (0, (val), mtra, 0, 0), i642, (iltext));
		j = pointer (eb_data_$lavptr, j -> transfer_vector_bead.next);
	     end;
						/* put out error call. */
	     tinhib = 0;
	     if (tcall ^= 0) then
		do;
		pc = 0;
		curlc = lpcall;
		call prlst_$prlst_ (ff_ERROR_RETURN_CALL_nl);
		call litevl_$litasn (argout, dzero (1), 2, 0);
		slcall (3) = utils_$makins (0, argout + litorg, meapap, 0, 0);
		nslbit (3) = iltext;
		calblk = lstman_$blkasn (4, lstman_$namasn (smxer (1)), lstman_$namasn (sretrn (1)), 0);
		slcall (5) = utils_$makins (lp, lstman_$lnkasn (calblk, 0, 0, 0) + lnkorg, mtra, 1, mri);
		nslbit (5) = ilkptr * twop18;		/* glpl_$glwrd (ilkptr, 0) */
		call putout_$putlst (pc, slcall (1), i642, nslcal, nslbit (1));
		call putout_$putwrd (pc, 0, i642, 0);
	     end;
	end;

/*  For new object segment format, put out text-section entry sequences.
   These merely call an operator, because the full entry sequence is fairly long.  */

	if tnewobject ^= 0 then do;
	     call alm_definitions_$fix_entries ();
	     header_done = "0"b;
	     j = pointer (eb_data_$lavptr, lnklst);	/* Chain of links, entries, etc. */
	     curlc = lpentries;
	     pc = 0;
	     do while (rel (j));
		if j -> entry_bead.kind = bit (binary (2, 18), 18) then do;
		     if ^ header_done then do;
			call prlst_$prlst_ (ff_ENTRY_SEQUENCES_nl);
			header_done = "1"b;
		     end;
		     tinhib = convert (tinhib, j -> entry_bead.inhibit);
		     ientpc = pointer (eb_data_$lavptr, j -> entry_bead.transfer_vector);
		     ioffst = convert (ioffst, ientpc -> transfer_vector_bead.location);
		     ientlc = pointer (eb_data_$lavptr, ientpc -> transfer_vector_bead.location_counter);
		     ival = fixed (ientlc -> location_counter_bead.origin, 18) + ioffst;

		     new_entlst (1) = fixed (j -> entry_bead.link_no, 18) * twop18;
		     new_entlst (3) = utils_$makins (0, ival, new_entlst (3), 0, 0);
		     call putout_$putlst (pc, new_entlst (1), i642, new_nentls, new_entbit (1));
		end;
		j = pointer (eb_data_$lavptr, j -> entry_bead.next);
	     end;
	end;

/* punch out literals in order of definition. */
	if pointer (eb_data_$lavptr, lplit) -> location_counter_bead.value then
	     do;
	     curlc = lplit;
	     call prlst_$prlst_ (ff_LITERALS_nl);
	     j = pointer (eb_data_$lavptr, litlst);
	     do while (rel (j));
		pc = convert (pc, j -> literal_bead.location);
		nwrds = convert (nwrds, j -> literal_bead.size);
		lcptr = pointer (eb_data_$lavptr, j -> literal_bead.location_counters);
		if rel (lcptr) then			/* */
label_280a:	     do l = 1 to nwrds;
		     lcl = pointer (eb_data_$lavptr, lcptr -> location_counters (l).left);
		     lcr = pointer (eb_data_$lavptr, lcptr -> location_counters (l).right);
		     ileft = convert (ileft, j -> literal_bead.words (l).left);
		     iright = convert (iright, j -> literal_bead.words (l).right);
		     rleft = 0;
		     rright = 0;
		     if rel (lcl) then
			do;
			ileft = ileft + fixed (lcl -> location_counter_bead.origin, 18);
			rleft = ibits (fixed (lcl -> location_counter_bead.section, 18));
		     end;
		     if rel (lcr) then
			do;
			iright = iright + fixed (lcr -> location_counter_bead.origin, 18);
			rright = ibits (fixed (lcr -> location_counter_bead.section, 18));
		     end;
		     j -> literal_bead.words (l).left = convert (literal_bead.words (1).left, ileft);
		     j -> literal_bead.words (l).right = convert (literal_bead.words (1).right, iright);
		     rblock (l) = rleft * twop18 + rright; /* glpl_$glwrd (rleft, rright) */
		end label_280a;
		else				/* */
label_211a:	do l = 1 to nwrds;
		     rblock (l) = 0;
		end label_211a;
		call putout_$putblk (pc, addr (j -> literal_bead.words), i66, nwrds, addr (rblock));
		j = pointer (eb_data_$lavptr, j -> literal_bead.next);
	     end;
	end;
	else
	call prlst_$prlst_ (nl_NO_LITERALS_nl);

	itxpc, deforg = fixed (pointer (eb_data_$lavptr, lplit) -> location_counter_bead.origin, 18) + litc;

/* assign locations to definitions, if required. */
	if (tmvdef = 0) then
	     do;
	     new_text_offset = 0;
	     new_text_length, new_definition_offset = deforg;
	     pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin = bit (fixed (deforg, 18), 18);
	     call alm_definitions_$emit_definitions (lnkorg, rlkdef, rsydef); /* Put out the definitions. */
	     new_definition_length = defc;
						/* save the length of the text segment - slave procedure. */
	     itxlen = defc + fixed (pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin, 18);
	end;
	else
	do;
	     pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin =
		bit (fixed (fixed (pointer (eb_data_$lavptr, lpsect) -> location_counter_bead.origin, 18) + lnkno, 18), 18);
	     call alm_definitions_$assign_definitions;	/* Merely assign definitions for later output. */
	     itxlen = fixed (pointer (eb_data_$lavptr, lplit) -> location_counter_bead.origin, 18) + litc;
	end;

/* force the linkage to begin on an even word boundary */
	if (mod (itxlen + idfpc, 2) ^= 0) then do;
	     curlc = lptext;
	     call putout_$putwrd (itxlen, 0, i66, 0);
	     /* The pad word is part of the defn section only when there is
	        more stuff to be added to the defn section. */
	     if idfpc > 0 then new_definition_length = new_definition_length + 1;
	end;
						/* Put out links, entries, and call - outs. */
						/* comment, initialize, and generate the eight word header. */
	if tnewobject = 0 then itxpc = itxlen;
	text_section_length = itxlen;
	call prlst_$prlst_ (ff_LINKAGE_INFORMATION_nl);
	tpulnk = 1;
	if eb_data_$separate_static
	   then lnkc = eb_data_$stat_len;
	   else lnkc = 0;
	curlc = lphead;
	if pointer (eb_data_$lavptr, lphead) -> location_counter_bead.value then
	     do;
	     call prnter_$prnter_ ("alm: fatal processing error in POSTP2 in the assembler");
	     call prnter_$abort1;
	end;
	tinhib = 0;
						/* put def ptr in header. */
	if (tmvdef = 0) then
	     do;
	     ldef = 0;
	     words (1) = 0;
	end;
	else
	do;
	     ldef = defcnt;
	     words (1) = mri;
	end;
	lnklen = lnkno + ldef + lnkorg;
	words (2) = convert (words (2), pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin) * twop18;
	lword (1) = 0;
	lword (2) = iltext;
	if (tmvdef ^= 0) then
	     lword (2) = illink;

	if tfirstreftrap ^= 0 then do;
	     words (2) = words (2) + lnklen;
	     lword (2) = lword (2) + ilink;
	     lnklen = lnklen + 3;
	     lnkno = lnkno + 3;
	end;
	call putout_$putlst (lnkc, words (1), i66, 2, lword (1));
						/* nxt blk ptr and pre blk ptr are 0 since only one */
						/* linkage block is currently produced by eplbsa. */
	words (1) = 0;
	words (2) = 0;
	words (3) = 0;
	words (4) = 0;
	call putout_$putlst (lnkc, words (1), i66, 4, words (1));
						/* put loc of links and block length in 7th word of header and */
						/* segment length in 8th word. */
	words (1) = lnkorg * twop18 + lnklen;
	lword (1) = illink + ilink;
          if ^ eb_data_$separate_static
             then words (2) = lnkorg - 8;
             else words (2) = eb_data_$stat_len;
          statlen = words (2);
          lword (2) = ilink;
	call putout_$putlst (lnkc, words (1), i66, 2, lword (1));

/* put out links, entries, and call - outs. */

	if eb_data_$separate_static
	   then lnkc = eb_data_$stat_len;
	   else lnkc = 0;
	curlc = lpsect;
	l = lnkorg;
	j = pointer (eb_data_$lavptr, lnklst);
label_1020:
	do while (rel (j));
	     go to control_1020 (fixed (j -> link_bead.kind, 18));

/* type 1 in list, normal link pair, generate fi pair. */
/* print proper names according to the type no. of the link. */
/* see mspm bd.7.01 for a discussion of the 5 link types. */
label_1030:    tinhib = 0;
						/* print the symbols corresponding to the link types. */
						/* but ignoring the internal expression values of the link. */
	     iexp = pointer (eb_data_$lavptr, pointer (eb_data_$lavptr,
		j -> link_bead.expression) -> expression_bead.type_pair);
	     iexp1 = convert (iexp1, iexp -> type_pair_bead.segment);
	     iname = addr (eb_data_$anames (2 * iexp1));
	     isym = pointer (eb_data_$lavptr, pointer (eb_data_$lavptr,
		iexp -> type_pair_bead.symbol) -> name_bead.name);
	     if isym = eb_data_$lavptr then
		isym = addr (eb_data_$blanks);
	     ilnkno = convert (ilnkno, iexp -> type_pair_bead.type); /* Extract the type no. of the link. */
	     go to control_1030 (ilnkno);		/* Branch on the link type. */

/* type 1 link, print *name only. */
label_1031:    isym = addr (eb_data_$blanks);
	     go to label_1037;

/* type 2 link, print base and symbol. */
label_1032:    iname = addr (eb_data_$bases (divide (iexp1, 32768, 26, 0)));
	     go to label_1037;

/* type 3 link, print segment name only. */
label_1033:    isym = addr (eb_data_$blanks);
						/* type 4 link, print segment and symbol */
label_1034:    iname = pointer (eb_data_$lavptr, pointer (eb_data_$lavptr, iexp1) -> name_bead.name);
label_1035:					/* type 5 link, print *name and symbol. */
label_1037:    call prnam_$prnam2 (iname, isym);		/* Print the segment and symbol characters for the fi pair. */
	     words (1) = - l * twop18 + mfi;
	     lword (1) = imblok * twop18;
	     words (2) = fixed (pointer (eb_data_$lavptr,
		j -> link_bead.expression) -> expression_bead.location || j -> link_bead.modifier, 18);
	     lword (2) = ildefs;
						/* put out the binary fi word pair. */
	     call putout_$putlst (lnkc, words (1), i642, 2, lword (1));
	     l = l + 2;
	     go to label_1080;

/* type 2, entry point, generate entry interlude. */
/* print entry sequence */
label_1040:    if tnewobject ^= 0 then goto label_1080;	/* Entries already processed. */
	     call prnam_$prnam_ (addr (eb_data_$entseq));
	     tinhib = convert (tinhib, j -> entry_bead.inhibit);
	     if (tprot = 0) then
		do;
		ientpc = pointer (eb_data_$lavptr, j -> entry_bead.transfer_vector);
		ioffst = convert (ioffst, ientpc -> transfer_vector_bead.location);
		ientlc = pointer (eb_data_$lavptr, ientpc -> transfer_vector_bead.location_counter);
		ival = fixed (ientlc -> location_counter_bead.origin, 18) + ioffst;
		words (1) = utils_$makins (0, - l, meaplp, 0, mpc);
		words (2) = utils_$makins (0, 3, eb_data_$maos, 0, mpc);
		words (3) = utils_$makins (0, ival, eb_data_$meax7, 0, 0);
		words (4) = utils_$makins (0, fixed (j -> entry_bead.link_no, 18) - l - 3 + lnkorg, mtra, 0, mpci);
		lword (1) = imlink * twop18;
		lword (2) = iselfr * twop18;
						/* extract the segment number to determine proper relocation. */
		isegno = convert (isegno, ientlc -> location_counter_bead.section);
		itemp = ibits (isegno);
		lword (3) = itemp * twop18;
		lword (4) = lword (2);
		call putout_$putlst (lnkc, words (1), i642, 4, lword (1));
		words (1) = 0;
		words (2) = 0;
		lword (1) = 0;
		lword (2) = 0;
		call putout_$putlst (lnkc, words (1), i66, 2, lword (1)); /* changed to i66 to keep inhibit bit off */
		l = l + 6;
	     end;
	     else
	     do;
						/* mastermode or execute only entry sequence */
		call putout_$putwrd (lnkc,
		     utils_$makins (0, (fixed (j -> entry_bead.transfer_vector_no, 18)), eb_data_$meax0, 0, 0), i642, 0);
		l = l + 1;
		words (1) = utils_$makins (0, - l, meaplp, 0, mpc);
		words (2) = utils_$makins (0, 2, eb_data_$maos, 0, mpc);
		words (3) = utils_$makins (0, fixed (j -> entry_bead.link_no, 18) - l - 2 + lnkorg, mtra, 0, mpci);
		lword (1) = imlink * twop18;
		lword (2) = iselfr * twop18;
		lword (3) = lword (2);
		call putout_$putlst (lnkc, words (1), i642, 3, lword (1));
		call putout_$putwrd (lnkc, 0, i66, 0);
		l = l + 4;
		call putout_$putwrd (lnkc, 0, i66, 0);
		l = l + 1;
	     end;
	     go to label_1080;

/* type 3, call - out, in mastermode put out call interlude. */
/* print call sequence comment; */
label_1070:    call prnam_$prnam_ (addr (eb_data_$calseq));
	     words (1) = utils_$makins (0, fixed (j -> call_out_bead.transfer_vector_no, 18), eb_data_$meax0, 0, 0);
	     words (2) = utils_$makins (0, fixed (j -> call_out_bead.type_pair, 18) - l - 1 + lnkorg, mtra, 0, mpci);
	     lword (1) = 0;
	     lword (2) = iselfr * twop18;
	     tinhib = convert (tinhib, j -> call_out_bead.inhibit);
	     call putout_$putlst (lnkc, words (1), i642, 2, lword (1));
	     l = l + 2;
						/* link through link list. */
label_1080:    j = pointer (eb_data_$lavptr, j -> link_bead.next);
	end label_1020;

/* First-reference trap array goes at end of links. */

	if tfirstreftrap ^= 0 then do;
	     call prlst_$prlst_ (nl_FIRST_REFERENCE_TRAP_LIST_nl);
	     words (1) = 1;				/* Declaration version. */
	     words (2) = 1;				/* Number of trap pointers. */
	     words (3) = first_ref_trap_proc_linkno * twop18 + first_ref_trap_arg_linkno;
	     lword (1), lword (2) = 0;
	     if first_ref_trap_arg_linkno = 0 then lword (3) = illink;
	     else lword (3) = illink + ilink;
	     call putout_$putlst (lnkc, words (1), i66, 3, lword (1));
	end;

/* end of links, decide to put out definitions or pointer. */

	if (tmvdef ^= 0) then			/* */
	     call alm_definitions_$emit_definitions (lnkorg, rlkdef, rsydef); /* Put out the definitions now. */
						/* Check for phase error in linkage file. */
	ilkpc = lnklen;
	if (tmvdef ^= 0) then
	     lnkc = lnkc + defc;
	if (lnkc ^= (lnkno + ldef) + eb_data_$stat_len) then
	     do;
	     call prnter_$prnter_ ("Phase error in the assembler while generating the linkage segment.");
	     call prnter_$abort1;
	end;

          if ^ eb_data_$separate_static
             then eb_data_$stat_len = statlen;

/* force linkage to be an even length */

	if (mod (ilkpc, 2) ^= 0) then
	     do;
	     call putout_$putwrd (lnkc, 0, i66, 0);
	     lnklen = lnklen + 1;
	     ilkpc = ilkpc + 1;
	end;
	call prlst_$prlst_ (ff_SYMBOL_INFORMATION_nl);
	ilc = curlc;
	curlc = lpst;
						/* assembler produced header always */
						/* begins following joined data of symbol segment. */
	ispc = fixed (pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin, 18);
	if mod (ispc, 2) ^= 0 then ispc = ispc + 1;
	call prlst_$prlst_ (SYMBOL_TABLE_HEADER_nl);
						/* if the symbol table header is changed */
						/* then the following calls must be */
						/* changed accordingly. */
						/* complete the symbol table header */
						/* store the text length and linkage length */
	sthedr_$text_and_link_lengths.text_length = bit (fixed (itxlen, 18), 18);
	sthedr_$text_and_link_lengths.link_length = bit (fixed (lnklen, 18), 18);
	if tnewobject ^= 0 then do;
	     call alm_symtab_$count_words (symtab_words);
	     optional_truncate = bit (fixed (ispc + new_sthedr_$hdrlen, 18), 18);
	     pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin, rel_text, default_truncate =
		bit (fixed (fixed (optional_truncate, 18) + symtab_words, 18), 18);
	     text_boundary = bit (fixed (itxtmod, 18), 18);
	     link_boundary = bit (fixed (ilnkmod, 18), 18);
	end;
	else pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin = bit (fixed (ispc + sthedr_$hdrlen, 18), 18);

	call putxt_$txtcnt (val);			/* Count relocation bits. */
	if tnewobject = 0 then if tmvdef = 0 then val = val + 8; /* Adjust for rlkdef, rsydef output later. */
	tpc = convert (tpc, pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin);
						/* call pusmb_$pusmb_ (tpc, val, 0); DONE BY PAKBIT. */
	itxcnt = val;
	nwrds = divide (val + 35, 36, 26, 0) + 1;
	if tnewobject ^= 0 then nwrds = nwrds + 1;
	iaddr = nwrds + fixed (pointer (eb_data_$lavptr, lprtx) -> location_counter_bead.origin, 18);
	pointer (eb_data_$lavptr, lprlk) -> location_counter_bead.origin =
	     bit (fixed (iaddr, 18), 18);

	if tnewobject = 0 then if tmvdef = 0 then
		call putxt_$putxt_ (rlkdef, iaddr * twop18 + 2, ilsymb);
	     else					/* */
	     call pulnk_$pulnk_ (rlkdef, iaddr * twop18 + 2, ilsymb);
	else rel_link = bit (fixed (iaddr - ispc, 18), 18);

	call pulnk_$lnkcnt (val);
	if (tmvdef ^= 0) then
	     val = val + 4;
	tpc = convert (tpc, pointer (eb_data_$lavptr, lprlk) -> location_counter_bead.origin);
						/* call pusmb_$pusmb_ (tpc, val, 0); DONE BY PAKBIT. */
	ilkcnt = val;
	nwrds = divide (val + 35, 36, 26, 0) + 1;
	if tnewobject ^= 0 then nwrds = nwrds + 1;
	iaddr = iaddr + nwrds;
	pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin =
	     bit (fixed (iaddr, 18), 18);

	if tnewobject = 0 then if tmvdef = 0 then
		call putxt_$putxt_ (rsydef, iaddr * twop18 + 2, ilsymb);
	     else					/* */
	     call pulnk_$pulnk_ (rsydef, iaddr * twop18 + 2, ilsymb);
	else rel_def = bit (fixed (iaddr - ispc, 18), 18);

	l = itxpc;	/* l(def) = l(def+text)-l(text)+l(exp def) */
	itxpc = itxpc + new_definition_length;
	call putxt_$txtcnt(idfcnt);
	itxpc = l;	/* restore value of itxpc */
	call putxt_$txtcnt(val);
	l = idfcnt - val;	/* l(def+text) - l(text) */
	call pudef_$defcnt(val);	/* calculate length of reloc info for definition section */
	val = val + l;
	if (tmvdef ^= 0) then
	     val = val + 4;
	tpc = convert (tpc, pointer (eb_data_$lavptr, lpdefs) -> location_counter_bead.origin);
						/* call pudef_$pudef_ (tpc, val, 0); DONE BY PAKBIT. */
	idfcnt = val;
	nwrds = divide (val + 35, 36, 26, 0) + 1;
	if tnewobject ^= 0 then nwrds = nwrds + 1;
	iaddr = iaddr + nwrds;
	pointer (eb_data_$lavptr, lprst) -> location_counter_bead.origin =
	     bit (fixed (iaddr, 18), 18);

	if tnewobject = 0 then if tmvdef = 0 then
		call putxt_$putxt_ (rsydef, iaddr * twop18 + 2, ilsymb);
	     else					/* */
	     call pulnk_$pulnk_ (rsydef, iaddr * twop18 + 2, ilsymb);
	else rel_symbol = bit (fixed (iaddr - ispc, 18), 18);

	new_sthedr_$block_size.block_size =
	     bit (fixed (iaddr - ispc + divide (fixed (default_truncate, 18) + 17, 18, 17, 0) + 2, 18), 18);
						/*  *** ASSUMING all absolute relocation for symbol header. *** */

	ilc = curlc;
	curlc = lpst;
	if tnewobject = 0 then call putout_$putblk (ispc, addr (sthedr_$sthedr_), i66, sthedr_$hdrlen, null ());
	else do;
	     call putout_$putblk (ispc, addr (new_sthedr_$new_sthedr_), i66, new_sthedr_$hdrlen, addr (new_sthedr_$relocinfo));
	     call alm_symtab_$emit (ispc);
	end;
	istpc = ispc;
	curlc = ilc;
	call pusmb_$symcnt (itemp);
     end postp2_;




		    prlst_.pl1                      10/17/88  1013.9rew 10/17/88  0938.4       26937



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



/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Rewritten to ignore alignment and not put out padding characters.
                                                   END HISTORY COMMENTS */


/* prlst_ procedure to put a remark into the ALM listing. A newline
   is added to each line. This is used by all of ALM except prwrd_
   which does it himself for efficiency.

   Totally recoded by Richard Gray, 2/14/85, (alm 6) to remove word
   alignments and padding characters.  Note: lstlen used to be
   current length of listing component in words, now the length is
   in characters. */

prlst_:	procedure(remark);
dcl	remark char(*);
dcl	(length, substr) builtin;
dcl	(strstart, strlen, strmaxlen) fixed bin(21);
dcl	listing_segment char(strlen) based(list);
dcl	ec fixed bin(35);

dcl	eb_data_$list_component fixed bin external;
dcl	eb_data_$listing_max_length fixed bin(19) external;
dcl	eb_data_$who_am_I char(12) external;
dcl	error_table_$segknown fixed bin(35) external;
dcl	utils_$abort external entry;
dcl	com_err_ entry options(variable);
dcl	msf_manager_$get_ptr entry(ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl	NL char(1) int static options(constant) init("
");

%include segnfo;

%include lstcom;

%include alm_options;

	if tnolst ^= 0 then return; /* no listing wanted */
	strstart = lstlen + 1;
	strlen = length(remark) + 1;
	strmaxlen = 4*eb_data_$listing_max_length - lstlen;
	if strlen > strmaxlen then do;
		lstlen = lstlen + strmaxlen;
		substr(listing_segment, strstart, strmaxlen) = substr(remark, 1, strmaxlen);
		call new_list_seg;
		lstlen = strlen - strmaxlen;
		substr(listing_segment, 1, lstlen) = substr(remark || NL, strmaxlen+1, lstlen);
		return;
	  end;
	lstlen = lstlen + strlen;
	substr(listing_segment, strstart, strlen) = remark || NL;
	return;

new_list_seg:	entry;
	eb_data_$list_component = eb_data_$list_component + 1;
	call msf_manager_$get_ptr(eb_data_$segnfo.list_fcb, eb_data_$list_component, "1"b, eb_data_$segnfo.list, 0, ec);
	eb_data_$segnfo.lstlen = 0;
	if ec ^= 0 then  if ec ^= error_table_$segknown then do;
		if tquietsw ^= 1 then call com_err_(ec, eb_data_$who_am_I, "Listing segment.");
		call utils_$abort;
	  end;
end prlst_;




		    prnam_.pl1                      10/17/88  1013.9r   10/17/88  0938.4       23814



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

prnam_:	proc( link );		/* this procedure puts symbols in the listing for postp2_ by
				faking a source line */
/**/
%include varcom;
%include lstcom;
/**/
dcl	(link, segname, symname)	ptr;
dcl	(count,count2)	fixed bin;

dcl	1 array_overlay	based aligned,
	2 words(count2)	bit(36) aligned;

dcl	char	based char(1) aligned;

dcl	1 eb_data_$oulst external, 2 oulst char(68) aligned;
/**/
	if tnolst ^= 0 then return;				/* ignore call if no listing */
	count = fixed(unspec(substr(link->char,1,1)),9,0);	/* get the count of the string */
	count2 = divide(count+4, 4, 17, 0);			/* convert it to words */
	addr(oulst) -> array_overlay = link -> array_overlay;	/* do a word by word move */
common:	substr(oulst, count+2, 1) = "
";							/* append a new_line */
	source_printed = "0"b;				/* set a flag so prwrd will print the line */
	return;
/**/
prnam2:	entry(segname, symname);	/* like prnam except takes two symbols and puts a | between them */
	if tnolst ^= 0 then return;				/* ignore the call if no listing */
	count = fixed(unspec(substr(segname->char,1,1)),9,0);	/* get the character count */
	count2 = divide(count+4, 4, 17, 0);			/* get the word count */
	addr(oulst) -> array_overlay = segname -> array_overlay;	/* do a word by word move */
	count = count + 1;					/* add a character for the count at the beginning */
	substr(oulst, count+1, 1) = "|";			/* put in the | */
	count2 = fixed(unspec(substr(symname->char,1,1)),9,0);	/* get the character count of the second symbol */
	substr(oulst, count+2, count2) = substr(symname->char, 2, count2);/*append it to the first*/
	count = count + count2;				/* get the total count */
	goto common;					/* and finish up */
/**/
	end prnam_;




		    prnter_.pl1                     10/17/88  1013.9rew 10/17/88  0938.4       26757



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


prnter_:	procedure ( line ) ;

  
	/* Last modified on 4/3/77 by Greenberg for macro entries. */
	/* Last modified on 11/23/72 at 02:29:18 by R F Mabee. Removed superfluous "abandoning assembly" message. */
	/* Modified by RHG on 17 September 1970 for new listing package */
  
	/* this procedure calls prlst to generate the comment and then writes 
	  the comment into the user's output stream */

declare line char (*)  ;

declare ioa_ external entry options (variable);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$user_output ptr external;

dcl  p1_macroerr_debug_sw static init ("0"b)bit (1);
dcl  nl char (1) static options (constant) init ("
");

declare	eb_data_$abort_assembly external static label;
declare	eb_data_$who_am_I external static char(12);
declare	com_err_ external entry options (variable);
  
declare prlst_$prlst_ external entry (char(*)) ;

	call prlst_$prlst_(line) ;

	call ioa_(line) ;

	return;

no_storage:	entry ;
		/* for GLPL usage */
	call com_err_(0, eb_data_$who_am_I, "list of available storage has been exhausted") ;

	go to abort_it ;


phsmsg:	entry ;
		/* for OBJECT usage */

	call com_err_(0,eb_data_$who_am_I, "Phase error while generating the object segment") ;

	go to abort_it ;



no_end_card:	entry ;

	call com_err_(0,eb_data_$who_am_I, "End statement missing.") ;

	go to abort_it ;

abort1:	entry ;

	/* for general usage */

abort_it:	goto eb_data_$abort_assembly;

macro_error:  entry (console_remark,  listing_remark);

dcl (console_remark, listing_remark) char (*);

	if tpass2 = 0 & ^p1_macroerr_debug_sw then return;

	if console_remark ^= "" & tquietsw = 0 then do;
	     call iox_$put_chars (iox_$user_output, addr (console_remark), length (console_remark), (0));
	     call iox_$put_chars (iox_$user_output, addr (nl), 1, (0));
	end;

	if listing_remark ^= "" then call prlst_$prlst_ (listing_remark);
	return;

debug_p1_macroerr: entry (sw);

	dcl sw char (*);

	if sw = "on" then p1_macroerr_debug_sw = "1"b;
	else p1_macroerr_debug_sw = "0"b;
	return;

general_abort: entry (abort_remark);

dcl  abort_remark char (*);

	call com_err_  (0, eb_data_$who_am_I, abort_remark);
	call prlst_$prlst_ (abort_remark);
	go to abort_it;

/**/

%include varcom;
%include alm_options;

end prnter_ ;




		    prwrd_.pl1                      10/17/88  1013.9rew 10/17/88  0938.3       80109



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support error severity, block joined to the definition
     section, and to remove pads from the listing.
                                                   END HISTORY COMMENTS */


prwrd_$prwrd_: procedure (pc, word, how);

/*
   Modified 4/29/81 by EBush to make A error fatal and B non-fatal.
   Modified 2/5/81 by EBush to add A error.
   Modified 3/25/77 by Greenberg for iox_ and no line buffer.
   Modified 3/23/77 by Noel I. Morris for macro processing.
   modified in 01/74 by E Stone to convert to v2 and to change check for end of listing seg
   modified on 11/28/72 at 20:49:00 by R F Mabee.
   Another line numbering change and 36-bit values for equ, 28 November 1972, R F Mabee.
   Minor change to line numbering, 23 July 1972, R F Mabee.
   Added B and C error codes, 16 April 1972, R F Mabee.
   by RHG on 3 June 1971 to get binlin right even if no list
   by R H Campbell 15 Nov 1970
   */
	relwrd = ""b;
	go to pr_common;

prwrd_$source_only:
	entry;
	source_only_flag = "1"b;
	go to common;

prwrd_$prwrd2:
	entry (pc, word, how, relarg);
	relwrd = relarg;
pr_common:
	source_only_flag = ""b;
	go to common;				/* Go to it. */
						/*  */
dcl  prlst_$new_list_seg entry;
dcl  eb_data_$ib6 external fixed bin;			/* character (4) */
dcl  eb_data_$macro_linect external fixed bin;
dcl  eb_data_$listing_max_length external fixed bin (35);
dcl  eb_data_$nlpads external character (4);
dcl  eb_data_$macro_depth fixed bin external,
     eb_data_$include_control bit (110) aligned external;
dcl  eb_data_$include_number fixed bin external;
dcl  eb_data_$macro_listing_control bit (36) aligned external;
dcl  err_count fixed bin;
dcl  source_had_been_printed bit (1) aligned;
dcl  flag_character char (18) static options (constant) init
    ("EFMNOPRSTUXBCDA567");
dcl  error_sv(18) fixed bin int static options(constant) init
    (3, 1, 3, 2, 3, 3, 1, 2, 2, 3, 0, 1, 0, 3, 3, 0, 0, 1);
dcl  how fixed bin (35);				/* character (4) aligned */
dcl  i fixed bin;
dcl  hdrlen fixed bin;
dcl  source_charray char (1) unal based (source) dim (srclen);
dcl  source_line char (linelen) based (addr (source_charray (begin_line + 1)));
dcl  linelen fixed bin;
dcl  padlen fixed bin;
dcl  iox_$user_output ptr ext;
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  prwrd_util_$pc entry (char (40), bit (36) aligned);
dcl  prwrd_util_$inst entry (char (40), bit (36) aligned, fixed bin (35));
dcl  j fixed bin;
dcl  listing_buf char (40);
dcl  (strstart, strlen, strmaxlen) fixed bin(21);
dcl  listing_segment char(strlen) based(list);
dcl  based_listing_buf char (hdrlen) based (addr (listing_buf));
dcl 1 listline aligned based (addrel (list, lstlen)),	/* to listing */
    2 chars char (linelen) unal,
    2 pads char (padlen) unal;

dcl  listing_buf_pointer pointer;
dcl  NL static character (1) initial ("
");						/* New line. */
dcl  num pic "zzzzzzz9";
dcl  zzzz9 pic "zzzz9";
dcl  pc bit (36) aligned;				/* fixed bin (35) */
dcl  relarg bit (36) aligned;
dcl  reloc_character char (32) static options (constant) init
    ("a???????????????0123456789Ld???*");
dcl  relwrd bit (36) aligned;
dcl  source_only_flag bit (1) aligned;
dcl  source_segment character (srclen) based (source) aligned;
dcl  word bit (36) aligned;
dcl (addr, addrel, bin, divide, index, length, ltrim, min, substr) builtin;
%	include concom;
%	include erflgs;
%	include lstcom;
%	include segnfo;
%	include varcom;
%	include alm_options;
/*  */
/* FIRST CLEAR THE LISTING BUFFER */
common:	listing_buf = " ";				/* Blank out listing buffer header */
						/* FIRST PRINT THE FLAGS IF ANY */
	err_count = 0;
	do i = 1 to 18;				/* Print out the error flags, if any. */
	     if flgvec (i) ^= 0 then do;		/* Is this flag set? */
		tfatal = max(tfatal, error_sv(i));	/* Severity of worst error. */
		flgvec (i) = 0;			/* Clear the flag now that we are printing it. */
		if err_count < 3 then do;		/* Do we have room for this flag? */
		     substr (listing_buf, err_count + 1, 1) = substr (flag_character, i, 1); /* Yes, print it. */
		     err_count = err_count + 1;
		end;
	     end;
	end;

	if err_count = 0 & tnolst ^= 0 then do;
	     source_printed = "1"b;			/* Don't print if no list, no errors. */
	     return;
	end;

	if (eb_data_$macro_depth > 0) & (err_count = 0) then do;
	     if substr (eb_data_$macro_listing_control, 1, 1) then
		source_printed = "1"b;
	     if substr (eb_data_$macro_listing_control, 2, 1) then
		return;
	end;

	if ^source_only_flag then do;

/* NOW PRINT OUT THE PROGRAM COUNTER */
	     if how ^= eb_data_$ib6 then
		call prwrd_util_$pc (listing_buf, pc);

/* CHECK IF LEFT HALF OF WORD IS BLANK */
	     if how = ibb then;
	     else if (how = eb_data_$ib6) then
		if (substr (word, 1, 18) ^= "0"b) then
		     call prwrd_util_$inst (listing_buf, word, (i66));
		else call prwrd_util_$inst (listing_buf, word, how);
	     else do;
		substr (listing_buf, 13, 1) = substr (reloc_character, bin (substr (relwrd, 1, 18), 18) + 1, 1);
		substr (listing_buf, 14, 1) = substr (reloc_character, bin (substr (relwrd, 19, 18), 18) + 1, 1);
		call prwrd_util_$inst (listing_buf, word, how);
	     end;
	end;
	else if eb_data_$macro_linect > 0 then do;	/* List macro def line */
	     zzzz9 = eb_data_$macro_linect;
	     substr (listing_buf, 27, 5) = zzzz9;
	end;

/* NOW ADD THE SOURCE IF IT HAS NOT ALREADY BEEN PRINTED */
	source_had_been_printed = source_printed;
	if tquietsw ^= 0 then err_count = 0;		/* Force error count zero in quiet mode. */
	if source_printed & err_count = 0 then do;	/* Only octal word to print. */
	     substr (listing_buf, 32, 1) = NL;		/* Append a new-line character. */
	     hdrlen = 32;
	end;
	else do;
	     hdrlen = 40;
	     if tpostp = 0 then do;

		num = binlin;
		j = length (ltrim (num));
		i = 39 - j;
		substr (listing_buf, i, j) = ltrim (num);

		if include_index > 0 then do;		/* Insert include file number into listing. */
		     num = eb_data_$include_number;
		     j = length (ltrim (num));
		     i = i - 1;
		     substr (listing_buf, i, 1) = "-";
		     i = i - j;
		     substr (listing_buf, i, j) = ltrim (num);
		end;

	     end;
	     linelen = index (substr (source_segment, begin_line + 1), NL) - 1; /* Find last character on this line. */
	     if linelen < 0 then linelen = srclen - begin_line;
	     if err_count ^= 0 & tquietsw = 0 then do;	/* Output problems to iox_ */
		call iox_$put_chars (iox_$user_output, addr (listing_buf), hdrlen, (0));
		call iox_$put_chars (iox_$user_output, addr (source_line), length (source_line)+1, (0));
	     end;

	     if source_had_been_printed then
		substr (listing_buf, 40, 1) = NL;
	     source_only_flag = "0"b;			/* make sure we print. */
	     source_printed = "1"b;
	     if substr (eb_data_$include_control, 1, 1) | source_had_been_printed then
		substr (listing_buf, 33, 6) = "";	/* Greenberg doesn't like this. */
	end;
	if source_only_flag then return;
	if tnolst ^= 0 then return;			/* As you like it, mister. */

	strstart = lstlen + 1;
	strmaxlen = 4*eb_data_$listing_max_length - lstlen;
	if hdrlen > strmaxlen then do;
		lstlen = lstlen + strmaxlen;
		substr(listing_segment, strstart, strmaxlen) = substr(listing_buf, 1, strmaxlen);
		call prlst_$new_list_seg;
		lstlen = hdrlen - strmaxlen;
		substr(listing_segment, 1, lstlen) = substr(listing_buf, strmaxlen+1, lstlen);
	  end;
	else do;
	     lstlen = lstlen + hdrlen;
	     substr(listing_segment, strstart, hdrlen) = based_listing_buf;
	  end;

	if source_had_been_printed then return;		/* detail line */

	strstart = lstlen + 1;
	strlen = length(source_line) + 1;
	strmaxlen = 4*eb_data_$listing_max_length - lstlen;
	if strlen > strmaxlen then do;
		lstlen = lstlen + strmaxlen;
		substr(listing_segment, strstart, strmaxlen) = substr(source_line, 1, strmaxlen);
		call prlst_$new_list_seg;
		lstlen = strlen - strmaxlen;
		substr(listing_segment, 1, lstlen) = substr(source_line || NL, strmaxlen+1, lstlen);
		return;
	  end;
	lstlen = lstlen + strlen;
	substr(listing_segment, strstart, strlen) = source_line || NL;
	return;

end prwrd_$prwrd_;




		    prwrd_util_.alm                 10/17/88  1013.9rew 10/17/88  0938.1       18738



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name	prwrd_util_
	entry	pc
	entry	inst


	include	eis_micro_ops



pc:
	eppbp	ap|2,*		bp -> output line
	eppbb	ap|4,*		bb -> loc counter

	mvt	(pr),(pr)		convert
	desc6a	bb|0,6
	desc9a	lp|temp,6
	arg	table

	mvn	(pr),(pr)		copy to output line
	desc4ns	lp|temp(6),6
	desc9ns	bp|1,6

	short_return



inst:
	eppbp	ap|2,*		bp -> output line
	eppbb	ap|4,*		bb -> instruction word

	lda	ap|6,*		get format
	eax1	0		initialize index
	rpt	nfmts,2,tze	search for correct one
	cmpa	fmts,1		..
	ldq	-1,1		get pointer and length
	eppab	0,qu		ab -> micro-op string
	eax2	0,ql		X2 contains length of micro-op

	mvt	(pr),(pr)		convert
	desc6a	bb|0,6
	desc9a	lp|temp,6
	arg	table

	mvne	(pr),(pr,rl),(pr)
	desc4ns	lp|temp,12
	desc9a	ab|0,x2
	desc9a	bp|4,15

	short_return


fmts:	aci	"642 "
	zero	f642,6
	aci	" 6  "
	zero	fb6,4
	aci	"1542"
	zero	f1542,7
	aci	"3333"
	zero	f3333,7
	aci	"66  "
	zero	f66,5

	equ	nfmts,(*-fmts)/2


f642:	vfd	9/insm+1,9/mvc+6,9/insm+1,9/mvc+4,9/insm+1,9/mvc+2
fb6:	vfd	9/ign+6,9/insm+8,9/mvc+6,9/insm+1
f1542:	vfd	9/mvc+1,9/insm+1,9/mvc+5,9/insm+1,9/mvc+4,9/insm+1,9/mvc+2
f3333:	vfd	9/mvc+3,9/insm+1,9/mvc+3,9/insm+1,9/mvc+3,9/insm+1,9/mvc+3
f66:	vfd	9/insm+1,9/mvc+6,9/insm+1,9/mvc+6,9/insm+2



table:	ac4	"0001020304050607"
	ac4	"1011121314151617"
	ac4	"2021222324252627"
	ac4	"3031323334353637"
	ac4	"4041424344454647"
	ac4	"5051525354555657"
	ac4	"6061626364656667"
	ac4	"7071727374757677"



	use	is
	join	/link/is

temp:	bss	,2


	end




		    pudef_.pl1                      10/17/88  1013.9rew 10/17/88  0938.3       16632



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Created to allow for joining blocks to the definition section.
                                                   END HISTORY COMMENTS */

pudef_:
	procedure( pc, word, relwrd ) ;

	/* makes calls to stack the definition words and stack the
	 associated relocation bits in the scratch segment */

declare	(pc, word, relwrd) fixed bin (26);
declare	(lbits, rbits, itemp, nl, nr, i, ival ) fixed bin ( 17 ) aligned ;

% include objnfo ;

declare	object_$objdf ext entry (fixed bin (26), fixed bin (26)),
	object_$wrbdf ext entry (fixed bin (26), fixed bin (26)),
	object_$getbdf ext entry (fixed bin, fixed bin, fixed bin) ;

	call object_$objdf( pc, word ) ;	/* write the symbol into the scratch segment */

	call object_$wrbdf( pc, relwrd ) ;	/* insert the relocation bits into the proper place in the scratch segment */ 


	return ;




defcnt:	entry( ival ) ;	/* entry to count the number of relocation bits for the definition portion */

	ival = 0 ;

	itemp = idfpc - 1 ;

label_1000:
	do i = 0 to itemp ;

		call object_$getbdf( i, lbits, rbits ) ;

		nl = 1 ;

		nr = 1 ;

		if lbits ^= 0 then nl = 5 ;

		if rbits ^= 0 then nr = 5 ;

		ival = nl + nr + ival ;

end label_1000 ;


	idfcnt = ival ;

end pudef_ ;




		    pulnk_.pl1                      10/17/88  1013.9r w 10/17/88  0938.3       19791



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


pulnk_:
	procedure( pc, word, relwrd ) ;

/* N. Adleman on June 24, 1970 at 1011  */
/* Modified for separate static on 06/15/75 by Eugene E Wiatrowski */
  
	/* makes calls to stack the linkage words and stack the
	  associated relocation bits in the scratch segment */

declare (pc, word, relwrd) fixed bin (26);
declare (lbits, rbits, itemp, nl, nr, i, ik, ival ) fixed bin ( 17 ) aligned ;

declare eb_data_$stat_len ext fixed bin(26);
declare eb_data_$separate_static ext bit(1) aligned;

% include objnfo ;

	/* EXTERNAL ENTRIES */
declare	object_$objlk ext entry (fixed bin (26), fixed bin (26)),
	object_$wrblk ext entry (fixed bin (26), fixed bin (26)),
	object_$gtblk ext entry (fixed bin, fixed bin, fixed bin) ;

/* 	*/

	call object_$objlk( pc, word ) ;	/* write the linkage into the scratch segment */

	call object_$wrblk( pc, relwrd ) ;	/* insert the relocation bits into the proper place in the scratch segment */ 


	return ;




lnkcnt:	entry( ival ) ;	/* entry to count the number of relocation bits for the linkage portion */

	ival = 0 ;

	if eb_data_$separate_static
	   then do;
	        itemp = (eb_data_$stat_len + ilkpc) - 1;
	        ik = eb_data_$stat_len;
	        end;
	   else do;
	        itemp = ilkpc - 1;
	        ik = 0;
	        end;

label_1000:
	do i = ik to itemp ;

		call object_$gtblk( i, lbits, rbits ) ;

		nl = 1 ;

		nr = 1 ;

		if lbits ^= 0 then nl = 5 ;

		if rbits ^= 0 then nr = 5 ;

		ival = nl + nr + ival ;

end label_1000 ;

	ilkcnt = ival ;

end pulnk_ ;




		    pusmb_.pl1                      10/17/88  1013.9r w 10/17/88  0938.3       16281



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


pusmb_:
	procedure( pc, word, relwrd ) ;

/* Last modified by NA on June 24, 1970 at 1022 */
  
	/* makes calls to stack the symbol words and stack the
	 associated relocation bits in the scratch segment */

declare	(pc, word, relwrd) fixed bin (26);
declare	(lbits, rbits, itemp, nl, nr, i, ival ) fixed bin ( 17 ) aligned ;

% include objnfo ;

declare	object_$objst ext entry (fixed bin (26), fixed bin (26)),
	object_$wrbst ext entry (fixed bin (26), fixed bin (26)),
	object_$getbst ext entry (fixed bin, fixed bin, fixed bin) ;

	call object_$objst( pc, word ) ;	/* write the symbol into the scratch segment */

	call object_$wrbst( pc, relwrd ) ;	/* insert the relocation bits into the proper place in the scratch segment */ 


	return ;




symcnt:	entry( ival ) ;	/* entry to count the number of relocation bits for the symbol portion */

	ival = 0 ;

	itemp = istpc - 1 ;

label_1000:
	do i = 0 to itemp ;

		call object_$getbst( i, lbits, rbits ) ;

		nl = 1 ;

		nr = 1 ;

		if lbits ^= 0 then nl = 5 ;

		if rbits ^= 0 then nr = 5 ;

		ival = nl + nr + ival ;

end label_1000 ;


	istcnt = ival ;

end pusmb_ ;




		    putout_.pl1                     10/17/88  1013.9rew 10/17/88  0938.3       34479



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to allow for joining blocks to the definition section.
                                                   END HISTORY COMMENTS */


putout_:	procedure ;

  
/* Modified for separate static on 06/15/75 by Eugene E Wiatrowski */
/* Modified on 11/23/72 at 00:56:57 by R F Mabee. Removed eb_data_$zerbuf. */
/* Modified by RHG on 7 August 1970 at 0534 to fix dimension of eb_data_$zerbuf */
% include varcom ;

% include concom ;

% include curlc ;

declare	(lary, rary, xlary, xlword) ptr ;
 
 declare	binword (n) fixed binary based (lary);
 
declare	relword(n) based (rary) fixed bin (35) ;
 
declare	( xpc, xary, xword, xhow, xn, how, rword, xrary, xrword, relwrd, origin, segmnt, i, n ) fixed bin (35) ; 
	declare word fixed bin (35);

declare	( eb_data_$mb28, eb_data_$mb29) fixed bin ( 35 )  ext ;

	/* EXTERNAL FUNCTIONS */
declare	glpl_$clh ext entry (fixed bin) returns (fixed bin),
	glpl_$crh ext entry (fixed bin) returns (fixed bin),
	utils_$or ext entry (fixed bin (35), fixed bin (35)) returns (fixed bin (35)),
	utils_$and ext entry (fixed bin (35), fixed bin (35)) returns (fixed bin (35)) ;

	/* EXTERNAL ENTRIES */
declare	putxt_$putxt_ ext entry (fixed bin (35), fixed bin (35), fixed bin (35)),
	pulnk_$pulnk_ ext entry (fixed bin (35), fixed bin (35), fixed bin (35)),
	pudef_$pudef_ ext entry (fixed bin (35), fixed bin (35), fixed bin (35)),
	pusmb_$pusmb_ ext entry (fixed bin (35), fixed bin (35), fixed bin (35)),
	prwrd_$prwrd2 ext entry (fixed bin (35), fixed bin (35), fixed bin (35), fixed bin (35)) ;


putlst:	entry( xpc, xary, xhow, xn, xrary ) ;

	n = xn ;

	lary = addr( xary ) ;

	rary = addr(xrary) ;
  
	go to label_1000 ;



putwrd:	entry( xpc, xword, xhow, rword ) ;

	n = 1 ;

	lary = addr( xword ) ;

	rary = addr( rword ) ;

	go to label_1000;




putblk:	entry( xpc, xlary, xhow, xn, xlword ) ;

	n = xn ;

	lary = xlary ;

	rary = xlword ;






label_1000:

	origin = glpl_$clh( curlc + 3 ) ;

	segmnt = glpl_$crh( curlc + 4 ) ;


label_1030:

	do i = 1 to n ;

		word = lary -> binword(i)  ;

		if rary ^= null () then relwrd = rary -> relword (i) ; else relwrd = 0;

		how = xhow ;

	if utils_$and( word, eb_data_$mb29 ) ^= 0 & how = i642 then how = i1542 ;

	if tinhib ^= 0 & ( how = i642 | how = i1542 ) then word = utils_$or( word, eb_data_$mb28 ) ;

	if segmnt = 1 then go to label_1010 ;	/* link */

	if segmnt = 2 then go to label_1015 ;	/* symbol */

	if segmnt = 4 then go to label_1010 ;   /* separate static */

	if segmnt = 8 then go to label_1017 ;   /* definition */


label_1005:
				/* text */

	call putxt_$putxt_ ( xpc+origin, word, relwrd ) ;

	go to label_1020 ;


label_1010:

	call pulnk_$pulnk_ ( xpc+origin, word, relwrd ) ;

	go to label_1020 ;

label_1015:

	call pusmb_$pusmb_ ( xpc+origin, word, relwrd ) ;

	go to label_1020 ;

label_1017:

	call pudef_$pudef_ ( xpc+origin, word, relwrd ) ;


label_1020:

	call prwrd_$prwrd2( xpc+origin, word, how, relwrd ) ;

	xpc = xpc + 1 ;

end label_1030 ;

end putout_ ;




		    putxt_.pl1                      10/17/88  1013.9r w 10/17/88  0938.3       16335



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


putxt_:	procedure( pc, word, relwrd ) ;

	/* Last modified by NA on June 25, 1970 at 1626 */
  
	/* makes calls to write the object text and stack the
	 associated relocation bits */

declare	(pc, word, relwrd) fixed bin (26);
declare	(lbits, rbits, itemp, nl, nr, i, ival ) fixed bin ( 17) aligned ;

% include objnfo ;

	/* EXTERNAL ENTRIES */
declare	object_$object_ ext entry (fixed bin (26), fixed bin (26)),
	object_$wrbtx ext entry (fixed bin (26), fixed bin (26)),
	object_$getbtx ext entry ( fixed bin, fixed bin, fixed bin) ;

	call object_$object_( pc, word ) ;	/* write the text directly into the object segment */

	call object_$wrbtx( pc, relwrd ) ;	/* insert the relocation bits into the proper place in the scratch segment */ 

	return ;




txtcnt:	entry( ival ) ;	/* entry to count the number of relocation bits for the text portion */

	ival = 0 ;

	itemp = itxpc - 1 ;

label_1000:
	do i = 0 to itemp ;

		call object_$getbtx( i, lbits, rbits ) ;

		nl = 1 ;

		nr = 1 ;

		if lbits ^= 0 then nl = 5 ;

		if rbits ^= 0 then nr = 5 ;

		ival = nl + nr + ival ;

end label_1000 ;

	itxcnt = ival ;

end putxt_ ;




		    setid_.pl1                      10/17/88  1013.9r w 10/17/88  0938.3        9693



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


setid_:	procedure(symlnk);
/**/
%include varcom;
/**/
dcl	inputs_$getid	ext entry;
dcl	glpl_$setblk	ext entry(fixed bin (26), fixed bin (26)) returns(fixed bin (35));
dcl	(symlnk, count)	fixed bin (35);
/**/
	call inputs_$getid;
	count = fixed(substr(unspec(sym(1)),1,9),9,0);
	if count = 0 then symlnk = 0;
	else symlnk = glpl_$setblk(sym(1),divide(count+4,4,26,0));
	return;
end setid_;




		    sthedr_.alm                     10/17/88  1013.9r w 10/17/88  0938.1       17163



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

"	This is the symbol table header skeleton for alm.
"	The version number should be updated every
"	time that any part of alm is changed.
" Modified 740905 by PG and ARD for installation of Version 4.5 (Version 2 PL/I).

	name	sthedr_
	use	impure
	join	/link/impure

	bool	char_dope,240000
	segdef	hdrlen
	segdef	sthedr_		impure data
	segdef	alm_creation_date,time_of_translation
	segdef	text_and_link_lengths,seg_name

sthedr_:
sthead:	zero	0,36*(tra_name-sthead)+9 dope for translator name
	zero	char_dope,9*tra_name_length (includes 9 bits for char count)

	zero	0,36*(ver_name-sthead)+9 dope for vers. name
	zero	char_dope,9*ver_name_length

alm_creation_date:
	dec	0,0		This is the clock at the creation of alm itself
time_of_translation:
	dec	0,0		This is the clock at assembly time.

	zero	0,0		root pointer, 0
	zero	0,2		map pointer, 2*n files
	zero	0,0		next header, binder indicator
text_and_link_lengths:
	zero	0,0		text length, linkage length

	zero	0,36*(seg_name-sthead) dope for segment name
	zero	char_dope,9*32	Always allow for maximum length name

tra_name:	acc	"alm";	equ	tra_name_length,3

ver_name:	acc	"ALM Version 4.5, September 1974";	equ	ver_name_length,31

seg_name:	bss	,8		For segment name from "name" pseudo-op or command arg.

hdrlen:	zero	0,*-sthead

	end




		    table_.pl1                      10/17/88  1013.9rew 10/17/88  0938.3       92394



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

table_:
     procedure (dowhat, xsym, xval, xflags, xaddr) returns (fixed binary (17));
			/* assignment table routine for symbols in the program being assembled */

/*
	Modified for new hashing schema on 02/10/76 by Eugene E Wiatrowski.
	Modified on 11/28/72 at 19:21:37 by R F Mabee.
	by RFM on 28 August and 22 November 1972 to fix little bugs.
	by RFM on 23 July 1972 to keep referencing line numbers for each name.
			This makes it possible for ALM to produce a cross reference table.
	by RHG on 3 June 1971 to fix flagging of multiply defined symbols
			and to let multiply defined symbols keep the first value given them
	by RHG on 22 Sept 1970 to submit an unexpanded copy (source got expanded accidentally)
	by RHG on 17 August 1970 at 1842 to spot multiply defined symbols of different classes
*/



/* for entering and searching for symbols in table.
   the table consists of a list structure in 211 parallel
   lists, one entry for each item in the table. each entry
   consists of a pointer block containing the symbol value and
   flags, and a pointer to the symbol stored in a variable
   length ascii type string. Both search and assign entries
   are contained in this program. */

% include alm_xref_nodes;

% include	alm_options;

%include varcom;

%include concom;

%include erflgs;

%include codtab;


 declare	 (dowhat, xsym (8), xval, xflags, xcls, xslink,
	words (-2:5), boxno, tval, tflags, yflags, tcls, xaddr,
	l, k, link, nwrds) fixed binary (26),
	result fixed binary, line_no fixed binary (35),
	tree_rel fixed binary, tree_ptr pointer,
	line_list_rel bit (18), line_list_ptr pointer,
	last_line_rel bit (18), last_line_ptr pointer;
 declare	internal_return label local;

	/* EXTERNAL FUNCTIONS */
 declare	glpl_$clh external entry (fixed binary (26)) returns (fixed binary (26)),
	glpl_$crh external entry (fixed binary (26)) returns (fixed binary (26)),
	glpl_$cwrd external entry (fixed binary (26)) returns (fixed binary (26)),
	utils_$rs external entry (fixed binary (26), fixed binary (26)) returns (fixed binary (26)),
	glpl_$glwrd external entry (fixed binary (26), fixed binary (26)) returns (fixed binary (26)),
	glpl_$setblk external entry (fixed binary(26), fixed binary(26)) returns (fixed binary(26)),
	utils_$nswrds external entry (fixed binary (26)) returns (fixed binary (26)),
	utils_$compare_acc external entry (fixed binary (26), fixed binary (26)) returns (fixed binary (26));

	/* EXTERNAL ENTRIES */
 declare	prnter_$prnter_ external entry (char (*)),
	glpl_$slwrd external entry (fixed binary (26), fixed binary (26), fixed binary (26)),
	glpl_$storl external entry (fixed binary (26), fixed binary (26)),
	glpl_$storr external entry (fixed binary (26), fixed binary (26)),
	utils_$abort external entry;

	declare (eb_data_$rho, eb_data_$twop18) external fixed binary (35) aligned;

 declare	eb_data_$lavptr external pointer;

 declare	 (slink, xslink_ptr) pointer;

dcl	mod_2_sum	bit(36) aligned;

dcl	bit_array(8) bit(36) aligned based;

 declare  1 bsym based aligned,
	  2 nc fixed bin (8) unal,
	  2 ch char (0 refer (bsym.nc)) unal;

 declare	1 word based aligned,
	  2 left bit (18) unaligned,
	  2 right bit (18) unaligned;

 declare	twop18 fixed binary (20) internal static initial (262144);

 declare	 (abs, addr, addrel, bit, fixed, mod, pointer, rel) builtin;


label_0100:
	result = 1;		/* Preset for happy return. */

	if (dowhat = iassgn) then goto label_1000;
	if (dowhat = iserch) then goto label_2000;
	call prnter_$prnter_ ("fatal error in the assembler (TABLE)"); call utils_$abort;


/* assign entry, first search table. */
label_1000:

	internal_return = label_1010;
	goto label_3000;

/* analyze result of table search. */
label_1010:

	if (link = 0) then goto label_1020;
	goto label_1030;

/* not now in table, hence assign directly. */
label_1020:


	if xsym (1) > eb_data_$twop18 then xslink = glpl_$setblk (xsym (1),nwrds); /* assign symbol if there is one in SYM */

	words (0), words (-1), words (-2) = 0;
	words (1) = glpl_$glwrd (xslink, box (boxno));
	words (2) = glpl_$glwrd (xflags,xval);
	if (xflags = fmlcrf) then goto label_1026;
	words (3) = glpl_$glwrd (xaddr, fixed (addr (xval) -> word.left, 18));
	l = 3;
	if xflags = 0 then l = 5;
label_1022:

	link = glpl_$setblk (words (-2), l + 3) + 3;
	box (boxno) = link;
	if (xflags = fmlcrf) then xaddr = link;

/* Insert new symbol into tree as well as hash table. */

	if tnoxref ^= 0 then goto all_done;		/* Don't bother unless user wants result. */

	tree_ptr = addr (symbol_tree_rel);
tree_loop:	tree_rel = tree_ptr -> symbol_tree_node.high_sublist;		/* Which must be the first word. */
		if tree_rel = 0 then goto tree_done;
		tree_ptr = pointer (eb_data_$lavptr, tree_rel);
		if utils_$compare_acc (xslink, fixed (tree_ptr -> symbol_tree_node.name_rel, 18)) < 0 then tree_ptr = addrel (tree_ptr, 1);
		goto tree_loop;
tree_done:tree_ptr -> symbol_tree_node.high_sublist = link - 3;
	goto make_line_node;

/* set up entry for multiple location counters. */
label_1026:

	words (3) = 0;
	words (4) = xval;
	words (5) = 0;
	l = 5;
	goto label_1022;

/* entry found table, check for consistency and redefinition. */
label_1030:

	if (unspec (tflags) & unspec (fdef)) = "0"b then goto label_1040;
	if unspec (tflags) & unspec (fset) then goto label_1070;
	if unspec (tflags) & unspec (fmul) then goto label_1062;
	if tcls = xcls then if tval = xval then goto label_1050;
	if unspec (xflags) & unspec (fdef) then goto label_1060;
	goto label_1050;

/* assign new value and flags to undefined symbol. */
label_1040:
	unspec (yflags) = unspec (tflags) | unspec (xflags);
	call glpl_$slwrd (link+1, yflags, xval);

	if xflags = fmlcrf then do;
		call glpl_$slwrd (link + 2, 0, 0);
		call glpl_$slwrd (link + 3, 0, xval);
		call glpl_$slwrd (link + 4, 0, 0);
		end;
	else call glpl_$slwrd (link + 2, xaddr, fixed (addr (xval) -> word.left, 18));

/* simple return for equivalent assignments. */
label_1050:

	goto make_line_node;

/* error if multiple non-equivalent assignment. */
label_1060:
	unspec (yflags) = unspec (tflags) | unspec (fmul);
	call glpl_$storl (link+1, yflags);
label_1062:
	prntm = 1;
	result = 0;
	goto make_line_node;

label_1070:

	call glpl_$slwrd (link+1,xflags,xval);
	call glpl_$storr (link + 2, fixed (addr (xval) -> word.left, 18));
	goto make_line_node;


/* search entry, first search table. */
label_2000:

	internal_return = label_2010;
	goto label_3000;

/* analyze search results. */
label_2010:

	if xcls ^= 0 then if xcls ^= tcls then goto label_2020;
	if link ^= 0 then if unspec (tflags) & unspec (fdef) then goto label_2030;

/* value not found, give bad return. */
label_2020:

	xval = 0;
	xaddr = 0;
	return (0);

/* found in table, check for errors and return value. */
label_2030:

	if unspec (tflags) & unspec (fmul) then prntm = 1;
	if unspec (tflags) & unspec (fphs) then prntp = 1;
	xval = tval;
	xaddr = 0;
	if (unspec (tflags) & unspec (flocrf)) = unspec (flocrf) then xaddr = glpl_$clh (link+2);
	if (unspec (tflags) & unspec (fmlcrf)) = unspec (fmlcrf) then xaddr = link;

/* Come here on both search and assign entries, to append line number node to list for symbol. */

make_line_node:
	if tnoxref ^= 0 then goto all_done;		/* Skip this extra work if xref not needed. */
	if binlin = 0 then goto all_done;		/* Initialization reference (probably). */

	line_no = binlin + fixed (rel (include_info_stack), 18) * twop18;
	line_list_ptr, tree_ptr = pointer (eb_data_$lavptr, link - 1);
line_loop:line_list_rel = line_list_ptr -> line_node.backward_rel;
	if line_list_rel = "0"b then do;
		line_list_ptr = tree_ptr;
		goto line_end;
		end;
	line_list_ptr = pointer (eb_data_$lavptr, line_list_rel);
	if line_list_ptr -> line_node.line_no > line_no then goto line_loop;
	if line_list_ptr -> line_node.line_no = line_no then goto all_done;

line_end:	last_line_rel = line_list_ptr -> line_node.forward_rel;
	if last_line_rel = "0"b then last_line_ptr = tree_ptr;
	else last_line_ptr = pointer (eb_data_$lavptr, last_line_rel);

	addr (words (1)) -> line_node.line_no = line_no;
	addr (words (1)) -> line_node.forward_rel = last_line_rel;
	addr (words (1)) -> line_node.backward_rel = line_list_rel;
	link = glpl_$setblk (words (1), 2);
	line_list_ptr -> line_node.forward_rel, last_line_ptr -> line_node.backward_rel = bit (fixed (link, 18));

all_done:	return (result);


/* table search routine, reached by assign goto linkage. */
label_3000:



	nwrds = utils_$nswrds (xsym (1));

	if xsym (1) > eb_data_$twop18 then xslink_ptr = addr (xsym (1));

	else do;
		xslink = xsym (1);
		xslink_ptr = pointer (eb_data_$lavptr, xslink);
	end;

	mod_2_sum = xslink_ptr -> bit_array(1);

	do k = 2 to nwrds;
	   mod_2_sum = bool(mod_2_sum,xslink_ptr -> bit_array(k),"0110"b);
	end;

	boxno = mod(binary(mod_2_sum,35),nboxes);

	link = box (boxno);
label_3010:
	if link = 0 then goto search_done;
	slink = pointer (eb_data_$lavptr,glpl_$clh (link));
label_3020:
	if (xslink_ptr -> bsym.ch ^= slink -> bsym.ch) then goto label_3030;

	tflags = glpl_$clh (link + 1);
	tval = glpl_$crh (link + 1);
	if tflags ^= fmlcrf then tval = tval + glpl_$crh (link + 2) * twop18;
	xcls = utils_$rs (xflags,15);
	tcls = utils_$rs (tflags,15);
search_done:
	goto internal_return;
label_3030:

	link = glpl_$crh (link);
	goto label_3010;


     end table_;




		    utils_.alm                      10/17/88  1013.9r w 10/17/88  0938.0       55395



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1988                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name	utils_
"	   	utils, utility machine language programs for alm.

"NOTE: segdefs are used rather than entrys where possible to speed up execution.
"the routines defined by segdefs must not use the linkage section, as lp may not be
"properly set

" Last modified on 11/12/72 at 02:01:23 by R F Mabee. Fixed short return for followon.
"	on 07/25/72 at 08:44:38 by R F Mabee. Added utils_$compare_acc to compare ACC strings.
"	on 03/04/72 at 20:49:26 by R F Mabee. Made opcode field 10 bits in makins.
"	by RHG on 22 Sept 1970 to fix bug in upkflg
"	by RHG on 17 Sept 1970 to delete
"		unnecessary entries and change "entry" to "segdef" where possible


"	basic shift and logical operations.



	segdef	and
and:	null
	ldq	ap|2,*
	anq	ap|4,*
	tra	store_6-*,ic


	segdef	ls		left shift operator.
ls:	null
	ldq	ap|2,*		get word,
	lda	ap|4,*		and shift,
	qls	0,al		then shift,
	tra	store_6-*,ic




	segdef	rs		right shift operator.
rs:	null
	ldq	ap|2,*		get word,
	lda	ap|4,*		and shift,
	qrl	0,al		then shift,
	tra	store_6-*,ic




	segdef	or		or operator
or:	null
	ldq	ap|2,*		get a operand
	orq	ap|4,*		or in b operand
store_6:	stq	ap|6,*
utils_short_return:
	short_return




"	make external address subroutine.

	segdef	exadrs		define entry.
exadrs:	null
	lda	ap|4,*		get displacement,
	lrl	15		and position.
	lda	ap|2,*		get base register,
	lrl	3+18		and position,
	tra	store_6-*,ic




"	get symbol character count from symbol first word.


	entry	nswrds		define entry.
nswrds:	null
	ldq	ap|2,*		get first word of ASCII string or relative ptr into free_ segment
	cmpq	=1,du		string has value in left part of Q-reg
	trc	have_string-*,ic
have_ptr:	ldq	<eb_data_>|[lavptr],*ql load first word of ASCII string
have_string:
	null
	qrl	3*9+2		position character count,
	adq	=1,dl		and form word count
	stq	ap|4,*
	tra	utils_short_return-*,ic then return to caller.




"	make instruction from its five fields.


	segdef	makins		define entry.
makins:	null
	lda	ap|6,*
	ana	=o777400,dl	isolate 10-bit opcode field.
	ora	ap|10,*		insert modifier,
	lrl	6		..
	ora	ap|8,*		insert b29,
	lrl	18-6		..
	lda	ap|4,*		insert displacement,
	lrl	15		..
	canq	=o1000,dl		test b29.
	tze	bypass-*,ic	skip if zero,
	lda	ap|2,*		insert base,
bypass:	lrl	3		else, take high bits of displacement.
	stq	ap|12,*		store answer.
	tra	utils_short_return-*,ic then return to caller.




"	pack and unpack routines for table flags.

	entry	pckflg		(word)  define entry.
pckflg:	null
	eax7	-36		set x7
	eppbp	<eb_data_>|[flgvec]
pklp:	lda	bp|36,7		insert flag vector word
	lrl	1		shift into assembled word
	stz	bp|36,7		clear the flag
	adx7	=1,du		decrement index into flag vector
	tnz	pklp-*,ic		loop if more to do.
	stq	ap|2,*		all done, save flags,
	tra	utils_short_return-*,ic and return to caller.




	entry	upkflg		(word)  define entry.
upkflg:	null
	eax7	36		initialize loop control
	eppbp	<eb_data_>|[flgvec]
	ldq	ap|2,*		get packed word
loopbk:	lda	=0,dl		clear the A-reg
	lls	1		shift in bit of packed word
	orsa	bp|-1,7		store bit into word vector
	sbx7	=1,du		bump loop control
	tnz	loopbk-*,ic	go back if more to do
	tra	utils_short_return-*,ic else, return to caller




"	put character routine, ascii.


	segdef	putach		(word,charno,char)  define entry.
putach:	null
	lda	ap|6,*		get the character
	lxl0	ap|4,*		get the character position
	xec	als-1,0		position the character
	eppbp	ap|2,*		get a pointer to the word
	xec	stba-1,0		store the character
	tra	utils_short_return-*,ic

als:	als	27
	als	18
	als	9
	nop	0,du

stba:	stba	bp|0,40
	stba	bp|0,20
	stba	bp|0,10
	stba	bp|0,04




"	exit and close-out routines, terminate run.


	entry	abort		utils$abort entry point.
abort:	tra	<prnter_>|[abort1]	have prnter_ give abort message and abort.


" compare_acc compares two ACC format strings in alphabetic collating
" sequence. It returns as a result: zero if the two strings are
" identical, a negative number if the first is less, or a positive
" number if the second is less.
" Its arguments are offsets into the scratch segment.

	entry	compare_acc
	temp	temp
compare_acc:
	save			" result = compare_acc (name_rel_1, name_rel_2);
	lda	ap|2,*
	ldq	ap|4,*
	eppbp	<eb_data_>|[lavptr],*
	eppap	bp|0,al		" ap points to base of first ACC string.
	eppbp	bp|0,ql		" and bp points to base of second.

	lda	bp|0
	ana	=o000137137137	" Compare first word without case bits.
	sta	temp
	lda	ap|0
	ana	=o000137137137
	sba	temp
	tnz	comp_done

" First three letters the same, start full check.

	lda	bp|0
	arl	29		" Length in words minus one.
	sta	temp
	lda	ap|0
	arl	29
	cmpa	temp
	tmi	2,ic
	lda	temp		" The length of the shorter one.
	ada	1,dl		" Get full word count.

	eppap	ap|0,al		" Add length to pointers, put negative length in xr0.
	eppbp	bp|0,al		" This is so one register can double as index and counter.
	neg	0,dl		" bp|0,0 is now the base of the ACC string.
	eax0	0,al

" Now look at rest of words, ignoring case bits.

	eax1	0,0
comp_l1:	adx1	1,du
	tpl	comp_d1

	lda	bp|0,1
	ana	=o137137137137
	sta	temp
	lda	ap|0,1
	ana	=o137137137137
	sba	temp
	tnz	comp_done
	tra	comp_l1
comp_d1:

" Now there is no difference except possibly case bits, so check them.
" First word first.

	lda	bp|0,0
	ana	=o000777777777
	sta	temp
	lda	ap|0,0
	ana	=o000777777777
	sba	temp
	tnz	comp_done

" Run over rest of words again.

	eax1	0,0
comp_l2:	adx1	1,du
	tpl	comp_d2

	lda	ap|0,1
	sba	bp|0,1
	tnz	comp_done
	tra	comp_l2
comp_d2:

" Now the only possible difference is in the lengths.

	lda	ap|0,0
	sba	bp|0,0
comp_done:
	eppap	sp|26,*
	sta	ap|6,*
	return

	end




		    varevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.3      115704



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




/****^  HISTORY COMMENTS:
  1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
     audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
     Modified to support *heap references.
                                                   END HISTORY COMMENTS */


varevl_:
     procedure (xwhat, xbasno, xval, xadmod, xb29, xaddr) returns (fixed bin (26));
						/*  evaluate variable fields for the Multics assembler (ma_6180). */


/*   Modified 3/8/77 by Noel I. Morris to handle segment$symbol.
        Modified for separate static on 06/15/75 by Eugene E Wiatrowski    
	Modified 740905 by PG to know about pr0...pr7.
   by RFM on 15 January 1973 to add an option to not read the modifier.
   by RHG on 15 June 1971 to add "(" and ")" to the list of legal field terminators (for "call", etc)
   by RFM and RHG on 22 November 1972 to _n_o_t set prntr on expevl_ error.
   by RHG on 2 June 1971 to set prntr on expevl_ error
   by RHG on 25 May 1971 to allow "," to terminate a field too
   by RHG on 29 March 1971 at 1703 to spot illegal field terminator
   by NA on June 28, 1970 at 2159 for the new CODTAB
*/

/* There are six modes of entry to VAREVL. Two are for external */
/* references, two for internal references, and two for boolean */
/* references. the routines are careful to generate the proper */
/* linkages for external references, to evaluate literals */
/* properly, and to check for errors of all types. parentheses */
/* are allowed in the internal expressions for nesting. */


/* INCLUDE FILES FOR VAREVL */

% include concom;
% include varcom;
% include codtab;
% include erflgs;
% include lcsect;
% include lclit;
/*  */

/* INTERBAL STATIC DATA */
declare  ixvrvl_notag fixed bin init (0);

/*  EXTERNAL ENTRIES USED BY VAREVL */

declare  getid_$getid_ ext entry,
         getid_$getnam ext entry,
         prnter_$prnter_ entry (char (*), fixed bin),
         utils_$abort ext entry,
         inputs_$next ext entry,
         litevl_$litevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26));

/* EXTERNAL FUNCTIONS USED BY VAREVL */

declare  lstman_$namasn entry (fixed bin (26)) returns (fixed bin (26)),
         lstman_$blkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
         lstman_$lnkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
         table_ entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
         glpl_$clh entry (fixed bin) returns (fixed bin),
         modevl_$modevl_ entry (fixed bin (26)) returns (fixed bin (26)),
         expevl_$expevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26));

/*  EXTERNAL DATA USED BY VAREVL */

declare (eb_data_$asym (2), eb_data_$atext (2), eb_data_$alink (2), eb_data_$astat (2), eb_data_$asys (2)) ext fixed bin (35);
declare eb_data_$aheap(2) ext fixed bin(35);

/* LABEL VARIABLES USED BY VAREVL */
	

declare  evlrtn label local;

/*  AUTOMATIC DATA USED BY VAREVL */

declare (admod, b29, basno, blk, i, iaddr,
         inexp, junk, snlnk, tbool, tmpno, tself, txnam,
         txtern, type, val, varevl_answer, xaddr, xadmod,
         xbasno, xb29, xnlnk, xval, xwhat) fixed bin (26);

/* BASED */

declare	1 acc aligned based (addr (eb_data_$varcom.sym (1))),
	  2 count unaligned fixed bin (8),
	  2 string unaligned char (3);

/*  */
/* - - - - - MAIN ENTRY POINT, Check type of call and branch to it. */

	iaddr = 0;
	tbool = 0;				/* FALSE */
	if xwhat = ixvrvl then go to label_200;
	if xwhat = ixvrvl_notag then goto label_200;
	if xwhat = ixvrvp then go to label_210;
	if xwhat = invrvl then go to label_130;
	if xwhat = invrvp then go to label_160;
	if xwhat = ibvrvl then go to label_110;
	if xwhat = ibvrvp then go to label_140;
	

	call prnter_$prnter_ ("fatal error in the assembler (VAREVL)", 101);
	call utils_$abort;

/* boolean entry without current break. */
label_110:
	tbool = 1;				/* TRUE */

/* arithmetic entry without current break. */
label_130:
	call getid_$getid_;
	go to label_170;

/* boolean entry with current break. */
label_140:
	tbool = 1;				/* TRUE */

/* normal entry with current break. */
label_160:
	sym (1) = 0;
label_170:
	admod = 0;
	varevl_answer = 1;				/* TRUE */
	txtern = 0;				/* FALSE */
	if (brk (1) = iequal & sym (1) = 0) then go to label_500;
	evlrtn = label_1100;
	go to label_3000;

/* process possible external field without current break. */
label_200:
	call getid_$getid_;
	go to label_220;


/* process possible external field with current break. */
label_210:
	sym (1) = 0;
label_220:
	tbool = 0;				/* FALSE */
	inexp = 0;
	txtern = 1;				/* TRUE */
	varevl_answer = 1;				/* TRUE */


/* check first break for possible external symbol. */
	if (brk (1) = ilpb & sym (1) = 0) then go to label_300;
	if (brk (1) = ivlin & sym (1) ^= 0) then go to label_400;
	if (brk (1) = idolr & sym (1) ^= 0) then go to label_290;
	if (brk (1) = iequal & sym (1) = 0) then go to label_500;
	if (brk (1) = istar | brk (1) = islash | sym (1) = 0) then go to label_600;
	go to label_700;




/* process segname$symbol */
label_290:
	tself = 0;
	snlnk = lstman_$namasn (sym (1));
	call getid_$getid_;

	if sym (1) ^= 0 then do;
	     xnlnk = lstman_$namasn (sym (1));
	     sym (1) = 0;
	     go to label_320;
	end;

	else do;
	     xnlnk = 0;
	     go to label_312;
	end;



/* process external symbol in pointed brackets. */
label_300:
	call getid_$getnam;
	if (sym (1) = 0 | brk (1) ^= irpb) then go to label_2000;
	call inputs_$next;
	if (brk (1) ^= ivlin) then go to label_2000;
	tself = 0;				/* FALSE */
	if (sym (1) ^= eb_data_$atext (1) | sym (2) ^= eb_data_$atext (2)) then go to label_302;
	tself = 1;				/* TRUE */
	snlnk = 0;
	go to label_310;
label_302:
	if (sym (1) ^= eb_data_$alink (1) | sym (2) ^= eb_data_$alink (2)) then go to label_304;
	tself = 1;				/* TRUE */
	snlnk = 1;
	go to label_310;
label_304:
	if (sym (1) ^= eb_data_$asym (1) | sym (2) ^= eb_data_$asym (2)) then go to label_305;
	tself = 1;				/* TRUE */
	snlnk = 2;
	go to label_310;
label_305:
	if (sym (1) ^= eb_data_$astat (1) | sym (2) ^= eb_data_$astat (2)) then go to label_306;
	tself = 1;
	snlnk = 4;
	go to label_310;
label_306:
	if (sym (1) ^= eb_data_$asys (1) | sym (2) ^= eb_data_$asys (2)) then go to label_307;
	tself = 1;
	snlnk = 5;
	go to label_310;
label_307:
	/* add support for *heap links */
	if (sym (1) = eb_data_$aheap (1) | sym (2) = eb_data_$aheap (2)) then do;
		tself = 1;
		snlnk = 6;
		goto label_310;
	  end;
	tself = 0;				/* FALSE */
	snlnk = lstman_$namasn (sym (1));

/* type 3 address, external name without external symbol. */
label_310:
	call check_external_name;
	if (txnam ^= 0) then go to label_320;
label_312:
	type = 3;
	if (tself ^= 0) then type = 1;
	evlrtn = label_330;
	go to label_3000;


/* type 4 address, external name with external symbol. */
label_320:
	type = 4;
	if (tself ^= 0) then type = 5;
	evlrtn = label_330;
	go to label_3100;


/* generate type block for external name and external symbol. */
label_330:
	blk = lstman_$blkasn (type, snlnk, xnlnk, 0);
	go to label_1000;




/* process base number in front of vertical line. */
label_400:
	if acc.count = 3
	then if substr (acc.string, 1, 2) = "pr"
	     then do;
		     basno = index ("01234567", substr (acc.string, 3, 1)) - 1;

		     if basno ^= -1		/* if pr0...pr7 */
		     then go to label_420;
		end;

	do i = 1 to 8;
	     basno = i - 1;
	     if (sym (1) = symbas (i)) then go to label_420;
	end;

	if (table_ (iserch, sym (1), basno, (clint), junk) ^= 0) then go to label_420;
	basno = 0;
	varevl_answer = 0;				/* FALSE */
	prntu = 1;				/* TRUE */


label_420:
	call check_external_name;
	if (txnam ^= 0) then go to label_440;


/* type 6 address, base specified without external symbol. */
	type = 6;
	evlrtn = label_1000;
	go to label_3000;


/* type 2 address, base specified with external symbol. */
label_440:
	type = 2;
	evlrtn = label_450;
	go to label_3100;


/* generate type block for base register and external symbol. */
label_450:
	blk = lstman_$blkasn (type, basno * 32768, xnlnk, 0); /* utils_$ls (basno, 15) */
	go to label_1000;




/* break is =, evaluate literal. */
label_500:
	call litevl_$litevl_ (inexp, admod, txtern);
	type = 0;
	if (admod = mdu | admod = mdl) then go to label_1010;
	iaddr = lplit;
	go to label_1010;




/* star or slash break implies internal, go to it. */
label_600:
	go to label_710;




/* plus or minus break, segref or basref symbol possible. */
label_700:
	if (table_ (iserch, sym (1), val, (clext), junk) ^= 0) then go to label_720;
	if (table_ (iserch, sym (1), val, (clstk), junk) ^= 0) then go to label_730;


/* internal symbol, process it. */
label_710:
	evlrtn = label_1000;
	type = 0;
	go to label_3000;


/* segref or basref symbol, setup block and type. */
label_720:
	blk = val;
	type = glpl_$clh (blk + 1);
	sym (1) = 0;
	evlrtn = label_1000;
	go to label_3100;


/* stack reference, set relative pointer and type. */
label_730:
	tmpno = val;
	type = 7;
	sym (1) = 0;
	evlrtn = label_1000;
	go to label_3100;

/* common entry after evaluating variable field, get modifier, */
/* establish linkage, address, local modifier, and b29, */
/* and return to caller with terminal break character. */


label_1000:
	admod = 0;
	if brk (1) = icomma then if xwhat ^= ixvrvl_notag then admod = modevl_$modevl_ (brk (1));
label_1010:
	go to address_type (type);

/* type 0, normal address, internal and b29 off. */
label_1100:
address_type (0):
	if (brk (1) ^= ivlin) then go to label_1110;
	basno = inexp;
	if txtern ^= 0 then goto label_420;
label_1110:

	basno = 0;
	val = inexp;
	b29 = 0;
	go to label_1900;


/* types 1 thru 5, reference requires linkage through type-block. */
address_type (1):
address_type (2):
address_type (3):
address_type (4):
address_type (5):
	val = lstman_$lnkasn (blk, inexp, admod, iaddr);
	basno = lp;
	admod = mri;
	b29 = 1;
	iaddr = lpsect;
	go to label_1900;


/* type 6, augmented reference requiring no linkage. */
address_type (6):
	val = inexp;
	b29 = 1;
	go to label_1900;


/* stack reference, generate reference without linkage. */
address_type (7):
	val = tmpno+inexp;
	basno = sp;
	b29 = 1;
	if (iaddr ^= 0) then prntr = 1;		/* TRUE */
	iaddr = 0;
	go to label_1900;

/* common return section, set external values and return. */
label_1900:
	i = brk (1);
	if i ^= isp then if i ^= inl then if i ^= iquot then if i ^= icomma
			then if i ^= irpar then if i ^= ilpar then prnte = 1;
label_1905:
	xbasno = basno;
	xval = val;
	xadmod = admod;
	xb29 = b29;
	xaddr = iaddr;
	return (varevl_answer);


/* field error, set f flag and make null return. */
label_2000:
	prntf = 1;				/* TRUE */
	varevl_answer = 0;				/* FALSE */
	basno = 0;
	val = 0;
	admod = 0;
	b29 = 0;
	go to label_1905;

/* interlude to internal variable field evaluation routine. this */
/* routine evaluates expressions consisting only of internal re- */
/* ferences using a stack evaluation method. nested parentheses are */
/* allowed, and are taken to delimit subexpressions. the interlude */
/* checks for call requirements and checks the results for field */
/* errors, any such causing varevl_answer to be false. */


/* normal entry, break in brk, and perhaps symbol in sym. */
label_3000:
	junk = expevl_$expevl_ (tbool, inexp, iaddr);
label_3010:
	go to evlrtn;


/* entry after external symbol encountered. symbol must be zero, */
/* and break must be + or -, anything else terminates scan. */
label_3100:
	if (sym (1) = 0 & (brk (1) = iplus | brk (1) = iminus)) then go to label_3000;
	go to label_3010;

/* chkxnm, internal subroutine used to check for external name */
/* after a vertical line. */

check_external_name:
	procedure;

	     call getid_$getid_;
	     if (brk (1) ^= ilsb | sym (1) ^= 0)
		then do;
		xnlnk = 0;
		txnam = 0;			/* FALSE */
		return;
	     end;

	     call getid_$getid_;
	     if (brk (1) ^= irsb | sym (1) = 0) then go to label_2000;
	     xnlnk = lstman_$namasn (sym (1));
	     txnam = 1;				/* TRUE */
	     call getid_$getid_;
	     return;

	end check_external_name;

     end varevl_;




		    vfdevl_.pl1                     10/17/88  1013.9rew 10/17/88  0938.3       51264



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

vfdevl_: vfdcnt:

	procedure (rslts, flags, k);	/* note that k is really the return value of vfdevl */
 
/* vfdevl evaluate variable field expr and return results and break. */
/* vfdevl returns at most 10 words in rslts, no modifiers are allowed */
/* note that type #a# fields are allowed and yield right justified */
/* ascii characters preceded by nulls. fields may be any number */
/* of bits long, but only the rightmost 36 bits of any field are */
/* evaluated, the leading (n-36) bits will be zeroes (nulls) . */
/* flags argument is for possible future relocation bits. */


/*	Modified for "vfd" pseudo-op on 12/15/75 by Eugene E Wiatrowski.
 	Modified on 112372 at 03:01:33 by R F Mabee.
	by R F Mabee and RHG to straighten out prntr on expevl_ error error.
	by R F Mabee on 2 November 1972 to fix bug that terminated scan on 4 char field.
	by RHG on 1 April 1971 to fix bad expevl_ to set prntr, not prnte
	by NA on July 16, 1970 at 0918 to fix n > 36 fields */


% include varcom;
% include concom;
% include erflgs;
% include codtab;

/* EXTERNAL ENTRIES */

declare	inputs_$next ext entry,
	inputs_$nxtnb ext entry,
	getid_$getid_ ext entry;

/* EXTERNAL FUNCTIONS */

declare	utils_$ls ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
	utils_$rs ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
	glpl_$setblk ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
	expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
	utils_$or ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (35)),
	utils_$and ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (35));

/* EXTERNAL DATA */

declare	 (eb_data_$jbo, eb_data_$jba, eb_data_$twop18) ext fixed bin (35);

/* INTERNAL DATA */

declare	 rslts (128) fixed bin(35);
declare	 ( flags, val, word, lcvec (128) , trel, i, j, k, ibl, nn, iaddr, l, n, let) fixed bin (26);
declare    vfd_buffer_size	init(128)		fixed bin int static;


 
 
 	i = 1;
	rslts (1) = 0;
	j = 0;
	n = 0;
	let = 0;
label_107:

          lcvec(*) = 0;
 
	trel = 0;	/* FALSE */
	flags = 0;
	call inputs_$nxtnb;
	goto label_120;

/* Count gathering loop.  */
label_110:
	call inputs_$next;
label_120:
	if (brk (1) = inum) then goto label_200;
	if (brk (1) = ilet) then goto label_210;
	if (brk (1) = islash) then goto label_300;
	goto label_530;

/* process characters in count field. */
label_200:
	n = 10*n+utils_$and (brk (2) , 15);
	goto label_110;

label_210:
		let = brk (2);
		goto label_110;

/* slash found, branch to evaluate field. */
label_300:
	if (let = 0) then goto label_310;
	if (let = eb_data_$jbo) then goto label_320;
	if (let = eb_data_$jba) then goto label_335;
	goto label_530;

label_310:
	ibl = 0;
	goto label_325;

label_320:
	ibl = 1;
label_325:
	call getid_$getid_;
	nn = expevl_$expevl_ (ibl, val, iaddr);
	if (iaddr = 0) then goto label_400;
	if (n >= 18 & val < eb_data_$twop18) then goto label_326;
		prntr = 1;	/*TRUE*/
		goto label_400;

label_326:
	k = j+n;
	l = 0;
label_327:
	if (k <=  36) then goto label_328;
		k = k-36;
		l = l+1;
		goto label_327;

label_328:
	if (k ^= 18) then goto label_329;
		l = l+i;
		lcvec (l) = utils_$ls (iaddr, 18);
		trel = 1;	/*TRUE*/
		goto label_400;

label_329:
	if (k ^= 36) then goto label_330;
		l = l+i;
		lcvec (l) = utils_$or (lcvec (l) , iaddr);
		trel = 1;	/*TRUE*/
		goto label_400;

label_330:
	prntr = 1;	/*TRUE*/
	goto label_400;

label_335:
	val = 0;

label_337:
	call inputs_$next;
	if (brk (1) = icomma | brk (1) = inl) then goto label_400;
	val = utils_$or (512*val, brk (2) );
	goto label_337;
	

/* field evaluated, insert in output buffer. */
label_400:
	if n <= 35 then val = utils_$and (val, utils_$rs (-1, 36 - n) );
label_420:
	if ( (j+n) < 36) then goto label_440;
	n = n- (36-j);
	rslts (i) = utils_$or (utils_$ls (word, 36-j) , utils_$rs (val, n) );
	j = 0;
	i = i+1;
	if (i > vfd_buffer_size) then goto label_530;
label_430:
	if (n < 36) then goto label_440;
		n = n-36;
		rslts (i) = utils_$rs (val, n);
		i = i+1;
		if (i > vfd_buffer_size) then goto label_530;
		goto label_430;

label_440:
	if n > 35 then word = val;
	else word = utils_$or (utils_$ls (word, n) , utils_$and (val, utils_$rs (-1, 36-n) ) );
	j = j+n;
	n = 0;
	let = 0;
	if (brk (1) = icomma) then goto label_110;

/* all done, position last word, and return to caller. */
label_500:
	if (j = 0) then goto label_510;
	rslts (i) = utils_$ls (word, 36-j);
	k = i;
	goto label_520;



/* overflow return, set flags and return partial buffer. */

label_530:

	prnte = 1;
	goto label_500;


label_510:
	
	k = i-1;
	if (i = 1) then k = 1;
label_520:
	
	if (trel ^=  0) then flags = glpl_$setblk (lcvec (1) , k);
 
end vfdevl_;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


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
