le.pl1 01/05/87 1316.0rew 01/05/87 1305.9 286893 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written as the command interface to le. 2) change(86-12-19,Elhard), approve(86-12-19,PBF7505), audit(86-12-22,DGHowe), install(87-01-05,MR12.0-1256): Changed to use "linkage_editor" in error messages rather than "le". END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ linkage_editor: le: proc; /*** ****************************************************************/ /*** */ /*** Name: linkage_editor, le */ /*** Syntax: le paths {-control_args} */ /*** Function: le is the command interface to the le_ linkage */ /*** editor subroutine. Its function is to parse the */ /*** command line arguments and create the le_ input */ /*** structure. */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl ARCHIVE_SUFFIX char (8) static options (constant) init (".archive"); /* procedures */ dcl archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl le_ entry (ptr, fixed bin, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (194)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); /* external */ dcl error_table_$bad_conversion external fixed bin (35); dcl error_table_$badopt external fixed bin (35); dcl error_table_$dirseg external fixed bin (35); dcl error_table_$msf external fixed bin (35); dcl error_table_$noarg external fixed bin (35); dcl error_table_$nomatch external fixed bin (35); dcl le_data_$version_string external char (64) varying; dcl le_et_$too_many_options external fixed bin (35); dcl sys_info$max_seg_size external fixed bin (35); dcl linkage_editor_severity_ external fixed bin (35); /* based */ dcl arg char (argl) based (argp); dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; /* automatic */ dcl argl fixed bin (21) automatic; dcl argp ptr automatic; dcl argx fixed bin automatic; dcl ec fixed bin (35) automatic; dcl has_delete bit (1) automatic; dcl has_global bit (1) automatic; dcl has_retain bit (1) automatic; dcl i fixed bin automatic; dcl leip ptr automatic; dcl nargs fixed bin automatic; dcl severity fixed bin automatic; dcl version_flag bit (1) automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl after builtin; dcl before builtin; dcl binary builtin; dcl currentsize builtin; dcl divide builtin; dcl index builtin; dcl length builtin; dcl null builtin; dcl rtrim builtin; dcl size builtin; dcl string builtin; dcl substr builtin; dcl unspec builtin; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ /* make sure that the le_info temp seg goes away on a release */ leip = null; on cleanup begin; if leip ^= null then call release_temp_segment_ ("le", leip, ec); end; /* see how many arguments we have */ call cu_$arg_count (nargs, ec); if ec ^= 0 then call abort (ec, ""); /* print a usage message if invoked with no arguments */ if nargs = 0 then call abort (0, "Usage: le path{s} {-control_args}"); call get_temp_segment_ ("le", leip, ec); /* set up default values */ lei.version = le_input_version_1; lei.header.name = "linkage_editor"; lei.output_file.dir = get_wdir_ (); lei.output_file.entry = "a.out"; lei.abort_severity = 3; lei.display_severity = 0; lei.component_size = 255; lei.bindfile.name = ""; lei.bindfile.dt_updated = 0; lei.bindfile.dt_modified = 0; string (lei.header.flags) = ""b; lei.flags.auto_segnames = true; version_flag = true; has_global = false; has_retain = false; has_delete = false; /* scan through the arguments and process them */ argx = 1; do while (argx <= nargs); /* read the argument */ call cu_$arg_ptr (argx, argp, argl, ec); /* first handle input pathnames */ if index (arg, "-") ^= 1 then do; /* evaluate path as seg/dir/archive/starname/archive_starname */ call expand_le_path (PATH, arg, leip, ec); if ec ^= 0 then call abort (ec, arg); end; /* now handle library paths and other ctl args which take arguments */ else if arg = "-library" | arg = "-lb" then do; /* make sure there is a next argument */ if argx = nargs then call abort (error_table_$noarg, "library specification expected."); /* get the next argument */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* expand pathname into discrete option entries */ call expand_le_path (LIBRARY, arg, leip, ec); if ec ^= 0 then call abort (ec, arg); end; else if arg = "-retain" | arg = "-ret" then do; has_retain = true; /* if there is no next argument, treat as global retain */ if argx = nargs then call add_ep (RETAIN, "", false, leip, ec); else do; /* otherwise fetch the next argument */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* if it is another control arg, treat as global retain */ /* and back up the argument count so the next control arg */ /* gets processed properly. */ if index (arg, "-") = 1 then do; call add_ep (RETAIN, "", false, leip, ec); argx = argx - 1; end; /* otherwise, add a retain for the entrpoint specified */ else call add_ep (RETAIN, arg, false, leip, ec); end; end; else if arg = "-delete" | arg = "-dl" then do; has_delete = true; /* if there is no next arg, treat as a global delete */ if argx = nargs then call add_ep (DELETE, "", false, leip, ec); else do; /* otherwise, fetch the next argument */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* if it is a control argument, treat as a global delete */ /* and back up the arg index so the next arg is processed */ /* properly. */ if index (arg, "-") = 1 then do; call add_ep (DELETE, "", false, leip, ec); argx = argx - 1; end; /* otherwise, add the delete option for the given entrypoint */ else call add_ep (DELETE, arg, false, leip, ec); end; end; else if arg = "-output_file" | arg = "-of" then do; /* make sure there is a next argument */ if argx = nargs then call abort (error_table_$noarg, "Output file pathname expected."); /* fetch the output filename */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* expand it to a dirname and entryname */ call expand_pathname_ (arg, lei.output_file.dir, lei.output_file.entry, ec); if ec ^= 0 then call abort (ec, arg); end; else if arg = "-component_size" | arg = "-compsz" then do; /* make sure there is a next argument */ if argx = nargs then call abort (error_table_$noarg, "Component size expected."); /* fetch the component size */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* try converting it and make sure it is a number */ lei.component_size = cv_dec_check_ (arg, ec); if ec ^= 0 then call abort (error_table_$bad_conversion, arg); /* make sure it is in the range 4-255 */ if lei.component_size > 255 | lei.component_size < 4 then call abort (error_table_$badopt, "-component_size " || arg); end; else if arg = "-display_severity" | arg = "-dsv" then do; /* make sure there is a next argument */ if argx = nargs then call abort (error_table_$noarg, "Display severity expected."); /* fetch the severity */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* try converting it and make sure it is a number */ lei.display_severity = cv_dec_check_ (arg, ec); if ec ^= 0 then call abort (error_table_$bad_conversion, arg); /* make sure it is in the range 1 - 5 */ if lei.display_severity > 5 | lei.display_severity < 1 then call abort (error_table_$badopt, "-display_severity " || arg); end; else if arg = "-abort_severity" | arg = "-asv" then do; /* make sure there is a next argument */ if argx = nargs then call abort (error_table_$noarg, "Abort severity expected."); /* fetch the severity */ argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, ec); /* try converting it and make sure it is a number */ lei.abort_severity = cv_dec_check_ (arg, ec); if ec ^= 0 then call abort (error_table_$bad_conversion, arg); /* make sure it is in the range 0 - 3 */ if lei.abort_severity > 3 | lei.abort_severity < 0 then call abort (error_table_$badopt, "-abort_severity " || arg); end; /* now handle args with no parameters */ else if arg = "-force" | arg = "-fc" then lei.flags.force = true; else if arg = "-no_force" | arg = "-nfc" then lei.flags.force = false; else if arg = "-list" | arg = "-ls" then do; lei.flags.list = true; lei.flags.map = false; end; else if arg = "-map" then do; lei.flags.map = true; lei.flags.list = false; end; else if arg = "-no_list" | arg = "-nls" then do; lei.flags.map = false; lei.flags.list = false; end; else if arg = "-version" | arg = "-vers" then version_flag = true; else if arg = "-no_version" | arg = "-nvers" then version_flag = false; else if arg = "-debug" | arg = "-db" then lei.flags.debug = true; else if arg = "-no_debug" | arg = "-ndb" then lei.flags.debug = false; else if arg = "-auto_segnames" | arg = "-asn" then lei.flags.auto_segnames = true; else if arg = "-no_auto_segnames" | arg = "-nasn" then lei.flags.auto_segnames = false; else call abort (error_table_$badopt, arg); argx = argx + 1; end; /* make sure everything is kosher, and fill in things like the */ /* component that a given entrypoint is found in. */ call validate_opts (leip); /* print the version message if requested */ if version_flag then call ioa_ ("^a", le_data_$version_string); /* call le_ to actually assemble the new binary */ call le_ (leip, severity, ec); linkage_editor_severity_ = severity; if ec ^= 0 then do; call ioa_ ("^/An error of severity ^d has occurred.", severity); call abort (ec, ""); end; /* release the temp segment if required */ ABORT: if leip ^= null then do; /* terminate all of the files initiated */ do i = 1 to lei.n_opts; if lei.opt (i).type = PATH | lei.opt (i).type = LIBRARY then call terminate_file_ (lei.opt (i).optp, lei.opt (i).bc, TERM_FILE_TERM, ec); end; call release_temp_segment_ ("le", leip, ec); leip = null; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ expand_le_path: proc (type, /** PATH or LIBRARY (in ) */ path, /** path to expand (in ) */ leip, /** le_info pointer (i/o) */ ec); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: expand_le_path */ /*** Input: type, path, leip */ /*** Function: given a le input or library path specification, */ /*** expand it into a set of discrete paths and add */ /*** them to the option list in the lei structure. */ /*** Output: leip, ec */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl path char (*) parameter; dcl leip ptr parameter; dcl ec fixed bin (35) parameter; /* automatic */ dcl archive bit (1) automatic; dcl bc fixed bin (24) automatic; dcl cn char (32) automatic; dcl dn char (168) automatic; dcl en char (32) automatic; dcl pathname char (194) automatic; dcl segp ptr automatic; /* expand the pathname into a dirname/entryname/starname or */ /* dirname/starname combination. */ call expand_pathname_$component (path, dn, en, cn, ec); if ec ^= 0 then return; /* if there is a component, we have either an archive path or an */ /* archive component starname. */ if cn ^= "" then do; /* check the component name for star status */ call check_star_name_$entry (cn, ec); if ec = 0 then do; /* simple archive component pathname */ call initiate_file_$component (dn, en, cn, R_ACCESS, segp, bc, ec); if ec ^= 0 then return; pathname = pathname_$component (dn, en, cn); /* add the option to the le_input structure */ call add_opt (type, cn, pathname, bc, segp, ""b, leip, ec); return; end; else if ec = 1 | ec = 2 then do; /* archive component starname of some variety */ call expand_le_archive_star (type, dn, en, cn, leip, ec); return; end; else return; end; /* we have a non-archive path, see if it is a starname */ call check_star_name_$entry (en, ec); if ec = 0 then do; /* if not a starname, then try to initiate it */ call initiate_file_ (dn, en, R_ACCESS, segp, bc, ec); if ec = error_table_$dirseg then do; /* the target is a directory, if it is a MSF, return an */ /* error code. */ call hcs_$status_minf (dn, en, 0, 0, bc, ec); if bc > 0 then do; /* target is an MSF, return an error code */ ec = error_table_$msf; return; end; /* target is a directory so assume dir>** */ dn = pathname_ (dn, en); call expand_le_star (type, dn, "**", leip, ec); return; end; else if ec = 0 then do; /* target is a segment, see if it has a .archive suffix. */ /* if it does, treat it as archive_segment_path::**, */ /* otherwise, just add the segment itself. */ pathname = pathname_ (dn, en); archive = false; if length (rtrim (en)) > length (ARCHIVE_SUFFIX) then if substr (en, length (rtrim (en)) - length (ARCHIVE_SUFFIX) + 1, length (ARCHIVE_SUFFIX)) = ARCHIVE_SUFFIX then archive = true; if archive then call expand_le_archive_star (type, dn, en, "**", leip, ec); else call add_opt (type, en, pathname, bc, segp, ""b, leip, ec); return; end; else return; end; else if ec = 1 | ec = 2 then do; /* the entryname is a starname of some sort, expand the */ /* starname into discrete segments and add them to the */ /* option list in le_input. */ call expand_le_star (type, dn, en, leip, ec); return; end; else return; end expand_le_path; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ expand_le_archive_star: proc (type, /** option type (in ) */ dname, /** dir name (in ) */ ename, /** entry name (in ) */ sname, /** component starname (in ) */ leip, /** le_input pointer (i/o) */ ec); /** error_code (out) */ /*** ****************************************************************/ /*** */ /*** Name: expand_le_archive_star */ /*** Input: type, dname, ename, sname, leip */ /*** Function: expands an archive component starname into a set */ /*** of discrete option entries in the le_input */ /*** structure. */ /*** Output: leip, ec */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl dname char (*) parameter; dcl ename char (*) parameter; dcl sname char (*) parameter; dcl leip ptr parameter; dcl ec fixed bin (35) parameter; /* automatic */ dcl archive_bc fixed bin (24) automatic; dcl archivep ptr automatic; dcl c_bc fixed bin (24) automatic; dcl complete_archive bit (1) automatic; dcl cname char (32) automatic; dcl cp ptr automatic; dcl no_match bit (1) automatic; dcl pathname char (194) automatic; /* first initiate the archive itself */ call initiate_file_ (dname, ename, R_ACCESS, archivep, archive_bc, ec); if ec ^= 0 then return; /* save some time by checking for a complete archive match now */ call check_star_name_$entry (sname, ec); if ec = 2 then do; pathname = pathname_ (dname, ename); complete_archive = true; end; else complete_archive = false; /* preset the component info */ cp = null; c_bc = 0; cname = ""; no_match = true; /* get the first component */ call archive_$next_component (archivep, archive_bc, cp, c_bc, cname, ec); if ec ^= 0 then return; /* scan through the components adding the matching ones */ do while (cp ^= null); if ^complete_archive then do; /* the starname does not necessarily match everything so */ /* compare the component name against the starname */ call match_star_name_ (cname, sname, ec); if ec = 0 then do; /* the name matches, so generate the path and add the option */ no_match = false; pathname = pathname_$component (dname, ename, cname); call add_opt (type, cname, pathname, c_bc, cp, ""b, leip, ec); if ec ^= 0 then return; end; end; else do; /* all of the components are being added so just add the */ /* option with the common pathname */ no_match = false; call add_opt (type, cname, pathname, c_bc, cp, ""b, leip, ec); if ec ^= 0 then return; end; /* get the next archive component */ call archive_$next_component (archivep, archive_bc, cp, c_bc, cname, ec); if ec ^= 0 then return; end; /* generate an error code if no components were found matching the */ /* starname given. */ if no_match then ec = error_table_$nomatch; end expand_le_archive_star; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ expand_le_star: proc (type, /** option type (in ) */ dname, /** directory name (in ) */ sname, /** starname (in ) */ leip, /** le_input pointer (i/o) */ ec); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: expand_le_star */ /*** Input: type, dname, sname, leip */ /*** Function: expands a starname and searches the directory for */ /*** single segments matching the starname. */ /*** Output: leip, ec */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl dname char (*) parameter; dcl sname char (*) parameter; dcl leip ptr parameter; dcl ec fixed bin (35) parameter; /* based */ dcl sys_area area based (sys_areap); /* automatic */ dcl archive bit (1) automatic; dcl bc fixed bin (24) automatic; dcl compx fixed bin automatic; dcl ename char (32) automatic; dcl last fixed bin automatic; dcl pathname char (168) automatic; dcl segp ptr automatic; dcl sys_areap ptr automatic; sys_areap = get_system_free_area_ (); star_list_branch_ptr = null; star_list_names_ptr = null; /* make sure the star structures get freed if we get unwound */ on cleanup begin; if star_list_names_ptr ^= null then free star_list_names in (sys_area); if star_list_branch_ptr ^= null then free star_dir_list_branch in (sys_area); end; /* perform the starname directory search */ star_select_sw = star_ALL_ENTRIES; call hcs_$star_dir_list_ (dname, sname, star_select_sw, sys_areap, star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, ec); if ec ^= 0 then return; /* scan through each matching branch/link */ do compx = 1 to star_branch_count + star_link_count; /* if the branch is a directory, we ignore it. */ if star_dir_list_branch (compx).type = star_DIRECTORY then ; else do; ename = star_list_names (star_dir_list_branch (compx).nindex); archive = false; if length (rtrim (ename)) > length (ARCHIVE_SUFFIX) then if substr (ename, length (rtrim (ename)) - length (ARCHIVE_SUFFIX) + 1, length (ARCHIVE_SUFFIX)) = ARCHIVE_SUFFIX then archive = true; if archive then do; /* the segment has a .archive suffix, so treat it as */ /* archive_name::** */ last = lei.n_opts; call expand_le_archive_star (type, dname, ename, "**", leip, ec); /* if the archive was found via a link, flag all the */ /* components found there so we can eliminate them if it */ /* is decided we shouldn't have chased links. */ if star_dir_list_branch (compx).type = star_LINK then do i = last + 1 to lei.n_opts; lei.opt (i).flags.link = true; end; end; else do; /* either a segment branch or a link, initiate it and add */ /* it to the option list in le_input */ call initiate_file_ (dname, ename, R_ACCESS, segp, bc, ec); if ec ^= 0 then goto free_and_return; pathname = pathname_ (dname, ename); call add_opt (type, ename, pathname, bc, segp, ""b, leip, ec); if ec ^= 0 then goto free_and_return; if star_dir_list_branch (compx).type = star_LINK then lei.opt (lei.n_opts).flags.link = true; end; end; end; /* free the star structures */ free_and_return: free star_list_names in (sys_area); free star_dir_list_branch in (sys_area); end expand_le_star; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ add_ep: proc (type, /** option type (in ) */ ep_name, /** entrypoint name (in ) */ inhibit, /** inhibit errors (in ) */ leip, /** le_input pointer (i/o) */ ec); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: add_ep */ /*** Input: type, ep_name, inhibit, leip */ /*** Function: adds an entrypoint name to be retained or deleted */ /*** to the option list after converting ambiguous */ /*** specifications into a standard format. */ /*** Output: leip, ec */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl ep_name char (*) parameter; dcl inhibit bit (1) parameter; dcl leip ptr parameter; dcl ec fixed bin (35) parameter; /* automatic */ dcl entrypoint char (168) automatic; dcl segname char (256) varying; dcl offsetname char (256) varying; /* convert the name given to segname$offsetname format if necessary */ if ep_name = "" then entrypoint = "**$**"; else if index (ep_name, "$") = 0 then entrypoint = "**$" || ep_name; else do; /* extract the segname and offsetname portions */ segname = before (ep_name, "$"); offsetname = after (ep_name, "$"); /* check out the segname as a starname, and convert to standard format */ call check_star_name_$entry ((segname), ec); if ec = 2 then segname = "**"; /* check out the offsetname as a starname, and convert null offsetnames */ /* and global starnames into a ** format */ if offsetname = "" then offsetname = "**"; else do; call check_star_name_$entry ((offsetname), ec); if ec = 2 then offsetname = "**"; end; entrypoint = segname || "$" || offsetname; end; /* add it to the option list */ if inhibit then call add_opt (type, "", entrypoint, 0, null, "0001"b, leip, ec); else call add_opt (type, "", entrypoint, 0, null, ""b, leip, ec); if entrypoint = "**$**" then has_global = true; end add_ep; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ add_opt: proc (type, /** option type (in ) */ name, /** name string (in ) */ path, /** path or ep string (in ) */ bc, /** bit count (in ) */ optp, /** option pointer (in ) */ flags, /** flags (in ) */ leip, /** li_info pointer (i/o) */ ec); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: add_opt */ /*** Input: type, name, path, bc, optp, flags, leip */ /*** Function: adds an option to the le_input option table. The */ /*** only error returned by this routine is if the */ /*** table cannot hold the new entry. */ /*** Output: ec */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl name char (*) parameter; dcl path char (*) parameter; dcl bc fixed bin (24) parameter; dcl optp ptr parameter; dcl flags bit (*) parameter; dcl leip ptr parameter; dcl ec fixed bin (35) parameter; /* based */ dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; /* see if adding another entry will overflow the temp seg */ if currentsize (lei) + size (le_option) > sys_info$max_seg_size then do; ec = le_et_$too_many_options; return; end; else ec = 0; /* add the new option to the le_input structure */ lei.n_opts = lei.n_opts + 1; lei.opt (lei.n_opts).type = type; lei.opt (lei.n_opts).name = name; lei.opt (lei.n_opts).path_or_ep = path; unspec (lei.opt (lei.n_opts).flags) = flags; lei.opt (lei.n_opts).bc = bc; lei.opt (lei.n_opts).optp = optp; end add_opt; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ validate_opts: proc (leip); /** le_input pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: validate_opts */ /*** Input: leip */ /*** Function: make sure that the options in the le_input option */ /*** array are all valid. In particular, that we have */ /*** some input paths, and that there is an explicit */ /*** statement regarding the entrypoint **$main_ */ /*** Output: leip */ /*** */ /*** ****************************************************************/ /* parameters */ dcl leip ptr parameter; /* based */ dcl 01 lei aligned based (leip), 02 header like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; /* automatic */ dcl ec fixed bin (35) automatic; dcl o fixed bin automatic; dcl path_count fixed bin automatic; dcl found bit (1) automatic; path_count = 0; /* pass 1: make sure we have at least 1 PATH option */ do o = 1 to lei.n_opts; if lei.opt (o).type = PATH then path_count = path_count + 1; end; if path_count = 0 then call abort (error_table_$noarg, "At least 1 input path must be specified."); /* pass 2: add in a -retain main_ option if no other specification */ /* is given for main_ */ found = false; do o = 1 to lei.n_opts while (^found); /* see if this is a "-retain **$main_" or "-delete **$main_" argument */ if lei.opt (o).type = RETAIN | lei.opt (o).type = DELETE then found = (lei.opt (o).path_or_ep = "**$main_"); end; if ^found then call add_ep (RETAIN, "**$main_", true, leip, ec); /* assume global deletion if just retains specified, and global */ /* retention otherwise. */ if ^has_global then if has_retain & ^has_delete then call add_ep (DELETE, "", false, leip, ec); else call add_ep (RETAIN, "", false, leip, ec); end validate_opts; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ abort: proc (ec, /** error code (in ) */ msg); /** error message (in ) */ /*** ****************************************************************/ /*** */ /*** Name: abort */ /*** Input: ec, msg */ /*** Function: aborts execution of le and returns after printing */ /*** a message on error_output. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl ec fixed bin (35) parameter; dcl msg char (*) parameter; call com_err_ (ec, "linkage_editor", msg); goto ABORT; end abort; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include le_input; %include star_structures; %include terminate_file; end le;  le_.pl1 12/10/86 1307.7rew 12/10/86 1252.2 112167 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written as the subroutine interface to the linkage editor. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_: proc (leip, /** le_info pointer (in ) */ severity, /** max error severity (out) */ code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_ */ /*** Input: leip */ /*** Function: This is the multics linkage_editor subroutine */ /*** interface. It takes as input a structure which */ /*** consists of a set of flags, an output pathname, */ /*** and a list of options which specify the input */ /*** binaries to be included, any library binaries, */ /*** synonyms, addnames, and retention and deletion */ /*** options for the entire output, one component, or */ /*** a single entrypoint. */ /*** Output: severity, code */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); /* parameters */ dcl leip ptr parameter; dcl severity fixed bin parameter; dcl code fixed bin (35) parameter; /* procedures */ dcl define_area_ entry (ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hash_$search entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl le_apply_def_options_ entry (ptr, ptr); dcl le_combine_init_info_ entry (ptr); dcl le_complete_binary_ entry (ptr, ptr); dcl le_create_binary_ entry (ptr, char (*), char (*), fixed bin, bit (1), char (*), char (*)); dcl le_create_list_ entry (ptr, ptr, char (*), char (*), bit (1)); dcl le_error_ entry options (variable); dcl le_make_comp_tbl_ entry (ptr, ptr); dcl le_make_component_ entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin); dcl le_make_link_tbl_ entry (ptr, ptr, ptr); dcl le_make_opt_tbl_ entry (ptr, ptr); dcl le_make_segname_tbl_ entry (ptr, ptr, ptr, ptr); dcl le_msf_partition_ entry (ptr, fixed bin, fixed bin); dcl nd_handler_ entry (char(*), char(*), char(*), fixed bin(35)); dcl nd_handler_$force entry (char(*), char(*), char(*), fixed bin(35)); dcl release_area_ entry (ptr); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); /* external */ dcl error_table_$dup_ent_name external fixed bin (35); dcl error_table_$namedup external fixed bin (35); dcl error_table_$noentry external fixed bin (35); dcl error_table_$segnamedup external fixed bin (35); dcl error_table_$translation_failed external fixed bin (35); dcl le_data_$caller external char (32) varying; dcl le_data_$debug external bit (1); dcl le_data_$display_severity external fixed bin; dcl le_data_$max_severity external fixed bin; dcl le_data_$patch_ptr external ptr; dcl le_data_$running external bit (1); dcl le_et_$recursive_invocation external fixed bin (35); dcl sys_info$max_seg_size external fixed bin (35); /* based */ dcl 01 lec aligned based (ts.lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; dcl 01 ts aligned based (addr (temp_segs (1))), 02 lecp ptr, 02 leop ptr, 02 leshp ptr, 02 lebp ptr, 02 lepp ptr; /* automatic */ dcl 01 ai aligned like area_info automatic; dcl bits aligned bit (36) automatic; dcl c fixed bin automatic; dcl done bit (1) automatic; dcl dname char (168) automatic; dcl ec fixed bin (35) automatic; dcl ename char (32) automatic; dcl i fixed bin automatic; dcl leap ptr automatic; dcl n_components fixed bin automatic; dcl temp_segs (1:5) aligned ptr automatic; /* conditions */ dcl cleanup condition; dcl le_abort_ condition; /* builtin */ dcl addr builtin; dcl char builtin; dcl ltrim builtin; dcl null builtin; dcl rtrim builtin; dcl unspec builtin; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ /* initialize le_data_ static variables */ le_data_$max_severity = 0; le_data_$display_severity = lei.display_severity; le_data_$debug = lei.flags.debug; le_data_$caller = rtrim (lei.header.name); temp_segs (1) = null; leap = null; on le_abort_ goto ABORT; on cleanup begin; if temp_segs (1) ^= null then call release_temp_segments_ ((le_data_$caller), temp_segs, 0); if leap ^= null then call release_area_ (leap); le_data_$running = false; end; /* see if we have a recursive invocation */ if le_data_$running then do; call le_error_ (LE_FATAL_ERROR, le_et_$recursive_invocation, ""); severity = le_data_$max_severity; code = error_table_$translation_failed; return; end; le_data_$running = true; /* create the area for table allocation */ unspec (ai) = ""b; ai.version = area_info_version_1; ai.control.extend = true; ai.control.no_freeing = true; ai.owner = le_data_$caller; ai.size = sys_info$max_seg_size; ai.areap = null; call define_area_ (addr (ai), ec); leap = ai.areap; /* get temp segments for extensible tables */ call get_temp_segments_ ((le_data_$caller), temp_segs, ec); /* give the backpatch facility a segment to use */ le_data_$patch_ptr = ts.lepp; /* 1) create option table */ call le_make_opt_tbl_ (leip, ts.leop); /* note that until we actually start to emit object, we can keep */ /* going with any severity less than 3 so as to get the most info */ /* to the user regardless of what severity was given as abort. */ call severity_check (LE_FATAL_ERROR); /* 2) create component table */ call le_make_comp_tbl_ (leip, ts.lecp); call severity_check (LE_FATAL_ERROR); /* 3) create segname table */ call le_make_segname_tbl_ (leip, ts.lecp, ts.leshp, leap); call severity_check (LE_FATAL_ERROR); /* 4) apply the options to the definitions extracted */ call le_apply_def_options_ (ts.lecp, ts.leop); call severity_check (LE_FATAL_ERROR); /* 5) recursive link resolution through path and library links */ call le_make_link_tbl_ (ts.lecp, ts.leshp, leap); call severity_check (LE_FATAL_ERROR); /* determine if the new object should have its perprocess_static */ /* switch on */ lec.flags.perprocess_static = lei.flags.perprocess_static; /* determine if the new object should have separate static sections */ done = false; lec.header.flags.separate_static = false; do c = 1 to lec.n_components while (^done); if lec.comp (c).flags.include & lec.comp (c).orig.statl > 0 then do; if ^lec.comp (c).flags.separate_static then do; lec.header.flags.separate_static = false; done = true; end; else lec.header.flags.separate_static = true; end; end; /* 6) partition into MSF components */ call le_msf_partition_ (lecp, lei.component_size, n_components); call severity_check (LE_FATAL_ERROR); /* 7) resolve init_infos into 1 init_info/external variable */ call le_combine_init_info_ (ts.lecp); call severity_check (LE_FATAL_ERROR); /* 8) insure that the component block segnames don't conflict with */ /* anything. */ if n_components = 1 then do; call hash_$search (leshp, lei.output_file.entry, bits, ec); if ec ^= error_table_$noentry then call le_error_ (LE_FATAL_ERROR, error_table_$dup_ent_name, "^/Name ^a on bound segment " || "conflicts with another segname.", lei.output_file.entry); end; else do; do i = 1 to n_components; ename = rtrim (lei.output_file.entry) || ltrim (rtrim (char (i))); call hash_$search (leshp, ename, bits, ec); if ec ^= error_table_$noentry then call le_error_ (LE_FATAL_ERROR, error_table_$dup_ent_name, "^/Name ^a on bound segment " || "conflicts with another segname.", ename); end; end; /* from now on we use the users abort severity, since we are about */ /* to try emitting some object code. */ call severity_check (lei.abort_severity); /* 9) process each component */ /* create the msf directory if necessary and adjust the dirname */ call le_create_binary_ (ts.lecp, lei.output_file.dir, lei.output_file.entry, n_components, lei.flags.force, dname, ename); call severity_check (lei.abort_severity); /* 10) now emit each component of the output binary */ do c = 1 to n_components; call le_make_component_ (dname, ename, leip, ts.lebp, ts.lecp, c, n_components); call severity_check (lei.abort_severity); end; /* 11) create msf component 0 if there more than 1 component and */ /* backpatch and unresolved references */ call le_complete_binary_ (ts.lecp, ts.lebp); /* 12) add any names specified by ADDNAME options */ do i = 1 to lei.n_opts; if lei.opt (i).type = ADDNAME then do; call hcs_$chname_file (lei.output_file.dir, lei.output_file.entry, "", lei.opt (i).name, ec); if ec = error_table_$namedup then do; if lei.flags.force then call nd_handler_$force ((lei.header.name), lei.output_file.dir, lei.opt (i).name, ec); else call nd_handler_ ((lei.header.name), lei.output_file.dir, lei.opt (i).name, ec); if ec = 0 then call hcs_$chname_file (lei.output_file.dir, lei.output_file.entry, "", lei.opt (i).name, ec); end; else if ec ^= error_table_$segnamedup then call le_error_ (LE_WARNING, ec, "^/While adding name ""^a"".", lei.opt (i).name); end; end; /* 13) generate the listing if one was requested */ if lei.flags.list | lei.flags.map then call le_create_list_ (ts.lecp, ts.lebp, lei.output_file.dir, lei.output_file.entry, lei.flags.list); ABORT: if temp_segs (1) ^= null then call release_temp_segments_ ((le_data_$caller), temp_segs, ec); if leap ^= null then call release_area_ (leap); severity = le_data_$max_severity; if severity >= lei.abort_severity then code = error_table_$translation_failed; else code = 0; le_data_$running = false; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ severity_check: proc (abort_severity); /** severity to abort (in ) */ /*** ****************************************************************/ /*** */ /*** Name: severity_check */ /*** Input: abort_severity */ /*** Function: determines whether the highest severity error */ /*** encountered so far is sufficient to cause us to */ /*** abort the run. If it is, we release out temp */ /*** storage and return with an error code of */ /*** error_table_$translation_failed */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl abort_severity fixed bin parameter; if le_data_$max_severity >= abort_severity then goto ABORT; end severity_check; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include area_info; %include le_input; %include le_data; end le_;  le_apply_def_options_.pl1 12/10/86 1307.7rew 12/10/86 1252.0 107037 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to apply the retain/delete/no_link options to the definitions in each component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_apply_def_options_: proc (lecp, /** components pointer (i/o) */ leop); /** options pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_apply_def_options_ */ /*** Input: lecp, leop */ /*** Function: applies the definition retain/delete/no_link */ /*** options to the definitions in the definition */ /*** table prior to link resolution so that no_link */ /*** defs are handled correctly. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl lecp ptr parameter; dcl leop ptr parameter; /* procedures */ dcl le_debug_ entry options (variable); dcl le_error_ entry options (variable); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); /* external */ dcl error_table_$nomatch external fixed bin (35); dcl le_et_$implementation_error external fixed bin (35); dcl le_et_$unused_option external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; /* automatic */ dcl c fixed bin automatic; dcl d fixed bin automatic; dcl ledp ptr automatic; dcl lesp ptr automatic; dcl o fixed bin automatic; dcl optx fixed bin automatic; dcl type fixed bin automatic; /* builtin */ dcl mod builtin; dcl null builtin; call le_debug_ ("Beginning definition option application."); /* for each component . . . */ do c = 1 to lec.n_components; ledp = lec.comp (c).tables.ledp; lesp = lec.comp (c).tables.lesp; /* for each definition . . . */ if ledp ^= null then do d = 1 to led.n_defs; optx = None; type = RETAIN; /* search the option table for the first matching option */ do o = 1 to leo.n_opts while (optx = None); if match (lesp, ledp, leop, d, o) then do; optx = o; type = leo.opt (o).type; end; end; call le_debug_ ("entry ^a will be " || "^[retained^;deleted^;left unlinked^]" || "^/ ^[by default.^s^s^s^;as per option " || """^[retain^;delete^;no_link^] ^a$^a"".^]", led.def (d).str, (type - RETAIN + 1), (optx = None), (type - RETAIN + 1), leo.opt (optx).segname, leo.opt (optx).ep_name); /* mark the option as used */ leo.opt (optx).used = true; /* set the definition disposition flags */ if type = RETAIN then led.def (d).flags.retain = true; else if type = DELETE then led.def (d).flags.delete = true; else if type = NO_LINK then do; led.def (d).flags.retain = true; led.def (d).flags.no_link = true; end; else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Option found in option table was not of type" || " RETAIN, DELETE or NO_LINK."); end; end; /* check the definition options for unused options */ do optx = 1 to leo.n_opts; if ^leo.opt (optx).inhibit_error & ^leo.opt (optx).used then do; if leo.opt (optx).class = 9 then call le_error_ (LE_WARNING, le_et_$unused_option, "^/global ""^[retain^;delete^;no_link^]""", leo.opt (optx).type - RETAIN + 1); else call le_error_ (LE_WARNING, le_et_$unused_option, "^/^[retain^;delete^;no_link^] ^[^s^;^a$^]^[^s^;^a^]", leo.opt (optx).type - RETAIN + 1, (mod (leo.opt (optx).class, 3) = 0), leo.opt (optx).segname, (leo.opt (optx).class > 6), leo.opt (optx).ep_name); end; end; call le_debug_ ("Completed definition option application.^2/"); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ match: proc (lesp, /** segnames pointer (in ) */ ledp, /** definitions pointer (in ) */ leop, /** options pointer (in ) */ d, /** definition index (in ) */ o) /** option index (in ) */ returns (bit (1)); /** match switch (out) */ /*** ****************************************************************/ /*** */ /*** Name: match */ /*** Input: lesp, ledp, leop, d, o */ /*** Function: determines if the definition given by d paired */ /*** with any of the segnames in the containing block */ /*** match the starnames given in the option specified */ /*** by o. */ /*** Output: match_sw */ /*** */ /*** ****************************************************************/ /* constants */ dcl class (1:9) label init (specific_segname_and_ep, star_segname_and_specific_ep, any_segname_and_specific_ep, specific_segname_and_star_ep, star_segname_and_ep, any_segname_and_star_ep, specific_segname_and_any_ep, star_segname_and_any_ep, any_segname_and_ep); /* parameters */ dcl d fixed bin parameter; dcl ledp ptr parameter; dcl leop ptr parameter; dcl lesp ptr parameter; dcl o fixed bin parameter; /* based */ dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; /* automatic */ dcl defn char (256) automatic; dcl ec fixed bin (35) automatic; dcl match_sw bit (1) automatic; dcl optn char (256) automatic; dcl segn char (32) automatic; segn = leo.opt (o).segname; optn = leo.opt (o).ep_name; defn = led.def (d).str; /* select determination method depending on ordering class of option */ goto class (leo.opt (o).class); specific_segname_and_ep: if optn ^= defn then match_sw = false; else match_sw = literal_sn_match (lesp, segn); goto DONE; star_segname_and_specific_ep: if optn ^= defn then match_sw = false; else match_sw = star_sn_match (lesp, segn); goto DONE; any_segname_and_specific_ep: if optn = defn then match_sw = true; else match_sw = false; goto DONE; specific_segname_and_star_ep: call match_star_name_ (defn, optn, ec); if ec = 0 then match_sw = literal_sn_match (lesp, segn); else if ec = error_table_$nomatch then match_sw = false; else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Bad starname detected during option application."); goto DONE; star_segname_and_ep: call match_star_name_ (defn, optn, ec); if ec = 0 then match_sw = star_sn_match (lesp, segn); else if ec = error_table_$nomatch then match_sw = false; else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Bad starname detected during option application."); goto DONE; any_segname_and_star_ep: call match_star_name_ (defn, optn, ec); if ec = 0 then match_sw = true; else if ec = error_table_$nomatch then match_sw = false; else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Bad starname detected during option application."); goto DONE; specific_segname_and_any_ep: match_sw = literal_sn_match (lesp, segn); goto DONE; star_segname_and_any_ep: match_sw = star_sn_match (lesp, segn); goto DONE; any_segname_and_ep: match_sw = true; DONE: return (match_sw); end match; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ literal_sn_match: proc (lesp, /** segnames pointer (in ) */ name) /** name to match (in ) */ returns (bit (1)); /** match sw (out) */ /*** ****************************************************************/ /*** */ /*** Name: literal_sn_match */ /*** Input: lesp, name */ /*** Function: scans the segname block identified by blockx in */ /*** the segname table for a segname which literally */ /*** matches name. */ /*** Output: match_sw */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lesp ptr parameter; dcl name char (32) parameter; /* based */ dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (0 refer (les.n_segnames)) like le_segnames.segname; /* automatic */ dcl s fixed bin automatic; /* scan the segname table for a match */ do s = 1 to les.n_segnames; if les.segname (s).str = name then return (true); end; return (false); end literal_sn_match; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ star_sn_match: proc (lesp, /** segnames pointer (in ) */ name) /** star name to match (in ) */ returns (bit (1)); /** match sw (out) */ /*** ****************************************************************/ /*** */ /*** Name: star_sn_match */ /*** Input: lesp, name */ /*** Function: scans the segname block identified by blockx in */ /*** the segname table for a segname which matches */ /*** the starname name using standard Multics star */ /*** conventions. */ /*** Output: match_sw */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lesp ptr parameter; dcl name char (32) parameter; /* based */ dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (0 refer (les.n_segnames)) like le_segnames.segname; /* automatic */ dcl s fixed bin automatic; dcl ec fixed bin (35) automatic; /* scan the segname table for a match */ do s = 1 to les.n_segnames; call match_star_name_ ((les.segname (s).str), name, ec); if ec = 0 then return (true); else if ec ^= error_table_$nomatch then call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Bad starname detected during option application."); end; return (false); end star_sn_match; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include le_input; end le_apply_def_options_;  le_backpatch_.pl1 12/10/86 1307.8rew 12/10/86 1251.6 210348 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to record and execute backpatches which cannot be resolved until the end of the run. These are references in one output component to something in another component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_backpatch_: proc (type, /** type of patch (in ) */ comp, /** component to patch (in ) */ relp, /** offset to patch (in ) */ target, /** target of patch (in ) */ index); /** thing to findd (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_backpatch_ */ /*** Input: type, comp, relp, target, index */ /*** Function: this is the backpatching facility for the linkage */ /*** editor. This main entrypoint is used to schedule */ /*** the backpatching of a reference. This is done by */ /*** placing an entry in a list. The list if found */ /*** using the external variable le_data_$patch_ptr */ /*** The following types of patch are supported: */ /*** Patch_Init */ /*** - This patch is used to install the link */ /*** offset into the init_info for *system and */ /*** *heap links with deferred initialization. */ /*** is the output component where the */ /*** link was emitted, is the offset */ /*** (unadjusted for static) within the linkage */ /*** section of the link, is the target */ /*** input component of the deferred init, and */ /*** is the index of the target link */ /*** within that component link_table. */ /*** Patch_Self_Init */ /*** - This patch is used to install the link */ /*** offset into the init_info for *system and */ /*** *heap links with self-referential pointer */ /*** initializations. This is required since */ /*** the link offset is unknown until the link */ /*** is emitted, and by then the init_info has */ /*** already been created. is the output */ /*** component where the link was emitted, */ /*** is the offset (unadjusted for */ /*** static) within the linkage section. */ /*** is unused, and is the */ /*** index of the init_template to be patched. */ /*** Patch_Link */ /*** - This patch is used to install the correct */ /*** offset into partial links whos target is */ /*** a link in another component. Since the link */ /*** offset is unknown until the component is */ /*** closed, we patch it. is the output */ /*** component containing the link to patch, */ /*** is the offset (unadjusted for */ /*** static) of the link within the linkage */ /*** section, is the target input */ /*** component of the link, and is the */ /*** index within that components definition */ /*** table of the target definition of the link. */ /*** This is used to find the target link and */ /*** where it was relocated to. */ /*** Patch_Symbol_Ref */ /*** - This patch is used when resolving text */ /*** section references to the symbol section. */ /*** While we have the targets offset within the */ /*** symbol section, we don't have the offset */ /*** of the symbol section within the object */ /*** segment until it is closed. is the */ /*** output component containing the reference, */ /*** is the offset of the word in the */ /*** text section, is a code indicating */ /*** the halfword to patch. is unused. */ /*** In this patch, the absolute offset of the */ /*** symbol section within the object is added */ /*** to the value in place. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl type fixed bin parameter; dcl comp fixed bin parameter; dcl relp fixed bin (18) unsigned parameter; dcl target fixed bin parameter; dcl index fixed bin parameter; dcl lecp ptr parameter; dcl lebp ptr parameter; /* procedures */ dcl get_group_id_ entry () returns (char (32)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)); dcl le_error_ entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); /* external */ dcl le_data_$patch_ptr ptr external; dcl le_et_$implementation_error external fixed bin (35); /* based */ dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lep aligned based (le_data_$patch_ptr), 02 header aligned like le_patches.header, 02 patch dim (0 refer (lep.n_patches)) like le_patch; dcl 01 patch aligned like le_patch based (patchp); /* automatic */ dcl bx fixed bin automatic; dcl patchp ptr automatic; dcl px fixed bin automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl currentsize builtin; dcl fixed builtin; dcl null builtin; dcl rel builtin; /* increment the number of patches and copy the info into the table */ px, lep.n_patches = lep.n_patches + 1; lep.patch (px).type = type; lep.patch (px).comp = comp; lep.patch (px).relp = relp; lep.patch (px).target = target; lep.patch (px).index = index; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ execute: entry (lecp, lebp); /*** ****************************************************************/ /*** */ /*** Name: le_backpatch_$execute */ /*** Input: lecp, lebp */ /*** Function: executes all of the backpatches scheduled. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* if there are no patches, just return */ if lep.n_patches = 0 then return; leb.binary (*).aclp = null; /* make sure we put back the acls on an unexpected release */ on cleanup begin; do bx = 1 to leb.n_binaries; call restore_acl (leb.binary (bx).segp, leb.binary (bx).aclp, leb.binary (bx).aclc); end; end; do bx = 1 to leb.n_binaries; /* for each output binary set the acl so we can write into */ /* the segment. */ call set_acl (leb.binary (bx).segp, leb.binary (bx).aclp, leb.binary (bx).aclc); end; do px = 1 to lep.n_patches; patchp = addr (lep.patch (px)); /* execute each patch in the table */ if patch.type = Patch_Init then call patch_init (lecp, lebp, patch.comp, patch.relp, patch.target, patch.index); else if patch.type = Patch_Self_Init then call patch_self_init (lecp, lebp, patch.comp, patch.relp, patch.index); else if patch.type = Patch_Link then call patch_link (lecp, lebp, patch.comp, patch.relp, patch.target, patch.index); else if patch.type = Patch_Symbol_Ref then call patch_symbol_ref (lebp, patch.comp, patch.relp, patch.target); else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Unknown patch type (^d) found in patch table.", patch.type); end; /* now put back the acls on the segment(s) */ do bx = 1 to leb.n_binaries; call restore_acl (leb.binary (bx).segp, leb.binary (bx).aclp, leb.binary (bx).aclc); end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ set_acl: proc (segp, /** segment pointer (in ) */ aclp, /** acl pointer (out) */ count); /** acl count (out) */ /*** ****************************************************************/ /*** */ /*** Name: set_acl */ /*** Input: segp */ /*** Function: saves the access_control_list for the segment */ /*** pointed to by segp, and adds a rw term to the acl */ /*** for the calling user. */ /*** Output: aclp, count */ /*** */ /*** ****************************************************************/ /* parameters */ dcl segp ptr parameter; dcl aclp ptr parameter; dcl count fixed bin parameter; /* automatic */ dcl 01 acl_entry aligned like segment_acl_entry automatic; dcl dname char (168) automatic; dcl ec fixed bin (35) automatic; dcl ename char (32) automatic; dcl sys_areap ptr automatic; sys_areap = get_system_free_area_ (); /* get the pathname and acl */ call hcs_$fs_get_path_name (segp, dname, 0, ename, ec); call hcs_$list_acl (dname, ename, sys_areap, aclp, null, count, ec); if ec ^= 0 then do; call le_error_ (LE_WARNING, ec, "^/Unable to read ACL for ^a.", pathname_ (dname, ename)); aclp = null; end; /* create a new acl entry giving rw access to the user */ acl_entry.access_name = get_group_id_ (); acl_entry.mode = REW_ACCESS; acl_entry.extended_mode = ""b; acl_entry.status_code = 0; /* add the new acl term */ call hcs_$add_acl_entries (dname, ename, addr (acl_entry), 1, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/Unable to set ACL on ^a.", pathname_ (dname, ename)); end set_acl; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ restore_acl: proc (segp, /** segment pointer (in ) */ aclp, /** acl pointer (in ) */ count); /** acl count (in ) */ /*** ****************************************************************/ /*** */ /*** Name: restore_acl */ /*** Input: segp, aclp, count */ /*** Function: replaces the saved acl (pointed to by aclp) on */ /*** segment pointed to by segp and frees the saved */ /*** acl structure. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl segp ptr parameter; dcl aclp ptr parameter; dcl count fixed bin parameter; /* based */ dcl 01 acl_list (1:count) like segment_acl_entry based (aclp); dcl sys_area area based (sys_areap); /* automatic */ dcl dname char (168) automatic; dcl ec fixed bin (35) automatic; dcl ename char (32) automatic; dcl sys_areap ptr automatic; /* if there is no saved acl, just return */ if aclp = null then return; sys_areap = get_system_free_area_ (); /* get the pathname and replace the saved acl */ call hcs_$fs_get_path_name (segp, dname, 0, ename, ec); call hcs_$replace_acl (dname, ename, aclp, count, "1"b, ec); free acl_list in (sys_area); if ec ^= 0 then call le_error_ (LE_WARNING, ec, "^/Unable to restore ACL on ^a.", pathname_ (dname, ename)); end restore_acl; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ patch_init: proc (lecp, /** components pointer (in ) */ lebp, /** object info pointer (in ) */ comp, /** component index (in ) */ relp, /** relpointer to link (in ) */ target, /** target input comp (in ) */ index); /** link table index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: patch_init */ /*** Input: lecp, lebp, comp, relp, target, index */ /*** Function: patches the link_relp value in a deferred init */ /*** init_info to properly refer to the target of the */ /*** deferred initialization. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl lebp ptr parameter; dcl comp fixed bin parameter; dcl relp fixed bin (18) unsigned parameter; dcl target fixed bin parameter; dcl index fixed bin parameter; /* based */ dcl 01 exp aligned like exp_word based (expp); dcl 01 init aligned like link_init_deferred based (initp); dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 lk aligned like object_link based (lkp); dcl 01 type aligned like type_pair based (typep); /* automatic */ dcl expp ptr automatic; dcl initp ptr automatic; dcl lelp ptr automatic; dcl lkp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl typep ptr automatic; /* builtin */ dcl mod builtin; /* adjust the link relpointer for the presence of the static section */ if lec.header.flags.separate_static then offset = relp; else do; offset = relp + leb.binary (comp).statl; offset = offset + mod (offset, 2); end; /* get the link information */ lkp = addrel (leb.binary (comp).linkp, offset); expp = addrel (leb.binary (comp).defnp, lk.expression_relp); typep = addrel (leb.binary (comp).defnp, exp.type_relp); initp = addrel (leb.binary (comp).defnp, type.trap_relp); lelp = lec.comp (target).tables.lelp; /* find the target link in the other component and adjust the link */ /* offset for combined static if necessary. */ if lec.header.flags.separate_static then init.link_relp = lel.link (index).relp; else do; init.link_relp = lel.link (index).relp + leb.binary (lec.comp (target).target).statl; init.link_relp = init.link_relp + mod (init.link_relp, 2); end; end patch_init; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ patch_self_init: proc (lecp, /** components pointer (in ) */ lebp, /** object info pointer (in ) */ comp, /** component index (in ) */ relp, /** relpointer to link (in ) */ index); /** init template index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: patch_self_init */ /*** Input: lecp, lebp, comp, relp, index */ /*** Function: patches the section_offset value in a pointer */ /*** init template for a self_referential link. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl lebp ptr parameter; dcl comp fixed bin parameter; dcl relp fixed bin (18) unsigned parameter; dcl index fixed bin parameter; /* based */ dcl 01 exp aligned like exp_word based (expp); dcl 01 init aligned based (initp), 02 header aligned like link_init_list_template.header, 02 pad bit (18) unaligned, 02 n_words_in_list fixed bin (18) unsigned unaligned, 02 template dim (0 refer (init.n_words_in_list)); dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lk aligned like object_link based (lkp); dcl 01 lte aligned based (ltep), 02 n_bits fixed bin (35) aligned, 02 mbz bit (3) unaligned, 02 init_type fixed bin (3) unsigned unaligned, 02 repeat fixed bin (30) unsigned unaligned, 02 datum bit (0 refer (lte.n_bits)); dcl 01 pit aligned like pointer_init_template based (pitp); dcl 01 type aligned like type_pair based (typep); /* automatic */ dcl expp ptr automatic; dcl i fixed bin automatic; dcl initp ptr automatic; dcl lkp ptr automatic; dcl ltep ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl pitp ptr automatic; dcl typep ptr automatic; /* builtin */ dcl mod builtin; /* adjust the link relpointer for the presence of the static section */ if lec.header.flags.separate_static then offset = relp; else do; offset = relp + leb.binary (comp).statl; offset = offset + mod (offset, 2); end; /* get the link information */ lkp = addrel (leb.binary (comp).linkp, offset); expp = addrel (leb.binary (comp).defnp, lk.expression_relp); typep = addrel (leb.binary (comp).defnp, exp.type_relp); initp = addrel (leb.binary (comp).defnp, type.trap_relp); /* find the appropriate template */ ltep = addr (init.template); do i = 1 to index-1; ltep = addrel (ltep, currentsize (lte)); end; /* make sure the template found is a pointer init list template */ if lte.init_type = 0 then call le_error_ (le_et_$implementation_error, LE_ABORT_ERROR, "^/Self Init backpatch does not refer to a pointer template." || "^/Patching link|^o", offset); else do; /* install the section offset into the init template */ pitp = addr (lte.datum); pit.section_offset = offset; end; end patch_self_init; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ patch_link: proc (lecp, /** components pointer (in ) */ lebp, /** binaries pointer (in ) */ comp, /** component index (in ) */ relp, /** link offset (in ) */ target, /** target input comp (in ) */ index); /** def table index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: patch_link */ /*** Input: lecp, lebp, comp, relp, target, index */ /*** Function: patches the word_offset portion of a partial */ /*** link to a link in another component linkage scn. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl lebp ptr parameter; dcl comp fixed bin parameter; dcl relp fixed bin (18) unsigned parameter; dcl target fixed bin parameter; dcl index fixed bin parameter; /* based */ dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 plk aligned like partial_link based (plkp); /* automatic */ dcl lelp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl plkp ptr automatic; /* builtin */ dcl mod builtin; /* adjust the link offset for the presence of combined static */ if lec.header.flags.separate_static then offset = relp; else do; offset = relp + leb.binary (comp).statl; offset = offset + mod (offset, 2); end; /* get the partial link itself */ plkp = addrel (leb.binary (comp).linkp, offset); /* find the target link */ lelp = lec.comp (target).tables.lelp; /* adjust the target offset for the presence of combined static and */ /* patch the new offset into the link. */ if lec.header.flags.separate_static then plk.offset = lel.link (index).relp; else do; plk.offset = lel.link (index).relp + leb.binary (lec.comp (target).target).statl; plk.offset = plk.offset + mod (plk.offset, 2); end; end patch_link; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ patch_symbol_ref: proc (lebp, /** binaries pointer (in ) */ comp, /** component index (in ) */ relp, /** reference offset (in ) */ relinfo); /** relinfo code (in ) */ /*** ****************************************************************/ /*** */ /*** Name: patch_symbol_ref */ /*** Input: lebp, comp, relp, relinfo */ /*** Function: patches a symbol reference being made using an */ /*** absolute offset within the segment by adding in */ /*** the offset of the symbol section within the seg. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lebp ptr parameter; dcl comp fixed bin parameter; dcl relp fixed bin (18) unsigned parameter; dcl relinfo fixed bin parameter; /* based */ dcl 01 ref aligned based (refp), 02 side (1:2) fixed bin (18) unsigned unaligned; dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; /* automatic */ dcl refp ptr automatic; /* find the referencing word */ refp = addrel (leb.binary (comp).textp, relp); /* add in the symbol section offset within the segment */ ref.side (relinfo) = ref.side (relinfo) + fixed (rel (leb.binary (comp).symbp), 18); end patch_symbol_ref; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include acl_structures; %include definition_dcls; %include le_data; %include object_link_dcls; end le_backpatch_;  le_combine_init_info_.pl1 01/05/87 1316.0rew 01/05/87 1304.0 131976 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to create a single initialization info block for each external variable reference by combining the init info blocks for all of the links referring to that external variable. 2) change(86-12-19,Elhard), approve(86-12-19,PBF7505), audit(86-12-22,DGHowe), install(87-01-05,MR12.0-1256): Changed to scan for multiple *system/*heap links to the same target within one linkage section when looking for init infos so that references to *heap$p and *heap$p,* references in the same linkage section both get the correct initialization. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_combine_init_info_: proc (lecp); /** components pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_combine_init_info_ */ /*** Input: lecp */ /*** Function: combines the init_infos for multiple *system or */ /*** *heap links to the same target into a single init */ /*** info. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl lecp ptr parameter; /* procedures */ dcl le_debug_ entry options (variable); dcl le_error_ entry options (variable); /* external */ dcl le_et_$incompatible_init external fixed bin (35); dcl le_et_$multiple_inits external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 name aligned based (namep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (name.count)) unaligned; dcl 01 new_name aligned based (new_namep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (new_name.count)) unaligned; dcl 01 tlel aligned based (tlelp), 02 header aligned like le_links.header, 02 link dim (0 refer (tlel.n_links)) like le_link; /* automatic */ dcl c fixed bin automatic; dcl chase_c fixed bin automatic; dcl chase_l fixed bin automatic; dcl extend bit (1) automatic; dcl extension fixed bin (35) automatic; dcl incompatible bit (1) automatic; dcl initp ptr automatic; dcl l fixed bin automatic; dcl lelp ptr automatic; dcl message bit (1) automatic; dcl min fixed bin automatic; dcl namep ptr automatic; dcl new_initp ptr automatic; dcl new_len fixed bin (35) automatic; dcl new_namep ptr automatic; dcl next_c fixed bin automatic; dcl next_l fixed bin automatic; dcl owner fixed bin automatic; dcl print_message bit (1) automatic; dcl replace bit (1) automatic; dcl target_comp fixed bin automatic; dcl target_link fixed bin automatic; dcl tc fixed bin automatic; dcl tl fixed bin automatic; dcl tlelp ptr automatic; /* builtin */ dcl max builtin; dcl null builtin; dcl unspec builtin; call le_debug_ ("Beginning init_info resolution."); /* for each component . . . */ do c = 1 to lec.n_components; /* only process included component */ if lec.comp (c).flags.include then do; /* get the link table */ lelp = lec.comp (c).tables.lelp; /* for each link . . . */ do l = 1 to lel.n_links; /* if a *system or *heap link */ if lel.link (l).type = LINK_SELF_OFFSETNAME & (lel.link (l).class = CLASS_SYSTEM | lel.link (l).class = CLASS_HEAP) & lel.link (l).target_link = None then do; /* initialize the flags and other init status info */ print_message = false; namep = lel.link (l).offsetp; initp = lel.link (l).initp; target_comp = c; target_link = l; extension = 0; call le_debug_ ("Combining init infos for " || "*^[system^;heap^]$^a" || "^/ using init info from component ^a", (lel.link (l).class = CLASS_SYSTEM), name.string, lec.comp (c).name); /* assume that there is only one copy of a given link */ /* in any one component, so search the other components */ /* for similar links. */ do tc = c to lec.n_components; if lec.comp (tc).flags.include then do; /* get the new components link table */ tlelp = lec.comp (tc).tables.lelp; /* search for a matching link */ if tc = c then min = l + 1; else min = 1; do tl = min to tlel.n_links; if tlel.link (tl).type = LINK_SELF_OFFSETNAME & tlel.link (tl).class = lel.link (l).class & tlel.link (tl).target_link = None then do; new_namep = tlel.link (tl).offsetp; new_initp = tlel.link (tl).initp; if name.count = new_name.count & name.string = new_name.string then do; /* the links match, so compare the init infos */ call compare_init (initp, extension, new_initp, replace, extend, message, incompatible, new_len); /* print a message if the inits cant be */ /* merged. */ if incompatible then call le_error_ (LE_FATAL_ERROR, le_et_$incompatible_init, "^/Combining init infos for " || "^[external^;heap^] " || "variable ""^a"".", (lel.link (l).class = CLASS_SYSTEM), name.string); else do; /* thread the links together for */ /* processing later when we know */ /* what init_info will be used. */ tlel.link (tl).target_comp = lel.link (l).target_comp; tlel.link (tl).target_link = lel.link (l).target_link; lel.link (l).target_comp = tc; lel.link (l).target_link = tl; if replace then do; /* we will use the new init info */ call le_debug_ ( "Replacing initialization with " || "version in ^a", lec.comp (tc).name); initp = new_initp; extension = new_len - new_initp -> link_init.n_words; target_comp = tc; target_link = tl; end; if extend then do; /* the current init_info must */ /* be extended. */ call le_debug_ ( "Extending initialization " || "to ^d words.", new_len); extension = new_len - initp -> link_init.n_words; end; /* if a message is required at any */ /* stage, remember and print it at */ /* the end */ print_message = print_message | message; end; end; end; end; end; end; /* non-matching init_infos were found so print a */ /* message to identify the one we will use. */ if print_message then call le_error_ (LE_WARNING, le_et_$multiple_inits, "for ^[external^;heap^] variable ""^a""." || "^/The one in ^a will be used.", (lel.link (l).class = CLASS_SYSTEM), name.string, lec.comp (target_comp).name); /* determine which output component will actually */ /* contain the init info (non-deferred init references) */ owner = lec.comp (target_comp).target; chase_c = c; chase_l = l; /* now chase through the linked list of link table */ /* entries that refer to this variable, and set their */ /* init info data so that the init info is emitted */ /* correctly (if in the target component) or a valid */ /* deferred initialization. */ do while (chase_l ^= None); tlelp = lec.comp (chase_c).tables.lelp; next_l = tlel.link (chase_l).target_link; next_c = tlel.link (chase_l).target_comp; tlel.link (chase_l).target_link = target_link; tlel.link (chase_l).target_comp = target_comp; if lec.comp (chase_c).target = owner then do; /* this link will be in the output component that */ /* actually contains the init_info, so fill in */ /* the information on how to generate it. */ tlel.link (chase_l).initp = initp; tlel.link (chase_l).extension = extension; end; else do; /* this link is in another output component. We */ /* will be generating a deferred_init init info */ /* for it, so all we need is the target link. */ tlel.link (chase_l).initp = null; tlel.link (chase_l).extension = None; end; chase_l = next_l; chase_c = next_c; end; end; end; end; end; call le_debug_ ("Completed init_info resolution.^2/"); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ compare_init: proc (oldp, /** old init info ptr (in ) */ extension, /** amount extended (in ) */ newp, /** new init info ptr (in ) */ replace, /** use new init sw (out) */ extend, /** must be extended (out) */ message, /** print an error msg (out) */ incompatible, /** cannot be combined (out) */ new_len); /** new init length (out) */ /*** ****************************************************************/ /*** */ /*** Name: compare_init */ /*** Input: oldp, newp */ /*** Function: compares two init_info structures and determines */ /*** which of them should be used, and whether it must */ /*** be extended. The rules for this are: */ /*** */ /*** A. init infos are same size */ /*** 1. no new initialization use old init */ /*** 2. new initialization */ /*** i. was init before use old and */ /*** print message */ /*** ii. was not init before use new init */ /*** B. new initialization smaller */ /*** 1. no new initialization use old init */ /*** 2. new initialization */ /*** i. was init before use old and */ /*** print message */ /*** ii. was not init before use new with */ /*** larger size */ /*** C. new initialization larger */ /*** 1. no new initialization */ /*** i. was init before use old with */ /*** larger size */ /*** ii. was not init before use new */ /*** 2. new initialization */ /*** i. was init before use new and */ /*** print message */ /*** ii. was not init before use new */ /*** Output: replace, extend, message, incompatible, new_len */ /*** */ /*** ****************************************************************/ /* parameters */ dcl oldp ptr parameter; dcl extension fixed bin (35) parameter; dcl newp ptr parameter; dcl replace bit (1) parameter; dcl extend bit (1) parameter; dcl message bit (1) parameter; dcl incompatible bit (1) parameter; dcl new_len fixed bin (35) parameter; /* automatic */ dcl have_new bit (1) automatic; dcl have_old bit (1) automatic; dcl larger bit (1) automatic; dcl smaller bit (1) automatic; /* preset return args */ replace, extend, message, incompatible = false; new_len = max (oldp -> link_init.n_words + extension, newp -> link_init.n_words); /* preset flags */ larger, smaller, have_old, have_new = false; /* see if the init_infos are the same */ if oldp -> link_init.n_words + extension = newp -> link_init.n_words & oldp -> link_init.type = newp -> link_init.type then do; if oldp -> link_init.type = INIT_COPY_INFO then if unspec (oldp -> link_init_copy_info) = unspec (newp -> link_init_copy_info) then return; else ; else if oldp -> link_init.type = INIT_LIST_TEMPLATE then if unspec (oldp -> link_init_list_template) = unspec (newp -> link_init_list_template) then return; else ; else return; end; /* at this point we know that the new and old templates are */ /* different, so we have to either select one of them or create */ /* a new combined template. */ /* area initialization is incompatible with any other type of init */ if oldp -> link_init.type ^= newp -> link_init.type then if oldp -> link_init.type = INIT_DEFINE_AREA | newp -> link_init.type = INIT_DEFINE_AREA then do; incompatible = true; return; end; /* determine if the size is different */ if oldp -> link_init.n_words + extension > newp -> link_init.n_words then smaller = true; else if oldp -> link_init.n_words + extension < newp -> link_init.n_words then larger = true; /* determine whether we already have initialiation info */ if oldp -> link_init.type = INIT_NO_INIT then have_old = false; else have_old = true; /* determine if the new one has init info */ if newp -> link_init.type = INIT_NO_INIT then have_new = false; else have_new = true; /* apply rules for what we do with init infos */ if larger then if have_new then if have_old then message, replace = true; else replace = true; else if have_old then extend = true; else replace = true; else if smaller then if have_new then if have_old then message = true; else replace, extend = true; else ; else if have_new then if have_old then message = true; else replace = true; else ; end compare_init; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include definition_dcls; %include object_link_dcls; end le_combine_init_info_;  le_complete_binary_.pl1 12/10/86 1307.8rew 12/10/86 1251.7 55530 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to backpatch unresolved references and complete generation of MSF objects by producing component 0. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_complete_binary_: proc (lecp, /** components pointer (in ) */ lebp); /** binaries pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_complete_binary_ */ /*** Input: lecp, lebp */ /*** Function: creates MSF component 0 and sets the ACL on the */ /*** resulting MSF. Note that this is unnecessary if */ /*** the output binary is not an MSF, since ocu_ will */ /*** set the ACL correctly on exit, but the ACL on a */ /*** MSF includes the directory and segment acls. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl lebp ptr parameter; /* procedures */ dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$add_acl_entries entry (char (*), char (*), ptr, fixed bin (35)); dcl get_group_id_$tag_star entry () returns (char (32)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl le_backpatch_$execute entry (ptr, ptr); dcl le_error_ entry options (variable); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); /* external */ dcl le_data_$caller external char (32) varying; dcl 01 le_data_$symbol_table aligned like std_symbol_header external; dcl le_data_$version_number external fixed bin; dcl le_data_$version_suffix external char (64) varying; /* based */ dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl sys_area area based (sys_areap); /* automatic */ dcl dn char (168) automatic; dcl dnl fixed bin automatic; dcl ec fixed bin (35) automatic; dcl en char (32) automatic; dcl i fixed bin automatic; dcl 01 le_gen_info aligned like gen_info automatic; dcl 01 my_acl aligned automatic, 02 version char (8) aligned, 02 count fixed bin, 02 entry aligned like general_acl_entry; dcl 01 oi aligned like object_info automatic; dcl sys_areap ptr automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addr builtin; dcl null builtin; /* execute any backpatches that were required */ call le_backpatch_$execute (lecp, lebp); /* if the object is a single segment binary, we are done. If it is */ /* an MSF, we have to create component 0. */ if leb.n_binaries = 1 then return; /* create the generator info */ le_gen_info.gen_created = le_data_$symbol_table.object_created; le_gen_info.generator = le_data_$caller; le_gen_info.gen_number = le_data_$version_number; le_gen_info.gen_version = le_data_$caller || le_data_$version_suffix; sys_areap = get_system_free_area_ (); component_count = leb.n_binaries; /* make sure a release frees out allocated storage */ component_listp = null; on cleanup begin; if component_listp ^= null then free component_list in (sys_area); end; /* allocate the component list */ allocate component_list in (sys_area); /* copy the segment pointers into it */ do i = 1 to component_count; component_list (i) = leb.binary (i).segp; end; /* create the MSF transfer vector */ call ocu_$create_msf (component_listp, component_count, addr (le_gen_info), ec); /* free the component list */ free component_list in (sys_area); if ec ^= 0 then call le_error_ (LE_FATAL_ERROR, ec, "^/Creating MSF transfer vector (component 0)."); call hcs_$fs_get_path_name (leb.binary (1).segp, dn, dnl, en, ec); /* get the binary info for component 0 */ call initiate_file_ (dn, "0", R_ACCESS, leb.binary (0).segp, leb.binary (0).bc, ec); oi.version_number = object_info_version_2; call object_info_$brief (leb.binary (0).segp, leb.binary (0).bc, addr (oi), ec); leb.binary (0).textp = oi.textp; leb.binary (0).defnp = oi.defp; leb.binary (0).linkp = oi.linkp; leb.binary (0).symbp = oi.symbp; leb.binary (0).statp = oi.statp; leb.binary (0).textl = oi.tlng; leb.binary (0).defnl = oi.dlng; leb.binary (0).linkl = oi.llng; leb.binary (0).symbl = oi.slng; leb.binary (0).statl = oi.ilng; call hcs_$get_uid_seg (leb.binary (0).segp, leb.binary (0).uid, ec); /* set the ACL on the Multi-Segment File */ call expand_pathname_ (dn, dn, en, ec); my_acl.version = GENERAL_ACL_VERSION_1; my_acl.count = 1; my_acl.entry.access_name = get_group_id_$tag_star (); my_acl.entry.mode = RE_ACCESS; my_acl.entry.status_code = 0; call fs_util_$add_acl_entries (dn, en, addr (my_acl), ec); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include acl_structures; %include le_data; %include object_info; %include ocu_dcls; %include std_symbol_header; end le_complete_binary_;  le_create_binary_.pl1 12/10/86 1307.8rew 12/10/86 1251.8 63729 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to create the output binary, and to resolve conflicts between single segment or MSF output. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_create_binary_: proc (lecp, /** components pointer (in ) */ dname, /** input dirname (in ) */ ename, /** input entryname (in ) */ comp_count, /** component count (in ) */ force, /** force switch (in ) */ act_dname, /** actual dirname (out) */ act_ename); /** actual entryname (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_create_binary_ */ /*** Input: lecp, dname, ename, comp_count */ /*** Function: If the leb.n_binaries is greater than 1, (ie. the */ /*** output binary is an MSF), we create a single */ /*** component MSF, and adjust the pathnames so */ /*** that the segments are created in the MSF dir. */ /*** Output: act_dname, act_ename */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); /* parameters */ dcl lecp ptr parameter; dcl dname char (*) parameter; dcl ename char (*) parameter; dcl comp_count fixed bin parameter; dcl force bit (1) parameter; dcl act_dname char (*) parameter; dcl act_ename char (*) parameter; /* procedures */ dcl get_group_id_$tag_star entry () returns (char (32)); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl le_error_ entry options (variable); dcl le_util_$check_uid entry (ptr, ptr, bit (36) aligned) returns (bit (1)); dcl make_msf_ entry (char (*), char (*), (3) fixed bin (6), fixed bin (35)); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl nd_handler_$force entry (char (*), char (*), char (*), fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl object_lib_$initiate entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl unmake_msf_ entry (char (*), char (*), bit (1), (3) fixed bin (6), fixed bin (35)); /* external */ dcl error_table_$noentry external fixed bin (35); dcl le_data_$caller external char (32) varying; dcl le_et_$input_output_overlap external fixed bin (35); /* automatic */ dcl abort bit (1) automatic; dcl bc fixed bin (24) automatic; dcl 01 br_info aligned like status_branch automatic; dcl deleted bit (1) automatic; dcl ec fixed bin (35) automatic; dcl msf_sw bit (1) automatic; dcl 01 my_acl aligned like segment_acl_entry automatic; dcl 01 oi aligned like object_info automatic; dcl rbs (3) fixed bin (6) automatic; dcl segp ptr automatic; /* conditions */ dcl le_abort_ condition; /* builtin */ dcl addr builtin; dcl null builtin; abort = false; act_dname = dname; act_ename = ename; /* see if the item exists at all. If not, just return */ call hcs_$status_long (dname, ename, 1, addr (br_info), null, ec); if ec = error_table_$noentry then do; /* the target does not exist, we create it if the output target */ /* an msf and adjust the pathnames accordingly. */ if comp_count > 1 then do; call make_msf_ (dname, ename, rbs, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "Unable to create MSF output file ^a.", pathname_ (dname, ename)); act_dname = pathname_ (dname, ename); act_ename = ename; end; return; end; if le_util_$check_uid (lecp, null, (br_info.uid)) then call le_error_ (LE_ABORT_ERROR, le_et_$input_output_overlap, "^/The output file is the same as one of the input files."); /* try to initiate it as an object and validate that it is one. */ /* We generally want to query any time the target exists but is not */ /* an object file. Object_lib_$initiate will only return */ /* a zero code when called with the validate switch set if the */ /* target is a legitimate object file. */ deleted = false; call object_lib_$initiate (dname, ename, "", "1"b, segp, bc, msf_sw, ec); if ec ^= 0 then do; msf_sw = false; if ^force then call nd_handler_ ((le_data_$caller), dname, ename, ec); else call nd_handler_$force ((le_data_$caller), dname, ename, ec); if ec ^= 0 then signal le_abort_; deleted = true; end; else do; oi.version_number = object_info_version_2; call object_info_$brief (segp, bc, addr (oi), ec); if ^oi.format.bound then do; if force then call nd_handler_$force ((le_data_$caller), dname, ename, ec); else call nd_handler_ ((le_data_$caller), dname, ename, ec); if ec ^= 0 then signal le_abort_; msf_sw = false; deleted = true; end; end; if msf_sw then do; /* convert it to a SSF */ call unmake_msf_ (dname, ename, ""b, rbs, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/Unable to truncate MSF to a single segment. ^a", pathname_ (dname, ename)); end; if comp_count > 1 then do; if ^deleted then do; /* give myself enough access to turn this thing into an MSF */ my_acl.access_name = get_group_id_$tag_star (); my_acl.mode = REW_ACCESS; my_acl.extended_mode = ""b; my_acl.status_code = 0; call hcs_$add_acl_entries (dname, ename, addr (my_acl), 1, ec); end; /* create/convert MSF */ call make_msf_ (dname, ename, rbs, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/Unable to convert ^a to MSF format", pathname_ (dname, ename)); act_dname = pathname_ (dname, ename); end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include acl_structures; %include access_mode_values; %include le_data; %include object_info; %include status_structures; end le_create_binary_;  le_create_list_.pl1 12/10/86 1307.8rew 12/10/86 1251.4 311265 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to generate a listing segment. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_create_list_: proc (lecp, /** components pointer (in ) */ lebp, /** binaries pointer (in ) */ dname, /** directory name (in ) */ ename, /** entry name (in ) */ list); /** map/list switch (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_create_list_ */ /*** Input: lecp, lebp, dname, ename, list */ /*** Function: creates a listing segment detailing the inclusion */ /*** and disposition of: input components, links, and */ /*** definitions. Degree of detail is determined by */ /*** the list switch. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl NL char (1) static options (constant) init (" "); dcl section_name (0:4) char (4) static options (constant) init ("text", "link", "symb", "****", "stat"); /* parameters */ dcl lecp ptr parameter; dcl lebp ptr parameter; dcl dname char (*) parameter; dcl ename char (*) parameter; dcl list bit (1) parameter; /* procedures */ dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl get_shortest_path_ entry (char (*)) returns (char (168)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35)); dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl le_error_ entry options (variable); dcl le_util_$check_uid entry (ptr, ptr, bit (36) aligned) returns (bit (1)); dcl le_util_$get_user_and_version entry (char (*), char (*)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); /* external */ dcl le_data_$caller external char (32) varying; dcl le_et_$implementation_error external fixed bin (35); dcl le_et_$input_output_overlap external fixed bin (35); /* based */ dcl 01 def_list based, 02 count fixed bin, 02 def (0 refer (def_list.count)) like dl_entry; dcl 01 dl_entry aligned based, 02 name char (32), 02 offset fixed bin (18) unsigned unaligned, 02 comp fixed bin (9) unsigned unaligned, 02 section fixed bin (3) unsigned unaligned, 02 flags unaligned, 03 entrypoint bit (1), 03 indirect bit (1), 03 mbz bit (4); dcl 01 link_list aligned based, 02 count fixed bin, 02 lk (0 refer (link_list.count)) like ll_entry; dcl 01 ll_entry aligned based, 02 name char (64), 02 comp fixed bin (18) unsigned unaligned, 02 offset fixed bin (18) unsigned unaligned, 02 init_offset fixed bin (18) unsigned unaligned, 02 init_length fixed bin (18) unsigned unaligned; /* automatic */ dcl bc fixed bin (24) automatic; dcl created bit (1) aligned automatic; dcl ec fixed bin (35) automatic; dcl listp ptr automatic; dcl new_dname char (168) automatic; dcl new_ename char (168) automatic; dcl uid bit (36) aligned automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addcharno builtin; dcl addr builtin; dcl addrel builtin; dcl char builtin; dcl clock builtin; dcl copy builtin; dcl divide builtin; dcl fixed builtin; dcl index builtin; dcl length builtin; dcl ltrim builtin; dcl null builtin; dcl rel builtin; dcl reverse builtin; dcl rtrim builtin; dcl size builtin; dcl string builtin; dcl substr builtin; dcl unspec builtin; dcl verify builtin; call expand_pathname_$add_suffix (ename, "list", new_dname, new_ename, ec); call initiate_file_$create (new_dname, new_ename, RW_ACCESS, listp, created, bc, ec); if ec ^= 0 then do; call le_error_ (LE_ERROR, ec, "^/While creating listing file ^a.", new_ename); return; end; call hcs_$get_uid_seg (listp, uid, ec); if le_util_$check_uid (lecp, lebp, uid) then call le_error_ (LE_ABORT_ERROR, le_et_$input_output_overlap, "^/Listing file is the same as one of the input files," || "^/or the executable output."); bc = 0; call generate_map (listp, bc, lecp, lebp); if list then call generate_list (listp, bc, lecp, lebp); call terminate_file_ (listp, bc, TERM_FILE_TRUNC_BC_TERM, ec); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ generate_map: proc (listp, /** listing segment ptr (i/o) */ bc, /** segment bit count (i/o) */ lecp, /** components pointer (in ) */ lebp); /** binaries pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: generate_map */ /*** Input: listp, bc, lecp, lebp */ /*** Function: generates the map portion of the le_ listing from */ /*** information contained in the component table and */ /*** binaries table. */ /*** Output: listp, bc */ /*** */ /*** ****************************************************************/ /* parameters */ dcl listp ptr parameter; dcl bc fixed bin (24) parameter; dcl lecp ptr parameter; dcl lebp ptr parameter; /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 comp aligned like le_comp based (compp); /* automatic */ dcl compp ptr automatic; dcl pn char (168) automatic; dcl strp ptr automatic; dcl dn char (168) automatic; dcl dnl fixed bin automatic; dcl en char (32) automatic; dcl ec fixed bin (35) automatic; dcl user char (32) automatic; dcl version char (128) automatic; dcl value fixed bin (35) automatic; dcl comp_pic pic "zz9" automatic; dcl b fixed bin automatic; dcl 01 comp_info aligned automatic, 02 name char (32) unaligned, 02 pad1 char (1) unaligned, 02 compiler char (8) unaligned, 02 pad2 char (2) unaligned, 02 target char (3) unaligned, 02 start char (7) unaligned, 02 text_start char (7) unaligned, 02 stat_start char (7) unaligned, 02 symb_start char (7) unaligned, 02 nl_1 char (1) unaligned, 02 pad3 char (10) unaligned, 02 dtcm char (36) unaligned, 02 length char (7) unaligned, 02 text_length char (7) unaligned, 02 stat_length char (7) unaligned, 02 symb_length char (7) unaligned, 02 nl_2 char (1) unaligned; dcl c fixed bin automatic; dcl col fixed bin automatic; dcl symbolp ptr automatic; dcl dtcm fixed bin (71) automatic; strp = addcharno (listp, divide (bc, 9, 21, 0)); col = 1; /* generate the listing header */ call append (strp, bc, col, "Listing for "); call hcs_$fs_get_path_name (leb.binary (1).segp, dn, dnl, en, ec); if leb.n_binaries = 1 then pn = pathname_ (substr (dn, 1, dnl), en); else pn = substr (dn, 1, dnl); call append (strp, bc, col, rtrim (pn) || NL); call append (strp, bc, col, "Created on "); call append (strp, bc, col, date_time_$format ("date_time", clock (), "", "")); call le_util_$get_user_and_version (user, version); call append (strp, bc, col, ", by " || rtrim (user) || NL); call append (strp, bc, col, "Using " || rtrim (version) || NL || NL); /* create the source_map listing */ do c = 1 to lec.n_components; compp = addr (lec.comp (c)); if comp.flags.include & comp.flags.unique_path then call append (strp, bc, col, rtrim (get_shortest_path_ ((comp.path))) || NL); end; /* create the length listings */ if leb.n_binaries > 1 then call append (strp, bc, col, NL || "Comp "); else call append (strp, bc, col, (NL)); call append (strp, bc, col, " Object Text Defs Link Symb Static" || NL); do b = 1 to leb.n_binaries; if leb.n_binaries > 1 then do; comp_pic = b; call append (strp, bc, col, char (comp_pic) || " "); end; call append (strp, bc, col, "Start 0 "); value = fixed (rel (leb.binary (b).textp), 18); call append (strp, bc, col, oct (value, 6, " ") || " "); value = fixed (rel (leb.binary (b).defnp), 18); call append (strp, bc, col, oct (value, 6, " ") || " "); value = fixed (rel (leb.binary (b).linkp), 18); call append (strp, bc, col, oct (value, 6, " ") || " "); value = fixed (rel (leb.binary (b).symbp), 18); call append (strp, bc, col, oct (value, 6, " ") || " "); value = fixed (rel (leb.binary (b).statp), 18); call append (strp, bc, col, oct (value, 6, " ") || NL); if leb.n_binaries > 1 then call append (strp, bc, col, " Length "); else call append (strp, bc, col, "Length "); call append (strp, bc, col, oct (divide (leb.binary (b).bc, 36, 18, 0), 6, " ") || " "); call append (strp, bc, col, oct ((leb.binary (b).textl), 6, " ") || " "); call append (strp, bc, col, oct ((leb.binary (b).defnl), 6, " ") || " "); call append (strp, bc, col, oct ((leb.binary (b).linkl), 6, " ") || " "); call append (strp, bc, col, oct ((leb.binary (b).symbl), 6, " ") || " "); call append (strp, bc, col, oct ((leb.binary (b).statl), 6, " ") || NL); end; /* emit the per_component information */ call append (strp, bc, col, NL || "Name Language "); if leb.n_binaries > 1 then call append (strp, bc, col, "Comp "); else call append (strp, bc, col, " "); call append (strp, bc, col, " Text Static Symbol" || NL); call append (strp, bc, col, " Date Compiled" || NL); string (comp_info) = ""; comp_info.start = " start"; comp_info.length = " length"; comp_info.nl_1 = NL; comp_info.nl_2 = NL; do c = 1 to lec.n_components; compp = addr (lec.comp (c)); if comp.flags.include then do; comp_info.name = comp.name; comp_info.compiler = comp.compiler; /* insert the component number only if there was more than 1 */ /* component */ if leb.n_binaries > 1 then do; comp_pic = comp.target; comp_info.target = comp_pic; end; else comp_info.target = ""; symbolp = addrel (leb.binary (comp.target).symbp, comp.new.rel_symb); dtcm = symbolp -> std_symbol_header.object_created; comp_info.dtcm = date_time_$format ("date_time", dtcm, "", ""); comp_info.text_start = oct ((comp.new.rel_text), 7, " "); comp_info.stat_start = oct ((comp.new.rel_stat), 7, " "); comp_info.symb_start = oct ((comp.new.rel_symb), 7, " "); comp_info.text_length = oct ((comp.orig.textl), 7, " "); comp_info.stat_length = oct ((comp.orig.statl), 7, " "); comp_info.symb_length = oct ((comp.orig.symbl), 7, " "); call append (strp, bc, col, string (comp_info)); end; end; end generate_map; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ generate_list: proc (listp, /** list segment ptr (i/o) */ bc, /** segment bit count (i/o) */ lecp, /** components pointer (in ) */ lebp); /** binaries pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: generate_list */ /*** Input: listp, bc, lecp, lebp */ /*** Function: generates the extended listing. (after the basic */ /*** map listing.) This includes the link resolution */ /*** information and definition information. */ /*** Output: listp, bc */ /*** */ /*** ****************************************************************/ /* parameters */ dcl listp ptr parameter; dcl bc fixed bin (24) parameter; dcl lecp ptr parameter; dcl lebp ptr parameter; /* based */ dcl 01 acc aligned based (accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (acc.count)) unaligned; dcl 01 dl aligned based (scratchp), 02 count fixed bin, 02 def dim (0 refer (dl.count)) like def_list.def; dcl 01 def aligned like definition based (defp); dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lk aligned like object_link based (lkp); dcl 01 ll aligned based (scratchp), 02 count fixed bin, 02 lk dim (0 refer (ll.count)) like link_list.lk; dcl 01 sn aligned like segname_definition based (defp); dcl 01 vlh aligned like virgin_linkage_header based (vlhp); dcl 01 plk aligned like partial_link based (plkp); dcl word fixed bin (35) based; /* automatic */ dcl accp ptr automatic; dcl col fixed bin automatic; dcl defnp ptr automatic; dcl linkp ptr automatic; dcl defp ptr automatic; dcl plkp ptr automatic; dcl scratchp ptr automatic; dcl strp ptr automatic; dcl msf_sw bit (1) automatic; dcl d fixed bin automatic; dcl b fixed bin automatic; dcl l fixed bin automatic; dcl vlhp ptr automatic; dcl dhp ptr automatic; dcl lk_start fixed bin (18) unsigned automatic; dcl lk_end fixed bin (18) unsigned automatic; dcl offset fixed bin (18) unsigned automatic; dcl lkp ptr automatic; dcl count fixed bin automatic; scratchp = null; on cleanup begin; if scratchp ^= null then call release_temp_segment_ ((le_data_$caller), scratchp, 0); end; call get_temp_segment_ ((le_data_$caller), scratchp, ec); strp = addcharno (listp, divide (bc, 9, 21, 0)); col = 1; if leb.n_binaries > 1 then msf_sw = true; else msf_sw = false; /* emit the definition list */ if msf_sw then do; defnp = leb.binary (0).defnp; linkp = leb.binary (0).linkp; end; else defnp = leb.binary (1).defnp; /* count the number of visible definitions */ count = 0; do defp = addrel (defnp, defnp -> definition_header.def_list_relp) repeat addrel (defnp, def.forward_relp) while (defp -> word ^= 0); if ^def.flags.ignore then count = count + 1; end; call append (strp, bc, col, NL || NL || ltrim (rtrim (char (count)))); call append (strp, bc, col, " Definitions:" || NL); dl.count = -1; do defp = addrel (defnp, defnp -> definition_header.def_list_relp) repeat addrel (defnp, def.forward_relp) while (defp -> word ^= 0); if def.class = 3 & ^def.flags.ignore then do; /* we have found a segname, so sort any pending definitions */ /* and print them out, zero the count, and print the segname */ if dl.count ^= 0 then do; if dl.count > 0 then call print_defs (scratchp, msf_sw, strp, bc, col); else dl.count = 0; accp = addrel (defnp, def.name_relp); if sn.first_relp ^= sn.forward_relp then call append (strp, bc, col, NL || NL || "segnames: "); else call append (strp, bc, col, NL || NL || "segname: "); call append (strp, bc, col, acc.string || NL); end; else do; /* another segname on a block, just indent and display */ accp = addrel (defnp, def.name_relp); call append (strp, bc, col, " " || acc.string || NL); end; end; else if ^def.flags.ignore then do; /* a non-segname definition, so we add it to the table to be */ /* sorted and printed. */ d, dl.count = dl.count + 1; accp = addrel (defnp, def.name_relp); dl.def (d).name = acc.string; if def.flags.indirect then do; /* for indirect definitions, we get the target info from */ /* the partial link to the actual target in another */ /* component */ dl.def (d).flags.indirect = true; plkp = addrel (linkp, def.thing_relp); dl.def (d).comp = plk.component; dl.def (d).offset = plk.offset; dl.def (d).section = plk.type; end; else do; /* for non-indirect definitions we get the info from the */ /* definition itself. */ dl.def (d).comp = 0; dl.def (d).flags.indirect = false; dl.def (d).offset = def.thing_relp; dl.def (d).section = def.class; end; dl.def (d).flags.entrypoint = def.flags.entry; end; end; /* now sort and print the definitions for the last block */ if dl.count > 0 then call print_defs (scratchp, msf_sw, strp, bc, col); ll.count = 0; do b = 1 to leb.n_binaries; vlhp = leb.binary (b).linkp; dhp = leb.binary (b).defnp; lk_start = vlh.link_begin; if vlh.first_ref_relp ^= 0 then lk_end = vlh.first_ref_relp; else lk_end = vlh.linkage_section_lng; do offset = lk_start to lk_end; lkp = addrel (vlhp, offset); if lk.tag = FAULT_TAG_2 then do; l, ll.count = ll.count + 1; ll.lk (l).comp = b; ll.lk (l).offset = offset; call get_link_info (lkp, dhp, addr (ll.lk (l))); end; end; end; call print_links (scratchp, msf_sw, strp, bc, col); call release_temp_segment_ ((le_data_$caller), scratchp, ec); end generate_list; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ print_defs: proc (dlp, /** def list pointer (in ) */ msf_sw, /** MSF swtich (in ) */ strp, /** list file pointer (i/o) */ bc, /** list file bit count (i/o) */ col); /** display column (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: print_defs */ /*** Input: dlp, msf_sw, strp, bc, col */ /*** Function: sorts and prints out the definition list. */ /*** Output: strp, bc */ /*** */ /*** ****************************************************************/ /* parameters */ dcl dlp ptr parameter; dcl msf_sw bit (1) parameter; dcl strp ptr parameter; dcl bc fixed bin (24) parameter; dcl col fixed bin parameter; /* based */ dcl 01 dl aligned based (dlp), 02 count fixed bin, 02 def dim (0 refer (dl.count)) like def_list.def; /* automatic */ dcl i fixed bin automatic; dcl addr char (20) varying automatic; dcl fixed_addr char (20) automatic; dcl temp (1:size (dl_entry)) fixed bin (35) automatic; /* perform a heapsort on the definition list before printing it */ do i = divide (dl.count, 2, 17, 0) by -1 to 1; call adjust_heap (dlp, i, dl.count, size (dl_entry)); end; do i = dl.count to 2 by -1; unspec (temp) = unspec (dl.def (i)); unspec (dl.def (i)) = unspec (dl.def (1)); unspec (dl.def (1)) = unspec (temp); call adjust_heap (dlp, 1, i - 1, size (dl_entry)); end; /* now scan the sorted list and print out the definition list */ do i = 1 to dl.count; /* print each definition entry */ call append (strp, bc, col, (NL)); /* we only print the component, if there is more than one */ if msf_sw then addr = "(" || ltrim (rtrim (char (dl.def (i).comp))) || ")"; else addr = ""; /* produce the rest of the address field */ addr = addr || section_name (dl.def (i).section) || "|"; addr = addr || oct ((dl.def (i).offset), -1, " "); fixed_addr = addr; /* display the address */ call append (strp, bc, col, (fixed_addr)); /* display the name */ if dl.def (i).flags.indirect | dl.def (i).flags.entrypoint then call append (strp, bc, col, (dl.def (i).name)); else call append (strp, bc, col, rtrim (dl.def (i).name)); /* display the flags (if any) */ if dl.def (i).flags.indirect then call append (strp, bc, col, " Indirect"); if dl.def (i).flags.entrypoint then call append (strp, bc, col, " Entrypoint"); end; dl.count = 0; end print_defs; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_link_info: proc (lkp, /** link pointer (in ) */ dhp, /** def header pointer (in ) */ lep); /** link list entry ptr (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: get_link_info */ /*** Input: lkp, dhp, lep */ /*** Function: extracts information about a link and enters it */ /*** into a link list entry. */ /*** Output: lep */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lkp ptr parameter; dcl dhp ptr parameter; dcl lep ptr parameter; /* based */ dcl 01 lk aligned like object_link based (lkp); dcl 01 le aligned like ll_entry based (lep); dcl 01 init aligned like link_init based (initp); dcl 01 exp aligned like exp_word based (expp); dcl 01 tp aligned like type_pair based (tpp); dcl 01 segname aligned based (segnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (segname.count)) unaligned; dcl 01 offsetname aligned based (offsetnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (offsetname.count)) unaligned; /* automatic */ dcl expp ptr automatic; dcl tpp ptr automatic; dcl segnamep ptr automatic; dcl offsetnamep ptr automatic; dcl initp ptr automatic; dcl nm char (64) varying automatic; expp = addrel (dhp, lk.expression_relp); tpp = addrel (dhp, exp.type_relp); segnamep = addrel (dhp, tp.segname_relp); offsetnamep = addrel (dhp, tp.offsetname_relp); initp = addrel (dhp, tp.trap_relp); if tp.type = 1 then nm = rtrim (SYMBOLIC_SECTION_NAMES (tp.segname_relp)) || "|0"; else if tp.type = 3 then nm = segname.string || "$"; else if tp.type = 4 then do; if segname.string = offsetname.string then nm = segname.string; else nm = segname.string || "$" || offsetname.string; end; else if tp.type = 5 then nm = rtrim (SYMBOLIC_SECTION_NAMES (tp.segname_relp)) || "$" || offsetname.string; else if tp.type = 6 then do; if segname.string = offsetname.string then nm = segname.string; else nm = segname.string || "$" || offsetname.string; end; else call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Invalid link type (^d) found at ^p.", tp.type, lkp); if exp.expression > 0 then nm = nm || "+" || oct ((exp.expression), -1, " "); if lk.modifier ^= ""b then nm = nm || "," || modifier (fixed (lk.modifier, 6, 0)); le.name = nm; if (tp.type = 5 | tp.type = 6) & tp.trap_relp ^= 0 then do; le.init_offset = tp.trap_relp; le.init_length = init.n_words; end; else do; le.init_offset = 0; le.init_length = 0; end; %include op_mnemonic_format; end get_link_info; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ print_links: proc (llp, /** link list pointer (in ) */ msf_sw, /** MSF switch (in ) */ strp, /** list seg pointer (i/o) */ bc, /** list seg bit count (i/o) */ col); /** display column (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: print_links */ /*** Input: llp, msf_sw, strp, bc, col */ /*** Function: sorts and prints out the list of retained links. */ /*** Output: strp, bc, col */ /*** */ /*** ****************************************************************/ /* parameters */ dcl llp ptr parameter; dcl msf_sw bit (1) parameter; dcl strp ptr parameter; dcl bc fixed bin (24) parameter; dcl col fixed bin parameter; /* based */ dcl 01 ll aligned based (llp), 02 count fixed bin, 02 lk dim (0 refer (ll.count)) like link_list.lk; /* automatic */ dcl temp (1:size (ll_entry)) fixed bin (35) automatic; dcl i fixed bin automatic; dcl comp char (5) varying automatic; dcl fixed_comp char (5) automatic; dcl addr char (12) varying automatic; dcl fixed_addr char (12) automatic; dcl init char (64) varying automatic; call append (strp, bc, col, NL || NL); do i = divide (ll.count, 2, 17, 0) by -1 to 1; call adjust_heap (llp, i, ll.count, size (ll_entry)); end; do i = ll.count by -1 to 2; unspec (temp) = unspec (ll.lk (i)); unspec (ll.lk (i)) = unspec (ll.lk (1)); unspec (ll.lk (1)) = unspec (temp); call adjust_heap (llp, 1, i - 1, size (ll_entry)); end; call append (strp, bc, col, NL || ltrim (rtrim (char (ll.count)))); call append (strp, bc, col, " Links:" || NL || NL); do i = 1 to ll.count; if msf_sw then do; comp = "(" || rtrim (ltrim (char (ll.lk (i).comp))) || ")"; fixed_comp = copy (" ", length (fixed_comp) - length (comp)) || comp; call append (strp, bc, col, (fixed_comp)); end; addr = "link|" || oct ((ll.lk (i).offset), -1, " "); fixed_addr = addr; call append (strp, bc, col, fixed_addr || rtrim (ll.lk (i).name)); if ll.lk (i).init_offset ^= 0 then do; init = " Init -> def|" || oct ((ll.lk (i).init_offset), -1, " "); init = init || ", length = "; init = init || ltrim (rtrim (char (ll.lk (i).init_length))); call append (strp, bc, col, init); end; call append (strp, bc, col, (NL)); end; end print_links; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ adjust_heap: proc (heapp, /** heap pointer (i/o) */ top, /** top node index (in ) */ last, /** end node index (in ) */ n_words); /** size of entry (in ) */ /*** ****************************************************************/ /*** */ /*** Name: adjust_heap */ /*** Input: heapp, top, last, n_words */ /*** Function: adjusts a heap structure so that a given node is */ /*** always greater than both its children. */ /*** Output: heapp */ /*** */ /*** ****************************************************************/ /* parameters */ dcl heapp ptr parameter; dcl top fixed bin parameter; dcl last fixed bin parameter; dcl n_words fixed bin parameter; /* based */ dcl 01 heap aligned based (heapp), 02 count fixed bin, 02 entry (0 refer (heap.count)) bit (n_words * 36); /* automatic */ dcl l fixed bin automatic; dcl r fixed bin automatic; dcl side fixed bin automatic; dcl temp bit (n_words * 36) automatic; l = top * 2; r = l + 1; if l > last then return; if r > last then do; if heap.entry (top) < heap.entry (l) then do; temp = heap.entry (l); heap.entry (l) = heap.entry (top); heap.entry (top) = temp; end; return; end; if heap.entry (top) > heap.entry (l) & heap.entry (top) > heap.entry (r) then return; if heap.entry (l) > heap.entry (r) then side = l; else side = r; temp = heap.entry (side); heap.entry (side) = heap.entry (top); heap.entry (top) = temp; call adjust_heap (heapp, side, last, n_words); return; end adjust_heap; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ append: proc (strp, /** string pointer (i/o) */ bc, /** bit count (i/o) */ col, /** current column (i/o) */ text); /** text to append (in ) */ /*** ****************************************************************/ /*** */ /*** Name: append */ /*** Input: strp, bc, col, text */ /*** Function: appends the text given to to the segment pointed */ /*** to by strp, and adjusts strp and bc appropriately */ /*** Output: strp, bc */ /*** */ /*** ****************************************************************/ /* parameters */ dcl strp ptr parameter; dcl bc fixed bin (24) parameter; dcl col fixed bin parameter; dcl text char (*) varying parameter; /* based */ dcl str char (strl) unaligned based (strp); /* automatic */ dcl strl fixed bin (21) automatic; dcl new char (512) varying automatic; call tabin (text, col, new); strl = length (new); str = new; strp = addcharno (strp, strl); bc = bc + strl * 9; end append; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ tabin: proc (old, /** old text (in ) */ col, /** start column (i/o) */ new); /** new text (out) */ /*** ****************************************************************/ /*** */ /*** Name: tabin */ /*** Input: old, col */ /*** Function: replaces spaces with tabs in the output listing */ /*** Output: col, new */ /*** */ /*** ****************************************************************/ /* parameters */ dcl old char (*) varying parameter; dcl col fixed bin parameter; dcl new char (*) varying parameter; /* automatic */ dcl start fixed bin automatic; dcl left fixed bin automatic; dcl first fixed bin automatic; dcl tab_col fixed bin automatic; dcl nlx fixed bin automatic; new = ""; start = 1; left = length (old); do while (left > 0); first = index (substr (old, start, left), " "); if first = 0 then first = left; else first = first - 1; if first > 0 then do; nlx = index (reverse (substr (old, start, first)), NL); if nlx > 0 then col = nlx; else col = col + first; new = new || substr (old, start, first); start = start + first; left = left - first; end; if left > 0 then do; first = verify (substr (old, start, left), " "); if first = 0 then first = left; else first = first - 1; tab_col = divide (col + 9, 10, 17, 0) * 10 + 1; col = col + first; left = left - first; start = start + first; if col >= tab_col then do; do while (tab_col <= col); new = new || " "; tab_col = tab_col + 10; end; tab_col = tab_col - 10; if col ^= tab_col then new = new || copy (" ", col - tab_col); end; else new = new || copy (" ", first); end; end; end tabin; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ oct: proc (value, /** value to convert (in ) */ size, /** field length (in ) */ pad) /** pad character (in ) */ returns (char (32) varying); /** octal string (out) */ /*** ****************************************************************/ /*** */ /*** Name: oct */ /*** Input: value, size, pad */ /*** Function: converts a number to a string of octal digits of */ /*** a given length, padded with a given character. */ /*** Output: octal_string */ /*** */ /*** ****************************************************************/ /* constants */ dcl octal (0:7) char (1) static options (constant) init ("0", "1", "2", "3", "4", "5", "6", "7"); /* parameters */ dcl value fixed bin (35) parameter; dcl size fixed bin parameter; dcl pad char (1) parameter; /* based */ dcl digit (1:12) fixed bin (3) unsigned unaligned based (addr (value)); /* automatic */ dcl string char (32) varying automatic; dcl overflow bit (1) automatic; dcl padding bit (1) automatic; dcl d fixed bin automatic; string = ""; overflow = false; padding = true; if size > 12 then string = copy (pad, size - 12); do d = 1 to 12; if d = 12 then padding = false; if 13 - d > size & size > 0 then do; if digit (d) ^= 0 then overflow = true; else ; end; else do; if overflow then string = string || "*"; else if padding & digit (d) = 0 then do; if size > 0 then string = string || pad; else ; end; else do; string = string || octal (digit (d)); if digit (d) ^= 0 then padding = false; end; end; end; return (string); end oct; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include definition_dcls; %include le_data; %include object_link_dcls; %include std_symbol_header; %include terminate_file; end le_create_list_;  le_data_.cds 12/10/86 1309.0rew 12/10/86 1252.3 30168 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to define constant and static data used by le_. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_data_: proc; /*** ****************************************************************/ /*** */ /*** Name: le_data_ */ /*** Function: This procedure is used to create the le_data_ */ /*** data segment for the linkage editor (le). */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); /* procedures */ dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (ptr, fixed bin (35)); /* automatic */ dcl ec fixed bin (35) automatic; dcl 01 le_cds_args aligned like cds_args automatic; dcl 01 le_static_data aligned automatic, 02 caller char (32) varying, 02 debug bit (1), 02 display_severity fixed bin, 02 max_severity fixed bin, 02 patch_ptr ptr, 02 running bit (1); dcl 01 le_text_data aligned automatic, 02 version_number fixed bin, 02 version_string char (64) varying, 02 version_suffix char (64) varying; /* builtin */ dcl addr builtin; dcl null builtin; dcl size builtin; dcl string builtin; /* build the cds_args structure */ le_cds_args.sections (1).p = addr (le_text_data); le_cds_args.sections (1).len = size (le_text_data); le_cds_args.sections (1).struct_name = "le_text_data"; le_cds_args.sections (2).p = addr (le_static_data); le_cds_args.sections (2).len = size (le_static_data); le_cds_args.sections (2).struct_name = "le_static_data"; le_cds_args.seg_name = "le_data_"; le_cds_args.num_exclude_names = 0; le_cds_args.exclude_array_ptr = null; string (le_cds_args.switches) = ""b; le_cds_args.switches.have_text = true; le_cds_args.switches.have_static = true; /* initialize the text and static section data */ le_text_data.version_number = 1; le_text_data.version_string = "le 1.0"; le_text_data.version_suffix = " Version 1.0 of November 27, 1986"; le_static_data.caller = ""; le_static_data.debug = false; le_static_data.display_severity = 0; le_static_data.max_severity = 0; le_static_data.patch_ptr = null; le_static_data.running = ""b; /* create the segment */ call create_data_segment_ (addr (le_cds_args), ec); if ec ^= 0 then call com_err_ (ec, "le_data_"); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include cds_args; end le_data_;  le_debug_.pl1 12/10/86 1307.8rew 12/10/86 1251.9 20205 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to display debugging information if the debug flag was set in the input structure. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_debug_: proc; /*** ****************************************************************/ /*** */ /*** Name: le_debug_ */ /*** Input: ioa_ control string and ioa_args */ /*** Function: if debugging is enables (as indicated by the */ /*** variable le_data_$debug) then print a message of */ /*** the form: */ /*** (debug): user message */ /*** on the user_output switch. Where if the */ /*** name of the caller of le_ as supplied in the */ /*** le_input data structure, and the user message is */ /*** that produced by calling ioa_ */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* procedures */ dcl cu_$arg_list_ptr entry (ptr); dcl cu_$generate_call entry (entry, ptr); dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); /* external */ dcl le_data_$caller external char (32) varying; dcl le_data_$debug external bit (1); /* automatic */ dcl arg_listp ptr automatic; /* just return if debugging is off */ if ^le_data_$debug then return; /* identify the message as a debug message */ call ioa_$nnl ("^a (debug): ", le_data_$caller); /* pass the args on to ioa_ for the user message */ call cu_$arg_list_ptr (arg_listp); call cu_$generate_call (ioa_, arg_listp); end le_debug_;  le_emit_defs_.pl1 12/10/86 1307.8rew 12/10/86 1251.7 74466 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to emit the definitions for a single component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_emit_defs_: proc (ocudp, /** ocu_data pointer (in ) */ lecp, /** components pointer (i/o) */ c); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_emit_defs_ */ /*** Input: ocudp, lecp, c */ /*** Function: emits the definitions for a given component. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl hdr_size fixed bin static options (constant) init (8); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl c fixed bin parameter; /* procedures */ dcl le_error_ entry options (variable); dcl le_snap_ entry (ptr, ptr, fixed bin, fixed bin (3), uns fixed bin (18), uns fixed bin (18), bit (1), fixed bin (3), uns fixed bin (18), bit (6), bit (1)); /* external */ dcl error_table_$bad_class_def external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (0 refer (les.n_segnames)) like le_segnames.segname; dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; /* automatic */ dcl chase fixed bin automatic; dcl flags bit (4) automatic; dcl ignore_block bit (1) automatic; dcl internal bit (1) automatic; dcl ledp ptr automatic; dcl lelp ptr automatic; dcl lesp ptr automatic; dcl library bit (1) automatic; dcl link_ref bit (1) automatic; dcl modifier bit (6) automatic; dcl new_relp fixed bin (18) unsigned automatic; dcl relp fixed bin (18) unsigned automatic; dcl section fixed bin (3) automatic; dcl stat_relp fixed bin (18) unsigned automatic; dcl symb_relp fixed bin (18) unsigned automatic; dcl text_relp fixed bin (18) unsigned automatic; dcl type fixed bin automatic; /* builtin */ dcl null builtin; dcl rtrim builtin; /* get the table pointers */ lesp = lec.comp (c).tables.lesp; ledp = lec.comp (c).tables.ledp; lelp = lec.comp (c).tables.lelp; /* get the relocation counters */ text_relp = lec.comp (c).new.rel_text; stat_relp = lec.comp (c).new.rel_stat; symb_relp = lec.comp (c).new.rel_symb; library = lec.comp (c).flags.library; ignore_block = true; /* see if any definitions in this block are being emitted */ do chase = 1 to led.n_defs while (ignore_block); /* unreferenced library entrypoints are deleted regardless */ if library & ^led.def (chase).flags.referenced then do; led.def (chase).flags.retain, led.def (chase).flags.no_link = false; led.def (chase).flags.delete = true; end; /* if we find a non-deleted entrypoint, then we keep the block */ if led.def (chase).flags.retain & ^led.def (chase).flags.ignore then ignore_block = false; end; /* set the ignore flag for the segnames if we are ignoring the block */ if ignore_block then flags = DEFINITION_FLAGS_IGNORE; else flags = ""b; /* emit the segnames for the block */ do chase = 1 to les.n_segnames; les.segname (chase).relp = ocu_$emit_segname (ocudp, rtrim (les.segname (chase).str), flags); end; /* now emit the definitions in the block */ do chase = 1 to led.n_defs; /* see if this definition should be emitted */ if (^led.def (chase).delete & ^led.def (chase).ignore) | led.def (chase).force_retain then do; /* set the definition flags */ if led.def (chase).flags.force_retain then flags = DEFINITION_FLAGS_RETAIN; else flags = ""b; if led.def (chase).flags.ignore | led.def (chase).flags.delete then flags = flags | DEFINITION_FLAGS_IGNORE; type = led.def (chase).type; /* handle the definition based on the target section */ if type = Text then do; /* text reference: relocate it and check to see if it is */ /* an entrypoint. Then emit it. */ relp = led.def (chase).relp + text_relp; if led.def (chase).flags.entrypoint then flags = flags | DEFINITION_FLAGS_ENTRY; led.def (chase).new_offset = ocu_$emit_definition (ocudp, led.def (chase).str, Text, relp, flags); end; else if type = Symbol then do; /* symbol reference: just relocate and emit. */ relp = led.def (chase).relp + symb_relp; led.def (chase).new_offset = ocu_$emit_definition (ocudp, led.def (chase).str, Symbol, relp, flags); end; else if type = Static then do; /* static reference: just relocate and emit. */ relp = led.def (chase).relp + stat_relp; led.def (chase).new_offset = ocu_$emit_definition (ocudp, led.def (chase).str, Static, relp, flags); end; else if type = Linkage then do; /* linkage reference: see if it is actually a reference */ /* to combined static. If so, relocate */ /* and emit. If not, we have a link */ /* reference, so we snap the link to */ /* remove excess indirection, but then */ /* we must insure that the target of */ /* the definition is a link, so if it */ /* did not resolve to the linkage */ /* section, we emit a type-1 link to */ /* the target and have the definition */ /* point there. */ if lec.comp (c).flags.separate_static then link_ref = true; else if led.def (chase).relp > hdr_size + lec.comp (c).orig.defnl then link_ref = true; else link_ref = false; if ^link_ref then do; /* we have a reference to a combined static section */ /* so we convert it back to a static reference and */ /* emit the definition with the appropriate reloc */ relp = led.def (chase).relp + stat_relp - hdr_size; led.def (chase).new_offset = ocu_$emit_definition (ocudp, led.def (chase).str, Static, relp, flags); end; else do; /* we have a reference to a link, which may indirect */ /* through another link (ie. a PASCAL exportable */ /* variable represented as a link.) So we first see */ /* if this link was resolved somewhere, and if it is, */ /* we generate a type-1 (link-self-base) link to the */ /* eventual target. */ call le_snap_ (ocudp, lecp, c, Definition, led.def (chase).offset + 1, relp, false, section, new_relp, modifier, internal); if section ^= Linkage then new_relp = ocu_$emit_link (ocudp, Self_Base, section, "", "", (new_relp), modifier, null); led.def (chase).new_offset = ocu_$emit_definition (ocudp, led.def (chase).str, Linkage, new_relp, flags); end; end; else call le_error_ (LE_FATAL_ERROR, error_table_$bad_class_def, "^/at def|^o in component ^a.", led.def (chase).offset, lec.comp (c).name); end; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include ocu_dcls; end le_emit_defs_;  le_emit_firstref_.pl1 12/10/86 1307.8rew 12/10/86 1251.4 36090 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to emit the first reference traps for a single input component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_emit_firstref_: proc (ocudp, /** ocu_data pointer (in ) */ lecp, /** components pointer (in ) */ c); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_emit_firstref_ */ /*** Input: ocudp, lecp, c */ /*** Function: emits the first reference traps contained in a */ /*** component. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* constants */ dcl false bit (1) static options (constant) init ("0"b); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl c fixed bin parameter; /* procedures */ dcl le_snap_ entry (ptr, ptr, fixed bin, fixed bin (3), uns fixed bin (18), uns fixed bin (18), bit (1), fixed bin (3), uns fixed bin (18), bit (6), bit (1)); /* based */ dcl 01 frt aligned based (frtp), 02 decl_vers fixed bin, 02 n_traps fixed bin, 02 trap_array dim (0 refer (frt.n_traps)) like fr_traps.trap_array; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 vlh aligned like virgin_linkage_header based (vlhp); /* automatic */ dcl call_relp fixed bin (18) unsigned automatic; dcl frtp ptr automatic; dcl info_relp fixed bin (18) unsigned automatic; dcl internal bit (1) automatic; dcl modifier bit (6) automatic; dcl relp fixed bin (18) unsigned automatic; dcl section fixed bin (3) automatic; dcl t fixed bin automatic; dcl vlhp ptr automatic; /* builtin */ dcl addrel builtin; dcl null builtin; /* get the linkage header for the component */ vlhp = lec.comp (c).orig.linkp; /* if there are no traps then return */ if vlh.first_ref_relp = 0 then return; /* get the trap block */ frtp = addrel (vlhp, vlh.first_ref_relp); do t = 1 to frt.n_traps; /* for each trap, emit the link pointed to by the call relp */ call le_snap_ (ocudp, lecp, c, Linkage, vlh.first_ref_relp + 1 + t, (frt.trap_array (t).call_relp), false, section, relp, modifier, internal); if section ^= Linkage then call_relp = ocu_$emit_link (ocudp, Self_Base, section, "", "", (relp), ""b, null); /* emit the link for the info relp (if any) */ if frt.trap_array (t).info_relp ^= 0 then do; call le_snap_ (ocudp, lecp, c, Linkage, vlh.first_ref_relp + 1 + t, (frt.trap_array (t).info_relp), false, section, relp, modifier, internal); if section ^= Linkage then info_relp = ocu_$emit_link (ocudp, Self_Base, section, "", "", (relp), ""b, null); end; else info_relp = 0; /* emit the first reference trap */ call ocu_$emit_firstref_trap (ocudp, call_relp, info_relp); end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include object_link_dcls; %include ocu_dcls; end le_emit_firstref_;  le_emit_static_.pl1 12/10/86 1307.8rew 12/10/86 1251.5 61659 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to emit the static section for a single input component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_emit_static_: proc (ocudp, /** ocu data pointer (in ) */ lecp, /** components pointer (i/o) */ c); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_emit_static_ */ /*** Input: ocudp, lecp, c */ /*** Function: emits the static section of a given input */ /*** component. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl Left fixed bin static options (constant) init (1); dcl Right fixed bin static options (constant) init (2); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl c fixed bin parameter; /* procedures */ dcl le_error_ entry options (variable); dcl le_util_$scan_relinfo entry (ptr, fixed bin, bit (1), fixed bin, char (*)); /* external */ dcl le_et_$implementation_error external fixed bin (35); dcl le_et_$invalid_relinfo external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 word18 aligned based (addr (word)), 02 side (1:2) fixed bin (18) unsigned unaligned; /* automatic */ dcl found bit (1) automatic; dcl len fixed bin (18) unsigned automatic; dcl n_words fixed bin automatic; dcl odd bit (1) automatic; dcl original_relp fixed bin (19) automatic; dcl pad (1:16) bit (36) aligned automatic; dcl rel char (2) automatic; dcl rel_char char (1) automatic; dcl relindex fixed bin automatic; dcl relinfop ptr automatic; dcl relp fixed bin (18) unsigned automatic; dcl s fixed bin automatic; dcl skip fixed bin automatic; dcl statp ptr automatic; dcl text_relp fixed bin (18) unsigned automatic; dcl word bit (36) aligned automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl hbound builtin; dcl min builtin; dcl size builtin; dcl substr builtin; dcl unspec builtin; /* align the static as required by padding with zeros */ n_words = lec.comp (c).new.static_pad; unspec (pad) = ""b; do while (n_words > 0); len = min (hbound (pad, 1), n_words); relp = ocu_$emit_static (ocudp, addr (pad), len); n_words = n_words - len; end; /* if there is no static, just return */ original_relp = -1; if lec.comp (c).orig.statl = 0 then return; /* if the static is separate, there is no relinfo so just emit it */ if lec.comp (c).flags.separate_static then original_relp = ocu_$emit_static (ocudp, lec.comp (c).orig.statp, (lec.comp (c).orig.statl)); else do; /* the static is combined, so if the object is an error table */ /* there may be text relocation for the message offsets, so we */ /* relocate it. */ n_words = 0; relinfop = lec.comp (c).orig.rel_linkp; text_relp = lec.comp (c).new.rel_text; relindex = 1; odd = false; found = false; /* first we skip over the relocation info for the linkage header */ do while (n_words < size (virgin_linkage_header)); call le_util_$scan_relinfo (relinfop, relindex, odd, skip, rel); if n_words + skip >= size (virgin_linkage_header) then do; n_words = size (virgin_linkage_header); skip = skip + n_words - size (virgin_linkage_header); found = true; end; else n_words = n_words + skip + 1; end; /* if we used all of the info from the last scan in skipping */ /* over the header scan for the next non-absolute word. */ if ^found then call le_util_$scan_relinfo (relinfop, relindex, odd, skip, rel); n_words = 0; statp = lec.comp (c).orig.statp; do while (n_words < lec.comp (c).orig.statl); /* emit the intervening static words */ if skip > 0 then do; /* since there may be links after the end of the static */ /* section, we may end up skipping more than the length */ /* of the section so only emit as may words as are left */ /* in the static section. */ len = min (skip, lec.comp (c).orig.statl - n_words); relp = ocu_$emit_static (ocudp, statp, len); if original_relp < 0 then original_relp = relp; statp = addrel (statp, len); n_words = n_words + len; end; /* copy the word to be relocated */ unspec (word) = unspec (statp -> word18); do s = Left to Right while (n_words < lec.comp (c).orig.statl); /* for each side of the non-absolute word */ rel_char = substr (rel, s, 1); if rel_char = "a" then ; else if rel_char = "t" then word18.side (s) = word18.side (s) + text_relp; else call le_error_ (LE_ERROR, le_et_$invalid_relinfo, "^/Relocation ""^a"" at static|^o of component ""^a"".", rel, n_words, lec.comp (c).name); end; /* if the word is within the static section, then emit it. */ if n_words < lec.comp (c).orig.statl then do; relp = ocu_$emit_static (ocudp, addr (word), 1); if original_relp < 0 then original_relp = relp; statp = addrel (statp, 1); n_words = n_words + 1; call le_util_$scan_relinfo (relinfop, relindex, odd, skip, rel); end; end; end; /* make sure it was emitted where we calculated is should be emitted */ if original_relp ^= lec.comp (c).new.rel_stat then call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Static for ^a relocated to ^d instead of ^d as expected.", lec.comp (c).name, original_relp, lec.comp (c).new.rel_stat); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include object_link_dcls; %include ocu_dcls; end le_emit_static_;  le_emit_symbol_.pl1 12/10/86 1307.9rew 12/10/86 1251.4 83349 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to relocate and emit the symbol section for a single input component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_emit_symbol_: proc (ocudp, /** ocu data pointer (in ) */ lecp, /** components pointer (i/o) */ c); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_emit_symbol_ */ /*** Input: ocudp, lecp, c */ /*** Function: emits the symbol section of a single input */ /*** component. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl Left fixed bin static options (constant) init (1); dcl Right fixed bin static options (constant) init (2); dcl Table_Removed_Mask bit (36) static options (constant) init ("000000010000"b3); dcl Root_Offset fixed bin (18) unsigned static options (constant) init (5); dcl Map_Offset fixed bin (18) unsigned static options (constant) init (6); dcl Flag_Offset fixed bin (18) unsigned static options (constant) init (3); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl c fixed bin parameter; /* procedures */ dcl le_error_ entry options (variable); dcl le_snap_ entry (ptr, ptr, fixed bin, fixed bin (3), uns fixed bin (18), uns fixed bin (18), bit (1), fixed bin (3), uns fixed bin (18), bit (6), bit (1)); dcl le_util_$scan_relinfo entry (ptr, fixed bin, bit (1), fixed bin, char (*)); /* external */ dcl le_et_$implementation_error external fixed bin (35); dcl le_et_$invalid_relinfo external fixed bin (35); dcl le_et_$unsupported_relinfo external fixed bin (35); /* based */ dcl based_word bit (36) aligned based; dcl 01 comp aligned like le_comp based (compp); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 word18 aligned based (addr (word)), 02 side (1:2) fixed bin (18) unsigned unaligned; /* automatic */ dcl compp ptr automatic; dcl internal bit (1) automatic; dcl modifier bit (6) automatic; dcl n_words fixed bin (18) unsigned automatic; dcl odd bit (1) automatic; dcl pad_words (1:16) bit (36) aligned automatic; dcl rel char (2) automatic; dcl relindex fixed bin automatic; dcl relp fixed bin (18) unsigned automatic; dcl relstr char (4096) varying automatic; dcl relstrp ptr automatic; dcl s fixed bin automatic; dcl sbp ptr automatic; dcl section fixed bin (3) automatic; dcl size fixed bin (18) unsigned automatic; dcl skip fixed bin automatic; dcl start fixed bin (18) unsigned automatic; dcl stat_relp fixed bin (18) unsigned automatic; dcl symb_relp fixed bin (18) unsigned automatic; dcl symbp ptr automatic; dcl text_relp fixed bin (18) unsigned automatic; dcl value fixed bin (35) automatic; dcl word bit (36) aligned automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl copy builtin; dcl fixed builtin; dcl min builtin; dcl null builtin; dcl substr builtin; compp = addr (lec.comp (c)); relindex = 1; odd = false; n_words = 0; symbp = comp.orig.symbp; relstrp = addrel (addr (relstr), 1); /* extract the relocation counters */ text_relp = comp.new.rel_text; stat_relp = comp.new.rel_stat; symb_relp = comp.new.rel_symb; /* pad the symbol section to put it on a doubleword boundary */ if comp.new.symbol_pad > 0 then do; n_words = comp.new.symbol_pad; relstr = copy ("aa", n_words); relp = ocu_$emit_symbol (ocudp, addr (pad_words), relstrp, n_words); end; start = 0; n_words = 0; /* emit the section */ do while (n_words < comp.orig.symbl); /* scan for a non-absolute word */ call le_util_$scan_relinfo (comp.orig.rel_symbp, relindex, odd, skip, rel); /* emit the intervening words with absolute relocation */ do while (skip > 0 & n_words < comp.orig.symbl); size = min (2048, skip, comp.orig.symbl - n_words); relstr = copy ("aa", size); relp = ocu_$emit_symbol (ocudp, symbp, relstrp, size); if start = 0 then start = relp; skip = skip - size; symbp = addrel (symbp, size); n_words = n_words + size; end; /* copy the word to relocate */ word = symbp -> based_word; do s = Left to Right while (n_words < comp.orig.symbl); /* for each halfword . . . */ /* abrolute or self-relative */ if substr (rel, s, 1) = "a" | substr (rel, s, 1) = "r" then ; /* no relocation required */ /* text relative */ else if substr (rel, s, 1) = "t" | substr (rel, s, 1) = "1" then do; value = word18.side (s) + text_relp; word18.side (s) = addr (value) -> word18.side (2); end; /* definition relative (not supported) */ else if substr (rel, s, 1) = "d" then call le_error_ (LE_FATAL_ERROR, le_et_$unsupported_relinfo, "^/Relocation code ""^a"" found at symbol|^o in ^a.", substr (rel, s, 1), n_words, comp.name); /* 18 bit linkage reference */ else if substr (rel, s, 1) = "2" | substr (rel, s, 1) = "3" then do; /* snap the link to its target and then make sure that the */ /* reference is still to a link by emitting a type-1 link */ /* to the target if the target is not a linkage reference. */ call le_snap_ (ocudp, lecp, c, Symbol, n_words, (word18.side (s)), false, section, relp, modifier, internal); if section = Linkage then word18.side (s) = relp; else word18.side (s) = ocu_$emit_link (ocudp, Self_Base, section, "", "", (relp), ""b, null); end; /* symbol reference */ else if substr (rel, s, 1) = "s" | substr (rel, s, 1) = "7" then do; value = word18.side (s) + symb_relp; word18.side (s) = addr (value) -> word18.side (Right); end; /* 18 bit static reference */ else if substr (rel, s, 1) = "8" then word18.side (s) = word18.side (s) + stat_relp; else call le_error_ (LE_FATAL_ERROR, le_et_$invalid_relinfo, "^/Relocation code ""^a"" found at symbol|^o in ^a.", substr (rel, s, 1), n_words, comp.name); end; /* if not off the end, then emit the word */ if n_words < comp.orig.symbl then do; relp = ocu_$emit_symbol (ocudp, addr (word), addr (rel), 1); if start = 0 then start = relp; n_words = n_words + 1; symbp = addrel (symbp, 1); end; end; /* make sure the section starts where we calculated that it would */ if start ^= 0 & start ^= lec.comp (c).new.rel_symb then call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Symbol for ^a emitted at ^d instead of ^d as expected.", lec.comp (c).name, start, lec.comp (c).new.rel_symb); /* if we deleted the symbol table from the component, then patch */ /* the pl1 symbol block to indicate that there is no table. */ if start ^= 0 & lec.comp (c).flags.delete_table then do; sbp = lec.comp (c).symbp; if sbp -> std_symbol_header.area_pointer ^= ""b then do; sbp = addrel (sbp, sbp -> std_symbol_header.area_pointer); if sbp -> pl1_symbol_block.identifier = "pl1info" then do; /* clear the root offset */ call ocu_$backpatch (ocudp, "symbol", start + Root_Offset, "left 18 unsigned", 0); /* clear the map start and length */ call ocu_$backpatch (ocudp, "symbol", start + Map_Offset, "left 18 unsigned", 0); call ocu_$backpatch (ocudp, "symbol", start + Map_Offset, "right 18 unsigned", 0); /* copy the flag bits, mask the table_removed bit on, */ /* and patch the halfword. */ word = ""b; word18.side (2) = addr (sbp -> pl1_symbol_block.flags) -> word18.side (1); word = word | Table_Removed_Mask; call ocu_$backpatch (ocudp, "symbol", start + Flag_Offset, "left 18 unsigned", fixed (word, 35)); end; end; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include std_symbol_header; %include pl1_symbol_block; %include ocu_dcls; end le_emit_symbol_;  le_emit_text_.pl1 12/10/86 1307.9rew 12/10/86 1251.5 115290 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to relocate and emit the text section of a single input component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_emit_text_: proc (ocudp, /** ocu_data pointer (in ) */ lecp, /** components pointer (i/o) */ c); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_emit_text_ */ /*** Input: ocudp, lecp, c */ /*** Function: emits the text section of the given input */ /*** component and relocates references. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl Left fixed bin static options (constant) init (1); dcl Right fixed bin static options (constant) init (2); dcl Section_Rel_15 (0:4) char (1) static options (constant) init ("t", "l", "a", "d", "i"); dcl special_case (1:4) bit (18) static options (constant) init ("551"b3, "552"b3, "751"b3, "752"b3); dcl special_case_name (1:4) char (4) static options (constant) init ("stba", "stbq", "stca", "stcq"); dcl Indirect_and_Tally bit (2) static options (constant) init ("10"b); dcl Indirect_then_Register bit (2) static options (constant) init ("11"b); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl c fixed bin parameter; /* procedures */ dcl le_backpatch_ entry (fixed bin, fixed bin, uns fixed bin (18), fixed bin, fixed bin); dcl le_error_ entry options (variable); dcl le_snap_ entry (ptr, ptr, fixed bin, fixed bin (3), uns fixed bin (18), uns fixed bin (18), bit (1), fixed bin (3), uns fixed bin (18), bit (6), bit (1)); dcl le_util_$scan_relinfo entry (ptr, fixed bin, bit (1), fixed bin, char (*)); /* external */ dcl le_et_$bad_def_reference external fixed bin (35); dcl le_et_$bad_instr_format external fixed bin (35); dcl le_et_$implementation_error external fixed bin (35); dcl le_et_$invalid_relinfo external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 word15 aligned based (addr (instr)), 02 halfword (1:2) unaligned, 03 pad bit (3), 03 side fixed bin (15) unsigned; dcl 01 word18 aligned based (addr (instr)), 02 side (1:2) fixed bin (18) unsigned unaligned; /* automatic */ dcl abort bit (1) automatic; dcl d fixed bin automatic; dcl found bit (1) automatic; dcl initial_relp fixed bin (19) automatic; dcl 01 instr aligned automatic, 02 pr fixed bin (3) unsigned unaligned, 02 offset fixed bin (15) unsigned unaligned, 02 op_code bit (9) unaligned, 02 extension bit (1) unaligned, 02 inhibit bit (1) unaligned, 02 use_pr bit (1) unaligned, 02 modifier bit (6) unaligned; dcl internal bit (1) automatic; dcl ledp ptr automatic; dcl lelp ptr automatic; dcl lx fixed bin automatic; dcl modifier bit (6) automatic; dcl n_words fixed bin automatic; dcl odd bit (1) automatic; dcl pad (1:16) bit (36) aligned automatic; dcl rel char (2) automatic; dcl rel_char char (1) automatic; dcl relindex fixed bin automatic; dcl relinfop ptr automatic; dcl relp fixed bin (18) unsigned automatic; dcl relstr char (4096) automatic; dcl s fixed bin automatic; dcl sc fixed bin automatic; dcl section fixed bin (3) automatic; dcl size fixed bin (18) unsigned automatic; dcl skip fixed bin automatic; dcl stat_relp fixed bin (18) unsigned automatic; dcl symb_relp fixed bin (18) unsigned automatic; dcl td bit (4) automatic; dcl text_relp fixed bin (18) unsigned automatic; dcl textp ptr automatic; dcl tm bit (2) automatic; dcl value fixed bin (35) automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl bin builtin; dcl copy builtin; dcl hbound builtin; dcl min builtin; dcl substr builtin; dcl unspec builtin; textp = lec.comp (c).orig.textp; relinfop = lec.comp (c).orig.rel_textp; relindex = 1; odd = false; initial_relp = -1; /* extract the relocation counters */ text_relp = lec.comp (c).new.rel_text; symb_relp = lec.comp (c).new.rel_symb; stat_relp = lec.comp (c).new.rel_stat; /* emit pad words to align the text section */ n_words = lec.comp (c).new.text_pad; unspec (pad) = ""b; do while (n_words > 0); size = min (hbound (pad, 1), n_words); substr (relstr, 1, size+size) = copy ("aa", size); relp = ocu_$emit_text (ocudp, addr (pad), addr (relstr), size); n_words = n_words - size; end; n_words = 0; do while (n_words < lec.comp (c).orig.textl); /* find the next word containing non-absolute relinfo */ call le_util_$scan_relinfo (relinfop, relindex, odd, skip, rel); /* emit the intervening text words with absolute relocation */ do while (skip > 0); size = min (skip, 2048); substr (relstr, 1, size+size) = copy ("aa", size); relp = ocu_$emit_text (ocudp, textp, addr (relstr), size); if initial_relp < 0 then initial_relp = relp; textp = addrel (textp, size); skip = skip - size; n_words = n_words + size; end; /* copy the word to be relocated */ unspec (instr) = unspec (textp -> word18); do s = Left to Right while (n_words < lec.comp (c).orig.textl); /* for each side of the non-absolute word */ rel_char = substr (rel, s, 1); if rel_char = "a" | rel_char = "r" then ; /* no relocation required */ else if rel_char = "t" | rel_char = "1" then do; /* text relative reference */ value = word18.side (s) + text_relp; word18.side (s) = addr (value) -> word18.side (Right); end; else if rel_char = "2" | rel_char = "3" then do; /* link reference, snap the link and then adjust the */ /* reference */ value = word18.side (s); call le_snap_ (ocudp, lecp, c, Text, (n_words), (value), true, section, relp, modifier, internal); word18.side (s) = relp; end; else if rel_char = "l" then do; /* standard pointer register link reference */ value = word15.side (s); abort = false; if s ^= Left then do; /* link 15 relocation is only allowed in the left halfword */ call le_error_ (LE_FATAL_ERROR, le_et_$invalid_relinfo, "^/Relocation code ""link 15"" is invalid in the right" || "^/halfword ^o of text|^o in ^a.", value, n_words, lec.comp (c).name); abort = true; end; if instr.use_pr = false & ^abort then do; call le_error_ (LE_FATAL_ERROR, le_et_$bad_instr_format, "^/Invalid instruction format at text|^o in ^a.", n_words, lec.comp (c).name); abort = true; end; do sc = 1 to 4 while (^abort); if instr.op_code = special_case (sc) then do; call le_error_ (LE_FATAL_ERROR, le_et_$bad_instr_format, "^/Invalid op_code (^a) for link ref at text|^o in ^a.", special_case_name (sc), n_words, lec.comp (c).name); abort = true; end; end; tm = substr (instr.modifier, 1, 2); td = substr (instr.modifier, 3, 4); if ^abort & ((tm = Indirect_and_Tally) | (tm ^= Indirect_then_Register & td ^= ""b)) then do; call le_error_ (LE_FATAL_ERROR, le_et_$bad_instr_format, "^/Invalid modifier ^o for link ref at text|^o of ^a.", bin (tm || td), n_words, lec.comp (c).name); abort = true; end; if ^abort then do; call le_snap_ (ocudp, lecp, c, Text, (n_words), (value), false, section, relp, modifier, internal); /* patch the returned offset */ if section = Static | section = Linkage then word15.side (s) = relp; else do; word18.side (s) = relp; instr.use_pr = false; end; /* schedule a backpatch since we don't know where the */ /* symbol section will be placed */ if section = Symbol then call le_backpatch_ (Patch_Symbol_Ref, lec.comp (c).target, n_words + lec.comp (c).new.rel_text, s, 0); /* remove the indirection modifier if the link was */ /* resolved internally. */ if internal then if modifier = ""b then substr (instr.modifier, 1, 2) = ""b; else instr.modifier = modifier; /* convert the relocation info */ substr (rel, s, 1) = Section_Rel_15 (section); end; end; else if rel_char = "d" then do; /* look for a definition that this points to */ ledp = lec.comp (c).tables.ledp; value = word18.side (s); found = false; /* scan the definition list */ do d = 1 to led.n_defs while (^found); if value = led.def (d).offset then do; word18.side (s) = led.def (d).new_offset; found = true; end; end; if ^found then call le_error_ (LE_FATAL_ERROR, le_et_$bad_def_reference, "^/Reference to definition|^o at text|^o in ^a.", value, n_words, lec.comp (c).name); end; /* symbol reference */ else if rel_char = "s" | rel_char = "7" then do; value = word18.side (s) + symb_relp; word18.side (s) = addr (value) -> word18.side (Right); end; /* 18 bit static reference */ else if rel_char = "8" then do; if ^lec.comp (c).flags.separate_static then word18.side (s) = word18.side (s) + stat_relp - 8; else word18.side (s) = word18.side (s) + stat_relp; end; /* normal 15 bit static reference */ else if rel_char = "i" then do; /* must be in the left halfword */ if s ^= Left then do; call le_error_ (LE_FATAL_ERROR, le_et_$invalid_relinfo, "^/Relocation code ""static 15"" is invalid in the" || "^/right halfword ^o of text|^o of ^a.", word15.side (s), n_words, lec.comp (c).name); end; else do; if ^lec.comp (c).flags.separate_static then word15.side (s) = word15.side (s) + stat_relp - 8; else word15.side (s) = word15.side (s) + stat_relp; end; end; else call le_error_ (LE_ABORT_ERROR, le_et_$invalid_relinfo, ""); end; /* if we are not off the end, then emit the word */ if n_words < lec.comp (c).orig.textl then do; relp = ocu_$emit_text (ocudp, addr (instr), addr (rel), 1); if initial_relp < 0 then initial_relp = relp; textp = addrel (textp, 1); n_words = n_words + 1; end; end; /* make sure the section started at the offset we calculated earlier */ if initial_relp ^= lec.comp (c).new.rel_text & initial_relp >= 0 then call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "^/Text for ^a relocated to ^d instead of ^d as expected.", lec.comp (c).name, initial_relp, lec.comp (c).new.rel_text); /* make a pass down the link table and forcibly emit any *system */ /* or *heap links which are the target link of a deferred_init */ /* group to make sure there is something at the end of the chain */ lelp = lec.comp (c).tables.lelp; do lx = 1 to lel.n_links; if lel.link (lx).target_comp = c & lel.link (lx).target_link = lx & lel.link (lx).type = Self_Offsetname then call le_snap_ (ocudp, lecp, c, Text, 0, lel.offset_adjustment + 2 * lx, false, section, relp, modifier, internal); end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include ocu_dcls; end le_emit_text_;  le_error_.pl1 12/10/86 1307.9rew 12/10/86 1252.1 55773 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to display error messages from the linkage editor and record severities. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_error_: proc (severity, /** severiity of error (in ) */ code, /** error code (in ) */ control_string); /** ioa_ control string (in ) */ /*** {ioa_args} /** optional ioa_ args (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_error_ */ /*** Input: severity, code, control_string, {ioa args} */ /*** Function: prints an error message on the error output */ /*** I/O switch. If the brief option was selected */ /*** (determined by the value of le_data_$brief_sw) */ /*** the message is not printed. The maximum severity */ /*** (in le_data_$max_severity) is updated regardless. */ /*** If the severity is 4 (LE_ABORT_ERROR) the */ /*** condition le_abort_ is signalled to abort the */ /*** execution. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* constants */ dcl ch_100_al_desc bit (36) static options (constant) init ("524000000144"b3); dcl ch_32_var_desc bit (36) static options (constant) init ("532000000040"b3); dcl ch_512_var_desc bit (36) static options (constant) init ("532000002000"b3); dcl ptr_desc bit (36) static options (constant) init ("464000000000"b3); dcl severity_msg (1:4) char (32) var static options (constant) init ("WARNING", "ERROR SEVERITY 2", "ERROR SEVERITY 3", "FATAL ERROR"); /* parameters */ dcl severity fixed bin parameter; dcl code fixed bin (35) parameter; dcl control_string char (*) parameter; /* procedures */ dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$generate_call entry (entry, ptr); dcl get_system_free_area_ entry () returns (ptr); dcl ioa_$ioa_switch entry () options (variable); /* external */ dcl iox_$error_output ptr external; dcl le_data_$display_severity fixed bin external; dcl le_data_$max_severity fixed bin external; /* based */ dcl 01 input_args aligned based (input_argsp), 02 header like arg_list.header, 02 arg_ptrs (0 refer (input_args.arg_count)) ptr, 02 desc_ptrs (0 refer (input_args.arg_count)) ptr; dcl 01 new_args aligned based (new_argsp), 02 header like arg_list.header, 02 arg_ptrs (nargs refer (new_args.arg_count)) ptr, 02 desc_ptrs (nargs refer (new_args.arg_count)) ptr; dcl sys_area area based (sys_areap); /* automatic */ dcl nargs fixed bin automatic; dcl i fixed bin automatic; dcl input_argsp ptr automatic; dcl message char (100) aligned automatic; dcl new_argsp ptr automatic; dcl new_ctl_str char (512) varying automatic; dcl sys_areap ptr automatic; /* conditions */ dcl cleanup condition; dcl le_abort_ condition; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl max builtin; dcl null builtin; /* update the maximum severity */ le_data_$max_severity = max (le_data_$max_severity, severity); /* if the severity is less than the display severity, don't display */ /* a message. */ if severity < le_data_$display_severity then do; if severity = LE_ABORT_ERROR then signal le_abort_; else return; end; /* build the new ioa_ control string */ new_ctl_str = "^/^a:^/^a " || control_string; /* convert the code supplied into a message */ call convert_status_code_ (code, (""), message); /* get the arg list pointer to copy the optional arguments */ call cu_$arg_list_ptr (input_argsp); /* release new arg list structure on unexpected unwind */ sys_areap = get_system_free_area_ (); new_argsp = null; on cleanup begin; if new_argsp ^= null then free new_args in (sys_area); end; /* determine the size of the arglist for the call to ioa_ and allocate it */ nargs = input_args.arg_count + 1; allocate new_args in (sys_area); /* set up the new arglist header */ new_args.header.pad1 = ""b; new_args.header.call_type = Interseg_call_type; new_args.header.desc_count = nargs; new_args.header.pad2 = ""b; /* set the argument and descriptor pointers for the first 4 constant args */ new_args.arg_ptrs (1) = addr (iox_$error_output); new_args.arg_ptrs (2) = addrel (addr (new_ctl_str), 1); new_args.arg_ptrs (3) = addrel (addr (severity_msg (severity)), 1); new_args.arg_ptrs (4) = addr (message); new_args.desc_ptrs (1) = addr (ptr_desc); new_args.desc_ptrs (2) = addr (ch_512_var_desc); new_args.desc_ptrs (3) = addr (ch_32_var_desc); new_args.desc_ptrs (4) = addr (ch_100_al_desc); /* copy any additional arguments into the new arg list */ do i = 4 to input_args.arg_count; new_args.arg_ptrs (i + 1) = input_args.arg_ptrs (i); new_args.desc_ptrs (i + 1) = input_args.desc_ptrs (i); end; /* call ioa_$ioa_switch with the new arglist */ call cu_$generate_call (ioa_$ioa_switch, new_argsp); /* free the arg_list structure */ free new_args in (sys_area); if severity = LE_ABORT_ERROR then signal le_abort_; else return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include arg_list; %include le_data; end le_error_;  le_et_.alm 12/10/86 1308.4rew 12/10/86 1252.2 56043 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1986 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), " audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): " Originally written to provide error messages used internally by le_. " END HISTORY COMMENTS """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """ " """ Name: le_et_ " """ Function: defines the internal error codes for the linkage " """ editor subroutine. " """ " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" include et_macros name le_et_ et le_et_ ec bad_def_reference,bddefref, (Definition section reference does not refer to a definition.) " a word with definition relinfo had a value which didn't refer to a " definition. ec bad_ep_starname,bdepstar, (Entrypoint starname given is invalid.) " the starname supplied as an entrypoint specification is invalid. ec bad_instr_format,bdinstfm, (Invalid instruction format found.) " instruction with link15 relocation has an invalid op-code, modifier, or " use_pr bit ec bad_link_class,badlkcls, (Invalid class found in Self-Base or Self-Offsetname link.) " a link class for a type 1 or 5 link was invalid. ec bad_link_ref,badlkref, (Linkage section reference does not refer to a link.) " le_snap_ was called to resolve a link reference that was not within the " link array. ec bad_link_type,badlktyp, (Invalid or unsupported link type found.) " le_snap_ was called to resolve a link with a type other than 1, 3, 4, or 5. ec cant_delete_table,nodeltbl, (Symbol table not removed because it may be needed for data-directed I/O.) " the user requested that the table be deleted but it is required by the " runtime to perform data-directed I/O. ec component_too_big,comptobg, (An input item is larger than the requested maximum component size.) " one of the input components is larger than the requested maximum output " component size, so an oversize component has been created to hold it. ec dup_ep_option,dupepopt, (Duplicate retain, delete, or no_link options supplied.) " two or more retain, delete, or no_link options were found with the same " definition specification ec dup_global_option,dupglopt, (Duplicate global retain, delete, or no_link options supplied.) " two or more retain, delete, or no_link options were found with a **$** " specification ec dup_global_table_opt,dpgtblop, (Multiple global table/no_table options were supplied.) " two or more global table or no_table options were encountered ec dup_input_component,dpincomp, (Component found more than once in input specification.) " more than one occurrance of a single input component were found in the " input options. ec dup_segname,dupsegnm, (Duplicate segname definition found in input component.) " a segname definitions was found in a required (PATH) input component " which has the same name as another required segname. ec dup_table_opt,duptblop, (Multiple table/no_table options were found for the same component.) " two or more table/no_table options exist referring to the same component ec entrypoints_inaccessible,entinacc, (Entrypoints in component are inaccessible since no segnames could be added.) " all of the segnames being added were duplicates, so the block has been " ignored ec has_break_map,hasbrkmp, (Input component contains breakpoints.) " An input component has a break map, and therefor cannot be used. ec implementation_error,imperror, (Implementation error. Please contact maintanance personnel.) " some condition which should never occur, has. ec incompatible_init,bad_init, (Incompatible initializations found (area with non-area).) " init infos for a variable had a mix of area and non-area init types. ec input_output_overlap,inoutmix, (Output segment is the same as a previously used segment.) " a segment used for output (list or binary) is the same as an input " component or a previously emitted output. ec invalid_relinfo,badrelif, (Invalid relocation information found.) " link15 or static15 relocation found for thr right side of a word or a " totally unknown relocation code found. ec link_not_found,lknotfnd, (Unable to find a link matching linkage section reference.) " A link reference could not be resolved to a link table entry ec multiple_inits,multinit, (Multiple initializations found) " More than 1 init info was found for a single external or heap variable ec nonrelocatable,nonreloc, (Input segment is not a relocatable object.) " There is no relocation info in the segment so we can't use it. ec nonstandard_object,nonstdob, (Segment is not in standard object format.) " Segment specified as input is not in standard format. ec not_an_object,notanobj, (Specified input or library component is not an executable object.) " Pointer given does not point to an object segment. ec not_linkfault,notlkflt, (Tag found in link is not linkfault.) " What should be a link in a linkage section does not contain a fault tag 2 " in the tag field. ec recursive_invocation,recurse, (This procedure may not be invoked recursively.) " the le_ subroutine has been recursively invoked. ec too_many_options,tomnyopt, (Too many options, input paths, and library paths specified.) " too many options were given. the option array has become larger than a " single segment. ec unsupported_relinfo,unsuprel, (Unsupported relocation code found.) " a relocation code not supported by the linkage editor has been found. " particulary, a definition relocation code in the symbol section. ec unused_option,unusedop, (Definition option did not match any definitions.) " a definition disposition option did not match any definitions, either " because it didn't match any, or all that it did match were covered by " more specific options end  le_make_comp_tbl_.pl1 12/10/86 1307.9rew 12/10/86 1252.1 98226 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to create the component table of input paths and library components to be included in the output object. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_make_comp_tbl_: proc (leip, /** le_input ptr (in ) */ lecp); /** comp_table ptr (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_make_comp_tbl_ */ /*** Input: leip */ /*** Function: create the component table from the list of */ /*** input components in the le_input structure. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); /* parameters */ dcl leip ptr parameter; dcl lecp ptr parameter; /* procedures */ dcl archive_$get_component_info entry (ptr, fixed bin (24), char (*), ptr, fixed bin (35)); dcl cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl le_error_ entry options (variable); dcl object_info_$long entry (ptr, fixed bin (24), ptr, fixed bin (35)); /* external */ dcl le_et_$cant_delete_table external fixed bin (35); dcl le_et_$dup_global_table_opt external fixed bin (35); dcl le_et_$dup_input_component external fixed bin (35); dcl le_et_$dup_table_opt external fixed bin (35); dcl le_et_$has_break_map external fixed bin (35); dcl le_et_$nonrelocatable external fixed bin (35); dcl le_et_$nonstandard_object external fixed bin (35); dcl le_et_$not_an_object external fixed bin (35); /* based */ dcl 01 comp aligned like le_comp based (compp); dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 opt aligned like le_option based (optp); dcl 01 ssb aligned like sb based (ssbp); /* automatic */ dcl 01 ac_info aligned like archive_component_info automatic; dcl 01 br_info aligned like status_branch automatic; dcl cn char (32) automatic; dcl compp ptr automatic; dcl cx fixed bin automatic; dcl dn char (168) automatic; dcl ec fixed bin (35) automatic; dcl en char (32) automatic; dcl ix fixed bin automatic; dcl found bit (1) automatic; dcl 01 oi aligned like object_info; dcl optp ptr automatic; dcl optx fixed bin automatic; dcl sblkp ptr automatic; dcl sbp ptr automatic; dcl select_type fixed bin automatic; dcl ssbp ptr automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl null builtin; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ oi.version_number = object_info_version_2; /* scan the option list for PATH or LIBRARY input */ do select_type = PATH, LIBRARY; do optx = 1 to lei.n_opts; optp = addr (lei.opt (optx)); if opt.type = select_type then do; found = false; do cx = 1 to lec.n_components while (^found); if opt.optp = lec.comp (cx).segp then found = true; end; if found then call le_error_ (LE_ERROR, le_et_$dup_input_component, "^a", opt.name); else do; /* get the object info for the segment */ call object_info_$long (opt.optp, opt.bc, addr (oi), ec); /* if it didn't work, complain and dont append anything */ /* to the component table. */ if ec ^= 0 then call le_error_ (LE_ERROR, le_et_$not_an_object, "^a", opt.name); else if ^found then do; if ^oi.format.standard /* if the thing is an object but not in standard */ /* format, then we don't want to touch it */ then call le_error_ (LE_ERROR, le_et_$nonstandard_object, "^a", opt.name); else if ^oi.format.relocatable then call le_error_ (LE_ERROR, le_et_$nonrelocatable, "^a", opt.name); else if oi.bmapp ^= null then call le_error_ (LE_ERROR, le_et_$has_break_map, "^a", opt.name); else do; /* actually add the component to the table */ cx, lec.n_components = lec.n_components + 1; compp = addr (lec.comp (cx)); comp.name = opt.name; comp.path = opt.path_or_ep; comp.segp = opt.optp; comp.bc = opt.bc; comp.compiler = oi.compiler; call expand_pathname_$component ((comp.path), dn, en, cn, ec); call hcs_$status_long (dn, en, 1, addr (br_info), null, ec); comp.uid = br_info.uid; if cn ^= "" then do; /* get dtcm from archive for archive components */ ac_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1; call archive_$get_component_info (comp.segp, (br_info.bit_count), cn, addr (ac_info), ec); comp.dtcm = ac_info.time_modified; end; /* from file system for segments or entire archives */ else comp.dtcm = cv_fstime_ ((br_info.dtcm)); comp.tables.lesp = null; comp.tables.ledp = null; comp.tables.lelp = null; comp.orig.textp = oi.textp; comp.orig.defnp = oi.defp; comp.orig.linkp = oi.linkp; comp.orig.statp = oi.statp; comp.orig.symbp = oi.symbp; comp.orig.rel_textp = oi.rel_text; comp.orig.rel_symbp = oi.rel_symbol; comp.orig.rel_linkp = oi.rel_link; comp.orig.text_boundary = oi.text_boundary; comp.orig.static_boundary = oi.static_boundary; comp.orig.textl = oi.tlng; comp.orig.defnl = oi.dlng; comp.orig.linkl = oi.llng; comp.orig.statl = oi.ilng; comp.orig.symbl = oi.slng; comp.orig.symbl_no_rel = oi.default_truncate; comp.orig.symbl_no_table = oi.optional_truncate; comp.flags.separate_static = oi.separate_static; /* see if the pathname is unique */ found = false; do ix = optx + 1 to lei.n_opts while (^found); if lei.opt (ix).type = opt.type & lei.opt (ix).path_or_ep = opt.path_or_ep then found = true; end; comp.flags.unique_path = ^found; /* if the option was a PATH option it is */ /* forcibly included. If it is a LIBRARY */ /* option, things are still negotiable. */ if opt.type = LIBRARY then comp.flags.library = true; else comp.flags.library = false; comp.flags.include = false; /* see if the table is required for language I/O */ comp.flags.io_table = false; if oi.compiler = "v2pl1" | oi.compiler = "PL/I" then do; sbp = oi.symbp; if sbp -> sb.area_ptr ^= ""b then if addrel (sbp, sbp -> sb.area_ptr) -> pl1_symbol_block.flags.io then comp.flags.io_table = true; end; /* see how many symbol blocks there are */ comp.orig.n_symb_blocks = 1; ssbp = comp.orig.symbp; do while (ssb.next_block ^= ""b); comp.orig.n_symb_blocks = comp.orig.n_symb_blocks + 1; ssbp = addrel (comp.orig.symbp, ssb.next_block); end; /* try to find an option specifying what we do */ /* with the symbol table. First we try to find */ /* a specific option for this component. */ found = false; comp.flags.delete_table = false; do ix = 1 to lei.n_opts; if (lei.opt (ix).type = TABLE | lei.opt (ix).type = NO_TABLE) & lei.opt (ix).name = comp.name & ^lei.opt (ix).ignore then if found then do; /* if this is the second such */ /* option, then complain that */ /* duplicates exist and mark the */ /* duplicate to be ignored. */ call le_error_ (LE_WARNING, le_et_$dup_table_opt, "table for ^a will be " || "^[deleted^;retained^].", lei.opt (ix).name, comp.flags.delete_table); lei.opt (ix).flags.ignore = true; end; else do; /* we have found an option, note */ /* that we have and set the */ /* delete_table flag */ found = true; if lei.opt (ix).type = TABLE then comp.flags.delete_table = false; else comp.flags.delete_table = true; end; end; /* if we have not found a specific option, */ /* look for a global table or no_table option. */ if ^found then do ix = 1 to lei.n_opts; /* look for a global table or no_table option */ if (lei.opt (ix).type = TABLE | lei.opt (ix).type = NO_TABLE) & lei.opt (ix).name = "" & ^lei.opt (ix).flags.ignore then if found then do; /* if we already found one, */ /* then print a message and */ /* flag the new one as ignored */ call le_error_ (LE_WARNING, le_et_$dup_global_table_opt, "Tables will be " || "^[deleted^;retained^].", comp.flags.delete_table); lei.opt (ix).flags.ignore = true; end; else do; /* note that we have found a */ /* global option and set the */ /* delete_table flag */ found = true; if lei.opt (ix).type = TABLE then comp.flags.delete_table = false; else comp.flags.delete_table = true; end; end; /* check to see if there is a conflict between */ /* the user option and the requirements of the */ /* runtime (ie. user wants table deleted but */ /* it is needed for data-directed I/O) */ if comp.flags.delete_table & comp.flags.io_table then do; call le_error_ (LE_WARNING, le_et_$cant_delete_table, "^a", comp.name); comp.flags.delete_table = false; end; end; end; end; end; end; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include archive_component_info; %include le_data; %include le_input; %include object_info; %include pl1_symbol_block; %include status_structures; %include symbol_block; end le_make_comp_tbl_;  le_make_component_.pl1 12/10/86 1307.9rew 12/10/86 1251.8 167553 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to generate a single output component. This may be a single standalone object or a component of an object MSF. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_make_component_: proc (dname, /** dirname (in ) */ ename, /** entryname (in ) */ leip, /** le input pointer (in ) */ lebp, /** binaries pointer (i/o) */ lecp, /** components pointer (i/o) */ compx, /** output comp index (in ) */ n_comp); /** no of components (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_make_component_ */ /*** Input: dname, ename, lebp, lecp, compx, n_comp */ /*** Function: Actually creates an output binary component. */ /*** Output: lebp, lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl Version_offset fixed bin (18) unsigned static options (constant) init (10); dcl Userid_offset fixed bin (18) unsigned static options (constant) init (11); dcl Backpointer_offset fixed bin (18) unsigned static options (constant) init (15); dcl Block_length_offset fixed bin (18) unsigned static options (constant) init (15); dcl Next_block_offset fixed bin (18) unsigned static options (constant) init (16); dcl Source_map_offset fixed bin (18) unsigned static options (constant) init (14); dcl Area_ptr_offset fixed bin (18) unsigned static options (constant) init (14); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl compx fixed bin parameter; dcl dname char (*) parameter; dcl ename char (*) parameter; dcl lebp ptr parameter; dcl lecp ptr parameter; dcl leip ptr parameter; dcl n_comp fixed bin parameter; /* procedures */ dcl date_time_ entry (fixed bin (71), char (*)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl le_emit_defs_ entry (ptr, ptr, fixed bin); dcl le_emit_firstref_ entry (ptr, ptr, fixed bin); dcl le_emit_static_ entry (ptr, ptr, fixed bin); dcl le_emit_symbol_ entry (ptr, ptr, fixed bin); dcl le_emit_text_ entry (ptr, ptr, fixed bin); dcl le_error_ entry options (variable); dcl le_util_$get_user_and_version entry (char (*), char (*)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)) ; dcl pathname_ entry (char (*), char (*)) returns (char (168)); /* external */ dcl le_data_$caller external char (32) varying; dcl le_data_$version_number external fixed bin; dcl 01 le_data_$symbol_table external aligned like std_symbol_header; /* based */ dcl 01 bd_map aligned based (bd_mapp), 02 dcl_version fixed bin, 02 n_components fixed bin, 02 component dim (comp_count refer (bd_map.n_components)) aligned like bindmap.component, 02 bf_name aligned like bindmap.bf_name, 02 bf_date_up char (24), 02 bf_date_mod char (24); dcl 01 comp aligned like le_comp based (compp); dcl 01 end_overlay aligned based (addr (end_relp)), 02 pad bit (35) unaligned, 02 odd bit (1) unaligned; dcl 01 leb aligned based (lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (0 refer (les.n_segnames)) like le_segnames.segname; dcl 01 sc_map aligned based (sc_mapp), 02 version fixed bin, 02 number fixed bin, 02 map dim (source_count refer (sc_map.number)) aligned like source_map.map; dcl 01 std_sb_hdr aligned like std_symbol_header based; dcl sys_area area based (sys_areap); /* automatic */ dcl bd_mapp ptr automatic; dcl bmp ptr automatic; dcl bx fixed bin automatic; dcl c fixed bin automatic; dcl cname char (32) automatic; dcl comp_count fixed bin automatic; dcl compp ptr automatic; dcl date_str char (24) automatic; dcl dummy fixed bin (18) unsigned automatic; dcl ec fixed bin (35) automatic; dcl end_relp fixed bin (18) unsigned automatic; dcl i fixed bin automatic; dcl lesp ptr automatic; dcl source_count fixed bin automatic; dcl n_words fixed bin (18) unsigned automatic; dcl nm char (32) automatic; dcl nml fixed bin (18) unsigned automatic; dcl ocudp ptr automatic; dcl 01 oi aligned like object_info automatic; dcl open_flags bit (6) automatic; dcl pad_word bit (36) aligned automatic; dcl pn char (168) automatic; dcl pnl fixed bin automatic; dcl prev_start fixed bin (18) unsigned automatic; dcl rel_str char (4096) varying automatic; dcl rel_strp ptr automatic; dcl relp fixed bin (18) unsigned automatic; dcl 01 sb_hdr aligned like std_symbol_header automatic; dcl sbp ptr automatic; dcl sc_mapp ptr automatic; dcl segname char (32) varying automatic; dcl start fixed bin automatic; dcl sys_areap ptr automatic; dcl userid char (32) automatic; dcl version char (256) automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl bin builtin; dcl bit builtin; dcl char builtin; dcl clock builtin; dcl copy builtin; dcl currentsize builtin; dcl divide builtin; dcl length builtin; dcl ltrim builtin; dcl null builtin; dcl rtrim builtin; dcl size builtin; dcl unspec builtin; sys_areap = get_system_free_area_ (); /* arrange to clean up on an unexpected release */ ocudp = null; sc_mapp = null; bd_mapp = null; on cleanup begin; if ocudp ^= null then call ocu_$release (ocudp); if sc_mapp ^= null then free sc_map in (sys_area); if bd_mapp ^= null then free bd_map in (sys_area); end; /* set up the open options for the component */ open_flags = OPEN_FLAGS_BOUND | OPEN_FLAGS_PROCEDURE; if lec.header.flags.separate_static then open_flags = open_flags | OPEN_FLAGS_SEPARATE_STATIC; if lec.flags.perprocess_static then open_flags = open_flags | OPEN_FLAGS_PERPROCESS_STATIC; if n_comp > 1 then open_flags = open_flags | OPEN_FLAGS_NO_HASHTABLE; /* determine the name of the component, and the name of the segname */ /* definition block to contain the symbol_table and bindmap defs */ if n_comp > 1 then do; cname = ltrim (char (compx)); segname = rtrim (ename) || "." || rtrim (cname); end; else cname, segname = rtrim (ename); /* open the new object segment */ call ocu_$open (dname, cname, open_flags, ocudp, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "Opening ^a", pathname_ (dname, cname)); /* find the first component to be emitted */ start = None; do c = 1 to lec.n_components while (start = None); if lec.comp (c).target = compx then start = c; end; /* if we have a MSF component, emit the msf map */ if n_comp > 1 then call ocu_$emit_msf_map (ocudp, n_comp + 1, (compx)); /* emit the definition block for the bound unit */ dummy = ocu_$emit_segname (ocudp, segname, ""b); dummy = ocu_$emit_definition (ocudp, "symbol_table", Symbol, 0, ""b); dummy = ocu_$emit_definition (ocudp, "bind_map", Symbol, 0, ""b); /* emit the symbol header for the bound unit */ unspec (sb_hdr) = ""b; sb_hdr.dcl_version = 1; sb_hdr.identifier = "bind_map"; sb_hdr.gen_number = le_data_$version_number; sb_hdr.gen_created = le_data_$symbol_table.object_created; sb_hdr.object_created = clock (); sb_hdr.generator = le_data_$caller; sbp = lec.comp (start).orig.symbp; sb_hdr.text_boundary = sbp -> std_sb_hdr.text_boundary; sb_hdr.stat_boundary = sbp -> std_sb_hdr.stat_boundary; /* calculate the size and relinfo */ n_words = size (sb_hdr); rel_strp = addrel (addr (rel_str), 1); rel_str = copy ("aa", n_words); /* emit the symbol header */ dummy = ocu_$emit_symbol (ocudp, addr (sb_hdr), rel_strp, n_words); call le_util_$get_user_and_version (userid, version); /* create the version string, relinfo, etc and emit the version string */ n_words = divide (length (rtrim (version)) + 3, 4, 17, 0); rel_str = copy ("aa", n_words); dummy = ocu_$emit_symbol (ocudp, addr (version), rel_strp, n_words); /* backpatch the string offset and length into the symbol header */ call ocu_$backpatch (ocudp, "symbol", Version_offset, "left 18 unsigned", (dummy)); call ocu_$backpatch (ocudp, "symbol", Version_offset, "right 18 unsigned", length (rtrim (version))); /* get the userid, create relinfo for it and emit it */ n_words = divide (length (rtrim (userid)) + 3, 4, 17, 0); rel_str = copy ("aa", n_words); dummy = ocu_$emit_symbol (ocudp, addr (userid), rel_strp, n_words); /* backpatch the offset and length into the symbol header */ call ocu_$backpatch (ocudp, "symbol", Userid_offset, "left 18 unsigned", (dummy)); call ocu_$backpatch (ocudp, "symbol", Userid_offset, "right 18 unsigned", length (rtrim (userid))); /*** ****************************************************************/ /*** */ /*** NOTE: when the relocation offsets are being calculated */ /*** for the various sections in le_msf_partition_, */ /*** it is assumed that the only things preceeding the */ /*** first components symbol block are the symbol */ /*** header, the userid string, and the version string */ /*** If this is changed, adjust the relocation offset */ /*** calculations accordingly. */ /*** */ /*** ****************************************************************/ comp_count = 0; do c = start to lec.n_components; compp = addr (lec.comp (c)); /* if the component is in the target component currently being */ /* then emit all of its sections */ if comp.target = compx & comp.flags.include then do; /* emit each section of the object segment */ call le_emit_defs_ (ocudp, lecp, c); call le_emit_text_ (ocudp, lecp, c); call le_emit_static_ (ocudp, lecp, c); call le_emit_symbol_ (ocudp, lecp, c); call le_emit_firstref_ (ocudp, lecp, c); /* count the number of components in this output component */ comp_count = comp_count + 1; end; end; /* thread the symbol blocks together */ prev_start = 0; do c = start to lec.n_components; compp = addr (lec.comp (c)); if comp.target = compx & comp.flags.include then do; /* backpatch the section backpointer */ call ocu_$backpatch (ocudp, "symbol", comp.new.rel_symb + Backpointer_offset, "left 18 signed", -comp.new.rel_symb); /* backpatch the new section length */ call ocu_$backpatch (ocudp, "symbol", comp.new.rel_symb + Block_length_offset, "right 18 unsigned", (comp.orig.symbl)); /* backpatch the next block offset */ call ocu_$backpatch (ocudp, "symbol", prev_start + Next_block_offset, "left 18 unsigned", comp.new.rel_symb - prev_start); prev_start = comp.new.rel_symb; end; end; /* create the source_map */ source_count, i = 0; /* find the number of unique source pathnames */ do c = start to lec.n_components while (i < comp_count); compp = addr (lec.comp (c)); if comp.flags.include & comp.target = compx then do; i = i + 1; if comp.flags.unique_path then source_count = source_count + 1; end; end; /* allocate the source map */ allocate sc_map in (sys_area); sc_map.version = 1; i = 0; do c = start to lec.n_components while (i < source_count); compp = addr (lec.comp (c)); if comp.target = compx & comp.flags.include & comp.flags.unique_path then do; /* if this component was included in the current output */ /* component, then add it to the source map. */ i = i + 1; sc_map.map (i).uid = comp.uid; sc_map.map (i).dtm = comp.dtcm; /* emit the pathname string and save the relpointer */ pn = comp.path; pnl = length (rtrim (pn)); n_words = divide (pnl + 3, 4, 17, 0); rel_str = copy ("aa", n_words); relp = ocu_$emit_symbol (ocudp, addr (pn), rel_strp, n_words); sc_map.map (i).pathname.offset = bit (bin (relp, 18)); sc_map.map (i).pathname.size = bit (bin (pnl, 18)); end_relp = relp + n_words; end; end; if end_overlay.odd then do; /* force source_map alignment to a doubleword boundary */ pad_word = ""b; rel_str = "aa"; end_relp = ocu_$emit_symbol (ocudp, addr (pad_word), rel_strp, 1) + 1; end; /* now we actually emit the source map */ n_words = currentsize (sc_map); rel_str = copy ("aa", n_words); relp = ocu_$emit_symbol (ocudp, sc_mapp, rel_strp, n_words); call ocu_$backpatch (ocudp, "symbol", Source_map_offset, "left 18 unsigned", (relp)); end_relp = relp + n_words; /* free the local copy */ free sc_map in (sys_area); sc_mapp = null; /* create the bind_map */ i = 0; allocate bd_map in (sys_area); bd_map.dcl_version = 1; do c = start to lec.n_components while (i < comp_count); compp = addr (lec.comp (c)); if comp.target = compx then do; /* for each component in the current output component, add a */ /* bind map entry. */ i = i + 1; /* emit the name string and insert the relpointer into the map */ nm = comp.name; nml = length (rtrim (nm)); n_words = divide (nml + 3, 4, 17, 0); rel_str = copy ("aa", n_words); relp = ocu_$emit_symbol (ocudp, addr (nm), rel_strp, n_words); end_relp = relp + n_words; bd_map.component (i).name.name_ptr = bit (bin (relp), 18); bd_map.component (i).name.name_lng = bit (bin (nml), 18); bd_map.component (i).comp_name = comp.compiler; bd_map.component (i).text_start = bit (bin (comp.new.rel_text), 18); bd_map.component (i).text_lng = bit (bin (comp.orig.textl), 18); bd_map.component (i).stat_start = bit (bin (comp.new.rel_stat), 18); bd_map.component (i).stat_lng = bit (bin (comp.orig.statl), 18); bd_map.component (i).symb_start = bit (bin (comp.new.rel_symb), 18); bd_map.component (i).symb_lng = bit (bin (comp.orig.symbl), 18); lesp = comp.tables.lesp; bd_map.component (i).defblock_ptr = bit (bin (les.segname (1).relp), 18); bd_map.component (i).n_blocks = bit (bin (comp.orig.n_symb_blocks), 18); end; end; /* determine a bindfile name string and emit it (if any) */ if lei.bindfile.name = "" then do; bd_map.bf_name.bf_name_ptr = ""b; bd_map.bf_name.bf_name_lng = ""b; end; else do; nm = lei.bindfile.name; nml = length (rtrim (nm)); n_words = divide (nml + 3, 4, 17, 0); rel_str = copy ("aa", n_words); relp = ocu_$emit_symbol (ocudp, addr (nm), rel_strp, n_words); bd_map.bf_name.bf_name_ptr = bit (bin (relp), 18); bd_map.bf_name.bf_name_lng = bit (bin (nml), 18); end; /* get the bindfile dates from the input structure */ call date_time_ (lei.bindfile.dt_updated, date_str); bd_map.bf_date_up = date_str; call date_time_ (lei.bindfile.dt_modified, date_str); bd_map.bf_date_mod = date_str; /* force bindmap alignment onto a doubleword boundary */ if end_overlay.odd then do; rel_str = "aa"; end_relp = ocu_$emit_symbol (ocudp, addr (pad_word), rel_strp, 1) + 1; end; n_words = currentsize (bd_map); rel_str = copy ("aa", n_words); /* emit the bindmap */ relp = ocu_$emit_symbol (ocudp, bd_mapp, rel_strp, n_words); /* patch the bindmap offset into the header */ call ocu_$backpatch (ocudp, "symbol", Area_ptr_offset, "right 18 unsigned", (relp)); free bd_map in (sys_area); bd_mapp = null; /* close the ocu_ invocation and actually create the segment */ call ocu_$close (ocudp, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/While closing component ^a.", pathname_ (dname, ename)); /* get a pointer to the output component for the binaries structure */ bx, leb.n_binaries = leb.n_binaries + 1; call initiate_file_ (dname, cname, R_ACCESS, leb.binary (bx).segp, leb.binary (bx).bc, 0); /* get the object info for the component */ oi.version_number = object_info_version_2; call object_info_$brief (leb.binary (bx).segp, leb.binary (bx).bc, addr (oi), ec); leb.binary (bx).textp = oi.textp; leb.binary (bx).defnp = oi.defp; leb.binary (bx).linkp = oi.linkp; leb.binary (bx).symbp = oi.symbp; leb.binary (bx).statp = oi.statp; leb.binary (bx).textl = oi.tlng; leb.binary (bx).defnl = oi.dlng; leb.binary (bx).linkl = oi.llng; leb.binary (bx).symbl = oi.slng; leb.binary (bx).statl = oi.ilng; call hcs_$get_uid_seg (leb.binary (bx).segp, leb.binary (bx).uid, ec); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include bind_map; %include le_data; %include le_input; %include object_info; %include ocu_dcls; %include std_symbol_header; %include source_map; end le_make_component_;  le_make_link_tbl_.pl1 12/10/86 1307.9rew 12/10/86 1252.0 178812 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to create a link table for each component containing a list of the links and the target that they resolve to (if they resolve internally). END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_make_link_tbl_: proc (lecp, /** component table ptr (i/o) */ leshp, /** seg hashtable ptr (in ) */ leap); /** le_area pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_make_link_tbl_ */ /*** Input: lecp, leshp, leap */ /*** Function: creates the link table from the input components. */ /*** The link table contains pointers to each type-4 */ /*** link in the input components and the index of the */ /*** component containing the link. It is used when */ /*** resolving links and to determine which library */ /*** components are included in the eventual output. */ /*** Output: lecp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl lecp ptr parameter; dcl leshp ptr parameter; dcl leap ptr parameter; /* procedures */ dcl hash_$search entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl le_debug_ entry options (variable); dcl le_error_ entry options (variable); /* external */ dcl error_table_$no_ext_sym external fixed bin (35); dcl le_et_$not_linkfault external fixed bin (35); /* based */ dcl le_area area based (leap); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; /* static */ dcl 01 default_init static aligned like link_init; dcl setup bit (1) static init ("0"b); /* automatic */ dcl c fixed bin automatic; dcl head fixed bin automatic; dcl tail fixed bin automatic; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl fixed builtin; dcl null builtin; dcl rel builtin; dcl size builtin; dcl unspec builtin; if ^setup then do; default_init.type = INIT_NO_INIT; default_init.n_words = 0; setup = true; end; call le_debug_ ("Beginning link resolution."); lec.comp (*).next_comp = None; /* thread all of the PATH components into the processing list initially */ head = 1; tail = 1; lec.comp (1).flags.include = true; do c = 2 to lec.n_components while (^lec.comp (c).library); lec.comp (c - 1).next_comp = c; lec.comp (c).flags.include = true; tail = c; end; lec.comp (tail).next_comp = None; /* scan the processing list. Any time a link resolves to a */ /* component that is not already in the list, add it to the end of */ /* the list and continue. */ do while (head ^= None); /* process the links from this component and resolve the type-3 */ /* and type-4 links that can be snapped internally. */ call get_links (lecp, leshp, head, tail); /* if there are components referenced by this one, then process */ /* them as well before going on to the next input component. */ head = lec.comp (head).next_comp; end; call le_debug_ ("Completed link resolution.^2/"); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_links: proc (lecp, /** components pointer (i/o) */ leshp, /** seg hashtable ptr (in ) */ c, /** component index (in ) */ tail); /** comp list tail (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: get_links */ /*** Input: lecp, leshp, c, tail */ /*** Function: extracts link information from the linkage */ /*** section of an input component and attempts to */ /*** determine the target of each link. When a link */ /*** is chased to another component, that component */ /*** is checked to see if it is to be included in the */ /*** final output already. If not, it is appended */ /*** to the list of components to be processed. */ /*** Output: lecp, tail */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl leshp ptr parameter; dcl c fixed bin parameter; dcl tail fixed bin parameter; /* based */ dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (link_count refer (lel.n_links)) like le_link; dcl 01 vlh aligned like virgin_linkage_header based (vlhp); /* automatic */ dcl dhp ptr automatic; dcl end_offset fixed bin (18) unsigned automatic; dcl found bit (1) automatic; dcl index fixed bin automatic; dcl lelp ptr automatic; dcl linkp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl start_offset fixed bin (18) unsigned automatic; dcl t fixed bin automatic; dcl vlhp ptr automatic; /* get pointers to the definition and linkage sections */ vlhp = lec.comp (c).orig.linkp; dhp = lec.comp (c).orig.defnp; /* find the end of the link array */ end_offset = vlh.linkage_section_lng - size (object_link); if vlh.first_ref_relp ^= 0 then end_offset = vlh.first_ref_relp - size (object_link); start_offset = vlh.link_begin; /* set the link start offset for this component */ if start_offset > end_offset then do; link_count = 0; allocate lel in (le_area) set (lec.comp (c).tables.lelp); return; end; /* determine the number of links */ link_count = (end_offset - start_offset) / size (object_link) + 1; /* allocate the link table */ allocate lel in (le_area) set (lelp); lec.comp (c).tables.lelp = lelp; lel.offset_adjustment = start_offset - size (object_link); /* scan the link array and attempt to resolve each link */ do index = 1 to link_count; offset = lel.offset_adjustment + (index + index); linkp = addrel (vlhp, offset); call process_link (lecp, leshp, linkp, dhp, c, index, t, found); /* if the link was resolved internally, see if the target */ /* component is already included in the output */ if found then do; /* if not already included, thread it into the processing */ /* list and flag that it has been included. */ if ^lec.comp (t).flags.include then do; call le_debug_ ("Including library component ""^a""", lec.comp (t).name); lec.comp (tail).next_comp = t; tail = t; lec.comp (t).flags.include = true; lec.comp (t).next_comp = None; end; end; end; end get_links; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ process_link: proc (lecp, /** components pointer (in ) */ leshp, /** seg hashtable ptr (in ) */ linkp, /** link to resolve (in ) */ dhp, /** def header pointer (in ) */ c, /** component index (in ) */ lx, /** index of link (in ) */ t, /** target component (out) */ found); /** found flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: process_link */ /*** Input: lecp, leshp, linkp, dhp, c, lx */ /*** Function: attempts to resolve a single link to a component */ /*** in the component table. This involves identifying */ /*** the component by searching the segname table and */ /*** then searching the definitions for that component */ /*** looking for a match. */ /*** Output: t, found */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl leshp ptr parameter; dcl linkp ptr parameter; dcl dhp ptr parameter; dcl c fixed bin parameter; dcl lx fixed bin parameter; dcl t fixed bin parameter; dcl found bit (1) parameter; /* based */ dcl 01 exp aligned like exp_word based (expp); dcl 01 init aligned like link_init based (initp); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 link aligned like object_link based (linkp); dcl 01 lk aligned like le_link based (lkp); dcl 01 offset_acc aligned based (offset_accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (offset_acc.count)) unaligned; dcl 01 seg_acc aligned based (seg_accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (seg_acc.count)) unaligned; dcl 01 seg_addr aligned based (addr (seg_bits)), 02 comp fixed bin (17) unaligned, 02 index fixed bin (17) unaligned; dcl 01 tlel aligned based (tlelp), 02 header aligned like le_links.header, 02 link dim (0 refer (tlel.n_links)) like le_link; dcl 01 tlk aligned like le_link based (tlkp); dcl 01 type_pr aligned like type_pair based (type_prp); /* automatic */ dcl dx fixed bin automatic; dcl ec fixed bin (35) automatic; dcl expp ptr automatic; dcl initp ptr automatic; dcl ledp ptr automatic; dcl lelp ptr automatic; dcl lkp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl offset_accp ptr automatic; dcl seg_accp ptr automatic; dcl seg_bits bit (36) aligned automatic; dcl tc fixed bin automatic; dcl tl fixed bin automatic; dcl tlelp ptr automatic; dcl tlkp ptr automatic; dcl type_prp ptr automatic; found = false; t = None; offset = fixed (rel (linkp), 18) - fixed (rel (lec.comp (c).orig.linkp), 18); /* make sure the link is actually an unsnapped link */ if link.tag ^= FAULT_TAG_2 then do; call le_error_ (LE_WARNING, le_et_$not_linkfault, "tag ^2o at link|^o", link.tag, offset); return; end; /* get the type_pair and expression word */ expp = addrel (dhp, link.expression_relp); type_prp = addrel (dhp, type_relp); lelp = lec.comp (c).tables.lelp; /* fill in the link table entry */ lkp = addr (lel.link (lx)); unspec (lk) = ""b; lk.flags.used = false; lk.type = type_pr.type; if type_pr.type = LINK_SELF_BASE | type_pr.type = LINK_SELF_OFFSETNAME then do; lk.class = type_pr.segname_relp; lk.segnamep = null; end; else do; lk.class = None; seg_accp, lk.segnamep = addrel (dhp, type_pr.segname_relp); end; if type_pr.type = LINK_SELF_BASE | type_pr.type = LINK_REFNAME_BASE then lk.offsetp = null; else offset_accp, lk.offsetp = addrel (dhp, type_pr.offsetname_relp); lk.mod = link.modifier; lk.exp = exp.expression; lk.target = None; lk.defx = None; lk.relp = None; lk.target_link = None; lk.target_comp = None; lk.extension = None; if type_pr.type = LINK_SELF_OFFSETNAME & (type_pr.segname_relp = CLASS_SYSTEM | type_pr.segname_relp = CLASS_HEAP) then if type_pr.trap_relp = 0 then lk.initp = addr (default_init); else lk.initp = addrel (dhp, type_pr.trap_relp); else lk.initp = null; if type_pr.type = LINK_SELF_BASE then return; if type_pr.type = LINK_SELF_OFFSETNAME then do; /* we only deal with *system and *heap links */ if type_pr.segname_relp < CLASS_SYSTEM then return; initp = lk.initp; /* we have a valid initialization so continue */ if init.type ^= INIT_NO_INIT then do; /* flag that the link has been processed and return */ lk.flags.used = true; return; end; do tc = 1 repeat lec.comp (tc).next_comp while (tc ^= None); /* get the link table for the component */ tlelp = lec.comp (tc).tables.lelp; /* scan each link looking for a matching link */ if tlelp ^= null then do tl = 1 to tlel.n_links; tlkp = addr (tlel.link (tl)); /* see if the link is to the same target */ if tlk.type = LINK_SELF_OFFSETNAME & tlk.class = lk.class then do; if tlk.offsetp -> acc_string.string = offset_acc.string then do; /* if we find a valid init, we can return */ initp = tlk.initp; if init.type ^= INIT_NO_INIT | lk.flags.used then do; lk.flags.used = true; return; end; end; end; end; else do; if has_init (lecp, tc, lk.class, offset_accp) then do; lk.flags.used = true; return; end; end; end; /* if we get here, we have searched all of the linkage */ /* sections for an init for this link and haven't found one, */ /* so we now scan the unincluded components and include the */ /* first component which has an initialization for this link */ do tc = 1 to lec.n_components; /* only process unincluded components */ if ^lec.comp (tc).flags.include then do; if has_init (lecp, tc, lk.class, offset_accp) then do; t = tc; found = true; lk.flags.used = true; return; end; end; end; /* there is no initialization info for this link anywhere */ lk.flags.used = true; return; end; /* if the link cannot be resolved to another component, just return */ /* otherwise we search for a matching segname */ call hash_$search (leshp, seg_acc.string, seg_bits, ec); if ec ^= 0 then return; /* if not found, the link remains external */ if type_pr.type = LINK_REFNAME_BASE then do; /* type-3 links resolve to the base of the text for the target seg */ call le_debug_ ( "Resolved link ^a|0^/ in component ^a^/ to component ^a", seg_acc.string, lec.comp (c).name, lec.comp (seg_addr.comp).name); t, lk.target = seg_addr.comp; found = true; return; end; /* if we found the segname, now look for the definition name */ offset_accp = addrel (dhp, type_pr.offsetname_relp); ledp = lec.comp (seg_addr.comp).tables.ledp; do dx = 1 to led.n_defs while (^found); if led.def (dx).str = offset_acc.string then do; /* found the definition, save the definition table index */ call le_debug_ ( "Resolved link ^a$^a^/ in component ^a^/ to component ^a", seg_acc.string, offset_acc.string, lec.comp (c).name, lec.comp (seg_addr.comp).name); led.def (dx).flags.referenced = true; /* reference the definition to force library retention but */ /* actually snap the link */ if led.def (dx).flags.no_link then return; t, lk.target = seg_addr.comp; lk.defx = dx; found = true; end; end; if ^found then call le_error_ (LE_WARNING, error_table_$no_ext_sym, "^/Could not find definition ""^a"" in ""^a"";" || " external link generated.", offset_acc.string, seg_acc.string); return; end process_link; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ has_init: proc (lecp, /** component info ptr (in ) */ c, /** component index (in ) */ class, /** link class (in ) */ namep) /** name acc string ptr (in ) */ returns (bit (1)); /** has init flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: has_init */ /*** Input: lecp, c, class, namep */ /*** Function: searches a linkage section for a particular */ /*** *system or *heap link that has valid init info. */ /*** (i.e. not INIT_NO_INIT) */ /*** Output: init_found_sw */ /*** */ /*** ****************************************************************/ /* parameters */ dcl lecp ptr parameter; dcl c fixed bin parameter; dcl class fixed bin (6) unsigned unaligned parameter; dcl namep ptr parameter; /* based */ dcl 01 exp aligned like exp_word based (expp); dcl 01 init aligned like link_init based (initp); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 link aligned like object_link based (linkp); dcl 01 name aligned based (namep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (name.count)) unaligned; dcl 01 offset_acc aligned based (offset_accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (offset_acc.count)) unaligned; dcl 01 type_pr aligned like type_pair based (type_prp); dcl 01 vlh aligned like virgin_linkage_header based (vlhp); /* automatic */ dcl dhp ptr automatic; dcl end_offset fixed bin (18) unsigned automatic; dcl expp ptr automatic; dcl initp ptr automatic; dcl linkp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl offset_accp ptr automatic; dcl start_offset fixed bin (18) unsigned automatic; dcl type_prp ptr automatic; dcl vlhp ptr automatic; /* get pointers to the definition and linkage sections */ vlhp = lec.comp (c).orig.linkp; dhp = lec.comp (c).orig.defnp; /* find the end of the link array */ end_offset = vlh.linkage_section_lng - size (link); if vlh.first_ref_relp ^= None then end_offset = vlh.first_ref_relp - size (link); start_offset = vlh.link_begin; /* look at each link in the linkage section */ do offset = start_offset to end_offset by size (link); /* get the name, type, class, and init pointers */ linkp = addrel (vlhp, offset); expp = addrel (dhp, link.expression_relp); type_prp = addrel (dhp, exp.type_relp); /* if the type and class are the same. . . */ if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = class & type_pr.trap_relp ^= None then do; /* check out the names . . . */ offset_accp = addrel (dhp, type_pr.offsetname_relp); if name.string = offset_acc.string then do; /* OK, the target is the same, see if this */ /* one has valid initialization. */ initp = addrel (dhp, type_pr.trap_relp); if init.type ^= INIT_NO_INIT then return (true); end; end; end; return (false); end has_init; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include object_link_dcls; %include definition_dcls; end le_make_link_tbl_;  le_make_opt_tbl_.pl1 12/10/86 1307.9rew 12/10/86 1252.1 119781 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to extract definition options and create the sorted option table to be used for definition retention determination. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_make_opt_tbl_: proc (leip, /** le_input ptr (in ) */ leop); /** le_options ptr (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: le_make_opt_tbl_ */ /*** Input: leip, leop */ /*** Function: creates the option table from the le_input */ /*** structure. This table is scanned to resolve */ /*** options which may be global, or deal with a */ /*** single component or entrypoint. Options are */ /*** places into the option list ordered such that */ /*** the most specific options are first. This way, */ /*** a linear search of the options for the first */ /*** option which matches will provide the option */ /*** which is most appropriate. */ /*** Output: leop */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); /* parameters */ dcl leip ptr parameter; dcl leop ptr parameter; /* procedures */ dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl le_error_ entry options (variable); /* external */ dcl le_et_$bad_ep_starname external fixed bin (35); dcl le_et_$dup_ep_option external fixed bin (35); dcl le_et_$dup_global_option external fixed bin (35); /* based */ dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; /* automatic */ dcl cl fixed bin automatic; dcl ec fixed bin (35) automatic; dcl en char (256) automatic; dcl io fixed bin automatic; dcl optx fixed bin automatic; dcl sn char (32) automatic; /* builtin */ dcl after builtin; dcl before builtin; dcl mod builtin; dcl unspec builtin; /* scan the option list for definition-disposition options, */ /* evaluate their ordering and add them to the option table. */ do io = 1 to lei.n_opts; if (lei.opt (io).type = DELETE | lei.opt (io).type = RETAIN | lei.opt (io).type = NO_LINK) & ^lei.opt (io).flags.ignore then do; lei.opt (io).flags.used = true; sn = before (lei.opt (io).path_or_ep, "$"); en = after (lei.opt (io).path_or_ep, "$"); cl = get_class (sn, en, ec); if ec ^= 0 then do; call le_error_ (LE_WARNING, le_et_$bad_ep_starname, "^a", lei.opt (io).path_or_ep); lei.opt (io).flags.ignore = true; end; else do; optx, leo.n_opts = leo.n_opts + 1; leo.opt (optx).type = lei.opt (io).type; leo.opt (optx).inhibit_error = lei.opt (io).flags.inhibit_error; leo.opt (optx).used = false; leo.opt (optx).order = io; leo.opt (optx).segname = sn; leo.opt (optx).ep_name = en; leo.opt (optx).class = cl; end; end; end; /* sort the options into ascending order by ordering class */ call sort_opts (leop); /* now that they are sorted, check for duplicates and print a message */ do optx = 1 to leo.n_opts - 1; if leo.opt (optx).segname = leo.opt (optx + 1).segname & leo.opt (optx).ep_name = leo.opt (optx + 1).ep_name then do; if leo.opt (optx).class = 9 then call le_error_ (LE_WARNING, le_et_$dup_global_option, "^/Global ""^[retain^;delete^;no_link^]"" option ignored.", leo.opt (optx + 1).type - RETAIN + 1); else call le_error_ (LE_WARNING, le_et_$dup_ep_option, "^/Option ""^[retain^;delete^;no_link^] ^[^a$^;^s^]^[^a^;^s^]"" ignored.", leo.opt (optx + 1).type - RETAIN + 1, (mod (leo.opt (optx + 1).class, 3) ^= 0), leo.opt (optx + 1).segname, (leo.opt (optx + 1).class < 7), leo.opt (optx + 1).ep_name); end; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_class: proc (segname, /** segname string (in ) */ offsetname, /** offsetname string (in ) */ ec) /** error code (out) */ returns (fixed bin); /** ordering class (out) */ /*** ****************************************************************/ /*** */ /*** Name: get_class */ /*** Input: segname, offsetname */ /*** Function: calculates the ordering class of an entrypoint */ /*** specification. Ordering class is based on how */ /*** specific the name is. Valid values are: */ /*** 1 - segname$offsetname */ /*** 2 - starname$offsetname */ /*** 3 - **$offsetname */ /*** 4 - segname$starname */ /*** 5 - starname$starname */ /*** 6 - **$starname */ /*** 7 - segname$** */ /*** 8 - starname$** */ /*** 9 - **$** */ /*** The options are sorted in ascending order by */ /*** ordering class. When trying to ascertain the */ /*** disposition of any single definition, the option */ /*** table is searched and the first matching option */ /*** is used. */ /*** Output: ordering_class, error_code */ /*** */ /*** ****************************************************************/ /* parameters */ dcl segname char (*) parameter; dcl offsetname char (*) parameter; dcl ec fixed bin (35) parameter; /* automatic */ dcl ordering_class fixed bin automatic; /* The ordering class is derived based on the error code returned */ /* by check_star_name_$entry. If the string is a valid non-star */ /* name, a 0 is returned, a starname returns a 1, and a starname */ /* which matches anything (ie. **) returns a 2. If the error code */ /* is greater than 2, then the name is invalid. */ call check_star_name_$entry (offsetname, ec); if ec > 2 then return (9999); ordering_class = ec * 3; call check_star_name_$entry (segname, ec); if ec > 2 then return (9999); ordering_class = ordering_class + ec + 1; ec = 0; return (ordering_class); end get_class; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ sort_opts: proc (leop); /** le_options pointer (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: sort_opts */ /*** Input: leop */ /*** Function: sorts the options into ascending order based on */ /*** the ordering class. This allows the disposition */ /*** of any definition to be determined by performing */ /*** a linear search of the option list searching for */ /*** the first matching specification. */ /*** Output: leop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl leop ptr parameter; /* based */ dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; /* automatic */ dcl i fixed bin automatic; /* build the heap */ do i = leo.n_opts / 2 by -1 to 1; call adjust_heap (leop, i, leo.n_opts); end; /* sort the heap by extracting the largest and placing it at the */ /* end of the array and inserting the last item into the heap to */ /* rebuild a heap 1 smaller. */ do i = leo.n_opts - 1 by -1 to 1; call exchange (leop, i + 1, 1); call adjust_heap (leop, 1, i); end; end sort_opts; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ adjust_heap: proc (leop, /** le_options pointer (i/o) */ head, /** pseudo-head index (in ) */ size); /** end of heap (in ) */ /*** ****************************************************************/ /*** */ /*** Name: adjust_heap */ /*** Input: leop, head, size */ /*** Function: given a heap structure and a starting node, */ /*** adjust the heap structure into a true heap by */ /*** making sure that each node has a value greater */ /*** than both of the child nodes. */ /*** Output: leop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl leop ptr parameter; dcl head fixed bin parameter; dcl size fixed bin parameter; /* automatic */ dcl r fixed bin automatic; dcl l fixed bin automatic; dcl exch fixed bin automatic; /* get the indecies of the left and right child nodes */ l = 2 * head; r = l + 1; /* if they are out of bounds, we are done */ if l > size then return; if r > size then r = 0; if greater (leop, head, r) then if greater (leop, l, r) then exch = r; else exch = l; else if greater (leop, head, l) then exch = l; else return; call exchange (leop, exch, head); call adjust_heap (leop, exch, size); end adjust_heap; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ exchange: proc (leop, /** le_options pointer (i/o) */ x1, /** exch node index 1 (in ) */ x2); /** exch node index 2 (in ) */ /*** ****************************************************************/ /*** */ /*** Name: exchange */ /*** Input: leop, x1, x2 */ /*** Function: exchange the nodes indicated by the indicies x1 */ /*** and x2. */ /*** Output: leop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl leop ptr parameter; dcl x1 fixed bin parameter; dcl x2 fixed bin parameter; /* based */ dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; /* automatic */ dcl 01 temp aligned automatic like le_options.opt; temp = leo.opt (x2); leo.opt (x2) = leo.opt (x1); leo.opt (x1) = temp; end exchange; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ greater: proc (leop, /** le_option pointer (in ) */ orig, /** index of original (in ) */ new) /** index of new (in ) */ returns (bit (1)); /** true if new > orig (out) */ /*** ****************************************************************/ /*** */ /*** Name: greater */ /*** Input: leop, new, orig */ /*** Function: determine if the option indicated by new is */ /*** greated (according to the ordering method) than */ /*** the option indicated by orig. */ /*** Output: greater_sw */ /*** */ /*** ****************************************************************/ /* parameters */ dcl leop ptr parameter; dcl new fixed bin parameter; dcl orig fixed bin parameter; /* based */ dcl 01 leo aligned based (leop), 02 header aligned like le_options.header, 02 opt dim (0 refer (leo.n_opts)) like le_options.opt; if new = 0 then return (false); /* first criterion is ordering class */ if leo.opt (new).class > leo.opt (orig).class then return (true); else if leo.opt (new).class < leo.opt (orig).class then return (false); /* with class, sort by segname */ if leo.opt (new).segname > leo.opt (orig).segname then return (true); else if leo.opt (new).segname < leo.opt (orig).segname then return (false); /* within class and segname, sort by ep_name */ if leo.opt (new).ep_name > leo.opt (orig).ep_name then return (true); else if leo.opt (new).ep_name < leo.opt (orig).ep_name then return (false); /* within class, segname, and ep_name, sort by order given in the */ /* input options. */ if leo.opt (new).order > leo.opt (orig).order then return (true); else return (false); end greater; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include le_input; end le_make_opt_tbl_;  le_make_segname_tbl_.pl1 12/10/86 1307.9rew 12/10/86 1252.0 120204 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to create the segname table containing names to be used to resolve external references. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_make_segname_tbl_: proc (leip, /** le_input pointer (in ) */ lecp, /** le_components ptr (i/o) */ leshp, /** segname hashtbl ptr (i/o) */ leap); /** le_area pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: le_make_segname_tbl_ */ /*** Input: leip, lecp, leshp, leap */ /*** Function: creates the segname and definition tables from */ /*** the input and component tables. */ /*** Output: lecp, leshp */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl leip ptr parameter; dcl lecp ptr parameter; dcl leshp ptr parameter; dcl leap ptr parameter; /* procedures */ dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hash_$make entry (ptr, fixed bin, fixed bin (35)); dcl hash_$in entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl hash_$opt_size entry (fixed bin) returns (fixed bin); dcl hash_$search entry (ptr, char (*), bit (36) aligned, fixed bin (35)); dcl le_error_ entry options (variable); dcl rehash_ entry (ptr, fixed bin, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); /* external */ dcl error_table_$full_hashtbl external fixed bin (35); dcl error_table_$namedup external fixed bin (35); dcl le_data_$caller external char (32) varying; dcl le_et_$dup_segname external fixed bin (35); dcl le_et_$entrypoints_inaccessible external fixed bin (35); dcl le_et_$implementation_error external fixed bin (35); /* based */ dcl 01 acc aligned based (accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (acc.count)) unaligned; dcl 01 def aligned like definition based (defp); dcl 01 dh aligned like definition_header based (dhp); dcl le_area area based (leap); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 led aligned based (ledp), 02 header aligned like le_definitions.header, 02 def dim (def_count refer (led.n_defs)) like le_definition; dcl 01 lei aligned based (leip), 02 header aligned like le_input.header, 02 opt dim (0 refer (lei.n_opts)) like le_option; dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (segname_count refer (les.n_segnames)) like le_segnames.segname; dcl word fixed bin (35) based; /* automatic */ dcl accp ptr automatic; dcl c fixed bin automatic; dcl def_list fixed bin automatic; dcl defp ptr automatic; dcl defx fixed bin automatic; dcl dhp ptr automatic; dcl ec fixed bin (35) automatic; dcl has_segname bit (1) automatic; dcl i fixed bin automatic; dcl ledp ptr automatic; dcl lesp ptr automatic; dcl offset fixed bin (18) unsigned automatic; dcl real_defs fixed bin automatic; dcl success bit (1) automatic; dcl ts (2) ptr automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addr builtin; dcl addrel builtin; dcl null builtin; dcl string builtin; dcl unspec builtin; /* since we don't know how many segnames we will have, star with */ /* an assumption of 1000 */ call hash_$make (leshp, hash_$opt_size (1000), ec); ts (1) = null; on cleanup begin; if ts (1) ^= null then call release_temp_segments_ ((le_data_$caller), ts, 0); end; /* segname and definition tables are originally created in temp */ /* segs so that they can be grown dynamically, and then allocated */ /* in the le_ area. */ call get_temp_segments_ ((le_data_$caller), ts, ec); lesp = ts (1); ledp = ts (2); do c = 1 to lec.n_components; has_segname = false; real_defs = 0; les.n_segnames = None; led.n_defs = None; /* add the component name as a segname and make it the block */ /* head if we are not using automatic segname generation */ if ^lei.flags.auto_segnames then do; call add_segname (lecp, leshp, lesp, c, (lec.comp (c).name), success); has_segname = has_segname | success; end; /* copy the definitions into the definition table */ dhp = lec.comp (c).orig.defnp; offset = dh.def_list_relp; defp = addrel (dhp, offset); def_list = None; do while (defp -> word ^= 0); /* copy all non-segname definitions */ if def.class ^= 3 then do; accp = addrel (dhp, def.name_relp); /* make a segname for this definition if it is not a */ /* symbol_table definition and we are generating automatic */ /* segnames from the entrypoint names. */ if (acc.string ^= "symbol_table") & lei.flags.auto_segnames & ^def.flags.ignore then do; /* add the definition as a segname */ call add_segname (lecp, leshp, lesp, c, acc.string, success); has_segname = has_segname | success; end; /* add the definition to the table */ if acc.string ^= "symbol_table" then real_defs = real_defs + 1; defx, led.n_defs = led.n_defs + 1; led.def (defx).str = acc.string; led.def (defx).offset = offset; led.def (defx).type = def.class; led.def (defx).relp = def.thing_relp; led.def (defx).new_offset = None; string (led.def (defx).flags) = ""b; led.def (defx).flags.force_retain = def.flags.retain; led.def (defx).flags.entrypoint = def.flags.entry; led.def (defx).flags.ignore = def.flags.ignore; def_list = defx; end; /* skip to the next definition */ offset = def.forward_relp; defp = addrel (dhp, offset); end; /* scan the input options for synonyms for this component */ do i = 1 to lei.n_opts; if lei.opt (i).type = SYNONYM & ^lei.opt (i).flags.used & ^lei.opt (i).flags.ignore then do; if lei.opt (i).name = lec.comp (c).name then do; /* mark the options as used */ lei.opt (i).flags.used = true; /* add the segname to the table */ call add_segname (lecp, leshp, lesp, c, lei.opt (i).path_or_ep, success); has_segname = has_segname | success; end; end; end; /* if we could not put any segnames on this block, then we can't */ /* ever find any of the entrypoints, so delete them and complain. */ if ^has_segname then do; /* print a message only if we are losing entrypoints in a */ /* required component (that had entrypoints to begin with) */ if ^lec.comp (c).flags.library & real_defs > 0 then call le_error_ (LE_ERROR, le_et_$entrypoints_inaccessible, "^/^a", lec.comp (c).name); segname_count = 0; def_count = 0; allocate le_segnames in (le_area) set (lesp); allocate le_definitions in (le_area) set (ledp); lec.comp (c).tables.lesp = lesp; lec.comp (c).tables.ledp = ledp; lesp = ts (1); ledp = ts (2); end; else do; /* allocate copies of the tables, set the component pointers */ /* and copy the tables. */ segname_count = les.n_segnames; def_count = led.n_defs; allocate le_segnames in (le_area) set (lesp); allocate le_definitions in (le_area) set (ledp); unspec (les) = unspec (ts (1) -> les); unspec (led) = unspec (ts (2) -> led); lec.comp (c).tables.lesp = lesp; lec.comp (c).tables.ledp = ledp; lesp = ts (1); ledp = ts (2); end; end; call release_temp_segments_ ((le_data_$caller), ts, 0); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ add_segname: proc (lecp, /** components pointer (in ) */ leshp, /** seg hash tbl ptr (i/o) */ lesp, /** segnames pointer (i/o) */ comp, /** component index (in ) */ name, /** name to add (in ) */ success); /** success flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: add_segname */ /*** Input: leshp, lesp, name */ /*** Function: adds a segname definition to the segname table */ /*** and hashes it into the hash table. */ /*** Output: leshp, lesp, success */ /*** */ /*** ****************************************************************(/ /* parameters */ dcl lecp ptr parameter; dcl leshp ptr parameter; dcl lesp ptr parameter; dcl comp fixed bin parameter; dcl name char (*) parameter; dcl success bit (1) parameter; /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 les aligned based (lesp), 02 header aligned like le_segnames.header, 02 segname dim (0 refer (les.n_segnames)) like le_segnames.segname; dcl 01 seg_addr aligned based (addr (seg_bits)), 02 comp fixed bin (17) unaligned, 02 index fixed bin (17) unaligned; /* automatic */ dcl dup_bits bit (36) aligned automatic; dcl ec fixed bin (35) automatic; dcl index fixed bin automatic; dcl newsz fixed bin automatic; dcl seg_bits bit (36) aligned automatic; success = false; /* build the hash table key value */ seg_addr.comp = comp; seg_addr.index = les.n_segnames + 1; /* first try to hash the name into the table */ call hash_$in (leshp, name, seg_bits, ec); /* hash_ thinks the table is too full, but it may just be unable to */ /* add an entry during rehash due to a bad packing. So we will make */ /* one rehash attempt with an even bigger table to try to open it */ /* up. If that fails, then we give up. */ if ec = error_table_$full_hashtbl then do; /* calculate the new table size */ newsz = hash_$opt_size (les.n_segnames + 1); newsz = hash_$opt_size (les.n_segnames + 1); /* try rehashing the table again */ call rehash_ (leshp, newsz, ec); /* if it didn't work, then we abort the run */ if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/While adding segname ^a.", name); /* otherwise retry the hash of the segname */ call hash_$in (leshp, name, seg_bits, ec); end; /* if we have a duplicate name, then we check to see if it is a */ /* path or library component. Library duplicates we can ignore */ /* but if we have to ignore a required segname, we print a message. */ if ec = error_table_$namedup then do; /* check the duplicate to see if it is already on this component */ call hash_$search (leshp, name, dup_bits, ec); if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, le_et_$implementation_error, "Segname hash table damage found while adding segname ^a", name); /* flag that we have not added the segname */ success = false; /* print an error message if the segname is already on a */ /* different component, and that component is required. */ if addr (dup_bits) -> seg_addr.comp ^= comp then if ^lec.comp (comp).library then call le_error_ (LE_ERROR, le_et_$dup_segname, "^/Deleting segname ""^a"" in component ^a", name, lec.comp (comp).name); end; /* if something else is wrong, we have a major problem so we punt */ else if ec ^= 0 then call le_error_ (LE_ABORT_ERROR, ec, "^/While adding segname ^a", name); else do; /* if the hash was ok, grow the segname table, and create an */ /* empty entry with the appropriate name and return the index */ index, les.n_segnames = les.n_segnames + 1; les.segname (index).str = name; les.segname (index).relp = None; success = true; end; end add_segname; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_input; %include le_data; %include object_link_dcls; %include definition_dcls; end le_make_segname_tbl_;  le_msf_partition_.pl1 12/10/86 1307.9rew 12/10/86 1251.8 96093 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to determine the placement of each input component into an output MSF component (if there is enough input to cause MSF generation) and to calculate the relocation values for each input component. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_msf_partition_: proc (lecp, /** components pointer (i/o) */ component_size, /** max size in pages (in ) */ n_components); /** no of output comp. (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_msf_partition_ */ /*** Input: lecp, component_size */ /*** Function: Partitions the input components into output */ /*** components. This is where it is determined */ /*** if the output will be an MSF. If all of the */ /*** components fit within the component size limit */ /*** given, a normal object segment will be created. */ /*** If more than one is required, an MSF is created. */ /*** Output: lecp, n_components */ /*** */ /*** ****************************************************************/ /* constants */ dcl max_linkage_words fixed bin (19) static options (constant) init (16384); dcl max_static_words fixed bin (19) static options (constant) init (16384); /* parameters */ dcl lecp ptr parameter; dcl component_size fixed bin parameter; dcl n_components fixed bin parameter; /* procedures */ dcl le_debug_ entry options (variable); dcl le_error_ entry options (variable); dcl le_util_$get_user_and_version entry (char (*), char (*)); /* external */ dcl le_et_$component_too_big external fixed bin (35); /* based */ dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; /* automatic */ dcl bound fixed bin automatic; dcl c fixed bin automatic; dcl c_linkage_words fixed bin (19) automatic; dcl c_static_words fixed bin (19) automatic; dcl c_symbol_words fixed bin (19) automatic; dcl c_text_words fixed bin (19) automatic; dcl c_words fixed bin (19) automatic; dcl max_words fixed bin (19) automatic; dcl n_linkage_words fixed bin (19) automatic; dcl n_static_words fixed bin (19) automatic; dcl n_symbol_words fixed bin (19) automatic; dcl n_text_words fixed bin (19) automatic; dcl n_words fixed bin (19) automatic; dcl pad fixed bin (19) automatic; dcl pad_base fixed bin (19) automatic; dcl symbol_base fixed bin (19) automatic; dcl user char (32) automatic; dcl version char (128) automatic; /* builtin */ dcl divide builtin; dcl length builtin; dcl mod builtin; dcl rtrim builtin; dcl size builtin; call le_debug_ ("Beginning MSF partitioning."); /* set the starting point for symbol sections to take the size of */ /* the symbol header, version string, and user string into account */ call le_util_$get_user_and_version (user, version); symbol_base = size (std_symbol_header); symbol_base = divide (length (rtrim (user)) + 3, 4, 17, 0) + divide (length (rtrim (version)) + 3, 4, 17, 0) + symbol_base; pad_base = mod (symbol_base, 2); n_components = 1; max_words = component_size * 1024; n_words = 0; n_static_words = 0; n_linkage_words = 0; n_text_words = 0; n_symbol_words = 0; do c = 1 to lec.n_components; /* for each included component . . . */ if lec.comp (c).flags.include then do; /* calculate the number of words in the input component */ c_words = divide (lec.comp (c).bc, 36, 19, 0); /* calculate the section sizes */ c_linkage_words = lec.comp (c).orig.linkl; c_static_words = lec.comp (c).orig.statl; c_text_words = lec.comp (c).orig.textl; c_symbol_words = lec.comp (c).orig.symbl_no_rel; /* adjust the linkage size for combined static */ if lec.comp (c).flags.separate_static & ^lec.header.flags.separate_static then c_linkage_words = c_linkage_words + c_static_words; /* adjust the symbol size for table removal */ if lec.comp (c).flags.delete_table then c_symbol_words = lec.comp (c).orig.symbl_no_table; lec.comp (c).orig.symbl = c_symbol_words; /* print a message if we are forcing an oversize output */ /* component */ if c_words > max_words then call le_error_ (LE_WARNING, le_et_$component_too_big, "^/Component ^a (^d pages) is larger than ^d pages.", lec.comp (c).name, divide (c_words + 1023, 1024, 9, 0), component_size); /* if the output component is empty, include the component */ /* even if it is larger than the maximum size to prevent */ /* looping into an infinite number of components because we */ /* couldn't ever fit one input component into a single output */ /* component. */ if n_words = 0 then do; /* set the section and total size values */ n_words = c_words; n_static_words = c_static_words; n_text_words = c_text_words; n_linkage_words = c_linkage_words; lec.comp (c).target = n_components; /* zero the relocation counters */ lec.comp (c).new.rel_text = 0; lec.comp (c).new.rel_stat = 0; lec.comp (c).new.text_pad = 0; lec.comp (c).new.static_pad = 0; /* set the symbol relocation counter accounting for the */ /* symbol header and strings */ lec.comp (c).new.rel_symb = symbol_base + pad_base; lec.comp (c).new.symbol_pad = pad_base; n_symbol_words = symbol_base + pad_base + c_symbol_words; end; else if n_words + c_words > max_words then do; /* if adding this input component would overflow the */ /* output component, skip to the next component */ call le_debug_ ("Skipping to component ^d due to size overflow.", n_components + 1); n_components = n_components + 1; n_words = c_words; n_static_words = c_static_words; n_linkage_words = c_linkage_words; n_text_words = c_text_words; lec.comp (c).target = n_components; /* zero the relocation counters */ lec.comp (c).new.rel_text = 0; lec.comp (c).new.rel_stat = 0; lec.comp (c).new.text_pad = 0; lec.comp (c).new.static_pad = 0; /* set the symbol relocation counter accounting for the */ /* symbol header and strings */ lec.comp (c).new.rel_symb = symbol_base + pad_base; lec.comp (c).new.symbol_pad = pad_base; n_symbol_words = symbol_base + pad_base + c_symbol_words; end; else if n_static_words + c_static_words > max_static_words then do; /* if adding to this component would overflow the maximum */ /* addressible static section size, then skip to the next */ /* component. */ call le_debug_ ( "Skipping to component ^d due to static section overflow.", n_components + 1); n_components = n_components + 1; n_words = c_words; n_static_words = c_static_words; n_linkage_words = c_linkage_words; n_text_words = c_text_words; lec.comp (c).target = n_components; /* zero the relocation counters */ lec.comp (c).new.rel_text = 0; lec.comp (c).new.rel_stat = 0; lec.comp (c).new.text_pad = 0; lec.comp (c).new.static_pad = 0; /* set the symbol relocation counter accounting for the */ /* symbol header and strings */ lec.comp (c).new.rel_symb = symbol_base + pad_base; lec.comp (c).new.symbol_pad = pad_base; n_symbol_words = symbol_base + pad_base + c_symbol_words; end; else if n_linkage_words + c_linkage_words > max_linkage_words then do; /* if adding to this component would overflow the maximum */ /* addressible linkage section size, then skip to the */ /* next component. */ call le_debug_ ( "Skipping to component ^d due to linkage section overflow.", n_components + 1); n_components = n_components + 1; n_words = c_words; n_static_words = c_static_words; n_linkage_words = c_linkage_words; lec.comp (c).target = n_components; /* zero the relocation counters */ lec.comp (c).new.rel_text = 0; lec.comp (c).new.rel_stat = 0; lec.comp (c).new.text_pad = 0; lec.comp (c).new.static_pad = 0; /* set the symbol relocation counter accounting for the */ /* symbol header and strings */ lec.comp (c).new.rel_symb = symbol_base + pad_base; lec.comp (c).new.symbol_pad = pad_base; n_symbol_words = symbol_base + pad_base + c_symbol_words; end; else do; /* otherwise just append this input component to the */ /* current output component. */ lec.comp (c).target = n_components; n_words = n_words + c_words; /* calculate the text relocation counter, padding if reqd */ /* to get the necessary text boundary. */ bound = lec.comp (c).orig.text_boundary; pad = mod (n_text_words, bound); lec.comp (c).new.rel_text = n_text_words + pad; lec.comp (c).new.text_pad = pad; n_text_words = n_text_words + pad + c_text_words; /* calculate the static relocation counter, padding if reqd */ /* to get the necessary static boundary. */ bound = lec.comp (c).orig.static_boundary; pad = mod (n_static_words, bound); lec.comp (c).new.rel_stat = n_static_words + pad; lec.comp (c).new.static_pad = pad; n_static_words = n_static_words + pad + c_static_words; /* calculate the symbol relocation counter */ pad = mod (n_symbol_words, 2); lec.comp (c).new.rel_symb = n_symbol_words + pad; lec.comp (c).new.symbol_pad = pad; n_symbol_words = n_symbol_words + pad + c_symbol_words; end; call le_debug_ ("Placing input component ""^a"" in component ^d.", lec.comp (c).name, n_components); end; end; call le_debug_ ("Completed MSF partitioning.^2/"); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include std_symbol_header; end le_msf_partition_;  le_snap_.pl1 12/10/86 1307.9rew 12/10/86 1251.6 270468 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to attempt to resolve links internally or to generate an external reference if the link cannot be resolved. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_snap_: proc (ocudp, /** ocu_data pointer (in ) */ lecp, /** components pointer (in ) */ comp, /** component index (in ) */ ref_section, /** referencing section (in ) */ ref_offset, /** referencing offset (in ) */ ref_relp, /** relpointer to link (in ) */ no_prelink, /** must be external (in ) */ section, /** section resolved to (out) */ relp, /** offset within scn (out) */ modifier, /** modifier required (out) */ internal); /** internal flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_snap_ */ /*** Input: ocudp, lecp, comp, ref_section, ref_offset, */ /*** ref_relp, no_prelink */ /*** Function: resolves an internal link and returns information */ /*** regarding where it snaps to. The information */ /*** returned consists of the section and offset to */ /*** refer to, and whether the resolution removed the */ /*** indirection through the link. */ /*** Output: section, relp, modifier, internal */ /*** */ /*** ****************************************************************/ /* constants */ dcl false bit (1) static options (constant) init ("0"b); dcl true bit (1) static options (constant) init ("1"b); dcl Indirection_modifier bit (6) static options (constant) init ("20"b3); dcl None fixed bin static options (constant) init (0); /* parameters */ dcl ocudp ptr parameter; dcl lecp ptr parameter; dcl comp fixed bin parameter; dcl ref_section fixed bin (3) parameter; dcl ref_offset fixed bin (18) unsigned parameter; dcl ref_relp fixed bin (18) unsigned parameter; dcl no_prelink bit (1) parameter; dcl section fixed bin (3) parameter; dcl relp fixed bin (18) unsigned parameter; dcl modifier bit (6) parameter; dcl internal bit (1) parameter; /* procedures */ dcl get_system_free_area_ entry () returns (ptr); dcl le_backpatch_ entry (fixed bin, fixed bin, uns fixed bin (18), fixed bin, fixed bin); dcl le_error_ entry options (variable); /* external */ dcl error_table_$bad_class_def external fixed bin (35); dcl le_et_$bad_link_class external fixed bin (35); dcl le_et_$bad_link_ref external fixed bin (35); dcl le_et_$bad_link_type external fixed bin (35); /* based */ dcl 01 defn aligned like le_definition based (defnp); dcl 01 init aligned like link_init based (initp); dcl 01 init_copy aligned based (initp), 02 header aligned like link_init_copy_info.header, 02 initial_data dim (0 refer (init_copy.n_words)) bit (36) aligned; dcl 01 init_list aligned based (initp), 02 header aligned like link_init_list_template.header, 02 pad bit (18) unaligned, 02 n_words_in_list fixed bin (18) unsigned unaligned, 02 template dim (0 refer (init_list.n_words_in_list)); dcl 01 lec aligned based (lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; dcl 01 led aligned based, 02 header aligned like le_definitions.header, 02 def dim (0 refer (led.n_defs)) like le_definition; dcl 01 lel aligned based (lelp), 02 header aligned like le_links.header, 02 link dim (0 refer (lel.n_links)) like le_link; dcl 01 lk aligned like le_link based (lkp); dcl 01 lte aligned based (ltep), 02 n_bits fixed bin (35) aligned, 02 mbz bit (3) unaligned, 02 init_type fixed bin (3) unsigned unaligned, 02 repeat fixed bin (30) unsigned unaligned, 02 datum bit (0 refer (lte.n_bits)); dcl 01 new_copy aligned based (new_initp), 02 header aligned like link_init_copy_info.header, 02 initial_data dim (n_words refer (init_copy.n_words)) bit (36) aligned; dcl 01 new_list aligned based (new_initp), 02 header aligned like link_init_list_template.header, 02 pad bit (18) unaligned, 02 n_words_in_list fixed bin (18) unsigned unaligned, 02 template dim (list_size refer (init_list.n_words_in_list)); dcl 01 offsetname aligned based (lk.offsetp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (offsetname.count)) unaligned; dcl 01 pit aligned like pointer_init_template based (pitp); dcl 01 segname aligned based (lk.segnamep), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (segname.count)) unaligned; dcl sys_area area based (sys_areap); dcl 01 tl aligned like le_link based (tlp); /* automatic */ dcl 01 auto_def aligned like link_init_deferred automatic; dcl 01 auto_init aligned like link_init automatic; dcl copied bit (1) automatic; dcl defnp ptr automatic; dcl hdr_size fixed bin automatic; dcl i fixed bin automatic; dcl initp ptr automatic; dcl lelp ptr automatic; dcl linkx fixed bin automatic; dcl list_size fixed bin (18) unsigned automatic; dcl lkp ptr automatic; dcl ltep ptr automatic; dcl new_initp ptr automatic; dcl n_words fixed bin (35) automatic; dcl offset fixed bin (18) unsigned; dcl patch_mask bit (10000) automatic; dcl pitp ptr automatic; dcl sys_areap ptr automatic; dcl template_index fixed bin automatic; dcl tlp ptr automatic; /* conditions */ dcl cleanup condition; /* builtin */ dcl addr builtin; dcl addwordno builtin; dcl currentsize builtin; dcl index builtin; dcl null builtin; dcl size builtin; dcl substr builtin; dcl unspec builtin; dcl wordno builtin; section = -1; relp = 0; modifier = ""b; internal = false; lelp = lec.comp (comp).tables.lelp; /* calculate the link table index of the referenced link */ linkx = (ref_relp - lel.offset_adjustment) / 2; if linkx < 0 | linkx > lel.n_links then do; call le_error_ (LE_FATAL_ERROR, le_et_$bad_link_ref, "^/Reference to link|^o at ^a|^o of ^a does not refer to a link.", ref_relp, section_nm (ref_section), ref_offset, lec.comp (comp).name); return; end; lkp = addr (lel.link (linkx)); /* optimize for already emitted links */ if ^no_prelink & lk.relp ^= None then do; section = Linkage; relp = lk.relp; modifier = Indirection_modifier; return; end; if lk.type < 1 | lk.type > 5 | lk.type = 2 then do; call le_error_ (LE_FATAL_ERROR, le_et_$bad_link_type, "^/Link at link|^o has an invalid type (^d).", ref_relp, lk.type); return; end; goto LINK_TYPE (lk.type); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ LINK_TYPE (1): /** *section|0+expression */ if lk.class = Text then do; /* if not prelinking, then relocate and re-emit */ if no_prelink then do; section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Text, "", "", lec.comp (comp).new.rel_text + lk.exp, lk.mod, null); return; end; /* otherwise relocate and return the text offset */ section = Text; relp = lec.comp (comp).new.rel_text + lk.exp; internal = true; end; else if lk.class = Linkage then do; hdr_size = size (virgin_linkage_header); /* actually a reference to combined static */ if lk.exp > hdr_size & lk.exp < hdr_size + lec.comp (comp).orig.statl & ^lec.comp (comp).flags.separate_static then do; /* if we are not prelinking, re-emit the link as a *static */ /* link. If static is combined, ocu_ will convert it to a */ /* *link|0+N link and adjust the offset */ if no_prelink then do; section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Static, "", "", lk.exp + lec.comp (comp).new.rel_stat, lk.mod, null); return; end; /* otherwise, we treat it as a static reference */ section = Static; relp = lec.comp (comp).new.rel_stat + lk.exp - hdr_size; internal = true; return; end; /* check for a reference to the header rather than a link or static */ if lk.exp < hdr_size then do; /* non-link, non-static linkage section references are just */ /* re-emitted with the same expression value, since we have */ /* no good way of determining how to relocate them. */ if no_prelink then do; relp = ocu_$emit_link (ocudp, Self_Base, Linkage, "", "", (lk.exp), lk.mod, null); section = Linkage; modifier = Indirection_modifier; return; end; relp = lk.exp; section = Linkage; modifier = lk.mod; internal = true; return; end; /* the reference is to another link */ if no_prelink then do; /* we have to emit the target link of this link, so snap it */ /* without prelinking and regenerate the reference. */ call le_snap_ (ocudp, lecp, comp, Linkage, ref_relp, (lk.exp), no_prelink, section, relp, modifier, internal); section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Linkage, "", "", (relp), lk.mod, null); modifier = Indirection_modifier; return; end; /* if the link has an indirection modifier, then we will end up */ /* indirecting through the target link as well, so snap to the */ /* target of that link instead. */ if lk.mod = Indirection_modifier then call le_snap_ (ocudp, lecp, comp, Linkage, ref_relp, (lk.exp), false, section, relp, modifier, internal); else do; call le_snap_ (ocudp, lecp, comp, Linkage, ref_relp, (lk.exp), false, section, relp, modifier, internal); modifier = lk.mod; end; internal = true; end; else if lk.class = CLASS_SYMBOL then do; /* if not prelinking, just re-emit the link */ if no_prelink then do; section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Symbol, "", "", (lk.exp), lk.mod, null); modifier = Indirection_modifier; return; end; /* otherwise, relocate and return the symbol offset */ section = Symbol; relp = lk.exp + lec.comp (comp).new.rel_symb; modifier = lk.mod; internal = true; end; else if lk.class = CLASS_STATIC then do; if lec.header.flags.separate_static | no_prelink then do; /* we can't prelink to separate static */ section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Static, "", "", lk.exp + lec.comp (comp).new.rel_stat, lk.mod, null); if ^no_prelink then lk.relp = relp; modifier = Indirection_modifier; return; end; section = Static; relp = lk.exp + lec.comp (comp).new.rel_stat; modifier = lk.mod; internal = true; end; else call le_error_ (LE_FATAL_ERROR, le_et_$bad_link_class, "^/Class ^d found while evaluating link at link|^o.", lk.class, ref_relp); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ LINK_TYPE (3): /** refname|0+expression */ if lec.comp (lk.target).target = None | no_prelink then do; /* the target is not internal, or we were told not to prelink, */ /* so we just regenerate the link. */ relp = ocu_$emit_link (ocudp, Refname_Base, 0, (segname.string), "", (lk.exp), lk.mod, null); section = Linkage; modifier = Indirection_modifier; if ^no_prelink then lk.relp = relp; end; else if lec.comp (lk.target).target ^= lec.comp (comp).target then do; /* the target is internal but in another component, so generate */ /* a partial link and retain the indirection. */ relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target).target), Text, 0, lk.mod); lk.relp = relp; section = Linkage; modifier = Indirection_modifier; end; else do; /* the target is internal and in this component, so remove the */ /* indirection and resolve from the base of the text section of */ /* the target component. */ relp = lk.exp + lec.comp (lk.target).new.rel_text; section = Text; modifier = lk.mod; internal = true; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ LINK_TYPE (4): /** refname|entry+expression */ if lk.target = None | no_prelink then do; /* the link is not internal, or we are not snapping it for */ /* other reasons. */ relp = ocu_$emit_link (ocudp, Refname_Offsetname, 0, (segname.string), (offsetname.string), (lk.exp), lk.mod, null); section = Linkage; modifier = Indirection_modifier; if ^no_prelink then lk.relp = relp; return; end; defnp = addr (lec.comp (lk.target).tables.ledp -> led.def (lk.defx)); if lec.comp (lk.target).target ^= lec.comp (comp).target then do; /* the target of the link is in another component, so we have */ /* to generate a partial link to the target. If the link */ /* points to the linkage section, we may have to backpatch if */ /* it refers to a link. */ if defn.type ^= Linkage then do; /* simple partial link reference, relocate the offset */ /* and emit the partial link. */ if defn.type = Text then offset = lec.comp (lk.target).new.rel_text; else if defn.type = Symbol then offset = lec.comp (lk.target).new.rel_symb; else if defn.type = Static then offset = lec.comp (lk.target).new.rel_stat; else call le_error_ (LE_ABORT_ERROR, error_table_$bad_class_def, "^/Class ^d definition in ^a at definition|^o.", defn.type, lec.comp (lk.target).name, defn.offset); offset = offset + defn.relp + lk.exp; relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target).target), (defn.type), offset, lk.mod); lk.relp = relp; end; else do; /* we have a linkage reference. Now we determine if it is */ /* a header, static, or link reference, and handle things */ /* accordingly. */ hdr_size = size (virgin_linkage_header); if defn.relp < hdr_size then do; /* the reference it so the header. Just link to the */ /* same point in the new header. */ relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target).target), Linkage, defn.relp + lk.exp, lk.mod); lk.relp = relp; end; else if defn.relp < hdr_size + lec.comp (lk.target).orig.statl then do; /* the reference is to the static section, so relocate */ /* it appropriately, and emit the link. */ relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target).target), Linkage, defn.relp + lk.exp + lec.comp (lk.target).new.rel_stat, lk.mod); lk.relp = relp; end; else do; /* the reference is to a link. But we probably don't */ /* know where that link will be emitted yet, so we will */ /* have to schedule a backpatch of the offset. */ relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target).target), Linkage, (lk.exp), lk.mod); call le_backpatch_ (Patch_Link, lec.comp (comp).target, relp, (lk.target), (lk.defx)); lk.relp = relp; end; end; section = Linkage; modifier = Indirection_modifier; return; end; /* the reference is internal and within this component, so we can */ /* actually resolve the reference. */ if defn.type = Text then do; section = Text; relp = defn.relp + lk.exp + lec.comp (lk.target).new.rel_text; modifier = lk.mod; internal = true; end; else if defn.type = Symbol then do; section = Symbol; relp = defn.relp + lk.exp + lec.comp (lk.target).new.rel_symb; modifier = lk.mod; internal = true; end; else if defn.type = Static then do; if lec.header.flags.separate_static then do; /* we can't prelink to separate static */ section = Linkage; relp = ocu_$emit_link (ocudp, Self_Base, Static, "", "", defn.relp + lk.exp + lec.comp (lk.target).new.rel_stat, lk.mod, null); modifier = Indirection_modifier; return; end; section = Static; relp = defn.relp + lk.exp + lec.comp (lk.target).new.rel_stat; modifier = lk.mod; internal = true; end; else if defn.type = Linkage then do; /* either a link or static reference. If static, relocate */ /* and resolve the link. If it is a link, we snap to the */ /* target of the link. */ hdr_size = size (virgin_linkage_header); if defn.relp < hdr_size + lec.comp (lk.target).orig.defnl then do; /* a static reference, so relocate and return */ relp = defn.relp + lk.exp + lec.comp (lk.target).new.rel_stat - hdr_size; section = Static; modifier = lk.mod; internal = true; end; else do; /* a link reference, so we snap the target of the link */ /* depending on the modifier in the current link, and */ /* snap to there. */ if lk.mod = Indirection_modifier then call le_snap_ (ocudp, lecp, (lk.target), Linkage, ref_relp, defn.relp + lk.exp, false, section, relp, modifier, internal); else do; call le_snap_ (ocudp, lecp, (lk.target), Linkage, ref_relp, defn.relp + lk.exp, true, section, relp, modifier, internal); modifier = lk.mod; end; internal = true; end; end; else call le_error_ (LE_ABORT_ERROR, error_table_$bad_class_def, "^/Class ^d found in ^a at definition|^o.", defn.type, lec.comp (lk.target).name, defn.offset); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ LINK_TYPE (5): /** *section|entry+expression */ /* for now, only *system and *heap links of this type are supported */ /* (primarily since none of the others are used). */ if lk.initp = null then do; /* this indicates that the actual init_info is in another MSF */ /* component, and we need to create a deferred_init init_info */ /* block for this link. */ tlp = addr (lec.comp (lk.target_comp).tables.lelp -> lel.link (lk.target_link)); auto_def.type = INIT_DEFERRED; auto_def.n_words = tl.initp -> init.n_words; auto_def.target_relp = ocu_$emit_partial_link (ocudp, (lec.comp (lk.target_comp).target), Linkage, 0, ""b); auto_def.link_relp = 0; section = Linkage; relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, addr (auto_def)); modifier = Indirection_modifier; lk.relp = relp; call le_backpatch_ (Patch_Init, lec.comp (comp).target, relp, (lk.target_comp), (lk.target_link)); end; else if lk.extension ^= None then do; /* clear the template count */ template_index = 0; /* the init info given will be used but must be extended to a */ /* larger size. So we generate a new init info, and extend it, */ /* padding with zeros, to the proper size. */ initp = lk.initp; if init.type = INIT_NO_INIT | init.type = INIT_DEFINE_AREA then do; auto_init.type = init.type; auto_init.n_words = init.n_words + lk.extension; initp = addr (auto_init); relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, addr (auto_init)); lk.relp = relp; section = Linkage; modifier = Indirection_modifier; end; else if init.type = INIT_COPY_INFO then do; sys_areap = get_system_free_area_ (); new_initp = null; if lk.extension > 50 /* arbitrary limit */ then do; /* the extension is large enough that it is more */ /* efficient to convert the copy info into a list */ /* template. */ on cleanup begin; if new_initp ^= null then free new_list in (sys_area); end; /* allocate a list_template init structure */ list_size = currentsize (init_copy) + 3; allocate new_list in (sys_area); new_list.type = INIT_LIST_TEMPLATE; new_list.n_words = init.n_words + lk.extension; /* create the template for the original data */ ltep = addr (new_list.template (1)); lte.n_bits = init_copy.n_words * 36; lte.repeat = 1; lte.datum = unspec (init_copy.initial_data); /* create the template to skip the size of the extension */ ltep = addwordno (ltep, currentsize (lte)); lte.n_bits = lk.extension * 36; lte.repeat = 0; /* skip bits */ /* create the template for end of initialization */ ltep = addwordno (ltep, 2); lte.n_bits = 0; /* emit the link */ relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, new_initp); lk.relp = relp; section = Linkage; modifier = Indirection_modifier; free new_list in (sys_area); revert cleanup; end; else do; /* the extenstion is small, so just extend the copy init */ new_initp = null; on cleanup begin; if new_initp ^= null then free new_copy in (sys_area); end; /* determine the new length */ n_words = init_copy.n_words + lk.extension; /* allocate the new init_info */ allocate new_copy in (sys_area); /* copy the data into the new template */ new_copy.type = INIT_COPY_INFO; unspec (new_copy.initial_data) = unspec (init_copy.initial_data); /* emit the link */ relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, new_initp); lk.relp = relp; section = Linkage; modifier = Indirection_modifier; free new_copy in (sys_area); revert cleanup; end; end; else if init.type = INIT_LIST_TEMPLATE then do; sys_areap = get_system_free_area_ (); new_initp = null; /* extend the list template init by adding a new skip bits */ /* template and end template. */ on cleanup begin; if new_initp ^= null then free new_list in (sys_area); end; /* allocate a larger template */ list_size = init_list.n_words_in_list + 2; allocate new_list in (sys_area); /* copy the old list template into the new structure */ new_list.type = INIT_LIST_TEMPLATE; new_list.n_words = init_list.n_words + lk.extension; unspec (new_list.template) = unspec (init_list.template); /* the new extension template starts in the last word of */ /* the old template, replacing the end-of-init (n_bits = 0) */ /* template. */ ltep = addwordno (new_initp, currentsize (init_list) - 1); lte.n_bits = lk.extension * 36; lte.repeat = 0; /* now append a new end-of-init template */ ltep = addwordno (ltep, 2); lte.n_bits = 0; /* scan the copy looking for pointer initializations */ ltep = addr (new_list.template); template_index = 1; substr (patch_mask, template_index, 1) = false; do while (lte.n_bits ^= 0); /* see if it is a pointer initialization */ if lte.init_type ^= 0 then do; /* get a pointer to the init datum */ pitp = addr (lte.datum); /* relocate text refs by adding in the text offset */ if pit.ptr_type = 0 then pit.word_offset = pit.word_offset + lec.comp (lk.target_comp).new.rel_text; /* relocate static refs by adding in the static offset */ else if pit.ptr_type = 2 then pit.word_offset = pit.word_offset + lec.comp (lk.target_comp).new.rel_stat; /* relocate linkage refs by regenerating the link */ /* and putting the new link offset in the template */ else do; if pit.section_offset = ref_relp then substr (patch_mask, template_index, 1) = true; else do; call le_snap_ (ocudp, lecp, (lk.target_comp), Linkage, ref_relp, (pit.section_offset), false, section, relp, modifier, internal); if section ^= None then if section ^= Linkage then pit.section_offset = ocu_$emit_link (ocudp, Self_Base, section, "", "", (relp), modifier, null); else pit.section_offset = relp; end; end; end; /* skip to the next template */ ltep = addwordno (ltep, currentsize (lte)); template_index = template_index + 1; substr (patch_mask, template_index, 1) = false; end; /* emit the link */ relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, new_initp); /* scan to see if we have to backpatch self-referential */ /* pointer init templates. */ do while (substr (patch_mask, 1, template_index) ^= ""b); i = index (patch_mask, "1"b); call le_backpatch_ (Patch_Self_Init, lec.comp (comp).target, relp, 0, i); substr (patch_mask, i, 1) = false; end; lk.relp = relp; section = Linkage; modifier = Indirection_modifier; /* and free the new init template */ free new_list in (sys_area); revert cleanup; end; end; else do; /* set up flags and handler in case relocation of pointer */ /* initializations requires us to make a copy of the template. */ initp = lk.initp; copied = false; new_initp = null; sys_areap = get_system_free_area_ (); on cleanup begin; if copied then free new_list in (sys_area); end; template_index = 0; /* only check for pointer inits in list templates, since you */ /* can't do them any other way. */ if init.type = INIT_LIST_TEMPLATE then do; /* get a pointer to the first template */ ltep = addr (init_list.template); template_index = 1; substr (patch_mask, template_index, 1) = false; /* scan until we hit the end template */ do while (lte.n_bits ^= 0); /* check for non-constant initialization template */ if lte.init_type ^= 0 then do; /* if we haven't already copied the template, do so now */ if ^copied then do; /* allocate a new template */ list_size = init_list.n_words_in_list; allocate new_list in (sys_area); /* note that we have done so so that it can be freed */ copied = true; /* copy the old template */ unspec (new_list) = unspec (init_list); /* generate a new template pointer that points to */ /* the same template in the new init info we were */ /* looking at in the original info and continue our */ /* scan using the new init info */ ltep = addwordno (new_initp, wordno (ltep)-wordno (initp)); end; /* get a pointer to the init datum */ pitp = addr (lte.datum); /* relocate text refs by adding in the text offset */ if pit.ptr_type = 0 then pit.word_offset = pit.word_offset + lec.comp (lk.target_comp).new.rel_text; /* relocate static refs by adding in the static offset */ else if pit.ptr_type = 2 then pit.word_offset = pit.word_offset + lec.comp (lk.target_comp).new.rel_stat; /* relocate linkage refs by regenerating the link */ /* and putting the new link offset in the template */ else do; if pit.section_offset = ref_relp then substr (patch_mask, template_index, 1) = true; else do; call le_snap_ (ocudp, lecp, (lk.target_comp), Linkage, ref_relp, (pit.section_offset), false, section, relp, modifier, internal); if section ^= None then if section ^= Linkage then pit.section_offset = ocu_$emit_link (ocudp, Self_Base, section, "", "", (relp), modifier, null); else pit.section_offset = relp; end; end; end; ltep = addwordno (ltep, currentsize (lte)); template_index = template_index + 1; substr (patch_mask, template_index, 1) = false; end; end; if ^copied then new_initp = initp; relp = ocu_$emit_link (ocudp, Self_Offsetname, (lk.class), "", (offsetname.string), (lk.exp), lk.mod, (new_initp)); /* scan to see if we have to backpatch self-referential pointer */ /* init templates. */ if template_index > 0 then do while (substr (patch_mask, 1, template_index) ^= ""b); i = index (patch_mask, "1"b); call le_backpatch_ (Patch_Self_Init, lec.comp (comp).target, relp, 0, i); substr (patch_mask, i, 1) = false; end; lk.relp = relp; section = Linkage; modifier = Indirection_modifier; if copied then free new_list in (sys_area); revert cleanup; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; %include definition_dcls; %include object_link_dcls; %include ocu_dcls; end le_snap_;  le_util_.pl1 12/10/86 1308.0rew 12/10/86 1251.7 80982 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to provide utilities used by a number of le subroutines. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ le_util_: proc; /*** ****************************************************************/ /*** */ /*** Name: le_util_ */ /*** Function: This is a set of utility routines used in a */ /*** number of places within le_ */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl Expanded_Absolute bit (5) static options (constant) init ("11110"b); dcl rel_chr (0:10) char (1) static options (constant) init ("t", "1", "2", "3", "l", "d", "s", "7", "8", "i", "r"); /* parameters */ dcl a_user char (*) parameter; dcl a_version char (*) parameter; dcl a_relinfop ptr parameter; dcl a_relindex fixed bin parameter; dcl a_odd bit (1) parameter; dcl a_skip fixed bin parameter; dcl a_rel char (*) parameter; dcl a_lebp ptr parameter; dcl a_lecp ptr parameter; dcl a_uid aligned bit (36) parameter; /* procedures */ dcl get_group_id_ entry () returns (char (32)); dcl le_error_ entry options (variable); /* external */ dcl le_data_$caller external char (32) varying; dcl le_data_$version_suffix external char (64) varying; dcl le_et_$invalid_relinfo external fixed bin (35); /* based */ dcl 01 relinfo aligned based (a_relinfop), 02 decl_vers fixed bin, 02 n_bits fixed bin, 02 relbits bit (0 refer (relinfo.n_bits)) aligned; dcl 01 leb aligned based (a_lebp), 02 header aligned like le_binaries.header, 02 binary dim (0:0 refer (leb.n_binaries)) like le_binaries.binary; dcl 01 lec aligned based (a_lecp), 02 header aligned like le_components.header, 02 comp dim (0 refer (lec.n_components)) like le_comp; /* automatic */ dcl b fixed bin automatic; dcl c fixed bin automatic; dcl 01 exp_abs aligned automatic, 02 type bit (5) unaligned, 02 count fixed bin (10) unsigned unaligned; dcl found bit (1) automatic; dcl halfwords fixed bin automatic; dcl 01 non_abs aligned automatic, 02 flag bit (1) unaligned, 02 type fixed bin (4) unsigned unaligned; /* builtin */ dcl divide builtin; dcl mod builtin; dcl null builtin; dcl rtrim builtin; dcl substr builtin; dcl unspec builtin; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ get_user_and_version: entry (a_user, /** userid string (out) */ a_version); /** version string (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_util_$get_user_and_version */ /*** Input: none */ /*** Function: returns the userid and version strings to be */ /*** included in the symbol section as part of the */ /*** symbol header. */ /*** Output: user, version */ /*** */ /*** ****************************************************************/ a_user = get_group_id_ (); a_version = rtrim (le_data_$caller) || rtrim (le_data_$version_suffix); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ scan_relinfo: entry (a_relinfop, /** reloc info pointer (in ) */ a_relindex, /** position in relinfo (i/o) */ a_odd, /** odd halfword flag (i/o) */ a_skip, /** words to skip (out) */ a_rel); /** relinfo found (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_util_$scan_relinfo */ /*** Input: relinfop, relindex, odd */ /*** Function: scans a relinfo block starting at a particular */ /*** point and returns the relocation information for */ /*** the next word containing non-absolute relinfo, as */ /*** well as the number of words to skip (ie. words */ /*** with absolute relocation.) */ /*** Output: relindex, skip, rel */ /*** */ /*** ****************************************************************/ a_skip = 0; a_rel = "aa"; /* handle adjustment for previous word containing part of an */ /* absolute group. */ if a_odd then halfwords = -1; else halfwords = 0; a_odd = false; found = false; /* scan for the next non-absolute halfword */ do while ((a_relindex <= relinfo.n_bits) & ^found); if substr (relinfo.relbits, a_relindex, 1) = "0"b then do; halfwords = halfwords + 1; a_relindex = a_relindex + 1; end; else if substr (relinfo.relbits, a_relindex, 5) = Expanded_Absolute then do; unspec (exp_abs) = substr (relinfo.relbits, a_relindex, 15); a_relindex = a_relindex + 15; halfwords = halfwords + exp_abs.count; end; else found = true; end; /* calculate the number of words to skip */ a_skip = divide (halfwords, 2, 18, 0); /* if we didn't run off the end, then we generate the relinfo for */ /* non-absolute word. */ if found then do; if mod (halfwords, 2) = 0 then do; /* non-absolute halfword was in the left halfword, so get */ /* the relinfo and insert it. */ unspec (non_abs) = substr (relinfo.relbits, a_relindex, 5); if non_abs.type > 10 then call le_error_ (LE_FATAL_ERROR, le_et_$invalid_relinfo, "^/Unknown relocation value (^d) found.", non_abs.type); else substr (a_rel, 1, 1) = rel_chr (non_abs.type); a_relindex = a_relindex + 5; end; /* now process the right halfword */ /* check for and absolute bit */ if substr (relinfo.relbits, a_relindex, 1) = "0"b then a_relindex = a_relindex + 1; /* see if the right halfword is absolute but part of an */ /* expanded absolute block, here we dont skip the block, just */ /* set the odd flag to note next time that we have already */ /* processed one bit of the expanded block. */ else if substr (relinfo.relbits, a_relindex, 5) = Expanded_Absolute then a_odd = true; else do; /* the right halfword is not absolute */ unspec (non_abs) = substr (relinfo.relbits, a_relindex, 5); if non_abs.type > 10 then call le_error_ (LE_FATAL_ERROR, le_et_$invalid_relinfo, "^/Unknown relocation value (^d) found.", non_abs.type); else substr (a_rel, 2, 1) = rel_chr (non_abs.type); a_relindex = a_relindex + 5; end; end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ check_uid: entry (a_lecp, /** components pointer (in ) */ a_lebp, /** binaries pointer (in ) */ a_uid) /** unique id (in ) */ returns (bit (1)); /** duplicate flag (out) */ /*** ****************************************************************/ /*** */ /*** Name: le_util_$check_uid */ /*** Input: lecp, lebp, uid */ /*** Function: compares a given uid (for a segment about to be */ /*** overwritten) with the stored UIDs for the input */ /*** components and already emitted output to insure */ /*** that nothing is being destroyed. */ /*** Output: duplicate_flag */ /*** */ /*** ****************************************************************/ /* see if the file is the same as an input component */ if a_lecp ^= null then do c = 1 to lec.n_components; if lec.comp (c).uid = a_uid then return (true); end; /* see if the file is the same as an output component */ if a_lebp ^= null then do b = 1 to leb.n_binaries; if leb.binary (b).uid = a_uid then return (true); end; /* no match so return false */ return (false); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include le_data; end le_util_;  ocu_.pl1 10/26/88 0824.9rew 10/26/88 0822.6 1155015 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Elhard), approve(86-08-12,MCR7505), audit(86-12-10,DGHowe), install(86-12-10,MR12.0-1241): Originally written to provide a subroutine library for creating standard object segments. 2) change(86-12-19,Elhard), approve(86-12-19,PBF7505), audit(86-12-22,DGHowe), install(87-01-05,MR12.0-1256): Changed declarations of list templates to put in explicit declaration of the template words (instead of letting them default to fixed bin (17)) so that debugging versions compiled with -prefix size dont explode. 3) change(88-10-06,Elhard), approve(88-10-06,MCR8015), audit(88-10-24,DGHowe), install(88-10-26,MR12.2-1185): Fixed phx21213 Re: invalid deferred init template relocation, and bug in definition hash table generation. END HISTORY COMMENTS */ /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll78,initcol0,dclind4,idind24,struclvlind1,comcol41 */ ocu_: proc; /*** ****************************************************************/ /*** */ /*** Name: ocu_ */ /*** Function: This is a set of object creation utilities used */ /*** to create standard format object segments. */ /*** */ /*** ****************************************************************/ /* constants */ dcl true bit (1) static options (constant) init ("1"b); dcl false bit (1) static options (constant) init ("0"b); dcl Left fixed bin static options (constant) init (1); dcl Right fixed bin static options (constant) init (2); dcl reloc_bits (1:12) bit (5) static options (constant) init ("10000"b, "10001"b, "10010"b, "10011"b, "10100"b, "10101"b, "10110"b, "10111"b, "11000"b, "11001"b, "11010"b, "11111"b); dcl reloc_chars char (12) static options (constant) init ("t123lds78ire"); dcl class_relinfo (0:4) char (1) static options (constant) init ("t", "l", "s", "d", "i"); dcl STD_RELINFO char (13) static options (constant) init ("at123lds78ire"); dcl ALM_RELINFO char (13) static options (constant) init ("a0123456789L*"); /* static structures for currentsize references */ dcl 01 s_vlh aligned like virgin_linkage_header static options (constant); dcl 01 s_lk aligned like object_link static options (constant); dcl 01 s_dh aligned like definition_header static options (constant); dcl 01 s_def aligned like definition static options (constant); /* parameters */ dcl A_call_relp fixed bin (18) unsigned parameter; dcl A_class fixed bin (3) parameter; dcl A_code fixed bin (35) parameter; dcl A_component fixed bin (15) unsigned parameter; dcl A_component_count fixed bin (15) unsigned parameter; dcl A_component_listp ptr parameter; dcl A_dir_name char (*) parameter; dcl A_entry_name char (*) parameter; dcl A_expression fixed bin (17) parameter; dcl A_flags bit (*) parameter; dcl A_generator_infop ptr; dcl A_info_relp fixed bin (18) unsigned parameter; dcl A_init_infop ptr parameter; dcl A_modifier bit (6) parameter; dcl A_my_component fixed bin (15) unsigned parameter; dcl A_name char (*) varying parameter; dcl A_new_value fixed bin (35) parameter; dcl A_ocu_datap ptr parameter; dcl A_offset fixed bin (18) unsigned parameter; dcl A_offsetname char (*) varying parameter; dcl A_patch_section char (*) parameter; dcl A_relocationp ptr parameter; dcl A_section fixed bin (3) parameter; dcl A_segname char (*) varying parameter; dcl A_side char (*) parameter; dcl A_type fixed bin (3) parameter; dcl A_word_count fixed bin (18) unsigned parameter; dcl A_wordp ptr parameter; /* procedures */ dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_shortest_path_ entry (char (*)) returns (char (168)); dcl get_system_free_area_ entry () returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl sub_err_ entry () options (variable); dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl tssi_$clean_up_segment entry (ptr); /* external */ dcl error_table_$bad_arg external fixed bin (35); dcl error_table_$improper_data_format external fixed bin (35); dcl error_table_$inconsistent_object_msf external fixed bin (35); dcl error_table_$namedup external fixed bin (35); dcl error_table_$out_of_sequence external fixed bin (35); dcl error_table_$unimplemented_version external fixed bin (35); /* static */ dcl vlh_size fixed bin static; dcl lk_size fixed bin static; dcl dh_size fixed bin static; dcl def_size fixed bin static; /* based */ dcl 01 de aligned like def_entry based (dep); dcl 01 di aligned based (dip), 02 header aligned like def_info.header, 02 def dim (0 refer (di.N_defs)) like def_entry; dcl 01 frti aligned based (frtip), 02 header aligned like firstref_trap_info.header, 02 trap dim (0 refer (frti.N_traps)) like firstref_trap_entry; dcl 01 li aligned based (lip), 02 header aligned like link_info.header, 02 link dim (0 refer (li.N_links)) like link_entry; dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); dcl 01 sbi aligned based (sbip), 02 header aligned like symbol_info.header, 02 symbol_word dim (0 refer (sbi.N_symbol_words)) bit (36); dcl 01 ti aligned based (tip), 02 header aligned like text_info.header, 02 text_word dim (0 refer (ti.N_text_words)) bit (36); dcl 01 mi aligned based (mip), 02 header aligned like msf_info.header, 02 component dim (0 refer (mi.N_components)) like msf_info.component; dcl 01 w15 aligned based (wordp), 02 pad1 bit (3) unaligned, 02 left fixed bin (15) unsigned unaligned, 02 pad2 bit (18) unaligned; dcl 01 w18 aligned based (wordp), 02 left fixed bin (18) unsigned unaligned, 02 right fixed bin (18) unsigned unaligned; dcl 01 w15s aligned based (wordp), 02 pad1 bit (3) unaligned, 02 left fixed bin (14) unaligned, 02 pad2 bit (18) unaligned; dcl 01 w18s aligned based (wordp), 02 left fixed bin (17) unaligned, 02 right fixed bin (17) unaligned; /* automatic */ dcl c fixed bin automatic; dcl call_relp fixed bin (18) unsigned automatic; dcl defx fixed bin automatic; dcl dep ptr automatic; dcl dip ptr automatic; dcl dname char (168) automatic; dcl ec fixed bin (35) automatic; dcl ename char (32) automatic; dcl frtip ptr automatic; dcl i fixed bin automatic; dcl info_relp fixed bin (18) unsigned automatic; dcl lip ptr automatic; dcl 01 linke aligned like link_entry automatic; dcl linkx fixed bin automatic; dcl mode bit (36) aligned automatic; dcl next_word fixed bin (18) unsigned automatic; dcl odp ptr automatic; dcl reloc_infop ptr automatic; dcl relp fixed bin (18) unsigned automatic; dcl sbip ptr automatic; dcl sip ptr automatic; dcl static_arrayp ptr automatic; dcl strx fixed bin automatic; dcl symbol_arrayp ptr automatic; dcl text_arrayp ptr automatic; dcl tip ptr automatic; dcl mip ptr automatic; dcl wordp ptr automatic; /* conditions */ dcl cleanup condition; dcl size condition; /* builtin */ dcl addr builtin; dcl addwordno builtin; dcl bit builtin; dcl char builtin; dcl clock builtin; dcl copy builtin; dcl currentsize builtin; dcl divide builtin; dcl fixed builtin; dcl hbound builtin; dcl index builtin; dcl ltrim builtin; dcl min builtin; dcl mod builtin; dcl null builtin; dcl ptr builtin; dcl rel builtin; dcl rtrim builtin; dcl search builtin; dcl string builtin; dcl substr builtin; dcl translate builtin; dcl unspec builtin; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ open: entry (A_dir_name, /** output dir name (in ) */ A_entry_name, /** output entry name (in ) */ A_flags, /** option flags (in ) */ A_ocu_datap, /** ocu_data pointer (out) */ A_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$open */ /*** Input: dir_name, entry_name, flags */ /*** Function: allocates all of the structures to be used and */ /*** initialize them. Since most of the structures */ /*** are extensible, each structure has its own temp */ /*** seg. */ /*** Output: ocu_datap, code */ /*** */ /*** ****************************************************************/ /* arrange to clean up if we are interrupted */ ocu_datap, A_ocu_datap = null; vlh_size = currentsize (s_vlh); lk_size = currentsize (s_lk); dh_size = currentsize (s_dh); def_size = currentsize (s_def); on cleanup begin; if ocu_datap ^= null then do; if temp_segs (1) ^= null then call release_temp_segments_ ("ocu_", temp_segs, 0); call release_temp_segment_ ("ocu_", ocu_datap, 0); end; A_ocu_datap = null; end; /* get the ocu_data temp seg */ call get_temp_segment_ ("ocu_", ocu_datap, ec); if ec ^= 0 then call exit (ec); /* get the temp segs for the extensible structures */ call get_temp_segments_ ("ocu_", temp_segs, ec); if ec ^= 0 then call exit (ec); /* now set up the rest of the ocu_data structure */ ocu_data.version = ocu_data_version_1; string (ocu_data.flags) = ""b; ocu_data.target.dir = A_dir_name; ocu_data.target.entry = A_entry_name; ocu_data.msf_info.component_count = 0; ocu_data.msf_info.my_component = 0; if (A_flags & OPEN_FLAGS_BOUND) then ocu_data.flags.bound = true; if A_flags & OPEN_FLAGS_RELOCATABLE then ocu_data.flags.relocatable = true; if A_flags & OPEN_FLAGS_PROCEDURE then ocu_data.flags.procedure = true; if A_flags & OPEN_FLAGS_SEPARATE_STATIC then ocu_data.flags.separate_static = true; if A_flags & OPEN_FLAGS_PERPROCESS_STATIC then ocu_data.flags.perprocess_static = true; if A_flags & OPEN_FLAGS_NO_HASHTABLE then ocu_data.flags.no_hash_table = true; /* the variables determining the sizes of the extensible structures */ /* are assumed to be zero since they are in temp-segs which should */ /* be zero length when received. */ /* set the returned parameter */ A_ocu_datap = ocu_datap; call exit (0); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ close: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$close */ /*** Input: ocu_datap */ /*** Function: closes the ocu_ invocation and creates the actual */ /*** object segment from the tables created. */ /*** Output: code */ /*** */ /*** ****************************************************************/ /* check out the pointer we received */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call exit (error_table_$unimplemented_version); /* arrange to cleanup if this is interrupted */ ocu_data.target.acinfop = null; reloc_infop = null; /* perform a few consistency checks before building the object */ on cleanup begin; if ocu_datap ^= null then if ocu_data.target.acinfop ^= null then call tssi_$clean_up_segment (ocu_data.target.acinfop); if reloc_infop ^= null then call release_temp_segment_ ("ocu_", reloc_infop, 0); end; /* create/truncate the target object segment */ call tssi_$get_segment (ocu_data.target.dir, ocu_data.target.entry, ocu_data.target.segp, ocu_data.target.acinfop, ec); if ec ^= 0 then call exit (ec); /* allocate a temp_seg for the relocation blocks */ call get_temp_segment_ ("ocu_", reloc_infop, ec); reloc_infop -> relinfo_blocks.no_relinfo = ^ocu_data.flags.relocatable; /* create each section of the object segment */ call create_text (ocu_datap, reloc_infop); call create_defs (ocu_datap, reloc_infop); call create_link (ocu_datap, reloc_infop); call create_stat (ocu_datap); call create_symb (ocu_datap, reloc_infop); call create_obj_map (ocu_datap); /* release the relocation_info temp seg */ call release_temp_segment_ ("ocu_", reloc_infop, ec); reloc_infop = null; /* determine what ACL mode should be on the resulting object */ if ocu_data.flags.procedure then mode = RE_ACCESS; else mode = RW_ACCESS; /* and finish off the object segment */ call tssi_$finish_segment (ocu_data.target.segp, ocu_data.target.bc, mode, ocu_data.target.acinfop, ec); /* now release the storage */ call release (ocu_datap); A_ocu_datap = null; call exit (ec); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ release: entry (A_ocu_datap); /** ocu_data pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$release */ /*** Input: ocu_datap */ /*** Function: frees the storage associated with an open ocu_ */ /*** invocation. This entry is provided for use by */ /*** cleanup handlers. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* release the temp segs for the extensible structures, and then */ /* the ocu_data structure itself. */ ocu_datap = A_ocu_datap; if ocu_datap ^= null then do; if ocu_data_ptrs.temp_segs (1) ^= null then call release_temp_segments_ ("ocu_", ocu_data_ptrs.temp_segs, 0); call release_temp_segment_ ("ocu_", ocu_datap, 0); end; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_text: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_wordp, /** word array ptr (in ) */ A_relocationp, /** relocation string (in ) */ A_word_count) /** word count (in ) */ returns (fixed bin (18) uns); /** text relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_text */ /*** Input: ocu_datap, wordp, relocationp, word_count */ /*** Function: appends a block of words to the text section of */ /*** the object segment. Relocation info is also */ /*** appended for use in relocating linkage section */ /*** references. If the object segment being created */ /*** is not relocatable, the relocation information */ /*** will not be placed into the final object segment. */ /*** Output: text_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we received */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get the pointers to the structures to be used */ tip = ocu_data.text_infop; /* set up the word array and relocation string */ word_arrayp = A_wordp; word_arrayl = A_word_count; reloc_strp = A_relocationp; reloc_strl = A_word_count * 2; /* get the info for the text section relocation info string */ relinfo_strp = ocu_data.text_relinfop; relinfo_strl = ti.text_relinfol + reloc_strl; /* save the relpointer to the new text */ relp = ti.N_text_words; /* copy the text words into the text section table */ next_word = ti.N_text_words + 1; ti.N_text_words = ti.N_text_words + A_word_count; text_arrayp = addr (ti.text_word (next_word)); unspec (text_arrayp -> word_array) = unspec (word_array); /* append the relinfo string to the text section relinfo string */ substr (relinfo_str, ti.text_relinfol + 1, reloc_strl) = translate (reloc_str, STD_RELINFO, ALM_RELINFO); ti.text_relinfol = relinfo_strl; return (relp); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_definition: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_name, /** definition name (in ) */ A_section, /** target section (in ) */ A_offset, /** offset in section (in ) */ A_flags) /** definition flags (in ) */ returns (fixed bin (18) uns); /** definition relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_definition */ /*** Input: ocu_datap, name, section, offset, flags */ /*** Function: appends a single non-class-3 definition to the */ /*** definition list. If the definition target is in */ /*** the static section, and we are combining the */ /*** static and linkage sections, then convert the */ /*** static reference to a linkage reference. */ /*** Output: definition_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we received */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the definition list structure */ dip = ocu_data.def_infop; /* make sure this call is preceeded by a call to ocu_$emit_definition */ if di.N_defs = 0 then call sub_err_ (error_table_$out_of_sequence, "sequence", ACTION_CANT_RESTART, null, 0, "^/ocu_$emit_segname must be called " || "before calling ocu_$emit_definition"); /* increment the number of definitions */ di.N_defs = di.N_defs + 1; dep = addr (di.def (di.N_defs)); /* set up the definition, and add the name to the stringmap, if not */ /* already present. */ de.strx = find_string (ocu_datap, rtrim (A_name)); de.class = A_section; de.offset = A_offset; string (de.flags) = ""b; if A_flags & DEFINITION_FLAGS_IGNORE then de.flags.ignore = true; if A_flags & DEFINITION_FLAGS_ENTRY then de.flags.entry = true; if A_flags & DEFINITION_FLAGS_RETAIN then de.flags.retain = true; if A_flags & DEFINITION_FLAGS_INDIRECT then de.flags.indirect = true; de.dup_tbl_relp = 0; /* return calculated definition offset */ return (dh_size + ((di.N_defs - 1) * def_size)); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_segname: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_name, /** segname (in ) */ A_flags) /** definition flags (in ) */ returns (fixed bin (18) uns); /** definition relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_segname */ /*** Input: ocu_datap, name, flags */ /*** Function: emits a single class-3 segname definition. */ /*** Output: definition_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we received */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the definition list structure */ dip = ocu_data.def_infop; /* make sure this is not a duplicate segname */ strx = find_string (ocu_datap, rtrim (A_name)); do defx = 1 to di.N_defs; if di.def (defx).class = 3 & di.def (defx).strx = strx then call sub_err_ (error_table_$namedup, "argument", ACTION_CANT_RESTART, null, 0, "^/There is already a segname definition ""^a""", A_name); end; /* increment the number of definitions */ di.N_defs = di.N_defs + 1; /* create the segname, and add the name to the stringmap if not */ /* already present. */ dep = addr (di.def (defx)); de.strx = strx; de.class = 3; de.offset = 0; de.dup_tbl_relp = 0; string (de.flags) = ""b; if A_flags & DEFINITION_FLAGS_IGNORE then de.flags.ignore = true; if A_flags & DEFINITION_FLAGS_ENTRY then de.flags.entry = true; if A_flags & DEFINITION_FLAGS_RETAIN then de.flags.retain = true; if (A_flags & DEFINITION_FLAGS_INDIRECT) ^= ""b then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CAN_RESTART, null, 0, "^/Segname definitions may not be indirect."); /* return the calculated definition relpointer */ return (dh_size + ((defx - 1) * def_size)); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_msf_map: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_component_count, /** no. of components (in ) */ A_my_component); /** this component no (in ) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_msf_map */ /*** Input: ocu_datap, component_count, my_component */ /*** Function: saves the values to be used for the msf_map in */ /*** the definition structure. */ /*** Output: code */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); if A_component_count <= 0 then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/The number of components in an object MSF must be positive." ); if (A_my_component < 0) | (A_my_component > A_component_count) then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/The component number must be in the range " || "0 .. component_count."); /* store the count and component number in ocu_data */ ocu_data.component_count = A_component_count; ocu_data.my_component = A_my_component; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_static: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_wordp, /** static word array (in ) */ A_word_count) /** size of word array (in ) */ returns (fixed bin (18) uns); /** static relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_static */ /*** Input: ocu_datap, wordp, word_count */ /*** Function: adds a block of words to the static section. */ /*** Output: static_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the static section info structure */ sip = ocu_data.static_infop; /* set up the input word array */ word_arrayp = A_wordp; word_arrayl = A_word_count; /* determine the return relpointer offset */ relp = si.N_static_words; /* copy the word array into the static info structure */ next_word = si.N_static_words + 1; si.N_static_words = si.N_static_words + A_word_count; static_arrayp = addr (si.static_word (next_word)); unspec (static_arrayp -> word_array) = unspec (word_array); return (relp); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_link: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_type, /** link type (in ) */ A_class, /** link class (in ) */ A_segname, /** target segment (in ) */ A_offsetname, /** target definition (in ) */ A_expression, /** word offset (in ) */ A_modifier, /** link modifier (in ) */ A_init_infop) /** initialization (in ) */ returns (fixed bin (18) uns); /** link relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_link */ /*** Input: ocu_datap, type, class, segname, offsetname, */ /*** expression, modifier, init_infop */ /*** Function: emits a single external link. The link relpointer */ /*** returned is calculated as if the static section */ /*** is separate. If the static section is internal */ /*** to the linkage section, references to the linkage */ /*** section in the text, symbol, and definition */ /*** sections will be relocated to the actual location */ /*** of the link. */ /*** Output: link_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the link array structure */ lip = ocu_data.link_infop; /* locate/create the expression_word, type_pair, strings, etc. */ unspec (linke) = ""b; linke.modifier = A_modifier; linke.exp_wordx = find_exp_word (ocu_datap, A_expression, A_type, A_class, A_segname, A_offsetname, A_init_infop); /* search for a link with the same expression_word and modifier. If */ /* found, return a relpointer to that link. */ do linkx = 1 to li.N_links; if unspec (li.link (linkx)) = unspec (linke) then return (vlh_size + (lk_size * (linkx - 1))); end; /* if not found, create a new link */ linkx, li.N_links = li.N_links + 1; unspec (li.link (linkx)) = unspec (linke); /* return the relpointer to the new link */ return (vlh_size + (lk_size * (linkx - 1))); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_partial_link: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_component, /** target component (in ) */ A_section, /** target section (in ) */ A_offset, /** offset in section (in ) */ A_modifier) /** link modifier (in ) */ returns (fixed bin (18) uns); /** link relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_partial_link */ /*** Input: ocu_datap, component, section, offset, modifier */ /*** Function: emits a single partially snapped link in the */ /*** linkage section of the new object. */ /*** Output: link_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the link array structure */ lip = ocu_data.link_infop; linke.exp_wordx = 0; linke.type = A_section; linke.component = A_component; linke.offset = A_offset; linke.modifier = A_modifier; /* look for an identical partial link and use it if one exists */ do linkx = 1 to li.N_links; if unspec (li.link (linkx)) = unspec (linke) then return (vlh_size + (lk_size * (linkx - 1))); end; /* if no matching link is found, generate a new link */ linkx, li.N_links = li.N_links + 1; unspec (li.link (linkx)) = unspec (linke); /* return a relpointer to the new partial link */ return (vlh_size + (lk_size * (linkx - 1))); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_firstref_trap: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_call_relp, /** relp to call link (in ) */ A_info_relp); /** relp to info link (in ) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_firtstref_trap */ /*** Input: ocu_datap, call_relp, info_relp */ /*** Function: adds a first reference trap to the firstref trap */ /*** block to be placed into the linkage section. If */ /*** no firstref traps are emitted, no trap block is */ /*** placed in the linkage section. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the firstref trap array */ frtip = ocu_data.firstref_trap_infop; /* increment the number of traps */ frti.N_traps = frti.N_traps + 1; /* copy the relpointers into the trap array */ frti.trap (frti.N_traps).call_relp = A_call_relp; frti.trap (frti.N_traps).info_relp = A_info_relp; return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ emit_symbol: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_wordp, /** symbol word array (in ) */ A_relocationp, /** relocation string (in ) */ A_word_count) /** word count (in ) */ returns (fixed bin (18) uns); /** symbol relp (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$emit_symbol */ /*** Input: ocu_datap, wordp, relocationp, word_count */ /*** Function: emits a block of symbol section words and their */ /*** associated relocation information. Note that */ /*** while the relocation information is located in */ /*** the symbol section, it should not be emitted */ /*** by the caller. It will be synthesized by ocu_ */ /*** and placed at the end of the symbol section. */ /*** Note also that ocu_ assumes the first thing in */ /*** the symbol section is a std_symbol_header */ /*** structure into which the relocation offsets will */ /*** patched when the object segment is assembled. */ /*** Output: symbol_relp */ /*** */ /*** ****************************************************************/ /* check out the pointer we were passed */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* get a pointer to the symbol section info structure */ sbip = ocu_data.symbol_infop; /* set up the input word array and relocation string */ word_arrayp = A_wordp; word_arrayl = A_word_count; reloc_strp = A_relocationp; reloc_strl = A_word_count * 2; /* set up the symbol section relocation string */ relinfo_strp = ocu_data.symbol_relinfop; relinfo_strl = sbi.symbol_relinfol + reloc_strl; /* determine the return value */ relp = sbi.N_symbol_words; /* copy the word array into the symbol section */ next_word = sbi.N_symbol_words + 1; sbi.N_symbol_words = sbi.N_symbol_words + A_word_count; symbol_arrayp = addr (sbi.symbol_word (next_word)); unspec (symbol_arrayp -> word_array) = unspec (word_array); /* append the relocation sting to the symbol section relocation string */ substr (relinfo_str, sbi.symbol_relinfol + 1, reloc_strl) = translate (reloc_str, STD_RELINFO, ALM_RELINFO); sbi.symbol_relinfol = relinfo_strl; return (relp); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ backpatch: entry (A_ocu_datap, /** ocu_data pointer (in ) */ A_patch_section, /** section to patch (in ) */ A_offset, /** word to patch (in ) */ A_side, /** halfword to patch (in ) */ A_new_value); /** value to patch in (in ) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$backpatch */ /*** Input: ocu_datap, patch_section, offset, side, value */ /*** Function: allows specific halfwords withing the text and */ /*** symbol sections to be patched. This is to allow */ /*** changes to be made after the section has been */ /*** emitted to install values unknown at that time. */ /*** Halfwords can be patched as signed or unsigned */ /*** 15 or 18 bit values. Note that the use of 15 */ /*** bit patching is restricted to the left halfword */ /*** of text section references. This reflects the */ /*** restriction on use of 15 bit relocation info. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* check out the pointer we received */ ocu_datap = A_ocu_datap; if ocu_data.version ^= ocu_data_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0); /* make sure the offset is positive */ if A_offset < 0 then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Negative word offset is invalid."); /* NB: The pl1 prefix (size): is used to determine whether the */ /* value given is suitable for the type of patching being done */ /* since overlays are used with appropriate precision and sign */ /* the parameter is declared fixed bin (35) and we let PL/I */ /* figure out whether this is legitimate or not. */ on size call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Invalid value specified for halfword."); /* determine which section is being patched */ if A_patch_section = "text" then do; /* patching text section: make sure the word offset is OK. */ tip = ocu_data.text_infop; if A_offset >= ti.N_text_words then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Specified offset is not within the text section."); wordp = addr (ti.text_word (A_offset + 1)); /* enable size checking and asign to an appropriate overlay */ /* based on the side specification given. */ (size): if A_side = "left 15 unsigned" then w15.left = A_new_value; else if A_side = "left 15 signed" then w15s.left = A_new_value; else if A_side = "left 18 unsigned" then w18.left = A_new_value; else if A_side = "left 18 signed" then w18s.left = A_new_value; else if A_side = "right 18 unsigned" then w18.right = A_new_value; else if A_side = "right 18 signed" then w18s.right = A_new_value; else call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Invalid text section side specification."); (nosize): end; else if A_patch_section = "symbol" then do; /* symbol section: Make sure the offset is in the section */ sbip = ocu_data.symbol_infop; if A_offset >= sbi.N_symbol_words then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Specified offset is not within the symbol section."); wordp = addr (sbi.symbol_word (A_offset + 1)); /* enable size checking and assign to the appropriate overlay */ (size): if A_side = "left 18 unsigned" then w18.left = A_new_value; else if A_side = "left 18 signed" then w18s.left = A_new_value; else if A_side = "right 18 unsigned" then w18.right = A_new_value; else if A_side = "right 18 signed" then w18s.right = A_new_value; else call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Invalid symbol section side specification."); (nosize): end; else if A_patch_section = "static" then do; /* static section: make sure the offset is in the section */ sip = ocu_data.static_infop; if A_offset >= si.N_static_words then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Specified offset is not within the static section."); wordp = addr (si.static_word (A_offset + 1)); /* enable size checking and assign to the appropriate overlay */ (size): if A_side = "left 18 unsigned" then w18.left = A_new_value; else if A_side = "left 18 signed" then w18s.left = A_new_value; else if A_side = "right 18 unsigned" then w18.right = A_new_value; else if A_side = "right 18 signed" then w18s.right = A_new_value; else call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Invalid static section side specification."); (nosize): end; /* unknown section */ else call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/Invalid section specification."); return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_msf: entry (A_component_listp, /** component array (in ) */ A_component_count, /** component count (in ) */ A_generator_infop, /** generator info (in ) */ A_code); /** error code (out) */ /*** ****************************************************************/ /*** */ /*** Name: ocu_$create_msf */ /*** Input: component_listp, component_count */ /*** Function: This entrypoint is used to construct component 0 */ /*** of an Object MSF. This involves creating */ /*** an object segment containing the definitions for */ /*** each accessible point in each of the other MSF */ /*** components, generating transfer vectors and */ /*** partial links in the internal static area and */ /*** link array of the linkage section (respectively) */ /*** and generating the first reference trap to cause */ /*** the snapping of partial links. Note that it */ /*** is NOT in this procedures contract to create the */ /*** actual Multi-Segment File. It will validate */ /*** that the segments to be used are all in the same */ /*** directory, have the appropriate names, have */ /*** msf_maps, and that there are no other segments */ /*** or directories in the containing directory */ /*** It will then create component 0 in the same */ /*** directory and set the bit count on the directory. */ /*** Output: code */ /*** */ /*** ****************************************************************/ /* get a temp_segment for out working structure */ mip = null; odp = null; on cleanup begin; if mip ^= null then call release_temp_segment_ ("ocu_", mip, 0); if odp ^= null then call release (odp); end; call get_temp_segment_ ("ocu_", mip, ec); /* copy the arguments into the working structure */ mi.containing_dir = ""; mi.gen_info = A_generator_infop -> gen_info; mi.N_components, component_count = A_component_count; component_listp = A_component_listp; /* make sure the segment pointers point to the base of the segment */ do c = 1 to component_count; mi.component (c).segp = ptr (component_list (c), 0); end; /* make sure all of the components are correct */ do c = 1 to component_count; call validate_component (mip, c); end; call open (mi.containing_dir, "0", OPEN_FLAGS_RELOCATABLE | OPEN_FLAGS_PROCEDURE | OPEN_FLAGS_BOUND, odp, ec); if ec ^= 0 then call exit (ec); /* emit the first reference trap and associated links */ call_relp = emit_link (odp, (LINK_REFNAME_OFFSETNAME), 0, "msf_prelink_", "msf_prelink_", 0, ""b, null); info_relp = emit_link (odp, (LINK_SELF_BASE), (SECTION_LINK), "", "", 0, ""b, null); call emit_firstref_trap (odp, call_relp, info_relp); /* emit the component 0 msf map */ call emit_msf_map (odp, component_count + 1, 0); /* copy the external definitions for each component */ do c = 1 to mi.N_components; call copy_defs (odp, mip, c); end; /* create the symbol section */ call mk_symbol_scn (odp, mip); /* close the ocu_ invocation to create component 0 */ call close (odp, ec); /* set the bit count on the MSF */ call expand_pathname_ (mi.containing_dir, dname, ename, ec); call hcs_$set_bc (dname, ename, mi.N_components + 1, ec); /* release the msf_info structure */ call release_temp_segment_ ("ocu_", mip, ec); call exit (ec); /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ exit: proc (ec); /** error code (in ) */ /*** ****************************************************************/ /*** */ /*** Name: exit */ /*** Input: ec */ /*** Function: returns from the object creation utilities */ /*** returning a specified error code. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl ec fixed bin (35) parameter; A_code = ec; /* do non-local goto to unwind stack and return from ocu_ */ goto EXIT; end exit; EXIT: return; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ find_exp_word: proc (odp, /** pointer to ocu_data (in ) */ exp, /** expression value (in ) */ type, /** link type (in ) */ class, /** link class (in ) */ segname, /** segname string (in ) */ offsetname, /** offsetname string (in ) */ init_infop) /** init_info pointer (in ) */ returns (fixed bin); /** exp_word index (out) */ /*** ****************************************************************/ /*** */ /*** Name: find_exp_word */ /*** Input: odp, exp, type, class, segname, offsetname, */ /*** init_infop */ /*** Function: looks for an expression_word matching the info */ /*** supplied and returns the index in the exp_word */ /*** table. If no matching expression_word exists, */ /*** it it created. */ /*** Output: exp_wordx */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl exp fixed bin parameter; dcl type fixed bin (3) parameter; dcl class fixed bin (3) parameter; dcl segname char (*) varying parameter; dcl offsetname char (*) varying parameter; dcl init_infop ptr parameter; /* based */ dcl 01 ewi aligned based (ewip), 02 header aligned like exp_word_info.header, 02 exp_wd dim (0 refer (ewi.N_exp_words)) like exp_word_entry; dcl 01 od aligned like ocu_data based (odp); /* automatic */ dcl ewip ptr automatic; dcl 01 expe aligned like exp_word_entry automatic; dcl expx fixed bin automatic; dcl type_pairx fixed bin automatic; /* get a pointer to the expression word array */ ewip = od.exp_word_infop; /* find/create the type pair referenced */ type_pairx = find_type_pair (odp, type, class, segname, offsetname, init_infop); /* see if a matching expression word exists and return the index */ /* if one is found */ expe.expression = exp; expe.type_pairx = type_pairx; expe.relp = 0; do expx = 1 to ewi.N_exp_words; if unspec (ewi.exp_wd (expx)) = unspec (expe) then return (expx); end; /* if not found, create a new expression word */ expx, ewi.N_exp_words = ewi.N_exp_words + 1; unspec (ewi.exp_wd (expx)) = unspec (expe); return (expx); end find_exp_word; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ find_type_pair: proc (odp, /** pointer to ocu_data (in ) */ type, /** link type (in ) */ class, /** link class (in ) */ segname, /** segname string (in ) */ offsetname, /** offsetname string (in ) */ init_infop) /** init info for link (in ) */ returns (fixed bin); /** type pair index (out) */ /*** ****************************************************************/ /*** */ /*** Name: find_type_pair */ /*** Input: odp, type, class, segname, offsetname, init_infop */ /*** Function: finds a type pair matching the given criteria. */ /*** If no such type pair exists, create one. */ /*** Output: type_pairx */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl type fixed bin (3) parameter; dcl class fixed bin (3) parameter; dcl segname char (*) varying parameter; dcl offsetname char (*) varying parameter; dcl init_infop ptr parameter; /* based */ dcl 01 od aligned like ocu_data based (odp); dcl 01 tpi aligned based (tpip), 02 header aligned like type_pair_info.header, 02 type_pr dim (0 refer (tpi.N_type_pairs)) like type_pair_entry; /* automatic */ dcl tpip ptr automatic; dcl 01 type_paire aligned like type_pair_entry automatic; dcl type_pairx fixed bin automatic; /* get a pointer to the type_pair array */ tpip = od.type_pair_infop; type_paire.type = type; /* encode the refname value, either as a string relpointer, if the */ /* link is a LINK_REFNAME_BASE or LINK_REFNAME_OFFSETNAME link, or */ /* as the class for a LINK_SELF_BASE or LINK_SELF_OFFSETNAME link. */ if type = LINK_REFNAME_BASE | type = LINK_REFNAME_OFFSETNAME then type_paire.segnamex = find_string (odp, segname); else type_paire.segnamex = class; /* store the offsetname value sting index. This is only valid for */ /* LINK_SELF_OFFSETNAME and LINK_REFNAME_OFFSETNAME links. */ if type = LINK_SELF_OFFSETNAME | type = LINK_REFNAME_OFFSETNAME then type_paire.offsetnamex = find_string (odp, offsetname); else type_paire.offsetnamex = 0; /* if we have an init_info pointer, determine whether this is init */ /* info or a trap pair and generate the appropriate structure. */ if init_infop ^= null then if type = LINK_SELF_OFFSETNAME then type_paire.init_infox = find_init_info (odp, init_infop); else type_paire.init_infox = find_trap_pair (odp, init_infop); else type_paire.init_infox = 0; type_paire.relp = 0; /* now that we have filled in all the fields, try to find a type */ /* pair that matches this description. Return the index if found */ do type_pairx = 1 to tpi.N_type_pairs; if unspec (tpi.type_pr (type_pairx)) = unspec (type_paire) then return (type_pairx); end; /* if not generate a new type pair and fill in the values */ type_pairx, tpi.N_type_pairs = tpi.N_type_pairs + 1; unspec (tpi.type_pr (type_pairx)) = unspec (type_paire); return (type_pairx); end find_type_pair; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ find_init_info: proc (odp, /** pointer to ocu_data (in ) */ init_infop) /** init info pointer (in ) */ returns (fixed bin); /** init table index (out) */ /*** ****************************************************************/ /*** */ /*** Name: find_init_info */ /*** Input: odp, init_infop */ /*** Function: locates an init_info block matching the block */ /*** specified. If one does not exist, it is created. */ /*** Output: init_infox */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl init_infop ptr parameter; /* based */ dcl 01 ii aligned based (iip), 02 header aligned like init_info.header, 02 init dim (0 refer (ii.N_inits)) like init_entry; dcl 01 in_init aligned like link_init based (init_infop); dcl 01 in_init_copy aligned based (init_infop), 02 header aligned like link_init_copy_info.header, 02 initial_data dim (0 refer (in_init_copy.n_words)) bit (36); dcl 01 in_init_deferred aligned like link_init_deferred based (init_infop); dcl 01 in_init_template aligned based (init_infop), 02 full_header aligned like init_list_template.full_header, 02 template dim (0 refer (in_init_template.n_words_in_list)) bit (36); dcl init_str char (init_len) based (init_infop); dcl 01 od aligned like ocu_data based (odp); dcl 01 st_init aligned like link_init based (stored_initp); dcl 01 st_init_copy aligned based (stored_initp), 02 header aligned like link_init_copy_info.header, 02 initial_data dim (0 refer (st_init_copy.n_words)) bit (36); dcl 01 st_init_deferred aligned like link_init_deferred based (stored_initp); dcl 01 st_init_template aligned based (stored_initp), 02 full_header aligned like init_list_template.full_header, 02 template dim (0 refer (st_init_template.n_words_in_list)) bit (36); dcl stored_str char (stored_len) based (stored_initp); /* automatic */ dcl iip ptr automatic; dcl init_infox fixed bin automatic; dcl init_len fixed bin (21) automatic; dcl len fixed bin (18) automatic; dcl stored_initp ptr automatic; dcl stored_len fixed bin (21) automatic; /* get a pointer to the init_info array */ iip = od.init_infop; /* first try to find an existing init_info matching the given one */ do init_infox = 1 to ii.N_inits; /* get a pointer to the current existing init_info */ stored_initp = addwordno (od.init_segp, ii.init (init_infox).start); /* figure out the lengths of the stored and given init infos and */ /* compare them by overlaying character strings */ if (st_init.n_words = in_init.n_words) & (st_init.type = in_init.type) then do; stored_len = ii.init (init_infox).length * 4; init_len = currentsize (in_init) * 4; if in_init.type = INIT_DEFERRED then init_len = currentsize (in_init_deferred) * 4; else if in_init.type = INIT_LIST_TEMPLATE then init_len = currentsize (in_init_template) * 4; else if in_init.type = INIT_COPY_INFO then init_len = currentsize (in_init_copy) * 4; if init_len = stored_len then if stored_str = init_str then return (init_infox); end; end; /* no matching init_info exists. Now we create one */ stored_initp = addwordno (od.init_segp, ii.init_segl); init_infox, ii.N_inits = ii.N_inits + 1; ii.init (init_infox).start = ii.init_segl; /* copy the init_info depending on the type */ if in_init.type = INIT_LIST_TEMPLATE then do; st_init_template.n_words = in_init_template.n_words; st_init_template.type = in_init_template.type; st_init_template.n_words_in_list = in_init_template.n_words_in_list; st_init_template.template (*) = in_init_template.template (*); len = currentsize (in_init_template); end; else if in_init.type = INIT_COPY_INFO then do; st_init_copy.n_words = in_init_copy.n_words; st_init_copy.type = in_init_copy.type; st_init_copy.initial_data (*) = in_init_copy.initial_data (*); len = currentsize (in_init_copy); end; else if in_init.type = INIT_DEFERRED then do; st_init_deferred.n_words = in_init_deferred.n_words; st_init_deferred.type = in_init_deferred.type; st_init_deferred.target_relp = in_init_deferred.target_relp; st_init_deferred.link_relp = in_init_deferred.link_relp; len = currentsize (in_init_deferred); end; else do; st_init.n_words = in_init.n_words; st_init.type = in_init.type; len = currentsize (in_init); end; /* adjust the size of the init_info seg and the array entry */ ii.init (init_infox).length = len; ii.init_segl = ii.init_segl + len; return (init_infox); end find_init_info; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ find_trap_pair: proc (odp, /** pointer to ocu_data (in ) */ trapp) /** trap-pair block ptr (in ) */ returns (fixed bin); /** trap_pair index (out) */ /*** ****************************************************************/ /*** */ /*** Name: find_trap_pair */ /*** Input: odp, trapp */ /*** Function: finds a trap pair matching the one given. If no */ /*** such trap_pair exists, it is created and the */ /*** index returned. */ /*** Output: trap_pairx */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl trapp ptr parameter; /* based */ dcl 01 od aligned like ocu_data based (odp); dcl 01 trap aligned like link_trap_pair based (trapp); dcl 01 trpi aligned based (trpip), 02 header aligned like trap_pair_info.header, 02 trap_pair dim (0 refer (trpi.N_trap_pairs)) like trap_pair_entry; /* automatic */ dcl trap_pairx fixed bin automatic; dcl trpip ptr automatic; /* get a pointer to the trap_pair array */ trpip = od.trap_pair_infop; /* look for a matching existing trap pair and return the index if found */ do trap_pairx = 1 to trpi.N_trap_pairs; if (trpi.trap_pair (trap_pairx).call_relp = trap.call_relp) & (trpi.trap_pair (trap_pairx).info_relp = trap.info_relp) then return (trap_pairx); end; /* if not found, create the new trap_pair */ trap_pairx, trpi.N_trap_pairs = trpi.N_trap_pairs + 1; trpi.trap_pair (trap_pairx).call_relp = trap.call_relp; trpi.trap_pair (trap_pairx).info_relp = trap.info_relp; return (trap_pairx); end find_trap_pair; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ find_string: proc (odp, /** pointer to ocu_data (in ) */ string) /** string to find (in ) */ returns (fixed bin); /** stringmap index (out) */ /*** ****************************************************************/ /*** */ /*** Name: find_string */ /*** Input: odp, string */ /*** Function: adds the string given to the definition stringmap */ /*** and returns the stringmap entry index. If the */ /*** string already exists in the stringmap, the index */ /*** of the existing entry is returned. */ /*** Output: stringmap_index */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl string char (*) varying parameter; /* based */ dcl 01 od aligned like ocu_data based (odp); dcl 01 sme aligned like string_map_entry based (smep); dcl 01 smi aligned based (smip), 02 header aligned like string_map_info.header, 02 string dim (0 refer (smi.N_strings)) like string_map_entry; /* automatic */ dcl smep ptr automatic; dcl smip ptr automatic; dcl stringmapx fixed bin automatic; /* builtin */ dcl length builtin; /* get pointers to the string_map and string text segment */ smip = od.string_map_infop; text_segp = od.string_segp; text_segl = smi.string_segl; /* first try to locate the string in the stringmap */ do stringmapx = 1 to smi.N_strings; smep = addr (smi.string (stringmapx)); if string = substr (text_seg, sme.start_offset, sme.length) then return (stringmapx); end; /* if it isn't there, then we have to add it. */ stringmapx, smi.N_strings = smi.N_strings + 1; /* create the stringmap entry */ smep = addr (smi.string (stringmapx)); sme.start_offset = text_segl + 1; sme.length = length (string); /* add the actual string to the text segment */ text_segl, smi.string_segl = text_segl + sme.length; substr (text_seg, sme.start_offset, sme.length) = string; /* return the stringmap offset */ return (stringmapx); end find_string; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_text: proc (odp, /** pointer to ocu_data (in ) */ reloc_infop); /** ptr to relinfo blk (out) */ /*** ****************************************************************/ /*** */ /*** Name: create_text */ /*** Input: odp, reloc_infop */ /*** Function: copies the text section from the intermediate */ /*** into the object segment. Any references to the */ /*** section are relocated to take static section size */ /*** into account if the static section is in the */ /*** linkage section, and static relocation codes */ /*** converted to linkage relocation. */ /*** Output: reloc_infop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl reloc_infop ptr parameter; /* based */ dcl 01 od aligned like ocu_data based (odp); dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); dcl 01 ti aligned based (tip), 02 header aligned like text_info.header, 02 text_word dim (0 refer (ti.N_text_words)) bit (36); /* automatic */ dcl abs_count fixed bin automatic; /* get pointers to the required data structures */ tip = od.text_infop; sip = od.static_infop; /* initialize the relocation info generation stuff */ abs_count = 0; /* copy each word into the actual text section */ call install_words (addr (ti.text_word), od.text_relinfop, ti.N_text_words, si.N_static_words, reloc_infop, Rel_text, (ocu_data.target.segp), abs_count); /* force the segment onto a doubleword boundary */ if mod (ti.N_text_words, 2) ^= 0 then do; call append_relinfo (reloc_infop, Rel_text, "aa", abs_count); od.lengths.text = ti.N_text_words + 1; end; else od.lengths.text = ti.N_text_words; /* force any remaining absolute relinfo into the block */ call append_relinfo (reloc_infop, Rel_text, " ", abs_count); /* save the segment bit_count */ od.target.bc = od.lengths.text * 36; end create_text; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_defs: proc (odp, /** pointer to ocu_data (in ) */ reloc_infop); /** pointer to relinfo (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: create_defs */ /*** Input: odp, reloc_infop */ /*** Function: creates the definition section of the object */ /*** segment. This is done is a set of discrete steps */ /*** - creation of the definition header */ /*** - installation of the definition list */ /*** - installation of the stringmap */ /*** - rescan of the def list to patch in stringmap */ /*** relpointers */ /*** - threading of the definition list */ /*** - installation of the init_infos */ /*** - installation of the trap_pairs */ /*** - installation of the type_pairs */ /*** - installation of the expression_words */ /*** - installation of the msf_map */ /*** - creation of the definiiton hash_table */ /*** Output: reloc_infop */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl reloc_infop ptr parameter; /* based */ dcl 01 acc aligned based (accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (acc.count)) unaligned; dcl 01 defn aligned like definition based (defnp); dcl 01 dh aligned like definition_header based (dhp); dcl 01 di aligned based (dip), 02 header aligned like def_info.header, 02 def dim (0 refer (di.N_defs)) like def_entry; dcl 01 ewi aligned based (ewip), 02 header aligned like exp_word_info.header, 02 exp_wd dim (0 refer (ewi.N_exp_words)) like exp_word_entry; dcl 01 expr aligned like exp_word based (exprp); dcl 01 ii aligned based (iip), 02 header aligned like init_info.header, 02 init dim (0 refer (ii.N_inits)) like init_entry; dcl 01 lte aligned based (ltep), 02 header aligned like template_entry.header, 02 datum bit (0 refer (lte.n_bits)); dcl 01 mm aligned like msf_map based (mmp); dcl new_init_str char (init_strl) based (new_init_strp); dcl 01 new_type_pair aligned like type_pair based (new_type_pairp); dcl obj_init_str char (init_strl) based (obj_init_strp); dcl 01 od aligned like ocu_data based (odp); dcl 01 pit aligned like pointer_init_template based (pitp); dcl 01 prev_sn aligned like segname_definition based (prev_snp); dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); dcl 01 smi aligned based (smip), 02 header aligned like string_map_info.header, 02 string dim (0 refer (smi.N_strings)) like string_map_entry; dcl 01 sn aligned like segname_definition based (snp); dcl 01 tpi aligned based (tpip), 02 header aligned like type_pair_info.header, 02 type_pr dim (0 refer (tpi.N_type_pairs)) like type_pair_entry; dcl 01 trap_pr aligned like link_trap_pair based (trap_prp); dcl 01 trpi aligned based (trpip), 02 header aligned like trap_pair_info.header, 02 trap_pair dim (0 refer (trpi.N_trap_pairs)) like trap_pair_entry; dcl word bit (36) aligned based (wordp); /* automatic */ dcl abs_count fixed bin automatic; dcl acc_relp fixed bin (18) unsigned automatic; dcl accp ptr automatic; dcl backward_relp fixed bin (18) unsigned automatic; dcl block_relp fixed bin (18) unsigned automatic; dcl def_relp fixed bin (18) unsigned automatic; dcl defnp ptr automatic; dcl dhp ptr automatic; dcl dip ptr automatic; dcl ewip ptr automatic; dcl exprp ptr automatic; dcl forward_relp fixed bin (18) unsigned automatic; dcl iip ptr automatic; dcl init_segp ptr automatic; dcl init_segl fixed bin (18) automatic; dcl init_strl fixed bin (21) automatic; dcl ltep ptr automatic; dcl n_words fixed bin (18) automatic; dcl new_block bit (1) automatic; dcl new_init_strp ptr automatic; dcl new_type_pairp ptr automatic; dcl obj_init_strp ptr automatic; dcl pitp ptr automatic; dcl prev_snp ptr automatic; dcl relchrs char (10) varying automatic; dcl relpair char (2) varying automatic; dcl set_first bit (1) automatic; dcl sip ptr automatic; dcl smip ptr automatic; dcl snp ptr automatic; dcl tpip ptr automatic; dcl tpx fixed bin automatic; dcl trap_prp ptr automatic; dcl trpip ptr automatic; dcl mmp ptr automatic; dcl wordp ptr automatic; dcl zero_relp fixed bin (18) unsigned automatic; /* builtin */ dcl string builtin; /* set up the structures to be used */ dip = od.def_infop; smip = od.string_map_infop; iip = od.init_infop; trpip = od.trap_pair_infop; tpip = od.type_pair_infop; ewip = od.exp_word_infop; sip = od.static_infop; /* initialize the relocation generation variables */ abs_count = 0; /* create the defintion_header */ dhp = addwordno (od.target.segp, od.target.bc / 36); dh.def_list_relp = currentsize (dh); string (dh.flags) = ""b; dh.flags.new = true; dh.flags.ignore = true; od.lengths.defs = currentsize (dh); /* generate the definition header relinfo */ if ocu_data.msf_info.component_count > 0 then call append_relinfo (reloc_infop, Rel_defs, "dd", abs_count); else call append_relinfo (reloc_infop, Rel_defs, "da", abs_count); if ocu_data.flags.no_hash_table then call append_relinfo (reloc_infop, Rel_defs, "aa", abs_count); else call append_relinfo (reloc_infop, Rel_defs, "da", abs_count); /* create the definition list */ defnp = addwordno (dhp, dh.def_list_relp); zero_relp = currentsize (dh) + N_defs * currentsize (defn); backward_relp = zero_relp; forward_relp = dh.def_list_relp + currentsize (defn); do i = 1 to di.N_defs; /* set up the basic threading */ defn.forward_relp = forward_relp; defn.backward_relp = backward_relp; /* adjust the thread values for the next definition */ backward_relp = forward_relp - currentsize (defn); forward_relp = forward_relp + currentsize (defn); /* adjust the section size */ od.lengths.defs = od.lengths.defs + currentsize (defn); /* set the values for the definition */ defn.class = di.def (i).class; string (defn.flags) = ""b; defn.flags.new = true; defn.flags.ignore = di.def (i).flags.ignore; defn.flags.entry = di.def (i).flags.entry; defn.flags.retain = di.def (i).flags.retain; defn.flags.indirect = di.def (i).flags.indirect; defn.name_relp = di.def (i).strx; /* set up the relocation info */ if di.def (i).class = 3 then call append_relinfo (reloc_infop, Rel_defs, "dddadd", abs_count); else do; /* set the thing relpointer */ defn.thing_relp = di.def (i).offset; /* extract the relocation info and relocate link references */ relpair = class_relinfo (di.def (i).class) || "a"; wordp = addr (defn.thing_relp); call relocate_link_ref (word, relpair, si.N_static_words); /* if the reference is to the static section and we have */ /* combined static, then convert the definition class to link */ if (relpair = "ia" | relpair = "8a") & ^od.flags.separate_static then defn.class = CLASS_LINKAGE; /* append the relinfo to the relinfo block */ relchrs = "dd" || relpair || "dd"; call append_relinfo (reloc_infop, Rel_defs, relchrs, abs_count); end; defnp = addwordno (defnp, currentsize (defn)); end; /* leave space for the zero word */ od.lengths.defs = od.lengths.defs + 1; text_segp = od.string_segp; text_segl = smi.string_segl; call append_relinfo (reloc_infop, Rel_defs, "aa", abs_count); /* create the stringmap */ acc_relp = od.lengths.defs; do i = 1 to smi.N_strings; /* copy the count and string into the object segment */ accp = addwordno (dhp, acc_relp); acc.count = smi.string (i).length; acc.string = substr (text_seg, smi.string (i).start_offset, smi.string (i).length); smi.string (i).relp = acc_relp; /* determine how big this thing is */ n_words = currentsize (acc); /* synthesize the relinfo */ call append_relinfo (reloc_infop, Rel_defs, copy ("a", n_words + n_words), abs_count); acc_relp = acc_relp + n_words; /* adjust the section length */ od.lengths.defs = od.lengths.defs + n_words; end; /* backpatch the stringmap relpointers into the definition list */ defnp = addwordno (dhp, dh.def_list_relp); do i = 1 to di.N_defs; defn.name_relp = smi.string (defn.name_relp).relp; defnp = addwordno (dhp, defn.forward_relp); end; /* now thread the definition list */ /* first make a pass setting the segname_relp values for each */ /* non-type-3 definition to point back to the first type-3 def in */ /* the block. */ block_relp = 0; new_block = true; def_relp = dh.def_list_relp; defnp = addwordno (dhp, def_relp); do while ((defn.forward_relp ^= 0) | (defn.backward_relp ^= 0)); /* if this is the first type 3 in the block, remember the relp */ if (defn.class = 3) & new_block then block_relp = def_relp; /* if this is not type 3, then set the segname relp */ else if defn.class ^= 3 then do; defn.segname_relp = block_relp; new_block = true; end; /* go to the next definition */ def_relp = defn.forward_relp; defnp = addwordno (dhp, def_relp); end; /* now we make another pass, setting the first_relp and */ /* next_segname_relp values in each type-3 definition. */ def_relp = dh.def_list_relp; snp = addwordno (dhp, def_relp); prev_snp = null; do while ((sn.forward_relp ^= 0) | (sn.backward_relp ^= 0)); /* set the next_segname_relp */ if (sn.class = 3) & prev_snp ^= null then prev_sn.next_segname_relp = def_relp; if sn.class = 3 then do; prev_snp = addwordno (dhp, def_relp); set_first = true; end; /* now set the first_relp values for the segnames in the block */ if (sn.class ^= 3) & set_first then do; /* save the current definition pointer */ defnp = snp; /* find the first segname in the block */ snp = addwordno (dhp, defn.segname_relp); /* scan forward, setting the first_relp until we find a */ /* non-class-3 definition */ do while (sn.class = 3); sn.first_relp = def_relp; snp = addwordno (dhp, sn.forward_relp); end; /* restore the current definition */ snp = defnp; /* flag that the next type 3 starts a new block */ set_first = false; end; def_relp = sn.forward_relp; snp = addwordno (dhp, def_relp); end; /* set the next_segname relp on the last class-3 definition, and */ /* set the first_relp values if the last block had no non-class-3 */ /* definitions. */ if prev_snp ^= null then do; prev_sn.next_segname_relp = zero_relp; if set_first then do while ((prev_sn.first_relp = 0) & (prev_sn.backward_relp ^= 0)); prev_sn.first_relp = zero_relp; prev_snp = addwordno (dhp, prev_sn.backward_relp); end; end; /* install any init_infos into the object segment */ init_segp = od.init_segp; init_segl = ii.init_segl; do i = 1 to ii.N_inits; /* save the relpointer */ ii.init (i).relp = od.lengths.defs; od.lengths.defs = od.lengths.defs + ii.init (i).length; /* get pointers to the object segment location and existing init */ /* info structures for copying */ obj_init_strp = addwordno (dhp, ii.init (i).relp); new_init_strp = addwordno (init_segp, ii.init (i).start); /* calculate the length if treated as as character string */ init_strl = ii.init (i).length * 4; /* copy character string overlays */ obj_init_str = new_init_str; /* the deferred initialization contains a link relpointer, which */ /* must be relocated for it to work. So we check for that type */ /* of init_info and relocate the link reference. */ if obj_init_strp -> link_init.type = INIT_DEFERRED then call relocate_link_ref ( addr (obj_init_strp->link_init_deferred.target_relp) -> word, "2a", si.N_static_words); /* if the init info is a list template, it may have pointer init */ /* templates containing a reference to a link which mist also be */ /* relocated. */ else if obj_init_strp -> link_init.type = INIT_LIST_TEMPLATE then do; ltep = addr (obj_init_strp -> link_init_list_template.template); do while (lte.n_bits ^= 0); /* see if the template is for a pointer init */ if lte.init_type ^= 0 then do; /* get a pointer to the pointer datum structure */ pitp = addr (lte.datum); if pit.ptr_type = CLASS_LINKAGE then call relocate_link_ref (pitp -> word, "a2", si.N_static_words); end; ltep = addwordno (ltep, currentsize (lte)); end; end; /* generate and append the relinfo */ call append_relinfo (reloc_infop, Rel_defs, copy ("a", ii.init (i).length * 2), abs_count); end; /* install any trap pairs into the object segment */ do i = 1 to trpi.N_trap_pairs; trap_prp = addwordno (dhp, od.lengths.defs); trap_pr.call_relp = trpi.trap_pair (i).call_relp; trap_pr.info_relp = trpi.trap_pair (i).info_relp; /* generate the relinfo for the trap word */ if trap_pr.call_relp = 0 then substr (relpair, 1, 1) = "a"; else substr (relpair, 1, 1) = "2"; if trap_pr.info_relp = 0 then substr (relpair, 2, 1) = "a"; else substr (relpair, 2, 1) = "2"; /* relocate any link references */ wordp = trap_prp; call relocate_link_ref (word, relpair, si.N_static_words); /* append the relinfo to the relinfo block */ call append_relinfo (reloc_infop, Rel_defs, relpair, abs_count); /* and grow the definition section */ od.lengths.defs = od.lengths.defs + currentsize (trap_pr); end; /* now install the type pairs into the object segment */ do i = 1 to tpi.N_type_pairs; /* set the relp of the type pair block */ tpi.type_pr (i).relp = od.lengths.defs; /* get a pointer to the new type pair */ new_type_pairp = addwordno (dhp, od.lengths.defs); od.lengths.defs = od.lengths.defs + currentsize (new_type_pair); /* generate the relinfo depending on the type since the fields */ /* vary with the type value. */ relchrs = "a"; new_type_pair.type = tpi.type_pr (i).type; /* decode the offsetname */ if (new_type_pair.type = 1) | (new_type_pair.type = 3) then do; new_type_pair.offsetname_relp = 0; relchrs = relchrs || "a"; end; else do; new_type_pair.offsetname_relp = smi.string (tpi.type_pr (i).offsetnamex).relp; relchrs = relchrs || "d"; end; /* decode the segname */ if (new_type_pair.type = 1) | (new_type_pair.type = 5) then do; /* convert Self-Base and Self-Offsetname links to static to */ /* linkage references if there is no separate static section */ if tpi.type_pr (i).segnamex = SECTION_STATIC & ^od.flags.separate_static then new_type_pair.segname_relp = SECTION_LINK; else new_type_pair.segname_relp = tpi.type_pr (i).segnamex; relchrs = relchrs || "a"; end; else do; new_type_pair.segname_relp = smi.string (tpi.type_pr (i).segnamex).relp; relchrs = relchrs || "d"; end; /* decode the init_info value */ if tpi.type_pr (i).init_infox ^= 0 then do; if (new_type_pair.type = 5) then new_type_pair.trap_relp = ii.init (tpi.type_pr (i).init_infox).relp; else new_type_pair.trap_relp = trpi.trap_pair (tpi.type_pr (i).init_infox).relp; relchrs = relchrs || "d"; end; else relchrs = relchrs || "a"; /* add the generated relinfo to the relinfo block */ call append_relinfo (reloc_infop, Rel_defs, relchrs, abs_count); end; /* now create the expression words */ do i = 1 to ewi.N_exp_words; /* set the relp value */ ewi.exp_wd (i).relp = od.lengths.defs; /* get a pointer to the new expression word */ exprp = addwordno (dhp, od.lengths.defs); od.lengths.defs = od.lengths.defs + currentsize (expr); /* set the type_relp and expression values */ tpx = ewi.exp_wd (i).type_pairx; expr.type_relp = tpi.type_pr (tpx).relp; expr.expression = ewi.exp_wd (i).expression; /* if the link is a self-base link to the linkage section, then */ /* we want to relocate the expression value to account for the */ /* insertion of the static section. If it is a self-base link to */ /* static, we must convert it to a self-base link to linkage with */ /* an appropriately adjusted expression value. */ if tpi.type_pr (tpx).type = LINK_SELF_BASE then do; if tpi.type_pr (tpx).segnamex = SECTION_LINK then call relocate_link_ref (exprp -> word, "d2", si.N_static_words); else if tpi.type_pr (tpx).segnamex = SECTION_STATIC then call relocate_link_ref (exprp -> word, "d8", si.N_static_words); end; /* append the relinfo to the defs relinfo block */ call append_relinfo (reloc_infop, Rel_defs, "da", abs_count); end; /* generate the msf_map (if any) */ if ocu_data.msf_info.component_count > 0 then do; /* get a pointer to the new msf_map */ mmp = addwordno (dhp, od.lengths.defs); /* patch the relpointer into the definition header */ dh.msf_map_relp = od.lengths.defs; od.lengths.defs = od.lengths.defs + currentsize (mm); /* set the values for the component and count */ mm.version = msf_map_version_1; mm.component_count = od.msf_info.component_count; mm.my_component = od.msf_info.my_component; /* and generate relinfo */ call append_relinfo (reloc_infop, Rel_defs, "aaaaaaaa", abs_count); end; /* now create the definition hash_table */ if ^od.flags.no_hash_table then call create_hash_table (dhp, dip, smip, od.lengths.defs); /* force the segment onto a doubleword boundary */ if mod (od.lengths.text + od.lengths.defs, 2) ^= 0 then do; call append_relinfo (reloc_infop, Rel_defs, "aa", abs_count); od.lengths.defs = od.lengths.defs + 1; end; /* finish off the relinfo block */ call append_relinfo (reloc_infop, Rel_defs, " ", abs_count); /* set the new bit count */ od.target.bc = od.target.bc + 36 * od.lengths.defs; end create_defs; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_link: proc (odp, /** pointer to ocu_data (in ) */ reloc_infop); /** pointer to relinfo (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: create_link */ /*** Input: reloc_info */ /*** Function: creates the linkage section of the new object */ /*** segment. */ /*** Output: reloc_info */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl reloc_infop ptr parameter; /* based */ dcl 01 ewi aligned based (ewip), 02 header aligned like exp_word_info.header, 02 exp_wd dim (0 refer (ewi.N_exp_words)) like exp_word_entry; dcl 01 frt aligned based (frtp), 02 decl_vers fixed bin, 02 n_traps fixed bin, 02 trap_array dim (0 refer (frt.n_traps)) like fr_traps.trap_array; dcl 01 frti aligned based (frtip), 02 header aligned like firstref_trap_info.header, 02 trap dim (0 refer (frti.N_traps)) like firstref_trap_entry; dcl 01 li aligned based (lip), 02 header aligned like link_info.header, 02 link dim (0 refer (li.N_links)) like link_entry; dcl 01 lk aligned like object_link based (lkp); dcl new_stat_str char (stat_strl) based (new_stat_strp); dcl obj_stat_str char (stat_strl) based (obj_stat_strp); dcl 01 od aligned like ocu_data based (odp); dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); dcl 01 partial_lk aligned like partial_link based (partial_lkp); dcl 01 vlh aligned like virgin_linkage_header based (vlhp); dcl word bit (36) aligned based (wordp); /* automatic */ dcl abs_count fixed bin automatic; dcl ewip ptr automatic; dcl frtip ptr automatic; dcl frtp ptr automatic; dcl lip ptr automatic; dcl lkp ptr automatic; dcl new_stat_strp ptr automatic; dcl obj_stat_strp ptr automatic; dcl relchars char (32) varying automatic; dcl relpair char (2) varying automatic; dcl sip ptr automatic; dcl stat_strl fixed bin (21) automatic; dcl static_size fixed bin (18) automatic; dcl vlhp ptr automatic; dcl partial_lkp ptr automatic; dcl wordp ptr automatic; /* builtin */ dcl currentsize builtin; /* get pointers to the structures to be used */ sip = od.static_infop; lip = od.link_infop; frtip = od.firstref_trap_infop; ewip = od.exp_word_infop; /* initialize the relocation generation variables */ abs_count = 0; /* create the linkage header */ vlhp = addwordno (od.target.segp, od.target.bc / 36); relchars = "aataaaaaaaaa22aa"; vlh.pad = ""b; vlh.defs_in_link = ""b; vlh.def_offset = od.lengths.text; vlh.filled_in_later = ""b; vlh.static_length = si.N_static_words; vlh.link_begin = currentsize (vlh); vlh.linkage_section_lng = currentsize (vlh) + N_links * currentsize (lk); /* adjust the header for static in linkage */ if ^od.flags.separate_static then do; static_size = si.N_static_words + mod (si.N_static_words, 2); vlh.link_begin = vlh.link_begin + static_size; vlh.linkage_section_lng = vlh.linkage_section_lng + static_size; end; /* adjust the header for the presence of firstref traps */ if frti.N_traps > 0 then do; vlh.first_ref_relp = vlh.linkage_section_lng; substr (relchars, 4, 1) = "2"; vlh.linkage_section_lng = vlh.linkage_section_lng + frti.N_traps + 2; end; /* add the relocation info for the linkage header */ call append_relinfo (reloc_infop, Rel_link, relchars, abs_count); od.lengths.link = currentsize (vlh); /* if the static section is in the linkage section, copy it now */ if ^od.flags.separate_static & si.N_static_words > 0 then do; obj_stat_strp = addwordno (vlhp, od.lengths.link); new_stat_strp = addr (static_word (1)); stat_strl = si.N_static_words * 4; obj_stat_str = new_stat_str; call append_relinfo (reloc_infop, Rel_link, copy ("a", static_size * 2), abs_count); od.lengths.link = od.lengths.link + static_size; od.lengths.stat = si.N_static_words; end; /* now copy the link array */ do i = 1 to li.N_links; if li.link (i).exp_wordx = 0 then do; /* emit a partial link */ /* make sure that a msf_map was present */ if od.msf_info.component_count = 0 then call sub_err_ (error_table_$improper_data_format, "format", ACTION_CANT_RESTART, null, 0, "^/Partial links cannot be emitted " || "without an msf_map."); /* make sure the given component number is in range */ if li.link (i).component > od.msf_info.component_count then call sub_err_ (error_table_$improper_data_format, "format", ACTION_CANT_RESTART, null, 0, "^/Partial link refers to component " || "outside the range in the msf_map."); partial_lkp = addwordno (vlhp, od.lengths.link); partial_lk.type = li.link (i).type; partial_lk.component = li.link (i).component; partial_lk.mbz1 = ""b; partial_lk.tag = FAULT_TAG_3; partial_lk.offset = li.link (i).offset; partial_lk.mbz2 = ""b; partial_lk.bit_offset = 0; partial_lk.mbz3 = ""b; partial_lk.modifier = li.link (i).modifier; call append_relinfo (reloc_infop, Rel_link, "aaaa", abs_count); od.lengths.link = od.lengths.link + currentsize (partial_lk); end; else do; /* emit a normal link */ lkp = addwordno (vlhp, od.lengths.link); lk.header_relp = -od.lengths.link; lk.ringno = 0; lk.mbz = ""b; lk.run_depth = 0; lk.tag = FAULT_TAG_2; lk.expression_relp = ewi.exp_wd (li.link (i).exp_wordx).relp; lk.mbz2 = ""b; lk.modifier = li.link (i).modifier; call append_relinfo (reloc_infop, Rel_link, "iada", abs_count); od.lengths.link = od.lengths.link + currentsize (lk); end; end; /* if there are firstref traps to be added, add them */ if frti.N_traps > 0 then do; /* emit the header for the firstref trap block */ frtp = addwordno (vlhp, vlh.first_ref_relp); frt.decl_vers = FR_TRAPS_VERSION_1; frt.n_traps = frti.N_traps; od.lengths.link = od.lengths.link + currentsize (frt); call append_relinfo (reloc_infop, Rel_link, "aaaa", abs_count); /* copy the trap array */ do i = 1 to frti.N_traps; frt.trap_array (i).call_relp = frti.trap (i).call_relp; frt.trap_array (i).info_relp = frti.trap (i).info_relp; wordp = addr (frt.trap_array (i)); relpair = "22"; /* adjust the relinfo for zero info relp values */ if frt.trap_array (i).info_relp = 0 then relpair = "2a"; /* relocate the link references */ call relocate_link_ref (word, relpair, si.N_static_words); call append_relinfo (reloc_infop, Rel_link, relpair, abs_count); end; end; /* force the segment to a doubleword boundary */ if mod (od.lengths.link, 2) ^= 0 then do; call append_relinfo (reloc_infop, Rel_link, "aa", abs_count); od.lengths.link = od.lengths.link + 1; end; /* clean up the relocation info */ call append_relinfo (reloc_infop, Rel_link, " ", abs_count); /* set the new bit count */ od.target.bc = od.target.bc + 36 * od.lengths.link; end create_link; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_stat: proc (odp); /** pointer to ocu_data (in ) */ /*** ****************************************************************/ /*** */ /*** Name: create_stat */ /*** Input: odp */ /*** Function: creates the static section of the new object */ /*** segment if the new object is to have a separate */ /*** static section. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; /* based */ dcl obj_stat_str char (stat_strl) based (obj_stat_strp); dcl 01 od aligned like ocu_data based (odp); dcl new_stat_str char (stat_strl) based (new_stat_strp); dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); /* automatic */ dcl sip ptr automatic; dcl stat_strl fixed bin (21) automatic; dcl obj_stat_strp ptr automatic; dcl new_stat_strp ptr automatic; /* get a pointer to the static section info structure */ sip = od.static_infop; /* save the length */ od.lengths.stat = si.N_static_words; /* if the static is in linkage, just return */ if ^od.flags.separate_static | (si.N_static_words = 0) then return; /* copy the static section into the object */ obj_stat_strp = addwordno (od.target.segp, od.target.bc / 36); new_stat_strp = addr (si.static_word (1)); stat_strl = si.N_static_words * 4; obj_stat_str = new_stat_str; end create_stat; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_symb: proc (odp, /** pointer to ocu_data (in ) */ reloc_infop); /** reloc info pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: create_symb */ /*** Input: odp, reloc_info */ /*** Function: creates the symbol section and appends the */ /*** generated relocation info to the new object */ /*** segment. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameter */ dcl odp ptr; dcl reloc_infop ptr; /* based */ dcl 01 od aligned like ocu_data based (odp); dcl 01 rel_info aligned based (rel_infop), 02 header aligned like relinfo.header, 02 relbits bit (0 refer (rel_info.n_bits)) aligned; dcl 01 reloc_info aligned based (reloc_infop), 02 header aligned like relinfo_blocks.header, 02 relbits bit (0 refer (reloc_info.header.n_bits)) aligned; dcl 01 sbi aligned based (sbip), 02 header aligned like symbol_info.header, 02 symbol_word dim (0 refer (sbi.N_symbol_words)) bit (36); dcl 01 si aligned based (sip), 02 header aligned like static_info.header, 02 static_word dim (0 refer (si.N_static_words)) bit (36); dcl 01 ssh aligned like std_symbol_header based (sshp); /* automatic */ dcl abs_count fixed bin automatic; dcl defs_relp fixed bin (18) unsigned automatic; dcl link_relp fixed bin (18) unsigned automatic; dcl rel_infop ptr automatic; dcl sbip ptr automatic; dcl sip ptr automatic; dcl sshp ptr automatic; dcl symb_relp fixed bin (18) unsigned automatic; dcl symbol_size fixed bin (18) unsigned automatic; dcl text_relp fixed bin (18) unsigned automatic; dcl wordp ptr automatic; /* get pointers to the required structures */ sip = od.static_infop; sbip = od.symbol_infop; relinfo_strp = od.symbol_relinfop; relinfo_strl = sbi.symbol_relinfol; wordp = addwordno (od.target.segp, od.target.bc / 36); sshp = wordp; /* initialize the relocation generation variables */ text_relp = 0; defs_relp = 0; link_relp = 0; symb_relp = 0; abs_count = 0; /* relocate and install each symbol word */ call install_words (addr (sbi.symbol_word), relinfo_strp, sbi.N_symbol_words, si.N_static_words, reloc_infop, Rel_symb, wordp, abs_count); symbol_size = sbi.N_symbol_words; /* finish off the relocation info */ call append_relinfo (reloc_infop, Rel_symb, " ", abs_count); /* if the object is to be relocatable, add the relocation to the */ /* object segment. */ if od.flags.relocatable then do; /* now append the relocation blocks to the object segment */ /* append the text relinfo block */ text_relp = sbi.N_symbol_words; rel_infop = wordp; rel_info.decl_vers = 2; rel_info.n_bits = reloc_info.section (Rel_text).n_bits; rel_info.relbits = substr (reloc_info.relbits, reloc_info.section (Rel_text).start_offset, reloc_info.section (Rel_text).n_bits); /* append the definition relinfo block */ defs_relp = text_relp + currentsize (rel_info); rel_infop = addwordno (rel_infop, currentsize (rel_info)); rel_info.decl_vers = 2; rel_info.n_bits = reloc_info.section (Rel_defs).n_bits; rel_info.relbits = substr (reloc_info.relbits, reloc_info.section (Rel_defs).start_offset, reloc_info.section (Rel_defs).n_bits); /* append the linkage relinfo block */ link_relp = defs_relp + currentsize (rel_info); rel_infop = addwordno (rel_infop, currentsize (rel_info)); rel_info.decl_vers = 2; rel_info.n_bits = reloc_info.section (Rel_link).n_bits; rel_info.relbits = substr (reloc_info.relbits, reloc_info.section (Rel_link).start_offset, reloc_info.section (Rel_link).n_bits); /* append the symbol relinfo block */ symb_relp = link_relp + currentsize (rel_info); rel_infop = addwordno (rel_infop, currentsize (rel_info)); rel_info.decl_vers = 2; rel_info.n_bits = reloc_info.section (Rel_symb).n_bits; rel_info.relbits = substr (reloc_info.relbits, reloc_info.section (Rel_symb).start_offset, reloc_info.section (Rel_symb).n_bits); /* calculate the new symbol section size */ symbol_size = symb_relp + currentsize (rel_info); end; /* check to make sure the first thing in the symbol section is */ /* a std_symbol_header before writing the relinfo relptrs in. */ if (ssh.dcl_version ^= 1) | (ssh.identifier ^= "symbtree" & ssh.identifier ^= "bind_map") then call sub_err_ (error_table_$improper_data_format, "format", ACTION_CAN_RESTART, null, 0); /* install the block size into the symbol header */ ssh.block_size = bit (symbol_size, 18); /* install the relinfo relpointers into the symbol section */ ssh.rel_text = bit (text_relp, 18); ssh.rel_def = bit (defs_relp, 18); ssh.rel_link = bit (link_relp, 18); ssh.rel_symbol = bit (symb_relp, 18); /* save the section length and adjust the segment bit_count */ od.lengths.symb = symbol_size; od.target.bc = od.target.bc + symbol_size * 36; end create_symb; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_obj_map: proc (odp); /** pointer to ocu_data (in ) */ /*** ****************************************************************/ /*** */ /*** Name: create_obj_map */ /*** Input: odp */ /*** Function: creates the object_map and inserts it into the */ /*** new object segment. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; /* based */ dcl 01 obj_map_relp aligned based (obj_map_relpp), 02 relp fixed bin (18) unsigned unaligned, 02 mbz bit (18) unaligned; dcl 01 od aligned like ocu_data based (odp); dcl 01 om aligned like object_map based (omp); /* automatic */ dcl end_relp fixed bin (18) unsigned automatic; dcl obj_map_relpp ptr automatic; dcl omp ptr automatic; dcl om_relp fixed bin (18) unsigned automatic; dcl relp fixed bin (18) unsigned automatic; /* get a pointer to the new object_map and determine the relpointer */ om_relp = divide (od.target.bc, 36, 18); omp = addwordno (od.target.segp, om_relp); /* set up the object map */ om.decl_vers = 2; om.identifier = "obj_map"; /* set the section lengths */ end_relp = 0; om.text_offset = bit (end_relp); om.text_length = bit (od.lengths.text, 18); end_relp = end_relp + od.lengths.text; om.definition_offset = bit (end_relp, 18); om.definition_length = bit (od.lengths.defs, 18); end_relp = end_relp + od.lengths.defs; om.linkage_offset = bit (end_relp, 18); om.linkage_length = bit (od.lengths.link, 18); end_relp = end_relp + od.lengths.link; om.static_length = bit (od.lengths.stat, 18); /* determind the static offset depending on whether it is separate */ if od.flags.separate_static then do; om.static_offset = bit (end_relp, 18); end_relp = end_relp + od.lengths.stat; om.symbol_offset = bit (end_relp, 18); end; else do; relp = fixed (om.linkage_offset, 18) + vlh_size; om.static_offset = bit (relp, 18); om.symbol_offset = bit (end_relp, 18); end; om.symbol_length = bit (od.lengths.symb, 18); /* set various constant values (for a standard object segment) */ om.break_map_offset = ""b; om.break_map_length = ""b; om.entry_bound = ""b; om.text_link_offset = ""b; /* set the flags */ om.format.bound = od.flags.bound; om.format.relocatable = od.flags.relocatable; om.format.procedure = od.flags.procedure; om.format.standard = true; om.format.separate_static = od.flags.separate_static; om.format.perprocess_static = od.flags.perprocess_static; /* generate the object map relpointer in the last word */ obj_map_relpp = addwordno (omp, currentsize (om)); obj_map_relp.relp = om_relp; /* calculate the final segment bit_count */ od.target.bc = od.target.bc + currentsize (om) * 36 + 36; end create_obj_map; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ install_words: proc (wordsp, /** ptr to word array (in ) */ relstrp, /** ptr to relinfo str (in ) */ n_words, /** number of words (in ) */ n_static, /** static size (in ) */ reloc_infop, /** reloc info pointer (i/o) */ section, /** section being moved (in ) */ targetp, /** target to move to (i/o) */ abs_count); /** reloc abs count (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: install_words */ /*** Input: wordsp, relstrp, n_words, n_static, reloc_infop, */ /*** section, targetp, abs_count */ /*** Function: copies a word block/relocation string format */ /*** into the object segment and relocates all of the */ /*** link and static references. */ /*** Output: reloc_infop, targetp, abs_count */ /*** */ /*** ****************************************************************/ /* parameters */ dcl wordsp ptr parameter; dcl relstrp ptr parameter; dcl n_words fixed bin parameter; dcl n_static fixed bin parameter; dcl reloc_infop ptr parameter; dcl section fixed bin parameter; dcl targetp ptr parameter; dcl abs_count fixed bin parameter; /* based */ dcl relstr char (relstrl) based (relstrp); dcl copy char (copyl) based (copyp); dcl target char (copyl) based (targetp); dcl word bit (36) aligned based; /* automatic */ dcl copyl fixed bin (21) automatic; dcl copyp ptr automatic; dcl first fixed bin (21) automatic; dcl halfwords fixed bin (21) automatic; dcl left fixed bin (21) automatic; dcl relpair char (2) varying automatic; dcl relstrl fixed bin (21) automatic; dcl start fixed bin (21) automatic; /* calculate the length of the relinfo */ relstrl = n_words * 2; start = 1; left = relstrl; copyp = wordsp; do while (left > 0); /* search for the first halfword needing relocation */ first = search (substr (relstr, start, left), "23l8i"); if first > 0 then first = first - 1; else first = left; /* calculate the number of intervening words to be copied */ first = divide (first, 2, 18, 0); if first > 0 then do; /* convert to a character string length */ copyl = first * 4; /* copy the words as a character string */ target = copy; /* adjust the source and destination pointers for the copied words */ copyp = addwordno (copyp, first); targetp = addwordno (targetp, first); /* calculate the number of halfwords copied */ halfwords = first + first; /* add the relinfo and adjust the counts */ call append_relinfo (reloc_infop, section, substr (relstr, start, halfwords), abs_count); start = start + halfwords; left = left - halfwords; end; if left > 0 then do; /* if not done, then extract the relinfo, relocate the link */ /* or static reference, and append the relinfo */ relpair = substr (relstr, start, 2); call relocate_link_ref (copyp -> word, relpair, n_static); call append_relinfo (reloc_infop, section, relpair, abs_count); /* length is 4 bytes (1 word) */ copyl = 4; /* copy the word, adjust the pointers and counts */ target = copy; targetp = addwordno (targetp, 1); copyp = addwordno (copyp, 1); start = start + 2; left = left - 2; end; end; end install_words; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ create_hash_table: proc (dhp, /** def header ptr (i/o) */ dip, /** def info pointer (in ) */ smip, /** string map pointer (in ) */ defnl); /** def section length (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: create_hash_table */ /*** Input: dhp, dip, smip, defnl */ /*** Function: creates the definition section hash table, */ /*** adjusts the section length, and backpatches the */ /*** hash table relp back into the definition header. */ /*** Output: dhp, defnl */ /*** */ /*** ****************************************************************/ /* parameters */ dcl dhp ptr parameter; dcl dip ptr parameter; dcl smip ptr parameter; dcl defnl fixed bin (18) unsigned parameter; /* based */ dcl 01 di aligned based (dip), 02 header aligned like def_info.header, 02 def dim (0 refer (di.N_defs)) like def_entry; dcl 01 smi aligned based (smip), 02 header aligned like string_map_info.header, 02 string dim (0 refer (smi.N_strings)) like string_map_entry; dcl 01 def aligned like definition based (defp); dcl 01 sn aligned like segname_definition based (snp); dcl 01 de aligned like def_entry based (dep); dcl 01 srch_de aligned like def_entry based (srch_dep); dcl 01 dt aligned based (dtp), 02 mbz bit (18) unaligned, 02 n_names fixed bin (18) unsigned unaligned, 02 table dim (0 refer (dt.n_names)) aligned like duplicate_table.table; dcl 01 dh aligned like definition_header based (dhp); dcl 01 dht aligned based (dhtp), 02 n_entries fixed bin, 02 table dim (0 refer (dht.n_entries)) aligned like definition_ht.table; dcl 01 cht aligned based (chtp), 02 n_entries fixed bin, 02 table dim (0 refer (cht.n_entries)) aligned like component_ht.table; /* automatic */ dcl defp ptr automatic; dcl snp ptr automatic; dcl dep ptr automatic; dcl srch_dep ptr automatic; dcl d fixed bin automatic; dcl n_names fixed bin automatic; dcl n_segnames fixed bin automatic; dcl make_comp_ht bit (1) automatic; dcl dtp ptr automatic; dcl dhtp ptr automatic; dcl chtp ptr automatic; dcl accp ptr automatic; dcl htx fixed bin automatic; dcl relp fixed bin (18) unsigned automatic; n_names = 0; n_segnames = 0; make_comp_ht = false; /* pass 1: create the duplicate tables */ do d = 1 to di.N_defs; dep = addr (di.def (d)); if de.flags.ignore then ; else if de.class = 3 then n_segnames = n_segnames + 1; else if ^de.flags.duplicate then do; n_names = n_names + 1; dtp = null; do i = d + 1 to di.N_defs; srch_dep = addr (di.def (i)); if srch_de.strx = de.strx & ^srch_de.flags.ignore & srch_de.class ^= 3 then do; if dtp ^= null then do; dt.n_names = dt.n_names + 1; dt.table (dt.n_names).def_relp = dh_size + (i - 1) * def_size; defp = addwordno (dhp, dt.table (dt.n_names).def_relp); dt.table (dt.n_names).block_hdr_relp = def.segname_relp; srch_de.flags.duplicate = true; end; else do; dtp = addwordno (dhp, defnl); dt.mbz = ""b; dt.n_names = 2; /* set up the table entry for the original name */ dt.table (1).def_relp = dh_size + ((d - 1) * def_size); defp = addwordno (dhp, dt.table (1).def_relp); dt.table (1).block_hdr_relp = def.segname_relp; de.flags.duplicate = true; de.dup_tbl_relp = defnl; /* set up the table entry for the duplicate name found */ dt.table (2).def_relp = dh_size + ((i - 1) * def_size); defp = addwordno (dhp, dt.table (2).def_relp); dt.table (2).block_hdr_relp = def.segname_relp; srch_de.flags.duplicate = true; srch_de.dup_tbl_relp = 0; end; end; end; if de.flags.duplicate then do; defnl = defnl + currentsize (dt); make_comp_ht = true; end; end; end; /* pass 2: create the actual definition hash table */ dh.hash_table_relp = defnl; dhtp = addwordno (dhp, defnl); dht.n_entries = opt_size (n_names); defnl = defnl + currentsize (dht); do d = 1 to di.N_defs; dep = addr (di.def (d)); if (de.flags.duplicate & de.dup_tbl_relp = 0) | de.class = 3 | de.flags.ignore then ; else do; accp = addwordno (dhp, smi.string (de.strx).relp); htx = hash (accp, dht.n_entries); do while (unspec (dht.table (htx)) ^= ""b); htx = mod (htx, dht.n_entries) + 1; end; if de.duplicate then dht.table (htx).def_relp = de.dup_tbl_relp; else dht.table (htx).def_relp = dh_size + (d - 1) * def_size; end; end; /* pass 3: if we need a component hash table we build that now */ if make_comp_ht then do; chtp = addwordno (dhp, defnl); cht.n_entries = opt_size (n_segnames); defnl = defnl + currentsize (cht); do d = 1 to di.N_defs; dep = addr (di.def (d)); if de.class = 3 & ^de.flags.ignore then do; accp = addwordno (dhp, smi.string (de.strx).relp); htx = hash (accp, cht.n_entries); do while (unspec (cht.table (htx)) ^= ""b); htx = mod (htx, cht.n_entries) + 1; end; relp, cht.table (htx).def_relp = dh_size + (d - 1) * def_size; snp = addwordno (dhp, relp); defp = addwordno (dhp, sn.first_relp); cht.table (htx).block_hdr_relp = def.segname_relp; end; end; end; end create_hash_table; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ opt_size: proc (n_names) /** valid entry count (in ) */ returns (fixed bin); /** opt table size (out) */ /*** ****************************************************************/ /*** */ /*** Name: opt_size */ /*** Input: n_names */ /*** Function: calculates the definition hash table size from */ /*** the number of entries to be included. */ /*** Output: ht_size */ /*** */ /*** ****************************************************************/ /* constants */ dcl sizes (1:11) fixed bin static options (constant) init (13, 27, 53, 89, 157, 307, 503, 733, 1009, 1451, 2003); /* parameters */ dcl n_names fixed bin parameter; /* automatic */ dcl i fixed bin automatic; dcl ht_size fixed bin automatic; /* allow for 20% of the buckets to be empty */ ht_size = n_names * 1.25; /* pick an appropriate number of entries */ do i = 1 to hbound (sizes, 1); if ht_size <= sizes (i) then return (sizes (i)); end; /* default for very large hash tables */ return (ht_size); end opt_size; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ hash: proc (strp, /** acc string pointer (in ) */ size) /** hash table size (in ) */ returns (fixed bin); /** hash index (out) */ /*** ****************************************************************/ /*** */ /*** Name: hash */ /*** Input: strp, size */ /*** Function: computes the hash function for a definition hash */ /*** table. */ /*** Output: index */ /*** */ /*** ****************************************************************/ /* parameter */ dcl strp ptr parameter; dcl size fixed bin parameter; /* based */ dcl word fixed bin (35) based (strp); return (mod (word, size) + 1); end hash; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ relocate_link_ref: proc (word, /** word to relocate (i/o) */ relinfo, /** relinfo for word (i/o) */ static_size); /** size of static scn (in ) */ /*** ****************************************************************/ /*** */ /*** Name: relocate_link_ref */ /*** Input: word, relinfo, static_size */ /*** Function: takes a word and relocation info and adjusts any */ /*** reference to the linkage section to compensate */ /*** for the insertion of the static section. */ /*** Output: word, relinfo */ /*** */ /*** ****************************************************************/ /* parameters */ dcl word bit (36) aligned parameter; dcl relinfo char (2) varying parameter; dcl static_size fixed bin parameter; /* based */ dcl 01 w15 (1:2) unaligned based (addr (word)), 02 pad bit (3), 02 value fixed bin (15) unsigned; dcl 01 w18 (1:2) unaligned based (addr (word)), 02 value fixed bin (18) unsigned; /* automatic */ dcl min fixed bin automatic; dcl s fixed bin automatic; dcl st_size fixed bin (18) unsigned automatic; /* don't bother if the static section is separate */ if ocu_data.flags.separate_static then return; /* leave link references that are not into the link array */ min = vlh_size; /* round the static section size to an even word boundary to keep */ /* the link array aligned properly (ITS pointers must be on a */ /* doubleword boundary or the hardware complains. . .) */ st_size = static_size + mod (static_size, 2); /* relocate each halfword */ do s = Left, Right; if (index ("23", substr (relinfo, s, 1)) > 0) & (w18 (s).value >= min) then w18 (s).value = w18 (s).value + st_size; if (substr (relinfo, s, 1) = "l") & (w15 (s).value >= min) then w15 (s).value = w15 (s).value + st_size; /* adjust static references for the size of the linkage header */ /* and convert the relinfo into linkage section relinfo */ if substr (relinfo, s, 1) = "8" then w18 (s).value = w18 (s).value + vlh_size; if substr (relinfo, s, 1) = "i" then w15 (s).value = w15 (s).value + vlh_size; end; end relocate_link_ref; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ append_relinfo: proc (relinfop, /** prt to relinfo blk (i/o) */ scn, /** section to add to (in ) */ relinfo_chrs, /** relinfo char string (in ) */ abs_count); /** pending abs halfwds (i/o) */ /*** ****************************************************************/ /*** */ /*** Name: append_relinfo */ /*** Input: relinfop, scn, relinfo_chrs, abs_count */ /*** Function: appends the specified relinfo to the relinfo */ /*** block given. */ /*** Absolute relocation is not appended to the */ /*** relinfo until the number of consecutive */ /*** halfwords is determined. If the relinfo_chr */ /*** specified is a blank, no additional relinfo is */ /*** emitted but any saved absolute relinfo is */ /*** appended to the relinfo block. This is used to */ /*** force all the relinfo into the block when it is */ /*** complete. */ /*** Output: relinfop, abs_count */ /*** */ /*** ****************************************************************/ /* parameters */ dcl relinfop ptr parameter; dcl scn fixed bin parameter; dcl relinfo_chrs char (*) varying parameter; dcl abs_count fixed bin parameter; /* based */ dcl 01 reloc_info aligned based (relinfop), 02 header like relinfo_blocks.header, 02 relbits bit (0 refer (reloc_info.header.n_bits)) aligned; /* automatic */ dcl c fixed bin (21) automatic; dcl 01 exp_abs unaligned automatic, 02 code bit (5), 02 count fixed bin (10) unsigned; dcl i fixed bin (21) automatic; dcl old_len fixed bin (24) automatic; dcl relinfo_chr char (1) automatic; /* builtin */ dcl length builtin; /* don't bother is the output is not relocatable */ if reloc_info.no_relinfo then return; /* set the section start if necessary */ if reloc_info.section (scn).start_offset = 0 then reloc_info.section (scn).start_offset = reloc_info.header.n_bits + 1; /* for each character in the relinfo string */ do c = 1 to length (relinfo_chrs); relinfo_chr = substr (relinfo_chrs, c, 1); /* if the relinfo is not absolute . . . */ if relinfo_chr ^= "a" then do; /* see if we have pending absolute stuff to insert */ do while (abs_count > 15); /* use expanded absolute if possible */ old_len = reloc_info.header.n_bits; exp_abs.code = "11110"b; exp_abs.count = min (abs_count, 1023); abs_count = abs_count - exp_abs.count; reloc_info.header.n_bits = reloc_info.header.n_bits + 15; reloc_info.section (scn).n_bits = reloc_info.section (scn).n_bits + 15; substr (reloc_info.relbits, old_len + 1, 15) = unspec (exp_abs); end; /* get the remainder using normal (non-expanded) absolute */ if abs_count > 0 then do; old_len = reloc_info.header.n_bits; reloc_info.header.n_bits = reloc_info.header.n_bits + abs_count; reloc_info.section (scn).n_bits = reloc_info.section (scn).n_bits + abs_count; substr (reloc_info.relbits, old_len + 1, abs_count) = copy ("0"b, abs_count); abs_count = 0; end; /* now search for the proper relocation bits */ i = index (reloc_chars, relinfo_chr); if i > 0 then do; old_len = reloc_info.header.n_bits; reloc_info.header.n_bits = reloc_info.header.n_bits + 5; reloc_info.section (scn).n_bits = reloc_info.section (scn).n_bits + 5; substr (reloc_info.relbits, old_len + 1, 5) = reloc_bits (i); end; end; /* otherwise, if the relocation is absolute, just increment the */ /* count and continue. */ else abs_count = abs_count + 1; end; end append_relinfo; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ validate_component: proc (mip, /** pointer to msf_info (in ) */ comp); /** component index (in ) */ /*** ****************************************************************/ /*** */ /*** Name: validate_component */ /*** Input: mip, comp */ /*** Function: This procedure is used to attempt to validate */ /*** a given object segment within a set of object */ /*** segments is valid as an MSF component. This is */ /*** determined based on the following criteria: */ /*** -- all of the segments must be in the same */ /*** directory. This values is set when the */ /*** first component is evaluated and checked */ /*** by the others. */ /*** -- the directory must otherwise be empty. */ /*** -- the name of the segment must correspond */ /*** to the component number of the segment. */ /*** -- the component must be an object segment. */ /*** -- the segment must have a msf_map. */ /*** -- the component number must correspond to */ /*** the component number stored in the msf_map. */ /*** -- the number of components must correspond */ /*** to the component count in the msf_map. */ /*** In the process of determining validity, the */ /*** bit count and relpointers to the various */ /*** sections are also filled in in the msf_info */ /*** structure. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl mip ptr parameter; dcl comp fixed bin parameter; /* based */ dcl 01 dh aligned like definition_header based (dhp); dcl 01 mi aligned based (mip), 02 header aligned like msf_info.header, 02 component dim (0 refer (mi.N_components)) like msf_info.component; dcl 01 mm aligned like msf_map based (mmp); /* automatic */ dcl bc fixed bin (24) automatic; dcl count fixed bin automatic; dcl dname char (168) automatic; dcl dhp ptr automatic; dcl dnl fixed bin automatic; dcl ename char (32) automatic; dcl 01 oi aligned like object_info automatic; dcl segp ptr automatic; dcl mmp ptr automatic; segp = mi.component (comp).segp; /* get the directory and entry names of the segment */ call hcs_$fs_get_path_name (segp, dname, dnl, ename, ec); if ec ^= 0 then call sub_err_ (ec, "argument", ACTION_CANT_RESTART, null, 0); if mi.containing_dir = "" then do; /* save the directory name */ mi.containing_dir = get_shortest_path_ (substr (dname, 1, dnl)); /* check out the directory to make sure there are no extraneous */ /* segments, directories, etc. */ retry_star_match: call hcs_$star_ (mi.containing_dir, "**", star_ALL_ENTRIES, null, count, null, null, ec); if ec ^= 0 then do; call sub_err_ (ec, "", ACTION_CAN_RESTART, null, 0); goto retry_star_match; end; if count > mi.N_components + 1 then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/There are extra entries in the containing directory."); end; else if mi.containing_dir ^= get_shortest_path_ (substr (dname, 1, dnl)) then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/All of the components do not reside in the same directory."); if ename ^= ltrim (char (comp)) then call sub_err_ (error_table_$bad_arg, "argument", ACTION_CANT_RESTART, null, 0, "^/The entryname for component ^d is ""^a"" instead of ""^d""", comp, ename, comp); call hcs_$status_mins (segp, 0, bc, ec); mi.component (comp).bc = bc; oi.version_number = object_info_version_2; /* see if this is actually an object segment */ call object_info_$brief (segp, bc, addr (oi), ec); if ec ^= 0 then call sub_err_ (ec, "argument", ACTION_CANT_RESTART, null, 0, "^/Component ^d is not an object segment.", comp); /* extract the section relpointers */ mi.component (comp).text_relp = fixed (rel (oi.textp), 18); mi.component (comp).defn_relp = fixed (rel (oi.defp), 18); mi.component (comp).link_relp = fixed (rel (oi.linkp), 18); mi.component (comp).stat_relp = fixed (rel (oi.statp), 18); mi.component (comp).symb_relp = fixed (rel (oi.symbp), 18); /* check for presence and validity of the msf_map */ dhp = oi.defp; if dh.msf_map_relp = 0 then call sub_err_ (error_table_$inconsistent_object_msf, "argument", ACTION_CANT_RESTART, null, 0, "^/Component ^d has no msf_map.", comp); mmp = addwordno (dhp, dh.msf_map_relp); if mm.version ^= msf_map_version_1 then call sub_err_ (error_table_$unimplemented_version, "argument", ACTION_CANT_RESTART, null, 0, "^/Incorrect version in msf_map for component ^d.", comp); if mm.component_count ^= mi.N_components + 1 then call sub_err_ (error_table_$inconsistent_object_msf, "argument", ACTION_CANT_RESTART, null, 0, "^/Number of components in input list (^d) disagrees with the" || "^/number given in the msf_map (^d) for component ^d.", mi.N_components + 1, mm.component_count, comp); if mm.my_component ^= comp then call sub_err_ (error_table_$inconsistent_object_msf, "argument", ACTION_CANT_RESTART, null, 0, "^/Component number ^d has the component number ^d in the msf_map.", comp, mm.my_component); end validate_component; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ copy_defs: proc (odp, /** ocu_data ptr (in ) */ mip, /** msf_info pointer (in ) */ comp); /** component number (in ) */ /*** ****************************************************************/ /*** */ /*** Name: copy_defs */ /*** Input: odp, mip, comp */ /*** Function: scans the definition list of component in */ /*** the msf_info structure and emits partial links */ /*** and corresponding indirect definitions. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl mip ptr parameter; dcl comp fixed bin parameter; /* based */ dcl 01 acc aligned based (accp), 02 count fixed bin (9) unsigned unaligned, 02 string char (0 refer (acc.count)) unaligned; dcl 01 def aligned like definition based (defp); dcl 01 dh aligned like definition_header based (dhp); dcl 01 mi aligned based (mip), 02 header aligned like msf_info.header, 02 component dim (0 refer (mi.N_components)) like msf_info.component; dcl word aligned fixed bin (35) based (defp); /* automatic */ dcl accp ptr automatic; dcl dhp ptr automatic; dcl defp ptr automatic; dcl dummy fixed bin (18) unsigned automatic; dcl lk_relp fixed bin (18) unsigned automatic; dcl flags bit (4) automatic; /* get the definition header */ dhp = addwordno (mi.component (comp).segp, mi.component (comp).defn_relp); /* scan the definition list */ do defp = addwordno (dhp, dh.def_list_relp) repeat (addwordno (dhp, def.forward_relp)) while (word ^= 0); /* for each externally visible definition . . . */ if ^def.flags.ignore then do; /* get the name ACC string */ accp = addwordno (dhp, def.name_relp); /* if it is a segname (class = 3), then emit a segname */ if def.class = 3 then dummy = emit_segname (odp, (acc.string), DEFINITION_FLAGS_RETAIN); else do; /* if not a segname, emit a partial link to the target */ /* and an indirect definition to the link. */ flags = DEFINITION_FLAGS_INDIRECT | DEFINITION_FLAGS_RETAIN; if def.flags.entry then flags = flags | DEFINITION_FLAGS_ENTRY; lk_relp = emit_partial_link (odp, (comp), (def.class), (def.thing_relp), ""b); dummy = emit_definition (odp, (acc.string), (CLASS_LINKAGE), lk_relp, flags); end; end; end; end copy_defs; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ mk_symbol_scn: proc (odp, /** ocu_data pointer (in ) */ mip); /** msf_info pointer (in ) */ /*** ****************************************************************/ /*** */ /*** Name: mk_symbol_hdr */ /*** Input: odp, mip */ /*** Function: creates the symbol section to be used for object */ /*** MSF component 0 and emits it. */ /*** Output: none */ /*** */ /*** ****************************************************************/ /* parameters */ dcl odp ptr parameter; dcl mip ptr parameter; /* based */ dcl 01 mi aligned based (mip), 02 header aligned like msf_info.header, 02 component dim (0 refer (mi.N_components)) like msf_info.component; dcl 01 mss aligned based (mssp), 02 header aligned like msf_symbol_scn.header, 02 user char (user_length refer (mss.header.userid.size)) aligned, 02 version char (version_length refer (mss.header.gen_version.size)) aligned; dcl system_free_area area based (system_free_areap); /* automatic */ dcl dummy fixed bin (18) unsigned automatic; dcl group_id char (40) varying automatic; dcl mssp ptr automatic; dcl reloc_str char (2048) automatic; dcl system_free_areap ptr automatic; dcl user_length fixed bin automatic; dcl version_length fixed bin automatic; /* builtin */ dcl length builtin; dcl size builtin; system_free_areap = get_system_free_area_ (); mssp = null; on cleanup begin; if mssp ^= null then free mss in (system_free_area); end; /* find the user id string */ group_id = get_group_id_ (); version_length = length (mi.gen_info.gen_version); user_length = length (group_id); /* allocate the symbol section structure */ allocate mss in (system_free_area); /* set all of the values in the symbol section */ mss.header.decl_version = 1; mss.header.identifier = "symbtree"; mss.header.gen_number = mi.gen_info.gen_number; mss.header.gen_created = mi.gen_info.gen_created; mss.header.object_created = clock (); mss.header.generator = mi.gen_info.generator; mss.header.text_boundary = 2; mss.header.stat_boundary = 2; mss.header.source_map = 0; mss.header.area_pointer = currentsize (mss); mss.header.backpointer = 0; mss.header.block_size = 0; mss.header.next_block = 0; mss.header.rel_text = 0; mss.header.rel_def = 0; mss.header.rel_link = 0; mss.header.rel_symbol = 0; mss.header.mini_truncate = currentsize (mss); mss.header.maxi_truncate = currentsize (mss); /* store the character strings */ mss.user = group_id; mss.version = mi.gen_info.gen_version; /* calculate the offsets */ mss.header.userid.offset = size (std_symbol_header); mss.header.gen_version.offset = size (std_symbol_header) + divide (user_length + 3, 4, 18); mss.header.comment.offset = 0; mss.header.comment.size = 0; /* overlay a word array on the structure */ word_arrayp = mssp; word_arrayl = currentsize (mss); /* generate the relocation information */ reloc_str = "aaaaaaaaaaaaaaaaaaaararaaaaaaraaaaaaaaaa" || copy ("a", currentsize (mss) - size (std_symbol_header)); /* emit the symbol section */ dummy = emit_symbol (odp, word_arrayp, addr (reloc_str), word_arrayl); /* free the symbol section structure */ free mss in (system_free_area); mssp = null; end mk_symbol_scn; /**** * * * * * * * * * * * * * * * * * * * * * * * */ /**** * * * * * * * * * * * * * * * * * * * * * * * */ %include access_mode_values; %include definition_dcls; %include object_info; %include object_link_dcls; %include object_map; %include ocu_structures; %include ocu_dcls; %include star_structures; %include std_symbol_header; %include sub_err_flags; end ocu_; 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