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 /* Procedure to create symbol table for PL/I
 12 
 13    Initial Version:  3 June 1970 by BLW
 14           Modified: 20 May 1971 by BLW
 15           Modified: 10 March 1972 by BLW for Version II
 16           Modified:  3 October 1972 by BLW
 17           Modified: 21 January 1973 by BLW for controlled
 18           Modified: 23 October 1973 by BLW for pictures
 19           Modified: 13 October 1975 by RAB to fix 1430
 20           Modified: 23 August 1976 by RAB to fix 1516
 21           Modified: 10 November 1976 by RAB to fix 1548
 22           Modified: 18 July 1977 to diagnose over-large separation between declarations of a var
 23           Modified: 17 July 1978 for unsigned binary by PCK
 24           Modified: 6 September 1978 by RAB to fix 1785
 25           Modified: 27 September 1978 by RAB to straighten out filling in the data_type field.
 26           Modified: 23 January 1979 by DS to fix bug 1817
 27           Modified: 25 Apr 1979 by PCK to implement 4-bit decimal.
 28           Modified: 25 March 1980 by M. N. Davidoff for new sym_sort_alphabetic calling sequence that is independent of
 29                     pl1_symbol_print.
 30           Modified: 830509 BIM for symbol.explicit_packed.
 31 */
 32 /* format: style3 */
 33 mst$block_nodes:
 34      proc (pt, father) returns (fixed bin (18));
 35 
 36 dcl       pt                  ptr,                          /* points at block node */
 37           father              fixed bin (18);               /* symbol location of father */
 38 
 39 dcl       (
 40           cg_static_$sym_base,
 41           cg_static_$sym_reloc_base,
 42           cg_static_$cur_block,
 43           cg_static_$root
 44           )                   ptr ext,
 45           cg_static_$table_option
 46                               bit (1) ext,
 47           cg_static_$compiler_name
 48                               char (12) varying ext,
 49           (
 50           cg_static_$cur_level,
 51           cg_static_$sym_pos,
 52           cg_static_$sym_origin
 53           )                   fixed bin ext;
 54 
 55 dcl       (p, p1, p2, bp, q, prev, sym_ptr, srp, cb, ref)
 56                               ptr,
 57           (base_list, offset_list, block_list, quick_list)
 58                               ptr int static,
 59           vec                 (0:5) fixed bin (18) int static,
 60           (max_n, min_n)      fixed bin int static,
 61           (sym_pos, sym_loc, prev_loc, i, k, j, jstart, delta, units)
 62                               fixed bin (18),
 63           co                  fixed bin (31),
 64           lgth                (0:6) fixed bin (16) int static init (1, 2, 4, 8, 16, 32, 64);
 65 dcl       get_data            bit (1) aligned;
 66 dcl       (n, dtype, inc)     fixed bin (18),
 67           next_offset         fixed bin (14),
 68           class               fixed bin (4);
 69 
 70 dcl       max_token_length    fixed bin int static init (256),
 71                                                             /* expected max length */
 72           1 tokens            (256 /* max_token_length */) int static,
 73             2 first           unal bit (18),                /* offset of first token with this length */
 74             2 last            unal bit (18);                /* offset of last token with this length */
 75 
 76 dcl       (addr, addrel, bit, divide, fixed, max, min, null, rel, string, substr, subtract)
 77                               builtin;
 78 
 79 dcl       mst$block_nodes     entry (ptr, fixed bin (18)) returns (fixed bin (18)),
 80           mst$data_nodes      entry (ptr, fixed bin (18)) returns (fixed bin (18));
 81 dcl       sym_sort_alphabetic$by_size
 82                               entry (ptr, fixed bin);
 83 dcl       create_list         entry (fixed bin) returns (ptr),
 84           e_v                 entry (ptr, fixed bin (35), ptr, fixed bin (31), fixed bin) returns (bit (36) aligned),
 85           error               entry (fixed bin, ptr, ptr);
 86 
 87 dcl       (
 88           ext_entry_in_type   init (26),
 89           ext_entry_out_type  init (27),
 90           int_entry_type      init (25),
 91           picture_type        init (63)
 92           )                   fixed bin static;
 93 
 94 dcl       reloc               (0:9) bit (36) aligned based;
 95 
 96 dcl       1 acc               aligned based,
 97             2 count           unal bit (9),
 98             2 string          unal char (n);
 99 
100 dcl       1 record            based,
101             2 next            ptr,
102             2 ptr             ptr,                          /* points at symbol for ptr base or offset area */
103             2 sym_loc         fixed bin;                    /* location of symbol node */
104 
105 %include pl1_tree_areas;
106 %include token_list;
107 %include block;
108 %include list;
109 %include operator;
110 %include statement;
111 %include token;
112 %include label;
113 %include symbol;
114 %include reference;
115 %include array;
116 %include nodes;
117 %include boundary;
118 %include declare_type;
119 %include token_types;
120 %include block_types;
121 %include op_codes;
122 %include system;
123 %include relbts;
124 %include reloc_lower;
125 %include runtime_symbol;
126 %include pl1_descriptor_type_fcn;
127 ^L
128 /* program */
129 
130           bp = pt;
131 
132           if bp = cg_static_$root
133           then do;
134                     base_list, offset_list, block_list, quick_list = null;
135                     max_n = 1;
136                     min_n = 1000;
137 
138                     do i = 1 to max_token_length;
139                          tokens.first (i), tokens.last (i) = "0"b;
140                     end;
141                end;
142 
143           sym_pos = cg_static_$sym_pos;
144           sym_ptr = addrel (cg_static_$sym_base, sym_pos);
145 
146           cg_static_$cur_block = bp;
147           cg_static_$cur_level = bp -> block.level;
148 
149           if bp -> block.block_type = begin_block
150           then goto b1;
151 
152           if bp -> block.main = null
153           then goto b1;
154           q = bp -> block.main -> statement.labels -> element (2) -> reference.symbol -> symbol.token;
155 
156           if q -> token.loc = "0"b
157           then call make_acc;
158 
159           sym_ptr -> runtime_block.name = bit (fixed (262144 + (fixed (q -> token.loc, 18) - sym_pos), 18), 18);
160 
161 b1:
162           bp -> block.symbol_block = sym_pos;
163 
164           p = create_list (2);
165           p -> element (2) = sym_ptr;
166           p -> element (1) = block_list;
167           block_list = p;
168 
169           sym_ptr -> runtime_block.flag = "1"b;
170           sym_ptr -> runtime_block.standard = "1"b;
171           sym_ptr -> runtime_block.quick = bp -> block.no_stack;
172 
173           if sym_ptr -> runtime_block.quick
174           then do;
175                     sym_ptr -> runtime_block.entry_info = bit (bp -> block.entry_info, 18);
176                     q = bp -> block.owner;
177                     call make_record (quick_list);
178                end;
179 
180           sym_ptr -> runtime_block.fortran = cg_static_$compiler_name = "fortran";
181           sym_ptr -> runtime_block.type = "011000"b;        /* 24 */
182           sym_ptr -> runtime_block.header = bit (fixed (262144 - sym_pos, 18), 18);
183           sym_ptr -> runtime_block.father = bit (fixed (262144 + (father - sym_pos), 18), 18);
184 
185           cg_static_$sym_pos = sym_pos + 10;
186           if sym_ptr -> runtime_block.quick
187           then cg_static_$sym_pos = cg_static_$sym_pos + 1;
188           p = bp -> block.declaration;
189           get_data = bp -> block.get_data;
190 
191           k = 0;
192           do while (p ^= null);
193                q = p;
194 
195                if p -> symbol.dcl_type = by_compiler
196                then goto step;
197 
198                if p -> node.type = label_node
199                then if cg_static_$table_option
200                     then goto yes;
201                     else goto step;
202 
203                if p -> symbol.cross_references = null & ^p -> symbol.allocate & ^get_data
204                then go to step;
205 
206                if p -> symbol.builtin
207                then goto step;
208                if p -> symbol.condition
209                then goto step;
210 
211                if p -> symbol.runtime ^= "0"b
212                then goto step;
213 
214                do while (q -> symbol.father ^= null);
215                     q = q -> symbol.father;
216                end;
217 
218                if q -> symbol.entry & q -> symbol.external & q -> symbol.constant & q -> symbol.initial = null
219                then goto step;
220 
221                if q -> symbol.put_in_symtab
222                then goto yes;
223                if get_data
224                then goto yes;
225                if ^cg_static_$table_option
226                then goto step;
227 
228 /* we have to set the qualifier fields of all reference nodes
229                   hanging from symbol nodes in a defined structure to point
230                   to the base reference of the defined variable */
231 
232 yes:
233                if q -> node.type = symbol_node
234                then if q -> symbol.defined
235                     then call set_qualifier (q, p -> symbol.reference -> reference.qualifier);
236 
237                sym_loc = mst$data_nodes (q, sym_pos);
238 
239                if sym_loc = 0
240                then goto step;
241 
242                k = k + 1;
243                token_list (k) = q;
244 
245 step:
246                p = p -> symbol.next;
247           end;
248 
249           if k = 0
250           then goto do_son;
251 
252           call sym_sort_alphabetic$by_size (pl1_stat_$token_list_ptr, (k));
253 
254           prev = null;
255           jstart = 1;
256 
257           do i = 1 to k;
258 
259                p = token_list (i);
260                if p -> node.type = label_node
261                then sym_loc = fixed (p -> label.symbol_table, 18);
262                else sym_loc = fixed (p -> symbol.runtime, 18);
263 
264                delta = sym_loc - sym_pos;
265 
266                if prev = null
267                then sym_ptr -> runtime_block.start = bit (delta, 18);
268                else do;
269                          n = sym_loc - prev_loc;
270                          if n > 0
271                          then prev -> runtime_symbol.brother = bit (fixed (n, 18), 18);
272                          else prev -> runtime_symbol.brother = bit (fixed (262144 + n, 18), 18);
273                     end;
274 
275                n = p -> symbol.token -> token.size;
276 
277                do j = jstart to 4;
278                     if n >= lgth (j)
279                     then if sym_ptr -> runtime_block.chain (j) = "0"b
280                          then do;
281                                    jstart = j + 1;
282                                    sym_ptr -> runtime_block.chain (j) = bit (delta, 18);
283                               end;
284                end;
285 
286                prev = addrel (cg_static_$sym_base, sym_loc);
287                prev_loc = sym_loc;
288 
289           end;
290 
291 do_son:
292           if bp -> block.son ^= null
293           then sym_ptr -> runtime_block.son = bit (fixed (mst$block_nodes ((bp -> block.son), sym_pos) - sym_pos, 18), 18);
294 
295           if bp -> block.brother ^= null
296           then sym_ptr -> runtime_block.brother =
297                     bit (fixed (mst$block_nodes ((bp -> block.brother), father) - sym_pos, 18), 18);
298 
299           if bp ^= cg_static_$root
300           then goto thru;
301 
302 /* make symbol table of based variable specify symbol table of variable
303              mentioned in the based(p) phrase */
304 
305           p = base_list;
306           do while (p ^= null);
307                sym_loc = p -> record.sym_loc;
308                q = addrel (cg_static_$sym_base, sym_loc);
309 
310                n = fixed (p -> record.ptr -> runtime, 18) - sym_loc;
311                if n >= 0
312                then q -> runtime_symbol.location = bit (fixed (n, 18), 18);
313                else q -> runtime_symbol.location = bit (fixed (262144 + n, 18), 18);
314 
315                p = p -> record.next;
316           end;
317 
318 /* make size field in symbol table of offset variable specify symbol
319              table of variable mentioned in the offset(a) phrase */
320 
321           p = offset_list;
322           do while (p ^= null);
323                sym_loc = p -> record.sym_loc;
324                addrel (cg_static_$sym_base, sym_loc) -> runtime_symbol.size =
325                     fixed (p -> record.ptr -> runtime, 18) - sym_loc;
326 
327                p = p -> record.next;
328           end;
329 
330 /* link quick blocks to their owners */
331 
332           p = quick_list;
333           do while (p ^= null);
334                sym_loc = p -> record.sym_loc;
335                q = addrel (cg_static_$sym_base, sym_loc);
336 
337                q -> runtime_block.owner_flag = "1"b;
338 
339                n = p -> record.ptr -> block.symbol_block - sym_loc;
340                if n >= 0
341                then q -> runtime_block.owner = bit (fixed (n, 18), 18);
342                else q -> runtime_block.owner = bit (fixed (262144 + n, 18), 18);
343 
344                p = p -> record.next;
345           end;
346 
347 /* link together the fragments of the token list */
348 
349           i = min_n;
350 
351 link:
352           sym_loc = fixed (tokens.last (i), 18);
353           p = addrel (cg_static_$sym_base, sym_loc);
354 
355           do j = i + 1 to max_n;
356                if tokens.first (j)
357                then do;
358                          k = fixed (tokens.first (j), 18) - sym_loc;
359                          if k >= 0
360                          then p -> runtime_token.next = bit (k, 18);
361                          else p -> runtime_token.next = bit (fixed (262144 + k, 18), 18);
362 
363                          i = j;
364                          goto link;
365                     end;
366           end;
367 
368 /* set vec(i) to location of first token whose length n
369              is such that 2 ** i <= n < 2 ** (i+1) */
370 
371           vec (0), vec (1), vec (2), vec (3), vec (4), vec (5) = 0;
372 
373           do i = 0 to 5;
374                do j = lgth (i) to lgth (i + 1);
375                     if tokens.first (j)
376                     then do;
377                               vec (i) = fixed (tokens.first (j), 18);
378                               goto next_i;
379                          end;
380                end;
381 next_i:
382           end;
383 
384 /* now set the token(i) field in all of the blocks we processed */
385 
386           p = block_list;
387           do while (p ^= null);
388                q = p -> element (2);
389 
390                sym_loc = fixed (rel (q), 18) - cg_static_$sym_origin;
391 
392                do i = 0 to 5;
393                     if vec (i) ^= 0
394                     then do;
395                               k = vec (i) - sym_loc;
396                               if k >= 0
397                               then q -> runtime_block.token (i) = bit (k, 18);
398                               else q -> runtime_block.token (i) = bit (fixed (262144 + k, 18), 18);
399                          end;
400                end;
401 
402                p = p -> element (1);
403           end;
404 
405 thru:
406           return (sym_pos);
407 
408 mst$data_nodes:
409      entry (pt, father) returns (fixed bin (18));
410 
411           p = pt;
412           cb = cg_static_$cur_block;
413 
414           if p -> node.type = symbol_node
415           then if p -> symbol.defined
416                then call check_defined (p -> symbol.equivalence);
417 
418           sym_pos = cg_static_$sym_pos;
419           sym_ptr = addrel (cg_static_$sym_base, sym_pos);
420 
421           q = p -> symbol.token;
422           if q -> token.loc = "0"b
423           then call make_acc;
424 
425           k = fixed (q -> token.loc, 18);
426           sym_ptr -> runtime_symbol.name = bit (fixed (262144 + k - sym_pos, 18), 18);
427 
428           p1 = addrel (cg_static_$sym_base, k - 1);
429           if p1 -> runtime_token.dcl
430           then do;
431                     next_offset =
432                          16384 + fixed (rel (addrel (p1, p1 -> runtime_token.dcl)), 18) - cg_static_$sym_origin - sym_pos;
433                     if next_offset > 0
434                     then sym_ptr -> runtime_symbol.next = bit (fixed (next_offset, 14), 14);
435                     else call error (366, null, p);
436                end;
437           p1 -> runtime_token.dcl = bit (fixed (sym_pos - k + 1, 18), 18);
438 
439           sym_ptr -> runtime_symbol.father = bit (fixed (262144 + (father - sym_pos), 18), 18);
440 
441           sym_ptr -> runtime_symbol.flag = "1"b;
442 
443           srp = addrel (cg_static_$sym_reloc_base, sym_pos);
444 
445           if p -> node.type = label_node
446           then goto lab;
447 
448           p -> runtime = bit (sym_pos, 18);
449 
450           sym_ptr -> runtime_symbol.level = bit (fixed (p -> symbol.level, 6), 6);
451 
452           sym_ptr -> runtime_symbol.aligned = p -> symbol.aligned;
453           sym_ptr -> runtime_symbol.packed = p -> symbol.packed | p -> symbol.explicit_packed;
454           if p -> symbol.scale >= 0
455           then sym_ptr -> runtime_symbol.scale = bit (fixed (p -> symbol.scale, 8), 8);
456           else sym_ptr -> runtime_symbol.scale = bit (fixed (256 + p -> symbol.scale, 8), 8);
457 
458           if ^p -> symbol.entry
459           then if p -> symbol.picture
460                then do;
461                          sym_ptr -> runtime_symbol.size = p -> symbol.general -> reference.symbol -> symbol.location;
462                          srp -> reloc (4) = rc_a_t;
463                     end;
464                else if p -> symtab_size = null
465                then sym_ptr -> runtime_symbol.size = p -> symbol.c_dcl_size;
466                else srp -> reloc (4) = e_v (p, sym_ptr -> runtime_symbol.size, (p -> symtab_size), 0, 1);
467 
468           ref = p -> symbol.reference;
469 
470           if p -> symbol.picture
471           then dtype = picture_type;
472 
473           else if p -> symbol.entry & p -> symbol.constant
474           then if p -> symbol.external
475                then if p -> symbol.initial ^= null
476                     then dtype = ext_entry_in_type;
477                     else dtype = ext_entry_out_type;
478                else dtype = int_entry_type;
479 
480           else do;
481                     dtype = pl1_descriptor_type (substr (string (p -> symbol.attributes), 1, 36), p -> symbol.c_dcl_size);
482 
483                     if p -> symbol.offset
484                     then do;
485                               q = p -> symbol.general;
486                               if q ^= null
487                               then if q -> node.type = reference_node
488                                    then if q -> reference.offset = null
489                                         then do;
490                                                   q = q -> reference.symbol;
491                                                   call make_record (offset_list);
492                                              end;
493                          end;
494                end;
495 
496           p2 = p;
497 
498           if p2 -> symbol.defined
499           then do;
500 
501 /* defined ok, change so actually encode storage class of
502                   base reference */
503 
504                     p2 = ref -> reference.qualifier -> reference.symbol;
505                     ref = p2 -> symbol.reference;
506                end;
507 
508           if p2 -> symbol.auto
509           then do;
510 
511                     if ref -> reference.qualifier = null
512                     then class = 1;
513                     else do;
514                               class = 2;
515                               p2 = ref -> reference.qualifier -> reference.symbol;
516                          end;
517 
518                     goto l2c;
519                end;
520 
521           if p2 -> symbol.based
522           then do;
523                     class = 3;
524 
525                     q = ref -> reference.qualifier;
526                     if q = null
527                     then goto l2;
528 
529                     if q -> node.type = reference_node
530                     then do;
531                               if q -> reference.offset ^= null
532                               then goto l2;
533 
534                               q = q -> reference.symbol;
535                               if q -> symbol.cross_references ^= null
536                               then call make_record (base_list);
537                          end;
538 
539                     goto l2;
540                end;
541 
542           if p2 -> symbol.parameter
543           then do;
544 
545                     if ref -> reference.qualifier -> node.type = operator_node
546                     then do;
547                               class = 9;
548                               if p2 -> symbol.father ^= null
549                               then p2 -> symbol.location = p2 -> symbol.father -> symbol.location;
550                          end;
551                     else do;
552                               class = 8;
553                               p2 = ref -> reference.qualifier -> reference.symbol;
554                          end;
555 
556                     goto l2c;
557                end;
558 
559           if p2 -> symbol.static
560           then do;
561 static:
562                     if p2 -> symbol.external
563                     then srp -> reloc (3) = rc_lp18;
564                     else srp -> reloc (3) = rc_is18;
565                     class = 4 + fixed (p2 -> symbol.external, 1);
566                     goto l2c;
567                end;
568 
569           if p2 -> symbol.constant
570           then do;
571                     if p2 -> symbol.file
572                     then goto static;
573 
574                     class = 12;
575                     goto l2c;
576                end;
577 
578           if p2 -> symbol.controlled
579           then do;
580                     class = 6 + fixed (p2 -> symbol.external, 1);
581                     goto l2c;
582                end;
583 
584           class = 0;
585 
586 l2c:
587           sym_ptr -> runtime_symbol.location = bit (fixed (p2 -> symbol.location, 18), 18);
588 l2:
589           sym_ptr -> runtime_symbol.class = bit (class, 4);
590 
591           ref = p -> symbol.reference;
592 
593           if class = 12
594           then srp -> reloc (3) = rc_t;                     /* text relocation */
595 
596           p2 = ref -> reference.offset;
597           co = ref -> reference.c_offset;
598 
599           units = ref -> reference.units;
600           if units = 0
601           then goto ec;
602 
603           if units = word_
604           then do;
605                     units = 0;
606                     goto ec;
607                end;
608 
609           if p2 = null
610           then goto ec;
611 
612           if p2 -> node.type ^= operator_node
613           then goto ec;
614 
615           if p2 -> op_code = mod_bit
616           then goto elim;
617           if p2 -> op_code = mod_byte
618           then goto elim;
619           if p2 -> op_code ^= mod_half
620           then goto ec;
621 
622 elim:
623           p2 = p2 -> operand (3);
624 
625 ec:
626           if p2 = null
627           then sym_ptr -> runtime_symbol.offset = co;
628           else srp -> reloc (5) = e_v (p, sym_ptr -> runtime_symbol.offset, p2, co, 2);
629 
630           call encode_runtime_units (sym_ptr -> runtime_symbol.units, sym_ptr -> runtime_symbol.use_digit, units);
631 
632           q = p -> symbol.array;
633 
634           if q = null
635           then do;
636                     if sym_ptr -> runtime_symbol.offset = 0
637                     then do;
638                               sym_ptr -> runtime_symbol.simple = "1"b;
639                               inc = 5;
640                          end;
641                     else inc = 6;
642                     goto l3;
643                end;
644 
645           units = q -> array.offset_units;
646           if units = word_
647           then units = 0;
648 
649           call encode_runtime_units (sym_ptr -> runtime_symbol.array_units, sym_ptr -> runtime_symbol.use_digit, units);
650 
651           sym_ptr -> runtime_symbol.ndims = bit (fixed (q -> number_of_dimensions, 6), 6);
652           inc = 7 + 3 * q -> number_of_dimensions;
653 
654           p2 = q -> symtab_virtual_origin;
655           if p2 = null
656           then sym_ptr -> runtime_symbol.virtual_org = q -> c_virtual_origin;
657           else srp -> reloc (6) = e_v (p, sym_ptr -> virtual_org, p2, (q -> c_virtual_origin), 3);
658 
659           p2 = addr (sym_ptr -> runtime_symbol.bounds (q -> number_of_dimensions));
660           i = inc - 1;
661           q = q -> array.bounds;
662 
663           do while (q ^= null);
664 
665                if q -> symtab_lower = null
666                then p2 -> runtime_bound.lower = q -> c_lower;
667                else srp -> reloc (i - 2) = e_v (p, p2 -> runtime_bound.lower, (q -> symtab_lower), 0, 4);
668 
669                if q -> symtab_upper = null
670                then p2 -> runtime_bound.upper = q -> c_upper;
671                else srp -> reloc (i - 1) = e_v (p, p2 -> runtime_bound.upper, (q -> symtab_upper), 0, 5);
672 
673                if q -> c_multiplier ^= 0
674                then p2 -> runtime_bound.multiplier = q -> c_multiplier;
675                else if q -> symtab_multiplier = null
676                then call error (339, null, p);
677                else srp -> reloc (i) = e_v (p, p2 -> runtime_bound.multiplier, (q -> symtab_multiplier), 0, 6);
678 
679                p2 = addrel (p2, -3);
680                q = q -> bound.next;
681                i = i - 3;
682 
683           end;
684 
685 l3:
686           cg_static_$sym_pos = sym_pos + inc;
687 
688           sym_ptr -> runtime_symbol.type = bit (fixed (dtype, 6), 6);
689 
690           q = p -> symbol.son;
691           if q = null
692           then goto done;
693 
694           prev_loc = mst$data_nodes (q, sym_pos);
695           sym_ptr -> runtime_symbol.son = bit (fixed (prev_loc - sym_pos, 18), 18);
696 
697           q = q -> symbol.brother;
698           do while (q ^= null);
699                sym_loc = mst$data_nodes (q, sym_pos);
700                addrel (cg_static_$sym_base, prev_loc) -> runtime_symbol.brother = bit (fixed (sym_loc - prev_loc, 18), 18);
701                prev_loc = sym_loc;
702                q = q -> symbol.brother;
703           end;
704 
705 done:
706 ret:
707           return (sym_pos);
708 
709 defined_error:
710           call error (306, null, p);
711           return (0);
712 
713 /* have label node */
714 
715 lab:
716           p -> label.symbol_table = bit (sym_pos, 18);
717           sym_ptr -> runtime_symbol.type = "011000"b;       /* label constant */
718 
719           if p -> label.array
720           then do;
721                     inc = 10;
722                     sym_ptr -> runtime_symbol.ndims = "000001"b;
723                     sym_ptr -> runtime_symbol.location = bit (fixed (p -> label.location, 18), 18);
724 
725                     sym_ptr -> runtime_symbol.virtual_org, sym_ptr -> runtime_symbol.bounds (1).lower = p -> label.low_bound;
726                     sym_ptr -> runtime_symbol.bounds (1).upper = p -> label.high_bound;
727                     sym_ptr -> runtime_symbol.bounds (1).multiplier = 1;
728                end;
729           else do;
730                     inc = 4;
731                     sym_ptr -> runtime_symbol.simple = "1"b;
732                end;
733 
734           sym_ptr -> runtime_symbol.class = "1100"b;
735           srp -> reloc (3) = rc_t;
736 
737           cg_static_$sym_pos = sym_pos + inc;
738 
739           goto ret;
740 
741 make_record:
742      proc (list_head);
743 
744 dcl       list_head           ptr;
745 
746 dcl       tp                  ptr;
747 
748           allocate record in (tree_area) set (tp);
749           tp -> record.next = list_head;
750           list_head = tp;
751 
752           tp -> record.sym_loc = sym_pos;
753           tp -> record.ptr = q;
754      end;
755 
756 set_qualifier:
757      proc (sym_pt, qual);
758 
759 dcl       sym_pt              ptr,                          /* points at symbol node */
760           qual                ptr unal;                     /* points at reference node*/
761 
762 dcl       sp                  ptr;
763 
764           sp = sym_pt;
765           do while (sp ^= null);
766                sp -> symbol.reference -> reference.qualifier = qual;
767                if sp -> symbol.son ^= null
768                then call set_qualifier ((sp -> symbol.son), qual);
769 
770                sp = sp -> symbol.brother;
771           end;
772 
773      end;
774 
775 check_defined:
776      proc (tree_in);
777 
778 dcl       tree_in             ptr unal,
779           tree                ptr,
780           i                   fixed bin;
781 
782           tree = tree_in;
783 
784           if tree = null
785           then return;
786 
787           if tree -> node.type = operator_node
788           then do i = 1 to tree -> operator.number;
789                     call check_defined (tree -> operand (i));
790                end;
791 
792           else if tree -> node.type = list_node
793           then do i = 1 to tree -> list.number;
794                     call check_defined (tree -> element (i));
795                end;
796 
797           else if tree -> node.type = reference_node
798           then call check_defined (tree -> reference.offset);
799 
800           else if tree -> node.type = token_node
801           then do;
802                     if tree -> token.type = asterisk
803                     then goto defined_error;
804                     if tree -> token.type = isub
805                     then goto defined_error;
806                end;
807 
808      end;
809 
810 make_acc:
811      proc;
812 
813 dcl       k                   fixed bin (18),
814           (tp1, tp2, tp3)     ptr;
815 
816 /* this procedure is called to add a token to the list of tokens being
817                   maintained in the symbol buffer. tokens.first(n) specifies the first
818                  token on the list of tokens of size n, tokens.last(n) specifies
819                  the last token on the list */
820 
821           n = q -> token.size;
822           min_n = min (n, min_n);
823           max_n = max (n, max_n);
824 
825           tp1 = addrel (sym_ptr, 1);
826           tp1 -> acc.string = q -> token.string;
827           tp1 -> acc.count = bit (fixed (n, 9), 9);
828 
829           q -> token.loc = bit (fixed (sym_pos + 1, 18), 18);
830 
831           if tokens.first (n) = (18)"0"b
832           then do;
833                     tokens.first (n), tokens.last (n) = bit (sym_pos, 18);
834                     goto bump;
835                end;
836 
837           tp2 = null;
838           tp3 = addrel (cg_static_$sym_base, tokens.first (n));
839           do while (tp3 ^= null);
840                if addrel (tp3, 1) -> acc.string > tp1 -> acc.string
841                then do;
842                          if tp2 = null
843                          then tokens.first (n) = bit (sym_pos, 18);
844                          else do;
845                                    k = sym_pos - fixed (rel (tp2), 18) + cg_static_$sym_origin;
846                                    if k >= 0
847                                    then tp2 -> runtime_token.next = bit (k, 18);
848                                    else tp2 -> runtime_token.next = bit (fixed (262144 + k, 18), 18);
849                               end;
850 
851                          k = fixed (rel (tp3), 18) - cg_static_$sym_origin - sym_pos;
852                          if k >= 0
853                          then sym_ptr -> runtime_token.next = bit (k, 18);
854                          else sym_ptr -> runtime_token.next = bit (fixed (262144 + k, 18), 18);
855 
856                          goto bump;
857                     end;
858 
859                tp2 = tp3;
860                if tp3 -> runtime_token.next
861                then tp3 = addrel (tp3, tp3 -> runtime_token.next);
862                else tp3 = null;
863           end;
864 
865 /* new token belongs at end of list */
866 
867           tokens.last (n) = bit (sym_pos, 18);
868           k = sym_pos - fixed (rel (tp2), 18) + cg_static_$sym_origin;
869           if k >= 0
870           then tp2 -> runtime_token.next = bit (k, 18);
871           else tp2 -> runtime_token.next = bit (fixed (262144 + k, 18), 18);
872 
873 /* update position in symbol buffer by number of words in string plus 1 */
874 
875 bump:
876           k = divide (n + 4, 4, 17, 0) + 1;
877           sym_ptr = addrel (sym_ptr, k);
878           sym_pos = sym_pos + k;
879 
880      end;                                                   /* Convert internal encoding of offset units to external (runtime symbol table) encoding */
881 
882 encode_runtime_units:
883      procedure (runtime_units, half_really_digit, internal_units);
884 
885 /* parameters */
886 
887 dcl       runtime_units       bit (2) unaligned;
888 dcl       half_really_digit   bit (1) unaligned;
889 dcl       internal_units      fixed bin (18);
890 
891           if internal_units <= bit_
892           then runtime_units = bit (fixed (internal_units, 2), 2);
893           else if internal_units = digit_
894           then do;
895                     runtime_units = bit (fixed (character_, 2), 2);
896                     half_really_digit = "1"b;               /* External encoding of half_
897                                                                is numerically equal to the internal encoding of char_ */
898                end;
899           else runtime_units = bit (subtract (internal_units, 1, 2, 0), 2);
900 
901      end /* encode_runtime_units */;
902 
903      end /* mst */;