1
2
3
4
5
6
7
8
9
10
11 db_parse: procedure (input_buffer_ptr, input_line_len, arg_auto_ptr, arg_stat_ptr);
12
13
14
15
16
17
18
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
30
31 dcl (data_ptr ptr,
32 offset fixed bin (18),
33 stack_depth fixed bin,
34 data_id char (1) aligned,
35 input_type char (1) aligned,
36
37
38
39
40
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",
66 "no stack frame",
67 "no symbol table",
68 "no internal 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;
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;
181
182 dcl (attach,
183 open) bit (1) unaligned;
184 dcl dec_default bit (1);
185 dcl switch_name char (32);
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);
204
205 dcl return_desc bit (36) aligned static init
206 ("100000100000000000000000000000000001"b);
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;
220
221
222 dcl 1 lot (0: 1023) aligned based,
223 2 segno bit (18) unaligned,
224 2 offset bit (18) unaligned;
225
226
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
257 %include db_common_auto;
258
259 %include db_common_static;
260
261 %include db_snt;
262
263 %include db_arg_list;
264
265 %include its;
266
267 %include stack_header;
268 %include stack_frame;
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
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;
330 go to label_1 (type (ilp -> bi.ts (lin)));
331 end;
332 else goto print;
333
334
335
336
337 depth_2:
338 if get_char (lin, lin, char) then do;
339 goto label_2 (type (ilp -> bi.ts (lin)));
340 end;
341 else goto print;
342
343
344
345
346
347
348
349
350
351 depth_4:
352 if get_char (lin, lin, char) then do;
353 goto label_3 (type (ilp -> bi.ts (lin)));
354 end;
355 else goto print;
356
357
358
359 label_1 (14):
360 label_2 (14):
361 offsetl:
362 nv = 0;
363 do i = lin to ill;
364 cmc = substr (il, i, 1);
365 j = type (ilp -> bi.ts (i));
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;
373 else if nv = 0 then go to donel;
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;
384 input_type = "v";
385 goto relative_offset;
386 end;
387 if code > 100 then do;
388 i = code - 100;
389 cmc = "?";
390 go to list_arg;
391 end;
392 call sym_err;
393
394
395
396
397 label_1 (1):
398 ct = 0;
399 go to colon_join;
400 label_2 (1):
401 label_3 (1):
402 ct = 1;
403 colon_join:
404 if substr (il, lin+1, 1) ^= "=" then go to syntax_error;
405 if ^get_char (lin + 2, lin, "") then goto syntax_error;
406 do i = lin to ill while (is_name (ilp -> bi.ts (i)));
407 end;
408 ent_name = substr (il, lin, i-lin);
409 if substr (il, i, 1) = "$" then do;
410 do lin = i+1 to ill while (is_name (ilp -> bi.ts (lin)));
411 end;
412 ref_name = substr (il, i+1, lin-1-i);
413 end; else do;
414 ref_name = ent_name;
415 lin = i;
416 end;
417 call hcs_$make_ptr (null, ent_name, ref_name, tp, code);
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;
427 lin = lin + 1;
428 argl: i = i + 1;
429 if ct + i > 11 then do;
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);
435 if substr (il, lin, 1) = "," then lin = lin + 1;
436 arglist (i+1) = addr (dummy_arg (i));
437 if j = 0 then do;
438 sym_name = addr (dummy_arg (i)) -> str;
439 call db_sym (sym_name, sntp, pp, temp1, j, c1, c2, pc, max_size, code);
440 if code = 0 then do;
441 arglist (i+1) = pp ;
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;
454 do j = 1 to i-1;
455 arglist (j+i+ct) = arglist (11+j);
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;
467 call cu_$gen_call (tp, addr (arglist));
468 in_debug = "1"b;
469 go to skip;
470 end;
471 else if j = -2 then do;
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);
476 else call ioa_$ioa_stream (debug_output, "??");
477 go to argl;
478
479
480
481
482 label_1 (2):
483 input_type = "%";
484 nv = db_get_count$dec (il, lin+1, lin);
485 if nv < 1 | nv > 10 then go to syntax_error;
486 data_ptr = addr (dummy_arg (nv));
487 data_format = "h";
488 go to star1;
489
490
491
492
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;
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;
508 ent_name = "signaller";
509 dir_name = "signaller_directory";
510 end;
511 pathname, entry_name = ent_name;
512 end;
513 else do;
514 pathname = substr (il, lin+1, i-lin-1);
515
516
517
518 dol = index (pathname, "$");
519 if dol > 0 then do;
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);
538 if pp ^= null then do;
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);
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;
548 sp = stack_ptr_array (i);
549 call db_fill_snt$proc_ptr (sp, tpp);
550 if tpp ^= null ()
551 then if baseno (pp) = baseno (tpp) then do;
552 stack_depth = i;
553 call db_fill_snt (sp, sntp);
554 if snt.ent_pt_name = entry_name then do;
555 data_ptr = sp;
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;
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;
574 data_ptr = pp;
575 stack_depth = -1;
576 data_id = "t";
577 go to found3;
578
579
580
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;
590 input_type = "*";
591 star1: offset = binary (rel (data_ptr), 17);
592 snt.symp = null;
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
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
632
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;
639 stack_depth = db_get_count$dec (il, lin+1, lin);
640 i = stack_depth;
641 go to set_stack;
642 end;
643 nv = type (ilp -> bi.ts (lin+2));
644 if cmc = "t" then call stack_trace;
645 else if cmc = "+" | cmc = "-" then do;
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);
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;
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;
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);
686 if cmc = "t" then do;
687 lin = lin + 1;
688 temp_break_mode = 1;
689 end;
690 else if cmc = "r" then do;
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;
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;
705 i = lin + 2;
706 cmc = substr (il, i, 1);
707 if cmc = "g" then do;
708 cmc = substr (il, i+1, 1);
709 if cmc = "t" then do;
710 i = i + 2;
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);
714 return;
715 end;
716 lin = i + 2;
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;
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);
730 nv = cv_oct_check_ (pathname, code);
731 if code = 0 then do;
732 tp = baseptr (nv);
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;
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);
747 return;
748 end;
749 if cmc = "p" then do;
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);
764 if nv <= 0 then do;
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
782 else if cmc = "a" then do;
783 if snt.sp = null then do;
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;
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"
805 then call db_find_mc (snt.sp, "0"b, db_mc_ptr);
806
807 else if cmc = "C"
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;
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
877
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;
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);
892 if i = lin then goto syntax_error;
893 if substr (il, lin, 1) = "|" then do;
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);
901 go to skip;
902
903
904
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;
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
919
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;
924 call db_break$set_break (tp, 0, sntp, print_mode);
925 go to skip;
926
927
928
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
941
942 label_1 (5):
943 input_type = "a";
944 offset1: offset = 0;
945 goto relative_offset;
946
947
948
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;
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
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
1037
1038 label_1 (8): label_2 (8): label_3 (8):
1039 lin = lin + 1;
1040 pp = data_ptr;
1041
1042
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
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
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
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124 if n > -1 then if n < 128 then return (table (n));
1125 call ioa_$ioa_stream (debug_output, "invalid character ""^a""", substr (il, n, 1));
1126 go to rskip;
1127
1128 end type;
1129
1130
1131 check_switch: proc;
1132
1133
1134
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
1144
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
1174
1175
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
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
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
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
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
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
1272
1273
1274
1275
1276
1277
1278
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;
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
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);
1308 if code = 2 then pc = 2;
1309 else if code = 5 then pc = 2;
1310 else if code = 7 then pc = 2;
1311 else if code = 15 then pc = 2;
1312 else if code = 16 then pc = 2;
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
1329
1330
1331
1332
1333
1334
1335
1336
1337
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;
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;
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
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
1419
1420
1421
1422
1423
1424
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);
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;