1
2
3
4
5
6 %;
7
8
9
10
11
12
13
14
15
16 debug: db: procedure;
17 debug
18
19 debugdebug
20
21
22
23
24
25
26 dcl arg_mcp ptr;
27
28
29 debug
30
31
32
33
34
35
36 dcl common_auto_area (88) fixed bin aligned,
37
38 snt_area (70) fixed bin aligned;
39
40 dcl 1 save aligned like db_ext_stat_$db_ext_stat_;
41 dcl break_num fixed bin,
42
43
44 break_ptr ptr,
45
46 temp_break_ptr ptr;
47
48 dcl comd_len fixed bin,
49
50
51 comd_ptr ptr,
52
53 cond_flag fixed bin;
54
55
56
57
58 dcl i fixed bin;
59
60 dcl input_buffer char (132) aligned,
61
62 input_buffer_ptr ptr,
63
64 input_line_len21 fixed bin (21),
65 input_line_len fixed bin;
66
67 dcl printer_on char (1) init ("^F");
68
69 dcl line_num fixed bin,
70
71
72 line_1st_inst_off fixed bin,
73
74
75 line_num_inst fixed bin;
76
77
78 dcl line_info char (14) aligned;
79
80 dcl last_sp ptr;
81
82
83
84 dcl cleanup condition;
85 dcl command_abort_ condition;
86 dcl code fixed bin (35);
87 dcl new_line char (1) init ("
88 ");
89
90 dcl read_line_label label;
91
92
93
94
95
96 dcl common_static_area (1063) fixed bin internal static aligned;
97 dcl static_init_count fixed bin internal static init (0);
98 dcl initial_flag bit (1) int static init ("0"b);
99
100
101
102
103 %include db_ext_stat_;
104
105 dcl 1 d like db_ext_stat_$db_ext_stat_ based (addr (db_ext_stat_$db_ext_stat_));
106 dcl condition_ ext entry (char (*), entry),
107 cu_$stack_frame_ptr ext entry returns (ptr),
108 db_break$check_break ext entry (ptr, fixed bin, ptr, fixed bin, fixed bin,
109 fixed bin, ptr, fixed bin),
110 db_break$restart ext entry (ptr, fixed bin, fixed bin, ptr, fixed bin),
111 db_break$set_break ext entry (ptr, fixed bin, ptr, fixed bin),
112 db_fill_snt ext entry (ptr, ptr),
113 db_find_mc ext entry (ptr, bit (1) aligned, ptr),
114 db_parse ext entry (ptr, fixed bin, ptr, ptr),
115 debug$mme2_fault ext entry (ptr),
116 hcs_$high_low_seg_count ext entry (fixed bin, fixed bin),
117 ioa_$ioa_stream ext entry options (variable),
118 ioa_$rsnnl ext entry options (variable),
119 legal_f_ ext entry (ptr) returns (fixed bin),
120 db_line_no ext entry (ptr, fixed bin (18), fixed bin, fixed bin, fixed bin);
121 dcl iox_$control ext entry (ptr, char (*), ptr, fixed bin (35));
122 dcl iox_$user_output ptr ext;
123 dcl iox_$user_input ptr ext;
124 dcl iox_$get_line ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
125 dcl iox_$close ext entry (ptr, fixed bin (35));
126 dcl iox_$detach_iocb ext entry (ptr, fixed bin (35));
127 dcl com_err_ ext entry options (variable);
128 dcl error_table_$long_record ext fixed bin (35);
129 dcl error_table_$not_attached ext fixed bin (35);
130 dcl error_table_$not_open ext fixed bin (35);
131 dcl (addr,
132 addrel,
133 baseptr,
134 fixed,
135 null,
136 ptr) builtin;
137
138 %include db_common_auto;
139 %include db_common_static;
140
141 %include db_inst;
142
143 %include db_snt;
144
145 %include stack_header;
146 %include stack_frame;
147 %include mc;
148
149 debugdebug
150
151 if static_init_count = 0 then call set_internal_stat;
152
153 call set_ext_stat;
154 d.static_handler_call = "0"b;
155
156 com_stat_ptr = addr (common_static_area);
157 com_auto_ptr = addr (common_auto_area);
158 sntp = addr (snt_area);
159
160 call condition_ ("mme2", debug$mme2_fault);
161
162 break_num = 0; debug
163 temp_break_mode = 0;
164 num_skips = 0;
165
166
167 debug
168
169 last_sp = cu_$stack_frame_ptr () ->
170 stack_frame.prev_sp; debug
171
172 debug
173
174
175
176
177
178
179 call db_find_mc (last_sp, "0"b, db_mc_ptr);
180
181
182
183
184 call common_init;
185
186 goto read_line;
187
188
189
190
191
192 debug
193
194
195
196 mme2_fault: entry (arg_mcp);
197
198 if static_init_count = 0 then do; debug
199 call set_internal_stat;
200 call set_ext_stat;
201 d.static_handler_call = "1"b;
202 end;
203
204 com_stat_ptr = addr (common_static_area);
205 com_auto_ptr = addr (common_auto_area);
206 sntp = addr (snt_area);
207
208 db_mc_ptr = arg_mcp;
209
210
211
212
213
214 scup = addr (db_mc_ptr -> mc.scu);
215 break_ptr = ptr (baseptr (fixed (scup -> scu.ppr.psr)), scup -> scu.ilc);
216 break_num = fixed (break_ptr -> instr.offset);
217 last_sp = db_mc_ptr -> mc.prs (spx);
218 call db_fill_snt (last_sp, sntp);
219 call db_break$check_break (break_ptr, break_num, sntp, cond_flag, num_skips, comd_len, comd_ptr, line_num);
220
221
222 debug
223
224 if break_ptr = null then do;
225 call common_init;
226 goto read_line_label;
227 end;
228
229 if (cond_flag = 1) | (num_skips > 0) then goto restart_break;
230
231 call common_init;
232
233 if line_num > 0 then call ioa_$rsnnl ("at line ^d", line_info, i, line_num);
234 else line_info = "";
235
236 if print_mode = 0 then call ioa_$ioa_stream (d.debug_output, "Break ^d ^a of ^a", break_num, line_info, snt.ent_name);
237 else call ioa_$ioa_stream (d.debug_output, "^RBreak ^d ^a of ^a - at ^p^B",
238 break_num, line_info, snt.ent_name, break_ptr);
239 if temp_comd_len ^= 0
240 then call db_parse (addr (temp_comd_line), temp_comd_len, com_auto_ptr, com_stat_ptr);
241
242 if comd_len ^= 0
243 then call db_parse (comd_ptr, comd_len, com_auto_ptr, com_stat_ptr);
244
245 goto db_action_label (db_action_code);
246
247
248
249 debugdebug
250 debug
251
252
253 conversion_handler: procedure;
254
255 call ioa_$ioa_stream (d.debug_output, "Conversion error");
256 goto read_line_label;
257
258 end conversion_handler;
259
260 prog_interrupt_handler: procedure;
261
262 goto read_line_label;
263
264 end prog_interrupt_handler;
265
266
267 debug
268
269 debug
270
271
272
273
274 debug
275
276
277 any_other_handler: proc (mcptr, name, wcptr, info_ptr, cont);
278
279 dcl mcptr ptr,
280 name char (*),
281 wcptr ptr,
282 info_ptr ptr,
283 cont bit (1);
284 dcl conditions char (106) init ("conversion,fixedoverflow,out_of_bounds,overflow,underflow,zerodivide,stringrange,stringsize,subscriptrange");
285
286 if d.in_debug then do; debug
287
288 if name = "db_conversion" then name = "conversion";
289 if index (conditions, name) > 0 then do;
290 call ioa_$ioa_stream (d.debug_output, "db: ^a", name);
291 go to read_line_label;
292 end;
293 end;
294
295 cont = "1"b;
296 return;
297
298 end any_other_handler;
299
300
301
302
303
304
305
306
307
308 read_line:
309 db_action_label (0):
310 call iox_$get_line (d.debug_io_ptr (1), input_buffer_ptr, 132, input_line_len21, code);
311 input_line_len = input_line_len21;
312
313 if code ^= 0 then do;
314 call com_err_ (code, "debug");
315 if code = error_table_$long_record then go to read_line;
316 else go to quit;
317 end;
318 if input_line_len = 1 then goto read_line;
319 db_action_code = 0;
320
321 call db_parse (input_buffer_ptr, input_line_len, com_auto_ptr, com_stat_ptr);
322
323 goto db_action_label (db_action_code);
324
325
326
327 db_action_label (1):
328
329 call iox_$control (d.debug_io_ptr (1), "resetread", null, code);
330 if code ^= 0 then call com_err_ (code, "debug");
331 goto read_line;
332
333 debug
334 db_action_label (2):
335 quit:
336
337 if break_num = 0 then do; debug
338 call restore;
339 return;
340 end;
341
342 debug
343 debug
344
345 if ^d.flags.static_handler_call then goto d.return_label;
346 signal command_abort_;
347 goto read_line;
348
349 return_from_debug:
350
351
352 call restore;
353 return;
354
355 Note
356 debug
357
358 debug
359
360
361
362
363 restart_break:
364 db_action_label (3):
365 if break_num = 0 | break_ptr = null
366
367 then do;
368 call ioa_$ioa_stream (d.debug_output, "No break fault, cannot restart break.");
369 goto read_line;
370 end;
371
372
373
374
375
376
377 if temp_break_mode ^= 0
378
379 then do;
380
381 call db_fill_snt (last_sp, sntp);
382
383 call get_line_num;
384
385 call db_break$set_break (temp_break_ptr, 1, sntp, print_mode);
386
387 end;
388
389
390 debug
391
392
393
394
395
396 d.in_debug = "0"b; debug
397 call db_break$restart (break_ptr, break_num, num_skips, scup, print_mode);
398 return;
399
400
401 common_init: procedure;
402
403
404
405
406
407
408
409
410
411 first_call_flag,
412 db_action_code = 0;
413
414 input_buffer_ptr = addr (input_buffer);
415 debug
416
417 debug
418 debug
419
420
421 read_line_label = read_line;
422 call condition_ ("db_conversion", conversion_handler);
423 call condition_ ("program_interrupt", prog_interrupt_handler);
424
425 call condition_ ("any_other", any_other_handler);
426 d.in_debug = "1"b;
427
428
429
430
431
432
433 sp = ptr (last_sp, 0) -> stack_header.stack_begin_ptr;
434 Note
435
436
437 do i = 0 to 511;
438
439 if legal_f_ (sp) ^= 0
440
441 then do;
442
443 max_sp_x = i - 1;
444
445
446 call ioa_$ioa_stream (d.debug_output, "Cannot trace stack past depth ^d", i-1);
447
448 goto get_snt_data;
449
450 end;
451 stack_ptr_array (i) = sp;
452
453
454 if sp = last_sp
455
456
457 then do;
458
459 max_sp_x = i;
460
461
462 goto get_snt_data;
463
464 end;
465
466 sp = sp -> stack_frame.next_sp;
467
468 end;
469
470
471 call ioa_$ioa_stream (d.debug_output, "Stack array overflow has occurred.");
472
473 max_sp_x = i - 1;
474
475
476
477
478 get_snt_data:
479
480 call db_fill_snt (stack_ptr_array (max_sp_x), sntp);
481
482 snt_ptr = sntp;
483
484 end common_init;
485
486 get_line_num: procedure;
487
488
489
490
491
492
493
494
495
496 call db_line_no (sntp, fixed (rel (break_ptr), 18), line_1st_inst_off,
497 line_num_inst, line_num);
498 if line_num > -1
499 then do;
500
501
502 temp_break_ptr = ptr (break_ptr, line_1st_inst_off + line_num_inst);
503
504 return;
505 end;
506
507
508
509
510
511
512 line_num = -1;
513
514 temp_break_ptr = addrel (break_ptr, 1);
515 end get_line_num;
516 restore: proc;
517
518 debug
519
520 debug
521 debug
522
523
524 do i = 1 to 2;
525
526 if d.debug_io_open (i) then do;
527 call iox_$close (d.debug_io_ptr (i), code);
528 if code ^= 0 then if code ^= error_table_$not_open then call com_err_ (code, "debug");
529 end;
530
531 if d.debug_io_attach (i) then do;
532 call iox_$detach_iocb (d.debug_io_ptr (i), code);
533 if code ^= 0 then if code ^= error_table_$not_attached then call com_err_ (code, "debug");
534 end;
535 end;
536
537 d = save;
538 static_init_count = static_init_count - 1;
539
540 return;
541 end restore;
542
543
544 debug
545 debug
546
547
548
549 set_ext_stat: proc;
550
551 save = d;
552 d.debug_input = "user_input";
553 d.debug_output = "user_output";
554 d.debug_io_open (1), d.debug_io_open (2), d.debug_io_attach (1), d.debug_io_attach (2) = "0"b;
555 d.debug_io_ptr (1) = iox_$user_input;
556 d.debug_io_ptr (2) = iox_$user_output;
557 static_init_count = static_init_count + 1;
558
559 debug
560 debugdebug
561 debug
562 debug
563
564 d.return_label = return_from_debug;
565
566 on cleanup call restore;
567
568 end set_ext_stat;
569 set_internal_stat: proc;
570
571 com_stat_ptr = addr (common_static_area);
572 if initial_flag then return;
573
574 call hcs_$high_low_seg_count (i, hcs_count);
575
576 sb = ptr (cu_$stack_frame_ptr (), 0);
577 lotp = sb -> stack_header.lot_ptr;
578
579 print_mode = 1;
580 temp_comd_len = 0;
581 initial_flag = "1"b;
582
583 end set_internal_stat;
584 end debug;