1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29 display_exp:
30 proc (a, tree_level);
31
32 dcl (a, p, q, s) ptr,
33 tree_level fixed bin,
34 display_stat_$brief_display
35 bit (1) ext static,
36 display_any_node_name
37 entry (char (*) aligned, ptr, fixed bin);
38 dcl (binary, substr, addr, fixed, string, length, null, hbound, baseno, rel)
39 builtin;
40 dcl decode_node_id entry (ptr, bit (1) aligned) returns (char (120) varying),
41 display_list entry (ptr, fixed bin),
42 display_constant entry (ptr, fixed bin);
43 dcl ioa_ entry options (variable);
44 dcl ioa_$nnl entry options (variable);
45 dcl (i, n) fixed bin (15),
46 line char (96),
47 lp fixed bin;
48 dcl b36 bit (36) aligned,
49 m fixed bin (18),
50 word_bit bit (36) aligned based (p),
51 op_name char (20) aligned,
52 op_number bit (9) aligned,
53 1 op_number_structure
54 based (addr (op_number)) aligned,
55 2 op_class bit (5) unaligned,
56 2 op_relative bit (4) unaligned;
57
58
59
60 %include op_codes;
61 %include cross_reference;
62 %include label;
63 %include nodes;
64 %include symbol;
65 %include operator;
66 %include temporary;
67 %include token;
68 %include token_types;
69 %include reference;
70
71
72
73 dcl units (7) char (5) int static options (constant) aligned
74 init ("bit ", "digit", "char", "half", "word", "mod2", "mod4");
75
76 dcl bit_names (30) char (20) varying static
77 init ("array", "varying", "shared", "put_data", "processed", "inhibit", "big_offset",
78 "big_length", "has_modword", "padded", "aligned", "long", "forward", "ic", "temp", "defined",
79 "evaluated", "allocate", "allocated", "aliasable", "even", "", "aggregate", "hit_zero",
80 "dont_save", "fo_in_qual", "hard_to_load", "substr", "padded_for_store", "aligned_for_store");
81
82 dcl data_type_name (1:24) char (20) var aligned
83 init ("real_fix_bin_1", "real_fix_bin_2", "real_flt_bin_1", "real_flt_bin_2",
84 "complex_fix_bin_1", "complex_fix_bin_2", "complex_flt_bin_1", "complex_flt_bin_2",
85 "real_fix_dec", "real_flt_dec", "complex_fix_dec", "complex_flt_dec", "char_string",
86 "bit_string", "label_constant", "local_label_variable", "label_variable", "entry_variable",
87 "ext_entry_in", "ext_entry_out", "int_entry", "int_entry_other", "unpacked_ptr", "packed_ptr")
88 int static options (constant);
89
90 dcl address_name (9) char (8) varying static init ("b0", "b1", "b2", "b3", "b4", "b5", "b6", "b7", "storage");
91
92 dcl value_name (24) char (12) varying static
93 init ("a", "q", "aq", "string_aq", "complex_aq", "decimal_aq", "b0", "b1", "b2", "b3", "b4",
94 "b5", "b6", "b7", "storage", "indicators", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");
95
96 dcl op_offset (0:20) fixed bin (15) int static
97 initial (0, 1, 8, 15, 25, 35, 46, 61, 65, 81, 92, 108, 117, 120, 131, 137, 153, 169, 185, 194,
98 210);
99
100
101
102 dcl op_names (0:210) char (20) aligned internal static initial (
103 "ZERO!!",
104 "UNUSED 1-0",
105 "add",
106 "sub",
107 "mult",
108 "div",
109 "negate",
110 "exp",
111
112 "UNUSED 2-0",
113 "and_bits",
114 "or_bits",
115 "xor_bits",
116 "not_bits",
117 "cat_string",
118 "bool_fun",
119
120 "UNUSED 3-0",
121 "assign",
122 "assign_size_ck",
123 "assign_zero",
124 "copy_words",
125 "copy_string",
126 "make_desc",
127 "assign_round",
128 "pack",
129 "unpack",
130
131 "UNUSED 4-0",
132 "UNUSED 4-1",
133 "UNUSED 4-2",
134 "UNUSED 4-3",
135 "less_than",
136 "greater_than",
137 "equal",
138 "not_equal",
139 "less_or_equal",
140 "greater_or_equal",
141
142 "UNUSED 5-0",
143 "jump",
144 "jump_true",
145 "jump_false",
146 "jump_if_lt",
147 "jump_if_gt",
148 "jump_if_eq",
149 "jump_if_ne",
150 "jump_if_le",
151 "jump_if_ge",
152 "jump_three_way",
153
154 "UNUSED 6-0",
155 "std_arg_list",
156 "return_words",
157 "std_call",
158 "return_bits",
159 "std_entry",
160 "return_string",
161 "ex_prologue",
162 "allot_auto",
163 "param_ptr",
164 "param_desc_ptr",
165 "std_return",
166 "allot_ctl",
167 "free_ctl",
168 "stop",
169
170 "mod_bit",
171 "mod_byte",
172 "mod_half",
173 "mod_word",
174
175 "bit_to_char",
176 "bit_to_word",
177 "char_to_word",
178 "half_to_word",
179 "word_to_mod2",
180 "word_to_mod4",
181 "word_to_mod8",
182 "rel_fun",
183 "baseno_fun",
184 "desc_size",
185 "bit_pointer",
186 "index_before_fun",
187 "index_after_fun",
188 "verify_ltrim_fun",
189 "verify_rtrim_fun",
190 "digit_to_bit",
191
192 "ceil_fun",
193 "floor_fun",
194 "round_fun",
195 "sign_fun",
196 "abs_fun",
197 "trunc_fun",
198 "byte",
199 "rank",
200 "index_rev_fun",
201 "search_rev_fun",
202 "verify_rev_fun",
203
204 "index_fun",
205 "off_fun",
206 "complex_fun",
207 "conjg_fun",
208 "mod_fun",
209 "repeat_fun",
210 "verify_fun",
211 "translate_fun",
212 "UNUSED 10-8",
213 "real_fun",
214 "imag_fun",
215 "length_fun",
216 "pl1_mod_fun",
217 "search_fun",
218 "allocation_fun",
219 "reverse_fun",
220
221 "addr_fun",
222 "addr_fun_bits",
223 "ptr_fun",
224 "baseptr_fun",
225 "addrel_fun",
226 "codeptr_fun",
227 "environmentptr_fun",
228 "stackbaseptr_fun",
229 "stackframeptr_fun",
230
231 "min_fun",
232 "max_fun",
233 "pos_dif_fun",
234
235 "UNUSED 13-0",
236 "stack_ptr",
237 "empty_area",
238 "UNUSED 13-3",
239 "enable_on",
240 "revert_on",
241 "signal_on",
242 "lock_fun",
243 "stacq_fun",
244 "clock_fun",
245 "vclock_fun",
246
247 "bound_ck",
248 "range_ck",
249 "loop",
250 "join",
251 "allot_based",
252 "free_based",
253
254 "UNUSED 15-0",
255 "r_parn",
256 "l_parn",
257 "r_format",
258 "c_format",
259 "f_format",
260 "e_format",
261 "b_format",
262 "a_format",
263 "x_format",
264 "skip_format",
265 "column_format",
266 "page_format",
267 "line_format",
268 "picture_format",
269 "bn_format",
270
271 "get_list_trans",
272 "get_edit_trans",
273 "get_data_trans",
274 "put_list_trans",
275 "put_edit_trans",
276 "put_data_trans",
277 "terminate_trans",
278 "stream_prep",
279 "record_io",
280 "fortran_read",
281 "fortran_write",
282 "ftn_file_manip",
283 "ftn_trans_loop",
284 "put_control",
285 "put_field",
286 "put_field_chk",
287
288 "UNUSED 17-0",
289 "UNUSED 17-1",
290 "return_value",
291 "allot_var",
292 "free_var",
293 "get_file",
294 "get_string",
295 "put_file",
296 "put_string",
297 "open_file",
298 "close_file",
299 "read_file",
300 "write_file",
301 "locate_file",
302 "do_fun",
303 "do_spec",
304
305 "rewrite_file",
306 "delete_file",
307 "unlock_file",
308 "lock_file",
309 "UNUSED 18-4",
310 "refer",
311 "prefix_plus",
312 "nop",
313 "assign_by_name",
314
315 "sqrt_fun",
316 "sin_fun",
317 "sind_fun",
318 "cos_fun",
319 "cosd_fun",
320 "tan_fun",
321 "tand_fun",
322 "asin_fun",
323 "asind_fun",
324 "acos_fun",
325 "acosd_fun",
326 "atan_fun",
327 "atand_fun",
328 "log2_fun",
329 "log_fun",
330 "log10_fun",
331
332 "exp_fun");
333
334
335 ^L
336
337
338 p = a;
339 if p = null
340 then do;
341 call ioa_ ("^/^vxdisplay_exp: pointer is NULL^/", tree_level);
342 return;
343 end;
344 if p -> node.type = token_node
345 then do;
346 call ioa_ ("^/^vxTOKEN ^p is ^a", tree_level, p, p -> token.string);
347 if p -> token.type = bit_string
348 then call ioa_ ("^vxtype is bit_string", tree_level);
349 else if p -> token.type = char_string
350 then call ioa_ ("^vxtype is char_string", tree_level);
351
352 call ioa_ ("");
353 return;
354 end;
355 if p -> node.type = block_node
356 then do;
357 call ioa_ ("^/^vxBLOCK ^p^/", tree_level, p);
358 return;
359 end;
360 if p -> node.type = label_node
361 then do;
362 call ioa_ ("^/^vxLABEL ^p is ^a^/", tree_level, p, p -> label.token -> token.string);
363 return;
364 end;
365 if p -> node.type = cross_reference_node
366 then do;
367 do p = p repeat p -> cross_reference.next while (p ^= null);
368 call ioa_ ("^/^vxXREF ^p, ^a^[ set^]^/", tree_level, p, decode_node_id (p, "0"b),
369 p -> cross_reference.set_reference);
370 end;
371 return;
372 end;
373 if p -> node.type = symbol_node
374 then do;
375 call ioa_ ("^/^vxSYMBOL ^p is ^a^/", tree_level, p, p -> symbol.token -> token.string);
376 return;
377 end;
378 if p -> node.type = reference_node
379 then do;
380 s, q = p -> reference.symbol;
381 if s = null
382 then call ioa_ ("^/^vxREFERENCE ^p", tree_level, p);
383 else do;
384 if q -> node.type = symbol_node | q -> node.type = label_node
385 then q = q -> symbol.token;
386 else ;
387
388 call ioa_$nnl ("^/^vxREFERENCE ^p is ^a, symbol is ^p", tree_level, p, q -> token.string,
389 p -> reference.symbol);
390
391 if p -> reference.data_type ^= 0
392 then call ioa_$nnl (", data type is ^d (^a)", p -> reference.data_type,
393 data_type_name (p -> reference.data_type));
394
395
396 call ioa_ ("");
397
398 if s -> node.type = symbol_node
399 then if s -> symbol.constant & ^s -> symbol.entry & s -> symbol.initial ^= null
400 then call display_constant (s, tree_level + 1);
401 end;
402
403 m = p -> reference.c_offset;
404 if m ^= 0
405 then call ioa_ ("^vxc_offset = ^d", tree_level, m);
406 m = p -> reference.c_length;
407 if m ^= 0
408 then call ioa_ ("^vxc_length = ^d", tree_level, m);
409
410 b36 = substr (p -> word_bit, 10, 5) || p -> reference.inhibit || string (p -> reference.other)
411 || string (p -> reference.bits) || string (p -> reference.more_bits);
412 if b36 ^= "0"b
413 then do;
414 line = "";
415 lp = 1;
416
417 do i = 1 to hbound (bit_names, 1);
418 if substr (b36, i, 1)
419 then do;
420 n = length (bit_names (i));
421 if n > 0
422 then do;
423 substr (line, lp, n) = bit_names (i);
424 lp = lp + n + 1;
425
426 if lp > 72
427 then do;
428 call ioa_ ("^vx^a", tree_level, line);
429 lp = 1;
430 line = "";
431 end;
432 end;
433 end;
434 end;
435
436 if lp > 1
437 then call ioa_ ("^vx^a", tree_level, line);
438 end;
439
440 if ^p -> reference.no_address
441 then call ioa_ (
442 "^vx^[perm ^]address = ^[^spr^.3b|^;^[^s^;(base = ^.3b)^] ^]^.3b^a^[^s^; (tag = ^.3b)^]^[ inhibit^]^[^s^; (op = ^.3b)^]"
443 , tree_level, p -> reference.perm_address, p -> reference.address.ext_base,
444 p -> reference.address.base = ""b, p -> reference.address.base, p -> reference.address.offset,
445 decode_tag (p -> reference.address.tag), p -> reference.address.tag = ""b,
446 p -> reference.address.tag, p -> reference.address.inhibit, p -> reference.address.op = ""b,
447 p -> reference.address.op);
448
449 b36 = string (p -> reference.address_in);
450 if b36 ^= "0"b
451 then do;
452 line = "address is in:";
453 lp = 16;
454
455 do i = 1 to length (string (p -> reference.address_in));
456 if substr (b36, i, 1)
457 then do;
458 n = length (address_name (i));
459 substr (line, lp, n) = address_name (i);
460 lp = lp + n + 1;
461 end;
462 end;
463
464 call ioa_ ("^vx^a", tree_level, line);
465 end;
466
467 b36 = string (p -> reference.value_in);
468 if b36 ^= "0"b
469 then do;
470 line = "value is in:";
471 lp = 14;
472
473 do i = 1 to length (string (p -> reference.value_in));
474 if substr (b36, i, 1)
475 then do;
476 n = length (value_name (i));
477 substr (line, lp, n) = value_name (i);
478 lp = lp + n + 1;
479
480 if lp > 72
481 then do;
482 call ioa_ ("^vx^a", tree_level, line);
483 lp = 1;
484 line = "";
485 end;
486
487 end;
488 end;
489
490 if lp > 1
491 then call ioa_ ("^vx^a", tree_level, line);
492 end;
493
494 i = p -> reference.ref_count;
495 if i ^= 0
496 then call ioa_ ("^vxreference count = ^d", tree_level, i);
497
498 m = fixed (p -> reference.units, 3);
499 if m ^= 0
500 then call ioa_ ("^vxunits = ^a", tree_level, units (m));
501
502 i = fixed (p -> reference.store_ins, 18);
503 if i ^= 0
504 then call ioa_ ("^vxstored into at ^6w", tree_level, i);
505
506 q = p -> reference.offset;
507 if q ^= null
508 then call show_exp ("offset");
509 q = p -> reference.length;
510 if q ^= null
511 then call show_exp ("length");
512 q = p -> reference.qualifier;
513 if q ^= null
514 then call show_exp ("qualifier");
515 q = p -> reference.subscript_list;
516 if baseno (q) ^= (18)"0"b
517 then if q ^= null
518 then call show_exp ("subscript list");
519 else ;
520 else do;
521 i = fixed (rel (q), 18);
522 if i ^= 0
523 then call ioa_ ("^vxfractional offset is ^6w", tree_level, i);
524 end;
525 call ioa_ ("^vxEND REFERENCE ^p^/", tree_level, p);
526 return;
527 end;
528
529 if p -> node.type = list_node
530 then do;
531 call display_list (p, tree_level);
532 return;
533 end;
534
535 if p -> node.type = temporary_node
536 then do;
537 call ioa_ ("^/^vxTEMPORARY ^p", tree_level, p);
538 call ioa_ ("^vxnext = ^p", tree_level, p -> temporary.next);
539 call ioa_ ("^vxsize = ^d", tree_level, p -> temporary.size);
540 call ioa_ ("^vxlocation = sp|^6w", tree_level, (p -> temporary.location));
541 call ioa_ ("^vxref_count = ^d", tree_level, p -> temporary.ref_count);
542 call ioa_ ("^vxsymbol = ^p", tree_level, p -> temporary.symbol);
543 call ioa_ ("^vxlast_freed = ^6w", tree_level, (p -> temporary.last_freed));
544 call ioa_ ("^vxEND TEMPORARY ^p^/", tree_level, p);
545 return;
546 end;
547
548 if p -> node.type ^= operator_node
549 then do;
550 call display_any_node_name ("display_exp: arg node not handled by display_exp,
551 arg =", p, tree_level + 1);
552 return;
553 end;
554 n = p -> operator.number;
555 op_number = p -> operator.op_code;
556 op_name = op_names (op_offset (fixed (op_class, 5)) + fixed (op_relative, 4));
557
558 line = "";
559 lp = 1;
560
561 if p -> operator.shared
562 then do;
563 substr (line, lp, 6) = "shared";
564 lp = lp + 7;
565 end;
566
567 if p -> operator.optimized
568 then do;
569 substr (line, lp, 9) = "optimized";
570 lp = lp + 10;
571 end;
572
573 if p -> operator.processed
574 then do;
575 substr (line, lp, 9) = "processed";
576 lp = lp + 10;
577 end;
578
579 if lp = 1
580 then call ioa_ ("^/^vxOPERATOR ^p is ^a, ^d operands", tree_level, p, op_name, n);
581 else call ioa_ ("^/^vxOPERATOR ^p is ^a, (^va), ^d operands", tree_level, p, op_name, lp - 2, line, n);
582 do i = 1 to n;
583 if p -> operator.operand (i) = null
584 then call ioa_ ("^vxOPERAND (^d) of ^p = NULL", tree_level, i, p);
585 else do;
586 call ioa_ ("^vxOPERAND (^d) of ^p =", tree_level, i, p);
587 call display_exp ((p -> operator.operand (i)), tree_level + 1);
588 end;
589 end;
590 if n ^= 0
591 then call ioa_ ("^vxEND OPERATOR ^p, ^d operands^/", tree_level, p, n);
592 else call ioa_ ("");
593
594 return;
595 ^L
596 show_exp:
597 proc (message);
598
599 dcl message char (*);
600
601 if display_stat_$brief_display
602 then call ioa_ ("^vx^a exp = ^p", tree_level, message, q);
603 else do;
604 call ioa_ ("^vx^a follows:", tree_level, message);
605 call display_exp (q, tree_level + 1);
606 call ioa_ ("^vx^a ended", tree_level, message);
607 end;
608 end show_exp;
609
610 decode_tag:
611 procedure (tag) returns (char (4) varying);
612
613 dcl tag bit (6);
614
615 dcl designator fixed bin (4);
616
617 dcl designator_names (0:15) char (2) varying internal static options (constant)
618 initial ("n", "au", "qu", "du", "ic", "al", "ql", "dl", "x0", "x1", "x2", "x3", "x4", "x5",
619 "x6", "x7");
620
621 dcl it_designator_names (0:15) char (3) varying internal static options (constant)
622 initial ("f1", "itp", "42", "its", "sd", "scr", "f2", "f3", "ci", "i", "sc", "ad", "di", "dic",
623 "id", "idc");
624
625 designator = binary (substr (tag, 3), 4);
626 goto modification (binary (substr (tag, 1, 2), 2));
627
628 modification (0):
629 if designator = 0
630 then return ("");
631 else return ("," || designator_names (designator));
632
633 modification (1):
634 if designator = 0
635 then return (",*");
636 else return ("," || designator_names (designator) || "*");
637
638 modification (2):
639 return ("," || it_designator_names (designator));
640
641 modification (3):
642 return (",*" || designator_names (designator));
643 end decode_tag;
644
645 end display_exp;