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 di: display: proc;
 12 
 13 /* Modified: 29 November 1979 by PCK to produce tree level indented output */
 14 
 15 dcl       display_block       entry(ptr,bit(1) aligned,bit(1) aligned,
 16                                     bit(1) aligned,fixed bin);
 17 dcl       display_statement   entry(ptr,bit(1) aligned,fixed bin);
 18 dcl       display_source      entry(ptr,fixed bin);
 19 dcl       (display_array, display_list, display_exp, display_symbol)
 20            entry(ptr,fixed bin);
 21 dcl       show_ms$pt entry(ptr);
 22 
 23 dcl       show_statement ext entry(char(*) aligned),
 24           show_declaration ext entry(char(*) aligned,char(*) aligned),
 25           display_any_node_name ext entry(char(*) aligned,ptr,fixed bin);
 26 
 27 dcl       ioa_                entry options(variable),
 28           cv_dec_             entry(char(*) aligned) returns(fixed bin),
 29           cu_$arg_count       entry(fixed bin(15)),
 30           cu_$arg_ptr         entry(fixed bin(15),ptr,fixed bin(15),fixed bin(15)),
 31           cu_$gen_call        entry(entry,ptr),
 32           cu_$arg_list_ptr    entry(ptr);
 33 
 34 dcl       (k,tree_level) fixed bin;
 35 dcl       (string,string2,string3) char(12) aligned;
 36 dcl       display_stat_$brief_display bit(1) ext static;
 37 dcl       argstring char(arglen) based(argpt);
 38 dcl       (code,arglen) fixed bin(15),
 39           (ap1,argpt) pointer;
 40 
 41 
 42 dcl       (addr,baseptr,fixed,index,min,null,ptr,substr) builtin;
 43 dcl       program_interrupt condition;
 44 
 45 dcl       p ptr,
 46           (no_dcls,sourceb,walk) bit(1) aligned,
 47           (i,j,n) fixed bin(15),
 48           (pl1_stat_$root,pl1_stat_$cur_block,pl1_stat_$cur_statement) ptr ext,
 49           cv_oct_ entry(char(*) aligned) returns(fixed);
 50 
 51 dcl       disp_xeq bit(1) aligned;
 52 
 53 %include pl1_tree_areas;
 54 %include token_list;
 55 %include token_types;
 56 %include source_list;
 57 %include nodes;
 58 
 59 dcl       based_ptr ptr based;
 60 
 61 dcl       1 arglist based,
 62           2 number  bit(17),
 63           2 filler  fixed,
 64           2 arg(1)  ptr;
 65 
 66 %include block;
 67 
 68                               /*eject^L*/
 69 
 70 begin:
 71           disp_xeq = "0"b;
 72 
 73 common:
 74           on condition(program_interrupt) goto done;
 75           no_dcls,
 76           sourceb,
 77           walk = "0"b;
 78           tree_level = 0;
 79           call cu_$arg_count(i);
 80           if i = 0 then do;
 81                     call ioa_("display | di -options-^/^a^/^a",
 82 "options are: root | main | cur_block | cur_statement (walk) (no_dcls) (source)",
 83 "            brief | long
 84              token_list (_^Hn)");
 85           call ioa_(
 86 "            source_list (_^Hn) (min'ed with pl1_stat_$last_source)
 87              arg arg# offset#
 88              seg#|offset# (default seg is tree_)
 89              statement file#.line#.statement#
 90              dcl iden1 iden2 ... (10 max)");
 91                     return;
 92                     end;
 93 
 94           call cu_$arg_ptr(1,argpt,arglen,code);
 95           ap1=argpt;
 96           string=argstring;
 97           if substr(string,1,4) = "dcl " then go to show_dcl;
 98 
 99           if substr(string,1,8) = "brief   "
100           then do;
101                display_stat_$brief_display = "1"b;
102                return;
103                end;
104 
105           if substr(string,1,8) = "long    "
106           then do;
107                display_stat_$brief_display = "0"b;
108                return;
109                end;
110 
111           call cu_$arg_ptr(2,argpt,arglen,code);
112           if code ^= 0 then string2=""; else string2=argstring;
113           call cu_$arg_ptr(3,argpt,arglen,code);
114           if code ^= 0 then string3=""; else string3=argstring;
115 
116           if substr(string,1,8) = "source_l" then go to source_list_;
117           if substr(string,1,8) = "token_li" then go to token_list_;
118           if substr(string,1,8) = "statemen" then go to show_stm;
119           if substr(string,1,4) = "root"
120           then p = pl1_stat_$root;
121           else if substr(string,1,8) = "cur_bloc"
122           then p = pl1_stat_$cur_block;
123           else if substr(string,1,8) = "cur_stat"
124           then p = pl1_stat_$cur_statement;
125           else if substr(string,1,4) = "main"
126           then if pl1_stat_$root ^= null then p = pl1_stat_$root -> block.son; else goto null_ptr;
127           else if substr(string,1,4) = "arg "
128           then do;
129                n = cv_oct_(string2);
130                p = addr(p);
131                p = ptr(p,cv_oct_(string3));
132                if n > fixed(p -> arglist.number,17)
133                then do;
134                     call ioa_("no arg ^d",n);
135                     return;
136                     end;
137                p = p -> arglist.arg(n) -> based_ptr;
138                end;
139           else do;
140                if disp_xeq
141                     then p = pl1_stat_$xeq_tree_area_ptr;
142                     else p = pl1_stat_$root;
143                n = index(string,"|");
144                if n = 0 then p = ptr(p,cv_oct_(string));
145                else p = ptr(baseptr(cv_oct_(substr(string,1,n-1))),
146                 cv_oct_(substr(string,n+1)));
147                end;
148 
149           if p = null
150           then do;
151 null_ptr:
152                call ioa_("Pointer is null");
153                return;
154                end;
155 
156           if substr(string2,1,4) = "walk" then walk="1"b; else
157           if substr(string3,1,4) = "walk" then walk="1"b;
158           if substr(string2,1,8) = "no_dcls " then no_dcls="1"b; else
159           if substr(string3,1,8) = "no_dcls " then no_dcls="1"b;
160           if substr(string2,1,8) = "source  " then sourceb="1"b; else
161           if substr(string3,1,8) = "source  " then sourceb="1"b;
162 
163           n = fixed(p -> node.type,17,0);
164           if n > fixed(temporary_node,9,0) then n = 0;
165 
166           call ioa_("Displaying ^p",p);
167           goto switch(n);
168 
169 switch(0):
170 switch(7):
171 switch(17):
172           call display_any_node_name("No display program for",p,tree_level+1);
173           return;
174 
175 switch(1):
176           call display_block(p,walk,no_dcls,sourceb,tree_level+1);
177           return;
178 
179 switch(3):
180 switch(4):
181 switch(5):
182 switch(10):
183 switch(16):
184 switch(18):
185           call display_exp(p,tree_level+1);
186           return;
187 
188 switch(8):
189 switch(9):
190           call display_array(p,tree_level+1);
191           return;
192 
193 switch(11):
194           call display_list(p,tree_level+1);
195           return;
196 
197 switch(2):
198           call display_statement(p,sourceb,tree_level+1);
199           return;
200 
201 switch(6):
202 switch(12):
203 switch(15):
204           call display_symbol(p,tree_level+1);
205           return;
206 
207 switch(13):
208           call show_ms$pt(p);
209           return;
210 
211 switch(14):
212           call display_source(p,tree_level+1);
213           return;
214 
215 show_stm:
216           call show_statement(string2);
217           return;
218 
219 show_dcl:
220           ap1->argstring="";                      /* zap "dcl" */
221           call cu_$arg_list_ptr(argpt);
222           call cu_$gen_call(show_declaration,argpt);
223 
224 done:     return;
225 
226 token_list_:
227           n = cv_dec_(string2);
228           if n = 0 then n = 3000;
229           do k = 1 to n;
230                if token_list(k)=null then return;
231 
232                if t_table.type = semi_colon & n = 3000
233                then return;
234 
235                call display_exp(token_list(k),tree_level+1);
236           end;
237           return;
238 
239 source_list_:
240           m = pl1_stat_$last_source;
241           n = cv_dec_(string2);
242           if n = 0
243           then do;
244                     n = m;
245                     j = 0;
246                end;
247           else      j, n = min(n,m);
248           do i = j to n;
249                call display_source(source_list(i),tree_level+1);
250           end;
251           return;
252 
253 dix:      display_xeq:        entry;
254           disp_xeq = "1"b;
255           go to common;
256 
257           end display;