bind.pl1 01/17/85 1330.6r w 01/17/85 1231.5 192753 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ bind: oldbind: bd: procedure (); /* * BIND -- the command procedure of the Multics binder * * * Redesigned and coded by Michael J. Spier, September 17, 1970 * Modified 75.06.24 by M. Weaver to remove no_old_alm option * Modified 5/76 by M. Weaver to add -brief option, identify bad control args and improve names in messages * Completely reimplemented, to make comprehensible, 01/14/81 W. Olin Sibert; Added several features: * warning for no bindfile, -force_order, -force_update, warning for update by earlier version. * Modified 11/22/83 by M. Weaver to initialize inp.bindfile_name * Modified 11/06/84 by M. Sharpe to implement -segment, -archive and -bindfile; * bind now uses a new version of binder_input.incl.pl1 which removes the limitation * on the number of archives/segments and object components. * Modified 01/07/84 by M. Sharpe to correct problem with control argument processing; */ /* Automatic */ dcl access_mode bit (3); dcl archive_dname char (168); dcl archive_ename char (32); dcl archive_idx fixed bin; dcl (argno, nargs) fixed bin; dcl argp pointer; dcl argl fixed bin (21); dcl bindfile_flag bit (1) aligned init ("0"b); dcl bindfile_to_use char (32); dcl code fixed bin (35); dcl component_name char (32) init (""); dcl comp_ptr pointer; dcl 1 comp_info aligned like archive_component_info; dcl ctl_arg char (10) varying; dcl (inpp, p) pointer; /* pointers which must be declared to use binder_input.incl.pl1 */ dcl error_sw bit (1) aligned; dcl ignore_not_found bit (1) aligned; dcl obj_idx fixed bin; dcl real_dname char (168); dcl real_ename char (32); dcl standalone_segment bit (1) aligned init ("0"b); dcl update_idx fixed bin; /* Based */ dcl arg char (argl) based (argp); /* Builtin */ dcl (addr, char, index, length, null, reverse, rtrim, search, substr) builtin; /* Condition */ dcl cleanup condition; /* Entries */ dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35)); dcl absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); dcl archive_$next_component_info entry (pointer, fixed bin (24), pointer, pointer, fixed bin (35)); dcl bind_ entry (pointer); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl hcs_$terminate_noname entry (pointer, fixed bin (35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl translator_info_$get_source_info entry (pointer, char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35)); /* External Static */ dcl error_table_$archive_pathname fixed bin (35) external static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$noentry fixed bin (35) external static; dcl error_table_$pathlong fixed bin (35) external static; /* Internal Static */ dcl ARCHIVE_SUFFIX char (7) internal static options (constant) init ("archive"); dcl WHOAMI char (32) internal static options (constant) init ("bind"); dcl binder_invoked bit (1) aligned internal static init ("0"b); /* Prevent recursion */ %page; if binder_invoked then do; call com_err_ (0, WHOAMI, "^a^/^a", "The binder may not be invoked while a previous invocation is", "suspended. Use the ""release"" or ""start"" command first."); return; /* Avoid resetting the flag, of course */ end; inpp = null; on cleanup call CLEAN_UP (); binder_invoked = "1"b; /* Set recursion-prevention flag */ call get_temp_segment_ (WHOAMI, inpp, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Could not obtain temporary segment. Report to maintainer."); return; end; inp.ntotal = 0; inp.version = BINDER_INPUT_VERSION_2; inp.caller_name = WHOAMI; inp.bindfilep = null (); inp.bindfile_name = ""; update_idx = 0; archive_idx = 0; error_sw = "0"b; /* Only set when multiple errors might occur */ ignore_not_found = "0"b; call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); MAIN_RETURN: if error_sw then /* Make mention of the fact that nothing will happen */ call com_err_ (0, WHOAMI, "Fatal errors have occurred; binding will not be attempted."); call CLEAN_UP (); /* This is the ONLY exit from this program */ return; /* except for the one which prevents recursion */ end; %page; /* Now, loop through the arguments, picking up the options and the archive pathnames. This loop initiates all the supposed archives, and fills in inp.archive_file for each one, but does not inspect their contents. */ /* The first part of the loop handles the simple control argument options */ argno = 1; do while (argno <= nargs); call cu_$arg_ptr (argno, argp, argl, (0)); if (arg = "-debug") | (arg = "-db") then inp.debug = "1"b; else if (arg = "-map") then do; inp.list_seg = "1"b; inp.map_opt = "1"b; end; else if (arg = "-list") | (arg = "-ls") then do; inp.list_opt = "1"b; inp.list_seg = "1"b; inp.map_opt = "1"b; end; else if (arg = "-brief") | (arg = "-bf") then inp.brief_opt = "1"b; else if (arg = "-force_order") | (arg = "-fco") then inp.force_order_opt = "1"b; %page; /* The next portion of the loop handles some of the more complicated control arguments */ else if (arg = "-update") | (arg = "-ud") then do; if inp.narc = 0 then do; NO_PRIMARY_ARCHIVE: call com_err_ (0, WHOAMI, "^a specified before any primary archive names.", arg); goto MAIN_RETURN; end; if update_idx > 0 then do; MULTIPLE_UPDATES: call com_err_ (0, WHOAMI, "Multiple -update or -force_update control arguments not allowed."); goto MAIN_RETURN; end; update_idx = inp.narc + 1; /* Start updating with the next archive */ end; else if (arg = "-force_update") | (arg = "-fud") then do; if inp.narc = 0 then goto NO_PRIMARY_ARCHIVE; if update_idx > 0 then goto MULTIPLE_UPDATES; ignore_not_found = "1"b; /* Set the flag to ignore update archives not found */ update_idx = inp.narc + 1; /* Start updating with the next archive */ end; %page; /* This portion handles control args that require another argument immediatedly following them */ else if (arg = "-segment") | (arg = "-sm") then do; if argno = nargs then goto MISSING_ARG; ctl_arg = arg; call cu_$arg_ptr (argno+1, argp, argl, (0)); /* Just checking! */ if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, WHOAMI, "^a ^a^/ ^a must be followed by a pathname.^/", ctl_arg, arg, ctl_arg); goto MAIN_RETURN; end; standalone_segment = "1"b; end; else if (arg = "-archive") | (arg = "-ac") then do; if argno = nargs then do; MISSING_ARG: call com_err_ (error_table_$noarg, WHOAMI, "^a must be followed by a pathname", arg); goto MAIN_RETURN; end; ctl_arg = arg; call cu_$arg_ptr (argno+1, argp, argl, (0)); /* Just checking! */ if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, WHOAMI, "^a ^a^/ ^a must be followed by a pathname.^/", ctl_arg, arg, ctl_arg); goto MAIN_RETURN; end; standalone_segment = "0"b; end; else if (arg = "-bindfile") | (arg = "-bdf") then do; if bindfile_flag then do; call com_err_ (0, WHOAMI, "Multiple -bindfile control args not allowed."); goto MAIN_RETURN; end; if argno = nargs then do; call com_err_ (error_table_$noarg, WHOAMI, "^a must be followed by an entry name.", arg); goto MAIN_RETURN; end; bindfile_flag = "1"b; /* don't use this arg again */ ctl_arg = arg; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, (0)); if (search (arg, "<>") > 0) | (index (arg, "-") = 1) then do; call com_err_ (0, WHOAMI, "^a must be followed by an entry name ^[not^;not a pathname.^] ^a.", ctl_arg, (index (arg,"-") = 1), arg); error_sw = "1"b; end; if (argl > 4 & index (arg, ".bind") = argl - 4) then do; /* has .bind suffix */ if argl > 32 then do; /* too long */ call com_err_ (0, WHOAMI, "Bindfile name is too long. ^a", arg); error_sw = "1"b; end; else bindfile_to_use = arg; end; else do; /* no .bind suffix */ if argl > 27 then do; /* too long */ call com_err_ (0, WHOAMI, "Bindfile name is too long. ^a", arg); error_sw = "1"b; end; else bindfile_to_use = arg || ".bind"; end; end; /* -bindfile */ else if char (arg, 1) = "-" then do; call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto MAIN_RETURN; end; %page; /* The final portion deals with initiating archives and getting information about them */ else do; /* If not a control argument, must be an archive name */ inp.ntotal, /* update the array bound */ archive_idx = archive_idx + 1; /* and the index */ inp.archive(archive_idx).ptr = null; /* initialize the ptr so that CLEAN_UP won't break */ if standalone_segment then call absolute_pathname_ (arg, inp.archive (archive_idx).path, code); else call absolute_pathname_$add_suffix (arg, ARCHIVE_SUFFIX, inp.archive (archive_idx).path, code); if code ^= 0 then do; BAD_ARCHIVE_PATH: call com_err_ (code, WHOAMI, "^a", arg); goto MAIN_RETURN; end; if standalone_segment then call expand_pathname_$component (inp.archive (archive_idx).path, archive_dname, archive_ename, component_name, code); else call expand_pathname_$add_suffix (inp.archive (archive_idx).path, ARCHIVE_SUFFIX, archive_dname, archive_ename, code); if code ^= 0 then goto BAD_ARCHIVE_PATH; if component_name ^= "" then do; call com_err_ (error_table_$archive_pathname, "bind_", inp.archive (archive_idx).path); component_name = ""; archive_idx = archive_idx - 1; goto SKIP_ARCHIVE; end; inp.archive(archive_idx).entryname = archive_ename; call initiate_file_ (archive_dname, archive_ename, access_mode, inp.archive (archive_idx).ptr, inp.archive (archive_idx).bc, code); if inp.archive (archive_idx).ptr = null () then do; if ignore_not_found then /* We can skip it */ if code = error_table_$noentry then do; archive_idx = archive_idx - 1; /* Keep this one out of the array */ goto SKIP_ARCHIVE; end; BAD_SEGMENT: call com_err_ (code, WHOAMI, "^a", inp.archive (archive_idx).path); goto MAIN_RETURN; end; if ^inp.brief_opt /* Warn about empties */ & inp.archive (archive_idx).bc = 0 then call com_err_ (0, WHOAMI, "Warning: ^a is empty.", inp.archive (archive_idx).path); call translator_info_$get_source_info (inp.archive (archive_idx).ptr, real_dname, real_ename, inp.archive (archive_idx).dtm, inp.archive (archive_idx).uid, code); if code ^= 0 then goto BAD_SEGMENT; if (length (rtrim (real_dname)) + length (rtrim (real_ename)) + 1) > 168 then do; call com_err_ (error_table_$pathlong, WHOAMI, "^a>^a", real_dname, real_ename); goto MAIN_RETURN; end; inp.archive (archive_idx).real_path = rtrim (real_dname) || ">" || rtrim (real_ename); inp.archive (archive_idx).standalone_seg = standalone_segment; if archive_idx = 1 then /* Apply default value for output segment */ inp.bound_seg_name = substr (archive_ename, 1, (length (rtrim (archive_ename)) - (length (ARCHIVE_SUFFIX) + 1))); if update_idx > 0 then /* Update the counts in the input */ inp.nupd = inp.nupd + 1; else inp.narc = inp.narc + 1; SKIP_ARCHIVE: end; /* Of processing one archive */ if char (arg, 1) = "-" & arg ^= "-segment" & arg ^= "-sm" then standalone_segment = "0"b; /* -segment is only in effect until the next control argument. */ argno = argno + 1; end; /* Of loop through arguments */ if inp.narc = 0 then do; call com_err_ (error_table_$noarg, WHOAMI, "^/Usage:^-^a archive_path{s} {-update update_archive_path{s}} {-control_args}", WHOAMI); goto MAIN_RETURN; end; if (update_idx > 0) & (inp.nupd = 0) & (^ignore_not_found) then do; call com_err_ (0, WHOAMI, "-update was specified, but not followed by any update archive names."); goto MAIN_RETURN; end; %page; comp_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1; /* In preparation for calling archive */ do archive_idx = 1 to inp.ntotal; /* Go through all the input archives */ comp_ptr = null (); /* Set up to loop through components */ GET_NEXT_OBJECT: if inp.archive (archive_idx).standalone_seg then do; comp_info.comp_ptr = inp.archive (archive_idx).ptr; comp_info.comp_bc = inp.archive (archive_idx).bc; comp_info.name = inp.archive (archive_idx).entryname; comp_info.time_updated, comp_info.time_modified = inp.archive (archive_idx).dtm; end; else do; call archive_$next_component_info (inp.archive (archive_idx).ptr, inp.archive (archive_idx).bc, comp_ptr, addr (comp_info), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Searching ^a.", inp.archive (archive_idx).path); goto MAIN_RETURN; end; if comp_ptr = null () then /* Nothing more in this archive */ goto GET_NEXT_ARCHIVE; end; if substr (reverse (rtrim (comp_info.name)), 1, 5) = reverse (".bind") then do; /* A bindfile */ if bindfile_flag then do; /* -bindfile was specified */ if comp_info.name ^= bindfile_to_use then goto IGNORE_BINDFILE; end; else if inp.bindfilep ^= null () then do; if archive_idx <= inp.narc then do; /* We are not processing an update archive */ if ^inp.brief_opt then /* Complain about it if not brief */ call com_err_ (0, WHOAMI, "Warning: Multiple bindfile ^a in ^a ignored.", comp_info.name, inp.archive (archive_idx).path); goto IGNORE_BINDFILE; /* and ignore it in any case */ end; /* of case for duplicate bindfile in non-update archive */ if ^inp.brief_opt then /* Mention it if not brief */ call com_err_ (0, WHOAMI, "Warning: ^a of ^a^/^2xreplaced by: ^a of ^a", inp.bindfile_name, inp.archive (inp.bindfile_idx).path, comp_info.name, inp.archive (archive_idx).path); end; /* of checking for duplicate bindfile */ inp.bindfilep = comp_info.comp_ptr; /* In any case, make this the bindfile */ inp.bindfile_bc = comp_info.comp_bc; inp.bindfile_idx = archive_idx; /* Index of archive from which this came */ inp.bindfile_name = comp_info.name; inp.bindfile_time_up = comp_info.time_updated; inp.bindfile_time_mod = comp_info.time_modified; IGNORE_BINDFILE: /* Now that we have it, go on to the next component */ if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE; else goto GET_NEXT_OBJECT; end; /* Of processing a bindfile entry */ %page; /* If we get here, we are known to be processing a "object" component. Put it in the list, perhaps replacing one which was there earlier, and complaining about a variety of things. */ do obj_idx = 1 to inp.nobj; /* Look for this one elsewhere in the input stream */ if inp.obj (obj_idx).filename = comp_info.name then do; if archive_idx <= inp.narc then do; call com_err_ (0, WHOAMI, "Duplicate object ^a in ^a", comp_info.name, inp.archive (archive_idx).path); error_sw = "1"b; /* Report all of these, but don't try binding */ if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE; else goto GET_NEXT_OBJECT; end; inp.obj (obj_idx).base = comp_info.comp_ptr; /* Replace the previous entry for this component */ inp.obj (obj_idx).bitcount = comp_info.comp_bc; /* The name, of course, is already correct */ if inp.obj (obj_idx).time_mod > comp_info.time_modified then if ^inp.brief_opt then /* Mention it, in case the user has made a mistake */ call com_err_ (0, WHOAMI, "Note: ^a in ^a (modified ^a)^/^3xreplaced by earlier (^a) copy in ^a", comp_info.name, inp.archive (inp.obj (obj_idx).archive_idx).path, DATE_TIME (inp.obj (obj_idx).time_mod), DATE_TIME (comp_info.time_modified), inp.archive (archive_idx).path); inp.obj (obj_idx).time_mod = comp_info.time_modified; inp.obj (obj_idx).time_up = comp_info.time_updated; inp.obj (obj_idx).archive_idx = archive_idx; inp.obj(obj_idx).to_be_ignored = (inp.obj(obj_idx).bitcount = 0); /* set ignore bit if seg is zero length; */ /* reset it if it was previously set & bitcount > 0 */ if inp.obj(obj_idx).bitcount = 0 then inp.zeroseg_seen = "1"b; /* Tell parse_bindfile_ to check for zsegs */ /* Having found the replacement, look no further */ if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE; else goto GET_NEXT_OBJECT; end; /* Of replacing a component */ end; /* of loop through objects */ %page; /* If we fall through to here, the object we are processing was not already in our list of objects, so we must add it to the list. */ obj_idx = inp.nobj + 1; inp.obj (obj_idx).filename = comp_info.name; /* These items need only be set the first time */ inp.obj (obj_idx).option = ""b; /* No options yet, of course */ inp.obj (obj_idx).base = comp_info.comp_ptr; inp.obj (obj_idx).bitcount = comp_info.comp_bc; inp.obj (obj_idx).time_mod = comp_info.time_modified; inp.obj (obj_idx).time_up = comp_info.time_updated; inp.obj (obj_idx).archive_idx = archive_idx; inp.obj(obj_idx).to_be_ignored = (inp.obj(obj_idx).bitcount = 0); /* set ignore bit if seg is zero length; */ /* reset it if it was previously set & bitcount > 0 */ if inp.obj(obj_idx).bitcount = 0 then inp.zeroseg_seen = "1"b; /* Tell parse_bindfile_ to check for zsegs */ inp.nobj = obj_idx; if ^inp.archive (archive_idx).standalone_seg then goto GET_NEXT_OBJECT; /* Having added it, go find another */ GET_NEXT_ARCHIVE: /* This "loop" is only reached after running out of */ /* components in an archive or processing a standalone */ end; /* segment -- see the top of the loop for details. */ /* Having done all the processing of the input archives, we now just call the subroutine which does the real work, and hope for the best. */ if error_sw then /* Reject the binding attempt, because something happened */ goto MAIN_RETURN; if inp.bindfilep = null () then do; /* Make this be more useful */ if bindfile_flag then do; /* Bindfile specified but not found -- ERROR */ call com_err_ ((0), WHOAMI, "Specified bindfile ^a was not found in the input archive^[s^].", bindfile_to_use, ((inp.narc + inp.nupd) ^= 1)); goto MAIN_RETURN; end; else /* No bindfiles specified or found -- Warning */ if ^inp.brief_opt then /* But only if we're allowed to be noisy */ call com_err_ (0, WHOAMI, "Warning: No bindfile was found in the input archive^[s^].", ((inp.narc + inp.nupd) ^= 1)); end; call bind_ (inpp); goto MAIN_RETURN; /* All done. Finish up, and return */ %page; CLEAN_UP: proc (); /* cleanup and exit procedure -- terminates all the input archives */ dcl idx fixed bin; dcl tempp pointer; if inpp ^= null then do; do idx = 1 to inp.ntotal; if inp.archive (idx).ptr ^= null () then do; tempp = inp.archive (idx).ptr; inp.archive (idx).ptr = null (); call hcs_$terminate_noname (tempp, (0)); end; end; call release_temp_segment_ (WHOAMI, inpp, (0)); binder_invoked = "0"b; /* Always turn off the flag */ end; return; end CLEAN_UP; DATE_TIME: proc (P_time) returns (char (14)); dcl P_time fixed bin (71) parameter; dcl ret_str char (14); dcl date_str char (24); call date_time_ (P_time, date_str); substr (ret_str, 1, 8) = substr (date_str, 1, 8); substr (ret_str, 9, 1) = " "; substr (ret_str, 10, 2) = substr (date_str, 11, 2); substr (ret_str, 12, 1) = ":"; substr (ret_str, 13, 2) = substr (date_str, 13, 2); return (ret_str); end DATE_TIME; %page; %include binder_input; %page; %include archive_component_info; end bind;  bind_.pl1 11/12/86 1736.3rew 11/12/86 1607.4 241731 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Modified cleanup handler to work with new bound object being created in a temp segment and then copied into the working dir. 2) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212): Generate first_ref_traps must be called after make_defs because make_defs my generate links when binding PASCAL objects. First ref traps must be generated after links. END HISTORY COMMENTS */ /* This is the main program of the binder. Designed and initially coded by Michael J. Spier, August 19, 1970, Completely revised by Michael J. Spier, December 23, 1971 */ /* modified 75.06.20 by M. Weaver for separate static */ /* modified 5/76 by M. Weaver for -brief option */ /* modified 1/77 by Melanie Weaver to call ext_link_$finish */ /* modified 8/77 by Melanie Weaver to check for perprocess static in non-standard */ /* modified 9/78 by David Spector to release temp segments on cleanup */ /* modified Dec 78 by David Spector to make repatch table automatically extensible */ /* Modified 01/14/81 W. Olin Sibert for new format of input structure, and -force_order */ /* Modified 01/21/81, WOS, to rename to bind_ so binder_ could remain "compatible" */ /* Modified 05/3/83 by Melanie Weaver to add handler for fatal_binder_error condition */ /* Modified 10/20/84 by M. Sharpe to use new binder_input_.incl.pl1; to check for bindfile errors before wiping out the old bound segment */ /* Warning: several places in the binder a fixed bin variable is referenced as based bit or based char; currently, referencing them via addr(variable) will make the pl1 compiler realize what is really being changed. */ /* format: style4,^indattr,^indcomtxt */ bind_: procedure (argp); declare argp pointer; /* DECLARATION OF EXTERNAL ENTRIES */ declare relocate_symbol_ external entry (); declare com_err_ external entry options (variable); declare decode_link_$init external entry (); declare dissect_object_ external entry (pointer); declare dissect_object_$init external entry (); declare ext_link_$init external entry (); declare ext_link_$finish entry (); declare generate_def_$init external entry (); declare get_temp_segment_ external entry (char (*), ptr, fixed bin (35)); declare form_bind_map_ external entry (pointer, fixed bin (35)); declare form_link_info_ external entry (pointer, fixed bin (35)); declare get_wdir_ external entry () returns (char (168) aligned); declare generate_first_ref_traps_ external entry (); declare int_link_$init external entry (); declare hcs_$set_bc_seg external entry (pointer, fixed bin (24), fixed bin (35)); declare hcs_$chname_seg ext entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35)); declare ioa_ external entry options (variable); declare ioa_$rs external entry options (variable); declare incorporate_options_ external entry (); declare make_bindmap_ external entry (); declare make_defs_$regenerate_block external entry (pointer); declare make_defs_$open_section external entry (); declare make_defs_$close_section external entry (); declare make_bound_object_map_ external entry (fixed bin (35)); declare parse_bindfile_ external entry (); declare rebuild_object_$init external entry (); declare rebuild_object_ external entry (pointer); declare release_temp_segment_ external entry (char (*), ptr, fixed bin (35)); declare temp_mgr_$allocate external entry (fixed bin); declare temp_mgr_$reserve external entry (pointer); declare temp_mgr_$init external entry (); declare temp_mgr_$make_object external entry (); declare temp_mgr_$close_files external entry (); declare terminate_file_ external entry (ptr, fixed bin (24), bit (*), fixed bin (35)); declare tssi_$clean_up_segment external entry (pointer); declare tssi_$get_segment external entry (char (*) aligned, char (*) aligned, ptr, ptr, fixed bin (35)); declare tssi_$finish_segment external entry (pointer, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, pos, nobjects) fixed bin; declare hash_index fixed bin (34); declare (val, lng, symb_relc) fixed bin (18); declare code fixed bin (35); declare list_acinfop pointer; declare (inpp, linkptr, old_ptr, p, sp, textp) pointer; declare (dirname char (168), segname char (32)) aligned; declare listname char (32) aligned; declare whalf char (3) aligned; declare 1 x aligned, 2 obj_ptr pointer, 2 list_ptr pointer, 2 list_bc fixed bin (24), 2 long fixed bin, 2 nopts fixed bin; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, divide, fixed, hbound, index, min, mod, null, rel, substr, unspec) builtin; declare size builtin; declare rank builtin; declare cleanup condition; declare fatal_binder_error condition; /* DECLARATION OF EXTERNAL STATIC */ declare (error_table_$pathlong, error_table_$segnamedup) ext fixed bin (35); /* DECLARATION OF INTERNAL STATIC */ declare BINDER_INPUT_VERSION_1 char (4) aligned internal static options (constant) init ("BI.1"); declare NL char (1) static options (constant) init (" "); declare FF char (1) static options (constant) init (" "); /* DECLARATION OF BASED STRUCTURES */ declare linksection (val) aligned fixed bin based; declare 1 halfword aligned based, 2 lhe18 bit (18) unaligned, 2 rhe18 bit (18) unaligned; declare 1 pr_offset aligned based, 2 dum1 bit (3) unaligned, 2 lhe15 bit (15) unaligned, 2 dum2 bit (3) unaligned, 2 rhe15 bit (15) unaligned; declare 1 clngns_overlay aligned based (addr (comp.clngns)), 2 dum bit (35) unaligned, 2 odd bit (1) unaligned; declare reset_bx (bx_$size) fixed bin (35) based (addr (bx_$area_begin)); declare based_string char (10000) based (p); declare 1 temp_seg based aligned, /* Format of temp segments */ 2 next_temp_ptr ptr, /* ptr to next temp seg in chain */ 2 storage bit (0); /* Start of temp_mgr_ storage */ %page; /* PROLOGUE - Initialize binder's temporaries, and validate format of bindfile before starting actual binding. */ inpp = argp; /* copy pointer to input structure */ reset_bx (*) = 0; /* reset main data base to zeros */ bx_$inpp = inpp; /* record address of input structure */ bx_$caller = inp.caller_name; list_acinfop, old_ptr, bx_$temp, bx_$bsegp, bx_$temp_bsegp, bx_$bseg_acinfop = null; on cleanup begin; /* delete the temp copy of the bound seg on a fault */ if bx_$temp_bsegp ^= null then call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, 0); /* clean up temp for new bound object */ if list_acinfop ^= null then call tssi_$clean_up_segment (list_acinfop); /* clean up temp for list segment */ /* Return all temp segments to free pool. */ if old_ptr ^= null then do; /* release the temp seg we got for version 2 input */ call release_temp_segment_ ("bind_", inpp, (0)); inpp = old_ptr; end; do p = bx_$temp repeat sp while (p ^= null); /* Follow chain of temp segments */ sp = p -> temp_seg.next_temp_ptr; /* Get ptr to next temp segment */ call release_temp_segment_ ("bind", p, code); if code ^= 0 then do; call com_err_ (code, inp.caller_name); return; end; end; end; if inp.version = BINDER_INPUT_VERSION_1 then call CONVERT_I_TO_II (); /* convert to new version */ else if inp.version ^= BINDER_INPUT_VERSION_2 then do; /* Complain and give up */ call com_err_ (0, inp.caller_name, "Invalid version ""^4a"" in binder input structure.", inp.version); return; end; bx_$debug = fixed (inp.debug, 1); /* copy debug flag */ bx_$brief = bin (inp.brief_opt, 1); /* copy brief flag */ bx_$force_order = bin (inp.force_order_opt, 1); /* Copy command-line Force_order option */ /* (this may also get set in parse_bindfile)_ */ on fatal_binder_error begin; bx_$fatal_error = 1; go to return; end; call temp_mgr_$init; /* create temp segment, return pointer to main database */ if bx_$fatal_error = 1 then goto return; bx_$v_lng = rank (substr (bx_$vers_name, 1, 1)); /* get length of version name */ sntp, bx_$sntp = bx_$freep; /* allocate segname table */ snt.max_size = bx_$snt_limit; call temp_mgr_$reserve (addr (snt.entry (snt.max_size + 1))); /* determine end of table */ /* reserve the area allocated to main table */ if bx_$fatal_error ^= 0 then goto return; odnp, bx_$odnp = bx_$freep; /* oddname table */ od.max_size = bx_$oddname_limit; call temp_mgr_$reserve (addr (od.entry (od.max_size + 1))); rptp = bx_$freep; /* Reserve first chunk of repatch table */ bx_$first_rptp, bx_$last_rptp = rptp; call temp_mgr_$reserve (addrel (addr (rpt), size (rpt))); rpt.thread = null; /* No more chunks */ rpt.npt = 0; /* No entries in chunk */ bx_$ncomp = inp.nobj; bx_$adnp = null; call parse_bindfile_; /* parse the bindfile, if there is one */ if bx_$fatal_error = 1 then goto return; inpp = bx_$inpp; /* refresh, in case it was modified by parse_bindfile_ */ if list_seg then do; /* be sure segname || ".list" is <= 32 chars */ i = index (bx_$bound_segname, " "); /* get length of name */ if ((i = 0) | (i > 27)) then do; call com_err_ (error_table_$pathlong, inp.caller_name, "Cannot add .list to ^a", bx_$bound_segname); bx_$fatal_error = 1; go to return; /* don't make user have to delete empty seg */ end; end; ctp, bx_$ctp = bx_$freep; /* allocate component table */ nobjects = bx_$ncomp; /* get number of component objects */ call temp_mgr_$reserve (addr (comp_tbl (nobjects + 1))); /* reserve area for component table */ if bx_$fatal_error = 1 then goto return; call temp_mgr_$make_object; /* create the new bound segment */ if bx_$fatal_error = 1 then goto return; if ^inp.brief_opt then call ioa_ ("Binding ^a", bx_$bound_segname); %page; /* FIRST PASS OF BINDER = obtain ITS pointers to all relevant parts (e.g., definition section, relocation bits, etc.) of every object to be bound, and copy the text sections into the new bound segment. */ call dissect_object_$init; do i = 1 to nobjects; /* start processing components */ ctep, comp_tbl (i) = bx_$freep; /* allocate entry for this component */ call temp_mgr_$reserve (addr (comp.last_item)); unspec (comp) = ""b; /* iniitalize structure; seems to be necessary */ comp.cindex = i; /* remember entry's index in table */ comp.filename = inp.obj (i).filename; /* store object's filename */ lng = index (comp.filename, " "); /* compute filename's length */ if lng = 0 then lng = 32; else lng = lng - 1; comp.fn_lng = lng; /* remember length */ comp.ctxtp = inp.obj (i).base; /* get pointer to object segment */ comp.cbitcount = inp.obj (i).bitcount; /* and its bitcount */ call dissect_object_ (ctep); /* and process this object segment */ end; if bx_$tintlng >= 16384 then do; /* max is 16K because of 15-bit link offsets */ call com_err_ (0, inp.caller_name, "length of internal static >= 16384, the maximum static section length"); bx_$fatal_error = 1; end; bx_$maxlinklng = min (bx_$maxlinklng, 16384); /* enforce usable size */ if (bx_$has_comb_stat = 0 & bx_$has_sep_stat = 1) then bx_$bound_sep_stat = 1; /* have at least 1 nonzero sep stat and no comb stat */ else bx_$bound_sep_stat = 0; if bx_$fatal_error = 1 then go to return; call incorporate_options_; if bx_$fatal_error = 1 then goto return; /* Create hash table for segname table (snt), all of whose entries have already been stored. */ do hash_index = 0 to hbound (snt.hash_table, 1); snt.hash_table (hash_index) = null; /* Clear hash table */ end; do i = 1 to snt.n_names; /* Scan entire snt */ /* Hash code segment name from table. */ hash_index = 0; do pos = 1 to min (snt.entry (i).lng, 24); /* 24 times max */ hash_index = 2 * hash_index + bin (unspec (substr (snt.entry (i).name, pos, 1)), 9); end; hash_index = mod (hash_index, hbound (snt.hash_table, 1) + 1); /* Push snt entry into bucket thus found. */ snt.entry (i).hash_thread = snt.hash_table (hash_index); snt.hash_table (hash_index) = addr (snt.entry (i)); end; %page; /* SECOND PASS OF THE BINDER = allocate temporary area for construction of new linkage section, relocate all text sections building up the linkage section in the process, and finally construct the new definition section of the new bound object segment. */ val = bx_$textlng; /* get length of text portion */ val = divide (val + 1, 2, 17, 0) * 2; /* make it a 0 mod 2 value */ bx_$textlng = val; /* and restore to data base */ bx_$tdefp = addrel (bx_$temp_bsegp, val); call temp_mgr_$allocate (bx_$maxlinklng); /* make sure an area of sufficient size available */ if bx_$bound_sep_stat = 1 then do; bx_$tintp = bx_$freep; /* static will be between defs and link */ val = 8; /* locatiion of first link */ linkptr, bx_$tlinkp = addrel (bx_$tintp, bx_$tintlng); /* ptr to temp linkage section */ end; else do; /* bound segment has static in linkage */ linkptr, bx_$tlinkp = bx_$freep; /* linkage immediately follows defs */ val = bx_$tintlng + 8; bx_$tintp = addrel (linkptr, 8); end; call temp_mgr_$reserve (addrel (bx_$freep, bx_$maxlinklng)); /* and reserve area */ strmp, bx_$strmp = bx_$freep; /* get pointer to generated string map */ strm.max_size = bx_$stringmap_limit; call temp_mgr_$reserve (addr (strm.entry (strm.max_size + 2))); /* now fabricate a new header for this linkage section */ linkptr -> virgin_linkage_header.link_begin = bit (bin (val, 18), 18); /* and store in header */ bx_$tlinklng = val; /* remember current length of linkage section */ /* now compute length of first part of binder's symbol block */ bx_$n_lng = index (bx_$bound_segname, " ") - 1; if bx_$n_lng = -1 then bx_$n_lng = 32; /* make symbol section header length mod 8 */ i = divide (bx_$v_lng + 3, 4, 17, 0); /* compute length of version name in words */ bx_$s_lng = divide ((27 + i), 8, 17, 0) * 8; /* 27 for 20 + 7 */ call rebuild_object_$init; call decode_link_$init; call int_link_$init; call make_defs_$open_section; /* must call before ext_link_$init */ call ext_link_$init; call generate_def_$init; symb_relc = bx_$s_lng; do i = 1 to nobjects; ctep = comp_tbl (i); /* pointer to component entry */ /* the following must be done here because incorporate_options_ may have changed comp.clngns */ if clngns_overlay.odd then comp.cpads = 1; comp.crels = symb_relc; symb_relc = symb_relc + comp.clngns + comp.cpads; /* compute new relocation counter */ if comp.ignore = 0 then call rebuild_object_ (ctep); end; do i = 1 to nobjects; ctep = comp_tbl (i); /* pointer to component entry */ if comp.ignore = 0 then call make_defs_$regenerate_block (ctep); end; if bx_$n_firstrefs > 0 then call generate_first_ref_traps_ (); /* combine first ref trap arrays of each component */ call make_defs_$close_section; /* close new definition section */ call ext_link_$finish; /* print out multiple init messages */ if bx_$fatal_error = 1 then goto return; %page; /* FINAL PASS OF THE BINDER = copy new linkage section into new object segment, and relocate symbol sections into it */ val = bx_$curdeflng; /* length of new definition section */ val = divide (val + 1, 2, 17, 0) * 2; /* make it a 0 mod 2 value */ bx_$curdeflng = val; /* restore just in case */ if bx_$bound_sep_stat = 0 then do; /* int static is inside linkage */ bx_$blnkp = addrel (bx_$tdefp, val); /* ptr to location of new linkage sectiin */ val = bx_$tlinklng; /* includes static */ bx_$blnkp -> linksection = bx_$tlinkp -> linksection; bx_$bstatp = addrel (bx_$blnkp, 8); end; else do; /* static precedes linkage */ bx_$bstatp = addrel (bx_$tdefp, val); val = bx_$tintlng + bx_$tlinklng; /* get length of link and static */ bx_$bstatp -> linksection = bx_$tintp -> linksection; /* copy linkage and static into object */ bx_$blnkp = addrel (bx_$bstatp, bx_$tintlng);/* get ptr to linkage in object */ val = bx_$tlinklng; /* fill in length of actual linkage */ end; bx_$t_lng = bx_$textlng + bx_$curdeflng; /* length of new text section */ val = divide (val + 1, 2, 17, 0) * 2; /* make length of linkage section 0 mod 2 value */ bx_$l_lng = val; /* and store in main data base */ bx_$bdefp = bx_$tdefp; bx_$d_lng = bx_$curdeflng; bx_$i_lng = bx_$tintlng; bx_$blnkp -> virgin_linkage_header.linkage_section_lng = bit (bin (bx_$l_lng, 18), 18); bx_$blnkp -> virgin_linkage_header.def_offset = rel (bx_$bdefp); bx_$blnkp -> virgin_linkage_header.static_length = bit (bin (bx_$i_lng, 18), 18); bx_$bsymp = addrel (bx_$blnkp, bx_$l_lng); /* compute base of symbol section */ call relocate_symbol_; /* relocate and assemble symbol sections */ if bx_$fatal_error = 1 then goto return; /* EPILOG - make bindmap and object map, and complete addresses and values which were not available at some previous point of time. Close all files and terminate names. */ call make_bindmap_; do rptp = bx_$first_rptp repeat rpt.thread while (rptp ^= null); /* Scan repatch table */ do i = 1 to rpt.npt; /* Scan chunk of repatch table */ rptep = addr (rpt.entry (i)); /* pointer to next repatch table entry */ if rpte.pbase = "t" then textp = bx_$temp_bsegp; else if rpte.pbase = "l" then textp = bx_$blnkp; else if rpte.pbase = "s" then textp = bx_$bsymp; textp = addrel (textp, rpte.poffset); /* get pointer to instruction to patch */ whalf = rpte.halfword; /* determine which halfword to patch */ if whalf = "lhe" then val = fixed (textp -> halfword.lhe18, 18); else if whalf = "l15" then val = fixed (textp -> pr_offset.lhe15, 15); else if whalf = "rhe" then val = fixed (textp -> halfword.rhe18, 18); val = val + fixed (rpte.pexpr, 18); /* add expression value */ if rpte.code = "l" then val = val + bin (rel (bx_$blnkp), 18); else if rpte.code = "s" then val = val + bin (rel (bx_$bsymp), 18); if whalf = "lhe" then textp -> halfword.lhe18 = bit (bin (val, 18), 18); else if whalf = "l15" then textp -> pr_offset.lhe15 = addr (val) -> pr_offset.rhe15; else textp -> halfword.rhe18 = bit (bin (val, 18), 18); end; end; /* and now, at last, make an object map for the new object segment */ call make_bound_object_map_ (code); if code ^= 0 then do; call com_err_ (0, inp.caller_name, "Cannot generate object map"); bx_$fatal_error = 1; bx_$o_lng = bx_$t_lng + (bx_$bound_sep_stat * bx_$i_lng) + bx_$l_lng + bx_$s_lng; /* to get bitcount */ bx_$bseg_bitcount = bx_$o_lng * 36; /* ... */ end; bx_$o_lng = divide (bx_$bseg_bitcount, 36, 17, 0); if bx_$fatal_error = 1 then goto return; call hcs_$set_bc_seg (bx_$temp_bsegp, bx_$bseg_bitcount, code); if list_seg = "1"b then /* produce a listing segment */ do; dirname = get_wdir_ (); /* get directory name */ segname = bx_$bound_segname; /* get name of bound object segment */ i = index (segname, " "); substr (segname, i, 5) = ".list"; list_ptr = null; call tssi_$get_segment (dirname, segname, list_ptr, list_acinfop, code); /* create segment */ if list_ptr = null then do; call com_err_ (code, inp.caller_name, segname); bx_$fatal_error = 1; goto return; end; listname = segname; /* copy segment name */ substr (listname, i, 5) = ".map "; call hcs_$chname_seg (list_ptr, "", listname, code); if code ^= 0 then /* name duplication */ if code ^= error_table_$segnamedup then do; call com_err_ (0, inp.caller_name, "Cannot add name ^a to segment ^a", listname, segname); end; obj_ptr = bx_$temp_bsegp; /* pointer to new bound object segment */ list_bc = 0; if list_opt = "1"b then do; /* copy bindfile, if any */ if inp.bindfilep = null then goto output_bindmap; p = list_ptr; /* copy for convenience */ call ioa_$rs ("^/^/^-^-Bindfile for ^a^/", dirname, val, bx_$bound_segname); substr (based_string, 1, val) = substr (dirname, 1, val); lng = divide (inp.bindfile_bc, 9, 17, 0); /* get character count */ substr (based_string, val + 1, lng) = substr (bindfilep -> based_string, 1, lng); lng = lng + val; substr (based_string, lng + 1, 2) = FF || NL; list_bc = (lng + 2) * 9; /* set bitcount of list segment */ end; output_bindmap: long = 1; nopts = 0; if map_opt = "1"b then call form_bind_map_ (addr (x), code); /* go produce bindmap information */ if list_opt = "1"b then do; unspec (x.long) = "740000000000"b3; /* fabricate form_link_info_ arguments */ lng = divide (list_bc, 9, 17, 0); /* get length in chars of list seg */ substr (list_ptr -> based_string, lng + 1, 2) = FF || NL; list_bc = list_bc + 18; /* increase length by 2 chars */ call form_link_info_ (addr (x), code); /* output link info */ end; if list_ptr ^= null then call tssi_$finish_segment (list_ptr, list_bc, "1011"b, list_acinfop, code); end; return: if bx_$fatal_error = 1 then do; bx_$addname = 0; call com_err_ (0, inp.caller_name, "Fatal error has occurred; binding of ^a unsuccessful.^/The incomplete version exists in [pd]>^a.", bx_$bound_segname, bx_$bound_segname); end; call temp_mgr_$close_files; if old_ptr ^= null then do; /* release the temp seg we got for version 2 input */ call release_temp_segment_ ("bind_", inpp, (0)); inpp = old_ptr; end; return; %page; CONVERT_I_TO_II: proc (); /* program to convert version 1 inp to version 2 inp. */ /* Automatic */ dcl idx fixed bin; /* Based */ dcl 1 v1_inp aligned based (old_ptr), /* the now-obsolete version 1 binder_input */ 2 version char (4) aligned, 2 caller_name char (32) unaligned, /* Name of command on whose behalf binder is being invoked */ 2 bound_seg_name char (32) unaligned, /* name of new bound segment */ 2 narc fixed bin, /* number of input archive files */ 2 nupd fixed bin, /* number of update archive files */ 2 archive (30) aligned, /* info about input archives, for source map, etc. */ 3 path char (168) unaligned, /* for identifying archive */ 3 real_path char (168) unaligned, /* determined by translator_info_ */ 3 ptr pointer, /* pointer to archive */ 3 bc fixed bin (24), /* and its bitcount */ 3 uid bit (36) aligned, /* unique id of archive */ 3 dtm fixed bin (71), /* date-time modified of archive */ 2 bindfilep pointer, /* pointer to bindfile */ 2 bindfile_bc fixed bin (24), /* bitcount of bindfile */ 2 bindfile_name char (32) unaligned, /* name of bindfile */ 2 bindfile_time_up fixed bin (71), /* date updated in archive */ 2 bindfile_time_mod fixed bin (71), /* date last modified */ 2 bindfile_idx fixed bin, /* index of archive bindfile was in */ 2 options aligned, 3 debug bit (1) unaligned, /* 1-> debug option ON */ 3 list_seg bit (1) unaligned, /* 1 -> make list seg */ 3 map_opt bit (1) unaligned, /* 1 -> map option */ 3 list_opt bit (1) unaligned, /* 1 -> list option */ 3 brief_opt bit (1) unaligned, /* 1 -> brief option */ 3 force_order_opt bit (1) unaligned, /* 1 -> force_order option from command line */ 3 flags_pad bit (30) unaligned, 2 nobj fixed bin, /* number of objects to be bound */ 2 v1_obj (400) aligned like v1_obj; dcl 1 v1_obj aligned based (p), /* dcl of single input entry for version 1 binder_input */ 2 filename char (32) unaligned, 2 base pointer, /* pointer to base of object segment */ 2 bitcount fixed bin (24), /* bitcount of object segment */ 2 option bit (18) unaligned, /* pointer into option structure */ 2 flag bit (1) unaligned, /* This word of unaligned bits ought to be a substructure, */ 2 pad bit (17) unaligned, /* but if it is, pl1 scope-of-names stupidly rejects refs */ /* to obj.flag as "ambiguous", because of inp.obj.flag */ 2 archive_idx fixed bin, /* index of archive from which this component comes */ 2 time_mod fixed bin (71), /* DTCM of component (from archive) */ 2 time_up fixed bin (71); /* Time updated in archive */ old_ptr = inpp; call get_temp_segment_ ("bind_", inpp, code); if code ^= 0 then do; call com_err_ (code, "bind_", "Could not get temporary segment for version 2 input structure"); bx_$fatal_error = 1; goto return; end; inp.version = BINDER_INPUT_VERSION_2; inp.caller_name = v1_inp.caller_name; inp.bound_seg_name = v1_inp.bound_seg_name; inp.narc = v1_inp.narc; inp.nupd = v1_inp.nupd; inp.ntotal = inp.narc + inp.nupd; inp.nobj = v1_inp.nobj; inp.bindfilep = v1_inp.bindfilep; inp.bindfile_bc = v1_inp.bindfile_bc; inp.bindfile_name = v1_inp.bindfile_name; inp.bindfile_time_up = v1_inp.bindfile_time_up; inp.bindfile_time_mod = v1_inp.bindfile_time_mod; inp.bindfile_idx = v1_inp.bindfile_idx; unspec (inp.options) = unspec (v1_inp.options); do idx = 1 to inp.ntotal; inp.archive (idx) = v1_inp.archive (idx), by name; inp.archive (idx).standalone_seg = "0"b; end; do idx = 1 to inp.nobj; inp.obj (idx) = v1_inp.v1_obj (idx), by name; inp.obj (idx).new_order = 0; inp.obj (idx).to_be_ignored, inp.obj (idx).objectname_stmt = "0"b; end; return; end CONVERT_I_TO_II; %page; %include bindext; %page; %include comptbl; %page; %include bndtbl; %page; %include linkdcl; %page; %include binder_input; %page; %include terminate_file; end bind_;  binder_.pl1 12/18/84 0913.4r w 12/18/84 0836.8 44721 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ binder_: proc (P_old_input_ptr); /* * BINDER_ * * This procedure, once the standard subroutine interface for the binder, is now * just a writearound to call bind_ with the appropriately formatted new structure. * It is slightly complicated by the fact that it must copy between two structures * both named input, described in two different include files; this is done by * including one in the outer procedure, and one in a begin block. * * 01/21/81, W. Olin Sibert * 10/3/84, M. Sharpe modified to use version 2 of binder_input.incl.pl1 */ dcl P_old_input_ptr pointer parameter; dcl 1 old_input aligned like inp based (P_old_input_ptr); dcl (p, inpp) pointer; /* Silly pointers not declared by the include files */ dcl time_now fixed bin (71); dcl (idx, old_idx) fixed bin; dcl inp_area area; dcl bind_ entry (pointer); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl get_system_free_area_ entry () returns (area); dcl (clock, null, substr) builtin; dcl cleanup condition; %page; inpp = null (); on cleanup begin; if inpp ^= null () then free inp in (inp_area); end; begin; /* Copy all the information which is meaningful */ inp_area = get_system_free_area_ (); NTOTAL = old_input.nupd+old_input.narc; NOBJ = old_input.nobj; allocate inp in (inp_area) set (inpp); unspec (inp) = ""b; inp.version = BINDER_INPUT_VERSION_2; inp.caller_name = "binder_"; /* The "caller_name name", left as binder_ for compatibility */ inp.bound_seg_name = old_input.bound_seg_name; inp.narc = old_input.narc; inp.nupd = old_input.nupd; inp.ntotal = old_input.narc + old_input.nupd; inp.nobj = old_input.nobj; inp.archive (*).path = ""; /* First, clean these all out, then copy the used entries */ inp.archive (*).real_path = ""; /* Most things were already initialized by the unspec, above */ inp.archive (*).ptr = null (); /* All archive pointers will be null, sorry */ do idx = 1 to inp.ntotal; /* Now, copy what we can from the old input */ inp.archive (idx).real_path = substr (old_input.archive_file (idx).name, 1, old_input.archive_file (idx).lng); inp.archive (idx).uid = old_input.archive_file (idx).uid; inp.archive (idx).dtm = old_input.archive_file (idx).dtm; end; inp.bindfilep = old_input.bindfilep; inp.bindfile_bc = old_input.bindfile_bc; inp.bindfile_name = substr (old_input.bindfile_name, 1, old_input.bindfile_name_lng); call convert_date_to_binary_ ((old_input.bindfile_date_up), inp.bindfile_time_up, (0)); call convert_date_to_binary_ ((old_input.bindfile_date_mod), inp.bindfile_time_mod, (0)); inp.bindfile_idx = 1; /* All archive indices are faked to be one, even though */ /* this may be incorrect, since the field must have some */ /* value for certain error messages to work at all. */ inp.options.debug = old_input.debug; inp.options.list_seg = old_input.list_seg; inp.options.map_opt = old_input.map_opt; inp.options.list_opt = old_input.list_opt; inp.options.brief_opt = old_input.brief_opt; inp.obj (*).base = null (); /* Initialize certain values for all the input components */ inp.obj (*).filename = ""; time_now = clock (); idx = 0; do old_idx = 1 to old_input.nobj; /* Copy all meaningful values for real components */ if old_input.obj (old_idx).bitcount > 0 then do; idx = idx + 1; inp.obj (idx).filename = old_input.obj (old_idx).filename; inp.obj (idx).base = old_input.obj (old_idx).base; inp.obj (idx).bitcount = old_input.obj (old_idx).bitcount; inp.obj (idx).option = old_input.obj (old_idx).option; inp.obj (idx).flag = old_input.obj (old_idx).flag; inp.obj (idx).archive_idx = 1; /* To make messages work; same as for bindfile above */ inp.obj (idx).time_mod = time_now; /* This is as valid as we can make it. They will all be */ inp.obj (idx).time_up = time_now; /* the same, though they will all also be wrong */ end; end; inp.nobj = idx; /* reset after tossing out zero-length segs */ call bind_ (addr (inp)); /* Call the real interface */ %page; %include binder_input; end; /* Begin block */ if inpp ^= null () then free inp in (inp_area); return; /* All done */ %page; %include input; end binder_;  bx_.cds 07/16/86 1217.0rew 07/16/86 0846.3 70191 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Changed version number to 12, added bx_$caller and bx_$temp_bsegp END HISTORY COMMENTS */ /* BX_ - Static Segment for the Multics Binder. Rewritten in CDS 12/16/76 by Noel I. Morris */ /* Modified 8/16/77 by Melanie Weaver to add perprocess_static switch */ /* Modified Oct 78 by David Spector to delete temp pointers and count */ /* Modified Dec 78 by David Spector to make repatch table extensible */ /* Version 10.2: 01/15/81, W. Olin Sibert: -force_order, -force_update, bind command warnings */ /* Modified 5/25/82 by Melanie Weaver to increase addname limit */ /* Modified 06/16/83 by Melanie Weaver to handle list template external variable initialization */ /* Modified 11/03/83 by Melanie Weaver to change version for changes made by JMAthane in 1982 */ /* Modified 11/15/84 by M. Sharpe to change version number */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style3,^indnoniterdo */ bx_: proc; dcl 1 cdsa like cds_args auto aligned; dcl Binder_Version_Name char (167) static options (constant) init ("Multics Binder, Version 12 of Tuesday, March 26, 1985"); dcl Binder_Version_Number fixed bin static options (constant) init (12); dcl 1 bx_text aligned auto, /* pure portion of bx_ */ 2 vers_name, /* ASCII version name, in ACC form */ 3 lth fixed bin (8) unal, 3 chr char (167) unal, 2 vers_number fixed bin, /* integer part of version number */ 2 size fixed bin, /* size of main data base, for resetting */ 2 snt_limit fixed bin, /* preset limit for segname table */ 2 oddname_limit fixed bin, /* preset limit for oddname table */ 2 stringmap_limit fixed bin, /* preset limit for stringmap table */ 2 addname_limit fixed bin; /* preset limit for addname table */ dcl 1 bx_link aligned auto, /* internal static portion of bx_ */ 2 area_begin bit (0) unal, /* beginning of main data base */ 2 ctp pointer, /* pointer to component table */ 2 freep pointer, /* pointer to beginning of free area */ 2 isp pointer, /* pointer to first insym table */ 2 inpp pointer, /* pointer to binder's input structure */ 2 bsegp pointer, /* pointer to base of new object segment */ 2 temp_bsegp ptr, /* pointer to temporary bound seg (in [pd]) */ 2 temp pointer, /* pointer to threaded temp segments */ 2 optp pointer, /* pointer to options table */ 2 odnp pointer, /* pointer to oddname table */ 2 first_rptp pointer, /* pointer to first chunk of repatch table */ 2 last_rptp pointer, /* pointer to current chunk of repatch table */ 2 adnp pointer, /* pointer to addname table */ 2 bindmap_def pointer, /* pointer to new object's "bind_map" definition */ 2 bdefp pointer, /* pointer to new object's definition section */ 2 bstatp pointer, /* pointer to new object's static section */ 2 blnkp pointer, /* pointer to new object's linkage section */ 2 bsymp pointer, /* pointer to new object's symbol section */ 2 sntp pointer, /* pointer to segname table */ 2 tdefp pointer, /* pointer to temporary new definition section */ 2 tintp pointer, /* pointer to temporary new internal static */ 2 tlinkp pointer, /* pointer to temporary new linkage section */ 2 strmp pointer, /* pointer to stringmap table */ 2 n_firstrefs fixed bin, /* ptr to comp tbl for seg with frt */ 2 bound_segname char (32) aligned, /* name of new bound object */ 2 caller char (32) aligned, /* name of calling program */ 2 fatal_error fixed bin, /* 1 -> fatal error was detected */ 2 bseg_acinfop pointer, /* new object's acinfop for "tssi_" */ 2 bseg_bitcount fixed bin (24), /* new object's bitcount */ 2 o_lng fixed bin (19), /* length of new bound object */ 2 t_lng fixed bin (18), /* length of new text section */ 2 d_lng fixed bin (18), /* length of new definition section */ 2 i_lng fixed bin, /* length of new static section */ 2 l_lng fixed bin, /* length of new linkage section */ 2 s_lng fixed bin (18), /* length of new symbol section */ 2 addname fixed bin, /* 1 -> addname option specified */ 2 debug fixed bin, /* 1 -> debug option was specified */ 2 brief fixed bin, /* 1 -> brief option was specified */ 2 force_order fixed bin, /* 1 -> -force_order specified on command line */ 2 has_sep_stat fixed bin, /* 1 -> a comp has nonzero sep static */ 2 has_comb_stat fixed bin, /* 1 -> a comp has nonzero compined static */ 2 bound_sep_stat fixed bin, /* 1 -> bound segment has separate static */ 2 perprocess_static fixed bin, /* 1 -> bound seg has perprocess static switch on */ 2 standard fixed bin, /* 1 -> bound seg is in standard format */ 2 bproc fixed bin, /* 1 -> at least one component is a procedure */ 2 textlng fixed bin (18), /* length of new pure text portion */ 2 curdeflng fixed bin (18), /* current length of new definition section */ 2 tintlng fixed bin, /* current length of new internal static */ 2 maxlinklng fixed bin, /* maximum size linkage section may attain */ 2 maxdeflng fixed bin (18), /* maximum size definitions section may attain */ 2 tlinklng fixed bin, /* current size of linkage section */ 2 ncomp fixed bin, /* number of component objects to be bound */ 2 v_lng fixed bin, /* length of version name string */ 2 n_lng fixed bin, /* length of bound segment name string */ 2 nsymdefs fixed bin, /* count of non-null symbol definitions */ 2 nsegdefs fixed bin; /* count of non-null segment name definitions */ dcl code fixed bin (35), create_data_segment_ entry (ptr, fixed bin (35)), com_err_ entry options (variable); dcl (addr, length, null, size, string, unspec) builtin; %page; unspec (bx_text) = "0"b; /* Clear data bases. */ unspec (bx_link) = "0"b; vers_name.lth = length (Binder_Version_Name); vers_name.chr = Binder_Version_Name; vers_number = Binder_Version_Number; bx_text.size = size (bx_link); snt_limit = 900; oddname_limit = 256; stringmap_limit = 2048; addname_limit = 250; ctp, freep, isp, inpp, bsegp, temp_bsegp, optp, odnp, first_rptp, last_rptp, adnp, bindmap_def, bdefp, bstatp, blnkp, bsymp, sntp, tdefp, tintp, tlinkp, strmp, bseg_acinfop = null (); n_firstrefs = 0; cdsa.sections (1).p = addr (bx_text); cdsa.sections (1).len = size (bx_text); cdsa.sections (1).struct_name = "bx_text"; cdsa.sections (2).p = addr (bx_link); cdsa.sections (2).len = size (bx_link); cdsa.sections (2).struct_name = "bx_link"; cdsa.seg_name = "bx_"; cdsa.num_exclude_names = 0; string (cdsa.switches) = "0"b; cdsa.switches.have_text = "1"b; cdsa.switches.have_static = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, "bx_", ""); return; %page; %include cds_args; end bx_;  decode_link_.pl1 11/20/86 1403.9r w 11/20/86 1142.2 78732 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and readability and changed errname to use a caller supplied value instead of "binder_". END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /********************************************************************/ /* */ /* Name: decode_link_ */ /* Input: structure_ptr */ /* Function: given the offset of a link in the linkage section */ /* (from loffset in ext), extract the following */ /* information from the link: */ /* Tm modifier - from tag field of link */ /* stored in ext.link_tm */ /* Td modifier - from tag field of link */ /* store in ext.link_td */ /* expression value - from expression word in */ /* definition section */ /* store in ext.expr */ /* link type - from type-pair in defn scn */ /* store in ext.type */ /* trap pointer - from type-pair in defn scn */ /* store in ext.trap */ /* segname - from segname ACC string in */ /* defn scn or decoded from */ /* type and segpointer: */ /* tp 1, sp 0 = *text */ /* tp 1, sp 1 = *link */ /* tp 1, sp 2 = *symbol */ /* tp 1, sp 4 = *static */ /* tp 5, sp 5 = *system */ /* tp 5 = component filename */ /* other = segname ACC str */ /* store in ext.segname */ /* entryname - from entryname ACC string */ /* for type 4, 5, 6 links only */ /* store in ext.entryname */ /* The flag ext.dont_prelink is also set for *system */ /* links since they must remain external */ /* Output: code */ /* */ /********************************************************************/ /* Designed and coded by Michael J. Spier February 13,1971 */ /* modified 6/20/75 by M. Weaver for separate static */ /* modified 10/22/76 by M. Weaver for *system */ decode_link_: procedure (structure_ptr, code); declare structure_ptr pointer, code bit (1) aligned; /* DECLARATION OF EXTERNAL ENTRIES */ declare com_err_ external entry options (variable); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare errname char (16) aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, type) fixed bin (18); declare (extp, defptr) pointer; declare (linkp, expp, typep, ACCp) pointer; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bit, index, substr, unspec) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 ext aligned based (extp) like external_ref; declare 1 link aligned like object_link based (linkp); declare 1 exp aligned like exp_word based (expp); declare 1 loffset_overlay aligned based (addr (ext.loffset)), 2 dum bit (35) unaligned, 2 odd bit (1) unaligned; declare 1 type_pr aligned like type_pair based (typep); declare 1 segname_ACC aligned based (addr (ext.segname)) like acc_string; declare 1 entryname_ACC aligned based (addr (ext.entryname)) like acc_string; declare 1 ACC aligned like acc_string based (ACCp); declare segname_overlay bit (297) aligned based (addr (ext.segname)); declare entryname_overlay bit (2313) aligned based (addr (ext.entryname)); /* */ %include object_link_dcls; /* */ %include definition_dcls; /* */ %include extref; /* */ %include bindext; /* */ %include comptbl; /* */ extp = structure_ptr; /* copy pointer to external ref structure */ ctep = ext.compent_ptr; /* copy argument into stack for efficiency */ defptr = comp.cdefp; /* copy pointer to component object's def section */ code = "0"b; /* reset return value */ if loffset_overlay.odd then /* compiler error,should refer to an even location */ do; call com_err_ (0, errname, "^a|^o of ^a referencing odd location in linkage section.", ext.section, ext.offset, comp.filename); goto error_skip; end; linkp = addrel (comp.clnkp, ext.loffset); /* pointer to link fault */ if link.tag ^= "100110"b then do; call com_err_ (0, errname, "link|^o referenced by ^a|^o of ^a not linkfault (46)8.", ext.loffset, ext.section, ext.offset, comp.filename); goto error_skip; end; ext.link_tm = substr (link.modifier, 1, 2); /* get link's TM modifier */ ext.link_td = substr (link.modifier, 3, 4); /* get link's TD modifier */ segname_overlay, entryname_overlay = "0"b; /* clear ACC strings */ ext.slng, ext.elng = 0; /* and their respective lengths */ expp = addrel (defptr, link.expression_relp); /* get pointer to expression word */ ext.expr = unspec (exp.expression); /* get expression value */ typep = addrel (defptr, exp.type_relp); /* get pointer to type-pair */ ext.type = bit (type_pr.type); /* get type */ ext.trap = bit (type_pr.trap_relp); /* and trap pointer */ type = type_pr.type; if type ^= 3 then if type ^= 4 then if type ^= 1 then if type ^= 5 then if type ^= 6 then do; call com_err_ (0, errname, "External link type ^o in link|^o of ^a; not handled by current version.", type, ext.loffset, comp.filename); goto error_skip; end; ext.code15 = bit (type_pr.segname_relp); /* copy types 1 & 5 segbase code */ i = type_pr.segname_relp; /* convert segpointer to fix for type-1 link */ if type = 1 then /* *|expr,m link */ do; segname_ACC.count = 5; /* preset char count */ if i = 0 then segname_ACC.string = "*text"; else if i = 1 then segname_ACC.string = "*link"; else if i = 2 then do; segname_ACC.count = 7; segname_ACC.string = "*symbol"; end; else if i = 4 then do; segname_ACC.count = 7; segname_ACC.string = "*static"; end; else do; call com_err_ (0, errname, "type-1 link at link|^o of ^a has illegal seg-ptr value ^o", ext.loffset, comp.filename, i); goto error_skip; end; ext.slng = segname_ACC.count + 1; goto extract_symbol; end; if type = 5 then /* *|symbol+exp,m link */ do; if i = 5 then do; /* *system, not ordinary type 5 */ segname_ACC.count = 7; segname_ACC.string = "*system"; end; else do; /* make segname = filename */ segname_ACC.count = index (comp.filename, " ") - 1; segname_ACC.string = substr (comp.filename, 1, segname_ACC.count); end; ext.slng = segname_ACC.count + 1; /* length of entire ACC string (incl. count) */ goto extract_symbol; end; /* get pointer to segment name */ ACCp = addrel (defptr, type_pr.segname_relp); segname_ACC.count = ACC.count; /* get ACC string length */ if segname_ACC.count > 32 then /* string too long */ do; call com_err_ (0, errname, "external segname ^a longer than 32 chars; segname truncated.", ACC.string); segname_ACC.count = 32; end; ext.slng = segname_ACC.count + 1; /* store length in structure */ /* and copy string into structure */ segname_ACC.string = substr (ACC.string, 1, segname_ACC.count); extract_symbol: if type = 4 | type = 5 | type = 6 then /* there is an entryname */ do; ACCp = addrel (defptr, type_pr.offsetname_relp); entryname_ACC.count = ACC.count; if entryname_ACC.count > 256 then do; call com_err_ (0, errname, "external entryname ^a longer than 256 chars; entryname truncated.", ACC.string); entryname_ACC.count = 256; end; ext.elng = entryname_ACC.count + 1; entryname_ACC.string = substr (ACC.string, 1, entryname_ACC.count); end; /* *system must be external */ if ((type = 5) & (i = 5)) then ext.dont_prelink = "1"b; return; error_skip: code = "1"b; /* error occurred, return code */ return; init: entry; /* set error message caller name */ if bx_$debug = 1 then errname = "decode_link_"; else errname = bx_$caller; return; end decode_link_;  dissect_object_.pl1 11/20/86 1403.9r w 11/20/86 1145.0 175482 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Changed errname to use caller supplied name instead of "binder_", improved documentation and readability, deleted obsolete nonstandard object support, and added code to create the link_regeneration_table. 2) change(86-07-02,Elhard), approve(86-07-02,MCR7284), audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119): Modified to not use segname definitions already in the component as search names for resolving intercomponent calls. END HISTORY COMMENTS */ /**********************************************************************/ /* */ /* Name: dissect_object_ */ /* Input: compent_ptr */ /* Function: breaks down the object segment specified by the */ /* component table entry pointed to by compent and */ /* fills in the rest of the component table entry. */ /* This procedure is also responsible for the */ /* following: */ /* 1) copying the component's text section into */ /* the new object segment, padding the end of */ /* the the previous text section if required */ /* to get the proper text section alignment, */ /* and calculating the new text section */ /* relocation counter. */ /* 2) calculate the relocation counter for the */ /* internal static section and pad the static */ /* section of the previous component if reqd */ /* to align the current component's static */ /* section on the proper boundary. */ /* 3) the segname table is updated to include the */ /* new component. */ /* 4) copy the definition section into the insym */ /* table. */ /* 5) determine the number of symbol blocks that */ /* are present in the object segment. */ /* 6) allocate the link_regeneration_table for the */ /* component. */ /* Output: none */ /* */ /**********************************************************************/ /* Designed and initially coded by Michael J. Spier, August 20, 1970 */ /* modified 75.06.20 by M. Weaver for separate static */ /* format: style3,^indnoniterdo */ dissect_object_: procedure (compent_ptr); declare compent_ptr pointer; /* DECLARATION OF EXTERNAL ENTRIES */ declare decode_definition_$full external entry (pointer, pointer, pointer) returns (bit (1) aligned); declare object_info_$long external entry (pointer, fixed bin (24), pointer, fixed bin (35)); declare com_err_ external entry options (variable); declare ioa_ external entry options (variable); declare temp_mgr_$allocate external entry (fixed bin); declare temp_mgr_$reserve external entry (pointer); /* DECLARATION OF EXTERNAL STATIC */ declare error_table_$bad_segment external fixed bin (35); declare error_table_$unimplemented_version external fixed bin (35); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare last_insym pointer internal static initial (null); declare (text_relc, is_relc) fixed bin internal static initial (0); declare errname char (16) aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare i fixed bin; declare (def_begin, def_offset, val, lng) fixed bin (18); declare code fixed bin (35); declare (p, sblkp, ddp, oip) pointer; declare (defp, insymp, insymep) pointer; declare type_string char (5) aligned; declare link_start fixed bin (18) unsigned; declare link_end fixed bin (18) unsigned; declare lrt_len fixed bin; declare lrt_word_count fixed bin; declare 1 dd aligned, /* output structure for decode_definition_ */ 2 next_def pointer, 2 last_def pointer, 2 block_ptr pointer, 2 section char (4) aligned, 2 value fixed bin (18), 2 entrypoint fixed bin, 2 symbol char (256) aligned, 2 symbol_lng fixed bin, /* actual length of symbol */ 2 flags, 3 new_format bit (1) unaligned, 3 ignore bit (1) unaligned, /* def is to be ignored but will be regenerated */ 3 entrypoint bit (1) unaligned, /* def is for entrypoint */ 3 retain bit (1) unaligned, 3 arg_count bit (1) unaligned, /* there is an arg count for entry */ 3 descr_sw bit (1) unaligned, /* there are descriptors for entry */ 3 unused bit (13) unaligned, 2 n_args fixed bin, /* no of args entry expects */ 2 descr_ptr ptr; /* ptr to array of rel ptrs to descriptors in def section */ /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, divide, fixed, min, null, ptr, rel, substr, trunc) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 insyme aligned like is based (insymep); declare 1 symbol_acc aligned based (addr (insyme.symbol)), 2 len fixed bin (9) unsigned unaligned, 2 text char (32 refer (symbol_acc.len)) unaligned; declare 1 rhb based aligned, 2 dum bit (35) unaligned, 2 odd bit (1) unaligned; /* to determine if a value is even/odd */ declare textsection (lng) fixed bin based (p); /* */ %include bindext; /* */ %include comptbl; /* */ %include bndtbl; /* */ %include insym; /* */ declare 1 oi aligned like object_info; %include object_info; /* */ %include object_link_dcls; /* */ %include symbol_block; %include pl1_symbol_block; declare 1 firstref_block aligned based, 2 version fixed bin, 2 n_traps fixed bin, 2 traps (0 refer (firstref_block.n_traps), 2) bit (18) unaligned; declare 1 lh aligned based (oi.linkp), 2 defseg fixed bin, /* 0->defs in text, 16->defs in link */ 2 defptr bit (18) unaligned, /* offset of definition section */ 2 first_reference bit (18) unaligned, /* offset of first ref trap array */ 2 fthread pointer, /* unused */ 2 bthread pointer, /* unused */ 2 link_begin bit (18) unaligned, /* offset in linkage section of linkage info */ 2 block_lng bit (18) unaligned, 2 dum2 bit (18) unaligned, 2 linkage_lng bit (18) unaligned; /* */ ctep = compent_ptr; /* copy pointer to component table entry */ sntp = bx_$sntp; /* pointer to segname table */ oip = addr (oi); /* initialize */ oi.version_number = object_info_version_2; call object_info_$long (comp.ctxtp, comp.cbitcount, addr (oi), code); if code ^= 0 then do; /* bad object segment */ faterr: call com_err_ (code, errname, comp.filename); bx_$fatal_error = 1; return; end; if ^oi.format.standard then do; code = error_table_$bad_segment; /* don't process non-standard new objects */ go to faterr; /* this is fatal */ end; if oi.bmapp ^= null then do; /* also a no-no */ call com_err_ (0, errname, "Component ^a has a break map.", comp.filename); bx_$fatal_error = 1; return; end; if ^oi.format.relocatable then do; if oi.compiler = "binder " then type_string = "bound"; else type_string = ""; call com_err_ (0, errname, "Component ^a is a nonrelocatable ^a segment.", comp.filename, type_string); bx_$fatal_error = 1; return; /* don't generate all those name conflict messages */ end; /* find the number of links to determine the size of the linke_regeneration table */ /* and allocate it. */ if oi.linkp -> virgin_linkage_header.defs_in_link = "010000"b then link_end = oi.linkp -> virgin_linkage_header.def_offset; else link_end = oi.linkp -> virgin_linkage_header.linkage_section_lng; if oi.linkp -> virgin_linkage_header.first_ref_relp ^= 0 then link_end = min (link_end, oi.linkp -> virgin_linkage_header.first_ref_relp); link_start = oi.linkp -> virgin_linkage_header.link_begin; lrt_len = (link_end - link_start) * 0.5; /* calculate number of links */ lrt_word_count = trunc ((lrt_len + 1) * 0.5) + 2; /* calculate number of words reqd for table */ call temp_mgr_$allocate (lrt_word_count); /* allocate the table */ lrtp, comp.clrtp = bx_$freep; call temp_mgr_$reserve (addrel (lrtp, lrt_word_count)); lrt.count = lrt_len; /* initialize lrt */ lrt.start_offset = link_start; lrt.regenerated (*) = ""b; comp.clngt, val = oi.tlng; /* get length of pure-text section */ if addr (comp.clngt) -> rhb.odd then comp.cpadt = 1; /* if text length odd number, pad text with one word */ if oi.text_boundary ^= 2 /* text must sit on 4,8,16,64 boundary */ then if comp.cindex ^= 1 /* and this is not first entry */ then do; i = oi.text_boundary; /* copy for convenience */ val = divide (text_relc + i - 1, i, 17, 0) * i; /* compute new base */ i = val - text_relc; /* get difference */ if i > 0 then /* there was a difference */ do; p = bx_$ctp -> comp_tbl (comp.cindex - 1); /* get previous entry */ p -> comp.cpadt = p -> comp.cpadt + i; /* extend previous pad */ text_relc = val; /* adjust new base address */ end; end; comp.crelt = text_relc; /* get relocation counter value for this text section */ i = comp.clngt + comp.cpadt; /* compute effective length of text section */ bx_$textlng, text_relc = text_relc + i; /* compute relocation value for next text section */ comp.cdefp = oi.defp; /* pointer to definition section */ comp.clngd = oi.dlng; /* length of definition section */ comp.csymp = oi.symbp; /* pointer to symbol section */ comp.clngs = oi.slng; /* length of symbol section */ comp.clngns = oi.default_truncate; /* length of symbol section without relbits */ comp.clngss = oi.optional_truncate; /* length of symbol section without relbits or table */ /* if there is a symbol table and it is needed by v2pl1 io, we must make a note of it so that we will not delete it later */ if oi.compiler = "v2pl1" | oi.compiler = "PL/I" /* so far only compiler that can have this */ then if oi.standard /* only std objs have the special flags */ then if oi.symbp -> sb.area_ptr /* there might be a symbol table */ then if addrel (oi.symbp, oi.symbp -> sb.area_ptr) -> pl1_symbol_block.flags.io then comp.io_table = 1; /* table is needed by runtime io */ comp.clngi = oi.ilng; /* length of internal static */ if addr (comp.clngi) -> rhb.odd then comp.cpadi = 1; /* if length of int static odd number, then pad */ if oi.static_boundary ^= 2 then /* if static must start at mod 4,8,16,64 */ if comp.cindex ^= 1 then /* if this is not first entry */ do; i = oi.static_boundary; /* copy for convenience */ val = divide (is_relc + i - 1, i, 17, 0) * i; i = val - is_relc; /* get difference */ if i > 0 then do; p = bx_$ctp -> comp_tbl (comp.cindex - 1); /* pointer to previous entry */ p -> comp.cpadi = p -> comp.cpadi + i; is_relc = is_relc + i; end; end; comp.creli = is_relc; /* get relocation counter value for this internal static */ i = comp.clngi + comp.cpadi; /* get effective length of static */ bx_$tintlng, is_relc = is_relc + i; comp.clnkp = oi.linkp; /* pointer to linkage section header */ comp.cstatp = oi.statp; comp.separate_static = 0; /* initialize */ if oi.ilng > 0 then do; /* don't worry about 0 length static */ if oi.format.separate_static then do; bx_$has_sep_stat = 1; comp.separate_static = 1; /* this variable is needed by rebuild_object_ */ end; else bx_$has_comb_stat = 1; end; bx_$maxlinklng = bx_$maxlinklng + oi.llng + (comp.separate_static * comp.clngi); /* vble used to allocate space for both stat + link */ bx_$maxdeflng = bx_$maxdeflng + comp.clngd; /* compute size of temporary for new linkage section */ comp.crltp = oi.rel_text; comp.crllp = oi.rel_link; comp.crlsp = oi.rel_symbol; /* pointers to relocation information */ comp.standard_object = fixed (oi.format.standard, 1); /* copy object format indicator */ dd.symbol = comp.filename; /* put in structure for compatibility */ do i = 32 to 1 by -1 while (substr (comp.filename, i, 1) = " "); end; dd.symbol_lng = i; /* fill in length too */ call update_segname_table; /* put name in segment name table */ /* scan definition section to buildup insym entry for this object segment */ insymp, comp.insymentp = bx_$freep; /* get pointer to new area for insym entry */ if last_insym ^= null then last_insym -> insym.thread = insymp; /* thread insym entries together */ else bx_$isp = insymp; /* remember beginning of insym-table */ last_insym = insymp; /* remember pointer to current entry */ insymp -> insym.thread = null; /* indicate this last entry */ defp, dd.next_def = oi.defp; /* set up definition search */ def_begin = bin (rel (defp), 18); ddp = addr (dd); /* initialize before loop */ follow_defs: /* get offset of next def rel to defp */ def_offset = bin (rel (dd.next_def), 18) - def_begin; if decode_definition_$full (dd.next_def, ddp, oip) = "1"b then /* get next definition */ do; /* make a last null entry for type 3 links */ insymp -> insym.n_insyms, i = insymp -> insym.n_insyms + 1; insymep = addr (insymp -> insym.entry (i)); insyme.null_entry = "1"b; /* set null entry indicator */ goto identify_format; end; if dd.section = "segn" then goto follow_defs; insymp -> insym.n_insyms, i = insymp -> insym.n_insyms + 1; /* get current insym-table index */ insymep = addr (insymp -> insym.entry (i)); /* and get pointer to next entry */ insyme.value = bit (bin (dd.value, 18), 18); if dd.section = "link" then insyme.class = "000000000000000001"b; else if dd.section = "symb" then insyme.class = "000000000000000010"b; else if dd.section = "stat" then insyme.class = "000000000000000100"b; symbol_acc.len = dd.symbol_lng; /* get ACC length */ symbol_acc.text = substr (dd.symbol, 1, dd.symbol_lng); insyme.lng = symbol_lng + 1; insyme.entrypoint = dd.flags.entrypoint; insyme.ignore = dd.flags.ignore; /* def is probably for unofficial entryname */ insyme.retain_flag = dd.flags.retain; insyme.def_offset = def_offset; /* keep track of loc so we can relocate later */ insyme.nargs = dd.n_args; insyme.descr_ptr = dd.descr_ptr; /* get ptr to descr ptr list */ insyme.has_descr = dd.flags.descr_sw; /* copy switch indicating valid descriptors */ goto follow_defs; identify_format: comp.compiler = oi.compiler; /* get compiler name */ if comp.standard_object = 1 then do; standard_format: comp.format = "standard"; if lh.first_reference then do; /* have some traps to regenerate */ comp.cfrtp = addrel (oi.linkp, lh.first_reference); if comp.cfrtp -> firstref_block.version ^= 1 then do; call com_err_ (error_table_$unimplemented_version, errname, "A version ^d trap on first reference encountered.", comp.cfrtp -> firstref_block.version); bx_$fatal_error = 1; end; bx_$n_firstrefs = bx_$n_firstrefs + comp.cfrtp -> firstref_block.n_traps; end; else comp.cfrtp = null; if oi.format.procedure then bx_$bproc = 1; /* for obj map--bound seg is part proc */ go to block_number; /* anything else will turn off standard flag */ end; else do; call com_err_ (0, errname, "object ^a is not a standard object segment", comp.filename); bx_$fatal_error = 1; end; bx_$standard = 0; /* at least one component is non-standard */ /* find number of symbol blocks this component has */ block_number: comp.n_sym_blks = 1; /* object has to have at least 1 */ sblkp = oi.symbp; /* start with first block and thread */ block_loop: if sb.next_block = "0"b then go to return; /* no more blocks */ sblkp = addrel (oi.symbp, sb.next_block); /* get ptr to next block */ comp.n_sym_blks = comp.n_sym_blks + 1; /* found another one */ go to block_loop; /* see if there are any more */ return: call temp_mgr_$reserve (addr (insymp -> insym.entry (insymp -> insym.n_insyms + 1))); /* reserve area allocated for insym table */ /* now copy text section into new bound object */ p = ptr (bx_$temp_bsegp, comp.crelt); /* pointer to new text location */ lng = comp.clngt; p -> textsection = oi.textp -> textsection; /* and copy the stuff */ return; init: entry; /**********************************************************************/ /* */ /* Name: dissect_object_$init */ /* Input: none */ /* Function: initializes the static variables used by dissect */ /* object prior to the first invocation. The text */ /* and static section relocation counters are */ /* cleared, and clear various external static flags */ /* and counters. */ /* Output: none */ /* */ /**********************************************************************/ last_insym = null; /* initialize INSYM thread */ text_relc, is_relc = 0; bx_$maxlinklng = 128; /* give it a small margin of safety */ bx_$n_firstrefs = 0; /* so far, seen none */ bx_$bproc = 0; /* turn on if any component is a proc */ bx_$standard = 1; /* assume standard output; turn off if any component is not */ bx_$has_sep_stat, bx_$has_comb_stat = 0; /* will count only nonzero length static */ if bx_$debug = 1 then errname = "dissect_object_"; else errname = bx_$caller; return; /* */ update_segname_table: procedure; declare i fixed bin; declare sntep ptr; declare val fixed bin; declare acc_actual char (33) aligned; declare acc_overlay bit (297) based (addr (acc_actual)); declare acc_str char (val) based (addr (acc_actual)); declare 01 acc aligned based (addr (acc_actual)), 02 len fixed bin (9) unsigned unaligned, 02 text char (32 refer (acc.len)) unaligned; declare 01 snte aligned based (sntep) like seg; val = symbol_lng; if symbol_lng > 32 then do; /* not acceptable for segnames */ call ioa_ ( "Warning: Segment name ^a^/in definitions for component ^a^/is being truncated to 32 characters.", dd.symbol, comp.filename); val = 32; end; acc_overlay = "0"b; /* pad ACC temporary with zeroes */ acc.len = val; acc.text = substr (dd.symbol, 1, val); val = val + 1; /* adjust length to entire ACC string */ do i = 1 to snt.n_names; /* lookup segment name table */ sntep = addr (snt.entry (i)); if acc_str = substr (snte.name, 1, val) then do; if snte.comp = ctep then return; /* OK, its same component */ call com_err_ (0, errname, "Segment name ^a for component ^a^/^-already used for component ^a", dd.symbol, comp.filename, snte.comp -> comp.filename); bx_$fatal_error = 1; return; end; end; snt.n_names, i = snt.n_names + 1; if i > snt.max_size then do; call com_err_ (0, errname, "Segname table overflow; please contact maintenance"); snt.n_names = 1; bx_$fatal_error = 1; return; end; sntep = addr (snt.entry (i)); /* pointer to new entry */ substr (snte.name, 1, val) = acc_str; snte.lng = val; snte.comp = ctep; end update_segname_table; end dissect_object_;  ext_link_.pl1 11/20/86 1403.9r w 11/20/86 1142.2 379260 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation, changed errname to use the caller-supplied name instead of "binder_", and modified to store relocation address in the link_regeneration_table and just return relocated address on subsequent references. END HISTORY COMMENTS */ /**********************************************************************/ /* */ /* Name: ext_link_ */ /* Input: argument_pointer */ /* Function: given an external_ref structure (pointed to by */ /* argument_pointer) defining a link in the current */ /* input component, create a corresponding external */ /* link in the new object segments linkage section. */ /* Output: none. */ /* */ /* Notes: External links are created by the following */ /* process: */ /* - if the link is type-6 or *system, then find */ /* or create an init_map entry matching the */ /* initialization info for the link. */ /* - if the link is a trap-before-call link, then */ /* recursively generate the trap link, and the */ /* arg_link (if present) */ /* - try to find the segname, and entryname in the */ /* stringmap */ /* - scan the link_map for another link to the */ /* target. */ /* - if the link is a type-6 or *system link, and */ /* the init-info does not match then we must */ /* select one of the init info's or combine them */ /* The following algorithm is used to select */ /* the initialization info: */ /* If one links has an area initialization */ /* and the other does not, then abort with a */ /* fatal error. This cannot be resolved. */ /* */ /* Initializations same size */ /* */ /* no new initialization */ /* 1 was init before use old */ /* 2 was not init before use old */ /* */ /* new initialization */ /* 3 was init before use old; print msg */ /* 4 was not init before use new */ /* */ /* New initialization smaller */ /* */ /* no new initialization */ /* 5 was init before use old */ /* 6 was not init before use old */ /* */ /* new initialization */ /* 7 was init before use old; print msg */ /* 8 was not init before *use new with */ /* larger size */ /* */ /* New initialization larger */ /* */ /* no new initialization */ /* 9 was init before *use old with */ /* larger size */ /* 10 was not init before use new */ /* */ /* new initialization */ /* 11 was init before use new; print msg */ /* 12 was not init before use new */ /* */ /* * using a given init info template with a */ /* larger size means that it must be extended */ /* with zeros */ /* */ /* - if an existing link is found and can be used */ /* relocate the referencing halfword and return */ /* - generate a new expression word in the */ /* definition section */ /* - generate a new type pair if the existing one */ /* could not be used */ /* - if the segname or entryname were not found in */ /* the stringmap, then add them */ /* - generate a new link in the linkage section */ /* and a new link_map entry. */ /* - relocate the referencing halfword and return */ /* */ /* A note on error handling: */ /* bx_$fatal_error is set when the error is fatal (i.e. there */ /* should be no bound segment) but it is useful to continue */ /* and possibly generate more messages for the user. */ /* fatal_binder_error is signaled when the error is so severe */ /* that the binder cannot reasonably continue (as when it runs */ /* out of room). (It is possible that a different */ /* implementation could avoid having to abort.) */ /* */ /**********************************************************************/ /* Designed and initially coded by Michael J. Spier, October 6, 1970 */ /* modified 75.06.20 by M. Weaver to fix type 6 link initialization */ /* modified July 1975 for separate static */ /* modified October 1976 to regenerate *system */ /* modified January 1977 by M. Weaver to use largest init sizes and convert some type 6 links to *system */ /* modified March 18, 1977 by M. Weaver to handle 0 trap ptr for *system links */ /* modified October 21, 1977 by M. Weaver to add non-relocation mode */ /* modified December 6, 1977 by M. Weaver to allow larger external variable init sizes */ /* modified Sept 1978 by David Spector for hash-coding strm */ /* Modified 01/15/81, W. Olin Sibert, to remove ribbon shifts. */ /* modified March 1, 1983 by M. Weaver to use standard include files and allocate init structures during finish */ /* modified December 29, 1983 by M. Weaver to not relocate n for *text|offsetname+n */ /* format: style3,^indnoniterdo */ ext_link_: procedure (argument_pointer); declare argument_pointer pointer; /* DECLARATION OF EXTERNAL SYMBOLS */ declare decode_link_ external entry (pointer) returns (bit (1) aligned); declare ext_link_$gen_trap external entry (pointer) returns (fixed bin (18) unsigned aligned); declare com_err_ external entry options (variable); declare ioa_ entry options (variable); declare temp_mgr_$allocate external entry (fixed bin); declare temp_mgr_$reserve external entry (pointer); declare strm_hash_$lookup external entry (char (*), fixed bin (17)); declare strm_hash_$make_entry external entry (char (*) aligned, fixed bin (17)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare (linkbase, defbase, tblp, newlinkp, init_map_ptr) pointer internal static; declare (n_tbls, nlinks, init_map_lng) fixed bin internal static; declare null_acc_offset fixed bin (18) unsigned aligned internal static; declare errname char (16) aligned internal static; declare wsegname char (33) aligned internal static; declare wentryname char (257) aligned internal static; declare ext_lng fixed bin (18) internal static; declare linklimit fixed bin internal static; /* number of links generated */ /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, def_growth, map_lng, linkmapx, mapx, extension_size, new_init_map_index, strm_index, new_init_type, existing_init_type) fixed bin (17); declare (val, step, xoffset, class, name_offset) fixed bin (18); declare lrt_index fixed bin; declare real_init_size fixed bin (35); declare scratch (100) fixed bin; declare (p, ap, link_ptr, old_trap, extp, new_ptr) ptr; declare (orig_init_info_ptr, cur_init_info_ptr, init_entry_ptr) ptr; declare new_link_modifier bit (6) aligned; declare (segname_found, entryname_found, typepair_found, trap_sw, convert, new_has_init_template, init_before) bit (1) aligned; declare new_ename char (256) varying; declare 1 new_exp_word aligned like exp_word; declare 1 new_type_pair aligned like type_pair; declare 1 new_trap_pair aligned like link_trap_pair; declare 1 new aligned, 2 (smaller, equal, larger) bit (1) aligned; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, currentsize, divide, fixed, index, length, mod, null, size, sign, string, substr, unspec, wordno) builtin; declare fatal_binder_error condition; /* DECLARATION OF BASED STRUCTURES */ declare 1 linkmap (10000) aligned based (newlinkp), 2 type_ptr ptr, /* ptr to link's generated type pair */ 2 linkaddr fixed bin (18) unsigned unaligned, 2 init_map_index fixed bin unaligned, 2 init_source char (32) aligned, /* origin of init info */ 2 has_init_template bit (1) unaligned, /* "1"b -> has an associated */ /* initialization template */ 2 diff_init_size bit (1) unaligned, /* >1 size of init info specified for link */ 2 print_msg bit (1) unaligned, /* >1 init template specified for link */ 2 incompatible_init_types bit (1) unaligned; /* ext var both area and other init type */ declare 1 init_map (5000) aligned based (init_map_ptr), 2 init_ptr ptr, /* ptr to original initialization info */ 2 new_init_ptr ptr, /* ptr to regenerated initialization info */ 2 template_size fixed bin (35), /* expanded size of template */ 2 total_init_size fixed bin (35), /* size of variable incl extension */ 2 reference_count fixed bin unaligned, /* # of links that reference this entry */ 2 init_type fixed bin unaligned; /* type of init info */ declare 1 tbl_map based (tblp) aligned, /* newly generated trap_pair map */ 2 tbl_offset (1000) fixed bin (18) unsigned unaligned; declare init_size_compares (-1:1) bit (1) aligned based (addr (new)); declare copy_save (ext_lng) fixed bin based (p); declare 1 word aligned based, 2 left_half bit (18) unaligned, 2 right_half bit (18) unaligned; declare 1 ext aligned based (ap) like external_ref; trap_sw = "0"b; /* indicate that this is a regular link */ start: def_growth = 0; ctp = bx_$ctp; strmp = bx_$strmp; ap = argument_pointer; /* copy argument into our stack frame */ ctep = ext.compent_ptr; val = 0; lrtp = comp.clrtp; lrt_index = ((ext.loffset - lrt.start_offset) * 0.5) + 1; if (lrt.regenerated (lrt_index) ^= UNRESOLVED) & (lrt.regenerated (lrt_index) ^= INTERNALLY_RESOLVED) then do; step = fixed (lrt.regenerated (lrt_index), 18); goto adjust_text; end; new_link_modifier = ext.link_tm || ext.link_td; /* this program doesn't need them separated */ segname_found, entryname_found, typepair_found = "0"b; map_lng = strm.nstr; new_init_map_index = 0; old_trap = null; new_has_init_template = "0"b; unspec (new_exp_word) = "0"b; unspec (new_trap_pair) = "0"b; new_type_pair.type = bin (ext.type, 18); /* copy type/trap values into new type pair */ new_type_pair.trap_relp, /* this field does not get filled in */ new_type_pair.segname_relp, new_type_pair.offsetname_relp = 0; class = bin (ext.code15, 18); /* use class instead of segname for types 1 & 5 */ if new_type_pair.type = LINK_REFNAME_BASE then do; new_type_pair.offsetname_relp = null_acc_offset; /* use null acc offset to compare with type 6 */ entryname_found = "1"b; /* we know it's allocated */ end; if ^trap_sw /* normal ext_link_ entry (not gen_trap entry) */ then do; /* format name for possible error message */ wsegname = substr (ext.segname, 2, ext.slng - 1); i = ext.elng; wentryname = substr (ext.entryname, 1, i); if wsegname = "*system" then substr (wentryname, 1, 1) = "|"; else if i > 0 then substr (wentryname, 1, 1) = "$"; else do; i = 2; wentryname = "|0"; end; end; if ext.trap then if (new_type_pair.type = LINK_CREATE_IF_NOT_FOUND) | ((new_type_pair.type = LINK_SELF_OFFSETNAME) & (class = SECTION_SYSTEM)) then do; /* have create-if-not-found or *system link */ /* find/create an init map entry for this */ orig_init_info_ptr = addrel (comp.cdefp, ext.trap); call find_init_map_entry (); new_has_init_template = (init_map (new_init_map_index).template_size > 0); end; else do; /* have trap before link */ addr (scratch) -> copy_save = ap -> copy_save; /* save input structure */ ext.offset = ext.loffset; /* change input struc to process trap links */ ext.section = "link"; ext.relinfo = " "; old_trap = addrel (comp.cdefp, ext.trap); ext.loffset = old_trap -> link_trap_pair.call_relp; if decode_link_ (ap) then go to trap_error; new_trap_pair.call_relp = ext_link_$gen_trap (ap); /* will need to recreate link */ ext.loffset = old_trap -> link_trap_pair.info_relp; /* will look at arg link now */ if ext.loffset > 0 then do; /* process arg link */ if decode_link_ (ap) = "1"b then go to trap_error; new_trap_pair.info_relp = ext_link_$gen_trap (ap); end; else new_trap_pair.info_relp = 0; do i = 1 to n_tbls; /* scan trap before link trap pair map */ if unspec (new_trap_pair) = unspec (addrel (defbase, tbl_offset (i)) -> link_trap_pair) then do; new_type_pair.trap_relp = tbl_offset (i); /* put rel ptr into new link's trap field */ go to restore_ext; end; end; /* of searching table */ n_tbls = i; /* increment size of map */ tbl_offset (i), new_type_pair.trap_relp = bx_$curdeflng; bx_$curdeflng = bx_$curdeflng + 1; /* update def section size */ addrel (defbase, tbl_offset (i)) -> link_trap_pair = new_trap_pair; /* copy trap pair */ restore_ext: ap -> copy_save = addr (scratch) -> copy_save; /* restore input struc */ end; /* of trap decoding processing */ /* scan current portion of new linkage section to see if such ext link already exists */ def_growth = 0; new_exp_word.expression = bin (ext.expr, 17); if new_type_pair.type = LINK_SELF_BASE | new_type_pair.type = LINK_SELF_OFFSETNAME then do; /* type 1 & type 5 links don't have symbolic segnames */ new_type_pair.segname_relp = class; /* retrieve segbase code */ segname_found = "1"b; /* we know the "segment name" */ if bx_$bound_sep_stat ^= 1 then if class = SECTION_STATIC /* link to *static */ then new_type_pair.segname_relp = SECTION_LINK; /* will be no sep static; convert to *link */ if new_type_pair.type = LINK_SELF_BASE then do; /* there is no entryname symbol */ entryname_found = "1"b; if class = SECTION_TEXT then new_exp_word.expression = new_exp_word.expression + comp.crelt; if class = SECTION_STATIC then do; /* link to static; seg relp may have been changed */ if wsegname = "*static" then do; /* link to static of referencing component */ if bx_$bound_sep_stat = 1 then i = 0; else i = 8; new_exp_word.expression = new_exp_word.expression + comp.creli + i; end; end; /* Otherwise link to static of another component; relocation of expression already done by int_link_; ext.segname = original segname, etc. */ go to lookup_links; end; end; /* Lookup stringmap table for segname and entryname (avoid extra strings) */ if ^segname_found then do; call strm_hash_$lookup (substr (ext.segname, 1, ext.slng), strm_index); if strm_index ^= 0 then do; /* segname found in stringmap */ new_type_pair.segname_relp = bin (strm.entry (strm_index).map, 18); segname_found = "1"b; end; end; if ^entryname_found then do; call strm_hash_$lookup (substr (ext.entryname, 1, ext.elng), strm_index); if strm_index ^= 0 then do; /* entryname found in stringmap */ new_type_pair.offsetname_relp = bin (strm.entry (strm_index).map, 18); entryname_found = "1"b; end; end; lookup_links: do linkmapx = 1 to nlinks; /* scan all newly generated links */ step = linkmap (linkmapx).linkaddr; /* get rel pointer to link */ link_ptr = addrel (linkbase, step); /* and ITS pointer to it */ if link_ptr -> object_link.modifier ^= new_link_modifier then go to advance; exp_ptr = addrel (defbase, link_ptr -> object_link.expression_relp); if ^typepair_found then do; new_exp_word.type_relp = exp_ptr -> exp_word.type_relp; /* fill in in case this type pair fits */ type_ptr = linkmap (linkmapx).type_ptr; end; else go to use_typepair; if segname_found & entryname_found then do; /* see if this type pair may be reused */ if unspec (new_type_pair) ^= unspec (type_ptr -> type_pair) then go to advance; /* type pairs do not match */ /* but not comparing init info offsets here */ if new_init_map_index = linkmap (linkmapx).init_map_index then go to use_typepair; /* init info also matches */ /* now see if the init info can be made to match */ if (new_type_pair.type ^= LINK_CREATE_IF_NOT_FOUND) & ^((new_type_pair.type = LINK_SELF_OFFSETNAME) & (class = SECTION_SYSTEM)) then go to advance; /* diff trap-before-links or 1 trap and 1 not */ /* At this point we know we have a reference to a variable and we can't have 2 links to the same variable. We must use the existing link and either choose one of the init infos or combine them. */ /* Assume that ALL such links have initialization info. */ /* We can't combine the links if one is for an area and the other is not */ existing_init_type = init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.type; if linkmap (linkmapx).incompatible_init_types then return; /* don't print redundant messages */ if ((new_init_type = INIT_DEFINE_AREA) & (existing_init_type ^= INIT_DEFINE_AREA)) | ((existing_init_type = INIT_DEFINE_AREA) & (new_init_type ^= INIT_DEFINE_AREA)) then do; call com_err_ (0, errname, "External variable ^[^a^a^;^2s^]^a has incompatible initialization types.", wsegname ^= "*system", wsegname, substr (wentryname, 1, 1), substr (wentryname, 2)); bx_$fatal_error = 1; linkmap (linkmapx).incompatible_init_types = "1"b; return; /* we will bomb anyway */ end; /* now we find out how the two initializations compare */ string (new) = "0"b; real_init_size = init_map (linkmap (linkmapx).init_map_index).total_init_size; if real_init_size = 0 /* no template */ then real_init_size = init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.n_words; init_size_compares ( sign (init_map (new_init_map_index).init_ptr -> link_init.n_words - real_init_size)) = "1"b; /* compare new and previous init sizes and set appropriate flag via based array */ if linkmap (linkmapx).has_init_template then init_before = "1"b; else init_before = "0"b; if ^new.equal then do; /* print warning first time around */ if ^linkmap (linkmapx).diff_init_size then do; if bx_$brief ^= 1 then call ioa_ ( "Warning: external variable ^[^a^a^;^2s^]^a has different sizes;^/^-the largest will be used.", wsegname ^= "*system", wsegname, substr (wentryname, 1, 1), substr (wentryname, 2)); linkmap (linkmapx).diff_init_size = "1"b; end; end; /* cases 1, 2, 5, 6 just go to use_typepair */ if new_has_init_template & init_before then if init_map (new_init_map_index).init_ptr ^= init_map (linkmap (linkmapx).init_map_index).init_ptr /* make sure it's not the same template */ then do; /* cases 3, 7, 11 */ linkmap (linkmapx).print_msg = "1"b; if new.equal then if init_map (linkmap (linkmapx).init_map_index).total_init_size > init_map (linkmap (linkmapx).init_map_index).template_size then call replace_init_info; /* if old was extended, new is probably better */ end; if (new_has_init_template & ((new.equal & ^init_before) | (new.larger & init_before))) | (new.larger & ^init_before) /* cases 4, 10, 11, 12 */ then call replace_init_info; else if new.smaller & new_has_init_template & ^init_before then do; /* case 8 */ /* use new init template but extend it to length of old */ call extend_template ((new_init_map_index), init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.n_words); call replace_init_info; end; else if new.larger & ^new_has_init_template & init_before then do; /* case 9 */ /* use old template extended to new size */ call extend_template (linkmap (linkmapx).init_map_index, init_map (new_init_map_index).init_ptr -> link_init.n_words); call change_init_map_index; end; use_typepair: typepair_found = "1"b; if unspec (new_exp_word) = unspec (exp_ptr -> exp_word) then goto adjust_text; /* expression words must also match for actual link to be used */ end; advance: end; /* end of loop for looking at linkmap */ generate_definition: /* generate expression word and type pair, if necessary */ def_growth = 1; /* def section will grow by one expression word */ xoffset = bx_$curdeflng; /* offset of expression word */ exp_ptr = addrel (defbase, xoffset); if ^typepair_found /* we have to generate a type pair */ then new_exp_word.type_relp = xoffset + 1; /* thread to type pair to be created */ exp_ptr -> exp_word = new_exp_word; /* put expression word into definition section */ if typepair_found then go to generate_link; type_ptr = addrel (exp_ptr, 1); /* ptr to type pair to be generated */ type_ptr -> type_pair = new_type_pair; /* copy type pair into new definition section */ def_growth = def_growth + 2; /* remember def section grew by 2 words */ if new_init_map_index > 0 /* references are made by type pairs */ then init_map (new_init_map_index).reference_count = init_map (new_init_map_index).reference_count + 1; if ^segname_found then do; /* we have to generate an ACC string for the segname */ call add_name (addr (ext.segname), ext.slng); type_ptr -> type_pair.segname_relp = name_offset; end; if ^entryname_found then do; if substr (ext.entryname, 1, 33) = ext.segname then type_ptr -> type_pair.offsetname_relp = type_ptr -> type_pair.segname_relp; else do; /* must generate an ACC string for the entryname */ call add_name (addr (ext.entryname), ext.elng); type_ptr -> type_pair.offsetname_relp = name_offset; end; end; /* now update official stringmap length */ strm.nstr = map_lng; if strm.nstr > strm.max_size then do; call com_err_ (0, errname, "Stringmap table overflow; please notify maintenance."); strm.nstr = 0; bx_$fatal_error = 1; end; generate_link: /* regenerate link itself */ step = bx_$tlinklng; /* location where new link will be generated */ linkmapx, nlinks = nlinks + 1; /* increment table size */ if nlinks > linklimit then do; /* table overflow */ call com_err_ (0, errname, "Linktable overflow while adding link to ^a^a^/^-for component ^a.^/^-You have room for only ^d links^/^-after your ^d words of internal static.^/^-Consider using separate static (pl1 or alm) or large arrays (fortran)^/^-to make more room for links.", wsegname, wentryname, ext.compent_ptr -> comp.filename, linklimit, bx_$tintlng); signal fatal_binder_error; /* stop now; don't prolong the agony */ end; linkmap (nlinks).type_ptr = type_ptr; /* remembering this will make patching easier */ linkmap (nlinks).linkaddr = step; /* remember where link is */ linkmap (nlinks).init_source = comp.filename; /* and origin of init structure */ linkmap (nlinks).init_map_index = new_init_map_index; linkmap (nlinks).has_init_template = new_has_init_template; linkmap (nlinks).diff_init_size = "0"b; linkmap (nlinks).print_msg = "0"b; link_ptr = addrel (linkbase, step); /* get pointer to new link */ bx_$tlinklng = step + 2; /* and adjust new length of linkage section */ link_ptr -> object_link.header_relp = -step; /* backpointer to head of linkage section */ link_ptr -> object_link.tag = "46"b3; /* add fault tag 2 code */ link_ptr -> object_link.expression_relp = xoffset;/* ptr to expression word in def section */ link_ptr -> object_link.modifier = new_link_modifier; /* restore modifiers of original link */ adjust_text: bx_$curdeflng = bx_$curdeflng + def_growth; /* adjust def section length if necessary */ if ^ext.dont_relocate then do; /* sometimes we regenerate links that aren't referenced */ if trap_sw then trap_offset = step; /* return rel ptr to trap fault */ else if ext.relinfo = "lnk18 " then do; if ext.side = "lhe" then ext.ref_ptr -> word.left_half = bit (bin (step, 18), 18); else ext.ref_ptr -> word.right_half = bit (bin (step, 18), 18); end; else substr (ext.ref_ptr -> word.left_half, 4, 15) = bit (bin (step, 15), 15); /* put in textsection rel ptr to linkage */ end; lrt.regenerated (lrt_index) = bit (bin (step, 18), 18); return; trap_error: ap -> copy_save = addr (scratch) -> copy_save; /* restore original link information */ call com_err_ (0, errname, "cannot process trap before link for ^a^a referenced by ^a|^o of ^a", wsegname, wentryname, ext.section, ext.offset, comp.filename); bx_$fatal_error = 1; return; gen_trap: entry (argument_pointer, trap_offset); /**********************************************************************/ /* */ /* Name: ext_link_$gen_trap */ /* Input: argument_pointer */ /* Function: This entry point generates a link in essentially */ /* the same manner as ext_link_ except that it */ /* returns a relptr to the trap link relative to the */ /* base of the linkage section. */ /* Output: trap_offset */ /* */ /**********************************************************************/ declare trap_offset fixed bin (18) unsigned aligned; trap_sw = "1"b; /* indicate this is a trap before link */ trap_offset = 0; /* preset return argument */ go to start; init: entry; /**********************************************************************/ /* */ /* Name: ext_link_$init */ /* Input: none */ /* Function: allocates static tables for use by ext_link_ and */ /* initializes various static lengths */ /* Output: none */ /* */ /**********************************************************************/ linkbase = bx_$tlinkp; /* beginning of linkage section */ if mod (bx_$tlinklng, 2) = 1 then bx_$tlinklng = bx_$tlinklng + 1; /* make links start on even location */ tblp = bx_$freep; /* pointer to map of trap-pairs */ linklimit = divide ((bx_$maxlinklng - bx_$tlinklng), 2, 17, 0); /* get max no of links */ call temp_mgr_$reserve (addrel (tblp, linklimit));/* reserve map */ n_tbls = 0; /* indicate no trap-pairs yet */ i = linklimit * 7; /* get max size of init map */ call temp_mgr_$allocate (i); /* make sure that there is enough room */ init_map_ptr = bx_$freep; /* pointer to init info map */ call temp_mgr_$reserve (addrel (init_map_ptr, i));/* reserve init info map */ i = linklimit * 12; /* get max size of link map */ call temp_mgr_$allocate (i); /* make sure that there is enough room */ init_map_lng = 0; /* reset length of init map */ newlinkp = bx_$freep; /* make new link table */ call temp_mgr_$reserve (addrel (newlinkp, i)); nlinks = 0; /* preset table size */ if bx_$debug = 1 then errname = "ext_link_"; else errname = bx_$caller; defbase = bx_$tdefp; /* beginning of definition section */ null_acc_offset = bx_$curdeflng - 1; /* all zero word set in make_defs_$open_section */ /* compute the size of the external reference structure 'ext' */ ap = addr (scratch); ext_lng = size (ext); return; finish: entry; /**********************************************************************/ /* */ /* Name: ext_link_$finish */ /* Input: none */ /* Function: allocates the initialization structures in the */ /* bound segment and patches the initialization */ /* info relptrs back into the links. If the init */ /* info for a copy_info initialization has been */ /* extended, and the extension is longer than an */ /* arbitrary size (50 words), the copy_info is */ /* converted to a list_template containing a single */ /* copy of the existing info and a repeated zero */ /* Messages are also printed for links which had */ /* multiple initializations specified. */ /* Output: none */ /* */ /**********************************************************************/ declare n_bad_links fixed bin; /* print all multiple initialization messages */ do i = 1 to nlinks; if linkmap (i).print_msg then do; type_ptr = linkmap (i).type_ptr; if type_ptr -> type_pair.type = LINK_SELF_OFFSETNAME then wsegname = ""; /* no segname; don't print *system */ else wsegname = addrel (defbase, type_ptr -> type_pair.segname_relp) -> acc_string.string || "$"; call com_err_ (0, errname, "Multiple initializations specified for external variable ^a^a;^/^-the one in ^a will be used.", wsegname, addrel (defbase, type_ptr -> type_pair.offsetname_relp) -> acc_string.string, linkmap (i).init_source); end; end; /* Now allocate all init info structures that the links in the bound segment reference. */ link_init_n_bits_in_datum = 0; do mapx = 1 to init_map_lng; if init_map (mapx).reference_count > 0 then do; /* copy into bound segment */ init_map (mapx).new_init_ptr, cur_init_info_ptr = addrel (defbase, bx_$curdeflng); extension_size = init_map (mapx).total_init_size - init_map (mapx).template_size; if init_map (mapx).init_type = INIT_COPY_INFO then do; if extension_size <= 50 /* arbitrary limit */ then do; cur_init_info_ptr -> link_init_copy_info = init_map (mapx).init_ptr -> link_init_copy_info; if extension_size > 0 then cur_init_info_ptr -> link_init_copy_info.header.n_words = init_map (mapx).total_init_size; bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_copy_info); end; /* of no or small extension */ else do; /* convert to list template */ cur_init_info_ptr -> link_init_list_template.header.type = INIT_LIST_TEMPLATE; cur_init_info_ptr -> link_init_list_template.n_words_in_list = init_map (mapx).init_ptr -> link_init_copy_info.header.n_words + size (list_template_entry) + 1; init_entry_ptr = addr (cur_init_info_ptr -> link_init_list_template.template); init_entry_ptr -> list_template_entry.n_bits = init_map (mapx).init_ptr -> link_init_copy_info.n_words * 36; init_entry_ptr -> list_template_entry.repeat = 1; init_entry_ptr -> list_template_entry.datum = unspec (init_map (mapx).init_ptr -> link_init_copy_info.initial_data); init_entry_ptr = addrel (init_entry_ptr, currentsize (init_entry_ptr -> list_template_entry)); call add_extension; bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_list_template); end; /* of conversion to list */ end; /* of init_copy_info case */ else if init_map (mapx).init_type = INIT_LIST_TEMPLATE then do; cur_init_info_ptr -> link_init_list_template = init_map (mapx).init_ptr -> link_init_list_template; if extension_size > 0 then do; /* 0 repeat entry starts where last word now is */ init_entry_ptr = addrel (cur_init_info_ptr, currentsize (cur_init_info_ptr -> link_init_list_template) - 1); call add_extension; end; bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_list_template); end; /* of init_list template case */ else do; /* no template; just header */ cur_init_info_ptr -> link_init = init_map (mapx).init_ptr -> link_init; if extension_size > 0 then cur_init_info_ptr -> link_init.n_words = init_map (mapx).total_init_size; bx_$curdeflng = bx_$curdeflng + size (link_init); end; end; end; /* of copying init_info into bound segment */ /* Now update the links that have init info */ n_bad_links = 0; xoffset = wordno (defbase); do mapx = 1 to nlinks; if linkmap (mapx).init_map_index > 0 then do; /* have init info to fill in */ new_ptr = init_map (linkmap (mapx).init_map_index).new_init_ptr; if new_ptr ^= null then linkmap (mapx).type_ptr -> type_pair.trap_relp = wordno (new_ptr) - xoffset; else do; /* indicates bug in this program */ n_bad_links = n_bad_links + 1; call com_err_ (0, errname, "Link to external variable ^a has missing initialization information.^/^-Notify maintenance personnel.", addrel (defbase, linkmap (mapx).type_ptr -> type_pair.offsetname_relp) -> acc_string.string) ; /* segname is usually meaningless in this case */ end; end; end; if n_bad_links > 0 then bx_$fatal_error = 1; return; find_init_map_entry: proc; /**********************************************************************/ /* */ /* Name: find_init_map_entry */ /* Input: orig_init_info_ptr, new_type_pair, wsegname, */ /* external_ref (pointed to by ap) */ /* Function: finds or creates an init_map entry for a given */ /* link. Certain type-6 (create-if-not-found) links */ /* are first converted into *system links. If an */ /* init_map entry is found that matches, it's */ /* reference count is incremented and it is used. */ /* otherwise an new entry is created. */ /* Output: new_init_map_index */ /* */ /**********************************************************************/ convert = "0"b; if new_type_pair.type = LINK_CREATE_IF_NOT_FOUND then do; /* see if it needs to be converted */ extp = ap; /* normal, non trap case */ if wsegname = "stat_" then do; convert = "1"b; new_ename = addr (ext.entryname) -> acc_string.string; end; else if ext.elng = 1 then do; /* null entryname */ i = index (ext.segname, ".com"); if (i > 0) & (i = (ext.slng - 3)) then do; new_ename = substr (ext.segname, 2, i - 2); if new_ename = "b_" then new_ename = "blnk*com"; convert = "1"b; end; else do; new_type_pair.offsetname_relp = null_acc_offset; /* set to point to all zero word */ entryname_found = "1"b; end; end; else if wsegname = "cobol_fsb_" then do; new_ename = "cobol_fsb_" || addr (ext.entryname) -> acc_string.string; convert = "1"b; end; end; if convert then do; /* diddle info to make it look like *system link */ extp -> ext.code15 = bit (bin (LINK_SELF_OFFSETNAME, 18), 18); new_type_pair.type = LINK_SELF_OFFSETNAME; class = SECTION_SYSTEM; wsegname = "*system"; addr (extp -> ext.segname) -> acc_string.count = length ("*system"); addr (extp -> ext.segname) -> acc_string.string = "*system"; extp -> ext.slng = length ("*system") + 1; wentryname = "|" || new_ename; addr (extp -> ext.entryname) -> acc_string.count = length (new_ename); addr (extp -> ext.entryname) -> acc_string.string = new_ename; extp -> ext.elng = length (new_ename) + 1; end; /* See if an identical init structure is already in our map */ new_init_type = orig_init_info_ptr -> link_init.type; do new_init_map_index = 1 to init_map_lng; cur_init_info_ptr = init_map (new_init_map_index).init_ptr; /* get ptr to current entry's init info */ if unspec (orig_init_info_ptr -> link_init) = unspec (cur_init_info_ptr -> link_init) then do; /* so far, init headers match */ if new_init_type = INIT_COPY_INFO then if unspec (orig_init_info_ptr -> link_init_copy_info.initial_data) = unspec (cur_init_info_ptr -> link_init_copy_info.initial_data) then return; else ; /* templates don't match; continue */ else if new_init_type = INIT_LIST_TEMPLATE then if unspec (orig_init_info_ptr -> link_init_list_template.template) = unspec (cur_init_info_ptr -> link_init_list_template.template) then return; else ; /* templates don't match; continue */ else return; /* no templates to match in these cases */ end; /* of = headers part */ end; /* of comparison loop */ /* if we get here a match was not found, so we have to add an init_map entry */ init_map_lng = init_map_lng + 1; /* new_init_map_index should already be = to this */ init_map (init_map_lng).init_ptr = orig_init_info_ptr; init_map (init_map_lng).reference_count = 0; init_map (init_map_lng).init_type = new_init_type; init_map (init_map_lng).new_init_ptr = null; /* now set template size */ if (new_init_type = INIT_COPY_INFO) | (new_init_type = INIT_LIST_TEMPLATE) then init_map (init_map_lng).template_size = orig_init_info_ptr -> link_init_copy_info.header.n_words; else init_map (init_map_lng).template_size = 0; init_map (init_map_lng).total_init_size = init_map (init_map_lng).template_size; /* equality indicates not extended */ return; end; replace_init_info: proc; /**********************************************************************/ /* */ /* Name: replace_init_info */ /* Input: new_has_init_info, linkmapx, new_init_map_index */ /* Function: Changes the init_map index in the link specified */ /* by linkmapx to use the initialization info */ /* referred to by new_init_map_index. */ /* Output: none */ /* */ /**********************************************************************/ linkmap (linkmapx).init_source = comp.filename; linkmap (linkmapx).has_init_template = new_has_init_template; call change_init_map_index; return; end; change_init_map_index: proc; /**********************************************************************/ /* */ /* Name: change_init_map_index */ /* Input: linkmapx, new_init_map_index */ /* Function: replaces the init_map entry for the specified */ /* link and adjusts the reference counts in the */ /* init_map entries */ /* Output: none */ /* */ /* Notes: this procedure is logically a part of */ /* replace_init_info but must sometimes be called */ /* separately */ /* */ /**********************************************************************/ init_map (linkmap (linkmapx).init_map_index).reference_count = init_map (linkmap (linkmapx).init_map_index).reference_count - 1; init_map (new_init_map_index).reference_count = init_map (new_init_map_index).reference_count + 1; linkmap (linkmapx).init_map_index = new_init_map_index; return; end; extend_template: proc (cur_init_map_index, target_size); /**********************************************************************/ /* */ /* Name: extend_template */ /* Input: cur_init_map_index, target_size */ /* Function: extends the specified init_map entry to the size */ /* indicated by target size. This is done by first */ /* attempting to find an existing init_map entry */ /* that matches the requirements, or by creating one */ /* if no matching init_info already exists. */ /* Output: new_init_map_index */ /* */ /**********************************************************************/ declare cur_init_map_index fixed bin unal; declare target_size fixed bin (35); /* first try to match an existing template */ do mapx = 1 to init_map_lng; if init_map (mapx).total_init_size = target_size then if init_map (mapx).init_ptr = init_map (cur_init_map_index).init_ptr /* the unextended templates must match; the init_map has no duplicates; so if they match, they are the same */ then do; new_init_map_index = mapx; return; end; end; /* of mapx loop */ /* Did not find match. Must create a new init_map entry for the extension. */ init_map_lng = init_map_lng + 1; /* copy whole entry, then update */ init_map (init_map_lng) = init_map (cur_init_map_index); init_map (init_map_lng).total_init_size = target_size; init_map (init_map_lng).reference_count = 0; /* this will be updated later */ new_init_map_index = init_map_lng; return; end; add_name: proc (new_name_ptr, name_length); /**********************************************************************/ /* */ /* Name: add_name */ /* Input: new_name_ptr, name_length */ /* Function: adds a new name to the definition section and to */ /* the string map. */ /* Output: none */ /* */ /**********************************************************************/ declare new_name_ptr ptr; /* to an ACC string */ declare name_length fixed bin; declare new_name char (name_length) aligned based; name_offset = xoffset + def_growth; addrel (defbase, name_offset) -> new_name = new_name_ptr -> new_name; def_growth = def_growth + divide (name_length + 3, 4, 17, 0); map_lng = map_lng + 1; strm.entry (map_lng).map = bit (name_offset, 18); call strm_hash_$make_entry (new_name_ptr -> new_name, map_lng); return; end; add_extension: proc; /**********************************************************************/ /* */ /* Name: add_extension */ /* Input: init_entry_ptr, extension_size */ /* Function: adds a list_template entry to the list template */ /* initialization to add zero words */ /* to the end of the initialization */ /* Output: none */ /* */ /**********************************************************************/ /* add the extension to skip the required number of bits */ init_entry_ptr -> list_template_entry.n_bits = extension_size * 36; init_entry_ptr -> list_template_entry.repeat = 0; /* append the end-of-list-template marker (n_bits = 0) */ addrel (init_entry_ptr, size (list_template_entry)) -> list_template_entry.n_bits = 0; /* adjust the length of the template */ cur_init_info_ptr -> link_init_list_template.n_words_in_list = cur_init_info_ptr -> link_init_list_template.n_words_in_list + size (list_template_entry); cur_init_info_ptr -> link_init_list_template.header.n_words = init_map (mapx).total_init_size; return; end; %include extref; %include bindext; %include comptbl; %include bndtbl; %include definition_dcls; %include object_link_dcls; end; /* of ext_link_ */  generate_def_.pl1 11/20/86 1403.9r w 11/20/86 1145.0 108036 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation, changed errname to use the caller-supplied name instead of "binder_", deleted support for obsolete non-standard objects. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /**********************************************************************/ /* */ /* Name: generate_def_ */ /* Input: compent_ptr, definition_ptr */ /* Function: given a pointer to the current component_table */ /* entry (compent_ptr) and a pointer to an insym */ /* entry (definition_ptr), regenerates the specfied */ /* definition in the definition section of the new */ /* bound object_segment and threads it in place. The */ /* references are relocated and any links referenced */ /* by the definitions (as in pascal exported vars) */ /* are generated. */ /* Ouptut: none */ /* */ /**********************************************************************/ /* Designed and initially coded by Michael J. Spier, October 6, 1970 */ /* modified June, july 1975 by M. Weaver for separate static */ /* modified Sept 1978 by David Spector for hash-coding strm */ /* modified Sept 82 by JMAthane for PASCAL exportable variables definitions */ generate_def_: procedure (compent_ptr, definition_ptr); declare (compent_ptr, definition_ptr) pointer; /* DECLARATION OF CONSTANTS */ declare lda_pr0_instr bit (18) static options (constant) init ("010011101001010000"b); /* DECLARATION OF EXTERNAL SYMBOLS */ declare com_err_ external entry options (variable); declare strm_hash_$lookup external entry (char (*), fixed bin (17)); declare strm_hash_$make_entry external entry (char (*), fixed bin (17)); declare int_link_ entry (ptr) returns (bit (1)); declare decode_link_ entry (ptr) returns (bit (1)); declare ext_link_ entry (ptr); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare (defbase, linkbase) pointer internal static; declare inlink fixed bin internal static; declare errname char (16) aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, linkoffset) fixed bin; declare defoffset fixed bin (18); declare (p, ip, dp, sp, lp, dsp) pointer; dcl 1 my_ext aligned like external_ref; dcl generate_ext_link bit (1) init ("0"b); /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, divide, fixed, substr) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 new_def aligned based (dp), 2 forward_relp unal fixed bin (18) unsigned, 2 backward_relp unal fixed bin (18) unsigned, 2 thing_relp unal fixed bin (18) unsigned, 2 flags unal like definition_flags, 2 class unal fixed bin (3) unsigned, 2 name_relp unal fixed bin (18) unsigned, 2 segname_relp unal fixed bin (18) unsigned, 2 n_args unal fixed bin (18) unsigned, 2 descriptor_relp (0 refer (new_def.n_args)) unal fixed bin (18) unsigned; declare 1 last_def aligned like new_def based (lp); declare 1 insyme aligned like is based (sp); declare descr_list (1000) unal fixed bin (18) unsigned based (dsp); /* based on descriptor ptrs in def */ declare 1 dum_instr aligned, 2 register bit (3) unaligned, 2 rel_address bit (15) unaligned, 2 op_code bit (18) unaligned; declare acc_string_overlay char (257) aligned based; %page; ctp = bx_$ctp; strmp = bx_$strmp; ctep = compent_ptr; /* copy pointer to current component table entry */ sp = definition_ptr; /* copy pointer to definition entry */ if insyme.regenerated = "1"b then return; ip = comp.insymentp; /* pointer to component's definitions */ defoffset = bx_$curdeflng; /* get current size of definition section */ linkoffset = bx_$tlinklng; /* get current length of new linkage section */ dp = addrel (defbase, defoffset); /* pointer to location where new def will be generated */ if comp.defblockp = "0"b then do; comp.defblockp, comp.current_def = bit (bin (defoffset, 18), 18); /* remember current definition */ end; else do; lp = addrel (defbase, comp.current_def); /* pointer to last def */ new_def.backward_relp = fixed (comp.current_def, 18); /* backwards pointer */ last_def.forward_relp = defoffset; /* thread defs together */ comp.current_def = bit (bin (defoffset, 18), 18); /* remember last def */ end; insyme.defrel = comp.current_def; new_def.thing_relp = fixed (insyme.value, 18); /* copy value of definition */ new_def.class = fixed (insyme.class, 18); /* class of definition */ new_def.flags.new = "1"b; /* and set new format flag */ defoffset = defoffset + 3; /* grow def section by 3 words */ /* now copy descriptor ptrs, if they exist for this entry */ /* if ^insyme.has_descr then descriptors may be invalid, but copy them anyway */ if insyme.nargs > 0 then do; /* entry has descriptors */ new_def.flags.argcount = "1"b; /* indicate we have arg count */ if insyme.has_descr then new_def.flags.descriptors = "1"b; /* have valid descriptors */ new_def.n_args = insyme.nargs; dsp = insyme.descr_ptr; /* initialize for better referencing */ do i = 1 to insyme.nargs; /* copy and relocate ptrs */ new_def.descriptor_relp (i) = descr_list (i) + comp.crelt; end; defoffset = defoffset + divide (insyme.nargs + 2, 2, 17, 0); /* grow def section by length of array */ end; if bx_$standard = 1 then if insyme.retain_flag then new_def.flags.retain = "1"b; /* turn on only if on before */ /* now lookup generated strings to see if one can be reused */ call strm_hash_$lookup (substr (insyme.symbol, 1, insyme.lng), i); if i ^= 0 then do; /* string is already in strm */ new_def.name_relp = fixed (strm.entry (i).map, 18); goto adjust_value; end; /* string not found, generate string and put into map */ i, strm.nstr = strm.nstr + 1; if strm.nstr > strm.max_size then do; call com_err_ (0, errname, "stringmap table overflow; please contact maintenance"); strm.nstr = 1; bx_$fatal_error = 1; end; new_def.name_relp = defoffset; /* pointer to newly generated symbol string */ strm.entry (i).map = bit (bin (defoffset, 18), 18); p = addrel (defbase, defoffset); /* pointer to new string */ substr (p -> acc_string_overlay, 1, insyme.lng) = substr (insyme.symbol, 1, insyme.lng); defoffset = defoffset + divide (insyme.lng + 3, 4, 17, 0); /* grow definition section */ call strm_hash_$make_entry (substr (insyme.symbol, 1, insyme.lng), i); /* now compute the value of the new definition */ adjust_value: bx_$nsymdefs = bx_$nsymdefs + 1; if new_def.class = 0 then /* simple text reference */ do; new_def.thing_relp = new_def.thing_relp + comp.crelt; if comp.standard_object = 1 then /* have to do some extra fiddling here */ do; if insyme.entrypoint then new_def.flags.entry = "1"b; /* standard entries are only text */ if (insyme.ignore) | (insyme.delete) then do; new_def.flags.ignore = "1"b; /* need this for name but don't want linker to find it */ bx_$nsymdefs = bx_$nsymdefs - 1; end; end; goto return; end; else if new_def.class = 2 then /* reference relative to symbol section */ do; new_def.thing_relp = new_def.thing_relp + comp.crels; /* get value of symbol */ goto return; end; else if new_def.class = 1 then do; if new_def.thing_relp < comp.clngi + 8 then do; /* this is an ALM segdef located in the linkage section */ new_def.thing_relp = new_def.thing_relp + comp.creli; goto return; end; else do; if comp.compiler = "PASCAL " then do; /* We have a definition for a link, i.e. for a Pascal exportable variable which is represented by a link. We must regenerate the link. To do this, we fabricate an "instruction" that references the link along with the other link info. The link may indirect through another link that may be in another component. To handle this case, we must first call int_link_ to regenerate the correct target for this definition's link. */ dum_instr.rel_address = bit (bin (new_def.thing_relp, 15), 15); dum_instr.register = "000"b; dum_instr.op_code = lda_pr0_instr; /* make instruction = lda 0|nn,* */ my_ext.ref_ptr = addr (dum_instr); my_ext.dont_prelink = "0"b; my_ext.compent_ptr = ctep; my_ext.loffset = new_def.thing_relp; my_ext.side = "lhe"; my_ext.relinfo = "link15"; my_ext.dont_relocate = "0"b; if decode_link_ (addr (my_ext)) = "1"b then go to error_skip; generate_ext_link = "1"b; go to return; end; end; end; else if new_def.class = 4 then do; /* segdef in separate static */ if bx_$bound_sep_stat = 1 then i = 0; /* will still have separate static */ else do; /* static will be in linkage section */ new_def.class = 1; /* change to linkage */ i = 8; /* now static will be further offset by linkage header */ end; new_def.thing_relp = new_def.thing_relp + comp.creli + i; goto return; end; call com_err_ (0, errname, "definition ^a in file ^a has illegal class ^o", substr (insyme.symbol, 2, insyme.lng - 1), comp.filename, new_def.class); error_skip: bx_$fatal_error = 1; return: insyme.regenerated = "1"b; /* indicate that this def has been regenerated */ if ^new_def.flags.ignore then ip -> insym.retained = "1"b; /* indicate that a def was retained for this component */ bx_$curdeflng = defoffset; /* update length of new definition section */ bx_$tlinklng = linkoffset; /* update length of new linkage section */ if generate_ext_link then do; if int_link_ (addr (my_ext)) = "1"b then do; my_ext.segname = "*link"; my_ext.slng = 6; my_ext.elng = 0; my_ext.code15, my_ext.type = "000000000000000001"b; my_ext.expr = "000"b || dum_instr.rel_address; end; call ext_link_ (addr (my_ext)); new_def.thing_relp = fixed (dum_instr.rel_address, 15); end; return; %page; init: entry; defbase = bx_$tdefp; /* pointer to base of new definition section */ linkbase = bx_$tlinkp; /* pointer to base of new linkage section */ inlink = 0; /* reset pointer to inbound link */ if bx_$debug = 1 then errname = "generate_def_"; else errname = bx_$caller; return; %page; %include extref; %page; %include bindext; %page; %include comptbl; %page; %include bndtbl; %page; %include insym; %page; %include definition_dcls; end generate_def_;  generate_first_ref_traps_.pl1 08/06/86 1449.9rew 08/06/86 1419.6 47970 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved readability and documentation. 2) change(86-07-02,Elhard), approve(86-07-02,MCR7285), audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119): Modified to zero the info_relp value for the correct trap when no info link is present instead of zeroing the info_relp for the first trap. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ generate_first_ref_traps_: procedure; /**********************************************************************/ /* */ /* Name: generate_firstref_traps_ */ /* Input: none */ /* Function: scans the component table and copies the firstref */ /* traps from each component into the new firstref */ /* trap block, relocating each of the references and */ /* regenerating the links. */ /* Output: none */ /* */ /**********************************************************************/ /* DECLARATION OF EXTERNAL ENTRIES */ declare ext_link_ entry (pointer); declare decode_link_ entry (pointer) returns (bit (1) aligned); /* DECLARATION OF AUTOMATIC VARIABLES */ declare (component_firstref_blockp, linkp, extp, firstref_blockp) pointer; declare (compno, j, k) fixed bin; declare eside (2) char (3) aligned init ("lhe", "rhe"); declare 1 firstref_block aligned automatic, /* dcl of first reference trap structure */ 2 version fixed bin, 2 n_traps fixed bin, /* number of traps in array */ 2 trap (bx_$n_firstrefs, 2) bit (18) unaligned; /* automatic adjustable storage */ /* array for easier referencing */ declare 1 ext aligned like external_ref; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, null, rel, size, unspec) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 based_firstref_block aligned based (firstref_blockp) like firstref_block; declare 1 component_firstref_block aligned based (component_firstref_blockp) like firstref_block; declare 1 lh aligned based, /* linkage header */ 2 defseg fixed bin, /* 0->defs in text, 16->defs in link */ 2 defptr bit (18) unaligned, /* offset of definition section */ 2 first_reference bit (18) unaligned, /* offset of first ref trap array */ 2 fthread pointer, /* unused */ 2 bthread pointer, /* unused */ 2 link_begin bit (18) unaligned, /* offset in linkage section of linkage info */ 2 block_lng bit (18) unaligned, 2 dum2 bit (18) unaligned, 2 linkage_lng bit (18) unaligned; /* */ %include extref; /* */ %include bindext; /* */ %include comptbl; /* */ /* assume that all regular links have already been generated */ firstref_block.version = 1; firstref_block.n_traps = 0; /* for now */ extp = addr (ext); /* to use when decoding and generating links */ ext.relinfo = "lnk18"; /* fudge relocation info; can't be anything else */ ext.section = "link"; /* offsets are wrt linkage section */ /* look at each object for traps */ ctp = bx_$ctp; do compno = 1 to bx_$ncomp; ctep = comp_tbl (compno); if comp.cfrtp ^= null then do; /* this component has a firstref trap */ linkp = comp.clnkp; /* get ptr to component's linkage section */ component_firstref_blockp = comp.cfrtp; /* get ptr to component's trap array */ ext.compent_ptr = ctep; /* get offset of trap array relative to component's linkage section */ ext.offset = bin (rel (comp.cfrtp), 18) - bin (rel (comp.clnkp), 18) + 2; do j = 1 to component_firstref_block.n_traps; /* do for each trap in component */ firstref_block.n_traps = firstref_block.n_traps + 1; ext.ref_ptr = addr (firstref_block.trap (firstref_block.n_traps, 1)); /* get ptr to new trap pair (incl header) */ do k = 1 to 2; /* call and arg ptrs are processed the same */ ext.side = eside (k); ext.loffset = bin (component_firstref_block.trap (j, k), 18); /* get offset of original link */ if ext.loffset = 0 then firstref_block.trap (firstref_block.n_traps, k) = ""b; else if decode_link_ (extp) then bx_$fatal_error = 1; /* presumably a message will have been printed */ else call ext_link_ (extp); /* regenerate link; must be external */ end; end; end; end; /* allocate the firstref block in the linkage section */ firstref_blockp = addrel (bx_$tlinkp, bx_$tlinklng); bx_$tlinkp -> lh.first_reference = bit (bin (bx_$tlinklng, 18), 18); bx_$tlinklng = bx_$tlinklng + size (firstref_block); /* adjust the linkage length */ unspec (based_firstref_block) = unspec (firstref_block); return; end generate_first_ref_traps_;  get_relinfo_.pl1 07/16/86 1217.0rew 07/16/86 0848.0 45414 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and remove nonstandard object segment support. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ get_relinfo_: procedure (argp); /**********************************************************************/ /* */ /* Name: get_relinfo_ */ /* Input: none */ /* Function: returns the word_offset, halfword identifier, */ /* and relocation type of the next non-absolute */ /* halfword in the current blcok of relocation */ /* info. The current relocation block and the last */ /* halfword returned are maintained in static */ /* storage. Expanded_absolute relocation bits are */ /* also skipped over. get_relinfo_$init must be */ /* called prior to calling get_relinfo_ to initiate */ /* the sequential search through the specified block */ /* of relocation information. */ /* Output: word_offset, halfword_selector, relocation_code */ /* */ /**********************************************************************/ /* Initially coded by M. J. Spier on 24 August 1970 Completely re-written for efficiency by M. B. Weaver on 21 November 1972 */ /* modified Sept 1978 by David Spector to correct precision declarations */ declare type fixed bin; declare j fixed bin (19); declare i fixed bin (19) int static; declare nhwords fixed bin (19) aligned int static; declare bitcount fixed bin (24) int static; declare baseptr pointer int static; declare symb (0:15) char (8) aligned int static initial ("text ", "negtext ", "lnk18 ", "neglnk18", "lnk15 ", "def ", "symb ", "negsymb ", "int18 ", "int15 ", "selfrel ", "unused ", "unused ", "unused ", "exp_abs ", "escape "); declare (ap, argp) pointer; declare (addr, bin, divide, index, substr) builtin; declare relsection bit (bitcount) based (baseptr); declare 1 arg aligned based (ap), 2 offset fixed bin, 2 side char (3) aligned, 2 relinfo char (8) aligned; declare 1 word aligned based, 2 pad bit (35) unaligned, 2 odd bit (1) unaligned; /* */ ap = argp; /* copy argument */ loop: j = index (substr (relsection, i), "1"b); /* find next non-abs rel bit */ if j = 0 then do; /* no more rel bits for this section */ arg.relinfo = "overflow"; go to fill_loc; /* return location info of last call */ end; i = i + j + 4; /* set bit counter after current half word info */ /* find type of relocation */ type = bin (substr (relsection, i - 4, 4), 4); if type = 14 then do; /* have expanded absolute */ nhwords = nhwords + j + bin (substr (relsection, i, 10), 10) - 1; /* just skipping over */ /* determine number of half words to skip */ i = i + 10; /* skip bit counter 10 more in this case */ go to loop; /* don't have real relocation info yet */ end; else nhwords = nhwords + j; /* update half word count */ /* fill in return info */ arg.relinfo = symb (type); /* fill in type indicator */ fill_loc: if addr (nhwords) -> word.odd then arg.side = "lhe"; else arg.side = "rhe"; /* get word offset */ arg.offset = divide (nhwords - 1, 2, 17, 0); return; /* */ init: entry (rel_base); /**********************************************************************/ /* */ /* Name: get_relinfo_$init */ /* Input: rel_base */ /* Function: initializes a static pointer to the beginning of */ /* the string of relocation bits, saves the bitcount */ /* in static storage and sets the word position */ /* counter (nhwords) to zero and sets the bit string */ /* index (i) to the start of the bit string. */ /* Output: none */ /* */ /**********************************************************************/ declare rel_base pointer; declare 1 relinfo aligned based (rel_base), 2 decl_vers fixed bin, 2 n_bits fixed bin, 2 bits bit (0 refer (relinfo.n_bits)); /* initialize counters */ i = 1; /* current index into rel bit string */ nhwords = 0; /* # of half words covered so far */ bitcount = relinfo.n_bits; baseptr = addr (relinfo.bits); return; end get_relinfo_;  hash_defs_.pl1 11/20/86 1403.9r w 11/20/86 1145.0 136566 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation. END HISTORY COMMENTS */ /* HASH_DEFS - Program to Convert Object Segments for Definition Hashing. 12/2/76 by Noel I. Morris */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /**********************************************************************/ /* */ /* Name: hash_defs_ */ /* Input: component_table */ /* Function: given the component_table and associated insym */ /* tables, builds a definition_hash_table for the */ /* new bound object segment. Creation of the hash */ /* table occcurs in three stages: */ /* -- scanning of the definitions for duplicate */ /* definition names to create the duplicate */ /* tables, mark the duplicate definitions as */ /* duplicates, and to redefine the location of */ /* the definition to point to the duplicate */ /* table. */ /* -- hashing the non-duplicate symbols into the */ /* definition hash table. */ /* -- if there were duplicates in the definition */ /* hash table, hashing the segname definitions */ /* into the component hash table. */ /* Output: none */ /* */ /**********************************************************************/ /* format: style3,^indnoniterdo */ hash_defs_: proc; dcl (sp, sp1) ptr, /* pointers to insym entries */ ctep1 ptr, /* pointer to component table entry */ (ip, ip1) ptr, /* pointers to insym table entries */ (sytp, sgtp) ptr, /* pointers to seg/sym hash tables */ (symx, segx, cx, cx1, sx, sx1) fixed bin, /* table indices */ defrel bit (18) aligned, /* rel ptr to definition */ defp ptr, /* ITS pointer to definition */ namep ptr, /* pointer to symbol */ axtp ptr, /* pointer to auxiliary table */ axx fixed bin, /* aux table index */ dupn fixed bin, /* duplicate symbol counter */ htsize fixed bin (17); /* size of hash table */ dcl (addr, addrel, bin, bit, hbound, mod, substr, unspec) builtin; dcl 1 symht based aligned, /* def symbol hash table */ 2 size fixed bin, 2 table (0 refer (symht.size)), ( 3 defp bit (18), 3 pad bit (18) ) unal; dcl 1 seght based aligned, /* segment name def hash table */ 2 size fixed bin, 2 table (0 refer (seght.size)), ( 3 defp bit (18), 3 headp bit (18) ) unal; dcl 1 auxt based aligned, /* auxiliary symbol table */ 2 size fixed bin, 2 table (0 refer (auxt.size)), ( 3 defp bit (18), 3 headp bit (18) ) unal; dcl 1 accname based aligned, ( 2 lth fixed bin (8), 2 chr char (0 refer (accname.lth)) ) unal; dcl 1 bound_seg_comp aligned like comp auto; /* dummy comp table entry for bound segment */ dcl 1 bound_seg_seg aligned like seg auto; /* dummy seg table entry for bound segment */ dcl 1 symbol_table_is aligned like is auto; /* dummy is entry for symbol_table */ dcl 1 bind_map_is aligned like is auto; /* dummy insym entry for bind_map */ %include bindext; %include comptbl; %include bndtbl; %include insym; %include definition; /* first we generate a dummy component entry for the bound segment */ /* table as well as dummy insym entries for the bind map and symbol */ /* table. */ ctp = bx_$ctp; /* Get pointer to component table. */ unspec (bound_seg_comp) = "0"b; /* Prepare to make dummy comp table entry. */ defrel = bx_$tdefp -> definition.forward; /* Get rel ptr to seg def for bound segment. */ bound_seg_comp.defthread = bin (defrel, 18); /* Place in dummy comp table entry. */ unspec (bound_seg_seg) = "0"b; /* Prepare to make dummy segname table entry. */ bound_seg_seg.comp = addr (bound_seg_comp); defp = addrel (bx_$tdefp, defrel); /* Get pointer to definition. */ bound_seg_seg.defrel = defrel; namep = addrel (bx_$tdefp, defp -> definition.symbol); /* Get pointer to name. */ unspec (substr (bound_seg_seg.name, 1, namep -> accname.lth + 1)) = unspec (namep -> accname); bound_seg_seg.lng = namep -> accname.lth + 1; /* Copy the segment name. */ unspec (symbol_table_is) = "0"b; /* Prepare dummy insym entry for symbol_table. */ defrel = defp -> definition.forward; /* Get rel ptr to def for symbol_table. */ symbol_table_is.defrel = defrel; defp = addrel (bx_$tdefp, defrel); namep = addrel (bx_$tdefp, defp -> definition.symbol); unspec (substr (symbol_table_is.symbol, 1, namep -> accname.lth + 1)) = unspec (namep -> accname); symbol_table_is.lng = namep -> accname.lth + 1; /* Copy the symbol name. */ unspec (bind_map_is) = "0"b; /* Prepare dummy insym entry for bind_map. */ defrel = defp -> definition.forward; /* Get rel ptr to def for bind_map. */ bind_map_is.defrel = defrel; defp = addrel (bx_$tdefp, defrel); namep = addrel (bx_$tdefp, defp -> definition.symbol); unspec (substr (bind_map_is.symbol, 1, namep -> accname.lth + 1)) = unspec (namep -> accname); bind_map_is.lng = namep -> accname.lth + 1; /* Copy the symbol name. */ /* now we scan through the component table and check each insym */ /* to see if it is a duplicate. If it is a duplicate, then create */ /* a duplicate table for the symbol if necessary and then add the */ /* duplicate to the table. */ axtp = addrel (bx_$tdefp, bx_$curdeflng); /* Get pointer to end of defs. */ dupn = 0; /* Initialize duplicate counters. */ cx = 0; /* Start with zeroth component. */ ctep = addr (bound_seg_comp); /* Point to fake comp for bound segment. */ sp = addr (bind_map_is); /* Point to fake insym entry for bind_map. */ call dup_search; /* Search for duplicate name. */ sp = addr (symbol_table_is); /* Point to fake insym entry for symbol_table. */ call dup_search; /* Search for duplicate name. */ do cx = 1 to bx_$ncomp; /* Iterate through components. */ ctep = comp_tbl (cx); /* Get pointer to component table entry. */ ip = comp.insymentp; /* Get pointer to syms for this component. */ do sx = 1 to ip -> insym.n_insyms - 1; /* Look through the symbols. */ sp = addr (ip -> insym.entry (sx)); /* Get pointer to symbol table entry. */ if ^(sp -> is.ignore | sp -> is.delete | sp -> is.duplicate) then call dup_search; /* Search for duplicate name. */ end; end; /* now we take all of the definitions that are not duplicates and */ /* hash them into the definition has table. */ sytp = axtp; /* Get pointer for sym hash table. */ bx_$tdefp -> definition.value = bit (bx_$curdeflng); /* Set pointer to hash table. */ htsize = hlen (bx_$nsymdefs + 2); /* Compute size of hash table. */ sytp -> symht.size = htsize; /* Set size of hash table. */ sp = addr (bind_map_is); /* Point to fake insym entry for bind_map. */ call hash_sym; /* Make hash table entry for it. */ sp = addr (symbol_table_is); /* Point to fake insym entry for symbol_table. */ call hash_sym; /* Make hash table entry for it. */ do cx = 1 to bx_$ncomp; /* Through the components again. */ ctep = comp_tbl (cx); ip = comp.insymentp; do sx = 1 to ip -> insym.n_insyms - 1; /* Through the symbols again. */ sp = addr (ip -> insym.entry (sx)); if ^(sp -> is.ignore | sp -> is.delete | sp -> is.duplicate) then call hash_sym; /* Enter symbol in hash table, if desired. */ end; end; bx_$curdeflng = bx_$curdeflng + sytp -> symht.size + 1; /* Increase size of defs. */ /* if there were no duplicates, we return now, otherwise we create */ /* a component hash table from the segment name table. */ if dupn = 0 then /* If no duplicated names ... */ return; /* No need for seg name hash table. */ sgtp = addrel (bx_$tdefp, bx_$curdeflng); /* Get pointer to seg name hash table. */ htsize = hlen (bx_$nsegdefs + 1); /* Compute size of seg name hash table. */ sgtp -> seght.size = htsize; /* Fill in size of table. */ sp = addr (bound_seg_seg); /* Point to fake seg entry for bound segment. */ call hash_seg; /* Insert in hash table. */ sntp = bx_$sntp; /* Get pointer to segment name table. */ do sx = 1 to sntp -> snt.n_names; /* Go through the segment name table. */ sp = addr (sntp -> snt.entry (sx)); /* Get pointer to segment name table entry. */ if sp -> seg.defrel then /* If this is a real name ... */ call hash_seg; /* Insert seg name in hash table. */ end; bx_$curdeflng = bx_$curdeflng + sgtp -> seght.size + 1; /* Compute final size of defs. */ return; /* All finished. */ dup_search: proc; /**********************************************************************/ /* */ /* Name: dup_search */ /* Input: cx, sp */ /* Function: given a component table index (cx) and a pointer */ /* to an insym entry (sp), scan all of the later */ /* components insym lists for another definition */ /* with the same name. If duplicate definitions are */ /* found, create a duplicate table, add all of the */ /* duplicates to it, flag that the duplicates are */ /* duplicates, and change the rel_ptr in the insym */ /* for the original to point to the duplicate table */ /* rather than the definition itself. */ /* Output: duplicate table, dupn */ /* */ /**********************************************************************/ axx = 0; /* Initialize auxiliary table index. */ do cx1 = cx + 1 to bx_$ncomp; /* Look at the rest of the components. */ ctep1 = comp_tbl (cx1); ip1 = ctep1 -> comp.insymentp; do sx1 = 1 to ip1 -> insym.n_insyms - 1; sp1 = addr (ip1 -> insym.entry (sx1)); if ^(sp1 -> is.ignore | sp1 -> is.delete) then if substr (sp -> is.symbol, 1, sp -> is.lng) = substr (sp1 -> is.symbol, 1, sp1 -> is.lng) then do; if axx = 0 then do; /* If this is first occurrence of duplicate ... */ axx = 1; /* Initialize index. */ axtp -> auxt.defp (1) = sp -> is.defrel; /* Fill in first entry. */ axtp -> auxt.headp (1) = bit (bin (comp.defthread, 18)); sp -> is.defrel = bit (bx_$curdeflng, 18); end; /* Save rel ptr to aux table instead of def. */ axx = axx + 1; /* Step index. */ axtp -> auxt.defp (axx) = sp1 -> is.defrel; /* Fill in another entry. */ axtp -> auxt.headp (axx) = bit (bin (ctep1 -> comp.defthread, 18)); sp1 -> is.duplicate = "1"b; /* Indicate symbol was a duplicate. */ end; end; end; if axx ^= 0 then do; /* If we found a dup ... */ axtp -> auxt.size = axx; /* Fill in size of aux table. */ bx_$curdeflng = bx_$curdeflng + axx + 1; /* Increase length of defs. */ axtp = addrel (axtp, axx + 1); /* Get new aux table pointer. */ dupn = dupn + 1; /* Count another duplicated name. */ end; end dup_search; hash_sym: proc; /**********************************************************************/ /* */ /* Name: hash_sym */ /* Input: sp */ /* Function: inserts the relp for the specified definition */ /* into the definition hash table. The entry is */ /* inserted into the first empty slot at of after */ /* the index calculated by the hash function. */ /* Output: none */ /* */ /**********************************************************************/ namep = addr (sp -> is.symbol); /* Get pointer to first word of ACC string. */ symx = hash (); /* Hash the name. */ do while (sytp -> symht.defp (symx)); /* Find empty slot in hash table. */ symx = mod (symx, htsize) + 1; end; sytp -> symht.defp (symx) = sp -> is.defrel; /* Set pointer in hash table entry. */ end hash_sym; hash_seg: proc; /**********************************************************************/ /* */ /* Name: hash_seg */ /* Input: sp */ /* Function: given a pointer to an insym entry, inserts a relp */ /* for that definition into the first empty slot in */ /* the component hash table at of after the index */ /* generated by the hashing function. */ /* Output: none */ /* */ /**********************************************************************/ namep = addr (sp -> seg.name); segx = hash (); do while (sgtp -> seght.defp (segx)); /* Find an empty slot in the hash table. */ segx = mod (segx, htsize) + 1; end; sgtp -> seght.defp (segx) = sp -> seg.defrel; /* Set def pointer in hash table entry. */ ctep = sp -> seg.comp; /* Get address of component table entry. */ sgtp -> seght.headp (segx) = bit (bin (ctep -> comp.defthread, 18)); /* Set pointer to first segname def. */ end hash_seg; hash: proc returns (fixed bin); /**********************************************************************/ /* */ /* Name: hash */ /* Input: namep, htsize */ /* Function: given a pointer to an acc string, calculates the */ /* hash function on it and returns the index. The */ /* hash function used is the remainder of the first */ /* word of the acc string (count and first three */ /* characters) divided by the size of the hash table */ /* Output: hash_index */ /* */ /**********************************************************************/ dcl word fixed bin (35) based; /* first word of name */ return (mod (namep -> word, htsize) + 1); end hash; hlen: proc (s) returns (fixed bin); /**********************************************************************/ /* */ /* Name: hlen */ /* Input: s */ /* Function: given the number of definitions to be placed into */ /* a hash table, returns the size of the hash table */ /* The hash table is sized such that it is not more */ /* than 80% full. */ /* Output: htsize */ /* */ /**********************************************************************/ 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 20% 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; end;  incorporate_options_.pl1 08/06/86 1449.9rew 08/06/86 1419.4 96885 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Changed errname to use the caller-supplied name instead of "binder_", improved documentation, removed non-functional support for obsolete "indirect" keyword. "indirect" now functions the same as "retain". 2) change(86-07-02,Elhard), approve(86-07-02,MCR7281), audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119): Modified to improve error messages for multiple retain, delete, or no_link keywords given for a single input component. END HISTORY COMMENTS */ /**********************************************************************/ /* */ /* Name: incorporate_options_ */ /* Input: none */ /* Function: incorporates the options specified in the */ /* bindfile into the component table, (symbol length */ /* based on no_table specification), insym lists, */ /* (indirect, retain, delete, or nolink specified), */ /* and segname table, (synonym statements). checks */ /* are also made to insure that all the options are */ /* processed and that none of the segnames in the */ /* segname table match the bound objectname. Checks */ /* are also made to insure that all options are */ /* consistent. */ /* Output: none. */ /* */ /**********************************************************************/ /* format: style3,^indnoniterdo */ incorporate_options_: procedure; /* coded by Michael J. Spier 1970? */ /* modified 11/24/76 by M. Weaver to set comp.table_deleted */ /* Modified 01/14/81 W. Olin Sibert for new format of input structure */ /* Modified 85-02-11 by Dean Elhard to change errname to "bind" */ /* Modified 85-03-18 by Dean Elhard to clean up documentation and */ /* remove support for the indirect keyword. It */ /* now behaves exactly as retain. */ /* DECLARATION OF EXTERNAL SYMBOLS */ declare (com_err_, ioa_) external entry options (variable); /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, j, k, ndefs, nobjects) fixed bin; declare (p, inpp, areap, optp, ip, dp, sp) pointer; declare (g_nt, g_rt, g_in, g_dl, g_nl, op_sw, tab_sw) bit (1) aligned; declare opt_code char (1) aligned; declare (errname, str1, str3) char (32) aligned; declare str2 char (256) aligned; declare newname char (33) aligned; declare message char (256) varying; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, index, null, substr) builtin; /* DECLARATION OF BASED STRUCTURES */ declare reset bit (297) aligned based (p); declare acc_count bit (9) aligned based (p); /* */ ctp = bx_$ctp; inpp = bx_$inpp; sntp = bx_$sntp; areap = bx_$optp; if bx_$debug = 1 then errname = "incorporate_options_"; else errname = bx_$caller; addr (newname) -> reset = "0"b; /* make acc string of bound segname */ i = index (bx_$bound_segname, " "); if i = 0 then i = 32; else i = i - 1; addr (newname) -> acc_count = bit (bin (i, 9), 9); substr (newname, 2, i) = substr (bx_$bound_segname, 1, i); nobjects = bx_$ncomp; /* number of component objects */ if areap = null then goto check_bound_name; /* incorporate specified options into insym table */ g_nt, g_rt, g_in, g_dl, g_nl = "0"b; /* copy global options */ if option.g_delete = "d" then g_dl = "1"b; else if option.g_indirect = "i" then g_rt = "1"b; else if option.g_retain = "r" then g_rt = "1"b; else if option.g_nolink = "l" then do; g_rt, g_nl = "1"b; end; if option.g_notable = "t" then g_nt = "1"b; do i = 1 to nobjects; ctep = comp_tbl (i); if comp.ignore = 1 then goto next_object; ip = comp.insymentp; /* pointer to insym table of this component */ ndefs = ip -> insym.n_insyms - 1; /* number of defs to scan */ op_sw = "0"b; /* preset option flag */ optp = null; /* reset pointer to option structure */ tab_sw = "0"b; /* reset switch for keeping specific table */ if option.g_nolink = "l" then ip -> insym.global_nolink = "1"b; if inp.obj (i).option ^= "0"b then do; /* there is an option entry */ optp = addrel (areap, inp.obj (i).option); if op.n_options > op.n_synonyms then op_sw = "1"b; /* more than just synonyms */ if op.no_link = "l" then ip -> insym.global_nolink = "1"b; if op.table = "t" then do; /* want to keep table */ if comp.clngns = comp.clngss then call ioa_ ("Warning: ^a has no symbol table, which bindfile wanted kept.", comp.filename); else tab_sw = "1"b; /* do not delete this table */ end; end; if g_nt then if ^tab_sw then do; /* truncate any symbol table */ if comp.io_table ^= 0 then call ioa_ ( "Warning: symbol table not removed from ^a^/^-because it may be needed for data-directed I/O.", comp.filename); else do; if comp.clngns > comp.clngss then comp.table_deleted = 1; comp.clngns = comp.clngss; /* use the shorter length */ end; end; do j = 1 to ndefs; /* scan insym table */ dp = addr (ip -> insym.entry (j)); /* pointer to one definition */ if op_sw = "1"b then do k = 2 to op.n_options; /* lookup options */ p = addr (op.opes (k)); if p -> ope.symb ^= dp -> is.symbol then goto next_option; opt_code = p -> ope.code; if opt_code = "r" then dp -> is.retain = "1"b; else if opt_code = "i" then dp -> is.retain = "1"b; else if opt_code = "d" then dp -> is.delete = "1"b; else if opt_code = "l" then do; dp -> is.retain, dp -> is.no_link = "1"b; end; else goto next_option; /* skip synonyms */ p -> ope.code = "*"; /* indicate that entry has been processed */ goto next_def; next_option: end; if optp ^= null then do; /* use "global" options */ if op.delete = "d" then dp -> is.delete = "1"b; else if op.indirect = "i" then dp -> is.retain = "1"b; else if op.retain = "r" then dp -> is.retain = "1"b; else if op.no_link = "l" then do; dp -> is.retain, dp -> is.no_link = "1"b; end; else goto use_Global; end; else do; /* use "Global" options */ use_Global: dp -> is.retain = g_rt; dp -> is.delete = g_dl; dp -> is.no_link = g_nl; end; next_def: end; next_object: end; /* next process all synonyms */ ndefs = snt.n_names; /* size of segname table */ do i = 1 to nobjects; if inp.obj (i).option = "0"b then goto try_next; /* no option here */ optp = addrel (areap, inp.obj (i).option); /* pointer to option table */ if op.n_options = 0 then goto try_next; /* only global stuff */ p = addr (op.opes (1)); /* first string is the filename */ do j = 1 to snt.n_names; /* scan segname table */ if snt.entry (j).name = substr (p -> ope.symb, 1, 33) then goto filename_found; end; goto try_next; filename_found: ctep = snt.entry (j).comp; /* pointer to file's component entry */ op.opes (1).code = "*"; do k = 2 to op.n_options; /* now locate all synonyms for this file */ p = addr (op.opes (k)); if p -> ope.code ^= "s" then goto not_synonym; do j = 1 to ndefs; /* compare with all segnames in table */ sp = addr (snt.entry (j)); if sp -> seg.name = substr (p -> ope.symb, 1, 33) then do; if sp -> seg.comp = ctep then goto set_mark; /* already in table */ call com_err_ (0, errname, "segname ^a has been multiply declared in bindfile", substr (sp -> seg.name, 2, sp -> seg.lng - 1)); goto not_synonym; end; end; ndefs = ndefs + 1; sp = addr (snt.entry (ndefs)); /* pointer to segname table entry */ sp -> seg.name = p -> ope.symb; /* copy string */ sp -> seg.comp = ctep; /* remember pointer to component table entry */ sp -> seg.lng = p -> ope.lng; set_mark: p -> ope.code = "*"; /* indicate that entry was processed */ not_synonym: end; try_next: end; snt.n_names = ndefs; /* update size of segname table */ if ndefs > snt.max_size then do; call com_err_ (0, errname, "Segname table overflow; current limit = ^d.", snt.max_size); bx_$fatal_error = 1; end; /* Now check to see if all options were correctly processed */ do i = 1 to nobjects; if inp.obj (i).option ^= "0"b then do; optp = addrel (areap, inp.obj (i).option); if op.n_options = 0 then goto next_comp; p = addr (op.opes (1)); str3 = substr (p -> ope.symb, 2, p -> ope.lng - 1); do j = 1 to op.n_options; p = addr (op.opes (j)); if p -> ope.code ^= "*" then do; message = "'^a: ^a;' of bind-file entry ^a:^/Only one the 'retain', 'delete', or 'no_link', keywords may be specified." ; opt_code = p -> ope.code; str2 = substr (p -> ope.symb, 2, p -> ope.lng - 1); if opt_code = "r" then str1 = "retain"; else if opt_code = "i" then str1 = "indirect"; else if opt_code = "d" then str1 = "delete"; else if opt_code = "l" then str1 = "no_link"; else if opt_code = "s" then do; if j = 1 then str1 = "objectname"; else str1 = "synonym"; message = "'^a: ^a;' of bind-file entry ^a could not be processed"; end; else str1 = "'" || opt_code || "'"; call com_err_ (0, errname, message, str1, str2, str3); bx_$fatal_error = 1; end; end; end; next_comp: end; check_bound_name: do i = 1 to snt.n_names; /* rescan segname table */ p = addr (snt.entry (i)); if p -> seg.name = newname then do; if areap ^= null then /* have a bindfile */ call com_err_ (0, errname, "segname ^a has been multiply declared in bindfile", bx_$bound_segname); else call com_err_ (0, errname, "segname ^a has been multiply declared", bx_$bound_segname); bx_$fatal_error = 1; end; end; %page; %include bindext; %page; %include comptbl; %page; %include bndtbl; %page; %include insym; %page; %include binder_input; %page; %include option; end incorporate_options_;  int_link_.pl1 07/16/86 1217.0rew 07/16/86 0846.4 191628 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation, removed red/black shifts, changed errname to use the caller-supplied name instead of "binder_", removed obsolete nonstandard object support, modified to update the link_regeneration_table with a flag ("777777"b3) to indicate internal link resolution. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /**********************************************************************/ /* */ /* Name: int_link_ */ /* Input: argument_pointer */ /* Function: given a pointer to an external_ref structure */ /* (argument_pointer), determine whether the target */ /* of the reference is in a component of the bound */ /* object segment and perform the pre-linking. The */ /* determination is done in the following manner: */ /* -- if the dont_prelink flag is on in the */ /* external_ref structure, just return since */ /* this must remain external. */ /* -- for type 3, 4, 5, or 6 links, determine */ /* whether the entryname is in the segname */ /* table (type 1 have no segname, they are */ /* self-references). If the component is not */ /* found an external link must be regenerated. */ /* -- for type 4, 5, or 6 links, scan the insym */ /* list for the target component to find the */ /* target definition (type 1 and 3 links do not */ /* refer to a definition but to the base of a */ /* section/component). If the definition is not */ /* found, display a message indicating that the */ /* target could not be found and enter the name */ /* into the oddname table to prevent duplicate */ /* messages. */ /* -- if the reference is a type 1 or type 5 ref */ /* to the static section and we have a separate */ /* static section, generate an external link */ /* since we don't know where the static section */ /* will be. */ /* -- if the reference is a type 1 reference to */ /* the static section, relocate the reference, */ /* adjust the instruction, and return. */ /* -- if the reference is a type 1 link to the */ /* text section, relocate it, patch the */ /* instruction and return. */ /* -- if the reference is a type 1 link to a */ /* different section, create a repatch table */ /* entry for it to be filled in later since we */ /* don't know where the other stuff will be, */ /* patch the instruction and return. */ /* -- if the target of the link is to the static */ /* section of another component, we transform */ /* the link into a type 1 link to *static by */ /* adjusting the external_ref structure and */ /* then returning so that the call to ext_link_ */ /* will generate the type 1 link. */ /* -- if the link has an indirect modifier, and */ /* the compiler is "PASCAL", and the target of */ /* the link refers to the linkage section, then */ /* we have an indirect reference to a link in */ /* another component. This is resolved by */ /* removing the indirection and changing the */ /* instruction to refer directly to the target */ /* link. We then call int_link_ recursively */ /* to try to resolve that link internally. If */ /* that fails, we call ext_link_ to generate */ /* it externally. */ /* -- if the links has a modifier and the */ /* instruction has other than a simple */ /* indirection modifier, then generate an */ /* external link and print a message indicating */ /* that this link cannot be resolved internally */ /* -- now the link is resolved depending on the */ /* target section of the referenced definition. */ /* The following procedures are used for the */ /* different sections: */ /* -- Text section */ /* The definition value is relocated, the */ /* instruction word is patched, and the */ /* modifier from the link is copied into */ /* the instruction. */ /* -- Linkage section */ /* If the reference is within the static */ /* storage portion of the linkage section, */ /* (ie. an ALM segdef), the definition */ /* value is relocated, the instruction */ /* word is patched, and the modifier from */ /* the link copied into the instruction */ /* modifier. Otherwise an error message */ /* is printed indicating that an illegal */ /* sequence into the linkage section was */ /* found. */ /* -- Symbol section */ /* The symbol relocation is calculated and */ /* a repatch table entry for the halfword */ /* is generated and the instruction is */ /* patched and the modifier copied. */ /* -- Static section */ /* Since by this point we know we are not */ /* creating a separate static section, we */ /* adjust the static section reference for */ /* the linkage header, and then treat as a */ /* segdef in the linkage section. */ /* Output: none */ /* */ /**********************************************************************/ /* Designed and initially coded by Michael J. Spier, October 6, 1970 */ /* modified June, July 1975 by M. Weaver for separate static */ /* modified 9/78 by David Spector for hash coding "snt" */ /* modified Dec 78 by David Spector to make repatch table automatically extensible */ /* modified Oct 80 by JMAthane to allow relocation of reference to PASCAL REF variables and internal text references through link section */ /* modified October 1983 by Melanie Weaver to fix *text relocation and add error message to above */ int_link_: procedure (argument_pointer, result); declare argument_pointer pointer, result bit (1) aligned; /* DECLARATION OF EXTERNAL SYMBOLS */ declare com_err_ external entry options (variable); declare ioa_ external entry options (variable); declare temp_mgr_$allocate ext entry (fixed bin); declare temp_mgr_$reserve ext entry (ptr); dcl ext_link_ entry (ptr); dcl decode_link_ entry (ptr) returns (bit (1)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare (text_relocation, symbol_relocation) fixed bin internal static; declare errname char (16) aligned internal static; declare internally_resolved bit (18) static options (constant) init ("777777"b3); /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, val, type, ndefs, class, toffset, value, expression, link_modifier, int_limit) fixed bin (18); declare hash_index fixed bin (34); declare hash_ptr ptr; declare pos fixed bin; declare wnpt fixed bin; declare lrt_index fixed bin; declare force_retain bit (1) aligned; declare (p, refp, ap, ip, dp, targp) pointer; declare modp pointer; declare string char (33) aligned; declare wsegname char (32) aligned; declare wentryname char (256) aligned; declare oddname char (65) aligned; declare estring char (257) aligned based (addr (ebit)); declare ebit bit (2340) aligned init ("0"b); /* will be acc string */ dcl my_result bit (1) aligned; dcl 1 my_ext aligned like external_ref; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, fixed, hbound, min, mod, null, rel, substr, unspec) builtin; declare size builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 ext aligned based (ap) like external_ref; declare 1 insyme aligned based (dp) like is; declare 1 word aligned based, 2 lhe18 bit (18) unaligned, 2 rhe18 bit (18) unaligned; declare 1 instr aligned based, 2 dum1 bit (3) unaligned, 2 lhe15 bit (15) unaligned, 2 op_code bit (9) unaligned, 2 dum2 bit (2) unaligned, 2 bit29 bit (1) unaligned, 2 modifier bit (6) unaligned; declare 1 modifier_overlay aligned based (modp), 2 dum bit (30) unaligned, 2 tm bit (2) unaligned, 2 td bit (4) unaligned; declare 1 b5 aligned based (p), 2 dum bit (21) unaligned, 2 rhe15 bit (15) unaligned; /* */ %include extref; /* */ %include bindext; /* */ %include comptbl; /* */ %include bndtbl; /* */ %include insym; /* */ ctp = bx_$ctp; sntp = bx_$sntp; ap = argument_pointer; /* copy argument into stack */ result = "0"b; /* preset return argument */ if ext.dont_prelink = "1"b then return; /* ******* */ p = ext.compent_ptr -> comp.insymentp; /* pointer to referencing object's definitions */ force_retain = "0"b; if p -> insym.global_nolink = "1"b then force_retain = "1"b; /* retain referenced entry for nolink */ wsegname = substr (ext.segname, 2, ext.slng - 1); if ext.elng > 1 then wentryname = substr (ext.entryname, 2, ext.elng - 1); /* copy ACC strings into regular format */ else wentryname = " "; /* there is no entryname */ refp = ext.ref_ptr; /* copy into stack for efficiency */ ctep = ext.compent_ptr; /* copy pointer to referencing component's entry */ lrtp = comp.clrtp; lrt_index = ((ext.loffset - lrt.start_offset) * 0.5) + 1; link_modifier = 0; modp = addr (link_modifier); modifier_overlay.tm = ext.link_tm; /* get modifier of original ext.link */ modifier_overlay.td = ext.link_td; /* ... */ val = 0; /* reset conversion variable */ type = fixed (ext.type, 18); if type = 1 then go to have_target; /* it's an internal type-1 link */ string = ext.segname; /* copy ext.segname for efficiency */ /* Perform hash-coded lookup of snt. */ /* Hash-code the string (segname to be found) */ hash_index = 0; do pos = 1 to min (ext.slng, 24); /* prevent overflow of hash_index */ hash_index = 2 * hash_index + bin (unspec (substr (string, pos, 1)), 9); end; hash_index = mod (hash_index, hbound (snt.hash_table, 1) + 1); /* Do linear search of this hash-code "bucket" (chain of entries) for entry having segname=string. */ do hash_ptr = snt.hash_table (hash_index) repeat hash_ptr -> seg.hash_thread while (hash_ptr ^= null); /* search chain of links */ if hash_ptr -> seg.name = string then goto segname_found; /* success */ end; goto return; /* failure */ segname_found: substr (estring, 1, ext.elng) = substr (ext.entryname, 1, ext.elng); /* copy def for efficiency; remove substr when all names are 257 */ targp = hash_ptr -> seg.comp; /* pointer to referenced component's entry */ int_limit = targp -> comp.clngi + 8; /* scope of internal static */ text_relocation = targp -> comp.crelt; /* relocation counter for target component */ symbol_relocation = targp -> comp.crels; /* ... */ ip = targp -> comp.insymentp; /* pointer to component's definitions */ if ip -> insym.global_nolink = "1"b then goto return; /* target component not to be prelinked */ ndefs = ip -> insym.n_insyms; /* get number of defs for this component */ if (type = 6 & ext.elng = 1) then go to null_ent; /* treat like type 3 */ if type = 3 then /* its a segname|expresiion,m link */ do; null_ent: dp = addr (ip -> insym.entry (ndefs)); /* entry for null-name is the last */ goto definition_found; end; /* its a type-4 or type-5 segname|entryname+expression,m link */ else do i = 1 to ndefs - 1; /* scan definitions */ dp = addr (ip -> insym.entry (i)); /* pointer to a definition entry */ if estring = insyme.symbol then goto definition_found; end; oddname = wsegname; substr (oddname, ext.slng, 1) = "$"; substr (oddname, ext.slng + 1, ext.elng - 1) = wentryname; odnp = bx_$odnp; do i = 1 to od.n_odds; /* lookup oddname table */ if oddname = od.entry (i).name then goto return; /* message already printed */ end; if type = 5 then do; result = "1"b; /* this is an internal link by definition */ lrt.regenerated (lrt_index) = internally_resolved; i = fixed (ext.code15, 18); if i = 0 then wsegname = "*text"; else if i = 1 then wsegname = "*link"; else if i = 2 then wsegname = "*symbol"; else if i = 4 then wsegname = "*static"; call com_err_ (0, errname, "cannot locate ^a|^a for file ^a", wsegname, wentryname, comp.filename); bx_$fatal_error = 1; end; else call ioa_ ("Warning: cannot match symbol ^a; external link generated.", oddname); if i = od.max_size then do; od.n_odds = i + 1; call com_err_ (0, errname, "oddname table overflow; please notify maintenance."); goto return; end; od.entry (i).name = oddname; /* make new entry */ od.n_odds = i; goto return; definition_found: if insyme.no_link = "1"b then goto return; /* this symbol must not be prelinked to */ if force_retain = "1"b then do; insyme.delete = "0"b; /* retain symbol referenced by nolink component */ insyme.retain = "1"b; end; have_target: expression = fixed (ext.expr, 18); /* get expression from link */ if substr (ext.expr, 1, 1) then expression = -fixed (^ext.expr, 18) - 1; if type = 1 | type = 5 then do; /* check for *static */ if bin (ext.code15, 18) = 4 then do; /* *static */ if bx_$bound_sep_stat = 1 then return; /* addr of static not known */ /* the following treatment of *static links is inconsistent in that they are relocated whereas *link links are not */ if type = 1 then do; /* must change to internal reference to static in linkage */ value = 8; /* must adjust for linkage header */ targp = ctep; /* selfreference */ result = "1"b; lrt.regenerated (lrt_index) = internally_resolved; go to segdef_in_linkage; end; end; end; if type = 1 then /* internal link relative to sections */ do; result = "1"b; /* this is an internal reference */ lrt.regenerated (lrt_index) = internally_resolved; if wsegname = "*text" then toffset = comp.crelt; /* all type-1 links relative to base of section */ else do; /* reference to linkage and symbol must be done in two steps */ call create_rpt_entry; /* wnpt = index of repatch table entry */ rptep = addr (rpt.entry (wnpt)); rpte.halfword = ext.side; rpte.poffset = rel (refp); /* remember referencing instruction */ rpte.pbase = "t"; /* relative to text section */ rpte.pexpr = "0"b; /* no expression value */ toffset = 0; /* type-1 links refer to base of section */ if wsegname = "*link" then /* self reference to linkage section */ rpte.code = "l"; else if wsegname = "*symbol" then /* self reference to symbol section */ rpte.code = "s"; else call ioa_ ("int_link_: programming error 1;name=^a", wsegname); end; toffset = toffset + expression; /* put new address in referencing instruction */ refp -> word.lhe18 = addr (toffset) -> word.rhe18; goto patch_modifier; end; class = fixed (insyme.class, 18); /* get class of entrypoint */ /* can't prelink to separate static */ value = fixed (insyme.value, 18); /* get value */ if class = 4 then if bx_$bound_sep_stat = 1 then do; /* Transform a link to another component's static to a type 1 link to *static. To do this we change the info in ext so that ext_link_ will generate the right link. */ if type = 6 then ext.trap = "0"b; /* target won't need to be created */ ext.type = bit (bin (1, 18), 18); ext.code15 = bit (bin (4, 18), 18); ext.expr = bit (bin (value + targp -> comp.creli + expression, 18), 18); /* keep segname and entryname for messages and to distinguish diddled structure */ go to return; end; if link_modifier ^= 0 then do; /* the original link had a modifier in it */ if comp.compiler = "PASCAL " then do; if link_modifier = 16 then do; /* 20 octal (indirect) */ if class = 1 then do; /* This link indirects through another link. We now want to resolve the reference directly to the other link (or to its target, if internal). We do this by pretending that the reference is actually to the other link. */ refp -> instr.lhe15 = addr (value) -> rhe15; my_ext.ref_ptr = ext.ref_ptr; my_ext.compent_ptr = targp; my_ext.loffset = value; if decode_link_ (addr (my_ext)) = "1"b then do; call com_err_ (0, errname, "Cannot regenerate target link of indirect link ^a|^a,*", wsegname, wentryname); bx_$fatal_error = 1; return; end; call int_link_ (addr (my_ext), my_result); if my_result = "0"b then call ext_link_ (addr (my_ext)); end; else if class = 4 then do; value = value + targp -> comp.creli + 8; refp -> instr.lhe15 = addr (value) -> rhe15; end; result = "1"b; lrt.regenerated (lrt_index) = internally_resolved; return; end; end; if refp -> modifier_overlay.td ^= "0000"b then /* the referencing instruction has a modifier as well */ do; call ioa_ ("Warning: Modifier at ^a|^o cannot be handled by binder; external link generated.", comp.filename, ext.offset); insyme.delete = "0"b; /* make sure def gets regenerated */ insyme.retain = "1"b; goto return; end; end; result = "1"b; /* this is an internal link */ lrt.regenerated (lrt_index) = internally_resolved; if class = 0 then do; toffset = text_relocation + value + expression; goto update_reference; end; if class = 1 then do; p = targp -> comp.clnkp; /* pointer to base of target's old linkage section */ p = addrel (p, value); /* pointer to symbol's entry sequence in linkage section */ if (refp -> modifier_overlay.tm = "11"b) | (value < int_limit) then /* an ALM segdef */ do; segdef_in_linkage: val = value + targp -> comp.creli + expression; /* compute new address of internal static */ refp -> instr.lhe15 = addr (val) -> rhe15; /* and store in referencing instruction */ if link_modifier = 0 then refp -> modifier_overlay.tm = "00"b; else refp -> instr.modifier = bit (bin (link_modifier, 6), 6); if type ^= 1 then insyme.snapped = "1"b; /* dp not defined for type 1 */ goto return; end; illegal_entry: call com_err_ (0, errname, "illegal ^a entry sequence in link|^o for ^a$^a", targp -> comp.compiler, value, targp -> comp.filename, wentryname); bx_$fatal_error = 1; goto return; end; if class = 2 then do; toffset = symbol_relocation + value + expression; call create_rpt_entry; /* wnpt = index of repatch table entry */ rpt.entry (wnpt).halfword = ext.side; rpt.entry (wnpt).poffset = rel (refp); /* remember to finish relocation later */ rpt.entry (wnpt).pbase = "t"; /* relative to text section */ rpt.entry (wnpt).pexpr = "0"b; /* no expression value */ rpt.entry (wnpt).code = "s"; goto update_reference; end; if class = 4 then do; /* in static, but will be combined */ value = value + 8; /* must account for linkage header */ go to segdef_in_linkage; end; call com_err_ (0, errname, "internal entrypoint ^a in file ^a has unrecognized class ^o", wentryname, targp -> comp.filename, class); bx_$fatal_error = 1; goto return; update_reference: /* put new address in referencing instruction */ refp -> word.lhe18 = addr (toffset) -> word.rhe18; insyme.snapped = "1"b; patch_modifier: refp -> instr.bit29 = "0"b; if link_modifier = 0 then refp -> modifier_overlay.tm = "00"b; /* remove indirection */ else refp -> instr.modifier = bit (bin (link_modifier, 6), 6); /* copy modifier from original link */ goto return; illegal_reference: call com_err_ (0, errname, "illegal ^a external reference in ^a|^o", comp.compiler, comp.filename, ext.offset); bx_$fatal_error = 1; return: return; init: entry; if bx_$debug = 1 then errname = "int_link_"; else errname = bx_$caller; return; create_rpt_entry: procedure; /* wnpt = index of new repatch table entry */ rptp = bx_$last_rptp; wnpt, rpt.npt = rpt.npt + 1; if wnpt = hbound (rpt.entry, 1) then do; /* allocate new chunk of repatch table */ call temp_mgr_$allocate (size (rpt)); rpt.thread = bx_$freep; rptp = bx_$freep; bx_$last_rptp = rptp; rpt.thread = p; call temp_mgr_$reserve (addrel (rptp, size (rpt))); rpt.thread = null; rpt.npt = 0; end; end; end; /* End of int_link_ */  make_bindmap_.pl1 07/16/86 1217.0rew 07/16/86 0846.5 65790 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation, and force source_map onto a doubleword boundary. END HISTORY COMMENTS */ /**********************************************************************/ /* */ /* Name: make_bindmap_ */ /* Input: none */ /* Function: Creates the source map, setting the pointer to it */ /* in the symbol header, and creates the bindmap, */ /* setting the area_pointer in the symbol header to */ /* point to it. */ /* Output: none */ /* */ /**********************************************************************/ /* Coded sometime in 1972, by Melanie Weaver, as an adaptation of what is now called old_make_bindmap_ */ /* Modified 01/14/81 W. Olin Sibert for new format of input structure */ /* Modified 11/14/84 by M. Sharpe to forget non-standard objects ever existed */ /* format: style3,^indnoniterdo */ make_bindmap_: procedure; /* DECLARATION OF EXTERNAL SYMBOLS */ declare date_time_ entry (fixed bin (71), char (*) aligned); declare get_group_id_ entry () returns (char (32) aligned); /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, lng, val, ncomp) fixed bin; declare block_offset fixed bin (18); declare (p, bmp, sblkp, inpp, smp) pointer; declare w_string1 char (32) aligned; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, divide, fixed, index, length, rel, rtrim, substr) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 block_offset_overlay aligned based (addr (block_offset)), 2 dum bit (35) unaligned, 2 odd bit (1) unaligned; declare 1 source_map aligned based (smp), /* declaration of standard source map */ 2 decl_vers fixed bin, 2 size fixed bin, /* number of source segments */ 2 map (size) aligned, /* one for each input and update archive */ 3 pathname_offset bit (18) unaligned, 3 pathname_length bit (18) unaligned, 3 uid bit (36) aligned, /* uid of the source segment */ 3 dtm fixed bin (71); /* last date/time modified of source */ %page; ctp = bx_$ctp; inpp = bx_$inpp; sblkp = bx_$bsymp; block_offset = bx_$s_lng; /* this part of binder's block is at end */ w_string1 = get_group_id_ (); /* get user id for symbol header */ lng = index (w_string1, " ") - 1; /* get relevant length of user id */ if lng = -1 then lng = 32; /* generate userid string */ call gen_string (addr (sb.uid_offset), substr (w_string1, 1, lng)); /* generate source map */ ncomp = inp.ntotal; /* list both input and update archives */ if block_offset_overlay.odd then block_offset = block_offset + 1; /* align source map on an even boundary */ smp = addrel (sblkp, block_offset); /* get address of source map */ sb.source_map = bit (bin (block_offset, 18), 18); /* allocate map area */ block_offset = block_offset + (ncomp * 4) + 2; source_map.decl_vers = 1; source_map.size = ncomp; do i = 1 to ncomp; /* fill in info for each archive */ call gen_string (addr (source_map.map (i).pathname_offset), rtrim (inp.archive (i).real_path)); source_map.map (i).uid = inp.archive (i).uid; source_map.map (i).dtm = inp.archive (i).dtm; end; if block_offset_overlay.odd then block_offset = block_offset + 1; /* start bindmap of even word boundary */ /* generate bind map proper */ bmp = addrel (sblkp, block_offset); /* pointer to bindmap structure */ bindmap.dcl_version = 2; /* constant '2' to identify structure used */ /* and remember relpointer */ sb.area_ptr = bit (bin (block_offset, 18), 18); ncomp = inp.nobj; /* number of bound objects */ p = addr (bindmap.component (ncomp + 1)); /* compute size of structure */ val = fixed (rel (p), 18) - fixed (rel (bmp), 18) + 13; block_offset = block_offset + val; /* grow symbol block */ n_components = ncomp; /* put size in bindmap */ do i = 1 to ncomp; /* generate bindmap */ ctep = comp_tbl (i); /* pointer to component's entry */ call gen_string (addr (component (i).name), substr (comp.filename, 1, comp.fn_lng)); component (i).comp_name = comp.compiler; component (i).text_start = bit (bin (comp.crelt, 18), 18); component (i).text_lng = bit (bin ((comp.clngt + comp.cpadt), 18), 18); component (i).stat_start = bit (bin (comp.creli, 18), 18); component (i).stat_lng = bit (bin ((comp.clngi + comp.cpadi), 18), 18); component (i).symb_start = bit (bin (comp.crels, 18), 18); component (i).defblock_ptr = bit (bin (comp.defthread, 18), 18); component (i).symb_lng = bit (bin ((comp.clngns + comp.cpads), 18), 18); component (i).n_blocks = bit (bin (comp.n_sym_blks, 18), 18); end; call gen_string (addr (bindmap.bf_name), rtrim (inp.bindfile_name)); call date_time_ (inp.bindfile_time_up, bindmap.bf_date_up); call date_time_ (inp.bindfile_time_mod, bindmap.bf_date_mod); /* make block offset even */ if block_offset_overlay.odd then block_offset = block_offset + 1; block_size = bit (bin (block_offset - bin (sb.uid_offset, 18) + bin (sb.next_block, 18), 18), 18); /* set size of symbol block */ bx_$s_lng = block_offset; /* update length of symbol section */ return; gen_string: procedure (stringpointer, string); /**********************************************************************/ /* */ /* Name: gen_string */ /* Input: stringpointer, string */ /* Function: given a string and a pointer to a symbol table */ /* string reference (18 bit relp and 18 bit length), */ /* allocate the space for the string at the end of */ /* the symbol section, and set the relp and length. */ /* Output: none */ /* */ /**********************************************************************/ declare stringpointer pointer, string char (*); declare p pointer; declare (lng, delta) fixed bin; declare 1 sp aligned based (stringpointer), 2 relp bit (18) unaligned, 2 n_chars bit (18) unaligned; declare newstring char (10000) aligned based (p); lng = length (string); /* get length of new string */ n_chars = bit (bin (lng, 18), 18); /* and store in strinpointer */ relp = bit (bin (block_offset, 18), 18); /* store relpointer to string */ p = addrel (sblkp, block_offset); /* ITS pointer to string */ delta = divide (lng + 3, 4, 17, 0); /* compute block increment */ substr (newstring, 1, delta * 4) = string; block_offset = block_offset + delta; end gen_string; %page; %include bindext; %page; %include comptbl; %page; %include binder_input; %page; %include symbol_block; %page; %include bind_map; end make_bindmap_;  make_bound_object_map_.pl1 07/16/86 1217.0rew 07/16/86 0846.6 32706 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and removed obsolete nonstandard object support. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ make_bound_object_map_: proc (code); /**********************************************************************/ /* */ /* Name: make_bound_object_map_ */ /* Input: none */ /* Function: builds the bound segment's object map, sets the */ /* object map relp at the end of the object segment, */ /* and calculates the bit count for the new bound */ /* object segment. */ /* Output: error_code */ /* */ /**********************************************************************/ /* modified 75.06.20 by M. Weaver to create version 2 map */ /* modified 77/08/16 by M. Weaver to add perprocess_static switch */ declare maprel fixed bin (18); declare max_length fixed bin (19); declare code fixed bin (35); declare error_table_$boundviol fixed bin (35) external; declare hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); declare (addrel, bin, bit, ptr, multiply, rel, size) builtin; declare (obj_mapp, seg_ptr) pointer; declare 01 obj_map aligned like object_map based (obj_mapp); %include bindext; /* */ %include object_map; /* */ seg_ptr = bx_$temp_bsegp; /* Get pointer to base of object segment. */ call hcs_$get_max_length_seg (seg_ptr, max_length, code); if code ^= 0 then return; /* Get maximum number of words object segment may grow. */ /* get current object length */ maprel = bin (rel (bx_$bsymp), 18) + bx_$s_lng; if (maprel + size (object_map) + 1) > max_length then do; code = error_table_$boundviol; /* no room for map */ return; end; obj_mapp = ptr (seg_ptr, maprel); /* make ptr to map */ obj_map.decl_vers = object_map_version_2; obj_map.identifier = "obj_map"; obj_map.text_offset = "0"b; obj_map.text_length = bit (bin (bx_$textlng, 18), 18); obj_map.definition_offset = rel (bx_$bdefp); obj_map.definition_length = bit (bin (bx_$d_lng, 18), 18); obj_map.linkage_offset = rel (bx_$blnkp); obj_map.linkage_length = bit (bin (bx_$l_lng, 18), 18); obj_map.static_offset = rel (bx_$bstatp); obj_map.static_length = bit (bin (bx_$i_lng, 18), 18); obj_map.symbol_offset = rel (bx_$bsymp); obj_map.symbol_length = bit (bin (bx_$s_lng, 18), 18); obj_map.break_map_offset, obj_map.break_map_length = "0"b; obj_map.format.bound, obj_map.format.standard = "1"b; if bx_$bproc = 1 then obj_map.format.procedure = "1"b; if bx_$bound_sep_stat = 1 then obj_map.format.separate_static = "1"b; if bx_$perprocess_static = 1 then obj_map.format.perprocess_static = "1"b; addrel (obj_mapp, size (object_map)) -> map_ptr = bit (bin (maprel, 18), 18); /* fill in rel ptr to beg of obj map */ bx_$bseg_bitcount = multiply ((maprel + size (object_map) + 1), 36, 24, 0); code = 0; return; end make_bound_object_map_;  make_defs_.pl1 11/20/86 1403.9r w 11/20/86 1145.0 112329 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and readablilty, changed errname to use caller supplied name instead of "binder_". END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Designed and initially coded by Michael J. Spier, October 6, 1970 */ /* Modified Sept 1978 by David Spector for hash-coding strm */ make_defs_: procedure; /* DECLARATION OF EXTERNAL SYMBOLS */ declare com_err_ external entry options (variable); declare generate_def_ external entry (pointer, pointer); declare hash_defs_ external entry; declare strm_hash_$make_entry external entry (char (*), fixed bin (17)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare (defbase, linkbase, last_def, last_segname) pointer internal static; declare errname char (16) aligned internal static; declare last_def_rel fixed bin aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, j, ndefs) fixed bin; declare (ip, sp) pointer; declare (defblock_head, segblock_head, rel_ptr) fixed bin aligned; declare temp_name char (32) varying; declare newignore bit (1) aligned; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, divide, fixed, length, null, rtrim, substr) builtin; /* DECLARATION OF BASED VARIABLES */ declare acc_string_overlay char (acc_string.count + 1) based (acc_string_ptr); declare 01 last_definition aligned like definition based (last_def); /* */ %include bindext; /* */ %include comptbl; /* */ %include bndtbl; /* */ %include insym; /* */ %include definition_dcls; /* */ open_section: entry; /**********************************************************************/ /* */ /* Name: make_defs_$open_section */ /* Input: none */ /* Function: initializes the definition section of the new */ /* bound object segment and creates the standard */ /* definitions for the bound segment. */ /* Output: none */ /* */ /**********************************************************************/ ctp = bx_$ctp; strmp = bx_$strmp; errname = bx_$caller; if bx_$debug = 1 then errname = "make_defs_"; last_def, defbase = bx_$tdefp; /* pointer to base of new definition section */ linkbase = bx_$tlinkp; /* pointer to base of new linkage section */ newignore = "0"b; /* defs by this entry not ignored */ /* generate dummy def for standard object */ def_ptr = defbase; definition.forward_relp = 2; definition.flags.new = "1"b; definition.flags.ignore = "1"b; bx_$curdeflng = 2; /* adjust for dummy def */ last_def = addrel (last_def, 2); /* have reinitialized everything necessary */ /* Make a definition block for the new bound segment itself */ last_segname = null; /* indicate initialization */ last_def_rel, /* initialize threads */ segblock_head = bx_$curdeflng; temp_name = rtrim (bx_$bound_segname); call fabricate_def (temp_name, CLASS_SEGNAME, 0); last_definition.segname_relp, /* pointer to def block */ last_definition.forward_relp = bx_$curdeflng; last_segname = last_def; /* remember segname thread */ call fabricate_def ("symbol_table", CLASS_SYMBOL, 0); /* fabricate definitions for bound segment */ call fabricate_def ("bind_map", CLASS_SYMBOL, 0); bx_$bindmap_def = last_def; /* remember pointer to bindmap definition */ bx_$curdeflng = bx_$curdeflng + 1; /* grow def section for the zero word */ return; close_section: entry; /**********************************************************************/ /* */ /* Name: make_defs_$close_section */ /* Input: none */ /* Function: generates and threads in segname definitions for */ /* definition blocks which have retained definitions */ /* terminates the threads, and generates the hash */ /* table */ /* Output: none */ /* */ /**********************************************************************/ ctp = bx_$ctp; sntp = bx_$sntp; strmp = bx_$strmp; do i = 1 to bx_$ncomp; /* scan all component segments */ ctep = comp_tbl (i); /* pointer to component entry */ /* rel pointer to head of def list */ defblock_head = fixed (comp.defblockp, 18); if defblock_head ^= 0 then do; call check_ignore (); /* if defblock ignored, ignore segnames */ /* remember pointer to first segname */ segblock_head = bx_$curdeflng; /* remember defblock head */ comp.defthread = bx_$curdeflng; do j = 1 to snt.n_names; /* scan segname table */ sp = addr (snt.entry (j)); /* pointer to segname entry */ if sp -> seg.comp = ctep /* this is same component */ then do; temp_name = substr (sp -> seg.name, 2, sp -> seg.lng - 1); call fabricate_def (temp_name, CLASS_SEGNAME, 0); if ^newignore then do; bx_$nsegdefs = bx_$nsegdefs + 1; /* Save rel_ptr to new def. */ sp -> seg.defrel = bit (bin (rel_ptr, 18), 18); end; end; end; /* pointer to current regular def */ def_ptr = addrel (defbase, defblock_head); /* thread blocks together, forwards ... */ last_definition.forward_relp = defblock_head; /* and backwards */ definition.backward_relp = last_def_rel; gen_blockpointer: definition.segname_relp = segblock_head;/* pointer to segblock block */ if definition.forward_relp ^= 0 then do; /* follow thread */ def_ptr = addrel (defbase, definition.forward_relp); goto gen_blockpointer; end; /* end of list */ last_def_rel = fixed (comp.current_def, 18); last_def = addrel (defbase, last_def_rel); end; end; last_segname -> definition.thing_relp, /* last thread points to zero word */ last_definition.forward_relp, addrel (defbase, 2) -> definition.backward_relp = bx_$curdeflng; if last_definition.class ^= CLASS_SEGNAME then last_definition.segname_relp = segblock_head; bx_$curdeflng = bx_$curdeflng + 1; /* thread must end at physical end for checker */ call hash_defs_; /* Make defs hash table now. */ return; regenerate_block: entry (compent_ptr); /**********************************************************************/ /* */ /* Name: make_defs_$regenerate_block */ /* Input: component_entry_pointer */ /* Function: given a pointer to a component table entry, scan */ /* the insym table for that component and regenerate */ /* any definitions which are to be retained. */ /* Output: none */ /* */ /**********************************************************************/ declare compent_ptr pointer; ctep = compent_ptr; /* copy pointer to current component table entry */ ip = comp.insymentp; /* pointer to component's definitions */ ndefs = ip -> insym.n_insyms; /* get number of definitions for this component */ /* now generate definitions for all insyms which are to be retained */ do i = 1 to ndefs - 1; /* scan definition table for component */ sp = addr (ip -> insym.entry (i)); /* pointer to current definition */ if sp -> is.regenerated then goto skip; /* this definition has already been regenerated */ if ((sp -> is.delete | sp -> is.ignore) & ^sp -> is.retain_flag) then go to skip; call generate_def_ (ctep, sp); /* generate this definition */ skip: end; return; /* */ check_ignore: proc; /**********************************************************************/ /* */ /* Name: check_ignore */ /* Input: defblock_head */ /* Function: scans the definition block specified by defblock */ /* head for non-ignored definition and sets the */ /* newignore flag if all of the definitions in the */ /* block are ignored. */ /* Output: newignore */ /* */ /**********************************************************************/ newignore = "1"b; /* ignore unless we find 1 nonignored def */ /* find beginning of defblock */ def_ptr = addrel (defbase, defblock_head); test_ignore: if ^definition.flags.ignore then do; /* at least 1 nonignored def */ newignore = "0"b; return; /* don't need to look further */ end; if definition.forward_relp ^= 0 then do; /* follow thread */ def_ptr = addrel (defbase, definition.forward_relp); go to test_ignore; end; return; end; /* */ fabricate_def: procedure (defstring, newclass, newvalue); /**********************************************************************/ /* */ /* Name: fabricate_def */ /* Input: defstring, newclass, newvalue */ /* Function: creates a definition in the definition section */ /* with the name specified by defstring, the class */ /* specified by newclass, and a thing_relp specified */ /* by newvalue. */ /* */ /**********************************************************************/ declare defstring char (32) varying; declare newclass fixed bin (3) unsigned; declare newvalue fixed bin (18) unsigned; declare (i, defoffset) fixed bin; declare dp pointer; declare 01 new_def aligned like definition based (dp); defoffset = bx_$curdeflng; rel_ptr = defoffset; /* relative offset of def */ dp = addrel (defbase, rel_ptr); /* absolute pointer to new def */ new_def.class = newclass; new_def.thing_relp = newvalue; new_def.flags.new = "1"b; new_def.flags.ignore = newignore; defoffset = defoffset + 3; do i = 1 to strm.nstr; /* lookup string in map */ /* pointer to a generated string */ acc_string_ptr = addrel (defbase, strm.entry (i).map); if defstring = acc_string.string then do; new_def.name_relp = fixed (strm.entry (i).map, 18); goto string_generated; end; end; i, strm.nstr = strm.nstr + 1; if strm.nstr > strm.max_size then do; call com_err_ (0, errname, "stringmap table overflow; please contact maintenance."); strm.nstr = 1; bx_$fatal_error = 1; end; new_def.name_relp = defoffset; /* pointer to newly generated symbol string */ strm.entry (i).map = bit (bin (defoffset, 18), 18); acc_string_ptr = addrel (defbase, defoffset); acc_string.count = length (defstring); acc_string.string = defstring; defoffset = defoffset + divide (acc_string.count + 4, 4, 17, 0); call strm_hash_$make_entry (acc_string_overlay, i); string_generated: bx_$curdeflng = defoffset; if last_segname = null then return; /* only once for first definition */ last_definition.forward_relp = rel_ptr; /* thread entries together */ new_def.backward_relp = last_def_rel; /* backwards thread */ last_def = dp; /* remember this definition */ last_def_rel = rel_ptr; /* and its rel-ptr form */ if newclass ^= CLASS_SEGNAME then /* not a segname */ do; /* pointer to head of segname block */ new_def.segname_relp = segblock_head; return; /* and that's all */ end; /* thread of segname entries */ last_segname -> definition.thing_relp = rel_ptr; new_def.segname_relp = defblock_head; /* set up segname thread */ last_segname = dp; /* remember this segname definition */ return; end fabricate_def; end make_defs_;  parse_bindfile_.rd 07/16/86 1217.0rew 07/16/86 1212.5 332703 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Change error messages to use the caller supplied name instead of "parse_bindfile_", changed to produce a reasonable error message when parsing a bindfile with no tokens or a zero length bindfile, and to give a warning if the obsolete "indirect" keyword is used in a "global" or "Global" statement. END HISTORY COMMENTS */ /*++ INCLUDE NEXT_STMT \ INCLUDE LEX \ INCLUDE ERROR \ BEGIN stmt / /[keyword_idx = 0] / \ / /epilogue /RETURN \ / ; /LEX /stmt \ / / /KEYWORD \ / /[if keyword_idx = 0 then call ERROR (1)] NEXT_STMT /stmt \ KEYWORD /Addname /Addname LEX /ADDNAME \ /Force_Order : /LEX (2) [arg_ptr = Ptoken; arg_count = 0] /ORD_list \ /Force_Order /LEX /bad_syntax\ /Global : ; /LEX (2) Global NEXT_STMT /stmt \ /Global : /LEX (2) ERROR (7) NEXT_STMT /stmt \ /Global /LEX /bad_syntax\ /Ignore : /LEX (2) [arg_ptr = Ptoken; arg_count = 0] /ORD_list \ /Ignore /LEX /bad_syntax\ /No_Table /LEX /noarg_stmt\ /Objectname : ; /LEX (2) Objectname NEXT_STMT /stmt \ /Objectname : /LEX (2) ERROR(7) NEXT_STMT /stmt \ /Objectname /LEX /bad_syntax\ /Order : /LEX (2) [arg_ptr = Ptoken; arg_count = 0] /ORD_list \ /Order /LEX /bad_syntax\ /Partial_Order : /LEX (2) [arg_ptr = Ptoken; arg_count = 0] /ORD_list \ /Partial_Order /LEX /bad_syntax\ /Perprocess_Static /LEX /noarg_stmt\ /delete : /delete LEX (2) /ENTRY_list\ /delete /LEX /bad_syntax\ /global : ; /LEX (2) global NEXT_STMT /stmt \ /global : /LEX (2) ERROR(7) NEXT_STMT /stmt \ /global /LEX /bad_syntax\ /indirect : /indirect LEX (2) /ENTRY_list\ /indirect /LEX /bad_syntax\ /no_link : /no_link LEX (2) /ENTRY_list\ /no_link /LEX /bad_syntax\ /objectname : ; /LEX (2) objectname NEXT_STMT /stmt \ /objectname : /LEX (2) ERROR (7) NEXT_STMT /stmt \ /objectname /LEX /bad_syntax\ /retain : /retain LEX (2) /ENTRY_list\ /retain /LEX /bad_syntax\ /synonym : /synonym LEX (2) /SEG_list \ /synonym /LEX /bad_syntax\ /table /LEX /noarg_stmt\ ADDNAME /; /LEX /stmt \ /: ; /LEX (2) /stmt \ /: /[an.n_an = 0] LEX /ADN_list \ bad_syntax /: /LEX ERROR (2) NEXT_STMT /stmt \ /: /ERROR (3) LEX /stmt \ / /ERROR (4) NEXT_STMT /stmt \ / /ERROR (3) /stmt \ noarg_stmt / ; /LEX perform_noarg /stmt \ / : ; /LEX (2) perform_noarg /stmt \ / : /ERROR (6) NEXT_STMT /stmt \ / : /ERROR (3) LEX /stmt \ / /ERROR (4) NEXT_STMT /stmt \ / /ERROR (3) /stmt \ ADN_list / , /[an.n_an = an.n_an + 1; if an.n_an > an.max_size then call ERROR (13); else an.syn (an.n_an) = token_value] LEX (2) /ADN_list \ / ; /[an.n_an = an.n_an + 1; if an.n_an > an.max_size then call ERROR (13); else an.syn (an.n_an) = token_value] NEXT_STMT /stmt \ / /ERROR (7) NEXT_STMT /stmt \ / , /ERROR (8) LEX(2) /ADN_list \ / ; /ERROR (8) NEXT_STMT /stmt \ / /ERROR (2) NEXT_STMT /stmt \ / /ERROR (3) /stmt \ ORD_list / , /[if segname_too_long then call ERROR (8); else arg_count = arg_count + 1] LEX (2) /ORD_list \ / ; /[if segname_too_long then call ERROR (8); else arg_count = arg_count + 1] perform_order NEXT_STMT /stmt \ / /[if segname_too_long then call ERROR (8); else call ERROR (7)] NEXT_STMT /stmt \ / /ERROR (2) [if arg_count > 0 then do; ARG_list_error = "1"b; call perform_order (); end] NEXT_STMT /stmt \ / /ERROR (3) [if arg_count > 0 then do; ARG_list_error = "1"b; call perform_order (); end] NEXT_STMT /stmt \ SEG_list / , /FILL_OPTION_ENTRY LEX (2) /SEG_list \ / ; /FILL_OPTION_ENTRY GET_OPTION_TOTALS NEXT_STMT /stmt \ / , /ERROR (8) LEX (2) /SEG_list \ / ; /ERROR (8) GET_OPTION_TOTALS NEXT_STMT /stmt \ / /[if segname_too_long then call ERROR (8); else call ERROR (7)] NEXT_STMT /stmt \ / /ERROR (2) NEXT_STMT /stmt \ / /ERROR (3) /stmt \ ENTRY_list / , /[if ^entryname_too_long then call FILL_OPTION_ENTRY] LEX (2) /ENTRY_list\ / ; /[if ^entryname_too_long then call FILL_OPTION_ENTRY] GET_OPTION_TOTALS NEXT_STMT /stmt \ / /ERROR (5) NEXT_STMT /stmt \ / /ERROR (2) NEXT_STMT /stmt \ / /ERROR (3) /stmt \ ++*/ /* format: style3,^indnoniterdo */ %page; /* Parse Bind File - procedure to go through optional bindfile and extract the bind parameters from it. Newly coded by Michael J. Spier, November 23, 1971 */ /* modified 75.06.24 by M. Weaver to remove no_old_alm keyword */ /* modified 77.08.16 by M. Weaver to add Perprocess_Static keyword */ /* Modified 01/14/81 W. Olin Sibert for new format of input structure, and -force_order */ /* Rewritten 9/20/84 by M.Sharpe to use the reduction compiler, and implement the Ignore and Partial_Order statements Modified 01/23/83 by M.Sharpe to correct problem with unrecognized "no_link" attribute on "global" and "Global" statements. */ np: parse_bindfile_: proc; /* Automatic */ declare breaks char (9) var aligned, ignored_breaks char (6) var aligned, lex_delims char (70) var aligned, lex_control_chars char (70) var aligned, Linput fixed bin (21), Linput_ignore fixed bin (21) init (0), (Pfirst_stmt_descriptor, Pfirst_token_descriptor, Pinput, Psegment) ptr init (null ()); declare MYNAME char (32); declare arg_count fixed bin; declare code fixed bin (35); declare ( ORDER init (1), FORCE_ORDER init (2), PARTIAL_ORDER init (3) ) fixed bin; declare order_type fixed bin init (0); declare (i, j, k) fixed bin; declare keyword_idx fixed bin; declare Word_extent fixed bin init (0); declare new_nobj fixed bin; declare obj_idx fixed bin init (0); declare opt_counter fixed bin; declare partial_order_number fixed bin init (0); declare stmt_error (17) fixed bin init ((17) (0)); declare opt_code char (1); declare ARG_list_error bit (1) init ("0"b); declare entryname_too_long bit (1) init ("0"b); declare ignore_seen bit (1) init ("0"b); declare MAX_error bit (1) init ("0"b); declare no_parameters bit (1); declare order_error bit (1) init ("0"b); declare Parameters bit (1); declare segname_too_long bit (1) init ("0"b); declare (arg_ptr, p, p1, inpp, optp, copyp, areap) ptr init (null); /* Based */ declare arg char (arg_ptr -> token.Lvalue) based (arg_ptr -> token.Pvalue); declare 1 acc_ope aligned based (p), /* like op but uses acc format char) */ 2 symb_len fixed bin (9) unsigned unaligned, 2 symb char (256) unaligned, 2 code char (1) aligned, 2 lng fixed bin; declare Word (Word_extent) fixed bin based; declare reset bit (2313) based (p); /* Static */ /* format: off */ declare 1 error_control_table (25) internal static options (constant), 2 severity fixed bin (17) init ((8) 3, 1, 2, (12) 3, (3) 1), 2 Soutput_stmt bit (1) unaligned init ((4) ("1"b), "0"b, "1"b, "1"b, "0"b, (3) ("1"b), (12) ("0"b), (2) ("1"b)), 2 message char (90) varying init ( /* 1 */ "'^a ' is not a legal keyword.", /* 2 */ "Invalid parameter. '^a'", /* 3 */ "Bindfile ends with an incomplete statement.", /* 4 */ "Keyword not delimited by colon. '^a'", /* 5 */ "Entryname is longer than 255 characters '^a.'", /* 6 */ "This statement does not accept parameters.", /* 7 */ "Improper delimiter after '^a'.", /* 8 */ "Possible segment name is longer than 32 characters '^a'.", /* 9 */ "'indirect:' is an obsolete keyword. It should be replaced by 'retain:'.", /* 10 */ "Duplicate statement. Statement is ignored.", /* 11 */ "This statement must follow an 'objectname:' statement.", /* 12 */ "'Order', 'Force_Order', and 'Partial_Order' are mutually exclusive.", /* 13 */ "Too many addnames supplied. Maximum of 128 addnames is allowed.", /* 14 */ "Duplicate objectname statement for ^a.", /* 15 */ "Objectname ^a repeated in this statement.", /* 16 */ "Objectname ^a not found in any archive.", /* 17 */ "Zero-length object ^a mentioned in objectname statement.", /* 18 */ "Zero-length object ^a mentioned in Order/Force_Order/Partial_Order statement.", /* 19 */ "Objectname ^a mentioned in 'objectname' statement but not in Force_Order statement", /* 20 */ "Objectname ^a mentioned both in Ignore and Order/Force_Order/Partial_Order statements.", /* 21 */ "Objectname ^a mentioned both in Ignore and objectname statements.", /* 22 */ "Objectname ^a not mentioned in Order statement.", /* 23 */ "Objectname ^a ignored because of zero bitcount.", /* 24 */ "'indirect' is an obsolete Global option It should be replaced by 'retain'.", /* 25 */ "'indirect' is an obsolete global option It should be replaced by 'retain'."), 2 brief_message char (1) varying init ((25) (" ")); /* brief messages aren't used */ /* format: on */ declare ERROR_OUTPUT char (12) int static init ("error_output"); declare ( Addname_idx init (1), FOrder_idx init (2), Global_idx init (3), Ignore_idx init (4), No_Table_idx init (5), Objectname_idx init (6), Order_idx init (7), POrder_idx init (8), PStatic_idx init (9), delete_idx init (10), global_idx init (11), indirect_idx init (12), no_link_idx init (13), objectname_idx init (14), retain_idx init (15), synonym_idx init (16), table_idx init (17) ) fixed bin; declare ( DUP_stmt init (10), NO_obj init (11), EXCLUSIVE_stmt init (12), DUP_objectname init (14), NO_such_seg init (16), SKIP_stmt init (99) ) fixed bin internal static; /* External */ declare error_table_$zero_length_seg external fixed bin (35); /* Builtin */ declare (addr, addrel, bin, bit, collate, dimension, divide, fixed, max, null, rel, size, substr) builtin; /* Entry */ declare com_err_ entry () options (variable), ioa_$ioa_stream entry () options (variable), lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var aligned, char (*) var aligned, char (*) var aligned, char (*) var aligned, ptr, ptr, fixed bin (35)), lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var aligned, char (*) var aligned, char (*) var aligned, char (*) var aligned), temp_mgr_$reserve entry (pointer), translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)), translator_temp_$release_all_segments entry (ptr, fixed bin (35)); /* Condition */ declare cleanup condition; %page; on cleanup begin; if Psegment ^= null then call translator_temp_$release_all_segments (Psegment, code); bx_$fatal_error = 1; end; if bx_$debug = 1 then MYNAME = "parse_bindfile_"; else MYNAME = bx_$caller; inpp = bx_$inpp; NTOTAL = inp.ntotal; /* used for allocating copy area */ NOBJ = inp.nobj; /* ditto */ bx_$bound_segname = inp.bound_seg_name; /* remember in case of abort */ if inp.bindfilep = null | inp.bindfile_bc = 0 then do; bx_$optp = null; /* indicate there are no bind options */ bx_$addname = 0; bx_$adnp = null; if ^inp.zeroseg_seen then return; copyp = bx_$freep; /* allocate area for archive reorder */ call temp_mgr_$reserve (addrel (copyp, size (inp))); /* allocate with respect to NTOTAL and NOBJ */ call CHECK_CONFLICTS; /* make new structure, removing zero-length segments */ return; end; call translator_temp_$get_segment (MYNAME, Psegment, code); /* reduction compiler needs this */ if code ^= 0 then do; call com_err_ (code, MYNAME, "Could not get temp segment. Report to maintainer."); bx_$fatal_error = 1; return; end; SERROR_CONTROL = "11"b; /* use long error messages every time */ call INIT_PARSE; if Linput = 0 then do; call com_err_ (error_table_$zero_length_seg, MYNAME, inp.bindfile_name); goto Return; end; if bx_$brief = 1 then MIN_PRINT_SEVERITY = 2; /* Don't print warnings if -brief was specified. */ ignored_breaks = substr (collate, 10, 5) || " "; breaks = ignored_breaks || ",:;"; call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ignored_breaks, lex_delims, lex_control_chars); call lex_string_$lex (Pinput, Linput, Linput_ignore, Psegment, "1100"b, """", """", "/*", "*/", ";", breaks, ignored_breaks, lex_delims, lex_control_chars, Pfirst_stmt_descriptor, Pfirst_token_descriptor, code); Pthis_token = Pfirst_token_descriptor; if code ^= 0 then do; if Pthis_token = null then do; if code = error_table_$zero_length_seg then call com_err_ (0, MYNAME, "No tokens found in bindfile. ^a", inp.bindfile_name); else call com_err_ (code, MYNAME); go to Return; end; /* if code = error_table_$no_stmt_delim | code = error_table_$unbalanced_quotes error messages which can specify the location of the error are printed during the semantic analysis */ end; call SEMANTIC_ANALYSIS (); Return: if Psegment ^= null then call translator_temp_$release_all_segments (Psegment, code); return; %page; /*****************************************************************************/ /* These 4 entries are auxiliary scanner/lexical routines */ FUNCTIONS: proc returns (bit (1) aligned); /* this entry returns "1"b if a valid parameter has been specified to the Global/global keywords; "0"b otherwise. */ globe_arg: entry returns (bit (1) aligned); if token_value = "delete" | token_value = "indirect" | token_value = "no_link" | token_value = "retain" then return ("1"b); else return ("0"b); /* This entry returns "1"b if the current token consists of only alphanumeric characters allowed in an entryname. It also performs asemantic function. If the token is longer than 32 characters the segname_too_long flag is set; if it is longer than 255 characters the entryname_too_long flag is also set. This reduces the number of reductins necessary for parsing the bindfile. */ long_name: entry returns (bit (1) aligned); segname_too_long, entryname_too_long = "0"b; if token.Lvalue > 32 then segname_too_long = "1"b; if token.Lvalue > 255 then entryname_too_long = "1"b; return ("1"b); /* This entry returns "1"b if the current token is an appropriate segment name */ seg_name: entry returns (bit (1) aligned); segname_too_long = "0"b; if token.Lvalue > 32 then do; segname_too_long = "1"b; call ERROR (8); return ("0"b); end; return ("1"b); /* This entry determines if the current token is a valid keyword. If so keyword_idx is set accordingly; otherwise, keyword_idx is set to 0 and "0"b is returned. Some semantic analysis is also perfomed here. If a token is recognized as a keyword, but one whose presence in the bindfile constitues a semantic error, e.g., duplicate master keyword, the proper error message is issued here and "0"b is returned. The reduction routine ignores the entire statement if "0"b is returned; it issues errors only if keyword_idx is set to 0. */ keyword: entry () returns (bit (1) aligned); if token_value = "Addname" then keyword_idx = Addname_idx; else if token_value = "Force_Order" then keyword_idx = FOrder_idx; else if token_value = "Global" then keyword_idx = Global_idx; else if token_value = "Ignore" then keyword_idx = Ignore_idx; else if token_value = "No_Table" then keyword_idx = No_Table_idx; else if token_value = "Objectname" then keyword_idx = Objectname_idx; else if token_value = "Order" then keyword_idx = Order_idx; else if token_value = "Partial_Order" then keyword_idx = POrder_idx; else if token_value = "Perprocess_Static" then keyword_idx = PStatic_idx; else if token_value = "delete" then keyword_idx = delete_idx; else if token_value = "global" then keyword_idx = global_idx; else if token_value = "indirect" then keyword_idx = indirect_idx; else if token_value = "no_link" then keyword_idx = no_link_idx; else if token_value = "objectname" then keyword_idx = objectname_idx; else if token_value = "retain" then keyword_idx = retain_idx; else if token_value = "synonym" then keyword_idx = synonym_idx; else if token_value = "table" then keyword_idx = table_idx; else return ("0"b); if stmt_error (keyword_idx) = 0 then return ("1"b); else if stmt_error (keyword_idx) = SKIP_stmt then return ("0"b); /* Skip these silently */ call ERROR (stmt_error (keyword_idx)); return ("0"b); end FUNCTIONS; %page; /*****************************************************************************/ /* The following are the semantic analysis routines. The entries beginning with "Addname" up to "table" correspond to bindfile keywords. Others are auxiliary routines. */ ACTION: proc; perform_order: entry (); if keyword_idx = Order_idx then call Order (); else if keyword_idx = FOrder_idx then call Force_Order (); else if keyword_idx = POrder_idx then call Partial_Order (); else if keyword_idx = Ignore_idx then call Ignore (); else ; /* should never happen */ return; perform_noarg: entry (); if keyword_idx = No_Table_idx then call No_Table (); else if keyword_idx = PStatic_idx then call Perprocess_Static (); else if keyword_idx = table_idx then call table (); return; Addname: entry (); stmt_error (Addname_idx) = DUP_stmt; Parameters = "1"b; bx_$addname = 1; return; Force_Order: entry (); stmt_error (FOrder_idx) = DUP_stmt; /* Don't use this again */ stmt_error (Order_idx) = EXCLUSIVE_stmt; /* And this one is mutually exclusive with Force_Order */ stmt_error (POrder_idx) = EXCLUSIVE_stmt; /* ... and so's this one */ order_type = FORCE_ORDER; call REORDER_ARCHIVE (); return; Global: entry (); stmt_error (Global_idx) = DUP_stmt; if token_value = "delete" then g_delete = "d"; /* This scheme was kept from the original program */ else if token_value = "retain" then g_retain = "r"; /* because it is integral to other parts of the */ else if token_value = "no_link" then g_nolink = "l"; /* binder software */ else if token_value = "indirect" then do; call ERROR (24); g_indirect = "i"; end; else do; call ERROR (2); return; end; Parameters = "1"b; return; Ignore: entry (); /* The reduction routine checks the syntax of the "Ignore" statement; if it's OK, it sets arg_ptr to the addr of the 1st parameter and arg_count to the number of parameters. Because the parameters are separated by commans, every other token is skipped when getting the next parameter */ stmt_error (Ignore_idx) = DUP_stmt; ignore_seen = "1"b; p1 = Pthis_token; /* save it */ Pthis_token = arg_ptr; /* allows the correct component names to appear in the error messages in the followin loop */ do i = 1 to arg_count; /* Lookup input structure to match parameter */ if arg_ptr -> token.Lvalue > 32 then goto next_ignore_arg; do j = 1 to bx_$ncomp; p = addr (inp.obj (j)); if obj.filename = arg then goto ignore_it; end; call ERROR (NO_such_seg); /* the segment is not among the components specified by user */ goto next_ignore_arg; ignore_it: if (obj.to_be_ignored & obj.bitcount ^= 0) then do; /* Duplicated in Ignore statement */ call ERROR (15); goto next_ignore_arg; end; obj.to_be_ignored = "1"b; next_ignore_arg: Pthis_token, arg_ptr = arg_ptr -> token.Pnext -> token.Pnext; /* skip the delimiter between two args */ /* see opening comments for ignore */ end; Pthis_token = p1; /* restore to end of Ignore stmt */ return; No_Table: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (No_Table_idx) = DUP_stmt; option.g_notable = "t"; no_parameters = "0"b; return; Objectname: entry (); stmt_error (Objectname_idx) = DUP_stmt; if token.Lvalue > 32 then call ERROR (8); else bx_$bound_segname = token_value; return; Order: entry (); stmt_error (Order_idx) = DUP_stmt; stmt_error (FOrder_idx) = EXCLUSIVE_stmt; stmt_error (POrder_idx) = EXCLUSIVE_stmt; if bx_$force_order ^= 0 then order_type = FORCE_ORDER; /* Order becomes Force_Order if -force_order is specified in the command line */ else order_type = ORDER; call REORDER_ARCHIVE (); return; Partial_Order: entry (); stmt_error (POrder_idx) = DUP_stmt; stmt_error (FOrder_idx) = EXCLUSIVE_stmt; stmt_error (Order_idx) = EXCLUSIVE_stmt; order_type = PARTIAL_ORDER; call REORDER_ARCHIVE (); return; Perprocess_Static: entry (); stmt_error (PStatic_idx) = DUP_stmt; bx_$perprocess_static = 1; Parameters = "1"b; return; delete: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (delete_idx) = DUP_stmt; opt_counter = 0; opt_code = "d"; no_parameters = "0"b; return; global: entry (); stmt_error (global_idx) = DUP_stmt; if token_value = "delete" then op.delete = "d"; else if token_value = "retain" then op.retain = "r"; else if token_value = "no_link" then op.no_link = "l"; else if token_value = "indirect" then do; call ERROR (25); op.indirect = "i"; end; else do; call ERROR (2); return; end; no_parameters = "0"b; return; indirect: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (indirect_idx) = DUP_stmt; if bx_$brief = 0 then call ERROR (9); /* This is an obsolete keyword; it now functions like "retain" */ opt_counter = 0; opt_code = "i"; no_parameters = "0"b; return; no_link: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (no_link_idx) = DUP_stmt; opt_counter = 0; opt_code = "l"; no_parameters = "0"b; return; objectname: entry (); stmt_error (objectname_idx) = 0; call CLOSE_ENTRY; /* start a new option table entry, etc. */ if segname_too_long then do; call ERROR (8); goto skip_objname; end; do obj_idx = 1 to bx_$ncomp; if token_value = inp.obj (obj_idx).filename then go to OPEN_ENTRY; end; call ERROR (NO_such_seg); goto skip_objname; OPEN_ENTRY: if inp.obj (obj_idx).bitcount = 0 then do; call ERROR (17); /* zero-length segs can't be specified in any statements */ goto skip_objname; end; if inp.obj (obj_idx).option ^= "0"b then do; /* Another objectname statement for this obj specified earlier */ call ERROR (DUP_objectname); skip_objname: /* Ignore any attributes pertaining to this rejected */ stmt_error (delete_idx), /* objectname. The errors cause the corresponding */ stmt_error (global_idx), /* statements to be ignored (See keyword FUNCTION) */ stmt_error (indirect_idx), /* until the next objectname statement is seen */ stmt_error (no_link_idx), /* when all are reset to 0 */ stmt_error (retain_idx), stmt_error (synonym_idx), stmt_error (table_idx) = SKIP_stmt; return; end; op.n_retain, op.n_indirect, op.n_nolink, op.n_options, op.n_synonyms, op.n_delete = 0; /* reset structure */ op.table, op.retain, op.indirect, op.no_link, op.delete = " "; /* ... */ inp.obj (obj_idx).objectname_stmt = "1"b; /* Now it cannot be Ignore'd or omitted from Order / Force_Order lists */ no_parameters = "1"b; /* indicate no params specified yet */ stmt_error (delete_idx) = 0; /* reset errors for attribute statements, since any errors */ stmt_error (global_idx) = 0; /* were for previous object and we've got a new one now */ stmt_error (indirect_idx) = 0; stmt_error (no_link_idx) = 0; stmt_error (retain_idx) = 0; stmt_error (synonym_idx) = 0; stmt_error (table_idx) = 0; /* put objectname into structure, tag it as synonym */ opt_counter = 0; opt_code = "s"; /* pretend it's a synonym */ call FILL_OPTION_ENTRY; op.n_synonyms = 1; return; retain: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (retain_idx) = DUP_stmt; opt_counter = 0; opt_code = "r"; no_parameters = "0"b; return; synonym: entry (); /* The option table entries are filled by FILL_OPTION_ENTRY by the reduction routine after we return from here. */ stmt_error (synonym_idx) = DUP_stmt; opt_counter = 0; opt_code = "s"; no_parameters = "0"b; return; table: entry (); stmt_error (table_idx) = DUP_stmt; op.table = "t"; no_parameters = "0"b; return; REORDER_ARCHIVE: entry (); /* The argument processing is same as Ignore */ k = 0; order_error = ARG_list_error; p1 = Pthis_token; /* save it */ Pthis_token = arg_ptr; /* This will allow the correct component name to be printed in error messages inside this loop */ do i = 1 to arg_count; /* Lookup input structure to match parameter */ if arg_ptr -> token.Lvalue > 32 then goto next_arg; do j = 1 to bx_$ncomp; p = addr (inp.obj (j)); if obj.filename = arg then goto match_found; end; call ERROR (NO_such_seg); order_error = "1"b; goto next_arg; match_found: if obj.flag = "1"b then do; /* repeated in order-ing statement */ call ERROR (15); order_error = "1"b; goto next_arg; end; if obj.bitcount = 0 then do; /* zero-length obj has no business here */ call ERROR (18); order_error = "1"b; goto next_arg; end; obj.flag = "1"b; k = k + 1; /* increment index */ obj.new_order = k; /* remember the new order index */ next_arg: arg_ptr, Pthis_token = arg_ptr -> token.Pnext -> token.Pnext; /* skip the delimiter between two args */ end; Pthis_token = p1; /* restore to end of the Order stmt */ if order_type = PARTIAL_ORDER then partial_order_number = k; /* the number of objects so far "ordered". The rest will be given order numbers, beginning with partial_order_number +1, in the order they appear in the input structure */ if order_error then bx_$fatal_error = 1; return; FILL_OPTION_ENTRY: entry (); opt_counter = opt_counter + 1; op.n_options = op.n_options + 1; p = addr (op.opes (op.n_options)); reset = "0"b; /* want trailer nulls instead of blanks */ acc_ope.symb_len = token.Lvalue; substr (acc_ope.symb, 1, token.Lvalue) = token_value; acc_ope.code = opt_code; acc_ope.lng = token.Lvalue + 1; return; GET_OPTION_TOTALS: entry (); /* routine to set the counter for the particular option */ if keyword_idx = no_link_idx then n_nolink = n_nolink + opt_counter; else if keyword_idx = indirect_idx then n_indirect = n_indirect + opt_counter; else if keyword_idx = retain_idx then n_retain = n_retain + opt_counter; else if keyword_idx = delete_idx then n_delete = n_delete + opt_counter; else if keyword_idx = synonym_idx then n_synonyms = n_synonyms + opt_counter; /* else; should never happen. */ return; epilogue: entry (); call CLOSE_ENTRY; if order_type > 0 | ignore_seen | zeroseg_seen then call CHECK_CONFLICTS; if MERROR_SEVERITY > 2 then do; bx_$fatal_error = 1; return; end; if Parameters = "0"b then do; bx_$adnp = null; /* ... */ bx_$addname = 0; /* ... */ Word_extent = fixed (rel (optp), 18) - fixed (rel (areap), 18) + 128; areap -> Word (*) = 0; /* reset allocated table area */ end; call temp_mgr_$reserve (addr (op.opes (opt_counter + 1))); /* Mark the extent of the option table */ return; CLOSE_ENTRY: entry (); stmt_error (delete_idx), /* These statements can't appear again BEFORE */ stmt_error (global_idx), /* the next objectname stmt */ stmt_error (indirect_idx), stmt_error (no_link_idx), stmt_error (retain_idx), stmt_error (synonym_idx), stmt_error (table_idx) = NO_obj; if no_parameters then /* virgin entry */ do; if obj_idx ^= 0 then inp.obj (obj_idx).option = "0"b; /* reset option pointer */ return; end; if obj_idx ^= 0 then inp.obj (obj_idx).option = bit (bin (fixed (rel (optp), 18) - fixed (rel (areap), 18), 18), 18); Parameters = "1"b; no_parameters = "1"b; /* indicate no objectname parameters */ if op.n_options = 1 then do; /* No options; just the objectname used as synonym. */ op.n_options, op.n_synonyms, op.n_options = 0; end; if obj_idx > 0 then optp = addr (op.opes (op.n_options + 1)); /* prepare pointer to next option structure */ obj_idx = 0; return; %page; /* * It is the responsibility of this routine to examine the inp structure, * verifying that the Ignore, Order, Force_Order and Partial_Order * statements have been used in a consistent fashion. * If no errors are detected, a new copy of the inp structure * is built (in the area reserved and pointed to by copyp) and the * desired objectnames are placed in the new structure, in the * desired order. * * It is assumed that the caller has already checked the ignore, order and * zeroseg_seen flags, so this routine is not called when it is not needed. */ CHECK_CONFLICTS: entry (); declare erring_token_value char (32); j = 0; /* reset index that is used if no Order-ing statements in bindfile */ new_nobj = 0; /* reset counter of kept object segments */ do i = 1 to bx_$ncomp; /* examine every objectname known, looking for errors */ p = addr (inp.obj (i)); erring_token_value = obj.filename; if obj.bitcount = 0 /* Warn about zero-lengt segs except where . . . */ & obj.new_order = 0 /* 1) there's a coflict with order (already handled) */ & ^obj.objectname_stmt /* 2) there's a conflict with objectname stmt (ditto) */ & bx_$brief = 0 then do; /* 3) they've asked us to keep quiet */ MERROR_SEVERITY = max (1, MERROR_SEVERITY); call ioa_$ioa_stream (ERROR_OUTPUT, "^/WARNING 23^/" || error_control_table.message (23) || "^/", erring_token_value); end; else if obj.to_be_ignored then do; /* appeared in Ignore stmt */ if obj.new_order > 0 then do; /* ... AND some order stmt */ MERROR_SEVERITY = 3; call ioa_$ioa_stream (ERROR_OUTPUT, "^/ERROR 20 SEVERITY 3^/" || error_control_table.message (20) || "^/", erring_token_value); end; if obj.objectname_stmt then do; /* ... AND/OR in an objectname stmt */ MERROR_SEVERITY = 3; call ioa_$ioa_stream (ERROR_OUTPUT, "^/ERROR 21 SEVERITY 3^/" || error_control_table.message (21) || "^/", erring_token_value); end; end; if order_type = FORCE_ORDER & obj.objectname_stmt /* obj was in an objectname stmt... */ & obj.new_order = 0 /* but not in the Force_Order stmt */ then do; MERROR_SEVERITY = 3; call ioa_$ioa_stream (ERROR_OUTPUT, "^/ERROR 19 SEVERITY 3^/" || error_control_table.message (19) || "^/", erring_token_value); end; if order_type = ORDER & obj.new_order = 0 /* object not in Order stmt ... */ & ^obj.to_be_ignored /* and had no excuse for not being there */ then do; MERROR_SEVERITY = 3; call ioa_$ioa_stream (ERROR_OUTPUT, "^/ERROR 22 SEVERITY 3^/" || error_control_table.message (22) || "^/", erring_token_value); end; if order_type = PARTIAL_ORDER & ^obj.to_be_ignored & obj.new_order = 0 /* objects not in Partial_Order stmt ... */ then do; /* will be assigned orders as we catch them */ partial_order_number = partial_order_number + 1; obj.new_order = partial_order_number; end; /* * Assign an order to this module if we had no * type of Order statement and if this module is * not to be ignored. */ if order_type = 0 & ^obj.to_be_ignored then do; /* assign an order index to this not-to-be-ignored object */ j = j + 1; obj.new_order = j; end; if obj.new_order > 0 then new_nobj = new_nobj + 1; end; /* Now we can fill in the copy of the inp structure and switch pointers, if there were no errors. */ if MERROR_SEVERITY < 3 then do; Word_extent = fixed (fixed (rel (addr (inp.obj (1).filename)), 18) - fixed (rel (inpp), 18), 18); /* get size of input structure */ copyp -> Word (*) = inpp -> Word (*); /* copy input structure */ do i = 1 to bx_$ncomp; p = addr (inp.obj (i).filename); if obj.new_order > 0 then do; p1 = addr (copyp -> inp.obj (obj.new_order).filename); p1 -> obj = p -> obj; end; end; bx_$ncomp, copyp -> inp.nobj = new_nobj; inpp, bx_$inpp = copyp; end; return; end ACTION; %page; /**************************************************************************************************************************/ INIT_PARSE: proc (); Pinput = inp.bindfilep; /* copy pointer to bindfile */ Linput = divide (inp.bindfile_bc + 8, 9, 17, 0); /* compute length in characters */ Parameters = "0"b; no_parameters = "1"b; copyp = bx_$freep; /* allocate area for possible archive reorder */ call temp_mgr_$reserve (addrel (copyp, size (inp))); /* allocate with respect to NTOTAL and NOBJ */ adnp, bx_$adnp = bx_$freep; /* beginning of addname table */ call temp_mgr_$reserve (addrel (adnp, (bx_$addname_limit + 2) * 9)); /* reserve table */ an.n_an = 0; an.max_size = bx_$addname_limit; areap, bx_$optp = bx_$freep; /* beginning of option table */ /* we shouldn't run off the end of the temp seg by th time the option table is full. The temp area for the table is "reserved (actually marked) before we leave, i.e., when we KNOW how much space is needed. */ /* initialize various variables */ g_notable, g_retain, g_indirect, g_nolink, g_delete = " "; /* reset options structure */ optp = addr (option.structures); /* pointer to first structure */ stmt_error (delete_idx), /* Can't have any of these stmts until AFTER the next objectname stmt */ stmt_error (global_idx), stmt_error (indirect_idx), stmt_error (no_link_idx), stmt_error (retain_idx), stmt_error (synonym_idx), stmt_error (table_idx) = NO_obj; if bx_$force_order = 1 then stmt_error (POrder_idx) = EXCLUSIVE_stmt; /* if -forcer_order specified on cmmand line, "Order" is "translated" to Force_Order; Partial_Order,however, is not allowed in the bindfile */ return; end INIT_PARSE; /* The binder include files (1:4) and the code generated by the reduction compiler follows. */ %page; %include binder_input; %page; %include option; %page; %include bndtbl; %page; %include bindext; %page;  rebuild_object_.pl1 07/16/86 1217.0rew 07/16/86 0846.5 143811 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and readability, changed errnameto use the caller-supplied name instead of "binder_", changed to call regenerate_all_links_ after normal resolution to pick up any *system links not already regenerated, and to remove obsolete nonstandard object support. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /**********************************************************************/ /* */ /* Name: rebuild_object_ */ /* Input: compent_ptr */ /* Function: given a pointer to the component table entry for */ /* a given input object segment (compent_ptr), */ /* relocate the text section for that component, */ /* resolving all referenced links in the process, */ /* regenerate any unreferenced *system links. */ /* Then relocate the linkage section. Finally, we */ /* relocate any external references within the */ /* symbol section by generating a repatch table */ /* entry for it and then attempting to resolve the */ /* link. */ /* Output: none. */ /* */ /**********************************************************************/ /* Designed and initially coded by Michael J. Spier, September 30, 1970 */ /* modified 75.06.20 by M. Weaver for separate static */ /* modified 77.10.21 by M. Weaver to regenerate links when there is no text */ /* modified Dec 1978 by David Spector to make repatch table automatically extensible */ /* Modified 01/15/81 W. Olin Sibert to remove red shifts */ /* Modified September 82 JMAthane to relocate links referenced by symbol tables */ rebuild_object_: procedure (compent_ptr); declare compent_ptr pointer; /* DECLARATION OF EXTERNAL ENTRIES */ declare regenerate_all_links_ external entry (pointer); declare decode_link_ external entry (pointer) returns (bit (1) aligned); declare get_relinfo_ external entry (pointer); declare get_relinfo_$init external entry (pointer); declare ext_link_ external entry (pointer); declare generate_def_ external entry (pointer, pointer); declare int_link_ external entry (pointer) returns (bit (1) aligned); declare com_err_ external entry options (variable); declare temp_mgr_$allocate ext entry (fixed bin); declare temp_mgr_$reserve external entry (pointer); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare (textbase, defbase, intbase) pointer internal static initial (null); declare TRUE bit (1) static options (constant) init ("1"b); declare FALSE bit (1) static options (constant) init ("0"b); declare PR4 bit (3) static options (constant) init ("4"b3); declare LDA_INSTR bit (9) static options (constant) init ("235"b3); declare INDIRECT_TM bit (2) static options (constant) init ("01"b); declare INDIRECT_TD bit (4) static options (constant) init (""b); declare SPECIAL_CASE (4) bit (18) aligned static options (constant) init ("551"b3, /* stba */ "552"b3, /* stbq */ "751"b3, /* stca */ "752"b3); /* stcq */ declare errname char (16) aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare (i, textoffset, intoffset, int_reloc_offset, symboffset, textend, val, lng, intlimit, relocate) fixed bin (18); declare (wordp, argp, extp, sp, p, intp) pointer; declare (textptr, defptr) pointer; declare opcode bit (18) aligned; declare 1 ext aligned like external_ref; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, fixed, hbound, null, size) builtin; /* DECLARATION OF BASED STRUCTURES */ declare 1 word aligned based (wordp), 2 lhe18 bit (18) unaligned, 2 rhe18 bit (18) unaligned; declare 1 instr aligned based, 2 lp bit (3) unaligned, 2 lp_offset bit (15) unaligned, 2 op_code bit (9) unaligned, 2 op_code_extension bit (1) unaligned, 2 inhibit bit (1) unaligned, 2 use_pr bit (1) unaligned, 2 tm bit (2) unaligned, 2 td bit (4) unaligned; declare 1 word_instr aligned based (wordp) like instr; declare internal_static (lng) fixed bin based (p); /* */ ctp = bx_$ctp; ext.compent_ptr, ctep = compent_ptr; /* copy argument into stack for efficiency */ val = 0; /* reset conversion variable */ extp = addr (ext); /* get address of external ref structure */ call get_relinfo_$init (comp.crltp); /* initialize relocation bit scanner */ argp = addr (ext.offset); textoffset = comp.crelt; /* get relocation value for text section */ intoffset = comp.creli; /* copy relocation value for internal static */ symboffset = comp.crels; /* copy relocation value for symbol section */ textptr = addrel (textbase, textoffset); /* compute pointer to text section */ textend = comp.clngt; /* and get length of section */ int_reloc_offset = intoffset; if comp.separate_static = 0 then intlimit = comp.clngi + 8; /* offset of links within linkage sectioon */ else do; intlimit = 8; /* sep static doesn't have relocation bits */ if bx_$bound_sep_stat = 0 then int_reloc_offset = int_reloc_offset + 8;/* in this case, refs to static are shifted to link */ end; defptr = comp.cdefp; /* copy pointer to definition section */ ext.section = "text"; /* indicate referencing section */ if comp.clngt = 0 then /* no text to relocate; regenerate links anyway */ goto copy_unresolved_links; ext.dont_relocate = "0"b; relocate_text: call get_relinfo_ (argp); /* get next non-absolute relocation code */ if ext.relinfo = "overflow" then goto copy_unresolved_links; if ext.offset >= textend then goto copy_unresolved_links; /* end of text section */ /* First process text-to-text references */ ext.ref_ptr, wordp = addrel (textptr, ext.offset);/* compute pointer to specified word */ if ext.side = "lhe" then relocate = fixed (word.lhe18, 18); else relocate = fixed (word.rhe18, 18); if ext.relinfo = "text " then /* relocate by text relocation counter */ do; relocate = relocate + textoffset; goto restore_text; end; /* Now process references to the linkage section */ else if ext.relinfo = "lnk18 " then do; ext.loffset = relocate; if decode_link_ (extp) = "1"b then goto error_skip; call ext_link_ (extp); goto relocate_text; end; else if ext.relinfo = "int18 " then do; relocate = relocate + int_reloc_offset; goto restore_text; end; else if ext.relinfo = "symb " then do; relocate = relocate + symboffset; goto restore_text; end; else if ext.relinfo = "int15 " then do; if ext.side ^= "lhe" then do; wrong_halfword: call com_err_ (0, errname, "relocation ^a illegal for right half of word ^o in text of ^a", ext.relinfo, ext.offset, comp.filename); goto error_skip; end; relocate = fixed (word_instr.lp_offset, 15); relocate = relocate + int_reloc_offset; word_instr.lp_offset = bit (bin (relocate, 15), 15); goto relocate_text; end; else if ext.relinfo = "lnk15 " then do; if ext.side ^= "lhe" then goto wrong_halfword; if word_instr.use_pr ^= "1"b then do; illegal_link15: call com_err_ (0, errname, "illegal instruction format word ^o in text of ^a", ext.offset, comp.filename); goto error_skip; end; opcode = word_instr.op_code; do i = 1 to 4; if opcode = SPECIAL_CASE (i) then goto illegal_link15; end; if word_instr.tm = "10"b then goto illegal_link15; /* indirect and tally */ if word_instr.tm ^= "11"b then /* indirect then index is OK */ if word_instr.td ^= "0000"b then goto illegal_link15; ext.loffset = fixed (word_instr.lp_offset, 15); ext.dont_prelink = "0"b; if decode_link_ (extp) = "1"b then goto error_skip; if ext.trap ^= "0"b then if bin (ext.type, 18) ^= 6 then ext.dont_prelink = "1"b; /* trap is just offset of init struc for type 6 */ /* if link target is found, trapping isn't necessary */ if int_link_ (extp) = "1"b then goto relocate_text; call ext_link_ (extp); goto relocate_text; end; else if ext.relinfo = "negtext " then do; relocate = -1; if ext.side = "lhe" then addr (relocate) -> word.rhe18 = word.lhe18; else addr (relocate) -> word.rhe18 = word.rhe18; relocate = relocate + textoffset; goto restore_text; end; else if ext.relinfo = "def " then do; p = comp.insymentp; do i = 1 to p -> insym.n_insyms - 1; /* try to find def being referenced */ if p -> entry (i).def_offset = relocate then do; /* have matching def */ call generate_def_ (ctep, addr (p -> insym.entry (i))); /* this def has to be regenerated */ if ext.side = "lhe" then word.lhe18 = comp.current_def; else word.rhe18 = comp.current_def; goto relocate_text; end; end; call com_err_ (0, errname, "def|^o referenced by text|^o of ^a^/^-is not the beginning of a definition", relocate, ext.offset, comp.filename); goto error_skip; end; else if ext.relinfo = "selfrel " then goto relocate_text; /* treat self-relative as absolute */ call com_err_ (0, errname, "relocation ^a illegal for word ^o in text of ^a", ext.relinfo, ext.offset, comp.filename); error_skip: bx_$fatal_error = 1; goto relocate_text; restore_text: if ext.side = "lhe" then word.lhe18 = addr (relocate) -> word.rhe18; else word.rhe18 = addr (relocate) -> word.rhe18; goto relocate_text; copy_unresolved_links: call regenerate_all_links_ (ctep); /* regenerate all links not already covered */ lng = comp.clngi; /* get length of internal static section */ if lng = 0 then goto relocate_symbol; /* no internal static for this component */ intp = addrel (bx_$tintp, intoffset); /* pointer to new IS location */ intp -> internal_static = comp.cstatp -> internal_static; if intlimit = 8 then goto relocate_symbol; /* there's nothing in linkage to relocate */ call get_relinfo_$init (comp.crllp); /* initiate search of rel_link */ relocate_linkage: call get_relinfo_ (argp); if ext.relinfo = "overflow" then goto relocate_symbol; if ext.offset < 8 then goto relocate_linkage; if ext.offset >= intlimit then goto relocate_symbol; wordp = addrel (intp, ext.offset - 8); /* pointer to relocatable word */ if ext.side = "lhe" then relocate = fixed (word.lhe18, 18); else relocate = fixed (word.rhe18, 18); if ext.relinfo = "text " then do; relocate = relocate + textoffset; goto restore_linkage; end; else do; call com_err_ (0, errname, "relocation ^a illegal for word ^o in linkage of ^a", ext.relinfo, ext.offset, comp.filename); bx_$fatal_error = 1; goto relocate_linkage; end; restore_linkage: if ext.side = "lhe" then word.lhe18 = addr (relocate) -> word.rhe18; else word.rhe18 = addr (relocate) -> word.rhe18; goto relocate_linkage; relocate_symbol: sp = comp.csymp; ext.section = "symb"; call get_relinfo_$init (comp.crlsp); lng = comp.clngns; ext.offset = 0; do while (ext.offset <= lng); /* relocate symbol tree */ call get_relinfo_ (argp); /* get next relocation code */ if ext.relinfo = "overflow" then goto done; if ext.offset > lng then goto done; /* get_relinfo_ doesn't know about removal of symbtree */ val = 0; if ext.relinfo ^= "lnk18 " then goto skip_this; /* check only for external refs */ wordp = addrel (sp, ext.offset); if ext.side = "lhe" then addr (val) -> word.rhe18 = word.lhe18; else addr (val) -> word.rhe18 = word.rhe18; rptp = bx_$last_rptp; i, rpt.npt = rpt.npt + 1; /* increment size of repatch table */ if i = hbound (rpt.entry, 1) then do; /* Allocate new chunk of repatch table */ call temp_mgr_$allocate (size (rpt)); p = bx_$freep; bx_$last_rptp = p; rpt.thread = p; call temp_mgr_$reserve (addrel (p, size (rpt))); p -> rpt.thread = null; p -> rpt.npt = 0; end; rptep = addr (rpt.entry (i)); /* pointer to new repatch table entry */ rpte.pbase = "s"; /* patching relative to symbol section */ rpte.code = "t"; /* patch with 0 relocation value */ rpte.poffset = bit (bin ((ext.offset + comp.crels), 18), 18); rpte.halfword = ext.side; /* get halfword to patch */ ext.loffset = val; /* store offset of referenced link */ val = 0; ext.ref_ptr = addr (val); if decode_link_ (extp) = "1"b then goto skip_this; /* A symbol table reference to an external must always have a link associated with it. But if the external reference is to another component, the link is converted to a type 1 link to the other component's text or linkage section. This avoids having to retain segdefs and add segment names that aren't otherwise needed. */ /* create a "lda 4|nn,*" instruction */ addr (val) -> word.lhe18 = addr (val) -> word.rhe18; addr (val) -> instr.lp = PR4; addr (val) -> instr.op_code = LDA_INSTR; addr (val) -> instr.op_code_extension = FALSE; addr (val) -> instr.inhibit = FALSE; addr (val) -> instr.use_pr = TRUE; addr (val) -> instr.tm = INDIRECT_TM; addr (val) -> instr.td = INDIRECT_TD; ext.dont_prelink = "0"b; ext.side = "lhe"; ext.relinfo = "link15"; ext.section = "text"; ext.offset = 0; ext.dont_relocate = "0"b; if int_link_ (extp) = "1"b then do; if (addr (val) -> instr.tm = "00"b) & (addr (val) -> instr.td = "0000"b) & (^addr (val) -> instr.use_pr) then do; /* relocated to "lda nn" */ ext.segname = "*text"; ext.code15 = "0"b; end; else if (addr (val) -> instr.tm = "00"b) & (addr (val) -> instr.td = "0000"b) & (addr (val) -> instr.use_pr) & (addr (val) -> instr.lp = PR4) then do; /* relocated to "lda 4|nn" */ ext.segname = "*link"; ext.code15 = "000000000000000001"b; end; else goto external_link; ext.slng = 6; ext.elng = 0; ext.type = "000000000000000001"b; addr (val) -> instr.lp = "000"b; ext.expr = addr (val) -> word.lhe18; ext.link_tm, ext.link_td = "0"b; end; external_link: ext.section = "symb"; addr (val) -> instr.lp = "000"b; call ext_link_ (extp); /* and regenerate the very same link */ if ext.side = "lhe" /* and store in repatch table */ then rpte.pexpr = addr (val) -> word.lhe18; else rpte.pexpr = addr (val) -> word.rhe18; skip_this: end; done: return; init: entry; textbase = bx_$temp_bsegp; /* pointer to base of new text section */ defbase = bx_$tdefp; /* pointer to base of new definition section */ intbase = bx_$tintp; /* pointer to base of new internal static section */ if bx_$debug = 1 then errname = "rebuild_object_"; else errname = bx_$caller; return; %page; %include extref; %page; %include bindext; %page; %include comptbl; %page; %include insym; %page; %include bndtbl; end rebuild_object_;  regenerate_all_links_.pl1 07/16/86 1217.0rew 07/16/86 0846.6 21240 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Rewritten to regenerate any *system links remaining unresolved in the link_regeneration_table rather than all links in the linkage section. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ regenerate_all_links_: proc (ctep); /**********************************************************************/ /* */ /* Name: regenerate_all_links_ */ /* Input: ctep (component table entry pointer) */ /* Function: scans the link_regeneration_table for the given */ /* component and regenerates any link that has not */ /* already been regenerated. This is primarily used */ /* to pick up unreferenced *system links for fortran */ /* block_data subprograms. */ /* Output: none */ /* */ /**********************************************************************/ dcl i fixed bin; dcl extp ptr; dcl addr builtin; dcl fixed builtin; dcl decode_link_ entry (ptr) returns (bit (1) aligned); dcl ext_link_ entry (ptr); dcl 1 ext aligned like external_ref; /* */ %include extref; /* */ %include comptbl; /* */ %include linkdcl; /* */ %include bndtbl; /* */ extp = addr (ext); lrtp = comp.clrtp; ext.compent_ptr = ctep; ext.section = "none"; ext.offset = 0; ext.dont_relocate = "1"b; ext.ref_ptr = comp.clnkp; /* initialize so ext_link_ won't blow up */ do i = 1 to lrt.count; if lrt.regenerated (i) = UNRESOLVED then do; ext.loffset = lrt.start_offset + ((i - 1) * 2); if ^decode_link_ (extp) then if (fixed (ext.type, 18) = 5) & (fixed (ext.code15, 18) = 5) then call ext_link_ (extp); end; end; end regenerate_all_links_;  relocate_symbol_.pl1 07/16/86 1217.0rew 07/16/86 0846.9 67185 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and readability, changed errname to use the caller-supplied name instead of "binder_" END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ relocate_symbol_: procedure; /* modified 6/75 by M. Weaver for separate static */ /* modified 11/76 by M. Weaver to clean up symbol tree thread */ /* Modified 01/15/81 W. Olin Sibert to remove red shifts */ /**********************************************************************/ /* */ /* Name: relocate_symbol_ */ /* Input: none */ /* Function: copies the symbol sections of the input object */ /* segments into the new bound object segment and */ /* relocates the references. */ /* Output: none */ /* */ /**********************************************************************/ /* source map and user_id are actually filled in by make_bindmap_ */ /* since they, like the bindmap, are variable and are put at the */ /* end of the symbol section */ /* DECLARATION OF EXTERNAL ENTRIES */ declare com_err_ external entry options (variable); declare bx_$symbol_table external fixed bin; declare clock_ external entry () returns (fixed bin (71)); declare get_relinfo_$init external entry (ptr); declare get_relinfo_ external entry (ptr); /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, addrel, bin, bit, substr, string) builtin; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare i fixed bin; declare (previous_length, lng, relocate) fixed bin; declare (textoffset, intoffset, symboffset) fixed bin (18); declare (p, sblkp, previous_block, wordp, pl1_sbp) pointer; declare errname char (16) aligned; declare 1 ext aligned, 2 offset fixed bin, 2 side char (3) aligned, 2 relinfo char (8) aligned; /* DECLARATION OF BASED STRUCTURES */ declare 1 word aligned based (wordp), 2 lhe18 bit (18) unaligned, 2 rhe18 bit (18) unaligned; declare 1 pl1_sb aligned like pl1_symbol_block based (pl1_sbp); declare vers_string char (10000) aligned based; declare symbolsection (lng) fixed bin based; /* */ if bx_$debug = 1 then errname = "relocate_symbol_"; else errname = bx_$caller; ctp = bx_$ctp; /* copy pointer to component table */ /* Make a symbol section header for the new bound object */ /* IMPORTANT: length of this header is preset in 'relocate_symbol_$init' and must not be exceeded unless its preset length is accordingly modified */ sblkp = bx_$bsymp; /* copy pointer to symbol section */ sb.decl_vers = 1; sb.identifier = "bind_map"; sb.gen_version_number = bx_$vers_number; p = addr (bx_$symbol_table); /* ptr to binder's own symbol table */ sb.gen_creation_time = p -> sb.obj_creation_time; /* get creation date of executing binder */ sb.obj_creation_time = clock_ (); sb.generator = "binder"; sb.gen_name_offset = bit (bin (20, 18), 18); lng = bx_$v_lng; sb.gen_name_length = bit (bin (lng, 18), 18); substr (addrel (sblkp, 20) -> vers_string, 1, lng) = substr (bx_$vers_name, 2, lng); p = ctp -> comp_tbl (1) -> comp.csymp; /* get ptr to first component's symbol section */ sb.tbound = p -> sb.tbound; /* use tbound of first component */ sb.stat_bound = p -> sb.stat_bound; /* same with stat_bound */ sb.symb_base = "0"b; /* this is first block in symbol section */ /* the rest of the header items are filled in by make_bindmap_ */ /* Now move all symbol tables over and relocate them */ previous_length = bx_$s_lng; previous_block = sblkp; i = 0; copy_tables: i = i + 1; if i > bx_$ncomp then goto return; /* all components processed */ ctep = comp_tbl (i); /* pointer to component entry */ if comp.ignore = 1 then goto copy_tables; sblkp = addrel (bx_$bsymp, bx_$s_lng); /* pointer to location of new section */ lng = comp.clngns; /* length of section to be copied */ sblkp -> symbolsection = comp.csymp -> symbolsection; /* copy symbol section */ sblkp -> sb.symb_base = bit (-bin (bx_$s_lng, 18), 18); textoffset = comp.crelt; intoffset = comp.creli; if bx_$bound_sep_stat = 0 then if comp.separate_static = 1 then intoffset = intoffset + 8; /* must account for linkage header */ symboffset = comp.crels; /* copy relocation counter values */ call get_relinfo_$init (comp.crlsp); /* initiate relocation bit lookup */ ext.offset = 0; relocate_table: call get_relinfo_ (addr (ext)); if relinfo = "overflow" then goto thread_blocks; if ext.offset > lng then goto thread_blocks; wordp = addrel (sblkp, ext.offset); /* pointer to relocatable word */ if side = "lhe" then relocate = bin (word.lhe18, 18); else relocate = bin (word.rhe18, 18); if relinfo = "text " then do; relocate = relocate + textoffset; goto restore_halfword; end; else if relinfo = "lnk18 " then do; relocate = 0; /* zero out to be repatched */ goto restore_halfword; end; else if relinfo = "symb " then do; relocate = relocate + symboffset; goto restore_halfword; end; else if relinfo = "int18 " then do; relocate = relocate + intoffset; goto restore_halfword; end; else if relinfo = "negsymb " then do; relocate = -1; if side = "lhe" then addr (relocate) -> word.rhe18 = word.lhe18; else addr (relocate) -> word.rhe18 = word.rhe18; relocate = relocate + symboffset; goto restore_halfword; end; else if relinfo = "def " then do; call com_err_ (0, errname, "relocation ^a for word ^o in symbol of ^a not currently handled by binder", relinfo, ext.offset, comp.filename); goto relocate_table; end; else if relinfo = "selfrel " then goto relocate_table; call com_err_ (0, errname, "relocation ^a illegal for word ^o in symbol of ^a", relinfo, ext.offset, comp.filename); bx_$fatal_error = 1; goto relocate_table; restore_halfword: if side = "lhe" then word.lhe18 = addr (relocate) -> word.rhe18; else word.rhe18 = addr (relocate) -> word.rhe18; goto relocate_table; thread_blocks: previous_block -> sb.next_block = bit (bin (bx_$s_lng, 18), 18); previous_length = comp.clngns + comp.cpads; bx_$s_lng = bx_$s_lng + previous_length; previous_block = sblkp; if comp.table_deleted = 1 /* symbol section has been truncated */ then if sblkp -> sb.area_ptr then do; pl1_sbp = addrel (sblkp, sblkp -> sb.area_ptr); if pl1_sb.identifier = "pl1info" then do; /* don't leave dangling thread */ pl1_sb.root = "0"b; string (pl1_sb.map) = "0"b; pl1_sb.flags.table_removed = "1"b; end; end; goto copy_tables; return: return; %page; %include bindext; %page; %include comptbl; %page; %include symbol_block; %page; %include pl1_symbol_block; end relocate_symbol_;  strm_hash_.pl1 07/16/86 1217.0rew 07/16/86 0846.5 50517 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation. END HISTORY COMMENTS */ /* External procedures to implement hash-coded lookup of the STRINGMAP table (strm). Sept 1978, David Spector. */ /* format: style3,^indnoniterdo */ make_entry: procedure (new_string, entry_nr); /**********************************************************************/ /* */ /* Name: strm_hash_$make_entry */ /* Input: new_string, entry_nr */ /* Function: stores a new entry into the strm hash table. */ /* Given a string (in ACC format) and the entry */ /* number in the hash table, calculate the hash */ /* function to determine the bucket and thread the */ /* new entry into the appropriate bucket. */ /* Each entry is a bit (18) relative offset in the */ /* definition section of the new object segment */ /* of a string (ACC format) being used in some */ /* definition. The hash table (strm.hash_table) */ /* contains fixed bin(17) array subscripts which */ /* point to the first strm.entry in the particular */ /* hash bucket of entries. Empty buckets are */ /* represented by zeros in the hash table. Each */ /* bucket contains a list of entries; the forward */ /* thread for the list is an array subscript */ /* (fixed bin(17)) in strm.entry.hash_thread for */ /* each entry in the bucket. The end of the list */ /* (or chain) of entries is marked by a hash thread */ /* of zero. */ /* Output: none */ /* */ /**********************************************************************/ declare new_string char (*); /* new entry's string */ declare trial_string char (*); declare entry_nr fixed binary (17); /* array subscript (location) of new entry */ declare hash_index fixed binary (34); /* array subscript of bucket in hash table */ declare bx_$strmp external ptr; /* global base of strm */ declare bx_$tdefp external ptr; /* global base of def section */ declare p ptr; declare defbase ptr; declare (addrel, length, substr) builtin; declare acc_string char (257) based; %include bndtbl; strmp = bx_$strmp; /* locate STRINGMAP table */ call hash_code (new_string, hash_index); /* hash code the string */ strm.entry (entry_nr).hash_thread = strm.hash_table (hash_index); /* push new entry into hash-code bucket */ strm.hash_table (hash_index) = entry_nr; return; lookup: entry (trial_string, entry_nr); /**********************************************************************/ /* */ /* Name: strm_hash_$lookup */ /* Input: trial_string */ /* Function: Given a string (trial_string) in ACC format, */ /* compute the hash function on it, and compare the */ /* trial string with each string in the bucket until */ /* a match is found or the bucket is exhausted. If */ /* the string is found, return the array subscript */ /* of the strm.entry. If not found, return zero. */ /* Output: entry_nr */ /* */ /**********************************************************************/ strmp = bx_$strmp; /* locate STRINGMAP table */ defbase = bx_$tdefp; /* locate base of def section */ call hash_code (trial_string, hash_index); /* hash code the string */ do entry_nr = strm.hash_table (hash_index) repeat strm.entry (entry_nr).hash_thread while (entry_nr ^= 0); /* search the hash-code bucket for the string */ p = addrel (defbase, strm.entry (entry_nr).map); /* locate strm string */ if substr (p -> acc_string, 1, length (trial_string)) = trial_string then return; /* success: entry_nr is non-zero */ end; /* continue scanning this bucket */ return; /* failure: entry_nr is zero */ hash_code: procedure (char_string, hash_index); /**********************************************************************/ /* */ /* Name: hash_code */ /* Input: char_string */ /* Function: given a character string, calculates the hash */ /* function and returns the array index of the first */ /* strm hash_table entry in the resulting bucket. */ /* Output: hash_index */ /* */ /**********************************************************************/ declare char_string char (*); /* input: string */ declare hash_index fixed binary (34); /* output: subscript of hash bucket */ declare pos fixed binary; declare (bin, hbound, length, min, mod, unspec) builtin; hash_index = 0; do pos = 1 to min (length (char_string), 24); /* prevent overflow of hash_index */ hash_index = 2 * hash_index + bin (unspec (substr (char_string, pos, 1)), 9); end; hash_index = mod (hash_index, hbound (strm.hash_table, 1) + 1); return; end; /* end of hash_code */ end; /* end of make_entry */  temp_mgr_.pl1 07/16/86 1217.0rew 07/16/86 0846.5 132993 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(85-09-24,Elhard), approve(85-09-24,MCR7198), audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094): Improved documentation and readability, changed errname to use the caller-supplied name instead of "binder_", changed make_object and close_files entrypoints to use a process dir temporary until binding is complete and then copy into the working dir. END HISTORY COMMENTS */ /* ****************************************************** * * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* procedure to do temporary database management for the binder. Designed and originally coded by Michael J. Spier, August 19, 1970 */ /* Modified 9/78 by David Spector to use get_temp_segment_ and release_temp_segment_ */ /* Note: -debug no longer stores temp segs in wdir! */ /* Modified 9/20/84 by M Sharpe to 1) use nd_handler_; 2) check for null pointers before using them; */ /* format: style3,^indnoniterdo */ temp_mgr_: procedure; /* DECLARATION OF EXTERNAL ENTRIES */ declare com_err_ external entry options (variable); declare error_table_$segnamedup external fixed bin (35); declare error_table_$namedup external fixed bin (35); declare error_table_$rqover external fixed bin (35); declare get_pdir_ external entry () returns (char (168)); declare get_wdir_ external entry () returns (char (168)); declare get_temp_segment_ external entry (char (*), ptr, fixed bin (35)); declare hcs_$chname_seg ext entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35)); declare initiate_file_$create ext entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); declare nd_handler_ ext entry (char (*), char (*), char (*), fixed bin (35)); declare release_temp_segment_ external entry (char (*), ptr, fixed bin (35)); declare sys_info$max_seg_size external fixed bin (19); declare terminate_file_ ext entry (ptr, fixed bin (24), bit (*), fixed bin (35)); declare tssi_$clean_up_segment entry (ptr); declare tssi_$get_segment external entry (char (*) aligned, char (*) aligned, pointer, ptr, fixed bin (35)); declare tssi_$finish_segment external entry (pointer, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ declare pdir char (168) internal static initial (""); declare wdir char (168) aligned internal static initial (" "); declare limit fixed bin (18) internal static; declare mask bit (36) aligned internal static initial ("000000000000000000111111111111111000"b); declare errname char (16) aligned internal static; /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */ declare bound_segl fixed bin (21); declare bound_segp ptr; declare created bit (1) aligned; declare offset fixed bin (18); declare i fixed bin; declare code fixed bin (35); declare (p, sp, ip) pointer; declare segname char (32) aligned; /* DECLARATION OF BUILTIN FUNCTIONS */ declare (addr, divide, null, ptr, rel, rtrim, substr) builtin; /* DECLARATION OF CONDITIONS */ declare cleanup condition; declare record_quota_overflow condition; /* DECLARATION OF BASED STRUCTURES */ declare 1 temp_seg based aligned, /* format of temp segments */ 2 next_temp_ptr ptr, /* ptr to next chained temp seg */ 2 storage bit (0); /* start of temp_mgr_ storage */ declare bound_seg char (bound_segl) based; declare 1 offset_overlay aligned based (addr (offset)), 2 dum bit (18) unaligned, 2 relp bit (18) unaligned; declare offset_bits bit (36) aligned based (addr (offset)); %include access_mode_values; %page; %include terminate_file; %page; reserve: entry (last_used); /**********************************************************************/ /* */ /* Name: temp_mgr_$reserve */ /* Input: last_used */ /* Function: reserves a block of storage from the current */ /* address pointed to by bx_$freep to the address */ /* pointed to by last_used and realigns bx_$freep */ /* to a 0 mod 8 boundary. If the new value for */ /* bx_$freep is past a preset limit, a new temp_seg */ /* is procured and chained in and bx_$freep set to */ /* point to the start of it's storage area. */ /* NB. Since no guarantees can be made about the */ /* amount of space remaining in the temp_seg */ /* temp_mgr_$allocate should be called prior */ /* to calling temp_mgr_$reserve to insure that */ /* sufficient space is available. */ /* Output: none */ /* */ /**********************************************************************/ declare last_used pointer; offset = 0; /* preset to zero */ offset_overlay.relp = rel (last_used); /* get offset of last-used location */ offset = offset + 7; /* make new offset 0 mod 8 */ offset_bits = offset_bits & mask; /* ... */ if offset <= limit then /* segment not yet overflowing */ do; /* generate new free pointer */ bx_$freep = ptr (last_used, offset_overlay.relp); return; end; /* arrived here we have an overflowing temporary segment, and must create a new one */ create_temp: /* Initialize a new temp segment. bx_$temp contains a pointer (initially null) to the latest temp seg. Each temp seg contains a pointer to the previous one in the list. Exact format is described by declaration for "temp_seg". */ call get_temp_segment_ ("bind", p, code); if code ^= 0 then do; call com_err_ (code, errname, "unable to create temporary segment."); bx_$fatal_error = 1; return; end; /* Push new temp segment onto chained list of temp segs, for later releasing. */ p -> temp_seg.next_temp_ptr = bx_$temp; bx_$temp = p; /* Initialize for storing into space following the fwd ptr. */ bx_$freep = addr (bx_$temp -> temp_seg.storage); return; allocate: entry (area_size); declare area_size fixed bin; /**********************************************************************/ /* */ /* Name: temp_mgr_$allocate */ /* Input: area_size */ /* Function: checks to make sure that words can be */ /* allocated within the current temp_seg, and gets a */ /* new one if not. */ /* Output: none */ /* */ /**********************************************************************/ offset = 0; offset_overlay.relp = rel (bx_$freep); /* get current offset */ if offset + area_size <= limit then return; /* there is enough room for area */ goto create_temp; /* go make another temporary */ %page; close_files: entry; /**********************************************************************/ /* */ /* Name: temp_mgr_$close_files */ /* Input: none */ /* Function: copies the process directory copy of the bound */ /* object segment into the working dir and adds the */ /* appropriate names to the new object segment. */ /* If an Addname statement occurred in the bindfile */ /* add the given names if any were given or add the */ /* names off all retained entrypoints if no names */ /* were specified. The object segment bit count and */ /* acl are set and the temp_segs are released. */ /* Output: none */ /* */ /**********************************************************************/ bx_$bseg_acinfop = null; bound_segp = null; if bx_$fatal_error ^= 0 then do; call close_file_cleanup (); return; /* forget the rest */ /* save the bad version */ end; /* move the new bound object from the pdir temporary into the final */ /* working dir copy. */ on cleanup begin; call close_file_cleanup (); end; /* create the working dir copy of the bound object segment */ call tssi_$get_segment (wdir, bx_$bound_segname, bound_segp, bx_$bseg_acinfop, code); if code ^= 0 then do; call com_err_ (code, errname, "^/Unable to create ^a, a copy exists in [pd]>^a", bx_$bound_segname, bx_$bound_segname); bx_$fatal_error = 1; call close_file_cleanup (); return; end; /* if a record quota overflow occurs while we are copying, print */ /* a message indicating that an intact copy of the bound segment is */ /* available in the process directory, and then abort. */ on record_quota_overflow begin; call com_err_ (error_table_$rqover, errname, "^/Unable to complete ^a, a copy exists in [pd]>^a", bx_$bound_segname, bx_$bound_segname); call close_file_cleanup; /* clean up what would have been the final version */ goto close_file_return; end; /* calculate the length of the bound segment expressed in terms of */ /* characters for the string overlay copy operation. */ bound_segl = divide (bx_$bseg_bitcount, 9, 21, 0); /* copy the new bound segment into the working dir copy */ bound_segp -> bound_seg = bx_$temp_bsegp -> bound_seg; revert record_quota_overflow; bx_$bsegp = bound_segp; /* now operate on the real thing */ /* now delete the copy of the bound object in the process dir */ call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, code); bx_$temp_bsegp = null; /* done with this */ /* add the appropriate synonyms to the bound segment */ if bx_$addname = 1 then do; adnp = bx_$adnp; /* add all names explicitly asked for by Addname statement by */ /* direct extraction from the addname table. */ if an.n_an > 0 then do i = 1 to an.n_an; segname = an.syn (i); call Addname; end; /* add names specified by implicit addname (ie. "Addname;") by */ /* scanning the segname table, and for each component, scanning the */ /* definition list for retained definitions and adding the name of */ /* the definition to the bound segment. */ else do i = 1 to bx_$sntp -> snt.n_names; sp = addr (bx_$sntp -> snt.entry (i)); ip = sp -> seg.comp -> comp.insymentp; if ip -> insym.retained = "1"b then do; segname = substr (sp -> seg.name, 2, sp -> seg.lng - 1); call Addname; end; end; end; /* finished processing Addname */ do p = bx_$temp repeat bx_$temp while (p ^= null); bx_$temp = p -> temp_seg.next_temp_ptr; call release_temp_segment_ ("bind", p, code); end; if bx_$bseg_acinfop ^= null then call tssi_$finish_segment (bx_$bsegp, bx_$bseg_bitcount, "1100"b, bx_$bseg_acinfop, code); close_file_return: return; close_file_cleanup: proc (); if bx_$bseg_acinfop ^= null then call tssi_$clean_up_segment (bx_$bseg_acinfop); /* Return all temp segments to free pool. */ do p = bx_$temp repeat bx_$temp while (p ^= null); bx_$temp = p -> temp_seg.next_temp_ptr; call release_temp_segment_ ("bind", p, code); end; return; end close_file_cleanup; %page; init: entry; /**********************************************************************/ /* */ /* Name: temp_mgr_$init */ /* Input: none */ /* Function: sets up the name for error messages and the limit */ /* on how full temp_segs will be allowed to grow. */ /* It then creates the first temp_seg. */ /* Output: none */ /* */ /**********************************************************************/ if bx_$debug = 1 then errname = "temp_mgr_"; else errname = bx_$caller; wdir = get_wdir_ (); /* get name of working directory */ pdir = get_pdir_ (); /* get name of process directory */ if sys_info$max_seg_size <= 65536 then limit = sys_info$max_seg_size - 8192; else limit = sys_info$max_seg_size - 16384; /* Slack in temporary will be 8K when 64K segments are maximum */ /* and will be 16K when 256K segments are maximum. */ bx_$temp = null; /* Clear list of temp segments. */ goto create_temp; make_object: entry; /**********************************************************************/ /* */ /* Name: temp_mgr_$make_object */ /* Input: none */ /* Function: creates a working copy of the new object in the */ /* process directory with the name specified by */ /* bx_$bound_segname and saves the segment pointer */ /* Output: none */ /* */ /**********************************************************************/ bx_$bseg_acinfop = null; call initiate_file_$create (pdir, (bx_$bound_segname), RW_ACCESS, bx_$temp_bsegp, created, (0), code); if code ^= 0 then do; call com_err_ (code, errname, "unable to create temporary copy of ^a", bx_$bound_segname); bx_$fatal_error = 1; return; end; if ^created then do; call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_TRUNC, code); if code ^= 0 then do; call com_err_ (code, errname, "unable to truncate temporary copy of ^a", bx_$bound_segname); bx_$fatal_error = 1; return; end; end; bx_$bsegp = bx_$temp_bsegp; /* bind into the temp */ return; Addname: procedure; /**********************************************************************/ /* */ /* Name: Addname */ /* Input: none */ /* Function: adds the name specified by the global variable */ /* segname to the output object segment. If the */ /* name is on another segment, the nd_handler_ is */ /* called to take care of things. */ /* Output: none */ /* */ /**********************************************************************/ TRY_ADDNAME: call hcs_$chname_seg (bx_$bsegp, "", segname, code); /* add name to the bound segment */ if code ^= 0 then do; /* this is a name duplication */ if code = error_table_$segnamedup then ; /* do nothing if seg already has the addname */ else if code = error_table_$namedup /* normal handling for name duplication */ then do; call nd_handler_ ((bx_$caller), rtrim (wdir), (segname), code); if code = 0 then go to TRY_ADDNAME; end; end; end Addname; %page; %include bindext; %page; %include bndtbl; %page; %include comptbl; %page; %include insym; end temp_mgr_; 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