1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4         *                                                         *
  5         * Copyright (c) 1972 by Massachusetts Institute of        *
  6         * Technology and Honeywell Information Systems, Inc.      *
  7         *                                                         *
  8         *********************************************************** */
  9 
 10 
 11 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
 15      audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
 16      Modified cleanup handler to work with new bound object being created in a
 17      temp segment and then copied into the working dir.
 18   2) change(86-09-05,JMAthane), approve(86-09-05,MCR7525),
 19      audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212):
 20      Generate first_ref_traps must be called after make_defs because make_defs
 21      my generate links when binding PASCAL objects. First ref traps must be
 22      generated after links.
 23                                                    END HISTORY COMMENTS */
 24 
 25 
 26 /* This is the main program of the binder.
 27 
 28    Designed and initially coded by Michael J. Spier, August 19, 1970,
 29    Completely revised by Michael J. Spier, December 23, 1971  */
 30 /* modified 75.06.20 by M. Weaver for separate static */
 31 /* modified 5/76 by M. Weaver  for -brief option */
 32 /* modified 1/77 by Melanie Weaver to call ext_link_$finish */
 33 /* modified 8/77 by Melanie Weaver to check for perprocess static in non-standard  */
 34 /* modified 9/78 by David Spector to release temp segments on cleanup */
 35 /* modified Dec 78 by David Spector to make repatch table automatically extensible */
 36 /* Modified 01/14/81 W. Olin Sibert for new format of input structure, and -force_order */
 37 /* Modified 01/21/81, WOS, to rename to bind_ so binder_ could remain "compatible" */
 38 /* Modified 05/3/83 by Melanie Weaver to add handler for fatal_binder_error condition */
 39 /* Modified  10/20/84 by M. Sharpe to use new binder_input_.incl.pl1; to check for bindfile
 40    errors before wiping out the old bound segment */
 41 
 42 /* Warning: several places in the binder a fixed bin variable is referenced as
 43    based bit or based char; currently, referencing them via addr(variable)
 44    will make the pl1 compiler realize what is really being changed. */
 45 
 46 /* format: style4,^indattr,^indcomtxt */
 47 
 48 bind_: procedure (argp);
 49 
 50 declare  argp pointer;
 51 
 52 
 53 /* DECLARATION OF EXTERNAL ENTRIES */
 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 /* DECLARATION OF AUTOMATIC STORAGE VARIABLES */
 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 /* DECLARATION OF BUILTIN FUNCTIONS */
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 /* DECLARATION OF EXTERNAL STATIC */
123 
124 declare  (error_table_$pathlong, error_table_$segnamedup) ext fixed bin (35);
125 
126 /* DECLARATION OF INTERNAL STATIC */
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 /* DECLARATION OF BASED STRUCTURES */
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,                          /* Format of temp segments */
151            2 next_temp_ptr ptr,                             /* ptr to next temp seg in chain */
152            2 storage bit (0);                               /* Start of temp_mgr_ storage */
153 
154 %page;
155 
156 /* PROLOGUE - Initialize binder's temporaries, and validate format of
157    bindfile before starting actual binding.                           */
158 
159 
160           inpp = argp;                                      /* copy pointer to input structure */
161 
162           reset_bx (*) = 0;                                 /* reset main data base to zeros */
163 
164           bx_$inpp = inpp;                                  /* record address of input structure */
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;                                 /* delete the temp copy of the bound seg on a fault */
176                if bx_$temp_bsegp ^= null then call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, 0);
177                                                             /* clean up temp for new bound object */
178                if list_acinfop ^= null then call tssi_$clean_up_segment (list_acinfop);
179                                                             /* clean up temp for list segment */
180 
181 /* Return all temp segments to free pool. */
182 
183                if old_ptr ^= null then do;                  /* release the temp seg we got for version 2 input */
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); /* Follow chain of temp segments */
189                     sp = p -> temp_seg.next_temp_ptr;       /* Get ptr to next temp segment */
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 (); /* convert to new version */
201           else if inp.version ^= BINDER_INPUT_VERSION_2 then do; /* Complain and give up */
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);                 /* copy debug flag */
208           bx_$brief = bin (inp.brief_opt, 1);               /* copy brief flag */
209           bx_$force_order = bin (inp.force_order_opt, 1);   /* Copy command-line Force_order option */
210                                                             /* (this may also get set in parse_bindfile)_ */
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                                                             /* create temp segment, return pointer to main database */
220           if bx_$fatal_error = 1 then goto return;
221 
222           bx_$v_lng = rank (substr (bx_$vers_name, 1, 1));  /* get length of version name */
223 
224           sntp,
225                bx_$sntp = bx_$freep;                        /* allocate segname table */
226           snt.max_size = bx_$snt_limit;
227           call temp_mgr_$reserve (addr (snt.entry (snt.max_size + 1))); /* determine end of table */
228                                                             /* reserve the area allocated to main table */
229           if bx_$fatal_error ^= 0 then goto return;
230 
231           odnp,
232                bx_$odnp = bx_$freep;                        /* oddname table  */
233           od.max_size = bx_$oddname_limit;
234           call temp_mgr_$reserve (addr (od.entry (od.max_size + 1)));
235 
236           rptp = bx_$freep;                                 /* Reserve first chunk of repatch table */
237           bx_$first_rptp,
238                bx_$last_rptp = rptp;
239           call temp_mgr_$reserve (addrel (addr (rpt), size (rpt)));
240           rpt.thread = null;                                /* No more chunks */
241           rpt.npt = 0;                                      /* No entries in chunk */
242 
243           bx_$ncomp = inp.nobj;
244           bx_$adnp = null;
245 
246           call parse_bindfile_;                             /* parse the bindfile, if there is one */
247           if bx_$fatal_error = 1 then goto return;
248 
249           inpp = bx_$inpp;                                  /* refresh, in case it was modified by parse_bindfile_ */
250 
251           if list_seg then do;                              /* be sure segname || ".list" is <= 32 chars */
252                i = index (bx_$bound_segname, " ");          /* get length of name */
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;                           /* don't make user have to delete empty seg */
257                end;
258           end;
259 
260           ctp,
261                bx_$ctp = bx_$freep;                         /* allocate component table */
262           nobjects = bx_$ncomp;                             /* get number of component objects */
263           call temp_mgr_$reserve (addr (comp_tbl (nobjects + 1))); /* reserve area for component table */
264           if bx_$fatal_error = 1 then goto return;
265 
266 
267           call temp_mgr_$make_object;                       /* create the new bound segment */
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 /* FIRST PASS OF BINDER = obtain ITS pointers to all relevant parts (e.g., definition
276    section, relocation bits, etc.) of every object to be bound, and copy the text
277    sections into the new bound segment.                               */
278 
279 
280           call dissect_object_$init;
281 
282           do i = 1 to nobjects;                             /* start processing components */
283                ctep,
284                     comp_tbl (i) = bx_$freep;               /* allocate entry for this component */
285                call temp_mgr_$reserve (addr (comp.last_item));
286                unspec (comp) = ""b;                         /* iniitalize structure; seems to be necessary */
287                comp.cindex = i;                             /* remember entry's index in table */
288                comp.filename = inp.obj (i).filename;        /* store object's filename */
289                lng = index (comp.filename, " ");            /* compute filename's length */
290                if lng = 0 then lng = 32;
291                else lng = lng - 1;
292                comp.fn_lng = lng;                           /* remember length */
293                comp.ctxtp = inp.obj (i).base;               /* get pointer to object segment */
294                comp.cbitcount = inp.obj (i).bitcount;       /* and its bitcount */
295                call dissect_object_ (ctep);                 /* and process this object segment */
296           end;
297 
298           if bx_$tintlng >= 16384 then do;                  /* max is 16K because of 15-bit link offsets */
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);     /* enforce usable size */
305           if (bx_$has_comb_stat = 0 & bx_$has_sep_stat = 1)
306           then bx_$bound_sep_stat = 1;                      /* have at  least 1 nonzero sep stat and no comb stat */
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 /* Create hash table for segname table (snt), all of whose entries have already been stored. */
315 
316           do hash_index = 0 to hbound (snt.hash_table, 1);
317                snt.hash_table (hash_index) = null;          /* Clear hash table */
318           end;
319           do i = 1 to snt.n_names;                          /* Scan entire snt */
320 
321 /* Hash code segment name from table. */
322 
323                hash_index = 0;
324                do pos = 1 to min (snt.entry (i).lng, 24);   /* 24 times max */
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 /* Push snt entry into bucket thus found. */
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 /* SECOND PASS OF THE BINDER = allocate temporary area for construction of
338    new linkage section, relocate all text sections building up the linkage
339    section in the process, and finally construct the new definition section
340    of the new bound object segment.                                   */
341 
342           val = bx_$textlng;                                /* get length of text portion */
343           val = divide (val + 1, 2, 17, 0) * 2;             /* make it a 0 mod 2 value */
344           bx_$textlng = val;                                /* and restore to data base */
345 
346 
347           bx_$tdefp = addrel (bx_$temp_bsegp, val);
348           call temp_mgr_$allocate (bx_$maxlinklng);         /* make sure an area of sufficient size available */
349           if bx_$bound_sep_stat = 1 then do;
350                bx_$tintp = bx_$freep;                       /* static will be between defs and link */
351                val = 8;                                     /* locatiion of first link */
352                linkptr,
353                     bx_$tlinkp = addrel (bx_$tintp, bx_$tintlng); /*  ptr to temp linkage section */
354           end;
355           else do;                                          /* bound segment has static in linkage */
356                linkptr,
357                     bx_$tlinkp = bx_$freep;                 /*  linkage immediately follows defs */
358                val = bx_$tintlng + 8;
359                bx_$tintp = addrel (linkptr, 8);
360           end;
361           call temp_mgr_$reserve (addrel (bx_$freep, bx_$maxlinklng)); /* and reserve area */
362 
363           strmp,
364                bx_$strmp = bx_$freep;                       /* get pointer to generated string map */
365           strm.max_size = bx_$stringmap_limit;
366           call temp_mgr_$reserve (addr (strm.entry (strm.max_size + 2)));
367 
368 /* now fabricate a new header for this linkage section */
369 
370           linkptr -> virgin_linkage_header.link_begin = bit (bin (val, 18), 18); /* and store in header */
371           bx_$tlinklng = val;                               /* remember current length of linkage section */
372 
373 /* now compute length of first part of binder's symbol block */
374 
375           bx_$n_lng = index (bx_$bound_segname, " ") - 1;
376           if bx_$n_lng = -1 then bx_$n_lng = 32;
377 
378 /* make symbol section header length mod 8 */
379           i = divide (bx_$v_lng + 3, 4, 17, 0);             /* compute length of version name in words */
380           bx_$s_lng = divide ((27 + i), 8, 17, 0) * 8;      /* 27 for 20 + 7 */
381           call rebuild_object_$init;
382           call decode_link_$init;
383           call int_link_$init;
384           call make_defs_$open_section;                     /* must call before ext_link_$init */
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);                         /* pointer to component entry */
391                                                             /* the following must be done here because incorporate_options_ may have changed comp.clngns */
392                if clngns_overlay.odd then comp.cpads = 1;
393                comp.crels = symb_relc;
394                symb_relc = symb_relc + comp.clngns + comp.cpads;
395                                                             /* compute new relocation counter */
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);                         /* pointer to component entry */
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                                                             /* combine first ref trap arrays of each  component */
407 
408 
409           call make_defs_$close_section;                    /* close new definition section */
410 
411           call ext_link_$finish;                            /* print out multiple init messages */
412           if bx_$fatal_error = 1 then goto return;
413 
414 
415 %page;
416 
417 /* FINAL PASS OF THE BINDER = copy new linkage section into new object segment,
418    and relocate symbol sections into it                               */
419 
420           val = bx_$curdeflng;                              /* length of new definition section */
421           val = divide (val + 1, 2, 17, 0) * 2;             /* make it a 0 mod 2 value */
422           bx_$curdeflng = val;                              /* restore just in case */
423           if bx_$bound_sep_stat = 0 then do;                /*  int static is inside linkage */
424                bx_$blnkp = addrel (bx_$tdefp, val);         /* ptr to location of new  linkage sectiin */
425                val = bx_$tlinklng;                          /* includes static */
426                bx_$blnkp -> linksection = bx_$tlinkp -> linksection;
427                bx_$bstatp = addrel (bx_$blnkp, 8);
428           end;
429           else do;                                          /*  static precedes linkage */
430                bx_$bstatp = addrel (bx_$tdefp, val);
431                val = bx_$tintlng + bx_$tlinklng;            /* get length of link and static */
432                bx_$bstatp -> linksection = bx_$tintp -> linksection; /* copy linkage and static into object */
433                bx_$blnkp = addrel (bx_$bstatp, bx_$tintlng);/* get ptr to linkage in object */
434                val = bx_$tlinklng;                          /* fill in length of actual linkage */
435           end;
436           bx_$t_lng = bx_$textlng + bx_$curdeflng;          /* length of new text section */
437           val = divide (val + 1, 2, 17, 0) * 2;             /* make length of linkage section 0 mod 2 value */
438           bx_$l_lng = val;                                  /* and store in main data base */
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);        /* compute base of symbol section */
448 
449           call relocate_symbol_;                            /* relocate and assemble symbol sections */
450           if bx_$fatal_error = 1 then goto return;
451 
452 
453 /* EPILOG - make bindmap and object map, and complete addresses and values
454    which were not available at some previous point of time. Close all
455    files and terminate names.                               */
456 
457           call make_bindmap_;
458 
459 
460           do rptp = bx_$first_rptp repeat rpt.thread while (rptp ^= null);
461                                                             /* Scan repatch table */
462                do i = 1 to rpt.npt;                         /* Scan chunk of repatch table */
463                     rptep = addr (rpt.entry (i));           /* pointer to next repatch table entry */
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);   /* get pointer to instruction to patch */
468                     whalf = rpte.halfword;                  /* determine which halfword to patch */
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);     /* add expression value */
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 /* and now, at last, make an object map for the new object segment */
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; /* to get bitcount */
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                           /* produce a listing segment */
500                do;
501                dirname = get_wdir_ ();                      /* get directory name */
502                segname = bx_$bound_segname;                 /* get name of bound object segment */
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); /* create segment */
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;                          /* copy segment name */
514                substr (listname, i, 5) = ".map ";
515                call hcs_$chname_seg (list_ptr, "", listname, code);
516                if code ^= 0 then                            /* name duplication */
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;                    /* pointer to new bound object segment */
522                list_bc = 0;
523                if list_opt = "1"b then
524                     do;                                     /* copy bindfile, if any */
525                     if inp.bindfilep = null then goto output_bindmap;
526                     p = list_ptr;                           /* copy for convenience */
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); /* get character count */
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;                /* set bitcount of list segment */
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); /* go produce bindmap information */
539                if list_opt = "1"b then
540                     do;
541                     unspec (x.long) = "740000000000"b3;     /* fabricate form_link_info_ arguments */
542                     lng = divide (list_bc, 9, 17, 0);       /* get length in chars of list seg */
543                     substr (list_ptr -> based_string, lng + 1, 2) = FF || NL;
544                     list_bc = list_bc + 18;                 /* increase length by 2 chars */
545                     call form_link_info_ (addr (x), code);  /* output link info  */
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;                       /* release the temp seg we got for version 2 input */
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 /* program to convert version 1 inp to version 2 inp. */
575 
576 /*  Automatic  */
577 
578 dcl  idx fixed bin;
579 
580 /*  Based */
581 
582 dcl  1 v1_inp aligned based (old_ptr),                      /* the now-obsolete version 1 binder_input */
583        2 version char (4) aligned,
584        2 caller_name char (32) unaligned,                   /* Name of command on whose behalf binder is being invoked */
585 
586        2 bound_seg_name char (32) unaligned,                /* name of new bound segment */
587 
588        2 narc fixed bin,                                    /* number of input archive files */
589        2 nupd fixed bin,                                    /* number of update archive files */
590 
591        2 archive (30) aligned,                              /* info about input archives, for source map, etc. */
592          3 path char (168) unaligned,                       /* for identifying archive */
593          3 real_path char (168) unaligned,                  /* determined by translator_info_ */
594          3 ptr pointer,                                     /* pointer to archive */
595          3 bc fixed bin (24),                               /* and its bitcount */
596          3 uid bit (36) aligned,                            /* unique id of archive */
597          3 dtm fixed bin (71),                              /* date-time modified of archive */
598 
599        2 bindfilep pointer,                                 /* pointer to bindfile */
600        2 bindfile_bc fixed bin (24),                        /* bitcount of bindfile */
601        2 bindfile_name char (32) unaligned,                 /* name of bindfile */
602        2 bindfile_time_up fixed bin (71),                   /* date updated in archive */
603        2 bindfile_time_mod fixed bin (71),                  /* date last modified */
604        2 bindfile_idx fixed bin,                            /* index of archive bindfile was in */
605 
606        2 options aligned,
607          3 debug bit (1) unaligned,                         /* 1-> debug option ON */
608          3 list_seg bit (1) unaligned,                      /* 1 -> make list seg */
609          3 map_opt bit (1) unaligned,                       /* 1 -> map option  */
610          3 list_opt bit (1) unaligned,                      /* 1 -> list option */
611          3 brief_opt bit (1) unaligned,                     /* 1 -> brief option */
612          3 force_order_opt bit (1) unaligned,               /* 1 -> force_order option from command line */
613          3 flags_pad bit (30) unaligned,
614 
615        2 nobj fixed bin,                                    /* number of objects to be bound */
616 
617        2 v1_obj (400) aligned like v1_obj;
618 
619 dcl  1 v1_obj aligned based (p),                            /* dcl of single input entry for version 1 binder_input */
620        2 filename char (32) unaligned,
621        2 base pointer,                                      /* pointer to base of object segment */
622        2 bitcount fixed bin (24),                           /* bitcount of object segment */
623        2 option bit (18) unaligned,                         /* pointer into option structure */
624        2 flag bit (1) unaligned,                            /* This word of unaligned bits ought to be a substructure, */
625        2 pad bit (17) unaligned,                            /* but if it is, pl1 scope-of-names stupidly rejects refs */
626                                                             /* to obj.flag as "ambiguous", because of inp.obj.flag */
627        2 archive_idx fixed bin,                             /* index of archive from which this component comes */
628        2 time_mod fixed bin (71),                           /* DTCM of component (from archive) */
629        2 time_up fixed bin (71);                            /* Time updated in archive */
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_;