1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1987                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1986 *
   6         *                                                         *
   7         *********************************************************** */
   8 
   9 
  10 
  11 
  12 /****^  HISTORY COMMENTS:
  13   1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
  14      audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
  15      Rewritten to support object multisegment files.  In particular, support
  16      of indirect definitions, deferred initialization, partial links, and
  17      preliminary support for *heap links.
  18   2) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
  19      audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
  20      added a check for heap links and a call to set_ext_variable_$star_heap
  21      when a heap link is found.
  22   3) change(86-06-24,DGHowe), approve(86-06-24,MCR7420),
  23      audit(86-11-05,Elhard), install(86-11-20,MR12.0-1222):
  24      added a segment pointer to the calling sequences of for_linker and
  25      star_heap for ext pointer initialization.
  26   4) change(87-06-10,Elhard), approve(87-07-17,MCR7739),
  27      audit(87-06-10,RWaters), install(87-07-17,MR12.1-1043):
  28      Critical fix to correct snapping of CREATE_IF_NOT_FOUND (type 6) links to
  29      targets with no offset name, or nonexistent targets.
  30                                                    END HISTORY COMMENTS */
  31 
  32 
  33 /* format: style1,insnl,ifthendo,indthenelse,^indnoniterdo,^inditerdo,indcom,^indthenbegin,^indprocbody,ind2,ll79,initcol0,dclind4,idind24,struclvlind1,comcol41 */
  34 
  35 link_snap:
  36   proc;
  37 
  38   /*** ****************************************************************/
  39   /***                                                                */
  40   /***    Name:     link_snap                                         */
  41   /***    Input:    none                                              */
  42   /***    Function: This procedure implements the Multics dynamic     */
  43   /***              linking mechanism.  Four entries exist in this    */
  44   /***              procedure:                                        */
  45   /***                link_snap$link_fault - This entry is called as  */
  46   /***                                       due to a fault_tag_2     */
  47   /***                                       (linkage) fault.         */
  48   /***                link_snap$link_force - This entry corresponds   */
  49   /***                                       to the hcs_$link_force   */
  50   /***                                       gate entry.  It basicly  */
  51   /***                                       duplicates the action of */
  52   /***                                       a link_fault without     */
  53   /***                                       taking a fault.          */
  54   /***                link_snap$make_ptr   - This entry corresponds   */
  55   /***                                       to the hcs_$make_ptr     */
  56   /***                                       gate entry. It simulates */
  57   /***                                       a type-3 or type-4 link  */
  58   /***                                       fault and returns the    */
  59   /***                                       target as a pointer.     */
  60   /***                link_snap$make_entry - This entry corresponds   */
  61   /***                                       to the hcs_$make_entry   */
  62   /***                                       gate entry. It simulates */
  63   /***                                       a type-3 or type-4 link  */
  64   /***                                       fault and returns the    */
  65   /***                                       target as an entry value */
  66   /***                                                                */
  67   /*** ****************************************************************/
  68 
  69   /* constants */
  70 
  71   dcl true                    bit (1) static options (constant) init ("1"b);
  72   dcl false                   bit (1) static options (constant) init ("0"b);
  73 
  74   dcl indirect                bit (6) static options (constant) init ("20"b3);
  75 
  76   dcl Link_fault              fixed bin static options (constant) init (1);
  77   dcl Link_force              fixed bin static options (constant) init (2);
  78   dcl Make_ptr                fixed bin static options (constant) init (3);
  79   dcl Make_entry              fixed bin static options (constant) init (4);
  80 
  81   dcl No_retry                bit (1) static options (constant) init ("0"b);
  82   dcl Will_retry              bit (1) static options (constant) init ("1"b);
  83 
  84   dcl zero_word               bit (36) static options (constant) init (""b);
  85 
  86   dcl None                    fixed bin (18) unsigned unaligned
  87                               static options (constant) init (0);
  88 
  89   /* parameters */
  90 
  91   dcl a_mcp                   ptr parameter;
  92   dcl a_link_pairp            ptr parameter;
  93   dcl a_dummy                 fixed bin parameter;
  94   dcl a_code                  fixed bin (35) parameter;
  95   dcl a_refp                  ptr parameter;
  96   dcl a_seg_name              char (*) parameter;
  97   dcl a_offset_name           char (*) parameter;
  98   dcl a_targetp               ptr parameter;
  99   dcl a_targete               entry parameter;
 100 
 101   /* procedures */
 102 
 103   dcl condition_              entry (char (*), entry);
 104   dcl fs_search               entry (ptr, char (*), bit (1) aligned, ptr,
 105                               fixed bin (35));
 106   dcl fs_search$same_directory
 107                               entry (ptr, char (*), ptr, fixed bin (35));
 108   dcl get_defptr_             entry (ptr, ptr, ptr, ptr, fixed bin (35));
 109   dcl level$get               entry () returns (fixed bin (3));
 110   dcl level$set               entry (fixed bin (3));
 111   dcl link_man$other_linkage  entry (ptr, ptr, ptr, ptr, fixed bin (35));
 112   dcl link_man$own_linkage    entry (ptr, ptr, ptr, ptr, fixed bin (35));
 113   dcl page$enter_data         entry (ptr unal, fixed bin);
 114   dcl set_ext_variable_$for_linker
 115                               entry (char (*), ptr, ptr, ptr, bit (1) aligned,
 116                               ptr, fixed bin (35), ptr, ptr, ptr, ptr);
 117   dcl set_ext_variable_$star_heap
 118                               entry (char (*), ptr, ptr, ptr, bit (1) aligned,
 119                               ptr, fixed bin (35));
 120   dcl trap_caller_caller_     entry (ptr, ptr, ptr, ptr, ptr, ptr,
 121                               fixed bin (35));
 122   dcl usage_values            entry (fixed bin (30) aligned,
 123                               fixed bin (71) aligned);
 124 
 125   /* external */
 126 
 127   dcl 01 ahd$link_meters      (4) aligned external like link_meters;
 128   dcl error_table_$bad_class_def
 129                               external fixed bin (35);
 130   dcl error_table_$bad_deferred_init
 131                               external fixed bin (35);
 132   dcl error_table_$bad_indirect_def
 133                               external fixed bin (35);
 134   dcl error_table_$bad_link_type
 135                               external fixed bin (35);
 136   dcl error_table_$bad_self_ref
 137                               external fixed bin (35);
 138   dcl error_table_$first_reference_trap
 139                               external fixed bin (35);
 140   dcl error_table_$illegal_ft2
 141                               external fixed bin (35);
 142   dcl error_table_$no_defs    external fixed bin (35);
 143   dcl error_table_$no_ext_sym external fixed bin (35);
 144   dcl error_table_$no_linkage external fixed bin (35);
 145   dcl error_table_$unexpected_ft2
 146                               external fixed bin (35);
 147   dcl pds$link_meters_bins    (4) external fixed bin (30);
 148   dcl pds$link_meters_pgwaits (4) external fixed bin (30);
 149   dcl pds$link_meters_times   (4) external fixed bin (35);
 150   dcl pds$stacks              (0:7) external ptr;
 151 
 152   /* based */
 153 
 154   dcl 01 based_entry          aligned based,
 155        02 code_ptr            ptr,
 156        02 env_ptr             ptr;
 157   dcl 01 expr                 aligned like exp_word based (exprp);
 158   dcl 01 link_pair            aligned like object_link based (link_pairp);
 159   dcl 01 offsetname           aligned based (offsetnamep),
 160        02 count               fixed bin (9) unsigned unaligned,
 161        02 string              char (offsetname.count) unaligned;
 162   dcl 01 segname              aligned based (segnamep),
 163        02 count               fixed bin (9) unsigned unaligned,
 164        02 string              char (segname.count) unaligned;
 165   dcl 01 type_pr              aligned like type_pair based (type_prp);
 166   dcl 01 usage                aligned based,
 167        02 time                fixed bin (71),
 168        02 pf                  fixed bin (30);
 169 
 170   /* automatic */
 171 
 172   dcl 01 automatic_offsetname aligned automatic,
 173        02 count               fixed bin (9) unsigned unaligned,
 174        02 string              char (256) unaligned;
 175   dcl 01 automatic_segname    aligned automatic,
 176        02 count               fixed bin (9) unsigned unaligned,
 177        02 string              char (32) unaligned;
 178   dcl 01 call_info            aligned automatic,
 179        02 type                fixed bin,
 180        02 save_ring           fixed bin,
 181        02 mcp                 ptr,
 182        02 codep               ptr,
 183        02 start               aligned like usage,
 184        02 finish              aligned like usage,
 185        02 search              aligned like usage,
 186        02 get_linkage         aligned like usage,
 187        02 def_search          aligned like usage;
 188   dcl call_infop              ptr automatic;
 189   dcl code                    fixed bin (35) automatic;
 190   dcl connect_fail_code       fixed bin (35) automatic;
 191   dcl defp                    ptr automatic;
 192   dcl exprp                   ptr automatic;
 193   dcl init_infop              ptr automatic;
 194   dcl instrp                  ptr automatic;
 195   dcl link_pairp              ptr automatic;
 196   dcl linkp                   ptr automatic;
 197   dcl nchars                  fixed bin automatic;
 198   dcl offset_name             char (256) automatic;
 199   dcl offsetnamep             ptr automatic;
 200   dcl refp                    ptr automatic;
 201   dcl retry_sw                bit (1) automatic;
 202   dcl seg_name                char (32) automatic;
 203   dcl segnamep                ptr automatic;
 204   dcl segp                    ptr automatic;
 205   dcl star_system_sw          bit (1) automatic;
 206   dcl target_linkagep         ptr automatic;
 207   dcl targetp                 ptr automatic;
 208   dcl textp                   ptr automatic;
 209   dcl type_prp                ptr automatic;
 210   dcl MSF_sw                  bit (1) aligned automatic;
 211 
 212   /* builtin */
 213 
 214   dcl addr                    builtin;
 215   dcl addrel                  builtin;
 216   dcl baseno                  builtin;
 217   dcl baseptr                 builtin;
 218   dcl bin                     builtin;
 219   dcl char                    builtin;
 220   dcl divide                  builtin;
 221   dcl index                   builtin;
 222   dcl length                  builtin;
 223   dcl ltrim                   builtin;
 224   dcl max                     builtin;
 225   dcl min                     builtin;
 226   dcl null                    builtin;
 227   dcl ptr                     builtin;
 228   dcl rtrim                   builtin;
 229   dcl substr                  builtin;
 230   dcl unspec                  builtin;
 231 
 232   return;
 233 
 234 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 235 ^L
 236 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 237 
 238 
 239 link_fault:
 240   entry (a_mcp);                        /** machine conditions  (i/o) */
 241 
 242   /*** ****************************************************************/
 243   /***                                                                */
 244   /***    Name:     link_snap$link_fault                              */
 245   /***    Input:    mcp                                               */
 246   /***    Function: handles a fault_tag_2 (linkage) fault.  The mcp   */
 247   /***              pointer points to the machine conditions at the   */
 248   /***              time of the fault.  If the link snapping is       */
 249   /***              successfull, the machine conditions will be       */
 250   /***              adjusted to allow the fault to be restarted.      */
 251   /***    Output:   mcp                                               */
 252   /***                                                                */
 253   /*** ****************************************************************/
 254 
 255   /* copy the parameters into automatic storage */
 256 
 257   mcp = a_mcp;
 258 
 259   call_infop = addr (call_info);
 260   call_info.type = Link_fault;
 261   call_info.mcp = mcp;
 262   call_info.save_ring = level$get ();
 263 
 264   /* since this is a fault, the trap routines can't set a return code */
 265 
 266   call_info.codep = null;
 267 
 268   /* set validation level to the level that the fault occurred at */
 269 
 270   scup = addr (mc.scu (0));
 271   call level$set (bin (scu.ppr.prr, 3));
 272 
 273   /* get a pointer to the faulting link pair and instruction */
 274 
 275   link_pairp = ptr (baseptr (bin (scu.tpr.tsr, 15)), scu.ca);
 276   instrp = ptr (baseptr (bin (scu.ppr.psr, 15)), scu.ilc);
 277 
 278   /* trace the fault */
 279 
 280   call page$enter_data ((instrp), linkage_fault_start);
 281 
 282   /* make sure the fault_tag_2 wasn't in an instruction */
 283 
 284   if instrp -> its.its_mod = FAULT_TAG_2
 285     then call exit (call_infop, error_table_$unexpected_ft2, null);
 286 
 287   goto link_join;
 288 
 289 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 290 ^L
 291 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 292 
 293 
 294 link_force:
 295   entry (a_link_pairp,                  /** ptr to link to snap (in ) */
 296        a_dummy,                         /** unused              (---) */
 297        a_code);                         /** error code          (out) */
 298 
 299   /*** ****************************************************************/
 300   /***                                                                */
 301   /***    Name:     link_snap$link_force                              */
 302   /***    Input:    link_pairp                                        */
 303   /***    Function: given a pointer to a link, snap it without taking */
 304   /***              a fault.  This entry is functionally the same as  */
 305   /***              link_snap$link_fault except that it is entered    */
 306   /***              via gate call rather than fault entry.            */
 307   /***    Output:   code                                              */
 308   /***                                                                */
 309   /*** ****************************************************************/
 310 
 311   /* not a fault entry */
 312 
 313   mcp = null;
 314 
 315   /* copy parameters into automatic storage */
 316 
 317   link_pairp = a_link_pairp;
 318 
 319   /* set up call info */
 320 
 321   call_infop = addr (call_info);
 322   call_info.type = Link_force;
 323   call_info.mcp = null;
 324   call_info.save_ring = -1;
 325 
 326   /* save error code address in case we trap out to the user ring and */
 327   /* the trap procedure needs to set the error code.                  */
 328 
 329   call_info.codep = addr (a_code);
 330 
 331   /* for a link_force call, we use the link itself as the start point */
 332   /* for tracing purposes.                                            */
 333 
 334   call page$enter_data ((link_pairp), linkage_fault_start);
 335 
 336 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 337 ^L
 338 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 339 
 340 
 341 link_join:
 342 
 343   /* clear out the metering information */
 344 
 345   call_info.search.time = 0;
 346   call_info.search.pf = 0;
 347   call_info.get_linkage.time = 0;
 348   call_info.get_linkage.pf = 0;
 349   call_info.def_search.time = 0;
 350   call_info.def_search.pf = 0;
 351 
 352   /* meter the fault time etc. */
 353 
 354   call usage_values (call_info.start.pf, call_info.start.time);
 355 
 356   if link_pair.tag ^= FAULT_TAG_2
 357     then if call_info.type = Link_force
 358            then call exit (call_infop, 0, baseptr (0));
 359            else call exit (call_infop, error_table_$illegal_ft2, null);
 360 
 361   /* get the linkage section and text pointers */
 362 
 363   linkp = addrel (link_pairp, link_pair.header_relp);
 364   textp = baseptr (linkp -> linkage_header.stats.segment_number);
 365   target_linkagep = null;
 366 
 367   /* validate the definition pointer */
 368 
 369   if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^= ITS_MODIFIER
 370     then call exit (call_infop, error_table_$no_defs, null);
 371     else defp = linkp -> linkage_header.def_ptr;
 372 
 373   /* validate that all first reference traps have been run */
 374 
 375   if linkp -> virgin_linkage_header.first_ref_relp ^= 0
 376     then call exit (call_infop, error_table_$first_reference_trap, null);
 377 
 378   /* now that things look reasonably valid, we start decoding the link */
 379 
 380   exprp = addrel (defp, link_pair.expression_relp);
 381   type_prp = addrel (defp, expr.type_relp);
 382 
 383   /* first we check the link to see if it should be converted into a  */
 384   /* *system link.  Trap-before links to datmk_ and certain type-6    */
 385   /* links are converted to *system links.                            */
 386 
 387   call convert_trap_link (call_infop, linkp, defp, type_prp, offset_name,
 388        init_infop, star_system_sw);
 389 
 390   if star_system_sw
 391     then do;
 392 
 393       /* the link either was a *system link, or has become one */
 394 
 395       call star_system (call_infop, link_pairp, defp, linkp, type_prp,
 396            offset_name, init_infop, targetp);
 397       call snap (targetp, (expr.expression), link_pairp);
 398       call meter (call_infop, (type_pr.type));
 399       call exit (call_infop, 0, targetp);
 400     end;
 401 
 402   /* see if we have a C *heap link */
 403 
 404   if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_HEAP
 405     then do;
 406 
 407       /* C *heap links are similar to *system links except that they  */
 408       /* are allocated separately, and have a level associated with   */
 409       /* them so that recursive invocations get new copies and they   */
 410       /* can be released when the invocation returns.                 */
 411 
 412       call star_heap (call_infop, defp, linkp, type_prp, targetp);
 413       call snap (targetp, (expr.expression), link_pairp);
 414       call meter (call_infop, (type_pr.type));
 415       call exit (call_infop, 0, targetp);
 416     end;
 417 
 418   /* now see if there is a trap pointer.  Anything with a trap        */
 419   /* pointer that wasn't converted to a *system link, and isn't a     */
 420   /* create link, we now treat as a trap-before link, and try to run  */
 421   /* the trap.                                                        */
 422 
 423   if type_pr.type ^= LINK_CREATE_IF_NOT_FOUND & type_pr.trap_relp ^= None
 424     then do;
 425 
 426       /* actually is a trap-before link, trap out to the user         */
 427       /* ring to execute the trap procedure.                          */
 428 
 429       /* NB.  We don't try to complete tracing or metering in this    */
 430       /*      case since it would be rather meaningless anyway. . .   */
 431 
 432       call adjust_mc (mcp);
 433       call trap_caller_caller_ (mcp, linkp, defp, type_prp, link_pairp,
 434            call_info.codep, code);
 435 
 436       /* usually we don't return, but. . . */
 437 
 438       call exit (call_infop, code, baseptr (0));
 439     end;
 440 
 441   /* at this point we assume we have a reasonably standard link and   */
 442   /* can just snap it according to type.                              */
 443 
 444   if /* case */ type_pr.type = LINK_SELF_BASE
 445     then do;
 446       call self_reference (call_infop, (type_pr.segname_relp), textp,
 447            targetp);
 448       call snap (targetp, (expr.expression), link_pairp);
 449       call meter (call_infop, (type_pr.type));
 450       call exit (call_infop, 0, targetp);
 451     end;
 452 
 453   else if type_pr.type = LINK_OBSOLETE_2
 454     then call exit (call_infop, error_table_$bad_link_type, null);
 455 
 456   else if type_pr.type = LINK_REFNAME_BASE
 457     then do;
 458       segnamep = addrel (defp, type_pr.segname_relp);
 459       if defp -> definition_header.msf_map_relp ^= None
 460         then MSF_sw = true;
 461         else MSF_sw = false;
 462       call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
 463            code);
 464       if segp = null
 465         then call exit (call_infop, code, null);
 466       call snap (segp, (expr.expression), link_pairp);
 467       call meter (call_infop, (type_pr.type));
 468       call exit (call_infop, 0, segp);
 469     end;
 470 
 471   else if type_pr.type = LINK_REFNAME_OFFSETNAME
 472     then do;
 473       segnamep = addrel (defp, type_pr.segname_relp);
 474       if defp -> definition_header.msf_map_relp ^= None
 475         then MSF_sw = true;
 476         else MSF_sw = false;
 477       call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
 478            code);
 479       if segp = null
 480         then call exit (call_infop, code, null);
 481       call condition_ ("seg_fault_error", connect_fail_handler_);
 482       call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
 483       call get_definition (call_infop, segnamep, offsetnamep, segp,
 484            No_retry, target_linkagep, targetp);
 485       call snap (targetp, (expr.expression), link_pairp);
 486       call meter (call_infop, (type_pr.type));
 487       call trap (call_infop, target_linkagep, targetp);
 488       call exit (call_infop, 0, targetp);
 489     end;
 490 
 491   else if type_pr.type = LINK_SELF_OFFSETNAME
 492     then do;
 493       call self_reference (call_infop, (type_pr.segname_relp), textp,
 494            targetp);
 495 
 496       /* insure that segname won't be found */
 497 
 498       segnamep = addr (zero_word);
 499       call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
 500       call get_definition (call_infop, segnamep, offsetnamep, textp,
 501            No_retry, (null), targetp);
 502       call snap (targetp, (expr.expression), link_pairp);
 503       call meter (call_infop, (type_pr.type));
 504       call exit (call_infop, 0, targetp);
 505     end;
 506 
 507   else if type_pr.type = LINK_CREATE_IF_NOT_FOUND
 508     then do;
 509 
 510       /* NB.  since we have already processed the trap case, we will  */
 511       /*      assume that this link can be treated as a type-4 until  */
 512       /*      something breaks.                                       */
 513 
 514       segnamep = addrel (defp, type_pr.segname_relp);
 515       if defp -> definition_header.msf_map_relp ^= None
 516         then MSF_sw = true;
 517         else MSF_sw = false;
 518       call search_for_segment (call_infop, segnamep, textp, MSF_sw, segp,
 519            code);
 520       if segp = null
 521         then do;
 522 
 523           /* OK.  something broke.  now we try to treat this as a     */
 524           /* *system link so that the caller will get something.      */
 525 
 526           call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
 527           if offsetnamep = null
 528             then offset_name = segname.string || "$";
 529             else offset_name = segname.string || "$" || offsetname.string;
 530           if type_pr.trap_relp = 0
 531             then init_infop = null;
 532             else init_infop = addrel (defp, type_pr.trap_relp);
 533           call star_system (call_infop, link_pairp, defp, linkp, type_prp,
 534                offset_name, init_infop, targetp);
 535           call snap (targetp, (expr.expression), link_pairp);
 536           call meter (call_infop, (type_pr.type));
 537           call exit (call_infop, 0, targetp);
 538         end;
 539 
 540       call condition_ ("seg_fault_error", connect_fail_handler_);
 541       call get_offsetnamep (call_infop, defp, type_prp, offsetnamep);
 542 
 543       /* dont try to do a definition search if no entrypoint name was given */
 544 
 545       if offsetnamep ^= null
 546         then call get_definition (call_infop, segnamep, offsetnamep, segp,
 547                   No_retry, target_linkagep, targetp);
 548         else targetp = segp;
 549       call snap (targetp, (expr.expression), link_pairp);
 550       call meter (call_infop, (type_pr.type));
 551       call trap (call_infop, target_linkagep, targetp);
 552       call exit (call_infop, 0, targetp);
 553     end;
 554 
 555   else call exit (call_infop, error_table_$bad_link_type, null);
 556 
 557 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 558 ^L
 559 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 560 
 561 
 562 make_ptr:
 563   entry (a_refp,                        /** referencing dir ptr (in ) */
 564        a_seg_name,                      /** segname to find     (in ) */
 565        a_offset_name,                   /** entrypoint to find  (in ) */
 566        a_targetp,                       /** target ptr returned (out) */
 567        a_code);                         /** error code          (out) */
 568 
 569   /*** ****************************************************************/
 570   /***                                                                */
 571   /***    Name:     link_snap$make_ptr                                */
 572   /***    Input:    refp, seg_name, offset_name                       */
 573   /***    Function: Using the segname and optional offsetname given,  */
 574   /***              snap a simulated type-3 (if a null offsetname)    */
 575   /***              or type-4 (if non-null) link and return a pointer */
 576   /***              to the target.  The reference pointer is passed   */
 577   /***              to fs_search in order to evaluate the referencing */
 578   /***              dir search rule.  If it is null, the referencing  */
 579   /***              dir rule is skipped.                              */
 580   /***    Output:   targetp, code                                     */
 581   /***                                                                */
 582   /*** ****************************************************************/
 583 
 584   /* preset the return values */
 585 
 586   a_targetp = null;
 587 
 588   /* set up the call info */
 589 
 590   call_info.type = Make_ptr;
 591 
 592   goto make_join;
 593 
 594 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 595 ^L
 596 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 597 
 598 
 599 make_entry:
 600   entry (a_refp,                        /** referencing dir ptr (in ) */
 601        a_seg_name,                      /** segname to find     (in ) */
 602        a_offset_name,                   /** entrypoint to find  (in ) */
 603        a_targete,                       /** entry returned      (out) */
 604        a_code);                         /** error code          (out) */
 605 
 606   /*** ****************************************************************/
 607   /***                                                                */
 608   /***    Name:     link_snap$make_entry                              */
 609   /***    Input:    refp, seg_name, offset_name                       */
 610   /***    Function: performs the same function as link_snap$make_ptr  */
 611   /***              except that an entry value is returned instead of */
 612   /***              a pointer value.  The other difference between    */
 613   /***              calling make_entry and make_ptr is that if the    */
 614   /***              offsetname value is null on a call to make_entry  */
 615   /***              the target linkage section is combined and any    */
 616   /***              first reference traps run.  This is because it is */
 617   /***              assumed that if you want an entry returned, you   */
 618   /***              plan on calling it, and to call it the linkage    */
 619   /***              section should be combined.                       */
 620   /***    Output:   targete, code                                     */
 621   /***                                                                */
 622   /*** ****************************************************************/
 623 
 624   call_info.type = Make_entry;
 625 
 626   /* preset the returned entry */
 627 
 628   addr (a_targete) -> based_entry.code_ptr = null;
 629   addr (a_targete) -> based_entry.env_ptr = null;
 630 
 631 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 632 ^L
 633 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 634 
 635 
 636 make_join:
 637 
 638   /* meter and trace the make_ptr/make_entry call */
 639 
 640   call usage_values (call_info.start.pf, call_info.start.time);
 641   call page$enter_data (baseptr (0), linkage_fault_start);
 642 
 643   /* clear out the metering information */
 644 
 645   call_info.search.time = 0;
 646   call_info.search.pf = 0;
 647   call_info.get_linkage.time = 0;
 648   call_info.get_linkage.pf = 0;
 649   call_info.def_search.time = 0;
 650   call_info.def_search.pf = 0;
 651 
 652   /* set up the common call_info stuff */
 653 
 654   call_infop = addr (call_info);
 655   call_info.codep = addr (a_code);
 656   call_info.mcp, mcp = null;
 657   call_info.save_ring = -1;
 658 
 659   /* copy the args into automatic storage */
 660 
 661   refp = a_refp;
 662   seg_name = a_seg_name;
 663   offset_name = a_offset_name;
 664 
 665   /* preset the return code */
 666 
 667   a_code = 0;
 668 
 669   /* try to determine whether the ref pointer refers to an MSF */
 670 
 671   if refp = null
 672     then MSF_sw = false;
 673     else do;
 674       call link_man$own_linkage (ptr (refp, 0), linkp, null, null, code);
 675       if code ^= 0
 676         then MSF_sw = false;
 677       else if addr (linkp -> linkage_header.def_ptr) -> its.its_mod ^=
 678                 ITS_MODIFIER
 679         then MSF_sw = false;
 680       else do;
 681         defp = linkp -> linkage_header.def_ptr;
 682         if defp -> definition_header.msf_map_relp ^= None
 683           then MSF_sw = true;
 684           else MSF_sw = false;
 685       end;
 686     end;
 687 
 688   /* search for the segment */
 689 
 690   call fs_search (refp, seg_name, MSF_sw, segp, code);
 691   if code ^= 0
 692     then call exit (call_infop, code, null);
 693 
 694   /* set up to handle connection failure gracefully */
 695 
 696   call condition_ ("seg_fault_error", connect_fail_handler_);
 697 
 698   nchars = length (rtrim (offset_name));
 699 
 700   if nchars = 0
 701     then do;
 702 
 703       /* no offsetname, so just meter, finish tracing and return */
 704 
 705       if call_info.type = Make_ptr
 706         then call meter (call_infop, (LINK_REFNAME_BASE));
 707         else do;
 708 
 709           /* if we are returning an entry, we must combine the        */
 710           /* target linkage section first.  If we combine the linkage */
 711           /* section we should run any first reference traps.         */
 712 
 713           call combine_linkage (call_infop, segp, (null), target_linkagep,
 714                (null), (null));
 715           call meter (call_infop, (LINK_REFNAME_BASE));
 716           call trap (call_infop, target_linkagep, segp);
 717         end;
 718       call exit (call_infop, 0, segp);
 719     end;
 720 
 721   /* set up the segname/offsetname pointers */
 722 
 723   segnamep = addr (automatic_segname);
 724   offsetnamep = addr (automatic_offsetname);
 725 
 726   /* clear them out */
 727 
 728   unspec (automatic_segname) = ""b;
 729   unspec (automatic_offsetname) = ""b;
 730 
 731   /* save the passed segname/offsetname values */
 732 
 733   automatic_segname.count = length (rtrim (seg_name));
 734   substr (automatic_segname.string, 1, automatic_segname.count) =
 735        substr (seg_name, 1, automatic_segname.count);
 736 
 737   automatic_offsetname.count = length (rtrim (offset_name));
 738   substr (automatic_offsetname.string, 1, automatic_offsetname.count) =
 739        substr (offset_name, 1, automatic_offsetname.count);
 740 
 741   /* if the offsetname and segname are the same, we want    */
 742   /* get_definition to retry using the offsetname "main_"   */
 743   /* if this attempt fails                                  */
 744 
 745   if seg_name = offset_name
 746     then retry_sw = Will_retry;
 747     else retry_sw = No_retry;
 748 
 749   call get_definition (call_infop, segnamep, offsetnamep, segp, retry_sw,
 750        target_linkagep, targetp);
 751 
 752   call meter (call_infop, (LINK_REFNAME_OFFSETNAME));
 753   call trap (call_infop, target_linkagep, targetp);
 754   call exit (call_infop, 0, targetp);
 755 
 756 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 757 ^L
 758 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 759 
 760 
 761 convert_trap_link:
 762   proc (infop,                          /** call info pointer   (in ) */
 763        linkp,                           /** linkage pointer     (in ) */
 764        defp,                            /** definition pointer  (in ) */
 765        type_prp,                        /** type_pair pointer   (in ) */
 766        offset_name,                     /** entrypoint name     (out) */
 767        init_infop,                      /** init_info pointer   (out) */
 768        star_system_sw);                 /** *system or mapped   (out) */
 769 
 770   /*** ****************************************************************/
 771   /***                                                                */
 772   /***    Name:     convert_trap_link                                 */
 773   /***    Input:    infop, linkp, defp, type_prp                      */
 774   /***    Function: determines whether the link in question has a     */
 775   /***              trap_relp value.  If it does, then the link is    */
 776   /***              a probably a *system link (type-5, class-5) or    */
 777   /***              should should be treated as one.  If it is not    */
 778   /***              not a *system link, and should be, we determine   */
 779   /***              what the offset_name to be found is and what the  */
 780   /***              init_info pointer should be and then set the flag */
 781   /***              to indicate that this is to be snapped as a       */
 782   /***              *system link.                                     */
 783   /***    Output:   offset_name, init_infop, star_system_sw           */
 784   /***                                                                */
 785   /*** ****************************************************************/
 786 
 787   /* parameters */
 788 
 789   dcl infop                   ptr parameter;
 790   dcl linkp                   ptr parameter;
 791   dcl defp                    ptr parameter;
 792   dcl type_prp                ptr parameter;
 793   dcl offset_name             char (256) parameter;
 794   dcl init_infop              ptr parameter;
 795   dcl star_system_sw          bit (1) parameter;
 796 
 797   /* based */
 798 
 799   dcl based_ptr               ptr based;
 800   dcl 01 offsetname           aligned based (offsetnamep),
 801        02 count               fixed bin (9) unsigned unaligned,
 802        02 string              char (offsetname.count) unaligned;
 803   dcl 01 segname              aligned based (segnamep),
 804        02 count               fixed bin (9) unsigned unaligned,
 805        02 string              char (segname.count) unaligned;
 806   dcl 01 trap                 aligned like link_trap_pair based (trapp);
 807   dcl 01 type_pr              aligned like type_pair based (type_prp);
 808 
 809   /* automatic */
 810 
 811   dcl code                    fixed bin (35) automatic;
 812   dcl init_linkp              ptr automatic;
 813   dcl offsetnamep             ptr automatic;
 814   dcl segnamep                ptr automatic;
 815   dcl trapp                   ptr automatic;
 816 
 817   segnamep = addrel (defp, type_pr.segname_relp);
 818   offsetnamep = addrel (defp, type_pr.offsetname_relp);
 819 
 820   /* preset output variables */
 821 
 822   star_system_sw = false;
 823   offset_name = offsetname.string;
 824   if type_pr.trap_relp = None
 825     then init_infop = null;
 826     else init_infop = addrel (defp, type_pr.trap_relp);
 827 
 828   /* first see if it is actually a *system link */
 829 
 830   if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_SYSTEM
 831     then do;
 832       star_system_sw = true;
 833       return;
 834     end;
 835 
 836   /* now check the conditions for converting a type 6 link */
 837 
 838   if type_pr.type = LINK_CREATE_IF_NOT_FOUND
 839     then do;
 840 
 841       /* check for pl1 ext static */
 842 
 843       if segname.string = "stat_"
 844         then do;
 845           star_system_sw = true;
 846           return;
 847         end;
 848 
 849       /* check for fortran common blocks */
 850 
 851       if offsetname.count = 0
 852         then if index (segname.string, ".com") = segname.count - 3
 853                then do;
 854                  star_system_sw = true;
 855                  offset_name = substr (segname.string, 1, segname.count - 4);
 856                  if offset_name = "b_"  /* blank common */
 857                    then offset_name = "blnk*com";
 858                  return;
 859                end;
 860                else ;
 861 
 862       /* check for cobol FSB link */
 863 
 864       else if segname.string = "cobol_fsb_"
 865         then do;
 866           offset_name = "cobol_fsb_" || offsetname.string;
 867           star_system_sw = true;
 868           return;
 869         end;
 870     end;
 871 
 872   if type_pr.type = LINK_REFNAME_OFFSETNAME & type_pr.trap_relp ^= None
 873     then do;
 874 
 875       /* if we have a type 4 link with a trap-before link to datmk_   */
 876       /* we force-snap the info-link of the trap, use that as the     */
 877       /* init_info pointer and use the offsetname from the original   */
 878       /* link as the name and then treat as a *system link.           */
 879 
 880       trapp = addrel (defp, type_pr.trap_relp);
 881       if segname.string = "stat_"
 882         then if addrel (defp,
 883                   addrel (defp,
 884                   addrel (defp, addrel (linkp, trap.call_relp)
 885                   -> object_link.expression_relp)
 886                   -> exp_word.type_relp)
 887                   -> type_pair.segname_relp) -> acc_string.string = "datmk_"
 888                then do;
 889                  init_linkp = addrel (linkp, trap.info_relp);
 890 
 891                  /* snap the info link */
 892 
 893                  call link_force (init_linkp, 0, code);
 894                  if code ^= 0
 895                    then call exit (call_infop, code, null);
 896 
 897                  init_infop = init_linkp -> based_ptr;
 898                  star_system_sw = true;
 899                end;
 900     end;
 901 
 902   end convert_trap_link;
 903 
 904 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 905 ^L
 906 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 907 
 908 
 909 star_system:
 910   proc (infop,                          /** call_info pointer   (in ) */
 911        link_pairp,                      /** pointer to link     (in ) */
 912        defp,                            /** definition pointer  (in ) */
 913        linkp,                           /** linkage pointer     (in ) */
 914        type_prp,                        /** type_pair pointer   (in ) */
 915        offset_name,                     /** ext var name string (in ) */
 916        init_infop,                      /** init_info pointer   (in ) */
 917        targetp);                        /** target variable     (out) */
 918 
 919   /*** ****************************************************************/
 920   /***                                                                */
 921   /***    Name:     star_system                                       */
 922   /***    Input:    infop, link_pairp, defp, linkp, type_prp,         */
 923   /***              offset_name, init_infop                           */
 924   /***    Function: determines the target of a *system link.  This    */
 925   /***              procedure calls set_ext_variable_ to return the   */
 926   /***              variable_node which defines the named external    */
 927   /***              variable, and then returns a pointer to the var   */
 928   /***              itself.                                           */
 929   /***    Output:   targetp                                           */
 930   /***                                                                */
 931   /*** ****************************************************************/
 932 
 933   /* parameters */
 934 
 935   dcl infop                   ptr parameter;
 936   dcl link_pairp              ptr parameter;
 937   dcl defp                    ptr parameter;
 938   dcl linkp                   ptr parameter;
 939   dcl type_prp                ptr parameter;
 940   dcl offset_name             char (256) parameter;
 941   dcl init_infop              ptr parameter;
 942   dcl targetp                 ptr parameter;
 943 
 944   /* based */
 945 
 946   dcl 01 info                 aligned like call_info based (infop);
 947 
 948   /* automatic */
 949 
 950   dcl code                    fixed bin (35) automatic;
 951   dcl sb                      ptr automatic;
 952 
 953   /* set the stack base pointer */
 954 
 955   if info.mcp = null
 956     then sb = pds$stacks (level$get ());
 957     else sb = ptr (info.mcp -> mc.prs (6), 0);
 958 
 959   /* check to see if this variable has a deferred initialization type */
 960 
 961   call deferred_init (infop, init_infop, linkp);
 962 
 963   /* now call set_ext_variable_ to get the variable node.  Note that  */
 964   /* this call may not return if the target is an uninitialized VLA,  */
 965   /* since this requires a call to fortran_storage_manager_. We cant  */
 966   /* call this in ring 0 so we trap out to the user ring to call out  */
 967   /* to set up the VLA.  The fortran_storage_manager_ is responsible  */
 968   /* for completing the link snap.                                    */
 969 
 970   call set_ext_variable_$for_linker (offset_name, init_infop, sb,
 971        ptr (init_infop, 0), ("0"b), targetp, code, info.mcp, def_ptr,
 972        type_prp, link_pairp);
 973   if code ^= 0
 974     then call exit (infop, code, null);
 975 
 976   /* get a pointer to the actual variable instead of the node */
 977 
 978   targetp = targetp -> variable_node.vbl_ptr;
 979 
 980   end star_system;
 981 
 982 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 983 ^L
 984 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 985 
 986 
 987 star_heap:
 988   proc (infop,                          /** call_info pointer   (in ) */
 989        defp,                            /** def section ptr     (in ) */
 990        linkp,                           /** linkage section ptr (in ) */
 991        type_prp,                        /** type_pair pointer   (in ) */
 992        targetp);                        /** target pointer      (out) */
 993 
 994   /*** ****************************************************************/
 995   /***                                                                */
 996   /***    Name:     star_heap                                         */
 997   /***    Input:    infop, defp, linkp, type_prp                      */
 998   /***    Function: given a pointer to the type_pair and definition   */
 999   /***              section for a link, get the offsetname and init   */
1000   /***              info pointer and call set_ext_variable_$star_heap */
1001   /***              to find or create the variable.                   */
1002   /***    Output:   targetp                                           */
1003   /***                                                                */
1004   /*** ****************************************************************/
1005 
1006   /* parameters */
1007 
1008   dcl infop                   ptr parameter;
1009   dcl defp                    ptr parameter;
1010   dcl linkp                   ptr parameter;
1011   dcl type_prp                ptr parameter;
1012   dcl targetp                 ptr parameter;
1013 
1014   /* based */
1015 
1016   dcl 01 info                 aligned like call_info based (infop);
1017   dcl 01 offsetname           aligned based (offsetnamep),
1018        02 count               fixed bin (9) unsigned unaligned,
1019        02 string              char (offsetname.count) unaligned;
1020   dcl 01 type_pr              aligned like type_pair based (type_prp);
1021 
1022   /* automatic */
1023 
1024   dcl init_infop              ptr automatic;
1025   dcl offsetnamep             ptr automatic;
1026   dcl sb                      ptr automatic;
1027   dcl offset_name             char (256) automatic;
1028 
1029   /* extract the variable name and init_info pointer */
1030 
1031   offsetnamep = addrel (defp, type_pr.offsetname_relp);
1032   offset_name = offsetname.string;
1033 
1034   if type_pr.trap_relp = None
1035     then init_infop = null;
1036     else init_infop = addrel (defp, type_pr.trap_relp);
1037 
1038   /* get the stack base pointer */
1039 
1040   if info.mcp = null
1041     then sb = pds$stacks (level$get ());
1042     else sb = ptr (info.mcp -> mc.prs (6), 0);
1043 
1044   /* get new init_info pointer if initialization type = INIT_DEFERRED */
1045 
1046   call deferred_init (infop, init_infop, linkp);
1047 
1048   /* call set_ext_variable_$star_heap to allocate the variable and    */
1049   /* return a node ptr                                                */
1050 
1051   call set_ext_variable_$star_heap (offset_name, init_infop, sb,
1052        ptr (init_infop, 0), ("0"b), targetp, code);
1053   if code ^= 0
1054     then call exit (infop, code, null);
1055 
1056   /* set the target to point to the variable itself */
1057 
1058   targetp = targetp -> variable_node.vbl_ptr;
1059 
1060   end star_heap;
1061 
1062 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1063 ^L
1064 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1065 
1066 
1067 deferred_init:
1068   proc (infop,                          /** call_info pointer   (in ) */
1069        init_infop,                      /** init_info pointer   (i/o) */
1070        linkp);                          /** linkage section ptr (in ) */
1071 
1072   /*** ****************************************************************/
1073   /***                                                                */
1074   /***    Name:     deferred_init                                     */
1075   /***    Input:    infop, init_infop, linkp                          */
1076   /***    Function: locates the initialization info for deferred init */
1077   /***              external or heap initialization.  The procedure   */
1078   /***              for deferred initialization is as follows:        */
1079   /***                - check to see if the init type is deferred.    */
1080   /***                - if so, extract the target_relp and link_relp  */
1081   /***                  from the init_info.                           */
1082   /***                - make sure the link referenced by target_relp  */
1083   /***                  has been snapped.                             */
1084   /***                - chase the link to find the target segments    */
1085   /***                  linkage header.                               */
1086   /***                - extract the def_ptr and original_linkage_ptr  */
1087   /***                  from the linkage_header.                      */
1088   /***                - apply the link_relp to the original_linkage   */
1089   /***                  pointer to find the unsnapped link.           */
1090   /***                - extract a pointer to the init_info from the   */
1091   /***                  def_ptr and type_pair.                        */
1092   /***                - return the actual init_info pointer.          */
1093   /***    Output:   init_infop                                        */
1094   /***                                                                */
1095   /*** ****************************************************************/
1096 
1097   /* parameters */
1098 
1099   dcl infop                   ptr parameter;
1100   dcl init_infop              ptr parameter;
1101   dcl linkp                   ptr parameter;
1102 
1103   /* based */
1104 
1105   dcl 01 lh                   aligned like linkage_header based (lhp);
1106   dcl based_ptr               ptr based;
1107   dcl 01 type_pr              aligned like type_pair based (type_prp);
1108   dcl 01 expr                 aligned like exp_word based (exprp);
1109   dcl 01 link_pair            aligned like object_link based (link_pairp);
1110   dcl 01 init_info            aligned like link_init_deferred
1111                               based (init_infop);
1112 
1113   /* automatic */
1114 
1115   dcl target_ptr_ptr          ptr automatic;
1116   dcl lhp                     ptr automatic;
1117   dcl exprp                   ptr automatic;
1118   dcl type_prp                ptr automatic;
1119   dcl link_pairp              ptr automatic;
1120 
1121   /* if no init_info, or init_info is not deferred, just return */
1122 
1123   if init_infop = null
1124     then return;
1125 
1126   if init_info.header.type ^= INIT_DEFERRED
1127     then return;
1128 
1129   /* get the target partial link and make sure it is snapped */
1130 
1131   target_ptr_ptr = addrel (linkp, init_info.target_relp);
1132   if target_ptr_ptr -> its.its_mod ^= ITS_MODIFIER
1133     then call exit (infop, error_table_$bad_deferred_init, null);
1134 
1135   /* make sure the target of the link looks somewhat like a linkage   */
1136   /* header and that the definition pointer is a pointer              */
1137 
1138   lhp = target_ptr_ptr -> based_ptr;
1139   if addr (lh.def_ptr) -> its.its_mod ^= ITS_MODIFIER
1140     then call exit (infop, error_table_$no_defs, null);
1141     else defp = lh.def_ptr;
1142 
1143   /* get a pointer to the link specified in the original linkage      */
1144   /* section and make sure it looks like an unsnapped link.           */
1145 
1146   link_pairp = addrel (lh.original_linkage_ptr, init_info.link_relp);
1147   if link_pair.tag ^= FAULT_TAG_2
1148     then call exit (infop, error_table_$bad_deferred_init, null);
1149 
1150   /* now decode the link and get a pointer to the init_info */
1151 
1152   exprp = addrel (defp, link_pair.expression_relp);
1153   type_prp = addrel (defp, expr.type_relp);
1154   if type_pr.trap_relp = None
1155     then init_infop = null;
1156     else init_infop = addrel (defp, type_pr.trap_relp);
1157 
1158   end deferred_init;
1159 
1160 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1161 ^L
1162 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1163 
1164 
1165 self_reference:
1166   proc (infop,                          /** call_info pointer   (in ) */
1167        class,                           /** link class          (in ) */
1168        textp,                           /** segment pointer     (in ) */
1169        targetp);                        /** section pointer     (out) */
1170 
1171   /*** ****************************************************************/
1172   /***                                                                */
1173   /***    Name:     self_reference                                    */
1174   /***    Input:    infop, class, textp                               */
1175   /***    Function: given a link class and a pointer to the owners    */
1176   /***              text_section, get the other section pointers and  */
1177   /***              return a pointer to the section specified by the  */
1178   /***              class of the link.                                */
1179   /***    Output:   targetp                                           */
1180   /***                                                                */
1181   /*** ****************************************************************/
1182 
1183   /* parameters */
1184 
1185   dcl infop                   ptr parameter;
1186   dcl class                   fixed bin (18) unsigned parameter;
1187   dcl textp                   ptr parameter;
1188   dcl targetp                 ptr parameter;
1189 
1190   /* automatic */
1191 
1192   dcl code                    fixed bin (35) automatic;
1193   dcl linkp                   ptr automatic;
1194   dcl staticp                 ptr automatic;
1195   dcl symbolp                 ptr automatic;
1196 
1197   /* get pointers to the various sections */
1198 
1199   call link_man$own_linkage (textp, linkp, staticp, symbolp, code);
1200   if code ^= 0
1201     then call exit (infop, code, null);
1202 
1203   /* return the section pointer based on the link class */
1204 
1205   if /* case */ class = CLASS_TEXT
1206     then targetp = textp;
1207   else if class = CLASS_LINKAGE
1208     then targetp = linkp;
1209   else if class = CLASS_STATIC
1210     then targetp = staticp;
1211   else if class = CLASS_SYMBOL
1212     then targetp = symbolp;
1213   else call exit (infop, error_table_$bad_self_ref, null);
1214 
1215   end self_reference;
1216 
1217 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1218 ^L
1219 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1220 
1221 
1222 search_for_segment:
1223   proc (infop,                          /** call_info pointer   (in ) */
1224        segnamep,                        /** segname acc pointer (in ) */
1225        refp,                            /** referencing pointer (in ) */
1226        MSF_sw,                          /** is caller an MSF    (in ) */
1227        segp,                            /** found segment ptr   (out) */
1228        code);                           /** error code          (out) */
1229 
1230   /*** ****************************************************************/
1231   /***                                                                */
1232   /***    Name:     search_for_segment                                */
1233   /***    Input:    infop, segnamep, refp                             */
1234   /***    Function: calls fs_search to search for the refname given   */
1235   /***              by the acc_string pointer to by segnamep, and     */
1236   /***              meters the call.                                  */
1237   /***    Output:   segp, code                                        */
1238   /***                                                                */
1239   /*** ****************************************************************/
1240 
1241   /* parameters */
1242 
1243   dcl infop                   ptr parameter;
1244   dcl segnamep                ptr parameter;
1245   dcl refp                    ptr parameter;
1246   dcl MSF_sw                  bit (1) aligned parameter;
1247   dcl segp                    ptr parameter;
1248   dcl code                    fixed bin (35) parameter;
1249 
1250   /* based */
1251 
1252   dcl 01 info                 aligned like call_info based (infop);
1253   dcl 01 segname              aligned based (segnamep),
1254        02 count               fixed bin (9) unsigned unaligned,
1255        02 string              char (segname.count) unaligned;
1256 
1257   /* automatic */
1258 
1259   dcl 01 finish               aligned like usage automatic;
1260   dcl 01 start                aligned like usage automatic;
1261 
1262   /* do the search and meter the time an pagewaits */
1263 
1264   call usage_values (start.pf, start.time);
1265 
1266   call fs_search (refp, segname.string, MSF_sw, segp, code);
1267 
1268   call usage_values (finish.pf, finish.time);
1269 
1270   /* calculate the metering info and add it to the search metering */
1271 
1272   info.search.pf = info.search.pf + (finish.pf - start.pf);
1273   info.search.time = info.search.time + (finish.time - start.time);
1274 
1275   end search_for_segment;
1276 
1277 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1278 ^L
1279 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1280 
1281 
1282 get_offsetnamep:
1283   proc (infop,                          /** call_info pointer   (in ) */
1284        defp,                            /** definition pointer  (in ) */
1285        type_prp,                        /** type_pair pointer   (in ) */
1286        offsetnamep);                    /** offsetname pointer (out) */
1287 
1288   /*** ****************************************************************/
1289   /***                                                                */
1290   /***    Name:     get_offsetnamep                                   */
1291   /***    Input:    infop, defp, type_prp                             */
1292   /***    Function: extract a pointer to the offsetname for the link  */
1293   /***              from the type_pair.  If there is no offsetname    */
1294   /***              or the type is 6 and the offset name length is 0, */
1295   /***              the null pointer is returned.                     */
1296   /***    Output:   offsetnamep                                       */
1297   /***                                                                */
1298   /*** ****************************************************************/
1299 
1300   /* parameters */
1301 
1302   dcl infop                   ptr parameter;
1303   dcl defp                    ptr parameter;
1304   dcl type_prp                ptr parameter;
1305   dcl offsetnamep             ptr parameter;
1306 
1307   /* based */
1308 
1309   dcl 01 offsetname           aligned based (offsetnamep),
1310        02 count               fixed bin (9) unsigned unaligned,
1311        02 string              char (offsetname.count) unaligned;
1312   dcl 01 type_pr              aligned like type_pair based (type_prp);
1313 
1314   if type_pr.offsetname_relp = None
1315     then offsetnamep = null;
1316     else do;
1317 
1318       /* type-6 links use a valid acc_string with a zero length instead. */
1319 
1320       offsetnamep = addrel (defp, type_pr.offsetname_relp);
1321       if type_pr.type = LINK_CREATE_IF_NOT_FOUND & offsetname.count = 0
1322         then offsetnamep = null;
1323     end;
1324 
1325   end get_offsetnamep;
1326 
1327 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1328 ^L
1329 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1330 
1331 
1332 combine_linkage:
1333   proc (infop,                          /** call_info pointer   (in ) */
1334        segp,                            /** target segment ptr  (in ) */
1335        textp,                           /** text section ptr    (out) */
1336        linkp,                           /** linkage section ptr (out) */
1337        statp,                           /** static section ptr  (out) */
1338        symbp);                          /** symbol section ptr  (out) */
1339 
1340   /*** ****************************************************************/
1341   /***                                                                */
1342   /***    Name:     combine_linkage                                   */
1343   /***    Input:    infop, segp                                       */
1344   /***    Function: given a pointer to a segment (segp), combine the  */
1345   /***              linkage section (if necessary) and return the     */
1346   /***              pointers to the various sections.  This routine   */
1347   /***              also meters the call.                             */
1348   /***    Output:   textp, linkp, statp, symbp                        */
1349   /***                                                                */
1350   /*** ****************************************************************/
1351 
1352   /* parameters */
1353 
1354   dcl infop                   ptr parameter;
1355   dcl segp                    ptr parameter;
1356   dcl textp                   ptr parameter;
1357   dcl linkp                   ptr parameter;
1358   dcl statp                   ptr parameter;
1359   dcl symbp                   ptr parameter;
1360 
1361   /* based */
1362 
1363   dcl 01 info                 aligned like call_info based (infop);
1364 
1365   /* automatic */
1366 
1367   dcl 01 finish               aligned like usage automatic;
1368   dcl 01 start                aligned like usage automatic;
1369 
1370   /* combine the linkage section and meter the time and pagewaits */
1371 
1372   call usage_values (start.pf, start.time);
1373 
1374   textp = ptr (segp, 0);
1375   call link_man$other_linkage (textp, linkp, statp, symbp, code);
1376 
1377   call usage_values (finish.pf, finish.time);
1378 
1379   /* add in to metering info */
1380 
1381   info.get_linkage.pf = info.get_linkage.pf + (finish.pf - start.pf);
1382   info.get_linkage.time = info.get_linkage.time + (finish.time - start.time);
1383 
1384   if code ^= 0
1385     then call exit (infop, code, null);
1386 
1387   if linkp = null
1388     then call exit (infop, error_table_$no_linkage, null);
1389 
1390   end combine_linkage;
1391 
1392 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1393 ^L
1394 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1395 
1396 
1397 get_definition:
1398   proc (infop,                          /** call_info pointer   (in ) */
1399        segnamep,                        /** segname acc ptr     (in ) */
1400        offsetnamep,                     /** offsetname acc ptr  (in ) */
1401        segp,                            /** segment to search   (in ) */
1402        retry,                           /** will retry "main_"  (in ) */
1403        target_linkagep,                 /** linkp of target seg (out) */
1404        targetp);                        /** target pointer      (out) */
1405 
1406   /*** ****************************************************************/
1407   /***                                                                */
1408   /***    Name:     get_definition                                    */
1409   /***    Input:    infop, segnamep, offsetnamep, segp, retry         */
1410   /***    Function: combines the linkage section for the segment      */
1411   /***              specified, and then searches the definition       */
1412   /***              section for a definition matching the segname     */
1413   /***              and offsetname given and meters the search.       */
1414   /***              A pointer to the definition target is then        */
1415   /***              generated based on the definition class, the      */
1416   /***              section pointers returned by combining the        */
1417   /***              linkage, and the definition offset.  If the       */
1418   /***              search fails and the retry flag is set, we        */
1419   /***              try another search for the entrypoint "main_".    */
1420   /***    Output:   targetp                                           */
1421   /***                                                                */
1422   /*** ****************************************************************/
1423 
1424   /* constant */
1425 
1426   dcl 01 main_acc             aligned static options (constant),
1427        02 count               fixed bin (9) unsigned unaligned init (5),
1428        02 string              char (5) unaligned init ("main_");
1429 
1430   /* parameters */
1431 
1432   dcl infop                   ptr parameter;
1433   dcl segnamep                ptr parameter;
1434   dcl offsetnamep             ptr parameter;
1435   dcl retry                   bit (1) parameter;
1436   dcl target_linkagep         ptr parameter;
1437   dcl segp                    ptr parameter;
1438   dcl targetp                 ptr parameter;
1439 
1440   /* based */
1441 
1442   dcl based_ptr               ptr based;
1443   dcl 01 def                  aligned like definition based (defp);
1444   dcl 01 info                 aligned like call_info based (infop);
1445 
1446   /* automatic */
1447 
1448   dcl code                    fixed bin (35) automatic;
1449   dcl defp                    ptr automatic;
1450   dcl 01 finish               aligned like usage automatic;
1451   dcl linkp                   ptr automatic;
1452   dcl 01 start                aligned like usage automatic;
1453   dcl statp                   ptr automatic;
1454   dcl symbp                   ptr automatic;
1455   dcl textp                   ptr automatic;
1456 
1457   /* if we have no name to search for, don't bother trying */
1458 
1459   if offsetnamep = null
1460     then return;
1461 
1462   /* combine the linkage section and get the section pointers */
1463 
1464   call combine_linkage (infop, segp, textp, linkp, statp, symbp);
1465 
1466   /* save the linkage pointer in case we have first reference traps to run */
1467 
1468   target_linkagep = linkp;
1469 
1470   call usage_values (start.pf, start.time);
1471   call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep, offsetnamep,
1472        defp, code);
1473   call usage_values (finish.pf, finish.time);
1474 
1475   /* update the metering info */
1476 
1477   info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
1478   info.def_search.time = info.def_search.time + (finish.time - start.time);
1479 
1480   if retry & code = error_table_$no_ext_sym
1481     then do;
1482 
1483       /* retry the search with an offsetname of "main_" */
1484 
1485       call usage_values (start.pf, start.time);
1486       call get_defptr_ (linkp -> linkage_header.def_ptr, segnamep,
1487            addr (main_acc), defp, code);
1488       call usage_values (finish.pf, finish.time);
1489 
1490       /* add to the metering info */
1491 
1492       info.def_search.pf = info.def_search.pf + (finish.pf - start.pf);
1493       info.def_search.time = info.def_search.time + (finish.time - start.time);
1494 
1495     end;
1496 
1497   if code ^= 0
1498     then call exit (infop, code, null);
1499 
1500   /* check for an indirect definition */
1501 
1502   if def.indirect
1503     then do;
1504 
1505       /* an indirect definition (used only in component 0 of an       */
1506       /* object MSF) is used to refer to something in another         */
1507       /* component by adding another indirection through a partial    */
1508       /* link. In this case the thing_relp is the offset in the       */
1509       /* linkage section of a partial link to the actual definition   */
1510       /* target.  In some cases this link will have been snapped      */
1511       /* already by the msf_prelink_ first reference trap, if not, we */
1512       /* snap the link, and then use the indirection to give us our   */
1513       /* definition target.                                           */
1514 
1515       if def.class ^= CLASS_LINKAGE
1516         then call exit (infop, error_table_$bad_indirect_def, null);
1517 
1518       /* if the link is snapped, just get the value and return */
1519 
1520       targetp = addrel (linkp, def.thing_relp);
1521       if targetp -> its.its_mod = ITS_MODIFIER
1522         then do;
1523           targetp = targetp -> based_ptr;
1524           return;
1525         end;
1526 
1527       /* if not make sure it is a partial link */
1528 
1529       if targetp -> its.its_mod ^= FAULT_TAG_3
1530         then call exit (infop, error_table_$bad_indirect_def, null);
1531 
1532       /* then snap it, get the value and return */
1533 
1534       call snap_partial_link (infop, targetp, textp);
1535       targetp = targetp -> based_ptr;
1536       return;
1537     end;
1538 
1539   /* calculate the target based on the definition class and offset */
1540 
1541   if /* case */ def.class = CLASS_TEXT
1542     then targetp = addrel (textp, def.thing_relp);
1543   else if def.class = CLASS_LINKAGE
1544     then targetp = addrel (linkp, def.thing_relp);
1545   else if def.class = CLASS_STATIC
1546     then targetp = addrel (statp, def.thing_relp);
1547   else if def.class = CLASS_SYMBOL
1548     then targetp = addrel (symbp, def.thing_relp);
1549   else call exit (infop, error_table_$bad_class_def, null);
1550 
1551   end get_definition;
1552 
1553 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1554 ^L
1555 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1556 
1557 
1558 snap_partial_link:
1559   proc (infop,                          /** call_info pointer   (in ) */
1560        link_pairp,                      /** link pair to snap   (i/o) */
1561        refp);                           /** ref ptr for search  (in ) */
1562 
1563   /*** ****************************************************************/
1564   /***                                                                */
1565   /***    Name:     snap_partial_link                                 */
1566   /***    Input:    infop, link_pairp, refp                           */
1567   /***    Function: snaps a partial link to another component in      */
1568   /***              the same directory.                               */
1569   /***    Output:   link_pairp                                        */
1570   /***                                                                */
1571   /*** ****************************************************************/
1572 
1573   /* parameters */
1574 
1575   dcl infop                   ptr parameter;
1576   dcl link_pairp              ptr parameter;
1577   dcl refp                    ptr parameter;
1578 
1579   /* based */
1580 
1581   dcl based_ptr               ptr based;
1582   dcl 01 info                 aligned like call_info based (infop);
1583   dcl 01 link_pair            aligned like partial_link based (link_pairp);
1584 
1585   /* automatic */
1586 
1587   dcl 01 finish               aligned like usage automatic;
1588   dcl linkp                   ptr automatic;
1589   dcl refname                 char (32) automatic;
1590   dcl 01 start                aligned like usage automatic;
1591   dcl statp                   ptr automatic;
1592   dcl symbp                   ptr automatic;
1593   dcl textp                   ptr automatic;
1594 
1595   /* get the name of the other component */
1596 
1597   refname = ltrim (char (link_pair.component));
1598 
1599   /* perform the search and meter the time and pagewaits */
1600 
1601   call usage_values (start.pf, start.time);
1602   call fs_search$same_directory (refp, refname, segp, code);
1603   call usage_values (finish.pf, finish.time);
1604 
1605   /* update the metering info */
1606 
1607   info.search.pf = info.search.pf + (finish.pf - start.pf);
1608   info.search.time = info.search.time + (finish.time - start.time);
1609 
1610   /* if we didn't find it, something is broken . . . */
1611 
1612   if code ^= 0
1613     then call exit (infop, code, null);
1614 
1615   /* combine the target linkage section */
1616 
1617   call combine_linkage (infop, segp, textp, linkp, statp, symbp);
1618 
1619   /* now snap the link based on the type and offset in the link */
1620 
1621   if /* case */ link_pair.type = CLASS_TEXT
1622     then link_pairp -> based_ptr = addrel (textp, link_pair.offset);
1623   else if link_pair.type = CLASS_LINKAGE
1624     then link_pairp -> based_ptr = addrel (linkp, link_pair.offset);
1625   else if link_pair.type = CLASS_STATIC
1626     then link_pairp -> based_ptr = addrel (statp, link_pair.offset);
1627   else if link_pair.type = CLASS_SYMBOL
1628     then link_pairp -> based_ptr = addrel (symbp, link_pair.offset);
1629   else call exit (infop, error_table_$bad_indirect_def, null);
1630 
1631   end snap_partial_link;
1632 
1633 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1634 ^L
1635 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1636 
1637 
1638 snap:
1639   proc (targetp,                        /** value to snap to    (in ) */
1640        expression,                      /** offset to add       (in ) */
1641        link_pairp);                     /** link pair to snap   (i/o) */
1642 
1643   /*** ****************************************************************/
1644   /***                                                                */
1645   /***    Name:     snap                                              */
1646   /***    Input:    targetp, expression, link_pairp                   */
1647   /***    Function: completes the snapping of the link and sets       */
1648   /***              targetp to point to the same value as the snapped */
1649   /***              link;                                             */
1650   /***    Output:   targetp, link_pairp                               */
1651   /***                                                                */
1652   /*** ****************************************************************/
1653 
1654   /* parameters */
1655 
1656   dcl targetp                 ptr parameter;
1657   dcl expression              fixed bin (17) parameter;
1658   dcl link_pairp              ptr parameter;
1659 
1660   /* based */
1661 
1662   dcl 01 link_as_its          aligned like its based (link_pairp);
1663   dcl 01 link_pair            aligned like object_link based (link_pairp);
1664   dcl link_ptr                ptr based (link_pairp);
1665 
1666   /* automatic */
1667 
1668   dcl modifier                bit (6) automatic;
1669   dcl sb                      ptr automatic;
1670 
1671   /* add in the expression value */
1672 
1673   targetp = addrel (targetp, expression);
1674 
1675   /* get the original modifier from the link */
1676 
1677   modifier = link_pair.modifier;
1678 
1679   /* store the new pointer back into the link */
1680 
1681   link_ptr = targetp;
1682 
1683   /* put the link modifier back in */
1684 
1685   link_as_its.mod = modifier;
1686 
1687   /* put the run-depth into the pointer */
1688 
1689   sb = pds$stacks (level$get ());
1690   link_pair.run_depth = sb -> stack_header.run_unit_depth;
1691 
1692   end snap;
1693 
1694 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1695 ^L
1696 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1697 
1698 
1699 meter:
1700   proc (infop,                          /** call_info pointer   (in ) */
1701        type);                           /** link type           (in ) */
1702 
1703   /*** ****************************************************************/
1704   /***                                                                */
1705   /***    Name:     meter                                             */
1706   /***    Input:    infop, type                                       */
1707   /***    Function: given the call_info structure containing the      */
1708   /***              metering info for the last call, and the type of  */
1709   /***              link snapped, update the perprocess link meters   */
1710   /***              in pds and the system_wide meters in ahd.         */
1711   /***    Output:   none                                              */
1712   /***                                                                */
1713   /*** ****************************************************************/
1714 
1715   /* parameters */
1716 
1717   dcl infop                   ptr parameter;
1718   dcl type                    fixed bin (18) unsigned parameter;
1719 
1720   /* based */
1721 
1722   dcl 01 info                 aligned like call_info based (infop);
1723   dcl 01 lm                   aligned like link_meters based (lmp);
1724 
1725   /* automatic */
1726 
1727   dcl elapsed_time            fixed bin (35) automatic;
1728   dcl elapsed_pf              fixed bin (30) automatic;
1729   dcl bin_no                  fixed bin automatic;
1730   dcl lmp                     ptr automatic;
1731 
1732   /* get the final metering values */
1733 
1734   call usage_values (info.finish.pf, info.finish.time);
1735 
1736   /* calculate the elapsed time and pagewaits */
1737 
1738   elapsed_time = bin (info.finish.time - info.start.time, 35);
1739   elapsed_pf = bin (info.finish.pf - info.start.pf, 30);
1740 
1741   /* determine which bin this fault goes into */
1742 
1743   bin_no = max (1, min (4, divide (elapsed_time, 25000, 17, 0) + 1));
1744 
1745   /* update the counts in pds */
1746 
1747   pds$link_meters_bins (bin_no) = pds$link_meters_bins (bin_no) + 1;
1748   pds$link_meters_pgwaits (bin_no) = pds$link_meters_pgwaits (bin_no) +
1749        elapsed_pf;
1750   pds$link_meters_times (bin_no) = pds$link_meters_times (bin_no) +
1751        elapsed_time;
1752 
1753   /* update the ahd link meters */
1754 
1755   lmp = addr (ahd$link_meters (bin_no));
1756 
1757   lm.total = lm.total + 1;
1758   lm.pf = lm.pf + elapsed_pf;
1759   lm.time = lm.time + elapsed_time;
1760 
1761   if /* case */ (info.type = Link_fault | info.type = Link_force) &
1762        (type = LINK_REFNAME_BASE | type = LINK_REFNAME_OFFSETNAME)
1763     then do;
1764       lm.search_pf = lm.search_pf + info.search.pf;
1765       lm.search_time = lm.search_time + info.search.time;
1766       lm.get_linkage_pf = lm.get_linkage_pf + info.get_linkage.pf;
1767       lm.get_linkage_time = lm.get_linkage_time + info.get_linkage.time;
1768       lm.defsearch_pf = lm.defsearch_pf + info.def_search.pf;
1769       lm.defsearch_time = lm.defsearch_time + info.def_search.time;
1770     end;
1771   else if type = LINK_CREATE_IF_NOT_FOUND
1772     then do;
1773       lm.total_type_6 = lm.total_type_6 + 1;
1774       lm.type_6_pf = lm.type_6_pf + elapsed_pf;
1775       lm.type_6_time = lm.type_6_time + elapsed_time;
1776     end;
1777   else do;
1778     if info.type = Make_entry | info.type = Make_ptr
1779       then lm.tot_make_ptr = lm.tot_make_ptr + 1;
1780     lm.total_others = lm.total_others + 1;
1781     lm.others_pf = lm.others_pf + elapsed_pf;
1782     lm.others_time = lm.others_time + elapsed_time;
1783   end;
1784 
1785   end meter;
1786 
1787 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1788 ^L
1789 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1790 
1791 
1792 trap:
1793   proc (infop,                          /** call_info pointer   (in ) */
1794        target_linkagep,                 /** target linkage scn  (in ) */
1795        targetp);                        /** return value        (in ) */
1796 
1797   /*** ****************************************************************/
1798   /***                                                                */
1799   /***    Name:     trap                                              */
1800   /***    Input:    infop, target_linkagep, targetp                   */
1801   /***    Function: executes first reference traps in the target of   */
1802   /***              the link snapped.  Since this operation involves  */
1803   /***              calling back out to the user ring, we set fix up  */
1804   /***              the maching conditions, error codes, and return   */
1805   /***              values prior to calling trap_caller_caller_.      */
1806   /***              If there are no traps, we return and exit through */
1807   /***              the normal mechanism.                             */
1808   /***    Output:   none                                              */
1809   /***                                                                */
1810   /*** ****************************************************************/
1811 
1812   /* parameters */
1813 
1814   dcl infop                   ptr parameter;
1815   dcl target_linkagep         ptr parameter;
1816   dcl targetp                 ptr parameter;
1817 
1818   /* based */
1819 
1820   dcl 01 info                 aligned like call_info based (infop);
1821 
1822   /* now we see if we have first reference traps to run in the target */
1823   /* of the link we just finished snapping.                           */
1824 
1825   if target_linkagep ^= null
1826     then do;
1827       if target_linkagep -> virgin_linkage_header.first_ref_relp ^= None
1828         then do;
1829 
1830           /* we adjust the machine conditions now, since we won't     */
1831           /* return from trap_caller_caller_ . . .                    */
1832 
1833           call adjust_mc (mcp);
1834 
1835           /* set the return values */
1836 
1837           if info.type ^= Link_fault
1838             then a_code = 0;
1839 
1840           if /* case */ info.type = Make_ptr
1841             then a_targetp = targetp;
1842           else if info.type = Make_entry
1843             then addr (a_targete) -> based_entry.code_ptr = targetp;
1844 
1845           /* now we complete tracing of the fault, since the trap     */
1846           /* should not return.                                       */
1847 
1848           call page$enter_data ((targetp), linkage_fault_end);
1849 
1850           /* trap back to the user ring and execute the firstref traps */
1851 
1852           call trap_caller_caller_ (info.mcp, target_linkagep, null,
1853                null, null, info.codep, code);
1854 
1855           /* just in case we returned. . . */
1856 
1857           if info.mcp ^= null
1858             then call exit (infop, code, null);
1859         end;
1860 
1861     end;
1862 
1863   end trap;
1864 
1865 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1866 ^L
1867 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1868 
1869 
1870 adjust_mc:
1871   proc (mcp);                           /** machine conditions  (in ) */
1872 
1873   /*** ****************************************************************/
1874   /***                                                                */
1875   /***    Name:     adjust_mc                                         */
1876   /***    Input:    mcp                                               */
1877   /***    Function: adjusts the fault machine conditions so that the  */
1878   /***              fault can be restarted.                           */
1879   /***    Output:   none.                                             */
1880   /***                                                                */
1881   /*** ****************************************************************/
1882 
1883   /* parameters */
1884 
1885   dcl mcp                     ptr parameter;
1886 
1887   /* based */
1888 
1889   dcl 01 instr                aligned based (instrp),
1890        02 address             bit (18) unaligned,
1891        02 op_code             bit (12) unaligned,
1892        02 modifier            bit (6) unaligned;
1893 
1894   /* automatic */
1895 
1896   dcl scup                    ptr automatic;
1897   dcl instrp                  ptr automatic;
1898 
1899   /* don't try fixing machine conditions that aren't there. . . */
1900 
1901   if mcp = null
1902     then return;
1903 
1904   scup = addr (mcp -> mc.scu);
1905   instrp = addr (scup -> scu.even_inst);
1906   instr.address = scup -> scu.ca;
1907   instr.modifier = indirect;
1908 
1909   end adjust_mc;
1910 
1911 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1912 ^L
1913 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1914 
1915 connect_fail_handler_:
1916   proc (a_mcp,                          /** machine conditions  (in ) */
1917        a_condition_name,                /** condition name      (in ) */
1918        a_wcp,                           /** crawlout info       (in ) */
1919        a_infop,                         /** condition info      (in ) */
1920        a_continue_flag);                /** continue flag       (out) */
1921 
1922   /*** ****************************************************************/
1923   /***                                                                */
1924   /***    Name:     connect_fail_handler_                             */
1925   /***    Input:    mcp, condition_name, wcp, infop, continue_flag    */
1926   /***    Function: handles the seg_fault condition.  This handler    */
1927   /***              in enabled prior to the definition search in      */
1928   /***              type-4 and type-6 links.  When invoked, the       */
1929   /***              faulting segment is compared with the global      */
1930   /***              variable segp, it the segments are not the same,  */
1931   /***              this means we have faulted somewhere unexpected,  */
1932   /***              so we continue to signal.  If the fault occurred  */
1933   /***              on the expected segment, we assume it is because  */
1934   /***              of a connection failure and simply return abort   */
1935   /***              the link fault returning the appropriate code.    */
1936   /***                                                                */
1937   /***              NB.  Because of the machanism involved, this      */
1938   /***                   procedure assumes that the global variables  */
1939   /***                   segp and call_infop are set prior to the     */
1940   /***                   establishment of the condition handler.      */
1941   /***    Output:   none                                              */
1942   /***                                                                */
1943   /*** ****************************************************************/
1944 
1945   /* parameters */
1946 
1947   dcl a_mcp                   ptr parameter;
1948   dcl a_condition_name        char (*) parameter;
1949   dcl a_wcp                   ptr parameter;
1950   dcl a_infop                 ptr parameter;
1951   dcl a_continue_flag         bit (1) parameter;
1952 
1953   /* automatic */
1954 
1955   dcl faulted_segno           fixed bin (18) automatic;
1956   dcl segno                   fixed bin (18) automatic;
1957   dcl scup                    ptr automatic;
1958 
1959   /* get the segment numbers of the faulting segment and the target   */
1960   /* segment of the current link snapping operation                   */
1961 
1962   a_continue_flag = false;
1963   scup = addr (a_mcp -> mc.scu);
1964   faulted_segno = bin (scup -> scu.tpr.tsr, 18);
1965   segno = bin (baseno (segp), 18);
1966 
1967   /* if they are different, continue to signal */
1968 
1969   if faulted_segno ^= segno
1970     then do;
1971       a_continue_flag = true;
1972       return;
1973     end;
1974 
1975   /* otherwise assume a connection failure, and return the code */
1976 
1977   connect_fail_code = a_mcp -> mc.errcode;
1978 
1979   /* NB.  here we set a global code and do a non-local goto which     */
1980   /*      then calls the exit procedure rather than calling exit      */
1981   /*      directly in order to keep the exit and adjust_mc procedures */
1982   /*      as quick procedures.                                        */
1983 
1984   goto CONNECT_FAIL_EXIT;
1985 
1986   end connect_fail_handler_;
1987 
1988 CONNECT_FAIL_EXIT:
1989   call exit (call_infop, connect_fail_code, null);
1990 
1991 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1992 ^L
1993 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
1994 
1995 
1996 exit:
1997   proc (infop,                          /** call_info pointer   (in ) */
1998        code,                            /** code to return      (in ) */
1999        targetp);                        /** target (for trace)  (in ) */
2000 
2001   /*** ****************************************************************/
2002   /***                                                                */
2003   /***    Name:     exit                                              */
2004   /***    Input:    info, code, targetp                               */
2005   /***    Function: returns from the fault or gate entry and cleans   */
2006   /***              up.  This procedure differs depending on where    */
2007   /***              we entered from:                                  */
2008   /***                link_fault - save the code in the machine       */
2009   /***                             conditions, adjust the machine     */
2010   /***                             conditions to allow restart, reset */
2011   /***                             the validation level back,         */
2012   /***                             complete the fault trace, and exit */
2013   /***                link_force - set the code to be returned,       */
2014   /***                             complete the fault trace, and exit */
2015   /***                make_ptr   - set the return pointer and code,   */
2016   /***                             complete the fault trace, and exit */
2017   /***                make_entry - set the return entry and code,     */
2018   /***                             complete the fault trace, and exit */
2019   /***                                                                */
2020   /***              NB.  When completing the fault trace, the code to */
2021   /***                   be returned is examined.  If it it nonzero,  */
2022   /***                   the info_ptr for the call to page$enter_data */
2023   /***                   is 0|0.  If the code is zero, the targetp    */
2024   /***                   value is passed to page$enter_data.          */
2025   /***    Output:   none                                              */
2026   /***                                                                */
2027   /*** ****************************************************************/
2028 
2029   /* parameters */
2030 
2031   dcl infop                   ptr parameter;
2032   dcl code                    fixed bin (35) parameter;
2033   dcl targetp                 ptr parameter;
2034 
2035   /* based */
2036 
2037   dcl 01 info                 aligned like call_info based (infop);
2038   dcl 01 exit_mc              aligned like mc based (info.mcp);
2039 
2040   /* if we had a make_ptr or make_entry call, set the return value */
2041 
2042   if /* case */ info.type = Make_ptr
2043     then a_targetp = targetp;
2044   else if info.type = Make_entry
2045     then addr (a_targete) -> based_entry.code_ptr = targetp;
2046 
2047   /* return the code */
2048 
2049   if info.type = Link_fault
2050     then do;
2051       call level$set ((info.save_ring));
2052       exit_mc.errcode = code;
2053       call adjust_mc (info.mcp);
2054     end;
2055     else a_code = code;
2056 
2057   /* complete fault tracing */
2058 
2059   if code = 0
2060     then call page$enter_data ((targetp), linkage_fault_end);
2061     else call page$enter_data (baseptr (0), linkage_fault_end);
2062 
2063   /* non-local goto to outer level and return */
2064 
2065   goto EXIT;
2066 
2067   end exit;
2068 
2069 EXIT:
2070   return;
2071 
2072 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
2073 %page;
2074 /****  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
2075 
2076 
2077 %include definition_dcls;
2078 %page;
2079 %include its;
2080 %page;
2081 %include link_meters;
2082 %page;
2083 %include mc;
2084 %page;
2085 %include object_link_dcls;
2086 %page;
2087 %include stack_header;
2088 %page;
2089 %include system_link_names;
2090 %page;
2091 %include trace_types;
2092 
2093   end link_snap;