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
36
37
38
39
40
41
42
43
44
45
46
47
48 bind_: procedure (argp);
49
50 declare argp pointer;
51
52
53
54
55 declare relocate_symbol_ external entry ();
56 declare com_err_ external entry options (variable);
57 declare decode_link_$init external entry ();
58 declare dissect_object_ external entry (pointer);
59 declare dissect_object_$init external entry ();
60 declare ext_link_$init external entry ();
61 declare ext_link_$finish entry ();
62 declare generate_def_$init external entry ();
63 declare get_temp_segment_ external entry (char (*), ptr, fixed bin (35));
64 declare form_bind_map_ external entry (pointer, fixed bin (35));
65 declare form_link_info_ external entry (pointer, fixed bin (35));
66 declare get_wdir_ external entry () returns (char (168) aligned);
67 declare generate_first_ref_traps_ external entry ();
68 declare int_link_$init external entry ();
69 declare hcs_$set_bc_seg external entry (pointer, fixed bin (24), fixed bin (35));
70 declare hcs_$chname_seg ext entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35));
71 declare ioa_ external entry options (variable);
72 declare ioa_$rs external entry options (variable);
73 declare incorporate_options_ external entry ();
74 declare make_bindmap_ external entry ();
75 declare make_defs_$regenerate_block external entry (pointer);
76 declare make_defs_$open_section external entry ();
77 declare make_defs_$close_section external entry ();
78 declare make_bound_object_map_ external entry (fixed bin (35));
79 declare parse_bindfile_ external entry ();
80 declare rebuild_object_$init external entry ();
81 declare rebuild_object_ external entry (pointer);
82 declare release_temp_segment_ external entry (char (*), ptr, fixed bin (35));
83 declare temp_mgr_$allocate external entry (fixed bin);
84 declare temp_mgr_$reserve external entry (pointer);
85 declare temp_mgr_$init external entry ();
86 declare temp_mgr_$make_object external entry ();
87 declare temp_mgr_$close_files external entry ();
88 declare terminate_file_ external entry (ptr, fixed bin (24), bit (*), fixed bin (35));
89 declare tssi_$clean_up_segment external entry (pointer);
90 declare tssi_$get_segment external entry (char (*) aligned, char (*) aligned, ptr, ptr, fixed bin (35));
91 declare tssi_$finish_segment external entry (pointer, fixed bin (24), bit (36) aligned,
92 ptr, fixed bin (35));
93
94
95
96 declare (i, pos, nobjects) fixed bin;
97 declare hash_index fixed bin (34);
98 declare (val, lng, symb_relc) fixed bin (18);
99 declare code fixed bin (35);
100 declare list_acinfop pointer;
101 declare (inpp, linkptr, old_ptr, p, sp, textp) pointer;
102 declare (dirname char (168), segname char (32)) aligned;
103 declare listname char (32) aligned;
104 declare whalf char (3) aligned;
105
106 declare 1 x aligned,
107 2 obj_ptr pointer,
108 2 list_ptr pointer,
109 2 list_bc fixed bin (24),
110 2 long fixed bin,
111 2 nopts fixed bin;
112
113
114
115 declare (addr, addrel, bin, bit, divide, fixed, hbound, index, min, mod, null, rel, substr, unspec) builtin;
116 declare size builtin;
117 declare rank builtin;
118
119 declare cleanup condition;
120 declare fatal_binder_error condition;
121
122
123
124 declare (error_table_$pathlong, error_table_$segnamedup) ext fixed bin (35);
125
126
127
128 declare BINDER_INPUT_VERSION_1 char (4) aligned internal static options (constant) init ("BI.1");
129 declare NL char (1) static options (constant) init ("
130 ");
131 declare FF char (1) static options (constant) init ("^L");
132
133
134
135 declare linksection (val) aligned fixed bin based;
136 declare 1 halfword aligned based,
137 2 lhe18 bit (18) unaligned,
138 2 rhe18 bit (18) unaligned;
139 declare 1 pr_offset aligned based,
140 2 dum1 bit (3) unaligned,
141 2 lhe15 bit (15) unaligned,
142 2 dum2 bit (3) unaligned,
143 2 rhe15 bit (15) unaligned;
144 declare 1 clngns_overlay aligned based (addr (comp.clngns)),
145 2 dum bit (35) unaligned,
146 2 odd bit (1) unaligned;
147 declare reset_bx (bx_$size) fixed bin (35) based (addr (bx_$area_begin));
148 declare based_string char (10000) based (p);
149
150 declare 1 temp_seg based aligned,
151 2 next_temp_ptr ptr,
152 2 storage bit (0);
153
154 %page;
155
156
157
158
159
160 inpp = argp;
161
162 reset_bx (*) = 0;
163
164 bx_$inpp = inpp;
165 bx_$caller = inp.caller_name;
166
167 list_acinfop,
168 old_ptr,
169 bx_$temp,
170 bx_$bsegp,
171 bx_$temp_bsegp,
172 bx_$bseg_acinfop = null;
173
174
175 on cleanup begin;
176 if bx_$temp_bsegp ^= null then call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, 0);
177
178 if list_acinfop ^= null then call tssi_$clean_up_segment (list_acinfop);
179
180
181
182
183 if old_ptr ^= null then do;
184 call release_temp_segment_ ("bind_", inpp, (0));
185 inpp = old_ptr;
186 end;
187
188 do p = bx_$temp repeat sp while (p ^= null);
189 sp = p -> temp_seg.next_temp_ptr;
190 call release_temp_segment_ ("bind", p, code);
191 if code ^= 0 then
192 do;
193 call com_err_ (code, inp.caller_name);
194 return;
195 end;
196 end;
197 end;
198
199
200 if inp.version = BINDER_INPUT_VERSION_1 then call CONVERT_I_TO_II ();
201 else if inp.version ^= BINDER_INPUT_VERSION_2 then do;
202 call com_err_ (0, inp.caller_name, "Invalid version ""^4a"" in binder input structure.", inp.version);
203 return;
204 end;
205
206
207 bx_$debug = fixed (inp.debug, 1); debug
208 bx_$brief = bin (inp.brief_opt, 1);
209 bx_$force_order = bin (inp.force_order_opt, 1);
210
211 on fatal_binder_error begin;
212 bx_$fatal_error = 1;
213 go to return;
214 end;
215
216
217
218 call temp_mgr_$init;
219
220 if bx_$fatal_error = 1 then goto return;
221
222 bx_$v_lng = rank (substr (bx_$vers_name, 1, 1));
223
224 sntp,
225 bx_$sntp = bx_$freep;
226 snt.max_size = bx_$snt_limit;
227 call temp_mgr_$reserve (addr (snt.entry (snt.max_size + 1)));
228
229 if bx_$fatal_error ^= 0 then goto return;
230
231 odnp,
232 bx_$odnp = bx_$freep;
233 od.max_size = bx_$oddname_limit;
234 call temp_mgr_$reserve (addr (od.entry (od.max_size + 1)));
235
236 rptp = bx_$freep;
237 bx_$first_rptp,
238 bx_$last_rptp = rptp;
239 call temp_mgr_$reserve (addrel (addr (rpt), size (rpt)));
240 rpt.thread = null;
241 rpt.npt = 0;
242
243 bx_$ncomp = inp.nobj;
244 bx_$adnp = null;
245
246 call parse_bindfile_;
247 if bx_$fatal_error = 1 then goto return;
248
249 inpp = bx_$inpp;
250
251 if list_seg then do;
252 i = index (bx_$bound_segname, " ");
253 if ((i = 0) | (i > 27)) then do;
254 call com_err_ (error_table_$pathlong, inp.caller_name, "Cannot add .list to ^a", bx_$bound_segname);
255 bx_$fatal_error = 1;
256 go to return;
257 end;
258 end;
259
260 ctp,
261 bx_$ctp = bx_$freep;
262 nobjects = bx_$ncomp;
263 call temp_mgr_$reserve (addr (comp_tbl (nobjects + 1)));
264 if bx_$fatal_error = 1 then goto return;
265
266
267 call temp_mgr_$make_object;
268 if bx_$fatal_error = 1 then goto return;
269
270 if ^inp.brief_opt then call ioa_ ("Binding ^a", bx_$bound_segname);
271
272
273 %page;
274
275
276
277
278
279
280 call dissect_object_$init;
281
282 do i = 1 to nobjects;
283 ctep,
284 comp_tbl (i) = bx_$freep;
285 call temp_mgr_$reserve (addr (comp.last_item));
286 unspec (comp) = ""b;
287 comp.cindex = i;
288 comp.filename = inp.obj (i).filename;
289 lng = index (comp.filename, " ");
290 if lng = 0 then lng = 32;
291 else lng = lng - 1;
292 comp.fn_lng = lng;
293 comp.ctxtp = inp.obj (i).base;
294 comp.cbitcount = inp.obj (i).bitcount;
295 call dissect_object_ (ctep);
296 end;
297
298 if bx_$tintlng >= 16384 then do;
299 call com_err_ (0, inp.caller_name,
300 "length of internal static >= 16384, the maximum static section length");
301 bx_$fatal_error = 1;
302 end;
303
304 bx_$maxlinklng = min (bx_$maxlinklng, 16384);
305 if (bx_$has_comb_stat = 0 & bx_$has_sep_stat = 1)
306 then bx_$bound_sep_stat = 1;
307 else bx_$bound_sep_stat = 0;
308
309 if bx_$fatal_error = 1 then go to return;
310
311 call incorporate_options_;
312 if bx_$fatal_error = 1 then goto return;
313
314
315
316 do hash_index = 0 to hbound (snt.hash_table, 1);
317 snt.hash_table (hash_index) = null;
318 end;
319 do i = 1 to snt.n_names;
320
321
322
323 hash_index = 0;
324 do pos = 1 to min (snt.entry (i).lng, 24);
325 hash_index = 2 * hash_index + bin (unspec (substr (snt.entry (i).name, pos, 1)), 9);
326 end;
327 hash_index = mod (hash_index, hbound (snt.hash_table, 1) + 1);
328
329
330
331 snt.entry (i).hash_thread = snt.hash_table (hash_index);
332 snt.hash_table (hash_index) = addr (snt.entry (i));
333 end;
334
335 %page;
336
337
338
339
340
341
342 val = bx_$textlng;
343 val = divide (val + 1, 2, 17, 0) * 2;
344 bx_$textlng = val;
345
346
347 bx_$tdefp = addrel (bx_$temp_bsegp, val);
348 call temp_mgr_$allocate (bx_$maxlinklng);
349 if bx_$bound_sep_stat = 1 then do;
350 bx_$tintp = bx_$freep;
351 val = 8;
352 linkptr,
353 bx_$tlinkp = addrel (bx_$tintp, bx_$tintlng);
354 end;
355 else do;
356 linkptr,
357 bx_$tlinkp = bx_$freep;
358 val = bx_$tintlng + 8;
359 bx_$tintp = addrel (linkptr, 8);
360 end;
361 call temp_mgr_$reserve (addrel (bx_$freep, bx_$maxlinklng));
362
363 strmp,
364 bx_$strmp = bx_$freep;
365 strm.max_size = bx_$stringmap_limit;
366 call temp_mgr_$reserve (addr (strm.entry (strm.max_size + 2)));
367
368
369
370 linkptr -> virgin_linkage_header.link_begin = bit (bin (val, 18), 18);
371 bx_$tlinklng = val;
372
373
374
375 bx_$n_lng = index (bx_$bound_segname, " ") - 1;
376 if bx_$n_lng = -1 then bx_$n_lng = 32;
377
378
379 i = divide (bx_$v_lng + 3, 4, 17, 0);
380 bx_$s_lng = divide ((27 + i), 8, 17, 0) * 8;
381 call rebuild_object_$init;
382 call decode_link_$init;
383 call int_link_$init;
384 call make_defs_$open_section;
385 call ext_link_$init;
386 call generate_def_$init;
387
388 symb_relc = bx_$s_lng;
389 do i = 1 to nobjects;
390 ctep = comp_tbl (i);
391
392 if clngns_overlay.odd then comp.cpads = 1;
393 comp.crels = symb_relc;
394 symb_relc = symb_relc + comp.clngns + comp.cpads;
395
396 if comp.ignore = 0 then call rebuild_object_ (ctep);
397 end;
398
399
400 do i = 1 to nobjects;
401 ctep = comp_tbl (i);
402 if comp.ignore = 0 then call make_defs_$regenerate_block (ctep);
403 end;
404
405 if bx_$n_firstrefs > 0 then call generate_first_ref_traps_ ();
406
407
408
409 call make_defs_$close_section;
410
411 call ext_link_$finish;
412 if bx_$fatal_error = 1 then goto return;
413
414
415 %page;
416
417
418
419
420 val = bx_$curdeflng;
421 val = divide (val + 1, 2, 17, 0) * 2;
422 bx_$curdeflng = val;
423 if bx_$bound_sep_stat = 0 then do;
424 bx_$blnkp = addrel (bx_$tdefp, val);
425 val = bx_$tlinklng;
426 bx_$blnkp -> linksection = bx_$tlinkp -> linksection;
427 bx_$bstatp = addrel (bx_$blnkp, 8);
428 end;
429 else do;
430 bx_$bstatp = addrel (bx_$tdefp, val);
431 val = bx_$tintlng + bx_$tlinklng;
432 bx_$bstatp -> linksection = bx_$tintp -> linksection;
433 bx_$blnkp = addrel (bx_$bstatp, bx_$tintlng);
434 val = bx_$tlinklng;
435 end;
436 bx_$t_lng = bx_$textlng + bx_$curdeflng;
437 val = divide (val + 1, 2, 17, 0) * 2;
438 bx_$l_lng = val;
439 bx_$bdefp = bx_$tdefp;
440 bx_$d_lng = bx_$curdeflng;
441 bx_$i_lng = bx_$tintlng;
442
443 bx_$blnkp -> virgin_linkage_header.linkage_section_lng = bit (bin (bx_$l_lng, 18), 18);
444 bx_$blnkp -> virgin_linkage_header.def_offset = rel (bx_$bdefp);
445 bx_$blnkp -> virgin_linkage_header.static_length = bit (bin (bx_$i_lng, 18), 18);
446
447 bx_$bsymp = addrel (bx_$blnkp, bx_$l_lng);
448
449 call relocate_symbol_;
450 if bx_$fatal_error = 1 then goto return;
451
452
453
454
455
456
457 call make_bindmap_;
458
459
460 do rptp = bx_$first_rptp repeat rpt.thread while (rptp ^= null);
461
462 do i = 1 to rpt.npt;
463 rptep = addr (rpt.entry (i));
464 if rpte.pbase = "t" then textp = bx_$temp_bsegp;
465 else if rpte.pbase = "l" then textp = bx_$blnkp;
466 else if rpte.pbase = "s" then textp = bx_$bsymp;
467 textp = addrel (textp, rpte.poffset);
468 whalf = rpte.halfword;
469 if whalf = "lhe" then val = fixed (textp -> halfword.lhe18, 18);
470 else if whalf = "l15" then val = fixed (textp -> pr_offset.lhe15, 15);
471 else if whalf = "rhe" then val = fixed (textp -> halfword.rhe18, 18);
472 val = val + fixed (rpte.pexpr, 18);
473 if rpte.code = "l" then val = val + bin (rel (bx_$blnkp), 18);
474 else if rpte.code = "s" then val = val + bin (rel (bx_$bsymp), 18);
475 if whalf = "lhe" then textp -> halfword.lhe18 = bit (bin (val, 18), 18);
476 else if whalf = "l15" then textp -> pr_offset.lhe15 = addr (val) -> pr_offset.rhe15;
477 else textp -> halfword.rhe18 = bit (bin (val, 18), 18);
478 end;
479 end;
480
481
482
483
484 call make_bound_object_map_ (code);
485 if code ^= 0 then
486 do;
487 call com_err_ (0, inp.caller_name, "Cannot generate object map");
488 bx_$fatal_error = 1;
489 bx_$o_lng = bx_$t_lng + (bx_$bound_sep_stat * bx_$i_lng) + bx_$l_lng + bx_$s_lng;
490 bx_$bseg_bitcount = bx_$o_lng * 36;
491 end;
492
493 bx_$o_lng = divide (bx_$bseg_bitcount, 36, 17, 0);
494
495
496 if bx_$fatal_error = 1 then goto return;
497 call hcs_$set_bc_seg (bx_$temp_bsegp, bx_$bseg_bitcount, code);
498
499 if list_seg = "1"b then
500 do;
501 dirname = get_wdir_ ();
502 segname = bx_$bound_segname;
503 i = index (segname, " ");
504 substr (segname, i, 5) = ".list";
505 list_ptr = null;
506 call tssi_$get_segment (dirname, segname, list_ptr, list_acinfop, code);
507 if list_ptr = null then
508 do;
509 call com_err_ (code, inp.caller_name, segname);
510 bx_$fatal_error = 1;
511 goto return;
512 end;
513 listname = segname;
514 substr (listname, i, 5) = ".map ";
515 call hcs_$chname_seg (list_ptr, "", listname, code);
516 if code ^= 0 then
517 if code ^= error_table_$segnamedup then
518 do;
519 call com_err_ (0, inp.caller_name, "Cannot add name ^a to segment ^a", listname, segname);
520 end;
521 obj_ptr = bx_$temp_bsegp;
522 list_bc = 0;
523 if list_opt = "1"b then
524 do;
525 if inp.bindfilep = null then goto output_bindmap;
526 p = list_ptr;
527 call ioa_$rs ("^/^/^-^-Bindfile for ^a^/", dirname, val, bx_$bound_segname);
528 substr (based_string, 1, val) = substr (dirname, 1, val);
529 lng = divide (inp.bindfile_bc, 9, 17, 0);
530 substr (based_string, val + 1, lng) = substr (bindfilep -> based_string, 1, lng);
531 lng = lng + val;
532 substr (based_string, lng + 1, 2) = FF || NL;
533 list_bc = (lng + 2) * 9;
534 end;
535 output_bindmap:
536 long = 1;
537 nopts = 0;
538 if map_opt = "1"b then call form_bind_map_ (addr (x), code);
539 if list_opt = "1"b then
540 do;
541 unspec (x.long) = "740000000000"b3;
542 lng = divide (list_bc, 9, 17, 0);
543 substr (list_ptr -> based_string, lng + 1, 2) = FF || NL;
544 list_bc = list_bc + 18;
545 call form_link_info_ (addr (x), code);
546 end;
547 if list_ptr ^= null then call tssi_$finish_segment
548 (list_ptr, list_bc, "1011"b, list_acinfop, code);
549 end;
550
551 return:
552 if bx_$fatal_error = 1 then
553 do;
554 bx_$addname = 0;
555 call com_err_ (0, inp.caller_name,
556 "Fatal error has occurred; binding of ^a unsuccessful.^/The incomplete version exists in [pd]>^a.",
557 bx_$bound_segname, bx_$bound_segname);
558 end;
559
560 call temp_mgr_$close_files;
561
562 if old_ptr ^= null then do;
563 call release_temp_segment_ ("bind_", inpp, (0));
564 inpp = old_ptr;
565 end;
566
567
568 return;
569 %page;
570
571 CONVERT_I_TO_II:
572 proc ();
573
574
575
576
577
578 dcl idx fixed bin;
579
580
581
582 dcl 1 v1_inp aligned based (old_ptr),
583 2 version char (4) aligned,
584 2 caller_name char (32) unaligned,
585
586 2 bound_seg_name char (32) unaligned,
587
588 2 narc fixed bin,
589 2 nupd fixed bin,
590
591 2 archive (30) aligned,
592 3 path char (168) unaligned,
593 3 real_path char (168) unaligned,
594 3 ptr pointer,
595 3 bc fixed bin (24),
596 3 uid bit (36) aligned,
597 3 dtm fixed bin (71),
598
599 2 bindfilep pointer,
600 2 bindfile_bc fixed bin (24),
601 2 bindfile_name char (32) unaligned,
602 2 bindfile_time_up fixed bin (71),
603 2 bindfile_time_mod fixed bin (71),
604 2 bindfile_idx fixed bin,
605
606 2 options aligned,
607 3 debug bit (1) unaligned, debug
608 3 list_seg bit (1) unaligned,
609 3 map_opt bit (1) unaligned,
610 3 list_opt bit (1) unaligned,
611 3 brief_opt bit (1) unaligned,
612 3 force_order_opt bit (1) unaligned,
613 3 flags_pad bit (30) unaligned,
614
615 2 nobj fixed bin,
616
617 2 v1_obj (400) aligned like v1_obj;
618
619 dcl 1 v1_obj aligned based (p),
620 2 filename char (32) unaligned,
621 2 base pointer,
622 2 bitcount fixed bin (24),
623 2 option bit (18) unaligned,
624 2 flag bit (1) unaligned,
625 2 pad bit (17) unaligned,
626
627 2 archive_idx fixed bin,
628 2 time_mod fixed bin (71),
629 2 time_up fixed bin (71);
630
631 old_ptr = inpp;
632 call get_temp_segment_ ("bind_", inpp, code);
633 if code ^= 0 then do;
634 call com_err_ (code, "bind_", "Could not get temporary segment for version 2 input structure");
635 bx_$fatal_error = 1;
636 goto return;
637 end;
638
639 inp.version = BINDER_INPUT_VERSION_2;
640 inp.caller_name = v1_inp.caller_name;
641 inp.bound_seg_name = v1_inp.bound_seg_name;
642 inp.narc = v1_inp.narc;
643 inp.nupd = v1_inp.nupd;
644 inp.ntotal = inp.narc + inp.nupd;
645 inp.nobj = v1_inp.nobj;
646
647 inp.bindfilep = v1_inp.bindfilep;
648 inp.bindfile_bc = v1_inp.bindfile_bc;
649 inp.bindfile_name = v1_inp.bindfile_name;
650 inp.bindfile_time_up = v1_inp.bindfile_time_up;
651 inp.bindfile_time_mod = v1_inp.bindfile_time_mod;
652 inp.bindfile_idx = v1_inp.bindfile_idx;
653
654 unspec (inp.options) = unspec (v1_inp.options);
655
656 do idx = 1 to inp.ntotal;
657 inp.archive (idx) = v1_inp.archive (idx), by name;
658 inp.archive (idx).standalone_seg = "0"b;
659 end;
660
661 do idx = 1 to inp.nobj;
662 inp.obj (idx) = v1_inp.v1_obj (idx), by name;
663 inp.obj (idx).new_order = 0;
664 inp.obj (idx).to_be_ignored,
665 inp.obj (idx).objectname_stmt = "0"b;
666 end;
667
668 return;
669
670 end CONVERT_I_TO_II;
671
672
673 %page; %include bindext;
674 %page; %include comptbl;
675 %page; %include bndtbl;
676 %page; %include linkdcl;
677 %page; %include binder_input;
678 %page; %include terminate_file;
679
680 end bind_;