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 |[getid] setid: tra |[setid_] getnam: tra |[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 |[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 |[lavptr],*ql qrl 18 stq ap|4,* short_return entry cllh cllh: ldq ap|2,* eppbp |[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 |[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 |[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 |[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 |[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 |[lavptr],* sta bp|nextf store it in the uninit pointer short_return and return entry setblk get a block of free storage. setblk: eppbp |[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 |[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 |[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 |[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 */ 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 ,,{,} */ 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 */ 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 ,{,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 */ 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: |x */ control_1030 (4) = label_1034; /* Type 4 link: |[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 |[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 |[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 |[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 |[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 |[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