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 display_block:
 12           procedure(node_ptr,walk,no_dcls,source,tree_level);
 13 
 14 /*        Modified on:        11 August 1971 by PG */
 15 /*        Modified on:        22 September 1971 by PAB */
 16 /*        Modified on:        28 February 1978 by PCK for options(main) */
 17 /*        Modified on:        29 November 1979 by PCK to display output with tree level indentation */
 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                               /*eject^L*/
 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;