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 db_print: proc (arg_iocb_ptr, arg_output_switch, data_ptr, mode, rel_offset, arg_no_prt, sntp, data_type, data_size);
 12 
 13 /* Modified 10/76 by S. Barr to add COBOL data types and to use data_size with octal format */
 14 /* Modified 1/77 by S. Barr to add number to print to "l" mode */
 15 /* Modified 771116 by PG to add el & fl output modes */
 16 
 17 /* parameters */
 18 
 19 dcl  arg_iocb_ptr ptr;                                      /* arg_iocb pointer for iox_ ioa_ calls */
 20 dcl  arg_output_switch char (32);                           /* for print_text_ (to be removed eventually) */
 21 dcl  data_type fixed bin;
 22 dcl  data_size fixed bin;
 23 dcl  data_ptr ptr,
 24      mode char (*) aligned,
 25     (rel_offset, arg_no_prt) fixed bin;
 26 
 27 /* entries */
 28 
 29 dcl
 30      print_text_ ext entry (ptr, fixed bin, char (*) aligned),
 31      db_get_sym ext entry (ptr),
 32      get_wdir_ ext entry returns (char (168) aligned),
 33      ioa_$ioa_switch entry options (variable),
 34      ioa_$ioa_switch_nnl entry options (variable),
 35      ioa_$rsnnl entry options (variable),
 36      db_line_no ext entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin);
 37 dcl  comp_8_to_ascii_ entry (bit (*), char (*));
 38 dcl  gr_print_ entry (char (*));
 39 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 40 dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
 41 dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
 42 dcl  stu_$get_line entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin);
 43 dcl  com_err_ entry options (variable);
 44 dcl  condition_ entry (char (*), entry);
 45 dcl  reversion_ entry (char (*));
 46 
 47 /* automatic & based */
 48 
 49 dcl  string char (64),
 50      num fixed bin,
 51      iocb_ptr ptr,
 52      output_switch char (32) aligned;                       /* output_switch: default is user_output */
 53 
 54 dcl
 55      i9 fixed bin (9),
 56     (no_prt, j, k, first, line_no, no, okp) fixed bin,
 57      code fixed bin (35),
 58      i fixed bin;
 59 
 60 
 61 dcl  line_offset fixed bin;                                 /* char. position of source line */
 62 dcl  line_length fixed bin;                                 /* length of source line */
 63 dcl  file fixed bin;                                        /* file containing source line */
 64 
 65 dcl  smap_ptr ptr;
 66 dcl  packed_ptr ptr unal based (pp);
 67 dcl  packed_bit_offset bit (6) based (pp);
 68 
 69 dcl  hp ptr;
 70 dcl  pp ptr,
 71      based_ptr ptr based;
 72 
 73 dcl
 74      bits bit (arg_no_prt) based (pp),
 75      cbit_offset char (8) aligned,
 76      str char (no_prt) based (pp);
 77 
 78 dcl 1 copy_its aligned like its ;
 79 
 80 
 81 dcl  format char (20) var aligned init ("^6o ^6o ^v(^");
 82 dcl  per_line fixed bin init (4);                           /* no. of items per line */
 83 dcl  octal bit (1) init ("0"b);                             /* 1 = octal print out */
 84 dcl  packed_decimal bit (1) init ("0"b);                    /* 1 = packed_decimal format */
 85 dcl  float bit (1) init ("0"b);                             /* 1 = float binary data */
 86 dcl (offset, loc) fixed bin;
 87 dcl 1 ff aligned based (pp),
 88     2 (w0, w1, w2, w3, w4) fixed bin (35);
 89 dcl  print_err bit (1) init ("1"b);                         /* 1 = print error message */
 90 
 91 /* builtins */
 92 
 93 declare (addr, addrel, baseno, binary, divide, fixed, max, min, null, ptr, rel, substr, mod, unspec, hbound) builtin;
 94 
 95 /* external static */
 96 
 97 dcl  iox_$user_output ptr ext;
 98 
 99 /* internal static */
100 
101 dcl  bit_loc (8) int static options (constant) init (0, 5, 9, 14, 18, 23, 27, 32);
102 dcl  last_source char (32) static init (" ");               /* last source used for printing */
103 dcl  MODES (21) char (6) static init ("a", "b", "p", "P", "i", "I", "l", "s", "o", "h", "d", "f", "e", "g",
104      "x", "comp-6", "comp-7", "comp-8", "comp-5", "fl", "el");
105 
106 /* include files */
107 
108 %include component_info;
109 %include db_snt;
110 %include its;
111 %include std_symbol_header;
112 %include source_map;
113 ^L
114 /* program */
115 
116           if arg_iocb_ptr = null then do;
117                iocb_ptr = iox_$user_output;
118                output_switch = "user_output";
119           end;
120           else do;
121                output_switch = arg_output_switch;
122                iocb_ptr = arg_iocb_ptr;
123           end;
124 
125           no_prt = max (1, arg_no_prt);                     /* get number of units to print */
126           pp = data_ptr;                                    /* get pointer to first word to be printed */
127           offset = rel_offset;                              /* get offset within stack or linkage */
128           loc = fixed (rel (pp), 17);
129 
130           call condition_ ("out_of_bounds", oob_handler);
131 
132           do j = 1 to hbound (MODES, 1) while (mode ^= MODES (j));
133           end;
134           if j > hbound (MODES, 1) then do;
135                call ioa_$ioa_switch (iocb_ptr, "^NUndefined output mode ""^a""^O", mode);
136                return;
137           end;
138 
139           goto label (j);
140 
141 /* a, x   character string */
142 label (1):
143 label (15):
144 
145           call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o """, loc, offset);
146 
147           if arg_no_prt > 0 then do;
148                call iox_$put_chars (iocb_ptr, pp, arg_no_prt, code);
149                if code ^= 0 then call com_err_ (code, "debug");
150           end;
151           call ioa_$ioa_switch (iocb_ptr, """");
152           return;
153 
154 /*  b     bit string */
155 label (2):
156           call ioa_$ioa_switch (iocb_ptr, "^6o ^6o ""^b""b", loc, offset, bits);
157           return;
158 
159 /* p, P   pointer */
160 label (3):
161 label (4):
162 
163           if data_size = 36 then no = 1;
164           else no = 2;
165 
166           do j = 1 to no_prt;
167 
168                if no = 2 then do;
169                     if pp -> its.its_mod ^= "100011"b | pp -> its.mod
170                     then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^w ^w", loc, offset, w0, w1);
171                     else do;
172                          i9 = fixed (pp -> its.bit_offset, 9); /* get bit offset of pointer */
173                          if i9 ^= 0 then call ioa_$rsnnl ("(^d)", cbit_offset, okp, i9); /* convert it to character */
174                          else cbit_offset = "";
175                          call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^o|^o^a", loc, offset, fixed (baseno (pp -> based_ptr), 18), fixed (rel (pp -> based_ptr), 18), cbit_offset);
176                     end;
177                end;
178 
179                else do;
180                     if binary (packed_bit_offset) > 35
181                     then call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^w", loc, offset, pp -> w0);
182                     else call ioa_$ioa_switch (iocb_ptr, "^6o ^6o  ^p", loc, offset, packed_ptr);
183                end;
184 
185                pp = addrel (pp, no);
186                loc = loc + no;
187                offset = offset + no;
188           end;
189           return;
190 
191 /*  i, I  instruction */
192 label (5):
193 label (6):
194           if sntp = null then okp = 0;                      /* ol_dump calls without snt table */
195           else okp = 1;                                     /* Try to get line numbers */
196           j = 0;
197 
198           do while (j < no_prt);
199 
200                if okp = 1 then do;                          /* try to get source line */
201 
202                     call db_line_no (sntp, loc, first, no, line_no);
203                     if first < 0 then do;                   /* can't find source line no. */
204                          okp = 0;
205                          no = no_prt - j;
206                     end;
207                     else do;
208                          call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no);
209                          no = no - loc + first;             /* In case loc is in middle of line */
210                     end;
211                end;
212                else no = no_prt;
213 
214                no = min (no, no_prt - j);
215                call print_text_ (pp, no, output_switch);
216                loc = loc + no;
217                pp = addrel (pp, no);
218                j = j + no;
219           end;
220           return;
221 
222 /*  l     instructions for a given line */
223 label (7):
224           do j = 1 to no_prt;
225                call db_line_no (sntp, loc, first, no, line_no);
226                if first < 0 then goto ERROR_NO_LINE;
227                call ioa_$ioa_switch (iocb_ptr, "LINE NUMBER ^d", line_no);
228                call print_text_ (ptr (pp, first), no, output_switch);
229                loc = loc + no;
230           end;
231 
232           return;
233 
234 /*  s     source line */
235 label (8):
236           call print_source;
237           return;
238 
239 /*  o, h  octal */
240 label (9):
241 label (10):
242           octal = "1"b;
243           format = format || ".3b ^)";
244           if mode = "o" then per_line = 8;
245           call print_data;
246           return;
247 
248 /*  d, comp-6, comp-7         decimal */
249 label (11):
250 label (16):
251 label (17):
252           format = format || "13d^)";
253           call print_data;
254           return;
255 
256 /*  f     float binary */
257 label (12):
258           float = "1"b;
259           format = format || "8.4f^)";
260           call print_data;
261           return;
262 
263 /*  e */
264 label (13):
265           float = "1"b;
266           format = format || "8e^)";
267           call print_data;
268           return;
269 
270 /*  fl    float-long */
271 
272 label (20):
273           float = "1"b;
274           format = format || "19.6f^)";
275           call print_data;
276           return;
277 
278 /*  el    exponential-long */
279 
280 label (21):
281           float = "1"b;
282           format = format || "19e ^)";
283           call print_data;
284           return;
285 
286 /*  g     graphic */
287 label (14):
288           call gr_print_ (str);
289           return;
290 
291 /*  comp-5,  comp-8 COBOL */
292 label (18):
293 label (19):
294           packed_decimal = "1"b;
295           call print_data;
296           return;
297 
298 out:                                                        /* for the out_of_bounds_handler */
299           return;
300 ERROR_NO_LINE: call ioa_$ioa_switch (iocb_ptr, "Cannot get line.");
301           return;
302 
303 /* ^L */
304 /*  print_data prints "per_line" data items on one line.  It matches the data type with
305    the format to prevent ioa_ from doing a data conversion before printing.
306    The next line is checked with the current line.  If it is the same, then "=====" will be
307    printed on the line instead.  This symbol will be printed only once for a series of repeated lines.
308 */
309 
310 print_data: proc;
311 
312 dcl  same bit (1) init ("0"b);                              /* ON if current output line is a repeat */
313 dcl  print_equal bit (1);                                   /* ON if should print ===== */
314 dcl  d_size fixed bin;
315 dcl  fl (4) float bin (63);
316 dcl  fx (4) fixed bin (71);
317 dcl  b bit (256);                                           /* copy of number to print in octal */
318 dcl  d fixed bin;                                           /* number of octal digits to print */
319 dcl  num_digits fixed bin;                                  /* Number of digits for paced decimal comp-8 */
320 dcl  check_ptr bit (1) aligned;                             /* ON, for comp-8 with odd number of digits */
321 dcl  add_bit bit (1) aligned;                               /* ON, if must add bit to data ptr */
322 dcl  next_p ptr;                                            /* points to next item to print */
323 
324 dcl  fxb (8) fixed bin (35) based (pp);
325 dcl  bits (16) bit (d_size) based (pp);
326 dcl  based_comp bit (data_size+1) unal based (next_p);
327 
328 dcl  data_line bit (data_line_len*2) unal based (pp);       /* line data_line_lenust printed + next line */
329 dcl  data_line_len fixed bin;                               /* number of bits in one line */
330 
331                d_size = data_size;
332                if d_size = 0 then d_size = 36;              /* no size given for temporaries (%) */
333                if d_size >72 & ^packed_decimal then d_size = 36;
334                data_line_len = d_size * per_line;
335 
336 /* COBOL - Packed decimal data with an odd number of digits as an alternating data size.  (ie. 7 digits = 32 bits, 31...)
337    db_print is given the smaller of these 2 sizes.  The pointer is digit aligned the first time.  Later a bit
338    is added every other time to correct the pointer.
339 */
340                check_ptr = "0"b;
341                if packed_decimal then do;
342                     num_digits = divide (d_size *2+1, 9, 17, 0);
343                     check_ptr = (mod (num_digits, 2) ^= 0);
344                     unspec (copy_its) = unspec (pp);
345                     num = fixed (copy_its.bit_offset, 6);
346                     do i = 1 to 8 while (num > bit_loc (i));
347                     end;
348 
349 /* If the pointer is not aligned on a digit boundary, then the pointer will be rounded up to the next boundary. */
350                     if num ^= bit_loc (i) then do;
351                          i = min (i, 8);
352                          copy_its.bit_offset = substr (unspec (bit_loc (i)), 31, 6);
353                          unspec (pp) = unspec (copy_its);
354                     end;
355                     add_bit = "1"b;
356 
357 /* If there are an odd number of digits in a packed decimal number and we have the smaller of the two numbers
358    then must add 2 bits for a line of 4 numbers. (i.e. 4*31+2 for 32, 31, 32, 31) */
359                     if check_ptr then data_line_len = data_line_len +2;
360                end;
361                k = loc - offset;
362 
363                do while (no_prt > 0);
364                     per_line = min (no_prt, per_line);
365                     if same then if print_equal then do;
366                               call ioa_$ioa_switch (iocb_ptr, "======"); /* skip line */
367                               print_equal = "0"b;
368                          end;
369                          else;
370 
371                     else do;
372 
373                          if octal then do;
374                               if d_size = 36
375                               then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, bits);
376 
377 /* Numbers to be printed in octal are copied into b so that they can be right justified.  Procedure ioa_ left justifies.  */
378                               else do;
379                                    call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset);
380                                    do j = 1 to per_line;
381                                         b = "0"b;
382                                         d = divide (d_size+2, 3, 17, 0);
383                                         substr (b, d*3-d_size+1, d_size) = bits (j);
384                                         call ioa_$ioa_switch_nnl (iocb_ptr, " ^v.3b", d, b);
385                                    end;
386                                    call ioa_$ioa_switch (iocb_ptr, "");
387                               end;
388                          end;
389 
390                          else if float then do;
391                               do j = 1 to per_line;
392                                    fl (j) = 0;
393                                    unspec (fl (j)) = unspec (bits (j));
394                               end;
395                               call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fl);
396                          end;
397 
398 /* COBOL data type */
399                          else if packed_decimal then do;
400                               call ioa_$ioa_switch_nnl (iocb_ptr, "^6o ^6o ", loc, offset, per_line);
401                               next_p = pp;
402                               do j = 1 to per_line;
403                                    call comp_8_to_ascii_ (based_comp, string);
404                                    call ioa_$ioa_switch_nnl (iocb_ptr, "  ^a", substr (string, 1, num_digits));
405 
406                                    next_p = addr (next_p -> bits (2));
407 
408 /* Add one bit to the pointer for odd digits per number. */
409                                    if check_ptr then do;
410                                         if add_bit then do;
411                                              unspec (copy_its) = unspec (next_p);
412                                              num = fixed (copy_its.bit_offset, 6)+1;
413                                              copy_its.bit_offset = substr (unspec (num), 31, 6);
414                                              unspec (next_p) = unspec (copy_its);
415                                         end;
416                                         add_bit = ^add_bit;
417                                    end;
418                               end;
419                               call ioa_$ioa_switch (iocb_ptr, ""); /* new_line */
420                          end;
421                          else do;
422 
423                               if d_size = 36 then call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fxb);
424 
425                               else do;
426                                    do j = 1 to per_line;
427                                         if substr (bits (j), 1, 1) = "1"b then fx (j) = -1;
428                                         else fx (j) = 0;
429                                         substr (unspec (fx (j)), 73-d_size, d_size) = bits (j);
430                                    end;
431                                    call ioa_$ioa_switch (iocb_ptr, format, loc, offset, per_line, fx);
432 
433                               end;
434                          end;
435                     end;
436 
437                     if ^same then print_equal = "1"b;
438 
439 /* Check for duplicate line.  Last line of comp-8 with odd number of digits will be printed. */
440 
441                     no_prt = no_prt - per_line;
442                     if no_prt > 0 then do;
443                          if no_prt >= per_line then j = data_line_len;
444                          else j = no_prt * d_size;
445                          if check_ptr & (no_prt < 4) then same = "0"b;
446                          else if substr (data_line, 1, j) = substr (data_line, data_line_len + 1, j) then same = "1"b;
447                          else same = "0"b;
448                     end;
449                     pp = addr (substr (data_line, data_line_len+1, 1));
450                     loc = fixed (rel (pp), 17);
451                     offset = loc - k;
452 
453                end;
454 
455           end print_data;
456 
457 /* ^L */
458 /*  This procedure prints one or more lines of source code beginning with the line associated with the object code
459    pointed to by data_ptr.  For an unbound segment, the directory in which
460    the object segment was compiled is searched for the source segment.  If the source segment is not found there,
461    the working directory is searched.  For bound segments only the working directory is searched for the source
462    segment.
463 */
464 print_source: proc;
465 
466 dcl  source_based char (2) based (source_ptr);
467 dcl  source_dir char (168);
468 dcl  source_ent char (32);
469 dcl  source_len fixed bin;
470 dcl  source_name char (source_len) based (source_name_ptr);
471 dcl  source_name_ptr ptr;
472 dcl  source_ptr ptr;                                        /* pointer to source segment */
473 
474                if sntp -> snt.symflag then call db_get_sym (sntp);
475 
476                if snt.std then do;                          /* standard header, use source map */
477                     hp = snt.headp;
478                     call stu_$get_line (hp, loc, no_prt, line_no, line_offset, line_length, file);
479 
480                     if line_no = -1 | line_length = 0 then go to ERROR_NO_LINE;
481                     file = file + 1;                        /* because of dimensioning in include file */
482 
483                     if hp -> std_symbol_header.source_map = (18)"0"b then go to ERROR_NO_LINE;
484                     smap_ptr = addrel (hp, hp -> std_symbol_header.source_map);
485                     source_name_ptr = addrel (hp, smap_ptr -> source_map.map (file).pathname.offset);
486                     source_len = fixed (smap_ptr -> source_map.map (file).pathname.size, 18);
487 
488 /* got source name, separate it out for initiate */
489 
490                     call expand_pathname_ (source_name, source_dir, source_ent, code);
491 
492                     call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code);
493 
494 /* If there is no pointer to the source segment, look in the working directory.  */
495 
496                     if source_ptr = null () then do;
497 
498                          if source_ent = last_source then print_err = "0"b;
499                          if print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source.  ^a>^a", source_dir,
500                               source_ent);
501 
502                          source_dir = get_wdir_ ();
503                          call hcs_$initiate (source_dir, source_ent, "", 0, 1, source_ptr, code);
504 
505                          if source_ptr = null () then do;
506                               if ^print_err then call ioa_$ioa_switch (iocb_ptr, "Cannot initiate source.  ^a>^a",
507                                    source_dir, source_ent);
508                               return;
509                          end;
510                          if print_err then call ioa_$ioa_switch (iocb_ptr, "Using source  ^a>^a", source_dir, source_ent);
511 
512                     end;
513                     last_source = source_ent;
514 
515 /* Now just write out the requisite stuff */
516 
517                     call iox_$put_chars (iocb_ptr, addr (substr (source_based, line_offset+1, 1)), line_length, code);
518                     call ioa_$ioa_switch (iocb_ptr, "");    /* add new-line */
519                     return;
520                end;
521 
522                else call ioa_$ioa_switch (iocb_ptr, "Version 1 object segments are not supported by debug.");
523 
524                return;
525 
526           end print_source;
527 
528 /* ^L */
529 oob_handler: proc (mcp, name, x_p, y_p, cont_sw);
530 
531 /*        Procedure to handle out_of_bounds. If it occurred in the data segment,
532    *      the user specified to high an address or too much data. Else it's a real
533    *      program error and we want to hear about it.
534    */
535 
536 dcl  name char (*);
537 dcl (x_p, y_p) ptr;
538 dcl  cont_sw bit (1) aligned;
539 
540 %include mc;
541 
542 
543                scup = addr (mcp -> mc.scu);
544                if scu.tpr.tsr = substr (baseno (pp), 4) then do; /* oob in data seg. */
545                     call reversion_ ("out_of_bounds");
546                     call ioa_$ioa_switch (iocb_ptr, "Request goes beyond end of segment.");
547                     go to out;
548                end;
549 
550 /* Elsewhere, use previous handler */
551 
552                cont_sw = "1"b;
553                return;
554 
555           end oob_handler;
556      end db_print;