1
2
3
4
5
6
7
8
9
10
11 di: display: proc;
12
13
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
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="";
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;