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_parse: procedure (input_buffer_ptr, input_line_len, arg_auto_ptr, arg_stat_ptr);
  12 
  13 
  14 /* Modified 10/ by S. Barr to recognize COBOL data types and the size field with the print request. */
  15 /* Modified 771116 by PG to add el & fl output modes */
  16 /* Changed "Version 1 symbol table" msg to say "this language not supported" 10/14/83 S. Herbst */
  17 
  18 /*        Parameters          */
  19 
  20 dcl  input_buffer_ptr ptr,
  21 
  22      input_line_len fixed bin,
  23 
  24      arg_auto_ptr ptr,
  25 
  26      arg_stat_ptr ptr;
  27 
  28 
  29 /*        Default  variables.           */
  30 
  31 dcl (data_ptr ptr,
  32      offset fixed bin (18),
  33      stack_depth fixed bin,
  34      data_id char (1) aligned,                              /* segment id corresponds to data_ptr (t, s, i, l) */
  35      input_type char (1) aligned,                           /* type of input.  Used to decide what
  36                                                                *  default to use for db_assign.
  37                                                                *  v = variable
  38                                                                *  a = address
  39                                                                *  * = indirect
  40                                                                *  % = temporary
  41                                                                */
  42      data_format char (6) aligned) internal static;
  43 
  44 
  45 dcl  continue bit (1) unal;
  46 dcl  break_action_code fixed bin,
  47      break_data_len fixed bin,
  48      break_data_line char (236),
  49      break_return fixed bin,
  50      reg_val bit (72);
  51 
  52 dcl  temp_reg_val fixed bin (71);
  53 
  54 dcl  goto_label label;
  55 
  56 dcl 1 label_map based aligned,
  57     2 pp ptr,
  58     2 sp ptr;
  59 
  60 dcl  err_no_linkage fixed init (1);
  61 dcl  err_no_stack fixed init (2);
  62 dcl  err_no_sym_tab fixed init (3);
  63 dcl  err_no_static fixed init (4);
  64 dcl  err_mess (4) char (40) int static init (
  65      "no linkage section",                                  /* err_no_linkage */
  66      "no stack frame",                                      /* err_no_stack */
  67      "no symbol table",                                     /* err_no_sym_tab */
  68      "no internal static");                                 /* err_no_static */
  69 
  70 dcl
  71      com_err_ ext entry options (variable),
  72      cu_$cp ext entry (ptr, fixed bin, fixed bin),
  73      cu_$gen_call ext entry (ptr, ptr),
  74      cv_oct_check_ ext entry (char (*), fixed bin) returns (fixed bin (35)),
  75      db_assign ext entry (char (132) aligned, fixed bin, fixed bin, ptr, ptr, ptr, fixed bin,
  76      fixed bin, fixed bin, fixed bin, bit (1)),
  77      db_break$global ext entry (fixed bin, fixed bin, char (236), fixed bin),
  78      db_break$print_bseg ext entry (fixed bin),
  79      db_break$print_default ext entry,
  80      db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin),
  81      db_break$set_default ext entry (ptr),
  82      db_break$set_skips ext entry (fixed bin, fixed bin),
  83      db_break$sub_global ext entry (fixed bin, fixed bin, char (236), fixed bin),
  84      db_break$single ext entry (fixed bin, fixed bin, fixed bin, char (236), fixed bin),
  85      db_parse_condition$set ext entry (char (132) aligned, fixed bin, fixed bin, fixed bin, char (236), fixed bin),
  86      db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
  87      db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
  88      db_get_count$double entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin (71)),
  89      db_get_sym ext entry (ptr),
  90      db_print ext entry (ptr, char (*) aligned, ptr, char (*) aligned, fixed bin, fixed bin, ptr,
  91      fixed bin, fixed bin),
  92      db_regs$get ext entry (ptr, char (4) aligned, bit (72), fixed bin),
  93      db_regs$print ext entry (ptr, char (4) aligned, fixed bin),
  94      db_regs$assign ext entry (ptr, char (4) aligned, bit (72), fixed bin),
  95      db_fill_snt ext entry (ptr, ptr),
  96      db_fill_snt$proc_ptr entry (ptr, ptr),
  97      db_sym ext entry (char (72) var, ptr, ptr, fixed bin (18), fixed bin, char (1) aligned, char (*) aligned,
  98      fixed bin, fixed bin, fixed bin),
  99      decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned,
 100      fixed bin, fixed bin, fixed bin),
 101      expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin),
 102      hcs_$fs_get_path_name ext entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin),
 103      hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin),
 104      hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*), fixed bin (1), fixed bin (2),
 105      ptr, fixed bin),
 106      hcs_$make_ptr ext entry (ptr, char (*) aligned, char (*) aligned, ptr, fixed bin),
 107      ioa_$ioa_stream entry options (variable),
 108      ioa_$rsnnl ext entry options (variable),
 109      iox_$close ext entry (ptr, fixed bin (35)),
 110      iox_$detach_iocb ext entry (ptr, fixed bin (35)),
 111      iox_$attach_ioname ext entry (char (*), ptr, char (*), fixed bin (35)),
 112      iox_$find_iocb ext entry (char (*), ptr, fixed bin (35)),
 113      iox_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
 114      list_arg_ ext entry (fixed bin, char (1) aligned, ptr),
 115      db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin),
 116      stu_$get_location ext entry (ptr, fixed bin, fixed bin (18));
 117 
 118 dcl  is_condition_frame_ entry (ptr) returns (bit (1) aligned);
 119 
 120 dcl  db_find_mc entry (ptr, bit (1) aligned, ptr);
 121 
 122 dcl  find_condition_info_ entry (ptr, ptr, fixed bin);
 123 
 124 dcl  stu_$get_runtime_location entry (ptr, fixed bin) returns (fixed bin (18));
 125 
 126 dcl  db_parse_arg$ptr_offset entry (char (132) aligned, fixed bin, fixed bin, fixed bin,
 127      ptr, fixed bin, fixed bin);
 128 
 129 
 130 
 131 dcl  error_table_$segknown ext fixed bin;
 132 
 133 
 134 dcl  code35 fixed bin (35);
 135 dcl  fboff fixed bin (9),
 136      code fixed bin,
 137      d_type fixed bin,
 138      itemp fixed bin,
 139     (max_stack, new_type, line_number) fixed bin,
 140     (pc, i, j) fixed bin,
 141      temp1 fixed bin (18),
 142     (ct, nv) fixed bin,
 143     (lin, ill) fixed bin,
 144     (size, scale, ndims) fixed bin,
 145      exec fixed bin;
 146 dcl  offset_incr fixed bin;                                 /* increment to be added to offset and working pointer */
 147 
 148 dcl  dol fixed bin;
 149 dcl  max_size fixed bin;
 150 
 151 dcl  based_bit72 bit (72) based;
 152 
 153 dcl  based_fix fixed bin based aligned;
 154 
 155 
 156 dcl  arglist (21) ptr,
 157      based_ptr ptr based (sp),
 158      ptr_array (1) based ptr,
 159     (pp, ilp, tp, tpp) ptr;
 160 
 161 
 162 
 163 
 164 dcl  switch bit (1) aligned;
 165 
 166 
 167 dcl  new_line char (1) aligned static init ("
 168 "),
 169 
 170      il char (132) aligned,
 171      reg_name char (4) aligned,
 172      str char (exec) based aligned,
 173      str1 char (ill) based aligned,
 174      sym_name char (72) var,
 175     (c1, c2) char (1) aligned,
 176      dir_name char (168) aligned,
 177      pathname char (168),
 178     (ent_name, ref_name) char (32) aligned,
 179      cmc char (1) aligned;
 180 dcl  char char (1) aligned;                                 /* character being used for parse */
 181 
 182 dcl (attach,                                                /* 1 = switch_name attached */
 183      open) bit (1) unaligned;                               /* 1 = switch_name opened */
 184 dcl  dec_default bit (1);                                   /* 1 = use dec_default for temporaries (%) */
 185 dcl  switch_name char (32);                                 /* switch_name for ".si" request */
 186 
 187 dcl  entry_name char (32) aligned;
 188 
 189 
 190 dcl  desc_area (11) bit (36) internal static
 191      init ((11) (1) "100000100000000000000000000000000001"b);
 192 
 193 dcl  desc_ptr ptr init (addr (desc_area));
 194 
 195 dcl 1 desc (11) aligned based (desc_ptr),
 196    (2 flag bit (1),
 197     2 type bit (6),
 198     2 packed bit (1),
 199     2 n_dims bit (4),
 200     2 size fixed bin (23)) unaligned;
 201 
 202 dcl  dummy_desc bit (36) aligned static init
 203     ("101010100000000000000000000000100000"b);              /* char(32) */
 204 
 205 dcl  return_desc bit (36) aligned static init
 206     ("100000100000000000000000000000000001"b);              /* fixed bin, 1 word */
 207 
 208 
 209 
 210 dcl (addr, addrel, baseno, baseptr, bit, max, null, ptr, rel, substr, index, search, verify) builtin;
 211 dcl (binary, divide, hbound, length, min, reverse) builtin;
 212 
 213 
 214 dcl 1 ff aligned based,
 215     2 (w0, w1) fixed bin;
 216 
 217 
 218 dcl 1 bi aligned based,
 219     2 ts (132) fixed bin (8) unaligned;                     /* character codes used as subscripts to type array */
 220 
 221 
 222 dcl 1 lot (0: 1023) aligned based,
 223     2 segno bit (18) unaligned,
 224     2 offset bit (18) unaligned;
 225 
 226 /* constants */
 227 
 228 dcl  NUMBER char (11) int static init ("0123456789&");
 229 dcl  MODES (21) char (6) var int static init (
 230      "a",
 231      "b",
 232      "p",
 233      "P",
 234      "i",
 235      "I",
 236      "l",
 237      "s",
 238      "o",
 239      "h",
 240      "d",
 241      "el",
 242      "fl",
 243      "f",
 244      "e",
 245      "g",
 246      "x",
 247      "comp-5",
 248      "comp-6",
 249      "comp-7",
 250      "comp-8");
 251 
 252 dcl 1 cond_info aligned,
 253 %include cond_info;
 254 %include db_ext_stat_;
 255 %include iocb;
 256 /* ^L */
 257 %include db_common_auto;
 258 /* ^L */
 259 %include db_common_static;
 260 /* ^L */
 261 %include db_snt;
 262 /* ^L */
 263 %include db_arg_list;
 264 /* ^L */
 265 %include its;
 266 /* ^L */
 267 %include stack_header;
 268 %include stack_frame;
 269 /*
 270    ^L
 271    use of big label arrays
 272 
 273    label_1                    label_2             label_3
 274 
 275    0                syntax_error        syntax_error        syntax_error
 276    1 (:)            colon0              colon               colon
 277    2 (%)            per_cent            syntax_error        syntax_error
 278    3 (/)            namel               syntax_error        syntax_error
 279    4 ($)            reg                 relative_offset     syntax_error
 280    5 (n)            offset1             relative_offset     syntax_error
 281    6 (+ -)          relative_offset     relative_offset     syntax_error
 282    7 (,)            set_mode            set_mode            set_mode
 283    8 (=)            assign              assign              assign
 284    9 (<)            set                 set                 set
 285    10 (>)           go                  go                  go
 286    11 ( )           ----                ----                ----
 287    12 (;)           rskip               print               print
 288    13 (&)           amper               amper               syntax_error
 289    l4 (letter)      offsetl             offsetl             syntax_error
 290    15 (nl)          print               print               print
 291    16 (*)           star                star                syntax_error
 292    17 (.)           com                 syntax_error        syntax_error
 293    */
 294 /* ^L */
 295 /*        Initialize data needed to parse the command line.   */
 296 
 297 
 298      com_auto_ptr = arg_auto_ptr;
 299 
 300           com_stat_ptr = arg_stat_ptr;
 301 
 302 
 303           lin = 1;
 304           ill = input_line_len;
 305           ilp = addr (il);
 306           ilp -> str1 = input_buffer_ptr -> str1;
 307 
 308           if first_call_flag = 0
 309 
 310           then do;
 311                data_ptr = stack_ptr_array (max_sp_x);
 312                offset = 0;
 313                stack_depth = max_sp_x;
 314                data_id = "s";
 315                data_format = "h";
 316                input_type = "";
 317                first_call_flag = 1;
 318           end;
 319 
 320           sntp = snt_ptr;
 321           max_stack = max_sp_x;
 322           sb = ptr (stack_ptr_array (max_stack), 0);
 323 
 324 
 325 depth_1:
 326 
 327           if get_char (lin, lin, char) then do;
 328                d_type = 0;
 329                pc = 1;                                      /* default is print one item */
 330                go to label_1 (type (ilp -> bi.ts (lin)));
 331           end;
 332           else goto print;
 333 
 334 /* come here (depth 2) when the procedure name has been established
 335    and associated defaults set up */
 336 
 337 depth_2:
 338           if get_char (lin, lin, char) then do;             /* PL1 bug 1497 */
 339                goto label_2 (type (ilp -> bi.ts (lin)));
 340           end;
 341           else goto print;
 342 
 343 /* come here after the following have been set up
 344    data_ptr
 345    offset
 346    output mode
 347 
 348    must either print out a value (or values), set a break, restart execution,
 349    or assign a value (or values) */
 350 
 351 depth_4:
 352           if get_char (lin, lin, char) then do;             /* PL1 bug 1497 */
 353                goto label_3 (type (ilp -> bi.ts (lin)));
 354           end;
 355           else goto print;
 356                                                             /* ^L */
 357                                                             /* come here if we are at start of a symbolic name */
 358 
 359 label_1 (14):
 360 label_2 (14):
 361 offsetl:
 362           nv = 0;                                           /* initialize depth count */
 363           do i = lin to ill;                                /* scan over variable name */
 364                cmc = substr (il, i, 1);                     /* pick up current character */
 365                j = type (ilp -> bi.ts (i));                 /* get type of current character */
 366                if j = 4 | j = 5 | j = 14 | j = 11 | cmc = "." then go to endl;
 367                if cmc = "(" then nv = nv + 1;
 368                else if cmc = ")" then do;
 369                     if nv > 0 then nv = nv - 1;
 370                end;
 371                else if cmc = "-" then do;
 372                     if substr (il, i+1, 1) = ">" then i = i+1; /* scan over arrow */
 373                     else if nv = 0 then go to donel;        /* done if not in parens */
 374                end;
 375                else if nv = 0 then go to donel;
 376 endl:     end;
 377 donel:
 378           sym_name = substr (il, lin, i-lin);
 379           lin = i;
 380           new_type = 0;
 381           call db_sym (sym_name, sntp, data_ptr, offset, d_type, data_id, data_format, pc, max_size, code);
 382           if data_format ^= "a" & data_format ^= "b" then pc = 1;
 383           if code = 0 then do;                              /* continue if no error */
 384                input_type = "v";
 385                goto relative_offset;
 386           end;
 387           if code > 100 then do;
 388                i = code - 100;                              /* a parameter */
 389                cmc = "?";
 390                go to list_arg;
 391           end;
 392           call sym_err;                                     /* print message and goto rskip */
 393 
 394 /* ^L */
 395 /* come here when a colon is encountered in the scan */
 396 
 397 label_1 (1):
 398           ct = 0;                                           /* no return value */
 399           go to colon_join;
 400 label_2 (1):
 401 label_3 (1):
 402           ct = 1;                                           /* return value requested */
 403 colon_join:
 404           if substr (il, lin+1, 1) ^= "=" then go to syntax_error; /* check for following = */
 405           if ^get_char (lin + 2, lin, "") then goto syntax_error;
 406           do i = lin to ill while (is_name (ilp -> bi.ts (i))); /* skip to end of procedure name */
 407           end;
 408           ent_name = substr (il, lin, i-lin);               /* pick up segment procedure name */
 409           if substr (il, i, 1) = "$" then do;               /* secondary entry point given */
 410                do lin = i+1 to ill while (is_name (ilp -> bi.ts (lin))); /* skip to end of entry name */
 411                end;
 412                ref_name = substr (il, i+1, lin-1-i);        /* copy entry point name */
 413                end; else do;                                /* if no entry point name, use same */
 414                ref_name = ent_name;
 415                lin = i;
 416           end;
 417           call hcs_$make_ptr (null, ent_name, ref_name, tp, code); /* get pointer to the entry */
 418           if code ^= 0 | tp = null then do;
 419                call ioa_$rsnnl ("^a$^a", ent_name, i, ent_name, ref_name);
 420                call com_err_ (code, "debug", ent_name);
 421                go to rskip;
 422           end;
 423 
 424           if ^get_char (lin, lin, "") then goto make_call;
 425           i = 0;
 426           if substr (il, lin, 1) ^= "(" then go to make_call; /* check for no args */
 427           lin = lin + 1;
 428 argl:     i = i + 1;                                        /* go to next arg */
 429           if ct + i > 11 then do;                           /* watch for too many args */
 430                call ioa_$ioa_stream (debug_output, "Too many arguments.");
 431                go to rskip;
 432           end;
 433 
 434           call db_parse_arg (il, lin, ill, addr (dummy_arg (i)), j, exec); /* pick up the next arg */
 435           if substr (il, lin, 1) = "," then lin = lin + 1;  /* skip over "," */
 436           arglist (i+1) = addr (dummy_arg (i));             /* set up default arglist pointer */
 437           if j = 0 then do;                                 /* a variable as the argument */
 438                sym_name = addr (dummy_arg (i)) -> str;      /* get returned symbol name */
 439                call db_sym (sym_name, sntp, pp, temp1, j, c1, c2, pc, max_size, code);
 440                if code = 0 then do;                         /* no error, variable */
 441                     arglist (i+1) = pp ;                    /* stuff pointer to var in arglist */
 442                     exec = pc;
 443                     go to make_desc;
 444                end;
 445                if code > 100 then arglist (i+1) = snt.sp -> stack_frame.arg_ptr -> ptr_array (code - 99);
 446                else call sym_err;
 447           end;
 448           if j > 0 then do;
 449 make_desc:     desc (i).type = bit (binary (j, 6), 6);
 450                desc (i).size = binary (exec, 23);
 451                arglist (i + 11) = addr (desc (i));
 452           end;
 453           else if j = -1 then do;                           /* no arg, all done */
 454                do j = 1 to i-1;                             /* loop through all arguments */
 455                     arglist (j+i+ct) = arglist (11+j);      /* move descriptor pointers down */
 456                end;
 457 make_call:     addr (arglist) -> arg_list.num_args = binary (i+ct-1, 17);
 458                addr (arglist) -> arg_list.num_desc = binary (i+ct-1, 17);
 459                if ct ^= 0 then do;
 460                     arglist (i + 1) = data_ptr;
 461                     arglist (2*i + 1) = addr (return_desc);
 462                end;
 463                addr (arglist) -> arg_list.code = (16) "0"b || "100"b;
 464                addr (arglist) -> arg_list.fill = "0"b;
 465 
 466                in_debug = "0"b;                             /* pass all conditions on */
 467                call cu_$gen_call (tp, addr (arglist));      /* call the specified procedure */
 468                in_debug = "1"b;                             /* turn handler on */
 469                go to skip;
 470           end;
 471           else if j = -2 then do;                           /* syntax error */
 472                call ioa_$ioa_stream (debug_output, "Syntax error in argument ^d.", i);
 473                go to rskip;
 474           end;
 475           else if j = -3 then arglist (i+11) = addr (dummy_desc); /* "%" in arg position */
 476           else call ioa_$ioa_stream (debug_output, "??");
 477           go to argl;
 478 
 479 /* ^L */
 480 /* come here to print out dummy args */
 481 
 482 label_1 (2):
 483           input_type = "%";
 484           nv = db_get_count$dec (il, lin+1, lin);           /* get correct dummy arg */
 485           if nv < 1 | nv > 10 then go to syntax_error;      /* make sure it's valid */
 486           data_ptr = addr (dummy_arg (nv));                 /* set data ptr to point to the dummy arg */
 487           data_format = "h";                                /* set print default to octal */
 488           go to star1;                                      /* merge with indirect code */
 489 
 490 
 491 /* ^L */
 492 /* come here if we are at start of a stack procedure name */
 493 
 494 label_1 (3):
 495 namel:
 496           do i = lin+1 to ill while (substr (il, i, 1) ^= "/");
 497           end;
 498           if i = ill+1 then go to syntax_error;
 499           nv = cv_oct_check_ (substr (il, lin+1, i-lin-1), code);
 500           if code = 0 then do;
 501                if nv < hcs_count then do;                   /* check for hardcore segment number */
 502                     call ioa_$ioa_stream (debug_output, "Hardcore segment number.");
 503                     go to rskip;
 504                end;
 505                pp = baseptr (nv);
 506                call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code);
 507                if code ^= 0 then do;                        /* signaller if trouble */
 508                     ent_name = "signaller";
 509                     dir_name = "signaller_directory";
 510                end;
 511                pathname, entry_name = ent_name;             /* if given number use primary name */
 512           end;
 513           else do;
 514                pathname = substr (il, lin+1, i-lin-1);
 515 
 516 /* find out if it's of form seg$entry */
 517 
 518                dol = index (pathname, "$");
 519                if dol > 0 then do;                          /* it is */
 520                     entry_name = substr (pathname, dol + 1);
 521                     pathname = substr (pathname, 1, dol - 1);
 522                end;
 523                else entry_name = pathname;
 524 
 525                j = index (reverse (entry_name), ">");
 526                if j > 0 then entry_name = substr (entry_name, 32 -j);
 527 
 528                if substr (pathname, 1, 2) = "&n" then do;
 529                     pathname = substr (pathname, 3);
 530                     lin = lin + 2;
 531                end;
 532                call expand_path_ (addr (pathname), i-lin-1, addr (dir_name), addr (ent_name), code);
 533                if code ^= 0 then do;
 534 com1:               call com_err_ (code, "debug", pathname);
 535                     go to rskip;
 536                end;
 537                call hcs_$fs_get_seg_ptr (pathname, pp, code); /* is segment already known ? */
 538                if pp ^= null then do;                       /* yes, get real names for the segment */
 539                     call hcs_$fs_get_path_name (pp, dir_name, itemp, ent_name, code);
 540                     go to check1;
 541                end;
 542                call hcs_$initiate (dir_name, ent_name, "", 0, 0, pp, code); /* no, initiate it */
 543                if code ^= 0 then if code ^= error_table_$segknown then go to com1;
 544           end;
 545 check1:
 546           lin = i+1;
 547           do i = max_stack to 0 by -1;                      /* search the stack for the procedure pointer */
 548                sp = stack_ptr_array (i);                    /* get current stack pointer */
 549                call db_fill_snt$proc_ptr (sp, tpp);
 550                if tpp ^= null ()
 551                then if baseno (pp) = baseno (tpp) then do;  /* we've found a good segment */
 552                          stack_depth = i;                   /* set index into stack */
 553                          call db_fill_snt (sp, sntp);       /* Get data about working segment. */
 554                          if snt.ent_pt_name = entry_name then do; /* make sure it's really right frame */
 555                               data_ptr = sp;                /* set defaults */
 556                               data_id = "s";
 557 found3:                       offset = 0;
 558                               data_format = "h";
 559 
 560                               input_type = "a";
 561                               go to depth_2;
 562                          end;
 563                     end;
 564           end;
 565 
 566           snt.symp = null;
 567           snt.symflag = "1"b;                               /* set flag saying we haven't got symp yet */
 568           snt.pp = pp;
 569           snt.sp = null;
 570           snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (pp))).segno), stack_header.lot_ptr -> lot (binary (baseno (pp))).offset);
 571           snt.ent_name = ent_name;
 572           snt.dir_name = dir_name;
 573           snt.ent_pt_name = entry_name;                     /* use reference name for symbol table */
 574           data_ptr = pp;
 575           stack_depth = -1;                                 /* stack depth is undefined */
 576           data_id = "t";
 577           go to found3;
 578                                                             /* ^L */
 579 
 580 /* come here when a star is encountered */
 581 
 582 label_1 (16):
 583 label_2 (16):
 584           lin = lin+1;
 585           if data_ptr -> its.its_mod ^= "100011"b then do;
 586                call ioa_$ioa_stream (debug_output, "Cannot indirect through ^w ^w.", data_ptr -> ff.w0, data_ptr -> ff.w1);
 587                go to rskip;
 588           end;
 589           data_ptr = data_ptr -> based_ptr;                 /* indirect once through ptr */
 590           input_type = "*";
 591 star1:    offset = binary (rel (data_ptr), 17);             /* set up offset variable */
 592           snt.symp = null;                                  /* fill in snt structure */
 593           snt.symflag = "1"b;
 594           snt.pp = ptr (data_ptr, 0);
 595           snt.sp = null;
 596           snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (data_ptr))).segno), stack_header.lot_ptr -> lot (binary (baseno (data_ptr))).offset);
 597           call hcs_$fs_get_path_name (data_ptr, snt.dir_name, itemp, snt.ent_name, code);
 598           snt.ent_pt_name = snt.ent_name;
 599           stack_depth = -1;
 600           data_id = "t";
 601           go to relative_offset;
 602 
 603 /* come here if a syntax error is encountered while scanning the command line */
 604 
 605 label_1 (0): label_2 (0): label_3 (0): go to syntax_error;
 606 label_2 (2): label_3 (2): go to syntax_error;
 607 label_2 (3): label_3 (3): go to syntax_error;
 608 label_3 (16):
 609 label_2 (17): label_3 (17):
 610 label_3 (4):
 611 label_3 (14):
 612 label_3 (5): label_3 (6):
 613 label_3 (13):
 614 syntax_error: call ioa_$ioa_stream (debug_output, "Syntax error");
 615 
 616 
 617 label_1 (12):
 618 rskip:
 619           db_action_code = 1;
 620           return;
 621 
 622 skip:     i = index (substr (il, lin, ill-lin+1), ";");
 623           if i > 0 then do;
 624                lin = lin + i;
 625                if lin < ill then go to depth_1;
 626           end;
 627           lin = ill;
 628           return;
 629 
 630 
 631 /* ^L */
 632 /*  come here on "."   */
 633 
 634 
 635 label_1 (17):
 636           if lin + 1 >= ill then go to no_comm;
 637           cmc = substr (il, lin+1, 1);
 638           if verify (cmc, "0123456789") = 0 then do;        /* no command name, set stack frame */
 639                stack_depth = db_get_count$dec (il, lin+1, lin); /* pick up desired stack depth */
 640                i = stack_depth;                             /* in case error, set frame to 0 */
 641                go to set_stack;
 642           end;
 643           nv = type (ilp -> bi.ts (lin+2));                 /* get type of character after command */
 644           if cmc = "t" then call stack_trace;
 645           else if cmc = "+" | cmc = "-" then do;            /* pop or push stack */
 646                i = db_get_count$dec (il, lin+1, lin);
 647                stack_depth = stack_depth + i;
 648 set_stack:     if stack_depth < 0 | stack_depth > max_stack then do;
 649                     call ioa_$ioa_stream (debug_output, "^d not in stack range.", stack_depth);
 650                     stack_depth = stack_depth - i;
 651                     go to rskip;
 652                end;
 653                call db_fill_snt (stack_ptr_array (stack_depth), sntp); /* get data for this new frame */
 654                if snt.pp = null () then call ioa_$ioa_stream (debug_output, "Cannot get text section for stack frame.");
 655                data_ptr = snt.sp;
 656                data_id = "s";
 657                data_format = "h";
 658                offset = 0;
 659           end;
 660           else if cmc = "|" | cmc = "." then do;
 661                substr (il, 1, lin+1) = " ";
 662 
 663                in_debug = "0"b;                             /* pass all conditions on */
 664                call cu_$cp (ilp, ill, i);
 665                in_debug = "1"b;
 666                return;
 667           end;
 668           else if cmc = "d" then do;
 669                fboff = binary (addr (data_ptr) -> its.bit_offset, 9);
 670                call ioa_$ioa_stream (debug_output, "^d  /^a/^o(^d)&^a,^a  ^o", stack_depth, snt.ent_name, offset, fboff, data_id, data_format,
 671                     binary (baseno (snt.pp), 18));
 672           end;
 673           else if cmc = "D" then do;
 674                fboff = binary (addr (data_ptr) -> its.bit_offset, 9);
 675                call ioa_$ioa_stream (debug_output, "^d  /^a>^a/^o(^d)&^a,^a  ^o", stack_depth, snt.dir_name, snt.ent_name, offset, fboff,
 676                     data_id, data_format, binary (baseno (snt.pp), 18));
 677           end;
 678           else if cmc = "m" then do;                        /* output mode */
 679                if substr (il, lin+2, 1) = "b" then print_mode = 0;
 680                else if substr (il, lin+2, 1) = "l" then print_mode = 1;
 681                else go to syntax_error;
 682           end;
 683 
 684           else if cmc = "c" then do;
 685                cmc = substr (il, lin+2, 1);                 /* get next character */
 686                if cmc = "t" then do;                        /* into temporary break mode */
 687                     lin = lin + 1;
 688                     temp_break_mode = 1;
 689                end;
 690                else if cmc = "r" then do;                   /* regular break mode */
 691                     lin = lin + 1;
 692                     temp_break_mode = 0;
 693                end;
 694                if substr (il, lin+2, 1) = "," then num_skips = db_get_count$dec (il, lin+3, lin) + 1;
 695                else num_skips = 1;                          /* num_skips is times to skip the break */
 696 
 697                db_action_code = 3;
 698                return;
 699           end;
 700           else if cmc = "q" then do;
 701                db_action_code = 2;
 702                return;
 703           end;
 704           else if cmc = "b" then do;                        /* some type of break command */
 705                i = lin + 2;
 706                cmc = substr (il, i, 1);                     /* get the particular break command name */
 707                if cmc = "g" then do;                        /* global break request */
 708                     cmc = substr (il, i+1, 1);              /* get the command char */
 709                     if cmc = "t" then do;                   /* .bge  set up global exec line */
 710                          i = i + 2;                         /* get index of first character of exec line */
 711                          temp_comd_len = ill-i+1;
 712                          if temp_comd_len = 1 then temp_comd_len = 0;
 713                          else temp_comd_line = substr (il, i, temp_comd_len); /* copy string to execute into static */
 714                          return;                            /* read next request line */
 715                     end;
 716                     lin = i + 2;                            /* point past request type */
 717                     call get_break_action_code;
 718                     if break_action_code = 0
 719                     then goto skip;
 720                     else call db_break$global (break_action_code, break_data_len, break_data_line, print_mode);
 721                     if break_return = 1 then lin = ill;
 722                     goto skip;
 723                end;
 724                if cmc = "d" then do;                        /* change default break segment */
 725                     if ^get_char (i+1, lin, char) then do;
 726                          call db_break$print_default;
 727                          go to skip;
 728                     end;
 729                     pathname = substr (il, lin, ill-lin);   /* get name of segment */
 730                     nv = cv_oct_check_ (pathname, code);    /* see if number was given */
 731                     if code = 0 then do;
 732                          tp = baseptr (nv);                 /* get pointer to break seg */
 733                     end;
 734                     else do;
 735                          if substr (pathname, 1, 2) = "&n" then do;
 736                               pathname = substr (pathname, 3);
 737                               lin = lin + 2;
 738                          end;
 739 
 740                          call expand_path_ (addr (pathname), ill-lin, addr (dir_name), addr (ent_name), code);
 741                          call hcs_$fs_get_seg_ptr (pathname, tp, code);
 742                          if tp ^= null then go to got_seg;  /* if refence name is known */
 743                          call hcs_$initiate (dir_name, ent_name, "", 0, 0, tp, code);
 744                          if tp = null then go to com1;
 745                     end;
 746 got_seg:            call db_break$set_default (tp);         /* set up default seg */
 747                     return;
 748                end;
 749                if cmc = "p" then do;                        /* print break segs */
 750                     call db_break$print_bseg (print_mode);
 751                     go to skip;
 752                end;
 753                if ^get_char (i + 1, i, "") then do;
 754                     lin = i;
 755                     call get_break_action_code;
 756                     if break_action_code > 0 then do;
 757                          call db_break$sub_global (break_action_code, break_data_len, break_data_line, print_mode);
 758                          if break_return > 0 then lin = ill;
 759                     end;
 760 
 761                     goto skip;
 762                end;
 763                nv = db_get_count$dec (il, i, lin);          /* Get break number. */
 764                if nv <= 0 then do;                          /* and make sure it's okay */
 765                     call ioa_$ioa_stream (debug_output, "Invalid break number.");
 766                     go to rskip;
 767                end;
 768 
 769                if cmc = "s" then do;
 770                     i = db_get_count$dec (il, lin+1, lin);
 771                     call db_break$set_skips (nv, i);
 772                     go to skip;
 773                end;
 774                call get_break_action_code;
 775                if break_action_code = 0
 776                then goto skip;
 777                else call db_break$single (nv, break_action_code, break_data_len, break_data_line, print_mode);
 778                if break_return = 1 then lin = ill;
 779                goto skip;
 780           end;
 781                                                             /* ^L */
 782           else if cmc = "a" then do;
 783                if snt.sp = null then do;                    /* must have stack frame for arglist print out */
 784 nost:               call ioa_$ioa_stream (debug_output, "No argument list available.");
 785                     go to rskip;
 786                end;
 787                if snt.sp -> stack_frame.prev_sp -> stack_frame_flags.signaller then go to nost;
 788                if snt.sp -> stack_frame.arg_ptr = null () then go to nost;
 789                if nv = 7 then do;                           /* if comma, use mode specified and do all args */
 790                     cmc = substr (il, lin+3, 1);
 791                     i = -1;
 792                end;
 793                else if nv = 5 | nv = 13 then do;
 794                     i = db_get_count$dec (il, lin+2, lin);
 795                     if substr (il, lin, 1) = "," then cmc = substr (il, lin+1, 1);
 796                     else cmc = "?";
 797                end;
 798                else if nv = 12 | nv = 15 then do;
 799                     i = -1;
 800                     cmc = "?";
 801                end;
 802 list_arg:      call list_arg_ (i, cmc, snt.sp -> stack_frame.arg_ptr);
 803           end;
 804           else if cmc = "f"                                 /* get pointer to fault conditions */
 805           then call db_find_mc (snt.sp, "0"b, db_mc_ptr);
 806 
 807           else if cmc = "C"                                 /* get pointer to crawlout conditions */
 808           then call db_find_mc (snt.sp, "1"b, db_mc_ptr);
 809 
 810 
 811           else if cmc = "s" then do;
 812                attach, open = "0"b;
 813                if substr (il, lin+2, 1) = "i" then j = 1;
 814                else if substr (il, lin+2, 1) = "o" then j = 2;
 815                else go to skip;
 816                lin = lin + 3;
 817                i = verify (substr (il, lin, ill-lin+1), " ");
 818                if i > 1 then do;
 819                     lin = lin + i - 1;
 820 
 821                     i = search (substr (il, lin, ill-lin+1), " ;
 822 ");
 823                     if i = 0 then i = ill;
 824                     else i = lin + i -2;
 825                     switch_name = substr (il, lin, i-lin+1);
 826                     call check_switch;
 827                     call iox_$find_iocb (switch_name, pp, code35);
 828                     if code35 ^= 0 then goto switch_err;
 829                     if pp -> iocb.attach_descrip_ptr = null then do;
 830                          call ioa_$ioa_stream (debug_output, "^a switch not attached", switch_name);
 831                          goto skip;
 832                     end;
 833                     if pp -> iocb.open_descrip_ptr = null then do;
 834                          call ioa_$ioa_stream (debug_output, "^a switch not open", switch_name);
 835                          goto skip;
 836                     end;
 837                end;
 838                else do;
 839                     if j = 1 then switch_name = "debug_input";
 840                     else switch_name = "debug_output";
 841                     call check_switch;                      /* Is this the same switch? */
 842                     call iox_$find_iocb (switch_name, pp, code35);
 843                     if code35 ^= 0 then go to switch_err;
 844                     if pp -> iocb.attach_descrip_ptr = null then do;
 845                          call iox_$attach_ioname (switch_name, pp, "syn_ user_i/o", code35);
 846                          if code35 ^= 0 then go to switch_err;
 847                          attach = "1"b;
 848                     end;
 849 
 850                     if pp -> iocb.open_descrip_ptr = null then do;
 851                          call iox_$open (pp, j, "0"b, code35);
 852                          if code35 ^= 0 then go to switch_err;
 853                          open = "1"b;
 854                     end;
 855                end;
 856 
 857                if debug_io_open (j) then call iox_$close (debug_io_ptr (j), code35);
 858                if debug_io_attach (j) then call iox_$detach_iocb (debug_io_ptr (j), code35);
 859                debug_io_ptr (j) = pp;
 860                debug_io_attach (j) = attach;
 861                debug_io_open (j) = open;
 862                if j = 1 then debug_input = switch_name;
 863                else debug_output = switch_name;
 864 
 865                go to skip;
 866 
 867 switch_err:    call com_err_ (code35, "debug");
 868                go to skip;
 869           end;
 870 
 871           else
 872 no_comm:  call ioa_$ioa_stream (debug_output, "db");
 873 
 874           go to skip;
 875 
 876 /* ^L */
 877 /* come here if we are looking at a register command */
 878 
 879 label_1 (4):
 880           do i = lin+1 to lin+4 while (is_name (ilp -> bi.ts (i)));
 881           end;
 882           reg_name = substr (il, lin+1, i-lin-1);
 883           do i = lin+1 to ill while (substr (il, i, 1) ^= ";" & substr (il, i, 1) ^= "=");
 884           end;
 885           if i >= ill | substr (il, i, 1) ^= "=" then do;
 886                if ill = lin + 1 then if substr (il, ill, 1) = new_line then goto syntax_error; /* avoid "$(nl)" */
 887                call db_regs$print (db_mc_ptr, reg_name, print_mode);
 888                go to skip;
 889           end;
 890           if ^get_char (i + 1, i, "") then goto syntax_error;
 891           temp_reg_val = db_get_count$double (il, i, lin);  /* is an assignment */
 892           if i = lin then goto syntax_error;
 893           if substr (il, lin, 1) = "|" then do;             /* pointer value, parse it */
 894                call db_parse_arg$ptr_offset (il, lin, ill, binary (temp_reg_val, 17),
 895                     addr (temp_reg_val), d_type, nv);
 896                if d_type ^= 13 then go to syntax_error;
 897           end;
 898 
 899           reg_val = addr (temp_reg_val) -> based_bit72;
 900           call db_regs$assign (db_mc_ptr, reg_name, reg_val, print_mode); /* assign a value to the register */
 901           go to skip;
 902 
 903 /* ^L */
 904 /* . handlers */
 905 
 906 label_1 (13): label_2 (13):
 907           cmc = substr (il, lin+1, 1);
 908           if lin >= ill then go to syntax_error;
 909           if cmc = "d" | cmc = "o" then go to offset1;
 910           if cmc = "n" then do;                             /* next char escaped */
 911                lin = lin+2;
 912                go to offsetl;
 913           end;
 914           if cmc ^= data_id then new_type = 1; else new_type = 0;
 915           goto relative_offset;
 916 
 917 
 918 /* ^L */
 919 /* come here to set a break point */
 920 
 921 label_1 (9): label_2 (9): label_3 (9):
 922           if data_id = "s" then tp = ptr (snt.pp, binary (rel (data_ptr))-binary (rel (snt.sp)));
 923           else tp = data_ptr;                               /* force pointer to text if in stack */
 924           call db_break$set_break (tp, 0, sntp, print_mode); /* set the break */
 925           go to skip;
 926 
 927 /* ^L */
 928 /* come here when restarting a program */
 929 
 930 label_1 (10): label_2 (10): label_3 (10):
 931           if stack_depth > max_stack | stack_depth < 0 then call ioa_$ioa_stream (debug_output, "No stack frame for given segment.");
 932           else do;
 933                addr (goto_label) -> label_map.pp = data_ptr;
 934                addr (goto_label) -> label_map.sp = snt.sp;
 935                goto goto_label;
 936           end;
 937           go to rskip;
 938 
 939 
 940 /* come here if scanning a number in a type 1 command */
 941 
 942 label_1 (5):
 943           input_type = "a";                                 /* user typed an offset */
 944 offset1:  offset = 0;
 945           goto relative_offset;
 946 
 947 /* ^L */
 948 /* come here when 'offset' has been established.  Search for an optional relative offset */
 949 
 950 label_2 (4): label_2 (5):
 951 label_1 (6): label_2 (6):
 952 relative_offset:
 953 
 954           code = 0;
 955           continue = "1"b;
 956           do while (code = 0 & continue);
 957                if ^get_char (lin, lin, char) then continue = "0"b;
 958                else do;
 959 
 960                     if char = "&" then do;
 961                          char = substr (il, lin+1, 1);
 962                          if char = "d" | char = "o" then do;
 963                               offset = offset + db_get_count (il, lin, lin);
 964                               call set_data_ptr (data_id);
 965                          end;
 966                          else do;
 967                               if char ^= data_id then new_type = 1;
 968                               else new_type = 0;
 969                               if new_type = 1 then data_format = "h";
 970                               if char = "p" then call parse_parameter (lin, code);
 971                               else if char = "a" then call parse_source (lin, code);
 972                               else if char = "n" then do;
 973                                    lin = lin +2;
 974                                    if lin >= ill then goto syntax_error;
 975                                    goto namel;
 976                               end;
 977                               else do;
 978                                    call set_data_ptr (char);
 979                                    if code = 0 then data_id = char;
 980                                    lin = lin +2;
 981                               end;
 982                          end;
 983                     end;
 984 
 985                     else do;
 986                          if char = "+" then offset_incr = db_get_count (il, lin + 1, lin);
 987                          else if char = "-" then offset_incr = - db_get_count (il, lin + 1, lin);
 988                          else if verify (char, NUMBER) = 0 then offset_incr = db_get_count (il, lin, lin);
 989 
 990                          else if char = "$" then do;
 991                               do i = lin+1 to lin+4 while (is_name (ilp -> bi.ts (i)));
 992                               end;
 993                               reg_name = substr (il, lin+1, i-lin-1);
 994                               lin = i;
 995                               call db_regs$get (db_mc_ptr, reg_name, reg_val, print_mode);
 996                               offset_incr = binary (reg_val);
 997                          end;
 998 
 999                          else continue = "0"b;              /* must not be a relative offset */
1000                          if continue then do;
1001                               offset = offset + offset_incr;
1002                               call set_data_ptr (data_id);
1003                          end;
1004                     end;
1005                end;
1006           end;
1007 
1008           if code ^= 0 then do;
1009                if code > 0 then call ioa_$ioa_stream (debug_output, "^a for ^a", err_mess (code), snt.ent_name);
1010                goto rskip;
1011           end;
1012 
1013           go to depth_4;
1014 
1015 
1016 /* come here if changing output mode :  , [print mode] [amount to print] */
1017 
1018 label_1 (7): label_2 (7): label_3 (7):
1019 
1020           call parse_print;
1021           goto print;
1022 
1023 label_2 (12): label_3 (12):
1024 label_1 (15): label_2 (15): label_3 (15):
1025 print:
1026           if data_format = "n" then go to skip;
1027           pp = data_ptr;
1028           if data_id = "s" then nv = binary (rel (pp)) - binary (rel (snt.sp));
1029           else if data_id = "l" then nv = binary (rel (pp)) - binary (rel (snt.lp));
1030           else if data_id = "i" then nv = binary (rel (pp)) - binary (rel (snt.static_ptr));
1031           else nv = binary (rel (pp));
1032 
1033           call db_print (debug_io_ptr (2), debug_output, pp, data_format, nv, pc, sntp, d_type, max_size);
1034           go to skip;
1035 
1036 /* come here when an equal sign is encountered */
1037 
1038 label_1 (8): label_2 (8): label_3 (8):
1039           lin = lin + 1;
1040           pp = data_ptr;
1041 
1042 /*        If the assignment is not to a program variable the default is octal.
1043    */
1044           if input_type = "v" then dec_default = "1"b;
1045           else dec_default = "0"b;
1046           call db_assign (il, lin, ill, pp, sntp, db_mc_ptr, d_type, pc, max_size, print_mode, dec_default);
1047           go to skip;
1048 
1049 
1050 /* ^L INTERNAL PROCEDURES */
1051 is_name:  proc (b9) returns (bit (1) aligned);
1052 
1053 dcl  b9 fixed bin (8) unal, t fixed bin;
1054 
1055                t = type (b9);
1056                if t ^= 14 then if t ^= 5 then return ("0"b);
1057                return ("1"b);
1058 
1059           end;
1060                                                             /* ^L */
1061 get_break_action_code: proc;
1062 
1063                break_data_len,
1064                     break_action_code,
1065                     break_return = 0;
1066                break_data_line = " ";
1067 
1068 
1069                if cmc = "l" then break_action_code = 1;
1070 
1071                else if cmc = "r" then break_action_code = 2;
1072 
1073                else if cmc = "o" then break_action_code = 3;
1074 
1075                else if cmc = "n" then break_action_code = 4;
1076 
1077                else if cmc = "e"
1078                then do;
1079                     break_action_code = 5;
1080                     break_data_len = ill-lin+1;
1081                     if break_data_len = 1 then break_data_len = 0;
1082                     else break_data_line = substr (il, lin, break_data_len);
1083                     break_return = 1;
1084                end;
1085 
1086                else if cmc = "c"
1087                then do;
1088                     break_action_code = 6;
1089                     call db_parse_condition$set (il, lin, ill, break_data_len, break_data_line, code);
1090                     if code = 100 then goto syntax_error;
1091                     if code ^= 0 then call ioa_$ioa_stream (debug_output, "Symbol error in conditional break.");
1092                end;
1093 
1094                else call ioa_$ioa_stream (debug_output, "Unknown break request");
1095           end get_break_action_code;
1096 
1097 type:     proc (n) returns (fixed bin);
1098 
1099 dcl  n fixed bin (8) unal;
1100 dcl  table (0: 127) fixed bin static init
1101     ((10)0, 15, (21)0, 11, 0, 14, 0, 4, 2, 13, (3)0, 16, 6, 7, 6, 17, 3, (10)5, 1,
1102      12, 9, 8, 10, (2)0, (26)14, (4)0, 14, 0, (26)14, 0, 17, (3)0);
1103 
1104 /* The table array has the following meaning:
1105    0 = illegal
1106    1 = :
1107    2 = %
1108    3 = /
1109    4 = $
1110    5 = number
1111    6 = + or -
1112    7 = ,
1113    8 = =
1114    9 = <
1115    10 = >
1116    11 = blank
1117    12 = ;
1118    13 = &
1119    14 = letter
1120    15 = new-line
1121    16 = *
1122    17 = | or . */
1123 
1124                if n > -1 then if n < 128 then return (table (n)); /* legal ascii value */
1125                call ioa_$ioa_stream (debug_output, "invalid character ""^a""", substr (il, n, 1));
1126                go to rskip;                                 /* error return */
1127 
1128           end type;
1129 
1130 
1131 check_switch: proc;
1132 
1133 /*        This procedure compares the old switch name and the new switch name.  If they are the same
1134    *      a message is printed and the procedure exits to skip which looks for the next request.
1135    */
1136                     if j = 1 then if switch_name ^= debug_input then return; else;
1137                else if switch_name ^= debug_output then return;
1138                call ioa_$ioa_stream (debug_output, "Switch already set to ^a", switch_name);
1139                goto skip;
1140 
1141           end check_switch;
1142 
1143 /*  This procedure prints the error message for db_sym and exits to rskip to
1144    *   find the next db request.
1145 */
1146 
1147 sym_err:  proc;
1148 
1149 dcl  mess char (80) var;
1150 
1151                mess = "";
1152                if code = 1 then mess = "Symbol " || sym_name || " not found for " || snt.ent_name;
1153                else if code = 2 then mess = "No symbol table for " || snt.ent_name;
1154                else if code = 3 then mess = "No linkage section for " || snt.ent_name;
1155                else if code = 4 then mess = "No stack frame for " || snt.ent_name;
1156                else if code = 5 then mess = "Cannot get address of " || sym_name;
1157                else if code = 6 then mess = "Cannot get size of " || sym_name;
1158                else if code = 7 then go to syntax_error;
1159                else if code = 8 then mess = "Subscripting error in " || sym_name;
1160                else if code = 9 then mess = "Invalid subscript in " || sym_name;
1161                else if code = 10 then mess = "Based variable error in " || sym_name;
1162                else if code = 11 then mess = "Too many structure levels in " || sym_name;
1163                else if code = 12 then mess = "Symbol is too long " || sym_name;
1164                else if code = 13 then mess = "Reference is ambiguous " || sym_name;
1165                else if code = 14 then mess = sym_name || " is entry constant; not supported";
1166                else if code = 15 then mess = "Symbol table for this language is not supported by debug.";
1167 
1168                if mess ^= "" then call ioa_$ioa_stream (debug_output, mess);
1169                go to rskip;
1170 
1171           end sym_err;
1172 
1173 /*  This procedure searches for the next non-blank character in the line beginning with index.
1174    It returns "0"b if the rest of the line is blank.  Otherwise it returns "1"b, the index and the character
1175    found.
1176 */
1177 get_char: proc (index_in, index_out, char_out) returns (bit (1));
1178 
1179 dcl  index_in fixed bin;
1180 dcl  index_out fixed bin;
1181 dcl  char_out char (1) aligned;
1182 dcl  i fixed bin;
1183 
1184                index_out = index_in;
1185                if index_out < ill then do;
1186                     i = verify (substr (il, index_out, ill - index_out +1), " ");
1187 
1188                     if i > 0 then do;
1189                          index_out = index_out + i -1;
1190                          char_out = substr (il, index_out, 1);
1191                          if char_out ^= ";" & char_out ^= new_line then return ("1"b);
1192                     end;
1193                     else index_out = ill;
1194                end;
1195 
1196                return ("0"b);
1197 
1198           end get_char;
1199 
1200 /* ^L */
1201 
1202 parse_print: proc;
1203 
1204 dcl  i fixed bin;
1205 dcl  size fixed bin;
1206 dcl (have_mode, have_size, have_count) bit (1);
1207 
1208                have_mode, have_size, have_count = "0"b;
1209 
1210                do while (get_char (lin+1, lin, char));
1211 
1212 /* (<size>)  */
1213                     if char = "(" then do;
1214                          if ^have_size then do;
1215                               have_size = "1"b;
1216                               i = db_get_count$dec (il, lin+1, lin);
1217                               if i > 0 then do;
1218                                    if get_char (lin, lin, char) then do;
1219                                         if char = ")" then do;
1220                                              size = i;
1221                                              goto next;
1222                                         end;
1223                                    end;
1224                               end;
1225                          end;
1226                          goto syntax_error;
1227                     end;
1228 
1229 /* <amount to print>  */
1230                     else if index (NUMBER, char) > 0 then do;
1231                          if have_count then goto syntax_error;
1232                          pc = db_get_count$dec (il, lin, lin);
1233                          pc = max (pc, 1);
1234                          have_count = "1"b;
1235                          lin = lin -1;
1236                     end;
1237 
1238 /* <mode>   Set mode and default size.  A change in mode causes the amount to print to be set to 1 */
1239                     else do;
1240                          if substr (il, lin, 1) = "n" then goto skip;
1241                          do i = 1 to hbound (MODES, 1)
1242                                    while (substr (il, lin, length (MODES (i))) ^= MODES (i));
1243                          end;
1244                          if i > hbound (MODES, 1) then do;
1245                               call ioa_$ioa_stream (debug_output, "Undefined output mode ""^a""", substr (il, lin, 1));
1246                               goto rskip;
1247                          end;
1248                          data_format = MODES (i);
1249                          lin = lin + length (MODES (i)) -1;
1250                          if data_format = "p" then max_size = 72;
1251                          else if data_format = "comp-7" then max_size = 18;
1252                          else if data_format = "el" | data_format = "fl" then max_size = 72;
1253                          else max_size = 36;
1254                          if ^have_count then pc = 1;
1255                     end;
1256 next:
1257                end;
1258 
1259 /* data_format and pc have been set.  Only set size if it is valid.  */
1260 
1261                if have_size then do;
1262                     if data_format = "p" & ^(size = 36 | size = 72) then do;
1263                          call ioa_$ioa_stream (debug_output, "Invalid size for pointer.  Use 36 or 72");
1264                          goto rskip;
1265                     end;
1266                     else if data_format = "comp-8" | data_format = "comp-5" then max_size = divide (size*9, 2, 17, 0);
1267                     else max_size = size;
1268                end;
1269           end parse_print;
1270 
1271 /* ^L */
1272 /*  This procedure parses &p requests and sets the data_ptr and offset and pc (data size).
1273    code = 0                             Pointer was found to the argument.
1274    code = err_no_stack                  No stack frame, so no parameter list.
1275    code = -1                            Illegal number for argument poaition.
1276 
1277    index                      (input) Set to start of string "&p"
1278    (output) Set to first character not used in parse
1279 */
1280 parse_parameter: proc (index, code);
1281 
1282 dcl  index fixed bin;
1283 dcl  code fixed bin;
1284 
1285                i = db_get_count$dec (il, index+2, index);
1286                if snt.sp = null then code = err_no_stack;
1287                else do;
1288                     if snt.sp -> stack_frame.arg_ptr = null then code = err_no_stack;
1289                     else do;
1290                          if i <= 0 | i > binary (snt.sp -> stack_frame.arg_ptr -> arg_list.num_args, 17) then do;
1291                               call ioa_$ioa_stream (debug_output, "No parameter ^d.", i);
1292                               code = -1;                    /* no error message, but error return */
1293                          end;
1294                          else do;
1295                               call decode_descriptor_ (snt.sp -> stack_frame.arg_ptr, i, code, switch, ndims, size, scale);
1296                               data_ptr = snt.sp -> stack_frame.arg_ptr -> arg_list.args (i);
1297                               offset = binary (rel (data_ptr), 18);
1298                                                             /* COBOL data codes */
1299                               if code = 38 | code = 39 | code = 41 then do;
1300                                    pc = 1;
1301                                    if code = 41 then data_format = "comp-8";
1302                                    else data_format = "comp-5";
1303                                    if code = 38 then size = divide (size*9, 2, 17, 0);
1304                                    else size = divide ((size+1)*9, 2, 17, 0);
1305                               end;
1306                               else if code > 0 then do;
1307                                    data_format = substr ("dhffdhfhhhhhphpphbbaah", code, 1); /* decode type into mode */
1308                                    if code = 2 then pc = 2; /* if double precision fixed point */
1309                                    else if code = 5 then pc = 2; /* complex fixed short */
1310                                    else if code = 7 then pc = 2; /* complex float short */
1311                                    else if code = 15 then pc = 2; /* label variable */
1312                                    else if code = 16 then pc = 2; /* entry variable */
1313                                    else if data_format = "a" then do;
1314                                         if code = 22 then pc = max (0, addrel (data_ptr, -1) -> based_fix);
1315                                         else pc = size;
1316                                    end;
1317                                    else if data_format = "b" then if code = 19 then pc = size;
1318                                         else pc = max (0, addrel (data_ptr, -1) -> based_fix);
1319                                    data_id = "p";
1320                               end;
1321                               code = 0;
1322                          end;
1323                     end;
1324                end;
1325                return;
1326 
1327           end parse_parameter;
1328                                                             /* ^L */
1329                                                             /*  This procedure sets offset and data_ptr to the text beginning at a given source line.
1330                                                                code = 0                   Was able to set the pointer to object code for line number.
1331 
1332                                                                data_ptr  = location of first instruction on the line.
1333                                                                data_format = "s"   (db_print mode for source code )
1334                                                                data_id   = "t"   (segment_ID is &t for text )
1335 
1336                                                                code = no_sym_tab          The procedure was not compiled with the table option.
1337                                                                code = -1                  No code generated for 10 lines after the line number requested.
1338                                                                */
1339 parse_source: proc (index, code);
1340 
1341 dcl  index fixed bin;
1342 dcl  code fixed bin;
1343 
1344                line_number = db_get_count$dec (il, index+2, index);
1345                if snt.symflag then call db_get_sym (sntp);
1346                tp = snt.symp;                               /* get pointer to symbol table */
1347                if (^snt.std & tp = null) | snt.headp = null then code = err_no_sym_tab;
1348                else do;
1349                     switch = "0"b;
1350                     do line_number = line_number to line_number + 10 while (code = 0);
1351                          if snt.std then offset = stu_$get_runtime_location (snt.headp, line_number);
1352                          else call stu_$get_location (snt.symp, line_number, offset);
1353                          if offset = -2 then code = err_no_sym_tab;
1354                          else do;
1355                               if offset >= 0 then do;       /* if positive offset, ok */
1356                                    data_id = "t";
1357                                    data_ptr = ptr (snt.pp, offset);
1358                                    data_format = "s";
1359                                    if switch then call ioa_$ioa_stream (debug_output, "Using line number ^d.", line_number);
1360                                    return;
1361                               end;
1362                               else switch = "1"b;
1363                          end;
1364                     end;
1365                     if code = 0 then do;
1366                          code = -1;
1367                          call ioa_$ioa_stream (debug_output, "debug: No code generated for 10 lines after ^d.", line_number - 11);
1368                     end;
1369                end;
1370 
1371                return;
1372 
1373           end parse_source;
1374                                                             /* ^L */
1375 set_data_ptr: proc (segment_id);
1376 
1377 dcl  segment_id char (1) aligned;
1378 
1379                if segment_id = "t" then data_ptr = ptr (snt.pp, offset);
1380                else if segment_id = "s" then do;
1381                     if snt.sp = null then code = err_no_stack;
1382 
1383                     else do;
1384                          data_ptr = addrel (snt.sp, offset);
1385                     end;
1386 
1387                end;
1388                else if segment_id = "l" then do;
1389                     if snt.pp = null () then code = err_no_linkage;
1390                     else do;
1391                          snt.lp = ptr (baseptr (stack_header.lot_ptr -> lot (binary (baseno (snt.pp))).segno),
1392                               stack_header.lot_ptr -> lot (binary (baseno (snt.pp))).offset);
1393                          if rel (snt.lp) = "0"b then code = err_no_linkage;
1394                          else do;
1395                               data_ptr = addrel (snt.lp, offset);
1396                          end;
1397                     end;
1398                end;
1399 
1400                else if segment_id = "i" then do;
1401                     if snt.pp = null () then code = err_no_static;
1402                     else do;
1403                          snt.static_ptr = ptr (baseptr (stack_header.isot_ptr -> lot (binary (baseno (snt.pp))).segno),
1404                               stack_header.isot_ptr -> lot (binary (baseno (snt.pp))).offset);
1405                          if rel (snt.static_ptr) = "0"b then code = err_no_static;
1406                          else do;
1407                               data_ptr = addrel (snt.static_ptr, offset);
1408                          end;
1409                     end;
1410                end;
1411 
1412                else do;
1413                     call ioa_$ioa_stream (debug_output, "bad segment ID ""^a""", segment_id);
1414                     code = -1;
1415                end;
1416           end set_data_ptr;
1417 
1418 /* ^L */
1419 /* * This procedure parses the trace stack request.
1420    *      .tN,M     where N is the number of the first frame to print and M is the number of frames to be printed.
1421    *
1422    * It uses global variables:
1423    *      lin       input     = index of "." on line
1424    *                output    = index of last character used for trace stack request
1425 */
1426 stack_trace: proc ();
1427 
1428 dcl (i, start, last) fixed bin;
1429 dcl  ent_name char (32) aligned;
1430 dcl 1 trace_snt aligned like snt;
1431 dcl  trace_snt_ptr ptr;
1432 
1433                trace_snt_ptr = addr (trace_snt);
1434                start = 0;
1435                last = max_stack;
1436 
1437                lin = lin + 2;
1438                if verify (substr (il, lin, 1), NUMBER) = 0 then start = db_get_count$dec (il, lin, lin);
1439                if substr (il, lin, 1) = "," then last = start + db_get_count$dec (il, lin+1, lin) -1;
1440                start = max (0, start);
1441                start = min (start, max_stack);
1442                last = min (last, max_stack);
1443 
1444                if print_mode = 1
1445                then call ioa_$ioa_stream (debug_output, "^/DEPTH  SEGNO  OFFSET  ^5xNAME^20xCONDITION^/");
1446 
1447                do i = start to last;
1448                     call db_fill_snt (stack_ptr_array (i), trace_snt_ptr); /* get data for this stack frame */
1449                     if is_condition_frame_ (trace_snt.sp) then do;
1450                          call find_condition_info_ (trace_snt.sp, addr (cond_info), code);
1451                          ent_name = cond_info.condition_name;
1452                     end;
1453                     else ent_name = "";
1454                     call ioa_$ioa_stream (debug_output, " ^4d  ^5o  ^6o  ^a|^o^2-^a",
1455                          i, binary (baseno (trace_snt.pp), 15), binary (rel (trace_snt.sp), 18),
1456                          trace_snt.ent_pt_name, binary (rel (trace_snt.pp), 18), ent_name);
1457                end;
1458 
1459           end stack_trace;
1460 
1461      end db_parse;