1
2
3
4
5
6
7
8
9
10
11 display_block:
12 procedure(node_ptr,walk,no_dcls,source,tree_level);
13
14
15
16
17
18
19 dcl (p, q, node_ptr) ptr;
20
21 dcl (addr, fixed, null, length, string, substr) builtin;
22
23 dcl display_exp entry(ptr,fixed bin);
24
25 dcl display_any_node_name ext entry(char(*) aligned,ptr,fixed bin),
26 display_statement ext entry(ptr,bit(1) aligned,fixed bin),
27 display_symbol ext entry(ptr,fixed bin),
28 display_block ext entry(ptr,bit(1) aligned,bit(1) aligned,bit(1) aligned,fixed bin),
29 ioa_ ext entry options(variable),
30 decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying),
31 convert_binary_integer_$decimal_string entry(fixed bin(15)) returns(char(12) varying),
32 ii fixed bin(18),
33 tree_level fixed bin,
34 (no_dcls,source,walk) bit(1) aligned,
35 (i,j) fixed bin(17);
36
37 dcl display_stat_$brief_display bit(1) ext static;
38
39
40 dcl context_bits(20) bit(1) unaligned based(addr(q->context.types)),
41 context_bit_names(20) char(11) aligned int static init(
42 "structure","fixed","float","bit","char","ptr","offset","area","label",
43 "entry","file","label_const","entry_const","file_const","condition",
44 "format","builtin","generic","picture","parameter");
45
46
47 dcl n fixed bin(15);
48
49 dcl btype char(12),
50 block_type(6) char(12) int static init(" root block", "n ext proc",
51 "n int proc", " begin block", "n on unit", " quick sub"),
52 itype fixed bin(15);
53
54 dcl bit_names(5) char(16) static varying
55 init("like ", "no_stack ", "get_data ", "flush_at_call ", "text_displayed ");
56
57 dcl nonquick_reasons (13) char (24) internal static varying
58 init ("auto_adjustable ", "returns_star ", "stack_extended ", "invoked_by_format ",
59 "format_stmt ", "io_stmts ", "assigned_to_entry_var ",
60 "condition_stmts ", "no_owner ", "recursive_call ", "options_non_quick ", "options_variable ",
61 "never_referenced ");
62
63 dcl line char(80) varying,
64 word bit(36) unaligned based,
65 b36 bit(36) aligned;
66
67 dcl pl1_stat_$constant_list ptr ext static,
68 pl1_stat_$defined_list ptr ext static,
69 pl1_stat_$temporary_list ptr ext static;
70
71
72 %include token;
73 %include block;
74 %include default;
75 %include list;
76 %include statement;
77 %include symbol;
78 %include context;
79 %include nodes;
80
81
82 p=node_ptr;
83 start:
84 if p=null
85 then do;
86 call ioa_("^vxblock ptr is NULL",tree_level);
87 go to ret;
88 end;
89
90 if p->node.type^=block_node
91 then do;
92 call display_any_node_name("display_block: arg is not a block node,
93 arg =",p,tree_level+1);
94 go to ret;
95 end;
96
97 itype= fixed(p->block.block_type,9);
98 if itype<=6 & itype>=1
99 then btype=block_type(itype);
100 else btype = convert_binary_integer_$decimal_string(itype);
101
102 call ioa_("^/^vxBLOCK ^p is a^a",tree_level,p,btype);
103 call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b));
104 i=p->block.level;
105 if i ^= 0 then call ioa_("^vxlevel = ^d",tree_level,i);
106
107 ii=p->block.symbol_block;
108 if ii ^= 0 then call ioa_("^vxruntime symbol block is ^6w",tree_level,ii);
109
110 i = p -> block.last_auto_loc;
111 if i ^= 0 then call ioa_("^vxlast auto loc = ^6w",tree_level,i);
112
113 i = p -> block.number_of_entries;
114 if i ^= 0 then call ioa_("^vxnumber of entries = ^d",tree_level,i);
115
116 call ioa_("^vxprefix = ^4o",tree_level,fixed(p->block.prefix,12));
117 call ioa_("^vxfather = ^p",tree_level,p->block.father);
118
119 if p->block.options_main
120 then call ioa_("^vxoptions_main",tree_level);
121
122 line = "";
123 b36 = addr(p -> block.like_attribute) -> word;
124
125 do i = 1 to hbound(bit_names,1);
126 if substr(b36,i,1)
127 then line = line || bit_names(i);
128 end;
129
130 if length(line) ^= 0 then call ioa_("^vx^a",tree_level,line);
131
132 line = "nonquick reasons: ";
133 do i = 1 to hbound (nonquick_reasons, 1);
134 if substr (string (p -> block.why_nonquick), i, 1) = "1"b
135 then do;
136 if length (line) + length (nonquick_reasons (i)) > 80
137 then do;
138 call ioa_ ("^vx^a",tree_level,line);
139 line = " ";
140 end;
141
142 line = line || nonquick_reasons (i);
143 end;
144 end;
145
146 if length (line) > length ("nonquick reasons: ")
147 then call ioa_ ("^vx^a",tree_level,line);
148
149 call ioa_("^vxnumber = ^d",tree_level,p->block.number);
150
151 if p->block.owner ^= null
152 then call ioa_("^vxowner = ^p",tree_level,p->block.owner);
153
154 q = p -> block.return_values;
155 if q^=null
156 then do;
157 if display_stat_$brief_display then call ioa_("^vxreturn values = ^p",tree_level,q);
158 else do;
159 call ioa_("^vxreturn values:",tree_level);
160
161 do while(q^=null);
162 call display_exp((q->list.element(2)),tree_level+1);
163 q=q->list.element(1);
164 end;
165 end;
166 end;
167
168 q = p -> block.return_count;
169 if q^=null
170 then do;
171 if display_stat_$brief_display then call ioa_("^vxreturn count = ^p",tree_level,q);
172 else do;
173 call ioa_("^vxreturn count:",tree_level);
174 call display_exp(q,tree_level+1);
175 end;
176 end;
177
178 do i = 1 to 3;
179 q = p -> block.free_temps(i);
180 if q ^= null then call ioa_("^vxfree temps(^d) = ^p",tree_level,i,q);
181 end;
182
183 i = p -> block.enter.start;
184 j = p -> block.enter.end;
185 if i + j ^= 0
186 then call ioa_("^vxenter.start = ^o, enter.end = ^o",tree_level,i,j);
187
188 i = p -> block.leave.start;
189 j = p -> block.leave.end;
190 if i + j ^= 0
191 then call ioa_("^vxleave.start = ^o, leave.end = ^o",tree_level,i,j);
192
193 q = p -> block.entry_list;
194 if q ^= null then call ioa_("^vxentry list = ^p",tree_level,q);
195
196 q=p->block.plio_ps;
197 if q ^= null then call ioa_("^vxplio_ps= ^p",tree_level,q);
198
199 q=p->block.plio_fa;
200 if q ^= null then call ioa_("^vxplio_format_area= ^p",tree_level,q);
201
202 q=p->block.plio_ffsb;
203 if q ^= null then call ioa_("^vxplio_ffsb= ^p",tree_level,q);
204
205 q=p->block.plio_ssl;
206 if q ^= null then call ioa_("^vxplio_ssl= ^p",tree_level,q);
207
208 q=p->block.plio_fab2;
209 if q ^= null then call ioa_("^vxplio_fab2= ^p",tree_level,q);
210
211 q = p -> block.declaration;
212 if q = null
213 then call ioa_("^vxno dcls",tree_level);
214 else do;
215 if display_stat_$brief_display | no_dcls then call ioa_("^vxdeclarations = ^p",tree_level,q);
216 else do;
217 call ioa_("^vxdeclarations:",tree_level);
218 dcl_loop: call display_symbol(q,tree_level+1);
219 q=q->symbol.next;
220 if q^=null then go to dcl_loop;
221 end;
222 end;
223
224 ck_context:
225 q=p->block.context;
226 if q = null
227 then call ioa_("^vxno context",tree_level);
228 else do;
229 if display_stat_$brief_display then call ioa_("^vxcontext = ^p",tree_level,q);
230 else do;
231 call ioa_("^vxcontext:",tree_level);
232 ctxt_loop: call ioa_("^vxidentifier is ^a, attributes are:",tree_level,q->context.token->token.string);
233 do i = 1 to 20;
234 if context_bits(i) then call ioa_("^vx^a",tree_level,context_bit_names(i));
235 end;
236 q=q->context.next;
237 if q^=null then go to ctxt_loop;
238 end;
239 end;
240
241 if p->block.father=null
242 then do;
243 if pl1_stat_$constant_list^=null
244 then do;
245 if display_stat_$brief_display then call ioa_("^vxconstants = ^p",tree_level,pl1_stat_$constant_list);
246 else do;
247 call ioa_("^vxconstants:",tree_level);
248
249 q=pl1_stat_$constant_list;
250 do while(q^=null);
251 call display_symbol(q,tree_level+1);
252 q=q->symbol.multi_use;
253 end;
254 end;
255 end;
256
257 if pl1_stat_$temporary_list^=null
258 then do;
259 if display_stat_$brief_display then call ioa_("^vxtemporaries = ^p",tree_level,pl1_stat_$temporary_list);
260 else do;
261 call ioa_("^vxtemporaries:",tree_level);
262
263 q=pl1_stat_$temporary_list;
264 do while(q^=null);
265 call display_symbol(q,tree_level+1);
266 q=q->symbol.multi_use;
267 end;
268 end;
269 end;
270
271 if pl1_stat_$defined_list ^= null
272 then do;
273 if display_stat_$brief_display
274 then call ioa_("^vxdefined overlays = ^p",tree_level,pl1_stat_$defined_list);
275 else do;
276 call ioa_("^vxdefined overlays:",tree_level);
277
278 do q = pl1_stat_$defined_list repeat q -> symbol.multi_use while(q ^= null);
279 call display_symbol(q,tree_level+1);
280 end;
281 end;
282 end;
283 end;
284
285 q=p->block.default;
286 if q^=null then do;
287 if display_stat_$brief_display then call ioa_("^vx^vxdefaults = ^p",tree_level,tree_level,q);
288 else do;
289 call ioa_("^vxdefault:",tree_level);
290 default_loop: call display_symbol(q,tree_level+1);
291 q=q->default.next;
292 if q^=null then go to default_loop;
293 end;
294 end;
295
296 q = p -> block.prologue;
297 if q = null
298 then call ioa_("^vxno prologue",tree_level);
299 else do;
300 if display_stat_$brief_display then call ioa_("^vxprologue = ^p",tree_level,q);
301 else do;
302 call ioa_("^vxprologue:",tree_level);
303 pro_loop: call display_statement(q,"0"b,tree_level+1);
304 q=q->statement.next;
305 if q^=null then go to pro_loop;
306 end;
307 end;
308
309 q = p -> block.main;
310 if q = null
311 then call ioa_("^vxno main",tree_level);
312 else do;
313 if display_stat_$brief_display then call ioa_("^vxmain = ^p",tree_level,q);
314 else do;
315 call ioa_("^vxmain:",tree_level);
316 main_loop: call display_statement(q,source,tree_level+1);
317 q=q->statement.next;
318 if q^=null then go to main_loop;
319 end;
320 end;
321
322
323 q=p->block.son;
324 if q = null
325 then call ioa_("^vxno sons",tree_level);
326 else if ^walk | display_stat_$brief_display then call ioa_("^vxson = ^p",tree_level,q);
327 else do;
328 call ioa_("^vxson:",tree_level);
329 call display_block(q,walk,no_dcls,source,tree_level+1);
330 end;
331
332 if p->block.brother=null
333 then call ioa_("^vxno brothers",tree_level);
334 else if ^walk | display_stat_$brief_display then call ioa_("^vxbrother = ^p",tree_level,p->block.brother);
335 else do;
336 call ioa_("^vxEND BLOCK ^p^/",tree_level,p);
337 p=p->block.brother;
338 call ioa_("^vxbrother:",tree_level);
339 go to start;
340 end;
341
342 ret: call ioa_("^vxEND BLOCK ^p^/",tree_level,p);
343 return;
344 end display_block;