1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Bull Inc., 1988                *
  6         *                                                         *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  8         *                                                         *
  9         * Copyright (c) 1972 by Massachusetts Institute of        *
 10         * Technology and Honeywell Information Systems, Inc.      *
 11         *                                                         *
 12         *********************************************************** */
 13 
 14 
 15 
 16 
 17 /****^  HISTORY COMMENTS:
 18   1) change(88-01-26,RWaters), approve(88-01-26,MCR7724), audit(88-02-05,Huen),
 19      install(88-02-16,MR12.2-1024):
 20      Expand the uses of options (constant) variables.
 21   2) change(88-02-22,RWaters), approve(88-02-22,PBF7724), audit(88-02-25,Huen),
 22      install(88-03-08,MR12.2-1034):
 23      Limit options(constant) expansions.
 24   3) change(89-02-28,RWaters), approve(89-02-28,MCR8069), audit(89-09-07,Vu),
 25      install(89-09-19,MR12.3-1068):
 26      Moved code from validate.pl1 to get_scale() to correctly diagnose
 27      illegal scale values.
 28   4) change(89-09-27,RWaters), approve(89-09-27,MCR8068), audit(89-09-27,Vu),
 29      install(89-10-02,MR12.3-1080):
 30      Fixed so that it doesn't flag duplicate attributes as fatal errors.
 31   5) change(91-01-18,Blackmore), approve(91-01-18,MCR8234),
 32      audit(91-12-05,Huen), install(92-04-24,MR12.5-1011):
 33      Change dcls of 'constant_token' and 'defer_constant_token_list' entries
 34      for the constant reference resolution fix.
 35                                                    END HISTORY COMMENTS */
 36 
 37 
 38 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
 39 attribute_parse:
 40      procedure (cblock, sp, k, in_generic);
 41 
 42 /*        This procedure is called to parse the attributes occuring in
 43           declare statements, in the returns( ) entry( ) attributes,
 44           and in the when( ) clause of the generic( ) attribute.
 45           Note that this procedure must be called with k (the index into
 46           the token_list) pointing to the token immediately before the
 47           attributes (if any). When it returns, k will have been advanced
 48           past any|all attributes, and will be on a comma, right_paren,
 49           or semi_colon.   */
 50 
 51 /* Modified 780629 by PG for unsigned */
 52 /* Modified 780807 by PG to fix 1652 (diagnose > 127 dimensions) */
 53 /* Modified 780824 by RAB to fix 1776 (unsigned & signed not diagnosed as nonstandard) */
 54 /* Modified 830427 by BIM for ptr options (packed) */
 55 /* Modified 880128 by RW to fix 1994 and 2186 */
 56 /* Modified 890307 by RW to correctly test scale values in get_scale() */
 57 
 58 
 59 /* parameters */
 60 
 61 dcl      (
 62          cblock ptr,
 63          sp ptr,
 64          k fixed bin (15),
 65          in_generic bit (1) aligned
 66          ) parameter;
 67 
 68 /* automatic */
 69 
 70 dcl      (p, q, p1, p2) ptr;
 71 dcl      (i, letterx, ndims) fixed bin;
 72 dcl      type bit (9) aligned;
 73 dcl      word char (11);
 74 dcl      (defined_parn, first_time, star) bit (1) aligned;
 75 
 76 /* builtins */
 77 
 78 dcl      (binary, null, string, substr, unspec) builtin;
 79 
 80 /* external static */
 81 
 82 dcl      pl1_stat_$one ptr external static;
 83 dcl      pl1_stat_$check_ansi bit (1) aligned ext static;
 84 
 85 /* internal static */
 86 
 87 dcl      action_index (82) fixed bin (8) unal internal static initial (0,
 88                                                             /* aligned */
 89               2,                                            /* area */
 90               0,                                            /* auto */
 91               0,                                            /* automatic */
 92               4,                                            /* based */
 93               3,                                            /* bin */
 94               3,                                            /* binary */
 95               2,                                            /* bit */
 96               0,                                            /* builtin */
 97               2,                                            /* char */
 98               2,                                            /* character */
 99               3,                                            /* complex */
100               0,                                            /* cond */
101               0,                                            /* condition */
102               0,                                            /* constant */
103               0,                                            /* controlled */
104               3,                                            /* cplx */
105               0,                                            /* ctl */
106               3,                                            /* dec */
107               3,                                            /* decimal */
108               8,                                            /* def */
109               8,                                            /* defined */
110               16,                                           /* dim */
111               16,                                           /* dimension */
112               0,                                            /* direct */
113               12,                                           /* entry */
114               10,                                           /* env */
115               10,                                           /* environment */
116               0,                                            /* ext */
117               0,                                            /* external */
118               0,                                            /* file */
119               3,                                            /* fixed */
120               3,                                            /* float */
121               0,                                            /* format */
122               15,                                           /* generic */
123               9,                                            /* init */
124               9,                                            /* initial */
125               0,                                            /* input */
126               0,                                            /* int */
127               0,                                            /* internal */
128               18,                                           /* irred */
129               18,                                           /* irreducible */
130               0,                                            /* keyed */
131               13,                                           /* label */
132               14,                                           /* like */
133               0,                                            /* local */
134               0,                                            /* member */
135               0,                                            /* nonvar */
136               0,                                            /* nonvarying */
137               5,                                            /* offset */
138               17,                                           /* options */
139               0,                                            /* output */
140               0,                                            /* parameter */
141               0,                                            /* parm */
142               6,                                            /* pic */
143               6,                                            /* picture */
144               0,                                            /* pointer */
145               7,                                            /* pos */
146               7,                                            /* position */
147               3,                                            /* prec */
148               3,                                            /* precision */
149               0,                                            /* print */
150               0,                                            /* ptr */
151               3,                                            /* real */
152               0,                                            /* record */
153               18,                                           /* red */
154               18,                                           /* reducible */
155               11,                                           /* returns */
156               0,                                            /* seql */
157               0,                                            /* sequential */
158               18,                                           /* signed */
159               0,                                            /* static */
160               0,                                            /* stream */
161               0,                                            /* structure */
162               0,                                            /* unal */
163               0,                                            /* unaligned */
164               18,                                           /* uns */
165               18,                                           /* unsigned */
166               0,                                            /* update */
167               0,                                            /* var */
168               0,                                            /* variable */
169               0 /* varying */);
170 
171 dcl      constant_token entry (ptr, ptr, bit (9) aligned, bit (9) aligned) returns (bit (9));
172 dcl      defer_constant_token_list entry (ptr, fixed bin, bit (9) aligned);
173 ^L
174 /* program */
175 
176           p = sp;                                           /* copy parameter into automatic */
177           first_time = "1"b;
178           go to next;
179 ck_parn:
180           if t_table.type ^= right_parn then
181                call print (11);
182 next:
183           k = k + 1;
184 find_type:
185           if token_list (k) = null then
186                call print (7);
187           type = t_table.type;
188 action (0):
189 test:
190           if (type = comma) | (type = semi_colon) | (type = right_parn) then do;
191                sp = p;                                      /* assign to parameter */
192 
193                if p -> symbol.varying then do;
194                     p -> symbol.aligned = "1"b;
195                     p -> symbol.unaligned = "0"b;
196                end;
197 
198                return;
199           end;
200           if first_time then do;
201                first_time = "0"b;
202                if type = left_parn then
203                     go to action (16);
204           end;
205           if type ^= identifier then
206                call print (7);
207           word = t_table.string;
208           letterx = binary (unspec (substr (word, 1, 1)), 9);
209           do i = index_given_letter (letterx) by 1 while (keyword (i) < word);
210           end;
211 
212           if keyword (i) = word then do;
213                substr (string (p -> symbol.attributes), bit_index (i), 1) = "1"b;
214                k = k + 1;
215                type = t_table.type;
216                go to action (action_index (i));
217           end;
218 
219           call print (7);
220 action (1):
221           call print (8);
222           return;
223 action (2):                                                 /* get size of strings or areas */
224           if type ^= left_parn then
225                go to test;
226           k = k + 1;
227 
228           p -> symbol.dcl_size = refer_exp ();
229           if p -> symbol.dcl_size = null then
230                call print (12);
231           go to ck_parn;
232 action (3):                                                 /* get arithmetic precision */
233           if type ^= left_parn then
234                go to test;
235           p -> symbol.precision = "1"b;
236           k = k + 1;
237           if constant_token (cblock, token_list (k), "777"b3, dec_integer) ^= dec_integer then
238                call print (15);
239           p -> symbol.c_dcl_size = token_to_binary (token_list (k));
240           if p -> symbol.c_dcl_size = 0 then
241                call print (490);
242           k = k + 1;
243           if in_generic then
244                if t_table.type = colon then do;
245                     k = k + 1;
246                     if constant_token (cblock, token_list (k), "777"b3, dec_integer) ^= dec_integer then
247                          call print (15);
248                     p -> symbol.pic_size = token_to_binary (token_list (k));
249                     k = k + 1;
250                end;
251                else
252                     p -> symbol.pic_size = p -> symbol.c_dcl_size;
253           if t_table.type = comma then do;
254                p -> symbol.scale = get_scale ();
255                p -> symbol.fixed = "1"b;
256                if in_generic then
257                     if t_table.type = colon then
258                          p -> symbol.pic_scale = get_scale ();
259                     else
260                          p -> symbol.pic_scale = p -> symbol.scale;
261           end;
262           go to ck_parn;
263 action (4):                                                 /* process the based attribute */
264           if type ^= left_parn then
265                go to test;
266           k = k + 1;
267           p -> symbol.reference -> reference.qualifier = reference_parse (k, cblock);
268           if p -> symbol.reference -> reference.qualifier = null then
269                call print (18);
270           if p -> symbol.reference -> reference.qualifier -> node.type = token_node then
271                call context ((p -> symbol.reference -> reference.qualifier), cblock, pointer_context);
272           go to ck_parn;
273 action (5):                                                 /* process the offset attribute */
274           if type ^= left_parn then
275                go to test;
276           k = k + 1;
277           p -> symbol.general = reference_parse (k, cblock);
278           if p -> symbol.general = null then
279                call print (17);
280           if p -> symbol.general -> node.type = token_node then
281                call context ((p -> symbol.general), cblock, area_context);
282           go to ck_parn;
283 action (6):                                                 /* process the picture attribute */
284           if type ^= char_string then
285                go to test;
286           p -> symbol.general = token_list (k);
287           go to next;
288 action (7):                                                 /* process the position attribute */
289           if type ^= left_parn then
290                go to test;
291           k = k + 1;
292           p -> symbol.initial = expression_parse (k, cblock);
293           if p -> symbol.initial = null then
294                call print (26);
295           go to ck_parn;
296 action (8):                                                 /* process the defined attribute */
297           defined_parn = "0"b;
298           if type = left_parn then do;
299                defined_parn = "1"b;
300                k = k + 1;
301           end;
302           p -> symbol.equivalence = reference_parse (k, cblock);
303           if p -> symbol.equivalence = null then
304                call print (24);
305           if defined_parn then
306                go to ck_parn;
307           else
308                go to find_type;
309 action (9):                                                 /* process the initial attribute */
310           if type ^= left_parn then
311                go to test;
312           if p -> symbol.initial ^= null then
313                call print (19);
314           p -> symbol.initial = initial_list (p);
315           if p -> symbol.initial = null then
316                call print (20);
317           go to find_type;
318 
319 action (10):                                                /* environment */
320           if type ^= left_parn then
321                go to test;
322           k = k + 1;
323           if t_table.string = "interactive" then
324                p -> symbol.interactive = "1"b;
325           else if t_table.string = "stringvalue" then
326                p -> symbol.stringvalue = "1"b;
327           else
328                call print (193);
329           k = k + 1;
330           if pl1_stat_$check_ansi then
331                call parse_error (355, token_list (k - 3));
332           go to ck_parn;
333 
334 action (11):                                                /* process the returns attribute */
335           if type ^= left_parn then
336                go to test;
337           q = descriptor_parse (cblock,
338                create_token (p -> symbol.token -> t_table.string || "[return_value]", identifier), k);
339           if q ^= null then do;
340                if q -> list.element (2) ^= null then
341                     call print (22);
342                p -> symbol.dcl_size, q = q -> list.element (1);
343                q -> symbol.passed_as_arg = "1"b;
344           end;
345           go to ck_parn;
346 
347 action (12):                                                /* process the entry attribute */
348           if type ^= left_parn then
349                go to test;
350           p -> symbol.general =
351                descriptor_parse (cblock, create_token (p -> symbol.token -> t_table.string || "[param", identifier), k);
352           if p -> symbol.general = null then do;            /* entry() -- add wart: a zero list node to prevent defaulting */
353                                                             /* this wart will be removed by validate after defaulting is complete */
354 
355                p -> symbol.general = create_list (0);
356           end;
357           go to ck_parn;
358 
359 action (13):                                                /* process the label attribute */
360           if type ^= left_parn then
361                go to test;
362 
363           call print (6);
364 
365 nxt:
366           k = k + 1;
367           if t_table.type ^= identifier then
368                call print (21);
369           k = k + 1;
370           if t_table.type = comma then
371                go to nxt;
372           go to ck_parn;
373 
374 action (14):                                                /* process the like attribute */
375           p -> symbol.general = reference_parse (k, cblock);
376           if p -> symbol.general = null then
377                call print (25);
378           cblock -> block.like_attribute = "1"b;
379           go to find_type;
380 action (15):                                                /* process the generic attribute        */
381           if t_table.type ^= left_parn then
382                go to test;
383           q = null;
384 next_entry:
385           k = k + 1;
386           p1 = create_list (3);
387           p1 -> list.element (1) = reference_parse (k, cblock);
388           if p1 -> list.element (1) = null then
389                call print (13);
390           if t_table.string ^= "when" then
391                call print (13);
392           k = k + 1;
393           if t_table.type ^= left_parn then
394                call print (13);
395           p1 -> list.element (2) = descriptor_parse (null, null, k);
396           if t_table.type ^= right_parn then
397                call print (13);
398           k = k + 1;
399           p1 -> list.element (3) = null;
400           if q ^= null then
401                p2 -> list.element (3) = p1;
402           else
403                q = p1;
404           p2 = p1;
405           if t_table.type = comma then
406                go to next_entry;
407           p -> symbol.general = q;
408           go to ck_parn;
409 action (16):                                                /* process the dimension attribute  */
410           if t_table.type ^= left_parn then
411                go to test;
412           p -> symbol.dimensioned = "1"b;
413           p -> symbol.array = create_array ();
414           ndims = 0;
415 next_b:
416           ndims = ndims + 1;
417           k = k + 1;
418           p1 = pl1_stat_$one;
419           p2 = refer_exp ();
420           if p2 = null then
421                call print (9);
422           if ^star then
423                if t_table.type = colon then do;
424                     k = k + 1;
425                     p1 = p2;
426                     p2 = refer_exp ();
427                     if p2 = null then
428                          call print (9);
429                end;
430                else
431                     ;
432           else
433                p1 = p2;
434 
435           if ndims <= max_number_of_dimensions then do;
436                q = create_bound ();
437                q -> bound.next = p -> symbol.array -> array.bounds;
438                p -> symbol.array -> array.bounds = q;
439                q -> bound.lower = p1;
440                q -> bound.upper = p2;
441           end;
442           if t_table.type = comma then
443                go to next_b;
444 
445           if ndims > max_number_of_dimensions then do;
446                call parse_error (372, p);
447                ndims = max_number_of_dimensions;
448           end;
449           p -> symbol.array -> array.own_number_of_dimensions = ndims;
450           if t_table.type ^= right_parn then
451                call print (10);
452           go to next;
453 
454 action (17):                                                /* options */
455           if type ^= left_parn then
456                go to test;
457           k = k + 1;
458           if t_table.string = "variable" then
459                p -> symbol.variable_arg_list = "1"b;
460           else if t_table.string = "constant" then
461                p -> symbol.alloc_in_text = "1"b;
462           else if t_table.string = "packed" then
463                p -> symbol.explicit_packed = "1"b;
464           else
465                call print (192);
466           k = k + 1;
467           if pl1_stat_$check_ansi then
468                call parse_error (355, token_list (k - 3));
469           go to ck_parn;
470 
471 action (18):                                                /* nonstandard attributes */
472           if pl1_stat_$check_ansi then
473                call parse_error (354, token_list (k - 1));
474           go to test;
475 ^L
476 /* Internal procedures */
477 
478 get_scale:
479      proc () returns (fixed bin (7) unaligned);
480 
481 dcl      temp fixed bin;
482 
483           k = k + 1;
484           call defer_constant_token_list (cblock, (k), right_parn);
485           p1 = expression_parse (k, cblock);
486           if p1 = null then
487                call print (15);
488           if p1 -> node.type ^= token_node then
489                call print (15);
490           if p1 -> t_table.type ^= dec_integer then
491                call print (15);
492           temp = token_to_binary (p1);
493 
494 /* This code yanked from validate.pl1.  We have to test "temp" before it
495 gets stuffed into a fixed bin(7) variable upon returning.
496 */
497           if temp < min_scale then do;
498                call parse_error (222, (p -> symbol.token));
499                return (min_scale);
500           end;
501           else if temp > max_scale then do;
502                call parse_error (222, (p -> symbol.token));
503                return (max_scale);
504           end;
505 
506           return (temp);
507 
508      end get_scale;
509 
510 refer_exp:
511      proc () returns (ptr);
512 
513 dcl      (p1, p2) ptr;
514 
515           star = "0"b;
516           if t_table.type = asterisk then do;
517                p1 = token_list (k);
518                star, p -> symbol.star_extents = "1"b;
519                k = k + 1;
520                go to exit;
521           end;
522           call defer_constant_token_list (cblock, (k), right_parn);
523           p1 = expression_parse (k, cblock);
524           if p1 = null then
525                go to fail;
526           if p1 -> node.type = token_node then
527                if p1 -> t_table.type ^= dec_integer then
528                     p -> symbol.exp_extents = "1"b;
529                else
530                     ;
531           else
532                p -> symbol.exp_extents = "1"b;
533           if t_table.string ^= "refer" then
534                go to exit;
535           k = k + 1;
536           p -> symbol.exp_extents, p -> symbol.refer_extents = "1"b;
537           if t_table.type ^= left_parn then
538                go to fail;
539           k = k + 1;
540           p2 = p1;
541           p1 = create_operator (refer, 2);
542           p1 -> operand (1) = p2;
543           p1 -> operand (2) = reference_parse (k, cblock);
544           if p1 -> operand (2) = null then
545                go to fail;
546           if p1 -> operand (2) -> node.type = reference_node then do;
547                if p1 -> operand (2) -> reference.qualifier ^= null then
548                     call declare_parse$abort (138, (p1 -> operand (2)));
549                if p1 -> operand (2) -> reference.offset ^= null then
550                     call declare_parse$abort (138, (p1 -> operand (2)));
551           end;
552           if t_table.type ^= right_parn then
553                go to fail;
554           k = k + 1;
555 
556 exit:
557           return (p1);
558 fail:
559           return (null);
560      end;
561 
562 initial_list:
563      proc (sym_ptr) returns (ptr);
564 
565 dcl      (ap, factor, value, p1, p2) ptr;
566 dcl      something_parsed bit (1) aligned;
567 dcl      sym_ptr ptr;
568 
569           p2 = null;
570           do while ("1"b);
571                something_parsed = "0"b;
572                k = k + 1;
573                if t_table.type = left_parn then do;
574                     k = k + 1;
575                     if ^(sym_ptr -> symbol.ptr | sym_ptr -> symbol.offset | sym_ptr -> symbol.area
576                          | sym_ptr -> symbol.label | sym_ptr -> symbol.entry | sym_ptr -> symbol.file) then
577                          call defer_constant_token_list (cblock, (k), right_parn);
578                     factor = expression_parse (k, cblock);
579                     if factor = null then
580                          go to fail;
581                     if t_table.type ^= right_parn then
582                          go to fail;
583                     k = k + 1;
584                     something_parsed = "1"b;
585                end;
586                else
587                     factor = pl1_stat_$one;
588                if t_table.type = asterisk then do;
589                     value = null;
590                     k = k + 1;
591                end;
592                else do;
593                     if t_table.type = left_parn then do;
594                          if ^(sym_ptr -> symbol.ptr | sym_ptr -> symbol.offset | sym_ptr -> symbol.area
595                               | sym_ptr -> symbol.label | sym_ptr -> symbol.entry | sym_ptr -> symbol.file) then
596                               call defer_constant_token_list (cblock, (k), right_parn);
597                          value = initial_list (sym_ptr);
598                          if value = null then
599                               go to fail;
600                     end;
601                     else if something_parsed & (t_table.type = right_parn | t_table.type = comma) then do;
602                          value = factor;
603                          factor = pl1_stat_$one;
604                     end;
605                     else do;
606                          if ^(sym_ptr -> symbol.ptr | sym_ptr -> symbol.offset | sym_ptr -> symbol.area
607                               | sym_ptr -> symbol.label | sym_ptr -> symbol.entry | sym_ptr -> symbol.file) then
608                               call defer_constant_token_list (cblock, (k), right_parn);
609                          value = expression_parse (k, cblock);
610                          if value = null then
611                               go to fail;
612                     end;
613                end;
614                p1 = create_list (3);
615                p1 -> list.element (1) = factor;
616                p1 -> list.element (2) = value;
617                p1 -> list.element (3) = null;
618                if p2 = null then
619                     ap = p1;
620                else
621                     p2 -> list.element (3) = p1;
622                p2 = p1;
623                if t_table.type = right_parn then do;
624                     k = k + 1;
625                     return (ap);
626                end;
627                if t_table.type ^= comma then
628                     go to fail;
629           end;
630 fail:
631           return (null);
632      end initial_list;
633 
634 print:
635      proc (m);
636 
637 dcl      m fixed bin (15);
638 
639           sp = p;                                           /* assign to parameter */
640           call declare_parse$abort (m, (p -> symbol.token));
641      end print;
642 ^L
643 %include parse;
644 
645 %include array;
646 %include block;
647 %include context_codes;
648 %include list;
649 %include nodes;
650 %include op_codes;
651 %include operator;
652 %include pl1_attribute_table;
653 %include reference;
654 %include symbol;
655 %include system;
656 %include token_list;
657 %include token_types;
658      end /* attribute_parse */;