--- /dev/null
+/****^ ***********************************************************
+ * *
+ * Copyright, (C) Honeywell Bull Inc., 1987 *
+ * *
+ * Copyright, (C) Honeywell Information Systems Inc., 1986 *
+ * *
+ *********************************************************** */
+
+
+
+
+/****^ HISTORY COMMENTS:
+ 1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
+ audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
+ Rewritten to support object multisegment files. In particular, support
+ of indirect definitions, deferred initialization, partial links, and
+ preliminary support for *heap links.
+ 2) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
+ audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
+ added a check for heap links and a call to set_ext_variable_$star_heap
+ when a heap link is found.
+ 3) change(86-06-24,DGHowe), approve(86-06-24,MCR7420),
+ audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
+ added a segment pointer to the calling sequences of for_linker and
+ star_heap for ext pointer initialization.
+ 4) change(87-06-10,Elhard), approve(87-07-17,MCR7739),
+ audit(87-06-10,RWaters), install(87-07-17,MR12.1-1043):
+ Critical fix to correct snapping of CREATE_IF_NOT_FOUND (type 6) links to
+ targets with no offset name, or nonexistent targets.
+ END HISTORY COMMENTS */
+
+
+/* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll79,initcol0,dclind4,idind24,struclvlind1,comcol41 */
+
+link_snap:
+ proc;
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: link_snap */
+ /*** Input: none */
+ /*** Function: This procedure implements the Multics dynamic */
+ /*** linking mechanism. Four entries exist in this */
+ /*** procedure: */
+ /*** link_snap$link_fault - This entry is called as */
+ /*** due to a fault_tag_2 */
+ /*** (linkage) fault. */
+ /*** link_snap$link_force - This entry corresponds */
+ /*** to the hcs_$link_force */
+ /*** gate entry. It basicly */
+ /*** duplicates the action of */
+ /*** a link_fault without */
+ /*** taking a fault. */
+ /*** link_snap$make_ptr - This entry corresponds */
+ /*** to the hcs_$make_ptr */
+ /*** gate entry. It simulates */
+ /*** a type-3 or type-4 link */
+ /*** fault and returns the */
+ /*** target as a pointer. */
+ /*** link_snap$make_entry - This entry corresponds */
+ /*** to the hcs_$make_entry */
+ /*** gate entry. It simulates */
+ /*** a type-3 or type-4 link */
+ /*** fault and returns the */
+ /*** target as an entry value */
+ /*** */
+ /*** ****************************************************************/
+
+ /* constants */
+
+ dcl true bit (1) static options (constant) init ("1"b);
+ dcl false bit (1) static options (constant) init ("0"b);
+
+ dcl indirect bit (6) static options (constant) init ("20"b3);
+
+ dcl Link_fault fixed bin static options (constant) init (1);
+ dcl Link_force fixed bin static options (constant) init (2);
+ dcl Make_ptr fixed bin static options (constant) init (3);
+ dcl Make_entry fixed bin static options (constant) init (4);
+
+ dcl No_retry bit (1) static options (constant) init ("0"b);
+ dcl Will_retry bit (1) static options (constant) init ("1"b);
+
+ dcl zero_word bit (36) static options (constant) init (""b);
+
+ dcl None fixed bin (18) unsigned unaligned
+ static options (constant) init (0);
+
+ /* parameters */
+
+ dcl a_mcp ptr parameter;
+ dcl a_link_pairp ptr parameter;
+ dcl a_dummy fixed bin parameter;
+ dcl a_code fixed bin (35) parameter;
+ dcl a_refp ptr parameter;
+ dcl a_seg_name char (*) parameter;
+ dcl a_offset_name char (*) parameter;
+ dcl a_targetp ptr parameter;
+ dcl a_targete entry parameter;
+
+ /* procedures */
+
+ dcl condition_ entry (char (*), entry);
+ dcl fs_search entry (ptr, char (*), bit (1) aligned, ptr,
+ fixed bin (35));
+ dcl fs_search$same_directory
+ entry (ptr, char (*), ptr, fixed bin (35));
+ dcl get_defptr_ entry (ptr, ptr, ptr, ptr, fixed bin (35));
+ dcl level$get entry () returns (fixed bin (3));
+ dcl level$set entry (fixed bin (3));
+ dcl link_man$other_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35));
+ dcl link_man$own_linkage entry (ptr, ptr, ptr, ptr, fixed bin (35));
+ dcl page$enter_data entry (ptr unal, fixed bin);
+ dcl set_ext_variable_$for_linker
+ entry (char (*), ptr, ptr, ptr, bit (1) aligned,
+ ptr, fixed bin (35), ptr, ptr, ptr, ptr);
+ dcl set_ext_variable_$star_heap
+ entry (char (*), ptr, ptr, ptr, bit (1) aligned,
+ ptr, fixed bin (35));
+ dcl trap_caller_caller_ entry (ptr, ptr, ptr, ptr, ptr, ptr,
+ fixed bin (35));
+ dcl usage_values entry (fixed bin (30) aligned,
+ fixed bin (71) aligned);
+
+ /* external */
+
+ dcl 01 ahd$link_meters (4) aligned external like link_meters;
+ dcl error_table_$bad_class_def
+ external fixed bin (35);
+ dcl error_table_$bad_deferred_init
+ external fixed bin (35);
+ dcl error_table_$bad_indirect_def
+ external fixed bin (35);
+ dcl error_table_$bad_link_type
+ external fixed bin (35);
+ dcl error_table_$bad_self_ref
+ external fixed bin (35);
+ dcl error_table_$first_reference_trap
+ external fixed bin (35);
+ dcl error_table_$illegal_ft2
+ external fixed bin (35);
+ dcl error_table_$no_defs external fixed bin (35);
+ dcl error_table_$no_ext_sym external fixed bin (35);
+ dcl error_table_$no_linkage external fixed bin (35);
+ dcl error_table_$unexpected_ft2
+ external fixed bin (35);
+ dcl pds$link_meters_bins (4) external fixed bin (30);
+ dcl pds$link_meters_pgwaits (4) external fixed bin (30);
+ dcl pds$link_meters_times (4) external fixed bin (35);
+ dcl pds$stacks (0:7) external ptr;
+
+ /* based */
+
+ dcl 01 based_entry aligned based,
+ 02 code_ptr ptr,
+ 02 env_ptr ptr;
+ dcl 01 expr aligned like exp_word based (exprp);
+ dcl 01 link_pair aligned like object_link based (link_pairp);
+ dcl 01 offsetname aligned based (offsetnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (offsetname.count) unaligned;
+ dcl 01 segname aligned based (segnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (segname.count) unaligned;
+ dcl 01 type_pr aligned like type_pair based (type_prp);
+ dcl 01 usage aligned based,
+ 02 time fixed bin (71),
+ 02 pf fixed bin (30);
+
+ /* automatic */
+
+ dcl 01 automatic_offsetname aligned automatic,
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (256) unaligned;
+ dcl 01 automatic_segname aligned automatic,
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (32) unaligned;
+ dcl 01 call_info aligned automatic,
+ 02 type fixed bin,
+ 02 save_ring fixed bin,
+ 02 mcp ptr,
+ 02 codep ptr,
+ 02 start aligned like usage,
+ 02 finish aligned like usage,
+ 02 search aligned like usage,
+ 02 get_linkage aligned like usage,
+ 02 def_search aligned like usage;
+ dcl call_infop ptr automatic;
+ dcl code fixed bin (35) automatic;
+ dcl connect_fail_code fixed bin (35) automatic;
+ dcl defp ptr automatic;
+ dcl exprp ptr automatic;
+ dcl init_infop ptr automatic;
+ dcl instrp ptr automatic;
+ dcl link_pairp ptr automatic;
+ dcl linkp ptr automatic;
+ dcl nchars fixed bin automatic;
+ dcl offset_name char (256) automatic;
+ dcl offsetnamep ptr automatic;
+ dcl refp ptr automatic;
+ dcl retry_sw bit (1) automatic;
+ dcl seg_name char (32) automatic;
+ dcl segnamep ptr automatic;
+ dcl segp ptr automatic;
+ dcl star_system_sw bit (1) automatic;
+ dcl target_linkagep ptr automatic;
+ dcl targetp ptr automatic;
+ dcl textp ptr automatic;
+ dcl type_prp ptr automatic;
+ dcl MSF_sw bit (1) aligned automatic;
+
+ /* builtin */
+
+ dcl addr builtin;
+ dcl addrel builtin;
+ dcl baseno builtin;
+ dcl baseptr builtin;
+ dcl bin builtin;
+ dcl char builtin;
+ dcl divide builtin;
+ dcl index builtin;
+ dcl length builtin;
+ dcl ltrim builtin;
+ dcl max builtin;
+ dcl min builtin;
+ dcl null builtin;
+ dcl ptr builtin;
+ dcl rtrim builtin;
+ dcl substr builtin;
+ dcl unspec builtin;
+
+ return;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+link_fault:
+ entry (a_mcp); /** machine conditions (i/o) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: link_snap$link_fault */
+ /*** Input: mcp */
+ /*** Function: handles a fault_tag_2 (linkage) fault. The mcp */
+ /*** pointer points to the machine conditions at the */
+ /*** time of the fault. If the link snapping is */
+ /*** successfull, the machine conditions will be */
+ /*** adjusted to allow the fault to be restarted. */
+ /*** Output: mcp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* copy the parameters into automatic storage */
+
+ mcp = a_mcp;
+
+ call_infop = addr (call_info);
+ call_info.type = Link_fault;
+ call_info.mcp = mcp;
+ call_info.save_ring = level$get ();
+
+ /* since this is a fault, the trap routines can't set a return code */
+
+ call_info.codep = null;
+
+ /* set validation level to the level that the fault occurred at */
+
+ scup = addr (mc.scu (0));
+ call level$set (bin (scu.ppr.prr, 3));
+
+ /* get a pointer to the faulting link pair and instruction */
+
+ link_pairp = ptr (baseptr (bin (scu.tpr.tsr, 15)), scu.ca);
+ instrp = ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc);
+
+ /* trace the fault */
+
+ call page$enter_data ((instrp), linkage_fault_start);
+
+ /* make sure the fault_tag_2 wasn't in an instruction */
+
+ if instrp -> its.its_mod = FAULT_TAG_2
+ then call exit (call_infop, error_table_$unexpected_ft2, null);
+
+ goto link_join;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+link_force:
+ entry (a_link_pairp, /** ptr to link to snap (in ) */
+ a_dummy, /** unused (---) */
+ a_code); /** error code (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: link_snap$link_force */
+ /*** Input: link_pairp */
+ /*** Function: given a pointer to a link, snap it without taking */
+ /*** a fault. This entry is functionally the same as */
+ /*** link_snap$link_fault except that it is entered */
+ /*** via gate call rather than fault entry. */
+ /*** Output: code */
+ /*** */
+ /*** ****************************************************************/
+
+ /* not a fault entry */
+
+ mcp = null;
+
+ /* copy parameters into automatic storage */
+
+ link_pairp = a_link_pairp;
+
+ /* set up call info */
+
+ call_infop = addr (call_info);
+ call_info.type = Link_force;
+ call_info.mcp = null;
+ call_info.save_ring = -1;
+
+ /* save error code address in case we trap out to the user ring and */
+ /* the trap procedure needs to set the error code. */
+
+ call_info.codep = addr (a_code);
+
+ /* for a link_force call, we use the link itself as the start point */
+ /* for tracing purposes. */
+
+ call page$enter_data ((link_pairp), linkage_fault_start);
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+link_join:
+
+ /* clear out the metering information */
+
+ call_info.search.time = 0;
+ call_info.search.pf = 0;
+ call_info.get_linkage.time = 0;
+ call_info.get_linkage.pf = 0;
+ call_info.def_search.time = 0;
+ call_info.def_search.pf = 0;
+
+ /* meter the fault time etc. */
+
+ call usage_values (call_info.start.pf, call_info.start.time);
+
+ if link_pair.tag ^= FAULT_TAG_2
+ then if call_info.type = Link_force
+ then call exit (call_infop, 0, baseptr (0));
+ else call exit (call_infop, error_table_$illegal_ft2, null);
+
+ /* get the linkage section and text pointers */
+
+ linkp = addrel (link_pairp, link_pair.header_relp);
+ textp = baseptr (linkp -> linkage_header.stats.segment_number);
+ target_linkagep = null;
+
+ /* validate the definition pointer */
+
+ if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= ITS_MODIFIER
+ then call exit (call_infop, error_table_$no_defs, null);
+ else defp = linkp -> linkage_header.def_ptr;
+
+ /* validate that all first reference traps have been run */
+
+ if linkp -> virgin_linkage_header.first_ref_relp ^= 0
+ then call exit (call_infop, error_table_$first_reference_trap, null);
+
+ /* now that things look reasonably valid, we start decoding the link */
+
+ exprp = addrel (defp, link_pair.expression_relp);
+ type_prp = addrel (defp, expr.type_relp);
+
+ /* first we check the link to see if it should be converted into a */
+ /* *system link. Trap-before links to datmk_ and certain type-6 */
+ /* links are converted to *system links. */
+
+ call convert_trap_link (call_infop, linkp, defp, type_prp, offset_name,
+ init_infop, star_system_sw);
+
+ if star_system_sw
+ then do;
+
+ /* the link either was a *system link, or has become one */
+
+ call star_system (call_infop, link_pairp, defp, linkp, type_prp,
+ offset_name, init_infop, targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, targetp);
+ end;
+
+ /* see if we have a C *heap link */
+
+ if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_HEAP
+ then do;
+
+ /* C *heap links are similar to *system links except that they */
+ /* are allocated separately, and have a level associated with */
+ /* them so that recursive invocations get new copies and they */
+ /* can be released when the invocation returns. */
+
+ call star_heap (call_infop, defp, linkp, type_prp, targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, targetp);
+ end;
+
+ /* now see if there is a trap pointer. Anything with a trap */
+ /* pointer that wasn't converted to a *system link, and isn't a */
+ /* create link, we now treat as a trap-before link, and try to run */
+ /* the trap. */
+
+ if type_pr.type ^= LINK_CREATE_IF_NOT_FOUND & type_pr.trap_relp ^= None
+ then do;
+
+ /* actually is a trap-before link, trap out to the user */
+ /* ring to execute the trap procedure. */
+
+ /* NB. We don't try to complete tracing or metering in this */
+ /* case since it would be rather meaningless anyway. . . */
+
+ call adjust_mc (mcp);
+ call trap_caller_caller_ (mcp, linkp, defp, type_prp, link_pairp,
+ call_info.codep, code);
+
+ /* usually we don't return, but. . . */
+
+ call exit (call_infop, code, baseptr (0));
+ end;
+
+ /* at this point we assume we have a reasonably standard link and */
+ /* can just snap it according to type. */
+
+ if /* case */ type_pr.type = LINK_SELF_BASE
+ then do;
+ call self_reference (call_infop, (type_pr.segname_relp), textp,
+ targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, targetp);
+ end;
+
+ else if type_pr.type = LINK_OBSOLETE_2
+ then call exit (call_infop, error_table_$bad_link_type, null);
+
+ else if type_pr.type = LINK_REFNAME_BASE
+ then do;
+ segnamep = addrel (defp, type_pr.segname_relp);
+ if defp -> definition_header.msf_map_relp ^= None
+ then MSF_sw = true;
+ else MSF_sw = false;
+ call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
+ code);
+ if segp = null
+ then call exit (call_infop, code, null);
+ call snap (segp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, segp);
+ end;
+
+ else if type_pr.type = LINK_REFNAME_OFFSETNAME
+ then do;
+ segnamep = addrel (defp, type_pr.segname_relp);
+ if defp -> definition_header.msf_map_relp ^= None
+ then MSF_sw = true;
+ else MSF_sw = false;
+ call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
+ code);
+ if segp = null
+ then call exit (call_infop, code, null);
+ call condition_ ("seg_fault_error", connect_fail_handler_);
+ call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
+ call get_definition (call_infop, segnamep, offsetnamep, segp,
+ No_retry, target_linkagep, targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call trap (call_infop, target_linkagep, targetp);
+ call exit (call_infop, 0, targetp);
+ end;
+
+ else if type_pr.type = LINK_SELF_OFFSETNAME
+ then do;
+ call self_reference (call_infop, (type_pr.segname_relp), textp,
+ targetp);
+
+ /* insure that segname won't be found */
+
+ segnamep = addr (zero_word);
+ call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
+ call get_definition (call_infop, segnamep, offsetnamep, textp,
+ No_retry, (null), targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, targetp);
+ end;
+
+ else if type_pr.type = LINK_CREATE_IF_NOT_FOUND
+ then do;
+
+ /* NB. since we have already processed the trap case, we will */
+ /* assume that this link can be treated as a type-4 until */
+ /* something breaks. */
+
+ segnamep = addrel (defp, type_pr.segname_relp);
+ if defp -> definition_header.msf_map_relp ^= None
+ then MSF_sw = true;
+ else MSF_sw = false;
+ call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
+ code);
+ if segp = null
+ then do;
+
+ /* OK. something broke. now we try to treat this as a */
+ /* *system link so that the caller will get something. */
+
+ call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
+ if offsetnamep = null
+ then offset_name = segname.string || "$";
+ else offset_name = segname.string || "$" || offsetname.string;
+ if type_pr.trap_relp = 0
+ then init_infop = null;
+ else init_infop = addrel (defp, type_pr.trap_relp);
+ call star_system (call_infop, link_pairp, defp, linkp, type_prp,
+ offset_name, init_infop, targetp);
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call exit (call_infop, 0, targetp);
+ end;
+
+ call condition_ ("seg_fault_error", connect_fail_handler_);
+ call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
+
+ /* dont try to do a definition search if no entrypoint name was given */
+
+ if offsetnamep ^= null
+ then call get_definition (call_infop, segnamep, offsetnamep, segp,
+ No_retry, target_linkagep, targetp);
+ else targetp = segp;
+ call snap (targetp, (expr.expression), link_pairp);
+ call meter (call_infop, (type_pr.type));
+ call trap (call_infop, target_linkagep, targetp);
+ call exit (call_infop, 0, targetp);
+ end;
+
+ else call exit (call_infop, error_table_$bad_link_type, null);
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+make_ptr:
+ entry (a_refp, /** referencing dir ptr (in ) */
+ a_seg_name, /** segname to find (in ) */
+ a_offset_name, /** entrypoint to find (in ) */
+ a_targetp, /** target ptr returned (out) */
+ a_code); /** error code (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: link_snap$make_ptr */
+ /*** Input: refp, seg_name, offset_name */
+ /*** Function: Using the segname and optional offsetname given, */
+ /*** snap a simulated type-3 (if a null offsetname) */
+ /*** or type-4 (if non-null) link and return a pointer */
+ /*** to the target. The reference pointer is passed */
+ /*** to fs_search in order to evaluate the referencing */
+ /*** dir search rule. If it is null, the referencing */
+ /*** dir rule is skipped. */
+ /*** Output: targetp, code */
+ /*** */
+ /*** ****************************************************************/
+
+ /* preset the return values */
+
+ a_targetp = null;
+
+ /* set up the call info */
+
+ call_info.type = Make_ptr;
+
+ goto make_join;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+make_entry:
+ entry (a_refp, /** referencing dir ptr (in ) */
+ a_seg_name, /** segname to find (in ) */
+ a_offset_name, /** entrypoint to find (in ) */
+ a_targete, /** entry returned (out) */
+ a_code); /** error code (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: link_snap$make_entry */
+ /*** Input: refp, seg_name, offset_name */
+ /*** Function: performs the same function as link_snap$make_ptr */
+ /*** except that an entry value is returned instead of */
+ /*** a pointer value. The other difference between */
+ /*** calling make_entry and make_ptr is that if the */
+ /*** offsetname value is null on a call to make_entry */
+ /*** the target linkage section is combined and any */
+ /*** first reference traps run. This is because it is */
+ /*** assumed that if you want an entry returned, you */
+ /*** plan on calling it, and to call it the linkage */
+ /*** section should be combined. */
+ /*** Output: targete, code */
+ /*** */
+ /*** ****************************************************************/
+
+ call_info.type = Make_entry;
+
+ /* preset the returned entry */
+
+ addr (a_targete) -> based_entry.code_ptr = null;
+ addr (a_targete) -> based_entry.env_ptr = null;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+make_join:
+
+ /* meter and trace the make_ptr/make_entry call */
+
+ call usage_values (call_info.start.pf, call_info.start.time);
+ call page$enter_data (baseptr (0), linkage_fault_start);
+
+ /* clear out the metering information */
+
+ call_info.search.time = 0;
+ call_info.search.pf = 0;
+ call_info.get_linkage.time = 0;
+ call_info.get_linkage.pf = 0;
+ call_info.def_search.time = 0;
+ call_info.def_search.pf = 0;
+
+ /* set up the common call_info stuff */
+
+ call_infop = addr (call_info);
+ call_info.codep = addr (a_code);
+ call_info.mcp, mcp = null;
+ call_info.save_ring = -1;
+
+ /* copy the args into automatic storage */
+
+ refp = a_refp;
+ seg_name = a_seg_name;
+ offset_name = a_offset_name;
+
+ /* preset the return code */
+
+ a_code = 0;
+
+ /* try to determine whether the ref pointer refers to an MSF */
+
+ if refp = null
+ then MSF_sw = false;
+ else do;
+ call link_man$own_linkage (ptr (refp, 0), linkp, null, null, code);
+ if code ^= 0
+ then MSF_sw = false;
+ else if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^=
+ ITS_MODIFIER
+ then MSF_sw = false;
+ else do;
+ defp = linkp -> linkage_header.def_ptr;
+ if defp -> definition_header.msf_map_relp ^= None
+ then MSF_sw = true;
+ else MSF_sw = false;
+ end;
+ end;
+
+ /* search for the segment */
+
+ call fs_search (refp, seg_name, MSF_sw, segp, code);
+ if code ^= 0
+ then call exit (call_infop, code, null);
+
+ /* set up to handle connection failure gracefully */
+
+ call condition_ ("seg_fault_error", connect_fail_handler_);
+
+ nchars = length (rtrim (offset_name));
+
+ if nchars = 0
+ then do;
+
+ /* no offsetname, so just meter, finish tracing and return */
+
+ if call_info.type = Make_ptr
+ then call meter (call_infop, (LINK_REFNAME_BASE));
+ else do;
+
+ /* if we are returning an entry, we must combine the */
+ /* target linkage section first. If we combine the linkage */
+ /* section we should run any first reference traps. */
+
+ call combine_linkage (call_infop, segp, (null), target_linkagep,
+ (null), (null));
+ call meter (call_infop, (LINK_REFNAME_BASE));
+ call trap (call_infop, target_linkagep, segp);
+ end;
+ call exit (call_infop, 0, segp);
+ end;
+
+ /* set up the segname/offsetname pointers */
+
+ segnamep = addr (automatic_segname);
+ offsetnamep = addr (automatic_offsetname);
+
+ /* clear them out */
+
+ unspec (automatic_segname) = ""b;
+ unspec (automatic_offsetname) = ""b;
+
+ /* save the passed segname/offsetname values */
+
+ automatic_segname.count = length (rtrim (seg_name));
+ substr (automatic_segname.string, 1, automatic_segname.count) =
+ substr (seg_name, 1, automatic_segname.count);
+
+ automatic_offsetname.count = length (rtrim (offset_name));
+ substr (automatic_offsetname.string, 1, automatic_offsetname.count) =
+ substr (offset_name, 1, automatic_offsetname.count);
+
+ /* if the offsetname and segname are the same, we want */
+ /* get_definition to retry using the offsetname "main_" */
+ /* if this attempt fails */
+
+ if seg_name = offset_name
+ then retry_sw = Will_retry;
+ else retry_sw = No_retry;
+
+ call get_definition (call_infop, segnamep, offsetnamep, segp, retry_sw,
+ target_linkagep, targetp);
+
+ call meter (call_infop, (LINK_REFNAME_OFFSETNAME));
+ call trap (call_infop, target_linkagep, targetp);
+ call exit (call_infop, 0, targetp);
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+convert_trap_link:
+ proc (infop, /** call info pointer (in ) */
+ linkp, /** linkage pointer (in ) */
+ defp, /** definition pointer (in ) */
+ type_prp, /** type_pair pointer (in ) */
+ offset_name, /** entrypoint name (out) */
+ init_infop, /** init_info pointer (out) */
+ star_system_sw); /** *system or mapped (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: convert_trap_link */
+ /*** Input: infop, linkp, defp, type_prp */
+ /*** Function: determines whether the link in question has a */
+ /*** trap_relp value. If it does, then the link is */
+ /*** a probably a *system link (type-5, class-5) or */
+ /*** should should be treated as one. If it is not */
+ /*** not a *system link, and should be, we determine */
+ /*** what the offset_name to be found is and what the */
+ /*** init_info pointer should be and then set the flag */
+ /*** to indicate that this is to be snapped as a */
+ /*** *system link. */
+ /*** Output: offset_name, init_infop, star_system_sw */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl linkp ptr parameter;
+ dcl defp ptr parameter;
+ dcl type_prp ptr parameter;
+ dcl offset_name char (256) parameter;
+ dcl init_infop ptr parameter;
+ dcl star_system_sw bit (1) parameter;
+
+ /* based */
+
+ dcl based_ptr ptr based;
+ dcl 01 offsetname aligned based (offsetnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (offsetname.count) unaligned;
+ dcl 01 segname aligned based (segnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (segname.count) unaligned;
+ dcl 01 trap aligned like link_trap_pair based (trapp);
+ dcl 01 type_pr aligned like type_pair based (type_prp);
+
+ /* automatic */
+
+ dcl code fixed bin (35) automatic;
+ dcl init_linkp ptr automatic;
+ dcl offsetnamep ptr automatic;
+ dcl segnamep ptr automatic;
+ dcl trapp ptr automatic;
+
+ segnamep = addrel (defp, type_pr.segname_relp);
+ offsetnamep = addrel (defp, type_pr.offsetname_relp);
+
+ /* preset output variables */
+
+ star_system_sw = false;
+ offset_name = offsetname.string;
+ if type_pr.trap_relp = None
+ then init_infop = null;
+ else init_infop = addrel (defp, type_pr.trap_relp);
+
+ /* first see if it is actually a *system link */
+
+ if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_SYSTEM
+ then do;
+ star_system_sw = true;
+ return;
+ end;
+
+ /* now check the conditions for converting a type 6 link */
+
+ if type_pr.type = LINK_CREATE_IF_NOT_FOUND
+ then do;
+
+ /* check for pl1 ext static */
+
+ if segname.string = "stat_"
+ then do;
+ star_system_sw = true;
+ return;
+ end;
+
+ /* check for fortran common blocks */
+
+ if offsetname.count = 0
+ then if index (segname.string, ".com") = segname.count - 3
+ then do;
+ star_system_sw = true;
+ offset_name = substr (segname.string, 1, segname.count - 4);
+ if offset_name = "b_" /* blank common */
+ then offset_name = "blnk*com";
+ return;
+ end;
+ else ;
+
+ /* check for cobol FSB link */
+
+ else if segname.string = "cobol_fsb_"
+ then do;
+ offset_name = "cobol_fsb_" || offsetname.string;
+ star_system_sw = true;
+ return;
+ end;
+ end;
+
+ if type_pr.type = LINK_REFNAME_OFFSETNAME & type_pr.trap_relp ^= None
+ then do;
+
+ /* if we have a type 4 link with a trap-before link to datmk_ */
+ /* we force-snap the info-link of the trap, use that as the */
+ /* init_info pointer and use the offsetname from the original */
+ /* link as the name and then treat as a *system link. */
+
+ trapp = addrel (defp, type_pr.trap_relp);
+ if segname.string = "stat_"
+ then if addrel (defp,
+ addrel (defp,
+ addrel (defp, addrel (linkp, trap.call_relp)
+ -> object_link.expression_relp)
+ -> exp_word.type_relp)
+ -> type_pair.segname_relp) -> acc_string.string = "datmk_"
+ then do;
+ init_linkp = addrel (linkp, trap.info_relp);
+
+ /* snap the info link */
+
+ call link_force (init_linkp, 0, code);
+ if code ^= 0
+ then call exit (call_infop, code, null);
+
+ init_infop = init_linkp -> based_ptr;
+ star_system_sw = true;
+ end;
+ end;
+
+ end convert_trap_link;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+star_system:
+ proc (infop, /** call_info pointer (in ) */
+ link_pairp, /** pointer to link (in ) */
+ defp, /** definition pointer (in ) */
+ linkp, /** linkage pointer (in ) */
+ type_prp, /** type_pair pointer (in ) */
+ offset_name, /** ext var name string (in ) */
+ init_infop, /** init_info pointer (in ) */
+ targetp); /** target variable (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: star_system */
+ /*** Input: infop, link_pairp, defp, linkp, type_prp, */
+ /*** offset_name, init_infop */
+ /*** Function: determines the target of a *system link. This */
+ /*** procedure calls set_ext_variable_ to return the */
+ /*** variable_node which defines the named external */
+ /*** variable, and then returns a pointer to the var */
+ /*** itself. */
+ /*** Output: targetp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl link_pairp ptr parameter;
+ dcl defp ptr parameter;
+ dcl linkp ptr parameter;
+ dcl type_prp ptr parameter;
+ dcl offset_name char (256) parameter;
+ dcl init_infop ptr parameter;
+ dcl targetp ptr parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+
+ /* automatic */
+
+ dcl code fixed bin (35) automatic;
+ dcl sb ptr automatic;
+
+ /* set the stack base pointer */
+
+ if info.mcp = null
+ then sb = pds$stacks (level$get ());
+ else sb = ptr (info.mcp -> mc.prs (6), 0);
+
+ /* check to see if this variable has a deferred initialization type */
+
+ call deferred_init (infop, init_infop, linkp);
+
+ /* now call set_ext_variable_ to get the variable node. Note that */
+ /* this call may not return if the target is an uninitialized VLA, */
+ /* since this requires a call to fortran_storage_manager_. We cant */
+ /* call this in ring 0 so we trap out to the user ring to call out */
+ /* to set up the VLA. The fortran_storage_manager_ is responsible */
+ /* for completing the link snap. */
+
+ call set_ext_variable_$for_linker (offset_name, init_infop, sb,
+ ptr (init_infop, 0), ("0"b), targetp, code, info.mcp, def_ptr,
+ type_prp, link_pairp);
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ /* get a pointer to the actual variable instead of the node */
+
+ targetp = targetp -> variable_node.vbl_ptr;
+
+ end star_system;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+star_heap:
+ proc (infop, /** call_info pointer (in ) */
+ defp, /** def section ptr (in ) */
+ linkp, /** linkage section ptr (in ) */
+ type_prp, /** type_pair pointer (in ) */
+ targetp); /** target pointer (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: star_heap */
+ /*** Input: infop, defp, linkp, type_prp */
+ /*** Function: given a pointer to the type_pair and definition */
+ /*** section for a link, get the offsetname and init */
+ /*** info pointer and call set_ext_variable_$star_heap */
+ /*** to find or create the variable. */
+ /*** Output: targetp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl defp ptr parameter;
+ dcl linkp ptr parameter;
+ dcl type_prp ptr parameter;
+ dcl targetp ptr parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+ dcl 01 offsetname aligned based (offsetnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (offsetname.count) unaligned;
+ dcl 01 type_pr aligned like type_pair based (type_prp);
+
+ /* automatic */
+
+ dcl init_infop ptr automatic;
+ dcl offsetnamep ptr automatic;
+ dcl sb ptr automatic;
+ dcl offset_name char (256) automatic;
+
+ /* extract the variable name and init_info pointer */
+
+ offsetnamep = addrel (defp, type_pr.offsetname_relp);
+ offset_name = offsetname.string;
+
+ if type_pr.trap_relp = None
+ then init_infop = null;
+ else init_infop = addrel (defp, type_pr.trap_relp);
+
+ /* get the stack base pointer */
+
+ if info.mcp = null
+ then sb = pds$stacks (level$get ());
+ else sb = ptr (info.mcp -> mc.prs (6), 0);
+
+ /* get new init_info pointer if initialization type = INIT_DEFERRED */
+
+ call deferred_init (infop, init_infop, linkp);
+
+ /* call set_ext_variable_$star_heap to allocate the variable and */
+ /* return a node ptr */
+
+ call set_ext_variable_$star_heap (offset_name, init_infop, sb,
+ ptr (init_infop, 0), ("0"b), targetp, code);
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ /* set the target to point to the variable itself */
+
+ targetp = targetp -> variable_node.vbl_ptr;
+
+ end star_heap;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+deferred_init:
+ proc (infop, /** call_info pointer (in ) */
+ init_infop, /** init_info pointer (i/o) */
+ linkp); /** linkage section ptr (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: deferred_init */
+ /*** Input: infop, init_infop, linkp */
+ /*** Function: locates the initialization info for deferred init */
+ /*** external or heap initialization. The procedure */
+ /*** for deferred initialization is as follows: */
+ /*** - check to see if the init type is deferred. */
+ /*** - if so, extract the target_relp and link_relp */
+ /*** from the init_info. */
+ /*** - make sure the link referenced by target_relp */
+ /*** has been snapped. */
+ /*** - chase the link to find the target segments */
+ /*** linkage header. */
+ /*** - extract the def_ptr and original_linkage_ptr */
+ /*** from the linkage_header. */
+ /*** - apply the link_relp to the original_linkage */
+ /*** pointer to find the unsnapped link. */
+ /*** - extract a pointer to the init_info from the */
+ /*** def_ptr and type_pair. */
+ /*** - return the actual init_info pointer. */
+ /*** Output: init_infop */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl init_infop ptr parameter;
+ dcl linkp ptr parameter;
+
+ /* based */
+
+ dcl 01 lh aligned like linkage_header based (lhp);
+ dcl based_ptr ptr based;
+ dcl 01 type_pr aligned like type_pair based (type_prp);
+ dcl 01 expr aligned like exp_word based (exprp);
+ dcl 01 link_pair aligned like object_link based (link_pairp);
+ dcl 01 init_info aligned like link_init_deferred
+ based (init_infop);
+
+ /* automatic */
+
+ dcl target_ptr_ptr ptr automatic;
+ dcl lhp ptr automatic;
+ dcl exprp ptr automatic;
+ dcl type_prp ptr automatic;
+ dcl link_pairp ptr automatic;
+
+ /* if no init_info, or init_info is not deferred, just return */
+
+ if init_infop = null
+ then return;
+
+ if init_info.header.type ^= INIT_DEFERRED
+ then return;
+
+ /* get the target partial link and make sure it is snapped */
+
+ target_ptr_ptr = addrel (linkp, init_info.target_relp);
+ if target_ptr_ptr -> its.its_mod ^= ITS_MODIFIER
+ then call exit (infop, error_table_$bad_deferred_init, null);
+
+ /* make sure the target of the link looks somewhat like a linkage */
+ /* header and that the definition pointer is a pointer */
+
+ lhp = target_ptr_ptr -> based_ptr;
+ if addr (lh.def_ptr) -> its.its_mod ^= ITS_MODIFIER
+ then call exit (infop, error_table_$no_defs, null);
+ else defp = lh.def_ptr;
+
+ /* get a pointer to the link specified in the original linkage */
+ /* section and make sure it looks like an unsnapped link. */
+
+ link_pairp = addrel (lh.original_linkage_ptr, init_info.link_relp);
+ if link_pair.tag ^= FAULT_TAG_2
+ then call exit (infop, error_table_$bad_deferred_init, null);
+
+ /* now decode the link and get a pointer to the init_info */
+
+ exprp = addrel (defp, link_pair.expression_relp);
+ type_prp = addrel (defp, expr.type_relp);
+ if type_pr.trap_relp = None
+ then init_infop = null;
+ else init_infop = addrel (defp, type_pr.trap_relp);
+
+ end deferred_init;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+self_reference:
+ proc (infop, /** call_info pointer (in ) */
+ class, /** link class (in ) */
+ textp, /** segment pointer (in ) */
+ targetp); /** section pointer (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: self_reference */
+ /*** Input: infop, class, textp */
+ /*** Function: given a link class and a pointer to the owners */
+ /*** text_section, get the other section pointers and */
+ /*** return a pointer to the section specified by the */
+ /*** class of the link. */
+ /*** Output: targetp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl class fixed bin (18) unsigned parameter;
+ dcl textp ptr parameter;
+ dcl targetp ptr parameter;
+
+ /* automatic */
+
+ dcl code fixed bin (35) automatic;
+ dcl linkp ptr automatic;
+ dcl staticp ptr automatic;
+ dcl symbolp ptr automatic;
+
+ /* get pointers to the various sections */
+
+ call link_man$own_linkage (textp, linkp, staticp, symbolp, code);
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ /* return the section pointer based on the link class */
+
+ if /* case */ class = CLASS_TEXT
+ then targetp = textp;
+ else if class = CLASS_LINKAGE
+ then targetp = linkp;
+ else if class = CLASS_STATIC
+ then targetp = staticp;
+ else if class = CLASS_SYMBOL
+ then targetp = symbolp;
+ else call exit (infop, error_table_$bad_self_ref, null);
+
+ end self_reference;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+search_for_segment:
+ proc (infop, /** call_info pointer (in ) */
+ segnamep, /** segname acc pointer (in ) */
+ refp, /** referencing pointer (in ) */
+ MSF_sw, /** is caller an MSF (in ) */
+ segp, /** found segment ptr (out) */
+ code); /** error code (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: search_for_segment */
+ /*** Input: infop, segnamep, refp */
+ /*** Function: calls fs_search to search for the refname given */
+ /*** by the acc_string pointer to by segnamep, and */
+ /*** meters the call. */
+ /*** Output: segp, code */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl segnamep ptr parameter;
+ dcl refp ptr parameter;
+ dcl MSF_sw bit (1) aligned parameter;
+ dcl segp ptr parameter;
+ dcl code fixed bin (35) parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+ dcl 01 segname aligned based (segnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (segname.count) unaligned;
+
+ /* automatic */
+
+ dcl 01 finish aligned like usage automatic;
+ dcl 01 start aligned like usage automatic;
+
+ /* do the search and meter the time an pagewaits */
+
+ call usage_values (start.pf, start.time);
+
+ call fs_search (refp, segname.string, MSF_sw, segp, code);
+
+ call usage_values (finish.pf, finish.time);
+
+ /* calculate the metering info and add it to the search metering */
+
+ info.search.pf = info.search.pf + (finish.pf - start.pf);
+ info.search.time = info.search.time + (finish.time - start.time);
+
+ end search_for_segment;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+get_offsetnamep:
+ proc (infop, /** call_info pointer (in ) */
+ defp, /** definition pointer (in ) */
+ type_prp, /** type_pair pointer (in ) */
+ offsetnamep); /** offsetname pointer (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: get_offsetnamep */
+ /*** Input: infop, defp, type_prp */
+ /*** Function: extract a pointer to the offsetname for the link */
+ /*** from the type_pair. If there is no offsetname */
+ /*** or the type is 6 and the offset name length is 0, */
+ /*** the null pointer is returned. */
+ /*** Output: offsetnamep */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl defp ptr parameter;
+ dcl type_prp ptr parameter;
+ dcl offsetnamep ptr parameter;
+
+ /* based */
+
+ dcl 01 offsetname aligned based (offsetnamep),
+ 02 count fixed bin (9) unsigned unaligned,
+ 02 string char (offsetname.count) unaligned;
+ dcl 01 type_pr aligned like type_pair based (type_prp);
+
+ if type_pr.offsetname_relp = None
+ then offsetnamep = null;
+ else do;
+
+ /* type-6 links use a valid acc_string with a zero length instead. */
+
+ offsetnamep = addrel (defp, type_pr.offsetname_relp);
+ if type_pr.type = LINK_CREATE_IF_NOT_FOUND & offsetname.count = 0
+ then offsetnamep = null;
+ end;
+
+ end get_offsetnamep;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+combine_linkage:
+ proc (infop, /** call_info pointer (in ) */
+ segp, /** target segment ptr (in ) */
+ textp, /** text section ptr (out) */
+ linkp, /** linkage section ptr (out) */
+ statp, /** static section ptr (out) */
+ symbp); /** symbol section ptr (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: combine_linkage */
+ /*** Input: infop, segp */
+ /*** Function: given a pointer to a segment (segp), combine the */
+ /*** linkage section (if necessary) and return the */
+ /*** pointers to the various sections. This routine */
+ /*** also meters the call. */
+ /*** Output: textp, linkp, statp, symbp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl segp ptr parameter;
+ dcl textp ptr parameter;
+ dcl linkp ptr parameter;
+ dcl statp ptr parameter;
+ dcl symbp ptr parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+
+ /* automatic */
+
+ dcl 01 finish aligned like usage automatic;
+ dcl 01 start aligned like usage automatic;
+
+ /* combine the linkage section and meter the time and pagewaits */
+
+ call usage_values (start.pf, start.time);
+
+ textp = ptr (segp, 0);
+ call link_man$other_linkage (textp, linkp, statp, symbp, code);
+
+ call usage_values (finish.pf, finish.time);
+
+ /* add in to metering info */
+
+ info.get_linkage.pf = info.get_linkage.pf + (finish.pf - start.pf);
+ info.get_linkage.time = info.get_linkage.time + (finish.time - start.time);
+
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ if linkp = null
+ then call exit (infop, error_table_$no_linkage, null);
+
+ end combine_linkage;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+get_definition:
+ proc (infop, /** call_info pointer (in ) */
+ segnamep, /** segname acc ptr (in ) */
+ offsetnamep, /** offsetname acc ptr (in ) */
+ segp, /** segment to search (in ) */
+ retry, /** will retry "main_" (in ) */
+ target_linkagep, /** linkp of target seg (out) */
+ targetp); /** target pointer (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: get_definition */
+ /*** Input: infop, segnamep, offsetnamep, segp, retry */
+ /*** Function: combines the linkage section for the segment */
+ /*** specified, and then searches the definition */
+ /*** section for a definition matching the segname */
+ /*** and offsetname given and meters the search. */
+ /*** A pointer to the definition target is then */
+ /*** generated based on the definition class, the */
+ /*** section pointers returned by combining the */
+ /*** linkage, and the definition offset. If the */
+ /*** search fails and the retry flag is set, we */
+ /*** try another search for the entrypoint "main_". */
+ /*** Output: targetp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* constant */
+
+ dcl 01 main_acc aligned static options (constant),
+ 02 count fixed bin (9) unsigned unaligned init (5),
+ 02 string char (5) unaligned init ("main_");
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl segnamep ptr parameter;
+ dcl offsetnamep ptr parameter;
+ dcl retry bit (1) parameter;
+ dcl target_linkagep ptr parameter;
+ dcl segp ptr parameter;
+ dcl targetp ptr parameter;
+
+ /* based */
+
+ dcl based_ptr ptr based;
+ dcl 01 def aligned like definition based (defp);
+ dcl 01 info aligned like call_info based (infop);
+
+ /* automatic */
+
+ dcl code fixed bin (35) automatic;
+ dcl defp ptr automatic;
+ dcl 01 finish aligned like usage automatic;
+ dcl linkp ptr automatic;
+ dcl 01 start aligned like usage automatic;
+ dcl statp ptr automatic;
+ dcl symbp ptr automatic;
+ dcl textp ptr automatic;
+
+ /* if we have no name to search for, don't bother trying */
+
+ if offsetnamep = null
+ then return;
+
+ /* combine the linkage section and get the section pointers */
+
+ call combine_linkage (infop, segp, textp, linkp, statp, symbp);
+
+ /* save the linkage pointer in case we have first reference traps to run */
+
+ target_linkagep = linkp;
+
+ call usage_values (start.pf, start.time);
+ call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep, offsetnamep,
+ defp, code);
+ call usage_values (finish.pf, finish.time);
+
+ /* update the metering info */
+
+ info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
+ info.def_search.time = info.def_search.time + (finish.time - start.time);
+
+ if retry & code = error_table_$no_ext_sym
+ then do;
+
+ /* retry the search with an offsetname of "main_" */
+
+ call usage_values (start.pf, start.time);
+ call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep,
+ addr (main_acc), defp, code);
+ call usage_values (finish.pf, finish.time);
+
+ /* add to the metering info */
+
+ info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
+ info.def_search.time = info.def_search.time + (finish.time - start.time);
+
+ end;
+
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ /* check for an indirect definition */
+
+ if def.indirect
+ then do;
+
+ /* an indirect definition (used only in component 0 of an */
+ /* object MSF) is used to refer to something in another */
+ /* component by adding another indirection through a partial */
+ /* link. In this case the thing_relp is the offset in the */
+ /* linkage section of a partial link to the actual definition */
+ /* target. In some cases this link will have been snapped */
+ /* already by the msf_prelink_ first reference trap, if not, we */
+ /* snap the link, and then use the indirection to give us our */
+ /* definition target. */
+
+ if def.class ^= CLASS_LINKAGE
+ then call exit (infop, error_table_$bad_indirect_def, null);
+
+ /* if the link is snapped, just get the value and return */
+
+ targetp = addrel (linkp, def.thing_relp);
+ if targetp -> its.its_mod = ITS_MODIFIER
+ then do;
+ targetp = targetp -> based_ptr;
+ return;
+ end;
+
+ /* if not make sure it is a partial link */
+
+ if targetp -> its.its_mod ^= FAULT_TAG_3
+ then call exit (infop, error_table_$bad_indirect_def, null);
+
+ /* then snap it, get the value and return */
+
+ call snap_partial_link (infop, targetp, textp);
+ targetp = targetp -> based_ptr;
+ return;
+ end;
+
+ /* calculate the target based on the definition class and offset */
+
+ if /* case */ def.class = CLASS_TEXT
+ then targetp = addrel (textp, def.thing_relp);
+ else if def.class = CLASS_LINKAGE
+ then targetp = addrel (linkp, def.thing_relp);
+ else if def.class = CLASS_STATIC
+ then targetp = addrel (statp, def.thing_relp);
+ else if def.class = CLASS_SYMBOL
+ then targetp = addrel (symbp, def.thing_relp);
+ else call exit (infop, error_table_$bad_class_def, null);
+
+ end get_definition;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+snap_partial_link:
+ proc (infop, /** call_info pointer (in ) */
+ link_pairp, /** link pair to snap (i/o) */
+ refp); /** ref ptr for search (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: snap_partial_link */
+ /*** Input: infop, link_pairp, refp */
+ /*** Function: snaps a partial link to another component in */
+ /*** the same directory. */
+ /*** Output: link_pairp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl link_pairp ptr parameter;
+ dcl refp ptr parameter;
+
+ /* based */
+
+ dcl based_ptr ptr based;
+ dcl 01 info aligned like call_info based (infop);
+ dcl 01 link_pair aligned like partial_link based (link_pairp);
+
+ /* automatic */
+
+ dcl 01 finish aligned like usage automatic;
+ dcl linkp ptr automatic;
+ dcl refname char (32) automatic;
+ dcl 01 start aligned like usage automatic;
+ dcl statp ptr automatic;
+ dcl symbp ptr automatic;
+ dcl textp ptr automatic;
+
+ /* get the name of the other component */
+
+ refname = ltrim (char (link_pair.component));
+
+ /* perform the search and meter the time and pagewaits */
+
+ call usage_values (start.pf, start.time);
+ call fs_search$same_directory (refp, refname, segp, code);
+ call usage_values (finish.pf, finish.time);
+
+ /* update the metering info */
+
+ info.search.pf = info.search.pf + (finish.pf - start.pf);
+ info.search.time = info.search.time + (finish.time - start.time);
+
+ /* if we didn't find it, something is broken . . . */
+
+ if code ^= 0
+ then call exit (infop, code, null);
+
+ /* combine the target linkage section */
+
+ call combine_linkage (infop, segp, textp, linkp, statp, symbp);
+
+ /* now snap the link based on the type and offset in the link */
+
+ if /* case */ link_pair.type = CLASS_TEXT
+ then link_pairp -> based_ptr = addrel (textp, link_pair.offset);
+ else if link_pair.type = CLASS_LINKAGE
+ then link_pairp -> based_ptr = addrel (linkp, link_pair.offset);
+ else if link_pair.type = CLASS_STATIC
+ then link_pairp -> based_ptr = addrel (statp, link_pair.offset);
+ else if link_pair.type = CLASS_SYMBOL
+ then link_pairp -> based_ptr = addrel (symbp, link_pair.offset);
+ else call exit (infop, error_table_$bad_indirect_def, null);
+
+ end snap_partial_link;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+snap:
+ proc (targetp, /** value to snap to (in ) */
+ expression, /** offset to add (in ) */
+ link_pairp); /** link pair to snap (i/o) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: snap */
+ /*** Input: targetp, expression, link_pairp */
+ /*** Function: completes the snapping of the link and sets */
+ /*** targetp to point to the same value as the snapped */
+ /*** link; */
+ /*** Output: targetp, link_pairp */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl targetp ptr parameter;
+ dcl expression fixed bin (17) parameter;
+ dcl link_pairp ptr parameter;
+
+ /* based */
+
+ dcl 01 link_as_its aligned like its based (link_pairp);
+ dcl 01 link_pair aligned like object_link based (link_pairp);
+ dcl link_ptr ptr based (link_pairp);
+
+ /* automatic */
+
+ dcl modifier bit (6) automatic;
+ dcl sb ptr automatic;
+
+ /* add in the expression value */
+
+ targetp = addrel (targetp, expression);
+
+ /* get the original modifier from the link */
+
+ modifier = link_pair.modifier;
+
+ /* store the new pointer back into the link */
+
+ link_ptr = targetp;
+
+ /* put the link modifier back in */
+
+ link_as_its.mod = modifier;
+
+ /* put the run-depth into the pointer */
+
+ sb = pds$stacks (level$get ());
+ link_pair.run_depth = sb -> stack_header.run_unit_depth;
+
+ end snap;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+meter:
+ proc (infop, /** call_info pointer (in ) */
+ type); /** link type (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: meter */
+ /*** Input: infop, type */
+ /*** Function: given the call_info structure containing the */
+ /*** metering info for the last call, and the type of */
+ /*** link snapped, update the perprocess link meters */
+ /*** in pds and the system_wide meters in ahd. */
+ /*** Output: none */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl type fixed bin (18) unsigned parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+ dcl 01 lm aligned like link_meters based (lmp);
+
+ /* automatic */
+
+ dcl elapsed_time fixed bin (35) automatic;
+ dcl elapsed_pf fixed bin (30) automatic;
+ dcl bin_no fixed bin automatic;
+ dcl lmp ptr automatic;
+
+ /* get the final metering values */
+
+ call usage_values (info.finish.pf, info.finish.time);
+
+ /* calculate the elapsed time and pagewaits */
+
+ elapsed_time = bin (info.finish.time - info.start.time, 35);
+ elapsed_pf = bin (info.finish.pf - info.start.pf, 30);
+
+ /* determine which bin this fault goes into */
+
+ bin_no = max (1, min (4, divide (elapsed_time, 25000, 17, 0) + 1));
+
+ /* update the counts in pds */
+
+ pds$link_meters_bins (bin_no) = pds$link_meters_bins (bin_no) + 1;
+ pds$link_meters_pgwaits (bin_no) = pds$link_meters_pgwaits (bin_no) +
+ elapsed_pf;
+ pds$link_meters_times (bin_no) = pds$link_meters_times (bin_no) +
+ elapsed_time;
+
+ /* update the ahd link meters */
+
+ lmp = addr (ahd$link_meters (bin_no));
+
+ lm.total = lm.total + 1;
+ lm.pf = lm.pf + elapsed_pf;
+ lm.time = lm.time + elapsed_time;
+
+ if /* case */ (info.type = Link_fault | info.type = Link_force) &
+ (type = LINK_REFNAME_BASE | type = LINK_REFNAME_OFFSETNAME)
+ then do;
+ lm.search_pf = lm.search_pf + info.search.pf;
+ lm.search_time = lm.search_time + info.search.time;
+ lm.get_linkage_pf = lm.get_linkage_pf + info.get_linkage.pf;
+ lm.get_linkage_time = lm.get_linkage_time + info.get_linkage.time;
+ lm.defsearch_pf = lm.defsearch_pf + info.def_search.pf;
+ lm.defsearch_time = lm.defsearch_time + info.def_search.time;
+ end;
+ else if type = LINK_CREATE_IF_NOT_FOUND
+ then do;
+ lm.total_type_6 = lm.total_type_6 + 1;
+ lm.type_6_pf = lm.type_6_pf + elapsed_pf;
+ lm.type_6_time = lm.type_6_time + elapsed_time;
+ end;
+ else do;
+ if info.type = Make_entry | info.type = Make_ptr
+ then lm.tot_make_ptr = lm.tot_make_ptr + 1;
+ lm.total_others = lm.total_others + 1;
+ lm.others_pf = lm.others_pf + elapsed_pf;
+ lm.others_time = lm.others_time + elapsed_time;
+ end;
+
+ end meter;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+trap:
+ proc (infop, /** call_info pointer (in ) */
+ target_linkagep, /** target linkage scn (in ) */
+ targetp); /** return value (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: trap */
+ /*** Input: infop, target_linkagep, targetp */
+ /*** Function: executes first reference traps in the target of */
+ /*** the link snapped. Since this operation involves */
+ /*** calling back out to the user ring, we set fix up */
+ /*** the maching conditions, error codes, and return */
+ /*** values prior to calling trap_caller_caller_. */
+ /*** If there are no traps, we return and exit through */
+ /*** the normal mechanism. */
+ /*** Output: none */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl target_linkagep ptr parameter;
+ dcl targetp ptr parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+
+ /* now we see if we have first reference traps to run in the target */
+ /* of the link we just finished snapping. */
+
+ if target_linkagep ^= null
+ then do;
+ if target_linkagep -> virgin_linkage_header.first_ref_relp ^= None
+ then do;
+
+ /* we adjust the machine conditions now, since we won't */
+ /* return from trap_caller_caller_ . . . */
+
+ call adjust_mc (mcp);
+
+ /* set the return values */
+
+ if info.type ^= Link_fault
+ then a_code = 0;
+
+ if /* case */ info.type = Make_ptr
+ then a_targetp = targetp;
+ else if info.type = Make_entry
+ then addr (a_targete) -> based_entry.code_ptr = targetp;
+
+ /* now we complete tracing of the fault, since the trap */
+ /* should not return. */
+
+ call page$enter_data ((targetp), linkage_fault_end);
+
+ /* trap back to the user ring and execute the firstref traps */
+
+ call trap_caller_caller_ (info.mcp, target_linkagep, null,
+ null, null, info.codep, code);
+
+ /* just in case we returned. . . */
+
+ if info.mcp ^= null
+ then call exit (infop, code, null);
+ end;
+
+ end;
+
+ end trap;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+adjust_mc:
+ proc (mcp); /** machine conditions (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: adjust_mc */
+ /*** Input: mcp */
+ /*** Function: adjusts the fault machine conditions so that the */
+ /*** fault can be restarted. */
+ /*** Output: none. */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl mcp ptr parameter;
+
+ /* based */
+
+ dcl 01 instr aligned based (instrp),
+ 02 address bit (18) unaligned,
+ 02 op_code bit (12) unaligned,
+ 02 modifier bit (6) unaligned;
+
+ /* automatic */
+
+ dcl scup ptr automatic;
+ dcl instrp ptr automatic;
+
+ /* don't try fixing machine conditions that aren't there. . . */
+
+ if mcp = null
+ then return;
+
+ scup = addr (mcp -> mc.scu);
+ instrp = addr (scup -> scu.even_inst);
+ instr.address = scup -> scu.ca;
+ instr.modifier = indirect;
+
+ end adjust_mc;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+connect_fail_handler_:
+ proc (a_mcp, /** machine conditions (in ) */
+ a_condition_name, /** condition name (in ) */
+ a_wcp, /** crawlout info (in ) */
+ a_infop, /** condition info (in ) */
+ a_continue_flag); /** continue flag (out) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: connect_fail_handler_ */
+ /*** Input: mcp, condition_name, wcp, infop, continue_flag */
+ /*** Function: handles the seg_fault condition. This handler */
+ /*** in enabled prior to the definition search in */
+ /*** type-4 and type-6 links. When invoked, the */
+ /*** faulting segment is compared with the global */
+ /*** variable segp, it the segments are not the same, */
+ /*** this means we have faulted somewhere unexpected, */
+ /*** so we continue to signal. If the fault occurred */
+ /*** on the expected segment, we assume it is because */
+ /*** of a connection failure and simply return abort */
+ /*** the link fault returning the appropriate code. */
+ /*** */
+ /*** NB. Because of the machanism involved, this */
+ /*** procedure assumes that the global variables */
+ /*** segp and call_infop are set prior to the */
+ /*** establishment of the condition handler. */
+ /*** Output: none */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl a_mcp ptr parameter;
+ dcl a_condition_name char (*) parameter;
+ dcl a_wcp ptr parameter;
+ dcl a_infop ptr parameter;
+ dcl a_continue_flag bit (1) parameter;
+
+ /* automatic */
+
+ dcl faulted_segno fixed bin (18) automatic;
+ dcl segno fixed bin (18) automatic;
+ dcl scup ptr automatic;
+
+ /* get the segment numbers of the faulting segment and the target */
+ /* segment of the current link snapping operation */
+
+ a_continue_flag = false;
+ scup = addr (a_mcp -> mc.scu);
+ faulted_segno = bin (scup -> scu.tpr.tsr, 18);
+ segno = bin (baseno (segp), 18);
+
+ /* if they are different, continue to signal */
+
+ if faulted_segno ^= segno
+ then do;
+ a_continue_flag = true;
+ return;
+ end;
+
+ /* otherwise assume a connection failure, and return the code */
+
+ connect_fail_code = a_mcp -> mc.errcode;
+
+ /* NB. here we set a global code and do a non-local goto which */
+ /* then calls the exit procedure rather than calling exit */
+ /* directly in order to keep the exit and adjust_mc procedures */
+ /* as quick procedures. */
+
+ goto CONNECT_FAIL_EXIT;
+
+ end connect_fail_handler_;
+
+CONNECT_FAIL_EXIT:
+ call exit (call_infop, connect_fail_code, null);
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+\f
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+exit:
+ proc (infop, /** call_info pointer (in ) */
+ code, /** code to return (in ) */
+ targetp); /** target (for trace) (in ) */
+
+ /*** ****************************************************************/
+ /*** */
+ /*** Name: exit */
+ /*** Input: info, code, targetp */
+ /*** Function: returns from the fault or gate entry and cleans */
+ /*** up. This procedure differs depending on where */
+ /*** we entered from: */
+ /*** link_fault - save the code in the machine */
+ /*** conditions, adjust the machine */
+ /*** conditions to allow restart, reset */
+ /*** the validation level back, */
+ /*** complete the fault trace, and exit */
+ /*** link_force - set the code to be returned, */
+ /*** complete the fault trace, and exit */
+ /*** make_ptr - set the return pointer and code, */
+ /*** complete the fault trace, and exit */
+ /*** make_entry - set the return entry and code, */
+ /*** complete the fault trace, and exit */
+ /*** */
+ /*** NB. When completing the fault trace, the code to */
+ /*** be returned is examined. If it it nonzero, */
+ /*** the info_ptr for the call to page$enter_data */
+ /*** is 0|0. If the code is zero, the targetp */
+ /*** value is passed to page$enter_data. */
+ /*** Output: none */
+ /*** */
+ /*** ****************************************************************/
+
+ /* parameters */
+
+ dcl infop ptr parameter;
+ dcl code fixed bin (35) parameter;
+ dcl targetp ptr parameter;
+
+ /* based */
+
+ dcl 01 info aligned like call_info based (infop);
+ dcl 01 exit_mc aligned like mc based (info.mcp);
+
+ /* if we had a make_ptr or make_entry call, set the return value */
+
+ if /* case */ info.type = Make_ptr
+ then a_targetp = targetp;
+ else if info.type = Make_entry
+ then addr (a_targete) -> based_entry.code_ptr = targetp;
+
+ /* return the code */
+
+ if info.type = Link_fault
+ then do;
+ call level$set ((info.save_ring));
+ exit_mc.errcode = code;
+ call adjust_mc (info.mcp);
+ end;
+ else a_code = code;
+
+ /* complete fault tracing */
+
+ if code = 0
+ then call page$enter_data ((targetp), linkage_fault_end);
+ else call page$enter_data (baseptr (0), linkage_fault_end);
+
+ /* non-local goto to outer level and return */
+
+ goto EXIT;
+
+ end exit;
+
+EXIT:
+ return;
+
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+%page;
+/**** * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+%include definition_dcls;
+%page;
+%include its;
+%page;
+%include link_meters;
+%page;
+%include mc;
+%page;
+%include object_link_dcls;
+%page;
+%include stack_header;
+%page;
+%include system_link_names;
+%page;
+%include trace_types;
+
+ end link_snap;
public / multics_sim.git / commitdiff