1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 bcdmp: proc (seg_ptr);
  7 
  8 /* Procedure to dump a GCOS segment, printing less information than dump_segment.
  9    Entry bcdmp prints bcw, then for each record, the rcw and its offset, and the
 10    BCD or ASCII contents (BCD translated to ASCII for printing). Binary card
 11    records just have their rcw and offset printed.
 12 
 13    Entry gcdmp prints just bcw and rcws, and their offsets. No record contents are
 14    printed.
 15 
 16    Entry set_max_line_len gives the line length of the terminal, and by implication,
 17    the number of rcw-offset pairs that will fit on a line (20 chars per).
 18    The segment and offset to be dumped are specified by a pointer argument. Dumping
 19    always begins at the beginning of a GCOS block (on a 320-word boundary). If the
 20    offset in the pointer does not specify such an address, it will be rounded
 21    DOWN, so dumping will begin at the start of the block in which the offset falls.
 22 
 23    This procedure can be called as a subroutine, or from db:
 24    :=bcdmp(segno|offset)
 25 
 26    or by the dump_gcos (dgc) command, which accepts a pathname, offset, line length,
 27    and -bcd (or -ch) argument.
 28 
 29 
 30    WRITTEN BY T. CASEY, JULY 1974
 31 
 32 */
 33 
 34 dcl  gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin, ptr);
 35 
 36 dcl (command_query_
 37      , ioa_, ioa_$nnl
 38      , com_err_
 39      , db
 40      ) ext entry options (variable);
 41 
 42 %include query_info_;
 43 
 44 dcl  word bit (36) aligned based;
 45 dcl  char_string char (200) based;
 46 
 47 dcl 1 bcw aligned based (block_ptr),
 48     2 bsn bit (18) unaligned,
 49     2 length bit (18) unaligned;
 50 
 51 dcl 1 rcw aligned based (record_ptr),
 52     2 length bit (18) unaligned,
 53     2 eof bit (6) unaligned,
 54     2 zeros bit (2) unaligned,
 55     2 media_code bit (4) unaligned,
 56     2 report_code bit (6) unaligned;
 57 
 58 dcl (seg_ptr, block_ptr, record_ptr) ptr;
 59 dcl  offset fixed bin (35);
 60 dcl (block_len, record_len, cur_line_len, i, medium) fixed bin;
 61 dcl  max_line_len fixed bin int static init (80);
 62 
 63 dcl  reply char (4) varying;
 64 dcl  me char (5);
 65 dcl  ascii_line char (200);
 66 
 67 dcl  bcdsw bit (1) aligned init ("1"b);
 68 
 69 dcl (addr, addrel, fixed, index, rel, substr) builtin;
 70 
 71           me = "bcdmp";
 72 
 73 start:
 74           block_ptr = seg_ptr;
 75           offset = fixed (rel (block_ptr));
 76           cur_line_len = 0;
 77 
 78           i = mod (offset, 320);
 79           if i ^= 0 then do;
 80                offset = offset - i;
 81                block_ptr = addrel (block_ptr, -i);
 82                call com_err_ (0, me, "will start at offset: ^6o", offset);
 83           end;
 84 
 85 start_block:
 86           block_len = fixed (bcw.length);
 87 
 88           if cur_line_len ^= 0 then do;
 89                call ioa_ ("");
 90                cur_line_len = 0;
 91           end;
 92 
 93           call ioa_ ("^/^6o ^w", offset, block_ptr -> word);
 94           if block_ptr -> word = (36)"0"b then do;
 95                call com_err_ (0, me, "bcw = 0; aborting dump");
 96                goto exit;
 97           end;
 98 
 99           if block_len = 0 then goto next_block;
100 
101           offset = offset + 1;
102           record_ptr = addrel (block_ptr, 1);
103 
104 next_record:
105           record_len = fixed (rcw.length);
106 
107           if record_len > block_len then do;
108                call com_err_ (0, me, "bad rcw:");
109                goto new_line;
110           end;
111 
112           if bcdsw then do;
113 
114                if record_len = 0 then goto new_line;
115 
116                ascii_line = "";
117 
118                medium = fixed (rcw.media_code);
119 
120                if medium >= 5 then                          /* ascii */
121                     ascii_line = substr (addrel (record_ptr, 1) -> char_string, 1, record_len*4);
122 
123                else if medium = 1 then                      /* binary card */
124                     ascii_line = "BINARY CARD";
125 
126                else do;                                     /* else assume bcd */
127                     call gcos_cv_gebcd_ascii_ (addrel (record_ptr, 1), record_len*6, addr (ascii_line));
128 
129 /* COMMENT OUT: so we can see the !1 or !2 or whatever, at the end of the last word
130    substr (ascii_line, 1+index (ascii_line, "!")) = ""; /* END COMMENT OUT */
131                     substr (ascii_line, 1+record_len*6) = ""; /* but blank out the garbage after the last word */
132                end;
133 
134                call ioa_ ("^6o ^w ^a", offset, record_ptr -> word, ascii_line);
135           end;
136 
137           else do;
138                if cur_line_len = 0 then goto new_line;
139                if cur_line_len + 20 > max_line_len then
140 new_line:           do;
141                     call ioa_$nnl ("^/^6o ^w", offset, record_ptr -> word);
142                     cur_line_len = 20;
143                end;
144                else do;
145                     call ioa_$nnl (" ^6o ^w", offset, record_ptr -> word);
146                     cur_line_len = cur_line_len + 20;
147                end;
148           end;
149 
150           if rcw.eof = "001111"b then do;
151                query_info.yes_or_no_sw = "1"b;
152                call command_query_ (addr (query_info), reply, me, "eof in rcw; do you wish to continue?");
153                if reply = "no" then goto exit;
154           end;
155 
156           offset = offset + record_len + 1;
157           record_ptr = addrel (record_ptr, record_len+1);
158           block_len = block_len - record_len - 1;
159 
160           if block_len < 0 then do;
161                call com_err_ (0, me, "warning - remaining block length went negative - calling db");
162                call db;
163           end;
164 
165           if block_len <= 0 then
166 next_block:    do;
167                block_ptr = addrel (block_ptr, 320);
168                offset = fixed (rel (block_ptr));
169                goto start_block;
170           end;
171 
172           goto next_record;
173 
174 exit:
175 
176 /* terminate the seg here, if we add code to initiate it later */
177 
178           call com_err_ (0, me, "returning to caller");
179           return;
180 
181 /* Entry to request printing of just block and record control words */
182 
183 gcdmp:    entry (seg_ptr);
184 
185           me = "gcdmp";
186           bcdsw = "0"b;
187           goto start;
188 
189 /* Entry to set max_line_length */
190 
191 set_max_line_len: entry (ll);
192 
193 dcl  ll fixed bin;
194 
195           max_line_len = ll;
196           return;
197 
198      end bcdmp;