1
2
3
4
5
6
7
8
9
10
11 db_sym: proc (line, a_sntp, data_ptr, offset, type, type_char, mode, a_size, m_size, code);
12
13
14
15
16
17
18 dcl line char (72) varying,
19 a_sntp ptr,
20 data_ptr ptr,
21 offset fixed bin,
22 type_char char (1) aligned,
23 mode char (*) aligned,
24 size fixed bin,
25 a_size fixed bin,
26 m_size fixed bin,
27 code fixed bin;
28
29
30 dcl (addr, addrel, baseno, divide, fixed, length, min, null, ptr, rel, substr, unspec) builtin;
31
32 dcl var_flag fixed bin;
33
34 dcl (type, n, i, j, steps) fixed bin,
35 f17 fixed bin based,
36 (p, stack_pt, found_block, symbol_pt, ref_pt) ptr,
37 current_block ptr,
38 packed_ptr based unaligned ptr,
39 based_ptr based ptr,
40 bn bit (18) aligned,
41 db_get_sym ext entry (ptr),
42 stu_$find_runtime_symbol entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr),
43 stu_$get_runtime_address entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
44 stu_$offset_to_pointer entry (ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
45 stu_$decode_runtime_value entry (fixed bin, ptr, ptr, ptr, ptr, ptr, fixed bin) returns (fixed bin);
46
47 dcl decode_type char (32) int static aligned
48 init ("oddfooooooooopoppoobvavoiiip");
49
50 %include db_snt;
51
52 %include stack_frame;
53 %include picture_image;
54
55 %include symbol_node;
56
57 %include runtime_symbol;
58 %include stu_frame;
59
60 sntp = a_sntp;
61 if sntp -> snt.symflag then call db_get_sym (sntp);
62 current_block = sntp -> snt.symp;
63
64 if current_block = null
65 then do;
66 err2: code = 2;
67 return;
68 end;
69
70 if baseno (sntp -> snt.lp) = "0"b then sntp -> snt.lp = null;
71
72 code = 0;
73
74 symbol_pt = db_var (1, (1), data_ptr, ref_pt, stack_pt);
75
76 if symbol_pt = null
77 then do;
78 err1: code = 1;
79 return;
80 end;
81
82 if data_ptr = null
83 then do;
84 err5: code = 5;
85 return;
86 end;
87
88
89
90 type = fixed (symbol_pt -> runtime_symbol.type, 6);
91
92 if type = 38 | type = 39 then mode = "comp-5";
93 else if type = 41 then mode = "comp-8";
94 else if type = 63 then do;
95 mode = "a";
96 p = ptr (snt.pp, symbol_pt -> runtime_symbol.size);
97 size = p -> picture_image.varlength;
98 type = 21;
99 goto l2;
100 end;
101 else mode = substr (decode_type, type+1, 1);
102 var_flag = 0;
103
104 if mode = "p" then do;
105 if symbol_pt -> runtime_symbol.packed then size = 36;
106 else size = 72;
107 go to l2;
108 end;
109
110 if mode = "v" then do;
111 var_flag = 1;
112 mode = substr (decode_type, type, 1);
113 a_size = data_ptr -> f17;
114 data_ptr = addrel (data_ptr, 1);
115 type = type - 1;
116 end;
117
118 size = symbol_pt -> symbol_node.size;
119 if size < 0
120 then do;
121 size = stu_$decode_runtime_value (size, found_block, stack_pt,
122 sntp -> snt.lp, sntp -> snt.pp, ref_pt, code);
123 if code ^= 0 then do;
124 code = 6;
125 return;
126 end;
127 end;
128
129
130 if type = 3|type = 4 then size = size + 8;
131
132 else if type = 14 then size = 36;
133
134
135 else if type = 38 then size = divide (size*9, 2, 17, 0);
136 else if type = 39 | type = 41 then size = divide ((size+1)*9, 2, 17, 0);
137
138 else if mode ^= "a" & mode ^= "b" then do;
139 if ^symbol_pt -> symbol_node.packed then
140 if size < 36 then size = 36;
141 else size = 72;
142 else size = size + 1;
143 end;
144
145 l2: bn = baseno (data_ptr);
146
147 m_size = size;
148 if var_flag = 0 then a_size = size;
149 else a_size = min (a_size, size);
150
151 if bn = baseno (sntp -> snt.sp)
152 then do;
153 type_char = "s";
154 offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.sp), 18);
155 return;
156 end;
157
158 if bn = baseno (sntp -> snt.static_ptr)
159 then do;
160 type_char = "i";
161 offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.static_ptr), 18);
162 return;
163 end;
164
165 if bn = baseno (sntp -> snt.lp)
166 then do;
167 type_char = "l";
168 offset = fixed (rel (data_ptr), 18) - fixed (rel (sntp -> snt.lp), 18);
169 return;
170 end;
171
172 type_char = "i";
173 offset = 0;
174 exit: return;
175
176 text_ref: data_ptr = ptr (sntp -> snt.pp, 0);
177 type_char = "t";
178 mode = "i";
179 goto l1;
180
181 link_ref: if rel (sntp -> snt.lp) = (18)"0"b
182 then do;
183 err3: code = 3;
184 return;
185 end;
186
187 data_ptr = sntp -> snt.lp;
188 type_char = "l";
189
190 l1: data_ptr = addrel (data_ptr, offset);
191 return;
192
193 err4: code = 4;
194 return;
195
196 err7: code = 7;
197 return;
198
199 err8: code = 8;
200 return;
201
202 err9: code = 9;
203 return;
204
205 err10: code = 10;
206 return;
207
208 err11: code = 11;
209 return;
210
211 err12: code = 12;
212 return;
213
214 err13: code = 13;
215 return;
216
217 err14: code = 14;
218 return;
219
220 err15: code = 15;
221 return;
222
223 db_var: proc (start_pos, end_pos, data_pt_out, ref_pt_out, stack_pt_out) returns (ptr);
224
225 dcl start_pos fixed bin,
226 end_pos fixed bin,
227 data_pt_out ptr,
228 ref_pt_out ptr,
229 stack_pt_out ptr;
230
231 dcl (p, q, s_pt, d_pt, r_pt, sp, dummy_pt, subs_pt) ptr,
232 (pos, n, m, val, type, steps, subscript (32)) fixed bin,
233 (thru, nosign) bit (1),
234 ch char (1),
235 db_get_count$dec entry (char (*) aligned, fixed bin, fixed bin) returns (fixed bin);
236
237 dcl char_type (0: 127) fixed bin int static
238 init ((33)0, 1, (2)0, 1, (9)0, 1, 0, (10)2, (7)0, (26)1, (4)0, 1, 0, (26)1, (5)0);
239
240
241
242
243
244
245 dcl line_ char (72) aligned;
246
247 dcl fix_single fixed bin (17) based,
248 fix_double fixed bin (53) based,
249 flt_single float bin (27) based,
250 flt_double float bin (63) based;
251
252 pos = start_pos;
253 thru = "0"b;
254 r_pt, d_pt, s_pt = null;
255
256 again: call sob;
257 if thru then goto err7;
258
259 n = pos;
260 loop: ch = substr (line, pos, 1);
261 type = char_type (fixed (unspec (ch), 9));
262
263 if type > 0
264 then do;
265 pos = pos + 1;
266 if pos <= length (line) then goto loop;
267 thru = "1"b;
268 end;
269
270 s_pt = stu_$find_runtime_symbol (current_block, substr (line, n, pos-n), found_block, steps);
271
272 if s_pt = null
273 then if steps = -2 then goto err11;
274 else if steps = -3 then goto err12;
275 else if steps = -5 then goto err13;
276 else goto err1;
277
278 if ^s_pt -> runtime_symbol.flag then go to err15;
279
280 subs_pt = null;
281
282 if thru
283 then do;
284 chk_tl: if n > 1 then goto ga;
285
286 offset = fixed (s_pt -> symbol_node.offset, 18);
287
288 if s_pt -> symbol_node.class = "1100"b
289 then if s_pt -> runtime_symbol.flag
290 then if s_pt -> runtime_symbol.type = "011000"b
291 then goto text_ref;
292 else if s_pt -> runtime_symbol.type = "011001"b
293 then go to err14; else;
294 else if s_pt -> symbol_node.type = "000000100101"b
295 then goto text_ref;
296 else if s_pt -> symbol_node.type = "000000100100"b
297 then go to err14;
298
299 if s_pt -> symbol_node.class = "1101"b
300 then if s_pt -> runtime_symbol.flag
301 then if s_pt -> runtime_symbol.type = "011010"b
302 then go to err14;
303 else go to link_ref;
304
305 else if s_pt -> symbol_node.type = "000000100100"b
306 then go to err14;
307 else go to link_ref;
308
309 goto ga;
310 end;
311
312 call sob;
313 if thru then goto chk_tl;
314
315 if ch ^= "(" then goto ga;
316
317 n = 1;
318 sub_loop: pos = pos + 1;
319 call sob;
320 if thru then goto err7;
321
322 val = 0;
323 nosign = "1"b;
324 type = char_type (fixed (unspec (ch), 9));
325
326 if type ^= 1 then goto s1;
327
328 p = db_var (pos, pos, q, dummy_pt, dummy_pt);
329
330 if p = null then goto err1;
331 if q = null then goto err1;
332
333 if p -> runtime_symbol.flag then type = fixed (p -> runtime_symbol.type, 6);
334 else do;
335 type = fixed (p -> symbol_node.type, 12);
336 if type > 16 then type = type - 16;
337 end;
338
339 if type = 1 then val = q -> fix_single;
340 else if type = 2 then val = q -> fix_double;
341 else if type = 3 then val = q -> flt_single;
342 else if type = 4 then val = q -> flt_double;
343 else goto err9;
344
345 nosign = "0"b;
346
347 call sob;
348 if thru then goto err7;
349
350 s1: if ch = "+" | ch = "-" | (type = 2 & nosign)
351 then do;
352 line_ = line;
353 val = val + db_get_count$dec (line_, pos, pos);
354 call sob;
355 if thru then goto err7;
356 end;
357
358 subscript (n) = val;
359
360 if ch = ","
361 then do;
362 n = n + 1;
363 if n > 32 then goto err8;
364 goto sub_loop;
365 end;
366
367 if ch ^= ")" then goto err7;
368
369 if n ^= fixed (s_pt -> symbol_node.ndims, 6) then goto err8;
370
371 if current_block -> runtime_block.flag
372 then if current_block -> runtime_block.fortran
373 then do i = 1 to divide (n, 2, 17, 0);
374 m = subscript (i);
375 subscript (i) = subscript (n-i+1);
376 subscript (n-i+1) = m;
377 end;
378
379 subs_pt = addr (subscript (1));
380
381 pos = pos + 1;
382 call sob;
383
384 ga:
385 sp = sntp -> snt.sp;
386
387 do i = 1 to steps while (sp ^= null);
388 sp = sp -> frame.display;
389 end;
390
391
392 d_pt = stu_$get_runtime_address (found_block, s_pt, sp, sntp -> snt.lp,
393 sntp -> snt.pp, r_pt, subs_pt);
394
395 if d_pt = null then goto err5;
396
397 if thru then goto done;
398
399 if substr (line, pos, 2) = "->"
400 then do;
401 pos = pos + 2;
402
403 if s_pt -> runtime_symbol.type = "001110"b
404 then do;
405 r_pt = stu_$offset_to_pointer (found_block, s_pt, d_pt,
406 sp, sntp -> snt.lp, sntp -> snt.pp);
407 go to again;
408 end;
409
410 if s_pt -> runtime_symbol.type ^= "001101"b
411 then if s_pt -> runtime_symbol.type ^= "011101"b
412 then goto err10;
413 if ^ s_pt -> runtime_symbol.flag
414 then if substr (s_pt -> symbol_node.type, 1, 6)
415 then goto err10;
416 if s_pt -> runtime_symbol.packed then r_pt = d_pt -> packed_ptr;
417 else r_pt = d_pt -> based_ptr;
418 goto again;
419 end;
420
421 done: end_pos = pos;
422 data_pt_out = d_pt;
423 ref_pt_out = r_pt;
424 stack_pt_out = sp;
425 return (s_pt);
426
427 sob: proc;
428
429 sl: if pos > length (line)
430 then do;
431 fini: thru = "1"b;
432 return;
433 end;
434
435 ch = substr (line, pos, 1);
436 if ch ^= " " then return;
437 pos = pos + 1;
438 goto sl;
439 end;
440
441
442 end db_var;
443 end;