1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35 link_snap:
36 proc;
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
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
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
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
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
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
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
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);
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
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
265
266 call_info.codep = null;
267
268
269
270 scup = addr (mc.scu (0));
271 call level$set (bin (scu.ppr.prr, 3));
272
273
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
279
280 call page$enter_data ((instrp), linkage_fault_start);
281
282
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,
296 a_dummy,
297 a_code);
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313 mcp = null;
314
315
316
317 link_pairp = a_link_pairp;
318
319
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
327
328
329 call_info.codep = addr (a_code);
330
331
332
333
334 call page$enter_data ((link_pairp), linkage_fault_start);
335
336
337 ^L
338
339
340
341 link_join:
342
343
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
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
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
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
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
379
380 exprp = addrel (defp, link_pair.expression_relp);
381 type_prp = addrel (defp, expr.type_relp);
382
383
384
385
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
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
403
404 if type_pr.type = LINK_SELF_OFFSETNAME & type_pr.segname_relp = CLASS_HEAP
405 then do;
406
407
408
409
410
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
419
420
421
422
423 if type_pr.type ^= LINK_CREATE_IF_NOT_FOUND & type_pr.trap_relp ^= None
424 then do;
425
426
427
428
429
430
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
437
438 call exit (call_infop, code, baseptr (0));
439 end;
440
441
442
443
444 if 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
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
511
512
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
524
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
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,
564 a_seg_name,
565 a_offset_name,
566 a_targetp,
567 a_code);
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586 a_targetp = null;
587
588
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,
601 a_seg_name,
602 a_offset_name,
603 a_targete,
604 a_code);
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624 call_info.type = Make_entry;
625
626
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
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
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
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
660
661 refp = a_refp;
662 seg_name = a_seg_name;
663 offset_name = a_offset_name;
664
665
666
667 a_code = 0;
668
669
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
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
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
704
705 if call_info.type = Make_ptr
706 then call meter (call_infop, (LINK_REFNAME_BASE));
707 else do;
708
709
710
711
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
722
723 segnamep = addr (automatic_segname);
724 offsetnamep = addr (automatic_offsetname);
725
726
727
728 unspec (automatic_segname) = ""b;
729 unspec (automatic_offsetname) = ""b;
730
731
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
742
743
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,
763 linkp,
764 defp,
765 type_prp,
766 offset_name,
767 init_infop,
768 star_system_sw);
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
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
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
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
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
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
837
838 if type_pr.type = LINK_CREATE_IF_NOT_FOUND
839 then do;
840
841
842
843 if segname.string = "stat_"
844 then do;
845 star_system_sw = true;
846 return;
847 end;
848
849
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_"
857 then offset_name = "blnk*com";
858 return;
859 end;
860 else ;
861
862
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
876
877
878
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
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,
911 link_pairp,
912 defp,
913 linkp,
914 type_prp,
915 offset_name,
916 init_infop,
917 targetp);
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
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
945
946 dcl 01 info aligned like call_info based (infop);
947
948
949
950 dcl code fixed bin (35) automatic;
951 dcl sb ptr automatic;
952
953
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
960
961 call deferred_init (infop, init_infop, linkp);
962
963 Note
964
965
966
967
968
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
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,
989 defp,
990 linkp,
991 type_prp,
992 targetp);
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
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
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
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
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
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
1045
1046 call deferred_init (infop, init_infop, linkp);
1047
1048
1049
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
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,
1069 init_infop,
1070 linkp);
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099 dcl infop ptr parameter;
1100 dcl init_infop ptr parameter;
1101 dcl linkp ptr parameter;
1102
1103
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
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
1122
1123 if init_infop = null
1124 then return;
1125
1126 if init_info.header.type ^= INIT_DEFERRED
1127 then return;
1128
1129
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
1136
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
1144
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
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,
1167 class,
1168 textp,
1169 targetp);
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
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
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
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
1204
1205 if 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,
1224 segnamep,
1225 refp,
1226 MSF_sw,
1227 segp,
1228 code);
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
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
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
1258
1259 dcl 01 finish aligned like usage automatic;
1260 dcl 01 start aligned like usage automatic;
1261
1262
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
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,
1284 defp,
1285 type_prp,
1286 offsetnamep);
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302 dcl infop ptr parameter;
1303 dcl defp ptr parameter;
1304 dcl type_prp ptr parameter;
1305 dcl offsetnamep ptr parameter;
1306
1307
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
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,
1334 segp,
1335 textp,
1336 linkp,
1337 statp,
1338 symbp);
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
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
1362
1363 dcl 01 info aligned like call_info based (infop);
1364
1365
1366
1367 dcl 01 finish aligned like usage automatic;
1368 dcl 01 start aligned like usage automatic;
1369
1370
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
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,
1399 segnamep,
1400 offsetnamep,
1401 segp,
1402 retry,
1403 target_linkagep,
1404 targetp);
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
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
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
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
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
1458
1459 if offsetnamep = null
1460 then return;
1461
1462
1463
1464 call combine_linkage (infop, segp, textp, linkp, statp, symbp);
1465
1466
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
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
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
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
1501
1502 if def.indirect
1503 then do;
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515 if def.class ^= CLASS_LINKAGE
1516 then call exit (infop, error_table_$bad_indirect_def, null);
1517
1518
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
1528
1529 if targetp -> its.its_mod ^= FAULT_TAG_3
1530 then call exit (infop, error_table_$bad_indirect_def, null);
1531
1532
1533
1534 call snap_partial_link (infop, targetp, textp);
1535 targetp = targetp -> based_ptr;
1536 return;
1537 end;
1538
1539
1540
1541 if 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,
1560 link_pairp,
1561 refp);
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575 dcl infop ptr parameter;
1576 dcl link_pairp ptr parameter;
1577 dcl refp ptr parameter;
1578
1579
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
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
1596
1597 refname = ltrim (char (link_pair.component));
1598
1599
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
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
1611
1612 if code ^= 0
1613 then call exit (infop, code, null);
1614
1615
1616
1617 call combine_linkage (infop, segp, textp, linkp, statp, symbp);
1618
1619
1620
1621 if 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,
1640 expression,
1641 link_pairp);
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656 dcl targetp ptr parameter;
1657 dcl expression fixed bin (17) parameter;
1658 dcl link_pairp ptr parameter;
1659
1660
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
1667
1668 dcl modifier bit (6) automatic;
1669 dcl sb ptr automatic;
1670
1671
1672
1673 targetp = addrel (targetp, expression);
1674
1675
1676
1677 modifier = link_pair.modifier;
1678
1679
1680
1681 link_ptr = targetp;
1682
1683
1684
1685 link_as_its.mod = modifier;
1686
1687
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,
1701 type);
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717 dcl infop ptr parameter;
1718 dcl type fixed bin (18) unsigned parameter;
1719
1720
1721
1722 dcl 01 info aligned like call_info based (infop);
1723 dcl 01 lm aligned like link_meters based (lmp);
1724
1725
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
1733
1734 call usage_values (info.finish.pf, info.finish.time);
1735
1736
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
1742
1743 bin_no = max (1, min (4, divide (elapsed_time, 25000, 17, 0) + 1));
1744
1745
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
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 (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,
1794 target_linkagep,
1795 targetp);
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814 dcl infop ptr parameter;
1815 dcl target_linkagep ptr parameter;
1816 dcl targetp ptr parameter;
1817
1818
1819
1820 dcl 01 info aligned like call_info based (infop);
1821
1822
1823
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
1831
1832
1833 call adjust_mc (mcp);
1834
1835
1836
1837 if info.type ^= Link_fault
1838 then a_code = 0;
1839
1840 if 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
1846
1847
1848 call page$enter_data ((targetp), linkage_fault_end);
1849
1850
1851
1852 call trap_caller_caller_ (info.mcp, target_linkagep, null,
1853 null, null, info.codep, code);
1854
1855
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);
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885 dcl mcp ptr parameter;
1886
1887
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
1895
1896 dcl scup ptr automatic;
1897 dcl instrp ptr automatic;
1898
1899
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,
1917 a_condition_name,
1918 a_wcp,
1919 a_infop,
1920 a_continue_flag);
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
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
1954
1955 dcl faulted_segno fixed bin (18) automatic;
1956 dcl segno fixed bin (18) automatic;
1957 dcl scup ptr automatic;
1958
1959
1960
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
1968
1969 if faulted_segno ^= segno
1970 then do;
1971 a_continue_flag = true;
1972 return;
1973 end;
1974
1975
1976
1977 connect_fail_code = a_mcp -> mc.errcode;
1978
1979
1980
1981
1982
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,
1998 code,
1999 targetp);
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031 dcl infop ptr parameter;
2032 dcl code fixed bin (35) parameter;
2033 dcl targetp ptr parameter;
2034
2035
2036
2037 dcl 01 info aligned like call_info based (infop);
2038 dcl 01 exit_mc aligned like mc based (info.mcp);
2039
2040
2041
2042 if 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
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
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
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;