1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  7 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  8 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  9 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
 10 
 11 ts_: tedshow_:                          /* show parts of bcb or dbase        */
 12    proc options (variable);
 13      goto start;
 14 
 15 init:      entry;
 16      stk_init = "1"b;
 17      return;
 18 
 19 dcl stk             (0:20) char (8) var int static;
 20 dcl stkl            fixed bin int static init (0);
 21 dcl stk_init        bit (1) int static init ("1"b);
 22 dcl prefix          char (1) int static init (" ");
 23 
 24 dcl concat          char (1024)var;
 25 dcl work            char (256) var;
 26 dcl token           char (8) var;
 27 dcl name            char (8) var;
 28 dcl abp             ptr based (arg_p);
 29 dcl active          bit (1);
 30 dcl argct           fixed bin;
 31 dcl argno fixed bin;
 32 dcl arg_l           fixed bin (21);
 33 dcl arg_p           ptr;
 34 dcl arg             char (arg_l) based (arg_p);
 35 dcl code            fixed bin (35);
 36 dcl CR              bit (1);
 37 dcl cu_$arg_count   entry (fixed bin, fixed bin(35));
 38 dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
 39 dcl td              fixed bin;
 40 dcl tedshow_        entry() options (variable);
 41 dcl new_name        bit (1);
 42 dcl gvx_mark        char (1);
 43 dcl NLct            fixed bin;
 44 dcl i               fixed bin;
 45 dcl ioa_$ioa_switch entry() options(variable);
 46 dcl ioa_$ioa_switch_nnl
 47                     entry() options(variable);
 48 dcl printing        char (96) int static options (constant) init (
 49                     " !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLM" ||
 50                     "NOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
 51 
 52 start:
 53       CR = ""b;
 54       concat = "";
 55       if stk_init
 56       then do;
 57          stk_init = "0"b;
 58          stk(*)="???";
 59          stkl = 0;
 60          prefix = "@";
 61       end;
 62 /****      call ioa_$ioa_switch (db_output, "stk(^i)=""^a""", stkl, stk(stkl));                  */
 63       call cu_$arg_count (argct, code);
 64       if (code ^= 0)
 65       then do;
 66          call com_err_ (code, "tedshow_");
 67          return;
 68       end;
 69       call cu_$arg_ptr (1, arg_p, arg_l, code);
 70       if (code ^= 0)
 71       then do;
 72          call com_err_ (code, "tedshow_");
 73          return;
 74       end;
 75       bp = abp;                         /* for bcb, a1, a2, etc              */
 76       dbase_p = ptr (bp, 0);
 77       if (dbase.version ^= dbase_vers_3)
 78          | (verify (dbase.rq_id, "0123456789.") ^= 0)
 79          | (verify (dbase.dir_db, printing) ^= 0)
 80          | (verify (dbase.person, printing) ^= 0)
 81          | (verify (dbase.project, printing) ^= 0)
 82       then dbase_p = null();
 83       else do;
 84 dcl set_lock_$lock  entry (bit(36) aligned, fixed bin, fixed bin(35));
 85 dcl error_table_$locked_by_this_process fixed bin(35) ext static;
 86          if (dbase.recurs = 0)
 87          | (dbase.lock = ""b)
 88          then active = ""b;
 89          else do;
 90                                         /* do NOT want to alter the value of */
 91                                         /*  dbase.lock, but want to test to  */
 92                                         /*  see if this process "owns" it.   */
 93             call set_lock_$lock ((dbase.lock), -1, code);
 94                                         /* MUST pass dbase.lock by value!    */
 95             if (code = error_table_$locked_by_this_process)
 96             then active = "1"b;
 97             else active = ""b;
 98          end;
 99       end;
100       name = stk(stkl);
101       prefix = " ";
102       new_name = ""b;
103       do argno = 2 to argct;
104          call cu_$arg_ptr (argno, arg_p, arg_l, code);
105          concat = concat || " ";
106          concat = concat || arg;
107          work = ltrim (arg);
108          do while (work ^= "");
109             token = before (work, " ");
110             if new_name
111             then do;
112                new_name = ""b;
113                name = token;
114                if (prefix = "..")
115                then call ioa_$ioa_switch (db_output, "^a", name);
116                else do;
117                   do td = 1 to stkl while (stkl > 0);
118                      call ioa_$ioa_switch_nnl (db_output,
119 "^[>^;:^]^a", (td = 1), stk (td));
120                   end;
121                   call ioa_$ioa_switch (db_output, "^[>^;:^]^a", (stkl < 1), name);
122                   if (prefix = ">")
123                   then do;
124                      stkl = min (hbound (stk, 1), stkl + 1);
125                      stk (stkl) = name;
126                   end;
127                end;
128             end;
129             else do;
130                if (substr (token, length (token), 1) = ",")
131                then do;
132                   NLct = 0;
133                   token = substr (token, 1, length (token) - 1);
134                end;
135                else NLct = 1;
136                if (token = "*")         /* show "  * :"                      */
137                | (token = "<")          /* pop name from stack               */
138                then do;
139                   prefix = token;
140                end;
141                else if (token = ">")    /* push name on stack                */
142                | (token = ".")          /* use temporary name                */
143                | (token = "..")
144                then do;
145                   prefix = token;
146                   new_name = "1"b;
147                end;
148                else if (substr (token, 1, 1) = "[") /* literal string        */
149                then do;
150                   token = "";
151                   call heading;
152                   i = index (work, "]");
153                   if (i = 0)
154                   then i = length (work) - 1;
155                   else i = i - 2;
156                   call ioa_$ioa_switch_nnl (db_output,
157 "^a", substr (work, 2, i));
158                   CR = "1"b;
159                   work = substr (work, i+1);
160                end;
161                else if (token = "max")
162                then do;
163                   token = ":";
164                   call heading;
165                   call ioa_$ioa_switch (db_output, "b(^a) max=  1:^i(^i^[ PSEUDO^]",
166                      b.name, b.maxl, b.maxln, b.pseudo);
167                   last_bname = b.name;
168                end;
169                else if (token = "re")
170                then do;
171                   if (dbase_p = null())
172                   then goto not_avail;
173                   call tedsrch_$dis_exp (addr (dbase.regexp));
174                end;
175                else if (token = "cf")
176                then do;
177                   comptr = bp;
178                   gvx_mark = "";
179                   call cf_dumper;
180                end;
181                else if (token = "gvx")
182                then do;
183                   comptr = bp;
184                   call gvx_dumper;
185                end;
186                else if (token = "b_")
187                then call des (addr (b.b_));
188                else if (token = "b_*")
189                then do;
190                   if (dbase_p = null())
191                   then goto not_avail;
192                   do i = 0 to dbase.bufnum;
193                      bp = addr (DATABASE.cb(i));
194                      call ioa_$ioa_switch_nnl (db_output,
195 "b(^a)^21t^15p spa=^2i,^2i,^2i ",
196                         b.name, b.cur.sp, b.cur.sn, b.cur.pn, b.cur.ast);
197                      call des$no_last (addr (b.b_));
198                   end;
199                end;
200                else if (substr (token, 1, 2) = "b(")
201                   & (substr (token, length (token), 1) = ")")
202                then do;
203                   if (dbase_p = null())
204                   then goto not_avail;
205                   token = substr (token, 3, length (token) - 3);
206                   bp = null();
207                   do i = 0 to dbase.bufnum;
208                      bp = addr (DATABASE.cb(i));
209                      if (b.name = token)
210                      then goto found;
211                   end;
212                   call ioa_$ioa_switch (db_output, "*** b(^a) not found", token);
213                   return;
214 found:
215                   call ioa_$ioa_switch (db_output, "--> b(^a)", token);
216                end;
217                else if (token = "nb")
218                then call des (addr (b.newb));
219                else if (token = "ex")
220                then call des (addr (b.ex));
221                else if (token = "bx")
222                then do;
223                   token = "b_";
224                   call des (addr (b.b_));
225                   token = "ex";
226                   call des (addr (b.ex));
227                end;
228                else if (token = "so.ex")
229                then do;
230                   if (dbase_p = null())
231                   then goto not_avail;
232                   sv_p = ptr (dbase.seg_p (3), b.stack_o);
233                   token = "sex";
234                   call des (addr (sv.ex));
235                end;
236                else if (token = "so.a0")
237                then do;
238                   if (dbase_p = null())
239                   then goto not_avail;
240                   sv_p = ptr (dbase.seg_p (3), b.stack_o);
241                   token = "sa0";
242                   call des (addr (sv.a0));
243                end;
244                else if (token = "a0")
245                then do;
246                   ad_b, ad_e = 0;
247                   goto do_adr;
248                end;
249                else if (token = "a1")
250                then do;
251                   ad_b, ad_e = 1;
252                   goto do_adr;
253                end;
254                else if (token = "a2")
255                then do;
256                   ad_b, ad_e = 2;
257                   goto do_adr;
258                end;
259                else if (token = "adr")
260                then do;
261                   ad_b = 0;
262                   ad_e = 2;
263                   hold_prefix = prefix;
264                   prefix = " ";
265 dcl hold_prefix     char (1);
266 dcl (ad_b, ad_e)    fixed bin;
267 do_adr:
268                   if (ad_b ^= ad_e)
269                   then do;
270                      prefix = hold_prefix;
271                      token = "b_";
272                      call des (addr (b.b_));
273                   end;
274                   do i = ad_b to ad_e;
275                      token = "a";
276                      token = token || ltrim (char (i));
277                      if b.present (i)
278                      then token = token || "p";
279                      call des (addr (b.a_ (i)));
280                   end;
281                end;
282                else if (token = "cd")
283                then call des (addr (b.cd));
284                else if (token = "gb")
285                then call des (addr (b.gb));
286                else if (token = "na")
287                then call des (addr (b.newa));
288                else if (token = "rt")
289                then call des (addr (b.rel_temp));
290                else if (token = "t0")
291                then call des (addr (b.temp (0)));
292                else if (token = "t1")
293                then call des (addr (b.temp (1)));
294                else if (token = "t2")
295                then call des (addr (b.temp (2)));
296                else if (token = "rl")
297                then do;
298                   if (dbase_p = null())
299                   then goto not_avail;
300                   call pspa (addr (dbase.rl.part1));
301                   token = "";
302                   call des$no_last (addr (dbase.rl.part2));
303                end;
304                else if (token = "cur")
305                then call pspa (addr (b.cur));
306                else if (token = "pend")
307                then do;
308                   if (unspec (b.pend) ^= unspec (b.cur))
309                   then call pspa (addr (b.pend));
310                end;
311                else if (token = "base")
312                then do;
313                   if (dbase_p = null())
314                   then goto not_avail;
315                   call dump_stk (1);
316                   call dump_base;
317                end;
318                else if (token = "segs")
319                then do;
320                   if (dbase_p = null())
321                   then goto not_avail;
322                   call segs;
323                end;
324                else if (token = "bcb")
325                then call bcb;
326                else if (token = "stkall")
327                then do;
328                   if (dbase_p = null())
329                   then goto not_avail;
330                   call dump_stk (1);
331                end;
332                else if (token = "stktop")
333                then do;
334                   if (dbase_p = null())
335                   then goto not_avail;
336                   call dump_stk (dbase.stk_info.level);
337                end;
338                else if (substr (token, 1, 1) = "?")
339                then do;
340                   if (token = "?")
341                   then do;
342                      do qm = 1 to hbound (item, 1);
343                         call ioa_$nnl (" ""^a""", substr (item(qm), 1, 6));
344                      end;
345                      call ioa_$nnl ("^2/");
346                   end;
347                   else do;
348                      token = substr (token, 2);
349                      done = ""b;
350                      do qm = 1 to hbound (item, 1) while (^done);
351                         if (substr (item(qm), 1, 6) = token)
352                         then do;
353                            call ioa_$nnl ("^7a ^a^/", token, substr (item(qm), 7));
354                            done = "1"b;
355                         end;
356                      end;
357                      if ^done
358                      then call ioa_$nnl ("""^a"" is not defined^/", token);
359                   end;
360 
361 
362 dcl qm              fixed bin;
363 dcl done            bit (1);
364 dcl ioa_$nnl        entry() options(variable);
365 dcl item            (39) char (18) int static options (constant) init (
366                     "?     ------------",
367                     "?X    ------------",
368                     "*     ------------",
369                     ".     ------------",
370                     "..    ------------",
371                     "<     ------------",
372                     "> X   ------------",
373                     "[X    ------------",
374                     "[X]   ------------",
375                     "a0    ------------",
376                     "a1    ------------",
377                     "a2    ------------",
378                     "adr   ------------",
379                     "b_    ------------",
380                     "b_*   ------------",
381                     "base  ------------",
382                     "bcb   ------------",
383                     "bx    ------------",
384                     "cd    ------------",
385                     "cf    ------------",
386                     "cur   ------------",
387                     "ex    ------------",
388                     "gb    ------------",
389                     "gvx   ------------",
390                     "max   ------------",
391                     "na    ------------",
392                     "nb    ------------",
393                     "pend  ------------",
394                     "re    ------------",
395                     "rl    ------------",
396                     "rt    ------------",
397                     "segs  ------------",
398                     "so.a0 ------------",
399                     "so.ex ------------",
400                     "stkall------------",
401                     "stktop------------",
402                     "t0    ------------",
403                     "t1    ------------",
404                     "t2    ------------");
405                end;
406                else do;
407                   call ioa_$ioa_switch (db_output, "??? ^a", token);
408                end;
409                if (prefix = "<") & (token ^= "<")
410                then do;
411                   do td = 1 to stkl while (stkl > 0);
412                      call ioa_$ioa_switch_nnl (db_output,
413 "^[^/^]^1a^a", CR, prefix, stk (td));
414                      CR = ""b;
415                      prefix = ":";
416                   end;
417                   call ioa_$ioa_switch (db_output, "");
418                   stkl = max (0, stkl - 1);
419                   name = stk (stkl);
420                   prefix = " ";
421                end;
422             end;
423             work = ltrim (after (work, " "));
424          end;
425       end;
426       if CR then call ioa_$ioa_switch (db_output, "");
427       return;
428 
429 not_avail:
430       call ioa_$ioa_switch (db_output, "tedshow_: dbase_p not available to do ^a.", token);
431       return;
432 
433 heading: proc;
434 
435             if move_right
436             then call ioa_$ioa_switch_nnl (db_output,
437 "^2-");
438             call ioa_$ioa_switch_nnl (db_output,
439 " :^4a", token);
440 
441       end heading;
442 
443 des: proc (bd_p);
444 dcl bd_p            ptr;
445 
446 dcl 1 bd            like buf_des based (bd_p);
447 
448       if (last_bname ^= b.name)
449       then do;
450          call ioa_$ioa_switch (db_output, "^2-    :---b(^a)", b.name);
451          last_bname = b.name;
452       end;
453       if (unspec (bd) = unspec (tedcommon_$no_data))
454       then do;
455          return;
456       end;
457 
458 des$no_last: entry (bd_p);
459 
460       call heading;
461       call ioa_$ioa_switch (db_output,
462          "l=^4i:^i(^i^v.1tr=^4i:^i(^i^[ lv=^i
463 ^6xex_next:ex_EOD^v.1tex_lre:ex_last^]",
464          bd.l.le, bd.l.re, bd.l.ln, indent,
465          bd.r.le, bd.r.re, bd.r.ln, (token="ex"), dbase.stk_info.level, indent);
466    end des; %skip (2);
467 pspa: proc (sd_p);
468 dcl (
469     sd_p            ptr                 /* segment descr to display          */
470     )               parm;
471 dcl 1 sd            like seg_des based (sd_p);
472 
473 /*      if (prefix ^= " ")                                                   */
474 /*      then call heading;                                                   */
475       if (unspec (sd) = unspec (tedcommon_$no_seg))
476       then do;
477          return;
478       end;
479       call heading;
480       call ioa_$ioa_switch (db_output,
481          "^p sn=^i pn=^i ast=^i^[(255K)^;(64K)^;(16K)^;(4K)^;(1K)^]",
482          sd.sp, sd.sn, sd.pn, sd.ast, sd.ast);
483 
484    end pspa; %skip (3);
485 segs: proc;
486 
487       call ioa_$ioa_switch (db_output, "    .. ................ r/u c/l");
488       do i = -1 to dbase.seg_ct;
489          if (dbase.seg_p (i) ^= null ())
490          then do;
491             if active
492             then do;
493                call hcs_$fs_get_path_name (dbase.seg_p (i),
494                   dname, 0, ename, code);
495                if (code ^= 0) then call com_err_ (code, "get_pn", "^p",
496                   dbase.seg_p (i));
497                call hcs_$status_long (dname, ename, 1, addr (sb),
498                   null(), code);
499                if (code ^= 0) then call com_err_ (code, "stat_lg", "^a > ^a",
500                   dname, ename);
501                call ioa_$ioa_switch_nnl (db_output,
502 "    ^2i ^16p ^3i ^3i", i, dbase.seg_p (i),
503                   sb.records_used, sb.current_length);
504             end;
505             else call ioa_$ioa_switch_nnl (db_output,
506 "    ^2i ^16p ??? ???", i,   dbase.seg_p (i));
507 
508             if (i = 0)
509             then call ioa_$ioa_switch (db_output, " segs=^b",
510                substr (dbase.inuse_seg,1,dbase.seg_ct));
511             else if (i = 1)
512             then call ioa_$ioa_switch (db_output, " 1K=^b 4K=^b", dbase.inuse_1K,dbase.inuse_4K);
513             else if (i = 2)
514             then call ioa_$ioa_switch (db_output, " 16K=^b", dbase.inuse_16K);
515             else call ioa_$ioa_switch (db_output, "");
516          end;
517       end;
518 
519 dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr,
520                     fixed bin(35));
521 dcl hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*),
522                     fixed bin(35));
523 dcl dname           char (168);
524 dcl ename           char (32);
525 dcl code            fixed bin (35);
526 %include status_structures;
527 dcl 1 sb like status_branch;
528 
529 
530    end segs;
531 dump_base: proc;
532 
533 
534       call ioa_$ioa_switch (db_output, "  version=^i recurs=^i bwd=^p cba_p=^p eval_p=^p",
535          dbase.version, dbase.recurs, dbase.bwd, dbase.cba_p, dbase.eval_p);
536       call segs;
537 
538       call ioa_$ioa_switch (db_output, "  inuse:16K=^.b  4K=^.b  1K=^.b  seg=^.b",
539          dbase.inuse_16K, dbase.inuse_4K, dbase.inuse_1K,
540          substr (dbase.inuse_seg, 1, dbase.seg_ct + 1));
541 dcl date_time_      entry options (variable) returns (char (21));
542       call ioa_$ioa_switch (db_output, "  time=^a ^a seg_ct=^i argct=^i S_count=^i",
543          date_time_ (dbase.time), dbase.rq_id, dbase.seg_ct, dbase.argct,
544          dbase.S_count);
545       call ioa_$ioa_switch (db_output, "  not_read_ct=^i at_break=^i bufnum=^i lock=^.3b",
546          dbase.not_read_ct, dbase.at_break, dbase.bufnum, dbase.lock);
547       call ioa_$ioa_switch (db_output, "  cb_c_r=^6.3b cb_w_r=^6.3b", dbase.cb_c_r, dbase.cb_w_r);
548       call ioa_$ioa_switch (db_output, " ^[ flow^]^[ break^]^[ edit^]^[ input^]^[ old^]"
549          || "^[ read^]^[ lit^]",
550          dbase.flow_sw, dbase.break_sw, dbase.edit_sw, dbase.input_sw,
551          dbase.old_style, dbase.read_sw, dbase.lit_sw);
552       call ioa_$ioa_switch (db_output, " name=^a  ^a.^a comment=^a", dbase.tedname,
553          dbase.person, dbase.project, dbase.comment);
554       call ioa_$ioa_switch (db_output, " dir_db=^a^[ REMOTE^]", dbase.dir_db, dbase.remote_sw);
555       call ioa_$ioa_switch (db_output, " error=""^a""  err_go=""^a""", dbase.err_msg, dbase.err_go);
556       call tedshow_ (dbase_p, "rl");
557 
558       do i = 0 to dbase.bufnum;
559          call tedshow_ (addr (DATABASE.cb(i)),
560             "..", ltrim(char(i)), "bcb");
561       end;
562 
563    end dump_base;
564 dcl 1 DATABASE      based (dbase_p),
565       2 zzzzzz      like dbase,
566       2 cb          (0:DATABASE.bufnum) like b;
567 dump_stk: proc (lower);
568 dcl lower           fixed bin (21);
569 dcl seg_fault_error condition;
570 dcl j               fixed bin (21);
571 dcl tbp             ptr;
572 dcl str             char (2048)based;
573 
574       on condition (seg_fault_error)
575       begin;
576          call ioa_$ioa_switch (db_output, " curp=x|x top=x level=x next=x");
577          goto seg_flt;
578       end;
579       call ioa_$ioa_switch (db_output, " curp=^p  top=^p  level=^d  next=^d",
580          dbase.stk_info.curp, dbase.stk_info.top, dbase.stk_info.level,
581          dbase.stk_info.next);
582       if (dbase.seg_p (3) = null ()) | (dbase.stk_info.level = 0) | ^active
583       then return;
584       sv_p = dbase.stk_info.top;
585 dcl dd (2) char (80)var int static options(constant) init (
586 " lvl) this ...sv..... ...bcb.... (lines) .link. b.ex..",
587 "^04i) ^04i ^00000010p ^00000010p (^005i) ^06.3b ^4i,^4i,^4i,^4i^/^-b(^a) pn=^i");
588       call ioa_$ioa_switch (db_output, dd (1));
589       do i = dbase.stk_info.level to lower by -1;
590          tbp = sv.bp;
591          call tedcount_lines_ (tbp, 1, tbp -> b.maxl, j);
592          call ioa_$ioa_switch (db_output, dd (2), i, sv.this, sv_p, tbp, j, sv.stackl, sv.ex.l.le,
593             sv.ex.l.re, sv.ex.r.le, sv.ex.r.re, tbp -> b.name, sv.pn);
594          if (sv.pn > 0)
595          then call ioa_$ioa_switch (db_output, "^2-""^va""", sv.pl (0),
596                  substr (sv.pp (0) -> str, 1, sv.pl (0)));
597          sv_p = sv.prev;
598       end;
599 seg_flt:
600       revert condition (seg_fault_error);
601    end dump_stk;
602 
603 bcb: proc;
604 
605       call heading;
606       if (b.name = "")
607       then do;
608          call ioa_$ioa_switch (db_output, " ^10p EMPTY", bp);
609       end;
610       else do;
611          call ioa_$ioa_switch (db_output, " ^10p old=^i,^i new=^i,^i",
612             bp, b.old.le, b.old.re, b.new.le, b.new.re);
613          stkl = stkl + 1;
614          stk (stkl) = "..";
615          call tedshow_ (bp, "max cur b_ nb ex a0 a1 a2 cd gb na rt t0 t1 t2");
616          stkl = stkl - 1;
617          if b.mod_sw | b.terminate | b.get_bit_count | b.force_name
618             | b.no_io | b.not_pasted | b.initiate | b.ck_ptr_sw
619             then call ioa_$ioa_switch (db_output, "   ^[ mod^]^[ term^]^[ getbc^]^[ force^]"
620             || "^[ ^I/O^]^[ ^^paste^]^[ init^]^[ ckptr^]",
621             b.mod_sw, b.terminate, b.get_bit_count, b.force_name, b.no_io,
622             b.not_pasted, b.initiate, b.ck_ptr_sw);
623          if (b.dname ^= "")
624          then call ioa_$ioa_switch (db_output, "^12x^a^[ > ^a ^a ^a^[ [trust]^]^]",
625             b.dname, b.file_sw, b.ename, b.kind, b.cname,
626             b.trust_sw);
627       end;
628    end bcb;%page;
629 gvx_dumper: proc;
630 dcl ti              fixed bin;
631 
632       call ioa_$ioa_switch (db_output, "^[^14p^;^s^]max=^i tot=^i srch=^i mk=^i ic=^i", db_gv,
633          comptr, gvx.max_len, gvx.tot_len, gvx.srch_len, gvx.mk_list, gvx.ic);
634 
635       ti = gvx.ic;                      /* save the IC value                 */
636       gvx_mark = "~";
637       gvx.ic = 1;
638       do while (gvx.ic < gvx.tot_len);
639          if (gvx.ic = gvx.srch_len+1)
640          then call ioa_$ioa_switch (db_output, "^[^14x^]   |--srch_len=^i", db_gv, gvx.srch_len);
641          call cf_dumper;
642          gvx.ic = gvx.ic + cf.siz;
643       end;
644       call ioa_$ioa_switch (db_output, "^[^14p^;^s^]   |---tot_len=^i", db_gv,
645          addr (gvx.word (gvx.ic)), gvx.tot_len);
646       gvx.ic = ti;                      /* restore the IC value              */
647 
648    end gvx_dumper;%skip(5);
649 cf_dumper: proc;
650 
651 re_dump:
652       if (gvx.ic > gvx.tot_len)
653       then do;
654          call ioa_$ioa_switch (db_output, "ERROR: ic=^i > tot=^i", gvx.ic, gvx.tot_len);
655          return;
656       end;
657       cfp = addr (gvx.word (gvx.ic));
658       call ioa_$ioa_switch_nnl (db_output,
659 "^[^14p^;^s^]^1a^[^p^-^;^s^]^3i# ^2iop ^3isiz ^3ilen ",
660          db_gv, cfp, gvx_mark, lg_sw, cfp, gvx.ic, cf.op, cf.siz, cf.len);
661       if (cf.op >= -7) & (cf.op <= 22)
662       then goto show (cf.op);
663       call ioa_$ioa_switch (db_output, " ERROR");
664       return;
665 
666 show (-7):                              /* test done, was success            */
667       call ioa_$ioa_switch (db_output, "success");
668       return;
669 show (-6):                              /* search test                       */
670       call ioa_$ioa_switch (db_output, "t=^i f=^i //", cft.t, cft.f);
671       exp_p = addr (cft.cexpml);
672       goto regexp;
673 show (-5):                              /* evaluation test                   */
674       call ioa_$ioa_switch (db_output, "t=^i f=^i ^a", cft.t, cft.f, cft.da);
675       return;
676 show (-4):                              /* evaluation replacement            */
677       call ioa_$ioa_switch (db_output, "(r) ^a", cf.da);
678       return;
679 show (-3):                              /* x\= replacement                   */
680       call ioa_$ioa_switch (db_output, "^a\=", cf.da);
681       return;
682 show (-2):                              /* & replacement                     */
683       call ioa_$ioa_switch (db_output, "&");
684       return;
685 show (-1):                              /* literal replacement               */
686       call ioa_$ioa_switch (db_output, """^va""", cf.len, cf.da);
687       return;
688 show (00):                              /* end of program                    */
689       call ioa_$ioa_switch (db_output, "EOP");
690       return;
691 show (01):                              /* ( address processing              */
692       call ioa_$ioa_switch (db_output, "(^i,^i)", cfa.ad1, cfa.ad2);
693       return;
694 show (04):                              /* K - kopy-append                   */
695 show (05):                              /* M - move-append                   */
696 show (06):                              /* k - kopy                          */
697 show (07):                              /* m - move                          */
698       call ioa_$ioa_switch (db_output, "^a(^.3b) ^i", substr (op_mnem, cf.op, 1), cfmk.cb_r,
699          cfmk.link);
700       return;
701 show (11):                              /* t - type to user_output           */
702 show (12):                              /* T - type to error_output          */
703       call ioa_$ioa_switch (db_output, "^a|^a|", substr (op_mnem, cf.op, 1), cf.da);
704       return;
705 show (17):                              /* { - evaluation                    */
706       call ioa_$ioa_switch (db_output, "^a", cf.da);
707       return;
708 show (18):                              /* a - append                        */
709 show (19):                              /* c - change                        */
710 show (20):                              /* i - insert                        */
711       call ioa_$ioa_switch (db_output, "^a ^va\f", substr (op_mnem, cf.op, 1), cf.len, cf.da);
712       return;
713 show (08):                              /* s - substitute                    */
714 show (15):                              /* u - lowercase translate           */
715 show (16):                              /* U - uppercase translate           */
716       call ioa_$ioa_switch (db_output, "^a/.../", substr (op_mnem, cf.op, 1));
717       exp_p = addr (cfx.cexpml);
718 regexp:
719       call tedsrch_$dis_exp (exp_p);
720       return;
721 
722 dcl exp_p           ptr;
723 
724 show (02):                              /* p - print                         */
725 show (03):                              /* P - print w/ linenumber           */
726 show (09):                              /* d - delete                        */
727 show (10):                              /* = - linenumber                    */
728 show (13):                              /* l - linefeed to user_output       */
729 show (14):                              /* L - linefeed to error_output      */
730 show (22):                              /* > -stop global if, goto           */
731       call ioa_$ioa_switch (db_output, "^a", substr (op_mnem, cf.op, 1));
732       return;
733 show (21):                              /* SP !!                             */
734       call ioa_$ioa_switch (db_output, "SP shouldn't be here");
735       return;
736 
737 /****                                           00000000011111111112222      */
738 /****                                           12345678901234567890123      */
739 dcl op_mnem         char (22) int static init ("(pPKMkmsd=tTlLuU{aci >");
740 
741    end cf_dumper;%skip(3);
742 dcl com_err_        entry() options(variable);
743 dcl tedsrch_$dis_exp entry (ptr);
744 dcl last_bname      char(16) int static init ("");
745 dcl (
746     addr, after, before, char, hbound, index, length, ltrim, max, min, null, ptr, substr, unspec, verify
747     )               builtin;
748 
749 bf: entry; indent = 17; return;
750 dcl indent          fixed bin int static init (26);
751 mlf: entry; move_right = ""b; return;
752 mln: entry; move_right = "1"b; return;
753 dcl move_right      bit (1) int static init (""b);
754 lgf: entry; lg_sw = ""b; return;
755 lgn: entry; lg_sw = "1"b; return;
756 dcl lg_sw bit (1) int static init (""b);
757 %include tedgvd;
758 %include tedcommon_;
759 %include tedbcb;
760 %include tedbase;
761 %include tedstk;
762 dcl tedcount_lines_ entry (             /* return # lines in string          */
763                     ptr,                /* -> buffer in which to count       */
764                     fixed bin (21),     /* where string begins in segment    */
765                     fixed bin (21),     /* where string ends in segment      */
766                     fixed bin (21)      /* # lines                     [OUT] */
767                     );
768 
769 
770    end tedshow_;