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 db_sym: proc (line, a_sntp, data_ptr, offset, type, type_char, mode, a_size, m_size, code);
 12 
 13 
 14 /*        Modified Nov 72 to convert to PL/I V2 by R Coren.
 15    *      Modified Nov 72 for 6180 (remove check entry ) by Bill Silver.
 16    *      Modified 10/76 to add COBOL data types by S. Barr. */
 17 /* Changed to test for Version 1/pascal symbol table before testing data_ptr 10/14/83 S. Herbst */
 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                                                             /* ^L */
 50 %include db_snt;
 51 /* ^L */
 52 %include stack_frame;
 53 %include picture_image;
 54 /* ^L */
 55 %include symbol_node;
 56 /* ^L */
 57 %include runtime_symbol;
 58 %include stu_frame;
 59 /* ^L */
 60           sntp = a_sntp;                                    /* copy arg. */
 61           if sntp -> snt.symflag then call db_get_sym (sntp); /* attempt to get symbol pointer */
 62           current_block = sntp -> snt.symp;
 63 
 64           if current_block = null
 65           then do;
 66 err2:          code = 2;                                    /* no symbol table */
 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;                                    /* symbol not found */
 79                return;
 80           end;
 81 
 82           if data_ptr = null
 83           then do;
 84 err5:          code = 5;                                    /* couldn't get address */
 85                return;
 86           end;
 87 
 88 /* have Version II symbol node */
 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;                        /* PICTURE */
 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;        /* floating-point, add in bits for exp */
131 
132           else if type = 14 then size = 36;                           /* offset must be one fullword */
133 
134 /* packed decimal */
135           else if type = 38 then size = divide (size*9, 2, 17, 0);    /* unsigned */
136           else if type = 39 | type = 41 then size = divide ((size+1)*9, 2, 17, 0);        /* sign uses one digit */
137 
138           else if mode ^= "a" & mode ^= "b" then do;
139                if ^symbol_pt -> symbol_node.packed then     /* unpacked, round size up to word */
140                     if size < 36 then size = 36;
141                     else size = 72;
142                else size = size + 1;                        /* add sign bit to precision */
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;                                    /* no linkage */
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;                                         /* no stack frame */
194           return;
195 
196 err7:     code = 7;                                         /* syntax error */
197           return;
198 
199 err8:     code = 8;                                         /* array error */
200           return;
201 
202 err9:     code = 9;                                         /* value error */
203           return;
204 
205 err10:    code = 10;                                        /* based error */
206           return;
207 
208 err11:    code = 11;                                        /* more than 64 structure levels */
209           return;
210 
211 err12:    code = 12;                                        /* symbol too long */
212           return;
213 
214 err13:    code = 13;                                        /* ambiguous reference */
215           return;
216 
217 err14:    code = 14;                                        /* entry constant */
218           return;
219 
220 err15:    code = 15;                                        /* unsupported symbol table format (V1, Pascal) */
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,                                   /* start index in line */
226      end_pos fixed bin,                                     /* finish index in line (output) */
227      data_pt_out ptr,                                       /* ptr to datum (output) */
228      ref_pt_out ptr,                                        /* ref ptr for datum (output) */
229      stack_pt_out ptr;                                      /* stack pointer for datum (output) */
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 /*        char_type:          2     number
241    1     letter ! $ . _
242    0     other
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  /* check for label/entry constant */
289                     then if s_pt -> runtime_symbol.flag
290                          then if s_pt -> runtime_symbol.type = "011000"b
291                               then goto text_ref;           /* label constant is simple */
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 /* ext entry in */
302                               then go to err14;
303                               else go to link_ref;
304 
305                          else if s_pt -> symbol_node.type = "000000100100"b /* likewise */
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 /* offset */
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;