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 /* ONLINE-DUMP --- process dump image created by BOS */
 12 /* od_355 entry added by R. Mullen May 1973 */
 13 /* modified for multiple fnps by Robert Coren 10/08/75 */
 14 /* modified 7/25/76 by Noel I. Morris for MR4.1 */
 15 /* modified 79 Aug 14 by Art Beattie to handle longer erf numbers and identify entry called to com_err_. */
 16 /* modified 2/24/81 by J. A. Bush for larger fdump header size */
 17 
 18 online_dump: od: proc;
 19 
 20 dcl  procname char (16);                                    /* Identification for com_err_ calls */
 21 
 22 dcl  arg char (argl) based (argp),                          /* Variables used to access arguments */
 23      argp ptr,
 24      argl fixed bin;
 25 
 26 dcl (erf_no char (18) aligned,                              /* First arg aligned, ERF # */
 27      name char (32)) aligned;                               /* Returned by "get_dump_ptrs_" */
 28 
 29 dcl  error_table_$badopt fixed bin (35) external static;
 30 
 31 dcl  num fixed bin init (1);
 32 dcl  n_blocks fixed bin;
 33 dcl  n_first fixed bin;
 34 
 35 dcl (ioname init ("od_output_"),                            /* Arguments for I/O attachment */
 36      iotype init ("prtdim"),
 37      ioname2 init ("prta")) char (168) aligned int static;
 38 
 39 dcl  get_dump_ptrs_ entry (char (*) aligned, (0:31) ptr, (0:31) fixed bin, fixed bin, char (32) aligned),
 40      od_print_ entry options (variable),
 41      od_stack_ entry (ptr, fixed bin, ptr, ptr, ptr, ptr),
 42      ioa_ entry options (variable),
 43      ring0_get_$segptr_given_slt entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35), ptr, ptr),
 44      hcs_$get_max_length_seg entry (ptr, fixed bin (18), fixed bin (35)),
 45      hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)),
 46      com_err_ entry options (variable),
 47      ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned),
 48      ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
 49 
 50 dcl (od_print_$op_new_page, od_print_$op_finish) entry,     /* No args */
 51      od_print_$op_fmt_line entry (fixed bin, fixed bin, fixed bin (35)),
 52      od_print_$op_new_seg entry (fixed bin),
 53      od_print_$op_init entry (fixed bin, fixed bin (71)),
 54      online_355_dump_ entry (ptr, fixed bin),
 55      copy_dump_seg_ entry (fixed bin, fixed bin, (0:31) ptr, (0:31) fixed bin, ptr, fixed bin),
 56      print_dump_seg_name_ entry (fixed bin, fixed bin (71), ptr, ptr),
 57      print_dump_seg_name_$hard entry (fixed bin, fixed bin (71), ptr, ptr),
 58      hcs_$terminate_noname entry (ptr, fixed bin (35)),
 59      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 60 
 61 dcl (addr, addrel, baseno, bin, divide, index, mod, null, size, substr) builtin; /* PSI! */
 62 
 63 dcl (ds_seg_no int static init (0),                         /* Seg # of descriptor segs */
 64      slt_seg_no, nam_seg_no, sstnt_seg_no, pds_seg_no, prds_seg_no, /* Miscellaneous system segment #-s */
 65      sst_seg_no) fixed bin;                                 /* .. */
 66 
 67 dcl (dslen, sstntlen, sltlen, namlen, sstlen, pdslen, prdslen, stklen) fixed bin; /* Lengths of copies of segs */
 68 
 69 dcl (slt_seg init (null), nam_seg, sst_seg, sstnt_seg, ds_seg, pds_seg, /* Static pointers to created segments */
 70      prds_seg /* , tc_data_seg, lot_seg */, stk_seg, shut_seg) ptr int static;
 71 
 72 dcl ( /* sstp, sltp, */ namp, dsp, pdsp, prdsp /* , tc_datap, lotp */) ptr; /* Automatic copies */
 73 
 74 dcl (astep, ptwp) ptr,
 75      code fixed bin (35);
 76 
 77 dcl ((m1 init (-1),
 78      five init (5),
 79      four init (4),
 80      three init (3),
 81      two init (2),
 82      one init (1)) fixed bin,
 83      seg_mode fixed bin (5) init (1011b),
 84      max_fnps fixed bin init (4),
 85      fnp_size fixed bin init (16384),                       /* size of core image in 36-bit words */
 86      wps fixed bin (18)) int static;
 87 
 88 
 89 
 90 dcl  onechar char (1) aligned;
 91 dcl  twochar char (2) aligned;
 92 
 93 dcl  dsbr_stk_no fixed bin;                                 /* the first stack segno, judged by dsbr.stack */
 94 dcl  xreg (0:7) fixed bin (17) unaligned based;
 95 dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin);
 96 dcl  ioargloc fixed bin init (2);
 97 dcl  seg_no fixed bin;
 98 dcl  restartsw bit (1) init ("0"b);
 99 dcl (rt_seg_no, rt_proc_no, cur_proc_no) fixed bin;
100 dcl  fnp_index fixed bin;
101 dcl  tag char (1);
102 dcl  all_fnps bit (1);                                      /* indicator of whether dumping all fnps */
103 dcl  segselsw bit (1) init ("0"b),
104      wants_regs bit (1) init ("0"b),
105      wants_seg (0:1151) bit (1) unal,
106      ws16x72 (16) fixed bin (71) based,
107      ask_ ext entry options (variable),
108      zilch (16) fixed bin (71) init ((16) 0),
109      ask_$ask_clr ext entry options (variable),
110      argno fixed bin,
111      fnp_only bit (1),
112      seg_id char (32);
113 
114 dcl  based_ptr based ptr;
115 ^L
116 dcl (fmtdbrh char (31) init ("^-^-DBR  ADDR   BOUND U STACK^/"),
117      fmtdbr char (34) init ("^-^-  ^8.3b  ^5.3b ^1.3b ^4.3b^/^/"),
118      fmtpprh char (28) init ("^-^-PPR  PRR   PSR      IC^/"),
119      fmtppr char (35) init ("^-^-      ^1.3b   ^5.3b   ^6.3b^/^/"),
120      fmtrar char (17) init ("^-^-RAR   ^1.3b^/"),
121      fmtind char (17) init ("^-^-IND   ^6.3b^/"),
122      fmta char (14) init ("^-^-A     ^12w"),
123      fmtq char (14) init ("^-^-Q     ^12w"),
124      fmte char (15) init ("^-^-EXP   ^3.3b"),
125      fmtt char (20) init ("^-^-TIMER    ^9.3b^/"),
126      fmtbar char (14) init ("^-^-BAR   ^w^/"),
127      fmtx char (13) init ("^-^-X^o   ^7o"),
128      fmtinter char (16) init ("^/^-^-INTER ^12w"),
129      fmtmode char (22) init ("^/^-^-MODE  ^12w  ^12w"),
130      fmtflt char (14) init ("^-^-FAULT ^12w"),
131      fmtprh char (39) init ("^/^/^-^-PR    R    SEG     WORD  BITS^/"),
132      fmtpr char (39) init ("^-       ^2a (^o)   ^o   ^5o   ^6o  ^2o"),
133      fmtamsdwh char (81) init ("^/^/^-AM: SDW^/^-^-  ADDR   R1R2R3  F  BOUND  REWPUG    CL  POINTER  F/E  USAGE^/"),
134      fmtamsdw char (51) init ("^-^-^8o  ^o ^o ^o     ^5o  ^8a^5o  ^5o    ^a    ^2o"),
135      fmtamptwh char (63) init ("^/^/^-AM: PTW^/^-^- ADDR    M   POINTER    PAGE    F/E  USAGE^/"),
136      fmtamptw char (41) init ("^-^-^6o   ^2a   ^5o     ^4o     ^a    ^2o"),
137      fmtcbh char (33) init ("^/^/^-^-COREBLOCKS: FIRST   NUM^/"),
138      fmtcbno char (13) init ("^-^-^- NO MEM"),
139      fmtmcmh char (33) init ("^/^/^-^-MEMORY CONTROLLER MASKS^/"),
140      fmtmcm char (40) init ("^-  ^2o ^14w^14w^14w^14w^14w^14w^14w^14w"),
141      fmthrh char (29) init ("^/^/^-^-^-HISTORY REGISTERS^/")) aligned int static;
142 
143 dcl (fmteight char (37) init ("^-^4o^16w^14w^14w^14w^14w^14w^14w^14w"), /* For page table printing */
144      fmtdesc char (66) init ("^-^-  ADDR   R1R2R3  F  BOUND  REWPUG    CL     SEGMENT     NAME^/"),
145      fmtast char (64) init ("^/      ASTE      ^14w^14w^14w^14w^14w^14w^14w^14w^/PAGE TABLE^/"),
146      fmtlth char (14) init ("^2-LENGTH = ^o"),
147      fmteject char (2) init ("^|"),
148      fmthdr char (11) init ("^|^a ERF ^a"),
149      fmteq char (21) init ("^-^7o line^a repeated")) aligned int static;
150 
151 dcl 1 dsbr based aligned,
152    (2 add bit (24),
153     2 pad1 bit (12),
154     2 pad2 bit (1),
155     2 bound bit (14),
156     2 pad3 bit (4),
157     2 unpaged bit (1),
158     2 pad4 bit (4),
159     2 stack bit (12)) unaligned;
160 
161 dcl 1 scu based (scup) aligned,                             /* SCU data needed by online_dump */
162     2 ppr,                                                  /* proceedure pointer register */
163       3 prr bit (3) unal,                                   /* procedure ting register */
164       3 psr bit (15) unal,                                  /* procedure segment register */
165     2 pad1 bit (18) unal,                                   /*                            */
166     2 pad2 (3) bit (36) unal,                               /*                            */
167     2 ilc bit (18) unal,                                    /* instruction counter */
168     2 ir bit (18) unal,                                     /* indicator registers */
169     2 pad3 (3) bit (36) unal;                               /*                  */
170 ^L
171 dcl (ptr_array ptr,                                         /* Pointers to, lengths of component segments of image */
172      len_array fixed bin) (0:31);
173 
174 declare 1 cmp aligned,                                      /* Buffer containing contents of last printed line */
175         2 (zero, two, four, six) fixed bin (71);
176 
177 declare 1 temp aligned,                                     /* Buffer used when current 8 words straddle image segment boundary */
178         2 (zero, two, four, six) fixed bin (71);
179 
180 declare 1 dbl based aligned,                                /* Template used to access current 8 words */
181         2 (zero, two, four, six) fixed bin (71);
182 
183 declare 1 sgl based aligned,                                /* Template for printing individual words */
184         2 (zero, one, two, three, four, five, six, seven) fixed bin (35);
185 
186 dcl (cur, nxt, tmp, prt, eightp) ptr,                       /* Pointers used in dumping */
187     (ast_off, sst_abs_loc, sst_high_loc, abs_loc, jbdry, page_no) fixed bin,
188     (b72 bit (72),                                          /* I/O status */
189      bl char (l) based,                                     /* For format overlay */
190      s char (1),                                            /* for singular/plural printing */
191      c0 char (0)) aligned,                                  /* = null string */
192     (i, j, l, j1, j2, eq_print) fixed bin,                  /* Misc values */
193      bin_array (0:1023) based fixed bin (35),
194      dbl_array (0:1023) based fixed bin (71),
195      cur_orig fixed bin (35),
196     (cur_proc_index, cur_seg_no, given_length, half_gl) fixed bin,
197                                                             /* Per-segment values */
198     (nsegs, seg_index, ptr_index, wpsmsi) fixed bin (18);   /* More misc */
199 
200 declare 1 io_status based aligned,                          /* To check 72-bits from ios_ calls */
201         2 code fixed bin,                                   /* error code */
202         2 substatus bit (36);                               /* Bits */
203 
204 dcl  axbitsp ptr;
205 dcl  axstring char (8) aligned;
206 dcl  axbits (6) bit (1) unaligned based (axbitsp);
207 
208 dcl (amrp, ampp, scup) ptr;
209 ^L
210 % include assoc_mem;
211 ^L
212 % include slt;
213 ^L
214 % include sstnt;
215 ^L
216 % include ptw;
217 ^L
218 % include its;
219 ^L
220 % include sdw;
221 ^L
222 % include bos_dump;
223 ^L
224 % include sst;
225 ^L
226 /* Initialization */
227 
228           procname = "online_dump";
229           prt = addr (wants_seg (0));
230           prt -> ws16x72 = zilch;
231           fnp_only = "0"b;
232           go to get_erfno;
233 
234 online_dump_355: od_355: entry;
235           procname = "online_dump_355";
236           fnp_only = "1"b;
237           fnp_index = 1;                                    /* assume doing all starting with first */
238           tag = "a";
239           all_fnps = "1"b;
240 
241 get_erfno: call cu_$arg_ptr (1, argp, argl, code);          /* Get mandatory first arg */
242           if code ^= 0
243           then do;
244                call com_err_ (code, procname, "ERF #");
245                return;
246           end;
247 
248           if ^fnp_only then erf_no = arg;                   /* Copy arg */
249           else erf_no = arg || ".355";
250           call get_dump_ptrs_ (erf_no, ptr_array, len_array, j, name); /* Get pointers to image segments */
251           if j = 0
252           then do;
253                call com_err_ (0, procname, "no pointers returned for arg ""^a""", erf_no);
254                return;
255           end;
256 
257           ptr_array (j) = null;                             /* For terminate loop */
258           dumpptr = ptr_array (0);                          /* Copy pointer for header access */
259           call hcs_$get_max_length_seg (dumpptr, wps, code);
260           if code ^= 0 then do;
261                call com_err_ (code, procname, "unable to get max length of ^a", name);
262                return;
263           end;
264                                                             /* NEW STUFF */
265 
266 get_args:
267           argno = 1;
268 
269 next_arg:
270           argno = argno + 1;
271           call cu_$arg_ptr (argno, argp, argl, code);       /* any more args */
272           if code ^= 0 | argl = 0 then do;                  /* if not, then leave */
273                if fnp_only then go to no_more_segs;         /* nothing more to do before attach call */
274                else go to no_more_args;
275           end;
276 
277           if arg = "-dim" then do;                          /* next arg is name of dim */
278                argno = argno + 1;
279                call cu_$arg_ptr (argno, argp, argl, code);
280                if code ^= 0 | argl = 0 then do;
281                     seg_id = "dim";
282                     go to call_com;
283                end;
284                iotype = arg;
285           end;
286 
287           else if arg = "-dev" then do;                     /* next arg is name of device or stream */
288                argno = argno + 1;
289                call cu_$arg_ptr (argno, argp, argl, code);
290                if code ^= 0 | argl = 0 then do;
291                     seg_id = "device";
292                     go to call_com;
293                end;
294                ioname2 = arg;
295           end;
296 
297           else if arg = "-restart" & ^fnp_only then do;     /* if we are restarting */
298                restartsw = "1"b;                            /* note it so no segs will be dumped */
299                argno = argno + 1;
300                call cu_$arg_ptr (argno, argp, argl, code);
301                if code ^= 0 | argl = 0 then do;
302                     seg_id = "restart process_number";
303                     go to call_com;
304                end;
305                rt_proc_no = cv_oct_check_ (arg, i);         /* except those following the seg with this proc_no */
306                if i ^= 0 then do;
307                     seg_id = "restart process_no is not octal";
308                     go to call_com_oct;
309                end;
310                argno = argno + 1;
311                call cu_$arg_ptr (argno, argp, argl, code);
312                if code ^= 0 | argl = 0 then do;
313                     seg_id = "restart segment number";
314                     go to call_com;
315                end;
316                rt_seg_no = cv_oct_check_ (arg, i);          /* AND this seg_no */
317                if i ^= 0 then do;
318                     seg_id = "restart segment_no is not octal";
319                     go to call_com_oct;
320                end;
321           end;
322 
323           else if arg = "-segs" & ^fnp_only then do;
324                segselsw = "1"b;                             /* later we will pick up selected segs */
325           end;
326 
327           else if arg = "-tag" & fnp_only then do;
328                argno = argno + 1;
329                call cu_$arg_ptr (argno, argp, argl, code);
330                if code ^= 0 | argl = 0 then do;
331                     seg_id = "tag";
332                     go to call_com;
333                end;
334 
335                tag = arg;
336                all_fnps = "0"b;                             /* not doing all now */
337                fnp_index = index ("abcdefgh", tag);         /* convert to number */
338                if fnp_index = 0 then do;                    /* not legal tag */
339                     seg_id = "invalid tag";
340                     go to call_com_oct;
341                end;
342 
343                dumpptr = addrel (dumpptr, fnp_size* (fnp_index-1)); /* point to relevant core image */
344           end;
345 
346           else do;
347                seg_id = arg;
348                code = error_table_$badopt;
349                go to call_com;
350           end;
351 
352           go to next_arg;
353 
354 call_com:
355           call com_err_ (code, procname, "^a", seg_id);
356           return;
357 call_com_oct:
358           call com_err_ (0, procname, "^a:  ^a", seg_id, arg);
359           return;
360 ^L
361 no_more_args:
362                                                             /* Extract various system segment numbers, and copy per-system data bases */
363           if slt_seg = null
364           then do;
365                call hcs_$make_seg (c0, "od.slt--", c0, seg_mode, slt_seg, code);
366                call hcs_$make_seg (c0, "od.nam--", c0, seg_mode, nam_seg, code);
367                call hcs_$make_seg (c0, "od.sst--", c0, seg_mode, sst_seg, code);
368                call hcs_$make_seg (c0, "od.sstnt", c0, seg_mode, sstnt_seg, code);
369                call hcs_$make_seg (c0, "od.dseg-", c0, seg_mode, ds_seg, code);
370                call hcs_$make_seg (c0, "od.pds--", c0, seg_mode, pds_seg, code);
371                call hcs_$make_seg (c0, "od.prds-", c0, seg_mode, prds_seg, code);
372                call hcs_$make_seg (c0, "od.shut-", c0, seg_mode, shut_seg, code);
373                call hcs_$make_seg (c0, "od.stk--", c0, seg_mode, stk_seg, code);
374                                                             /* Following calls temporarily commented out:
375                                                                call hcs_$make_seg(c0, "od.pdf--", c0, seg_mode, pdf_seg, code);
376                                                                /* Need more temporary segments?  Add above this line */
377           end;
378           cur_proc_index = 1;                               /* For copy_dump_seg_ */
379           namp, dsp, sstnp, sstp = null;                    /* Just in case */
380           slt_seg_no = 7;
381 
382           call copy_dump_seg_ (7, cur_proc_index, ptr_array, len_array, slt_seg, sltlen);
383           if sltlen = 0
384           then do;
385                call ioa_ ("Can't find ""^a""", "slt");
386 NOT_SLT:       sltp = null;
387                sst_seg_no = 10;                             /* Subject to change */
388                go to copy_sst;
389           end;
390 
391           else do;                                          /* Pick out all interesting segment #-s */
392                sltp = slt_seg;
393                nam_seg_no = bin (baseno (sltp -> based_ptr), 18);
394                call copy_dump_seg_ (nam_seg_no, cur_proc_index, ptr_array, len_array, nam_seg, namlen);
395                if namlen ^= 0 then namp = nam_seg;
396                else do;                                     /* well at best the SLT is useless... */
397                     call ioa_ ("Cannot find name_table for slt");
398                     go to NOT_SLT;
399                end;
400 
401                call ring0_get_$segptr_given_slt ("", "slt", prt, code, sltp, namp); /* remember we guessed slt_seg_no = 7 */
402                if bin (baseno (prt), 18) ^= 7 then do;      /* alleged SLT not able to figure its own number! */
403                     call ioa_ ("Segments 7 and ^o not functioning as slt and name_table", nam_seg_no);
404                     namp = null;
405                     go to NOT_SLT;
406                end;
407 
408                call ring0_get_$segptr_given_slt ("", "sst", prt, code, sltp, namp);
409                if code = 0 then do;
410                     sst_seg_no = bin (baseno (prt), 18);
411                end;
412                else do;
413                     sst_seg_no = 9;
414                end;
415                call ring0_get_$segptr_given_slt ("", "sst_names_", prt, code, sltp, namp);
416                sstnt_seg_no = bin (baseno (prt), 18);
417                call ring0_get_$segptr_given_slt ("", "pds", prt, code, sltp, namp);
418                pds_seg_no = bin (baseno (prt), 18);
419                call ring0_get_$segptr_given_slt ("", "prds", prt, code, sltp, namp);
420                prds_seg_no = bin (baseno (prt), 18);
421 ^L
422 copy_sst:                                                   /* Copying of SST must be the last in this sequence */
423                call copy_dump_seg_ (sst_seg_no, cur_proc_index, ptr_array, len_array, sst_seg, sstlen);
424                if sstlen = 0
425                then do;
426                     call ioa_ ("Can't find ""^a""", "sst");
427                     sstp = null;
428                end;
429                else do;
430                     sstp = sst_seg;
431                     sst_abs_loc = sstp -> sst.ptwbase;
432                     sst_high_loc = sst_abs_loc + sstlen ;
433                     ast_off = - (sstp -> sst.astsize);
434                end;
435                                                             /* Copy the SST name table */
436 
437                call copy_dump_seg_ (sstnt_seg_no, cur_proc_index, ptr_array, len_array, sstnt_seg, sstntlen);
438                if sstntlen = 0 then do;
439                     call ioa_ ("Cannot find SST name table.");
440                     sstnp = null;
441                end;
442                else do;
443                     sstnp = sstnt_seg;
444                     if ^sstnp -> sstnt.valid then do;
445                          call ioa_ ("SST name  table not filled in.");
446                          sstnp = null;
447                     end;
448                end;
449           end;
450           if segselsw then do;                              /* now we pick up selected segnames or numbers */
451                call ask_$ask_clr;                           /* clear ask's internal line buffer */
452 get_next_seg:
453                call ask_ (c0, seg_id);                      /* pick up specification of a seg */
454                if seg_id = "quit" then go to no_more_segs;  /* no more  wanted */
455                if seg_id = "regs" then do;
456                     wants_regs = "1"b;
457                     go to get_next_seg;
458                end;
459                seg_no = cv_oct_check_ (seg_id, i);          /* try it as octal segno */
460                if i = 0 then wants_seg (seg_no) = "1"b;     /* it is octal and we mark it wanted */
461                else if sltp ^= null then do;                /* not octal, see if its a name in SLT, if any */
462                     call ring0_get_$segptr_given_slt ("", (seg_id), prt, code, sltp, namp);
463                     if code = 0 then do;                    /* it was found in SLT */
464                          seg_no = bin (baseno (prt), 18);
465                          wants_seg (seg_no) = "1"b;         /* and we mark it's segno as wanted */
466                     end;
467                     else do;                                /* not in SLT,wasn't octal=> it loses */
468                          call ioa_ ("Cannot find segment ^a in slt", seg_id); /* name or slt is nonsense */
469                     end;
470                end;
471                go to get_next_seg;                          /* see if there are more */
472           end;
473 no_more_segs:
474           call ioa_ ("Segment ""^a"", device ""^a"", module ""^a""", /* Print current attachment info etc */
475                name, ioname2, iotype);
476           call ios_$attach (ioname, iotype, ioname2, "w", b72); /* Attach printer or other device */
477           tmp = addr (b72);                                 /* Pro _^Ht_^He_^Hm_^Hpore */
478           if tmp -> io_status.code ^= 0
479           then do;
480                call com_err_ (tmp -> io_status.code, procname,
481                     "attach call, sub-status ^w, contact programming staff", tmp -> io_status.substatus);
482                return;
483           end;
484           call od_print_$op_init (bin (dumpptr -> dump.erfno, 17), dumpptr -> dump.time); /* Initialize print program */
485           call od_print_ (m1, fmthdr, "Start", erf_no);     /* Print header */
486           tmp = addr (temp);                                /* For short lines, boundary conditions, etc */
487           eightp = addr (fmteight);                         /* For page-table printout */
488           if restartsw then call ioa_ ("Continue dumping ^a", erf_no);
489           else
490           call ioa_ ("Begin dumping ^a", erf_no);           /* Send message to console */
491           if fnp_only then do while ("1"b);
492                call od_print_$op_finish;
493                call online_355_dump_ (dumpptr, fnp_index);
494                if all_fnps & fnp_index < max_fnps then do;  /* more fnp dumps to process */
495                     fnp_index = fnp_index + 1;
496                     dumpptr = addrel (dumpptr, fnp_size);   /* point to next core image */
497                end;
498 
499                else go to tm_loop;
500           end;
501 ^L
502 /* Print register contents */
503 
504           prt = addr (dumpptr -> dump.dbr);
505           dsbr_stk_no = bin (prt -> dsbr.stack, 12) * 8;
506           if (restartsw | (segselsw & ^wants_regs)) then go to skip_regs;
507 
508           call od_print_ (two, fmtdbrh);                    /* descriptor base register */
509           call od_print_ (three, fmtdbr,
510                prt -> dsbr.add, prt -> dsbr.bound, prt -> dsbr.unpaged, prt -> dsbr.stack);
511 
512 
513           call od_print_ (four, fmtpprh);                   /* proceedure pointer register */
514           scup = addr (dumpptr -> dump.scu (0));
515           call od_print_ (one, fmtppr,
516                scup -> scu.ppr.prr, scup -> scu.ppr.psr, scup -> scu.ilc);
517 
518 
519           call od_print_ (two, fmtrar, dumpptr -> dump.regs.ralr);
520           call od_print_ (two, fmtind, scup -> scu.ir);
521           call od_print_ (one, fmta, dumpptr -> dump.regs.a);
522           call od_print_ (one, fmtq, dumpptr -> dump.regs.q);
523           call od_print_ (one, fmte, dumpptr -> dump.regs.e);
524           call od_print_ (two, fmtt, dumpptr -> dump.regs.t);
525 
526           call od_print_ (two, fmtbar, dumpptr -> dump.bar);
527 
528 
529           prt = addr (dumpptr -> dump.regs.x (0));
530           do j = 0 by 1 while (j < 8);                      /* index registers */
531                call od_print_ (one, fmtx, j, prt -> xreg (j));
532           end;
533 
534 
535           call od_print_ (two, fmtmode, dumpptr -> dump.modereg, dumpptr -> dump.cmodereg);
536           call od_print_ (one, fmtflt, dumpptr -> dump.faultreg);
537 
538 
539           call od_print_ (two, fmtinter, dumpptr -> dump.intrpts); /* interrupts */
540 
541 
542           call od_print_ (four, fmtprh);                    /* pointer registers */
543           do j = 0 by 1 while (j < 8);
544                prt = addr (dumpptr -> dump.prs (j));
545                call od_print_ (one, fmtpr,
546                     substr ("APABBPBBLPLBSPSB", j*2+1, 2),
547                     j,
548                     bin (prt -> its.ringno, 3),
549                     bin (prt -> its.segno, 15),
550                     bin (prt -> its.offset, 18),
551                     bin (prt -> its.bit_offset, 6));
552           end;
553 
554           call od_print_$op_new_page;
555 ^L
556           call od_print_ (five, fmtamsdwh);                 /* assoc. mem. segment descriptor words */
557 
558           do j = 0 by 1 while (j < 16);
559                amrp = addr (dumpptr -> dump.amsdwregs (j));
560                ampp = addr (dumpptr -> dump.amsdwptrs (j));
561 
562                axstring = "REWPUG  ";                       /* check some bits */
563                axbitsp = addr (amrp -> amsdwreg.read);
564                do l = 1 to 6;
565                     if axbitsp -> axbits (l) = "0"b then substr (axstring, l, 1) = " ";
566                end;
567 
568                call od_print_ (one, fmtamsdw,
569                     bin (amrp -> amsdwreg.addr, 24),
570                     bin (amrp -> amsdwreg.r1, 3),
571                     bin (amrp -> amsdwreg.r2, 3),
572                     bin (amrp -> amsdwreg.r3, 3),
573                     bin (amrp -> amsdwreg.bound, 14),
574                     axstring,
575                     bin (amrp -> amsdwreg.cl, 14),
576                     bin (ampp -> amsdwptr.pointer, 15),
577                     substr ("EF", bin (ampp -> amsdwptr.valid, 1)+1, 1),
578                     bin (ampp -> amsdwptr.usage, 4));
579           end;
580 
581 
582           call od_print_ (five, fmtamptwh);                 /* assoc. mem. page table words */
583           do j = 0 by 1 while (j < 16);
584 
585                amrp = addr (dumpptr -> dump.amptwregs (j));
586                ampp = addr (dumpptr -> dump.amptwptrs (j));
587 
588                if amrp -> amptwreg.modif then twochar = "  "; else twochar = "NO";
589                if ampp -> amptwptr.valid then onechar = "F"; else onechar = "E";
590 
591                call od_print_ (one, fmtamptw,
592                     bin (amrp -> amptwreg.addr, 18),
593                     twochar,
594                     bin (ampp -> amptwptr.pointer, 15),
595                     bin (ampp -> amptwptr.pageno, 12),
596                     onechar,
597                     bin (ampp -> amptwptr.usage, 4));
598           end;
599 
600           call od_print_$op_new_page;
601 ^L
602           call od_print_ (four, fmtcbh);                    /* coreblocks */
603           do j = 0 by 1 while (j < 8);
604                prt = addr (dumpptr -> dump.coreblocks (j).num_first);
605                if prt -> sgl.zero = -1 then call od_print_ (one, fmtcbno);
606                else do;
607                     n_first = bin (dumpptr -> dump.coreblocks (j).num_first, 18);
608                     n_blocks = bin (dumpptr -> dump.coreblocks (j).num_blocks, 18);
609                     call od_print_ (one, "^-^-^- ^6o ^4o", n_first, n_blocks);
610                end;
611           end;
612 
613           call od_print_ (four, fmtmcmh);                   /* memory controller masks */
614           do j = 0 by 4 while (j< 8);
615                prt = addr (dumpptr -> dump.mcm (j));
616                call od_print_ (1, fmtmcm,
617                     2*j,
618                     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
619                     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
620           end;
621 
622           call od_print_ (four, fmthrh);
623           call od_print_ (two, "^/^-OU");
624           do j = 0 by 4 while (j < 16);
625                prt = addr (dumpptr -> dump.ouhist (j));     /* operations unit history regs */
626                call od_print_ (one, fmtmcm,
627                     2*j,
628                     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
629                     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
630           end;
631 
632           call od_print_ (two, "^/^-CU");
633           do j = 0 by 4 while (j < 16);
634                prt = addr (dumpptr -> dump.cuhist (j));     /* control unit history registers */
635                call od_print_ (one, fmtmcm,
636                     2*j,
637                     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
638                     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
639           end;
640 
641           call od_print_ (two, "^/^-AU");
642           do j = 0 by 4 while (j < 16);
643                prt = addr (dumpptr -> dump.auhist (j));     /* appending unit history registers */
644                call od_print_ (one, fmtmcm,
645                     2*j,
646                     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
647                     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
648           end;
649 
650           call od_print_ (two, "^/^-DU");
651           do j = 0 by 4 while (j < 16);
652                prt = addr (dumpptr -> dump.duhist (j));     /* decimal unit history registers */
653                call od_print_ (one, fmtmcm,
654                     2*j,
655                     prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
656                     prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
657           end;
658 ^L
659 /* Now dump individual segments/processes */
660 
661 skip_regs:
662           nsegs = dumpptr -> dump.num_segs;                 /* Copy for quicker reference */
663           cur_proc_no = 0;
664           do i = 1 to nsegs;
665                cur_seg_no = bin (dumpptr -> dump.segs (i).segno, 18);
666                if i > 1 then cur_orig = bin (dumpptr -> dump.segs (i-1).length, 18) * 64 + cur_orig ;
667                else cur_orig = size (dump);
668                given_length = bin (dumpptr -> dump.segs (i).length, 18) * 64;
669                call od_print_$op_new_seg (cur_seg_no);
670                if cur_seg_no = ds_seg_no then cur_proc_no = cur_proc_no + 1;
671                if cur_seg_no = rt_seg_no then if cur_proc_no = rt_proc_no then restartsw = "0"b;
672                if restartsw then if cur_seg_no ^= ds_seg_no then go to next_seg;
673                if cur_seg_no = ds_seg_no & (^restartsw | cur_proc_no = rt_proc_no) /* Is it a new descriptor seg */
674                then do;
675                     cur_proc_index = i;                     /* Yes, remember position for info for new process */
676                     prdsp, pdsp = null;
677                     if sltp ^= null then if namp ^= null    /* If we know where KST, PDS,PRDS are, copy them */
678                          then do;
679                               call copy_dump_seg_ (pds_seg_no, cur_proc_index, ptr_array, len_array, pds_seg, pdslen);
680                               if pdslen ^= 0 then pdsp = pds_seg;
681                               call copy_dump_seg_ (prds_seg_no, cur_proc_index, ptr_array, len_array, prds_seg, prdslen);
682                               if prdslen ^= 0 then prdsp = prds_seg;
683                          end;
684                     call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, ds_seg, dslen);
685                                                             /* Copy descriptor segment for this process */
686                     if dslen = 0
687                     then dsp, sdwp = null;
688                     else do;
689                          dsp = ds_seg;
690                          if (restartsw | (segselsw & ^wants_seg (ds_seg_no))) then go to next_seg;
691                          else do;
692                               eq_print = 0;
693                               call od_print_ (four, "^/^/^4-DESCRIPTOR SEGMENT^/");
694                               call od_print_ (two, fmtdesc);
695                               half_gl = divide (given_length, 2, 17, 0);
696                               do j = 0 by 1 while (j ^= half_gl); /* Print symbolic breakout of descriptors */
697                                    if dsp -> dbl_array (j) = 0 /* Don't print null SDW */
698                                    then eq_print = eq_print + 1; /* merely note it for blank line later */
699                                    else do;
700                                         if eq_print ^= 0
701                                         then call od_print_ (one, c0); /* Print blank line */
702                                         if sltp = null then go to CALL_PDSN_1;
703                                         if sltp -> slt.last_sup_seg >= j then do;
704                                              call print_dump_seg_name_$hard (j, dsp -> dbl_array (j), sltp, namp);
705                                         end;
706                                         else do;
707 CALL_PDSN_1:                                 call print_dump_seg_name_ (j, dsp -> dbl_array (j), sstp, sstnp);
708                                         end;
709                                         eq_print = 0;       /* Reset counter */
710                                    end;
711                               end;
712                          end;
713                     end;
714                     call od_print_$op_new_page;             /* After descriptor breakout, new page for segment */
715                end;
716 ^L
717                if segselsw then if ^wants_seg (cur_seg_no) then go to next_seg;
718                abs_loc = -wps;                              /* Generate large negative number */
719                jbdry = -1;                                  /* Such that comparison below will never succeed */
720                if dsp ^= null
721                then do;
722                     sdwp = addr (dsp -> dbl_array (cur_seg_no));
723                     call od_print_ (two, fmtdesc);
724                     if sltp = null then go to CALL_PDSN_2;
725                     if sltp -> slt.last_sup_seg >= cur_seg_no
726                     then call print_dump_seg_name_$hard (cur_seg_no, dsp -> dbl_array (cur_seg_no), sltp, namp);
727                     else do;
728 CALL_PDSN_2:             call print_dump_seg_name_ (cur_seg_no, dsp -> dbl_array (cur_seg_no), sstp, sstnp);
729                     end;
730                     if sdwp -> sdw.add
731                     then if sdwp -> sdw.unpaged = "0"b
732                          then do;
733                               if sstp ^= null               /* Get AST entry and page table */
734                               then do;
735                                    j = bin (sdwp -> sdw.add, 24);
736                                    if j > sst_high_loc      /* Check for address beyond end of SST */
737                                    then go to use_abs;
738                                    jbdry = 0;               /* Where absolute location is next computed */
739                                    page_no = 0;             /* for indexing into page table */
740                                    ptp = addrel (sstp, j - sst_abs_loc);
741                                    prt = ptp;
742                                    astep = addrel (ptp, ast_off);
743 
744                                    j1 = bin (sdwp -> sdw.bound, 14) + 1; /* Extract bounds field */
745                                    j2 = divide (j1 + 63, 64, 17, 0);
746                                    j1 = divide (j2, 8, 17, 0);
747                                    j2 = j2 - j1 * 8;
748 
749                                    call od_print_ (four, fmtast,
750                                         astep -> sgl.zero, astep -> sgl.one, astep -> sgl.two, astep -> sgl.three,
751                                         astep -> sgl.four, astep -> sgl.five, astep -> sgl.six, astep -> sgl.seven);
752                                    do j = 0 by 8 while (j < j1); /* Print full lines */
753                                         call od_print_ (one, fmteight, j,
754                                              prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
755                                              prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven);
756                                         prt = addrel (prt, 8);
757                                    end;
758                                    if j2 ^= 0
759                                    then do;
760                                         l = j2 * 4 + 5;     /* # of characters to use */
761                                         call od_print_ (one, eightp -> bl, j,
762                                              prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
763                                              prt -> sgl.four, prt -> sgl.five, prt -> sgl.six);
764                                    end;
765                               end;
766                          end;
767                          else                               /* ! */
768 use_abs:                 abs_loc = bin (sdwp -> sdw.add, 24);
769                     call od_print_ (one, c0);               /* Separate contents from header by blank line */
770                end;
771                if given_length <= 0
772                then do;
773                     call od_print_ (one, fmtlth, given_length);
774                     go to next_seg;
775                end;
776 ^L
777 /* All preliminary work done, start to dump seg */
778 /* Note: given_length is in words */
779 
780                prt = null;
781                if cur_seg_no ^= 0 then do;
782                     if (cur_seg_no = pds_seg_no & pdsp ^= null) then prt = pdsp;
783                     else if (cur_seg_no = prds_seg_no & prdsp ^= null) then prt = prdsp;
784                     else if (cur_seg_no >= dsbr_stk_no & dsbr_stk_no ^= 0 & cur_seg_no - dsbr_stk_no < 8) then do;
785                          call copy_dump_seg_ (cur_seg_no, cur_proc_index, ptr_array, len_array, stk_seg, stklen);
786                          if stklen ^= 0 then prt = stk_seg;
787                     end;
788                end;
789                if prt = null then go to NOT_STACK;
790                call od_stack_ (prt, given_length, sltp, namp, sstp, sstnp);
791                go to next_seg;                              /* this one is done */
792 NOT_STACK:
793                j1 = given_length;                           /*  num lines in seg as dumped by bos, which dumps 64 wd blocks */
794                if sdwp -> sdw.unpaged then do;
795                     j2 = (bin (sdwp -> sdw.bound, 14) + 1) * 16; /* unpaged segs' lengths not necess multiple of 64 really */
796                     if j2 < j1 then j1 = j2;                /* so we use the bounds field which gives num of 16 wd units */
797                end;
798 
799                ptr_index = divide (cur_orig, wps, 17, 0);
800                seg_index = mod (cur_orig, wps);
801                cur = addrel (ptr_array (ptr_index), seg_index);
802 
803                eq_print = 0;                                /* No suppressed lines */
804 
805 /* Note re-entry to loop at "compare": if Version II PL/I makes noises, change to "do while", etc */
806 
807                do j = 0 by 8 while (j < j1);                /* print all full lines */
808 
809                     wpsmsi = wps - seg_index;               /* Calculate # of words remaining in current image seg */
810 
811                     if wpsmsi >= 8                          /* 8 or more, print directly */
812                     then do;
813 retry_8:
814                          prt = cur;
815 compare:                                                    /* Come here at most once after main loop to compare and */
816                                                             /* print partial line */
817 
818                          if j = jbdry
819                          then do;
820                               ptwp = addr (ptp -> bin_array (page_no));
821                               if ptwp -> ptw.df
822                               then abs_loc = bin (ptwp -> ptw.add, 18) * 64;
823                               else abs_loc = -wps;          /* Page not in core */
824 
825                               jbdry = jbdry + 1024;
826                               page_no = page_no + 1;
827                          end;
828 
829                          if j ^= 0                          /* Don't check first time through */
830                          then if prt -> dbl.six = cmp.six   /* See if this line equals previous line */
831                               then if prt -> dbl.four = cmp.four
832                                    then if prt -> dbl.two = cmp.two
833                                         then if prt -> dbl.zero = cmp.zero
834                                              then do;
835                                                   eq_print = eq_print + 1; /* Note occurence of repeated line */
836                                                   go to endj;
837                                              end;
838 
839                          if eq_print ^= 0                   /* Line was different, were there suppressed lines? */
840                          then do;
841                               if eq_print = 1               /* How many? */
842                               then s = " ";
843                               else s = "s";
844                               call od_print_ (one, fmteq, eq_print, s);
845                               eq_print = 0;                 /* Reset counter */
846                          end;
847 
848 
849 /*                       call od_print_(one, fmt, abs_loc, j,
850    prt -> sgl.zero, prt -> sgl.one, prt -> sgl.two, prt -> sgl.three,
851    prt -> sgl.four, prt -> sgl.five, prt -> sgl.six, prt -> sgl.seven); /* Print line */
852 
853                          call od_print_$op_fmt_line (abs_loc, j, prt -> sgl.zero);
854 
855                          cmp.six = prt -> dbl.six;          /* Copy for next comparison */
856                          cmp.four = prt -> dbl.four;
857                          cmp.two = prt -> dbl.two;
858                          cmp.zero = prt -> dbl.zero;
859                     end;
860 
861 
862                     else do;                                /* fewer than 8, switch to next seg of image */
863                          nxt = ptr_array (ptr_index + 1);
864                          if wpsmsi = 0                      /* If zero, trivial */
865                          then do;
866                               cur = nxt;
867                               seg_index = 0;
868                               go to retry_8;
869                          end;
870 
871                          seg_index = -wpsmsi;               /* Set for advancing at "endj" */
872                          cur = addrel (nxt, seg_index);
873                          prt = tmp;                         /* Compare/print from special buffer */
874                          go to compare;
875                     end;
876 
877 endj:               cur = addrel (cur, 8);                  /* Advance pointer */
878                     seg_index = seg_index + 8;              /* and index in parallel */
879                     abs_loc = abs_loc + 8;                  /* Augment absolute address */
880                end;
881 
882 
883                if eq_print ^= 0                             /* See if last line was identical to last printed line */
884                then do;
885                     if eq_print = 1
886                     then s = " ";
887                     else s = "s";
888                     call od_print_ (one, fmteq, eq_print, s);
889                end;
890 
891 
892 next_seg:
893           end;
894 ^L
895 /* Cleanup */
896 tm_loop:
897           do j = 0 by 1 to 9 while (ptr_array (j) ^= null); /* Terminate all segs of image */
898                call hcs_$terminate_noname (ptr_array (j), code);
899           end;
900 
901           call od_print_ (m1, fmthdr, "End", erf_no);
902 
903 od_cleanup: entry;                                          /* To close buffer and detach printer */
904           call od_print_ (m1, fmteject);
905 
906           call od_print_$op_finish;
907           call ios_$detach (ioname, c0, c0, b72);
908           call ioa_ ("Finished dump");
909      end online_dump;