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 print_relocation_info: procedure;
 12 pri: entry;
 13 
 14 /* originally coded before 1971 */
 15 /* modified 1972 by M. Weaver for standard object segments */
 16 /* last modified 10/75 by M. Weaver general cleaning up */
 17 
 18 
 19           dcl (i, last_word, half, bits_behind_runner, code(2), section, section_lng,
 20                     abs_block_to_go, cacnt, format,
 21                     comp_length, comp_bits, code_printed(2),
 22                     length_path, length_arg) fixed bin;
 23           dcl error_code fixed bin(35);
 24           dcl (relbitcnt based, total_bits) fixed bin(24) aligned;
 25           dcl (first_word, nwords) fixed bin(18);
 26 
 27           dcl (section_ptr, seg_ptr, pathname_ptr, arg_ptr, oip) ptr;
 28 
 29           dcl code_name(0:17) int static aligned char(16) initial("text", "neg text", "link ptr 18",
 30                               "neg link ptr 18", "link ptr 15", "def ptr", "symbol",
 31                               "neg symbol", "int static 18", "int static 15", "self relative",
 32                               "(11011)", "(11100)", "(11101)", "expanded abs", "escape",
 33                               "absolute", "off the end");
 34 
 35           dcl section_name(4) char(10) char(10) aligned init("text", "definition", "linkage", "symbol");
 36 
 37 %include relocation_header;
 38 
 39           dcl 1 old_relinfo aligned based,                  /* header for old format object segs */
 40                     2 n_bits fixed bin,
 41                     2 relbits bit (0 refer(old_relinfo.n_bits)) aligned;
 42 
 43           dcl 1 rel_section aligned based(section_ptr),
 44                     2 (bits_behind bit(bits_behind_runner),
 45                        lead bit(1),
 46                        four_bits bit(4),
 47                        abs_block bit(10)) unaligned;
 48 
 49           dcl (error_table_$badopt, error_table_$noarg, error_table_$wrong_no_of_args,
 50                     error_table_$segknown) external fixed bin(35);
 51 
 52 
 53           dcl null builtin;
 54 
 55           dcl dir_name char(168);
 56 
 57           dcl ent_name char(32);
 58 
 59           dcl me char(21) aligned int static init("print_relocation_info");
 60 
 61           dcl bit_count fixed bin(24);
 62 
 63           dcl no_copy int static fixed bin(2) initial(1);
 64 
 65           dcl arg_xx aligned char(2);
 66 
 67           dcl pathname char(length_path) based(pathname_ptr);
 68 
 69           dcl arg char(length_arg) based(arg_ptr);
 70 
 71           dcl (need_path, need_first_word, first_repeat, fatal_error, endsw) aligned bit(1);
 72 
 73           dcl (com_err_, ioa_) ext entry options(variable);
 74 
 75           dcl cu_$arg_ptr ext entry(fixed bin, ptr, fixed bin, fixed bin(35));
 76 
 77           dcl cu_$arg_count ext entry() returns(fixed bin);
 78 
 79           dcl cv_oct_check_ ext entry(char(*), fixed bin(35)) returns(fixed bin(18));
 80 
 81           dcl object_info_$long ext entry(ptr, fixed bin(24), ptr, fixed bin(35));
 82 
 83           dcl expand_path_ ext entry(ptr, fixed bin, ptr, ptr, fixed bin(35));
 84 
 85           dcl hcs_$initiate_count ext entry(char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35));
 86 
 87 
 88 
 89 /*^L*/
 90 dcl 1  oi aligned like object_info;
 91 
 92 %include object_info;
 93 
 94 /*^L*/
 95 
 96           need_path, need_first_word = "1"b /* Neither of these seen yet */;
 97           first_repeat, fatal_error = "0"b;                 /* Niether of these seen yet */
 98 
 99           section = 1;                            /* default = text */
100           nwords = 260000    /* Default */;
101           first_word = 0 /* Default */;
102           cacnt = 0;
103 
104           i = cu_$arg_count();
105           if (i > 4) | (i = 0) then do;
106                     call com_err_(error_table_$wrong_no_of_args, me, "need: path -section- -offset- -length-");
107                     return;
108           end;
109 
110           do i = 1 to 4 /* collect arguments */;
111                     call cu_$arg_ptr(i, arg_ptr, length_arg, error_code);
112                     if error_code ^= 0 then   /* Assume args exhausted.  maybe OK */
113                               go to no_more_args;
114 
115                     if substr(arg, 1, 1) = "-" then /* option */
116                               if arg = "-text" then do;
117                                         section = 1;
118                                         cacnt = cacnt + 1;
119                               end;
120 
121                               else if (arg = "-definition" | arg = "-def") then do;
122                                         section = 2;
123                                         cacnt = cacnt + 1;
124                               end;
125 
126                               else if (arg = "-link" | arg = "-lk") then do;
127                                         section = 3;
128                                         cacnt = cacnt + 1;
129                               end;
130 
131                               else if (arg = "-symbol" | arg = "-sb") then do;
132                                         section = 4;
133                                         cacnt = cacnt + 1;
134                               end;
135 
136                               else do;
137                                         call com_err_(error_table_$badopt, me, arg);
138                                         fatal_error = "1"b;
139                               end;
140 
141                     else if need_path then do;
142                               need_path = "0"b;
143                               length_path = length_arg;
144                               pathname_ptr = arg_ptr;
145                     end;
146 
147                     else if need_first_word then do;
148                               need_first_word = "0"b;
149                               first_word = cv_oct_check_(arg, error_code);
150                               if error_code ^= 0 then do;
151                                    call com_err_(0, me, "offset ^a is not an octal number", arg);
152                                    fatal_error = "1"b;
153                               end;
154                     end;
155 
156                     else do;
157                               nwords = cv_oct_check_(arg, error_code);
158                               if error_code ^= 0 then do;
159                                         call com_err_(0, me, "length ^a is not an octal number",arg);
160                                         fatal_error = "1"b;
161                               end;
162                     end;
163 
164           end /* Fall through after 4 args or after attempt to read arg after the last one given */;
165 
166 no_more_args:
167           if need_path then do;
168                     call com_err_(error_table_$wrong_no_of_args, me, "pathname missing");
169                     return;
170           end;
171 
172           if fatal_error then return;                       /* message already printed */
173 
174           if cacnt > 1 then
175                     call ioa_("^a: More than one section was specified; only last one will be used.", me);
176 
177           call expand_path_(pathname_ptr, length_path, addr(dir_name), addr(ent_name), error_code);
178           if error_code ^= 0 then do;
179                     call com_err_(error_code, me, pathname);
180                     return;
181           end;
182 
183           call hcs_$initiate_count(dir_name, ent_name, "", bit_count, no_copy, seg_ptr, error_code);
184           if seg_ptr = null then do;
185                     call com_err_(error_code, me, pathname);
186                     return;
187           end;
188 
189           oip = addr(oi);
190           oi.version_number  = object_info_version_2;
191           call object_info_$long(seg_ptr, bit_count, oip, error_code);
192           if error_code ^= 0 then do;
193                     call com_err_(error_code, me, "^a>^a", dir_name, ent_name);
194                     return;
195           end;
196 
197           if section = 1 then do;
198                     section_ptr = oi.rel_text;
199                     section_lng = oi.tlng - 1;
200           end;
201           else if section = 2 then do;
202                     section_ptr = oi.rel_def;
203                     section_lng = oi.dlng - 1;
204           end;
205           else if section = 3 then do;
206                     section_ptr = oi.rel_link;
207                     section_lng = oi.llng - 1;
208           end;
209           else if section = 4 then do;
210                     section_ptr = oi.rel_symbol;
211                     section_lng = oi.slng - 1;
212           end;
213 
214           if section_ptr = null then do;                    /* no point in going on */
215                     call com_err_(0, me, "Specified section has no relocation bits.");
216                     return;
217           end;
218 
219 
220           /* be sure specified range is within section */
221 
222           if first_word > section_lng then do;
223                     call ioa_("^a section is only ^o(8) words long", section_name(section), section_lng);
224                     return;
225           end;
226           last_word = first_word + nwords - 1;              /* this is what was asked for */
227           if last_word > section_lng then do;               /* set up to print more meaningful message */
228                     last_word = section_lng;                /* last word we're interested in */
229                     endsw = "1"b;                           /* so won't imply that section is longer */
230           end;
231           else endsw = "0"b;
232 
233           if oi.format.standard then do;
234                     total_bits = section_ptr -> relinfo.n_bits;
235                     section_ptr = addr(section_ptr -> relinfo.relbits);
236           end;
237           else do;
238                     total_bits = section_ptr -> old_relinfo.n_bits;
239                     section_ptr = addr(section_ptr -> old_relinfo.relbits);
240           end;
241           abs_block_to_go, bits_behind_runner = 0;
242           code_printed(1), code_printed(2) = 999 /* That is, the first line is NOT like the imaginary pre-first one */;
243 
244           do i = 0 to last_word;
245                     do half = 1 to 2;
246 GET_BITS:                     if abs_block_to_go > 0 then do;
247                                         code(half) = 16 /* absolute */;
248                                         abs_block_to_go = abs_block_to_go-1;
249                               end;
250 
251                               else if bits_behind_runner >= total_bits then
252                                         code(half) = 17 /* off the end */;
253 
254                               else if lead = "0"b then do;
255                                         code(half) = 16 /* absolute */;
256                                         bits_behind_runner = bits_behind_runner+1;
257                               end;
258 
259                               else if four_bits = "1110"b then do; /* expanded absolute */
260                                         abs_block_to_go = bin(abs_block,10);
261                                         bits_behind_runner = bits_behind_runner+15;
262                                         go to GET_BITS;
263                               end;
264 
265                               else do;
266                                         code(half) = bin(four_bits, 4);
267                                         bits_behind_runner = bits_behind_runner+5;
268                               end;
269                     end;
270 
271                     if i >= first_word then /* user is interested in this word */
272                               if code(1) ^= code_printed(1) | code(2) ^= code_printed(2) /* but only if ^= prev word */
273                               then do;
274                                         call ioa_("^6o   ^16a  ^16a", i, code_name(code(1)),
275                                                   code_name(code(2)));
276                                         code_printed(1) = code(1);
277                                         code_printed(2) = code(2);
278                                         first_repeat = "1"b;
279                               end;
280 
281                               else if first_repeat /* If not first repeat, nothing gets printed at all */
282                               then do;
283                                         first_repeat = "0"b;
284                                         call ioa_("(repeats)");
285                               end;
286 
287                     if code(1) = 17 then do; /* no sense continuing */
288                               call ioa_("Relocation bits are not provided for words after ^o", i-1);
289                               return;
290                     end;
291           end;
292 
293           if endsw then call ioa_("end of ^a section", section_name(section));
294 
295           return;
296 
297 end print_relocation_info;