1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Bull Inc., 1987                *
  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 /****^  HISTORY COMMENTS:
 17   1) change(87-04-15,RWaters), approve(87-04-15,MCR7635), audit(87-04-28,Huen),
 18      install(87-05-21,MR12.1-1033):
 19      Fix bug #2144
 20   2) change(89-02-28,RWaters), approve(89-02-28,MCR8068), audit(89-09-07,Vu),
 21      install(89-09-19,MR12.3-1068):
 22      Fix bugs 1737 & 1873
 23   3) change(90-08-30,Huen), approve(90-08-30,MCR8160),
 24      audit(90-09-07,Zimmerman), install(90-10-17,MR12.4-1046):
 25      pl1_2221: Fix the PL1 compiler to not complain about constant symbols that
 26      are actually legal.
 27   4) change(90-10-17,Gray), approve(90-10-17,MCR8160), audit(90-10-19,Schroth),
 28      install(90-10-25,MR12.4-1049):
 29      Modified to only validate constants for symbols declared by dcl statement.
 30                                                    END HISTORY COMMENTS */
 31 
 32 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9,idind23 */
 33 validate:
 34      proc (sp);
 35 
 36 /* Modified 780314 by PG to fix 1673 (don't default constants unless default statement explicitly touches constants)
 37           and to print error 206 only if none of the attribute sets are consistent.
 38    Modified 780629 by PG for unsigned
 39    Modified 780712 by PG to diagnose liking to a structure containing refer extents
 40    Modified 780725 by PG to move responsibility for setting the aliasable bit to declare and declare_structure.
 41    Modified 780731 by PG to use adam to determine storage class.
 42    Modified 780927 by PCK to flag the use of unaligned decimal for Release 24 of PL/I
 43    Modified 790521 by RAB to complete the implementation of multiple
 44           attribute sets for default statements started on 780314.
 45   Modified 830427 by BIM for options (packed) for pointers.
 46   Modified 860618 by RW to diagnose "dcl z varying" as incorrect
 47   Modified 890202 by RW "constant" attribute only on files and entries,
 48           duplicate parameter dcls only diagnosed once
 49 
 50 */
 51 
 52 /* parameters */
 53 
 54 dcl      sp pointer parameter;
 55 
 56 /* automatic */
 57 
 58 dcl      (adam, s, b, d, ds) ptr;
 59 dcl      m fixed bin (15);
 60 dcl      (n, minimum, maximum) fixed bin (31);
 61 dcl      1 invalid aligned like symbol.attributes;
 62 dcl      (invalid_attribute_set, valid_attribute_set, return_parameter, created_descriptor) bit (1) aligned;
 63 
 64 /* external static */
 65 
 66 dcl      pl1_stat_$check_ansi bit (1) aligned ext static;
 67 dcl      pl1_stat_$unaligned_dec bit (1) aligned ext static;
 68 
 69 /* builtins */
 70 
 71 dcl      (binary, hbound, index, lbound, length, null, string, substr, unspec) builtin;
 72 ^L
 73 /* program */
 74 
 75           s = sp;
 76 
 77 /* Since the storage class has not been propagated down at this time for members of
 78    structures, get a pointer to the level-1 symbol node ("adam") which contains the
 79    storage class of the structure.  (Which itself may not have been set for parameters...) */
 80 
 81           do adam = s repeat (adam -> symbol.father) while (adam -> symbol.father ^= null);
 82           end;
 83 
 84 /* Prevent the descriptor for parameters of internal procedures from being defaulted */
 85 
 86           created_descriptor = adam -> symbol.parameter & adam -> symbol.param_desc;
 87 
 88           if created_descriptor then
 89                s -> symbol.param_desc = "0"b;
 90 
 91           if s -> symbol.level = 0 & s -> symbol.member then do;
 92                call print (113);
 93                s -> symbol.member = "0"b;
 94           end;
 95 
 96           if adam -> symbol.parameter & s -> symbol.location = 0
 97                & ^(s -> symbol.member | s -> symbol.dcl_type = by_compiler) then do;
 98 
 99 /* parameter attribute but not a parameter */
100                if s -> symbol.token -> token.declaration -> symbol.location = 0 then
101                     call print (97);                        /* else it is just a duplicate declaration, diagnose it later */
102 
103           end;
104 
105           if (s -> symbol.level > 1 | s -> symbol.member) & s -> symbol.father = null then do;
106                call print (212);
107                s -> symbol.level = 0;
108                s -> symbol.member = "0"b;
109           end;
110 
111 /* Diagnose an invalid attribute set. */
112 
113           invalid = inconsistent (s -> symbol.attributes);
114 
115           if string (invalid) ^= ""b then do;
116                m = 200;
117                if s -> symbol.external & string (adam -> symbol.storage_class) ^= "0"b
118                     & ^(adam -> symbol.static | adam -> symbol.constant | adam -> symbol.controlled) then
119                     m = 218;
120 
121                if s -> symbol.varying & string (s -> symbol.data_type) ^= "0"b & ^(s -> symbol.bit | s -> symbol.char)
122                     then
123                     m = 219;
124 
125                if s -> symbol.initialed & (adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.defined)
126                     then
127                     m = 220;
128 
129                if s -> symbol.member & string (s -> symbol.storage_class) ^= ""b then
130                     m = 210;
131           end;
132           else
133                m = 0;
134 
135           if m ^= 0 then do;
136                call print (m);
137                string (s -> symbol.attributes) = string (s -> symbol.attributes) & ^string (invalid);
138           end;
139 
140           call check_extent_type;
141 
142 /* Prevent the return value from being defaulted. */
143 
144           return_parameter =
145                s -> symbol.parameter & ^created_descriptor & s -> symbol.level < 2 & s -> symbol.dcl_type = by_compiler;
146           if return_parameter then do;
147                s -> symbol.parameter = "0"b;
148                s -> symbol.return_value = "1"b;
149           end;
150 
151 /* Apply the defaults */
152 
153           if ^adam -> symbol.temporary then
154                do b = s -> symbol.block_node repeat b -> block.father while (b ^= null);
155                     do d = b -> block.default repeat d -> default.next while (d ^= null);
156                          if d -> default.no_defaults then
157                               go to develop;
158 
159                          valid_attribute_set, invalid_attribute_set = "0"b;
160                          if d -> default.system then
161                               call system;
162                          else if evaluate (d, s, adam, (d -> default.predicate)) then
163                               if d -> default.error then
164                                    call print (211);
165                               else
166                                    do ds = d -> default.symbol repeat ds -> symbol.next while (ds ^= null);
167                                         string (invalid) =
168                                              string (s -> symbol.attributes) | string (ds -> symbol.attributes);
169                                         invalid = inconsistent (invalid);
170 
171                                         if string (invalid) ^= ""b then
172                                              invalid_attribute_set = "1"b;
173                                         else if merge_attributes (s, ds) /* merge default symbol attributes into s */ then
174                                              invalid_attribute_set = "1"b;
175                                         else do;
176                                              s -> symbol.defaulted = "1"b;
177                                              valid_attribute_set = "1"b;
178                                         end;
179                                    end;
180 
181                          if invalid_attribute_set /* None of the attribute sets could be applied. */
182                               & ^valid_attribute_set then
183                               call print (206);
184                     end;
185                end;
186 
187           call system;
188 
189 /* now check that the automagickly supplied attributes still match the
190  * declared attributes
191  * diagnose this: dcl x fixed bin constant
192  */
193 
194           if adam -> symbol.constant & adam -> symbol.dcl_type = by_declare & ^(s -> symbol.file | s -> symbol.entry) then do;
195                call print (200);
196                s -> symbol.constant = "0"b;                 /* lets do it all again to get the defaults right this time. */
197                call validate (s);
198           end;
199 
200 /* These errors might result from supplying the system defaults.  */
201 
202           call check_extent_type;
203 
204 /* Restore the attributes modified above. */
205 
206 develop:
207           if created_descriptor then do;
208                s -> symbol.parameter = "0"b;
209                s -> symbol.param_desc = "1"b;
210           end;
211 
212           if return_parameter then do;
213                s -> symbol.parameter = "1"b;
214                s -> symbol.return_value = "0"b;
215           end;
216 
217 /* remove wart -- entry() caused a dummy list to be attached to symbol.general to prevent defaulting */
218 
219           if s -> symbol.entry then
220                if s -> symbol.general ^= null then
221                     if s -> symbol.general -> list.number = 0 then
222                          s -> symbol.general = null;
223 
224 /* Check for completed attributes and prevent faults if they are not complete */
225 
226           m = 0;
227           if s -> symbol.returns then
228                if s -> symbol.dcl_size = null then do;
229                     call print (279);
230                     s -> symbol.returns = "0"b;
231                end;
232           if s -> symbol.dimensioned then
233                if s -> symbol.array = null then do;
234                     call print (280);
235                     s -> symbol.dimensioned = "0"b;
236                end;
237           if s -> symbol.picture then
238                if s -> symbol.general = null then do;
239                     call print (281);
240                     s -> symbol.picture = "0"b;
241                end;
242           if s -> symbol.position then
243                if s -> symbol.initial = null then do;
244                     call print (282);
245                     s -> symbol.position = "0"b;
246                end;
247           if s -> symbol.initialed then
248                if s -> symbol.initial = null then do;
249                     call print (283);
250                     s -> symbol.alloc_in_text, s -> symbol.initialed = "0"b;
251                end;
252           if s -> symbol.generic then
253                if s -> symbol.general = null then do;
254                     m = 284;
255                     s -> symbol.generic = "0"b;
256                end;
257           if s -> symbol.environment then
258                if ^s -> symbol.interactive & ^s -> symbol.stringvalue then
259                     m = 285;
260           if s -> symbol.options then
261                if ^s -> symbol.variable_arg_list & ^s -> symbol.alloc_in_text & ^s -> symbol.explicit_packed then do;
262                     m = 498;
263                     s -> symbol.options = "0"b;
264                end;
265           if s -> symbol.alloc_in_text then do;
266                if pl1_stat_$check_ansi then
267                     call print (349);
268 
269                if ^(s -> symbol.internal & adam -> symbol.static & (s -> symbol.structure | s -> symbol.initialed))
270                then do;
271                     m = 482;
272                     s -> symbol.alloc_in_text = "0"b;
273                end;
274           end;
275           if m ^= 0 then
276                call print (m);
277 
278 /* check for nonstandard constructs */
279 
280           if pl1_stat_$check_ansi then do;
281                if s -> symbol.external then
282                     if index (s -> symbol.token -> token.string, "$") ^= 0 then
283                          call print (8);
284                if adam -> symbol.param_desc & s -> symbol.local then
285                     call print (353);
286           end;
287 
288 /* check for the unaligned and decimal attributes so that the user can be warned of an implementation change for Release 25 */
289 
290           if s -> symbol.unaligned & s -> symbol.decimal & ^s -> symbol.temporary then
291                pl1_stat_$unaligned_dec = "1"b;
292 
293 /* develop the packed bit.    */
294 
295           if (s -> symbol.fixed | s -> symbol.float | s -> symbol.char | s -> symbol.bit | s -> symbol.picture
296                | s -> symbol.ptr) & s -> symbol.unaligned then
297                s -> symbol.packed = "1"b;
298 
299 /* check the declared precision         */
300 
301           if s -> symbol.fixed | s -> symbol.float then do;
302                if s -> symbol.decimal then
303                     n = max_p_dec;
304                else if s -> symbol.fixed then
305                     n = max_p_fix_bin_2;
306                else
307                     n = max_p_flt_bin_2;
308 
309                if s -> symbol.c_dcl_size > n then do;
310                     call print (201);
311                     s -> symbol.c_dcl_size = n;
312                end;                                         /*
313  NOTE: neither of the following 2 tests will ever be true, as a too
314 large or too small of scale NEVER occures. Scale is fixed bin (7) and can
315 never have a too big of number to fit in it.  These tests have
316 therefore been moved to get_scale(), which is found in
317 attribute_parse.pl1
318 RW 89
319 */
320                                                             /*
321 *              if s -> symbol.scale < min_scale then do;
322 *                   call print (222);
323 *                   s -> symbol.scale = min_scale;
324 *              end;
325 *              if s -> symbol.scale > max_scale then do;
326 *                   call print (222);
327 *                   s -> symbol.scale = max_scale;
328 *              end;
329 */
330                s -> symbol.precision = "1"b;
331                return;
332           end;
333 
334 /* check the size of areas and strings. */
335 
336           minimum = 0;
337           if s -> symbol.char then
338                maximum = max_char_string;
339           else if s -> symbol.bit then
340                maximum = max_bit_string;
341           else if s -> symbol.area then do;
342                maximum = max_area_size;
343                minimum = min_area_size;
344           end;
345           else
346                return;
347 
348           d = s -> symbol.dcl_size;
349           if d = null then
350                return;                                      /* should emit error message about incomplete attribute set */
351           if d -> node.type ^= token_node then
352                return;
353           if d -> token.type ^= dec_integer then
354                return;
355           n = token_to_binary (d);
356 
357           if n > maximum then do;
358                call print (205);
359                n = maximum;
360           end;
361 
362           if n < minimum then do;
363                call print (204);
364                n = minimum;
365           end;
366 
367           s -> symbol.dcl_size = null;
368           s -> symbol.c_dcl_size = n;
369           return;
370 ^L
371 check_extent_type:
372      procedure ();
373 
374           m = 0;
375           if s -> symbol.star_extents
376                & ^(adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.return_value) then
377                m = 215;
378 
379           if s -> symbol.refer_extents & ^adam -> symbol.based & string (adam -> symbol.storage_class) ^= "0"b then
380                m = 217;
381 
382           if s -> symbol.exp_extents & (adam -> symbol.parameter | adam -> symbol.param_desc | adam -> symbol.static) then
383                m = 216;
384 
385 /* Check to avoid parsing ` dcl x varying; ' without a diagnostic.
386              Since this is called twice, check data type to avoid printing
387              out error two times */
388           if s -> symbol.varying & string (s -> symbol.data_type) ^= "0"b & ^(s -> symbol.bit | s -> symbol.char) then
389                m = 219;
390 
391           if m ^= 0 then
392                call print (m);
393 
394      end /* check_extent_type */;
395 ^L
396 /* subroutine to print an error message.          */
397 
398 print:
399      proc (m);
400 
401 dcl      m fixed bin (15) parameter;
402 
403           call semantic_translator$error (m, s);
404 
405      end;
406 ^L
407 /* subroutine to check string(symbol.attributes) for inconsistency */
408 
409 inconsistent:
410      procedure (bv_attributes) returns (1 aligned like symbol.attributes);
411 
412 /* parameters */
413 
414 dcl      1 bv_attributes aligned like symbol.attributes;
415 
416 /* automatic */
417 
418 dcl      1 a aligned like symbol.attributes,
419          1 b aligned like symbol.attributes;
420 dcl      i fixed bin;
421 
422 /* program */
423 
424           string (a) = string (bv_attributes);
425           string (b) = ""b;
426 
427           do i = lbound (incompatable, 1) to hbound (incompatable, 1);
428                if substr (string (a), i, 1) then
429                     string (b) = string (b) | (string (a) & incompatable (i));
430           end;
431 
432           return (b);
433 
434      end inconsistent;
435 ^L
436 /* subroutine to evaluate the predicate of a default statement */
437 
438 evaluate:
439      procedure (d, bv_s, bv_adam, e) returns (bit (1) aligned);
440 
441 /* parameters */
442 
443 dcl      (d, bv_s, bv_adam, e) ptr parameter;
444 
445 /* automatic */
446 
447 dcl      (adam, r, s, t) ptr;
448 dcl      (i, letterx, n) fixed bin;
449 dcl      m fixed bin (15);
450 dcl      c char (1);
451 dcl      v (2:3) bit (1) aligned;
452 dcl      ident (2) char (256) varying;
453 dcl      word char (11);
454 
455 /* program */
456 
457           s = bv_s;
458           adam = bv_adam;
459           if e = null then
460                go to fail;
461           if e -> node.type = token_node then do;
462                word = e -> token.string;
463                letterx = binary (unspec (substr (word, 1, 1)), 9);
464                do i = index_given_letter (letterx) by 1 while (keyword (i) < word);
465                end;
466                if keyword (i) ^= word then
467                     go to err2;
468 
469                return (substr (string (s -> symbol.attributes), bit_index (i), 1));
470           end;
471 
472           if e -> node.type = operator_node then do;
473                n = e -> operator.number;
474                if n > 3 | n < 2 then
475                     go to err1;
476                do i = 2 to n;
477                     v (i) = evaluate (d, s, adam, (e -> operand (i)));
478                end;
479                if e -> operator.op_code = or_bits then
480                     return (v (2) | v (3));
481                if e -> operator.op_code = and_bits then
482                     return (v (2) & v (3));
483                if e -> operator.op_code = not_bits then
484                     return (^v (2));
485                go to err1;
486           end;
487           if e -> node.type ^= reference_node then
488                go to err2;
489           if e -> reference.symbol -> token.string ^= "range" then
490                go to err2;
491           r = e -> reference.offset;
492           if r = null then
493                go to err2;
494           if r -> node.type ^= list_node then
495                go to err2;
496           n = r -> list.number;
497           if n > 2 then
498                go to err0;
499           if adam -> symbol.param_desc | adam -> symbol.return_value then
500                go to fail;
501           if adam -> symbol.constant & ^(s -> symbol.file | s -> symbol.entry) then
502                go to fail;
503 
504           do i = 1 to n;
505                if r -> element (i) -> node.type ^= token_node then
506                     go to err2;
507                ident (i) = r -> element (i) -> token.string;
508           end;
509 
510           t = s -> symbol.token;
511 
512           if n = 1 then do;
513                if t -> token.size < length (ident (1)) then
514                     go to fail;
515                if ident (1) = "*" then
516                     go to exit;
517                if substr (t -> token.string, 1, length (ident (1))) ^= ident (1) then
518                     go to fail;
519                go to exit;
520           end;
521           else do;
522                if length (ident (1)) ^= 1 then
523                     go to err0;
524                if length (ident (2)) ^= 1 then
525                     go to err0;
526                c = t -> token.string;
527                if c < ident (2) | c > ident (1) then
528                     go to fail;
529                go to exit;
530           end;
531 
532 /* error conditions detected during predicate evaluation. */
533 
534 
535 err0:
536           m = 207;                                          /* range operand syntax error */
537           go to print;
538 err1:
539           m = 208;                                          /* operator is not boolean              */
540           go to print;
541 err2:
542           m = 209;                                          /* illegal operand in predicate         */
543 
544 
545 /* error print and recovery routine */
546 
547 print:
548           call error_$no_text (m, d -> default.source_id, null);
549           d -> default.predicate = null;
550 fail:
551           return ("0"b);
552 exit:
553           return ("1"b);
554 
555      end evaluate;
556 ^L
557 system:
558      proc;
559 
560 /* check for nonstandard defaults */
561 
562           if pl1_stat_$check_ansi then
563                if (s -> symbol.variable_arg_list & ^s -> symbol.entry) | (s -> symbol.environment & ^s -> symbol.file)
564                     then
565                     call print (126);
566 
567 /* entry defaults   */
568 
569           if s -> symbol.returns | s -> symbol.reducible | s -> symbol.irreducible | s -> symbol.variable_arg_list then
570                s -> symbol.entry = "1"b;
571 
572           if s -> symbol.entry then
573                s -> symbol.irreducible = ^s -> symbol.reducible;
574 
575 /* file defaults    */
576 
577           if string (s -> symbol.file_attributes) then
578                s -> symbol.file = "1"b;
579 
580 /* arithmetic defaults */
581 
582           if ^s -> symbol.constant then do;
583                if string (s -> symbol.data_type) = "0"b then
584                     s -> symbol.fixed = "1"b;
585                if s -> symbol.fixed | s -> symbol.float then do;
586 
587 /* arithmetic defaults for variables */
588 
589                     s -> symbol.binary = ^s -> symbol.decimal;
590                     s -> symbol.real = ^s -> symbol.complex;
591                     if s -> symbol.c_dcl_size = 0 then
592                          if s -> symbol.fixed then
593                               if s -> symbol.binary then
594                                    s -> symbol.c_dcl_size = default_fix_bin_p;
595                               else
596                                    s -> symbol.c_dcl_size = default_fix_dec_p;
597                          else if s -> symbol.binary then
598                               s -> symbol.c_dcl_size = default_flt_bin_p;
599                          else
600                               s -> symbol.c_dcl_size = default_flt_dec_p;
601                end;
602                else if (s -> symbol.bit | s -> symbol.char) then do;
603 
604 /* string defaults for variables */
605 
606                     s -> symbol.non_varying = ^s -> symbol.varying;
607                     if s -> symbol.dcl_size = null then
608                          if s -> symbol.c_dcl_size = 0 then
609                               s -> symbol.c_dcl_size = 1;
610                end;
611           end;
612 
613 /* area defaults  */
614 
615           if s -> symbol.area then
616                if s -> symbol.dcl_size = null then
617                     if s -> symbol.c_dcl_size = 0 then
618                          s -> symbol.c_dcl_size = default_area_size;
619 
620 /* scope class defaults       */
621 
622           if s -> symbol.file | s -> symbol.entry then
623                if substr (string (s -> symbol.storage_class), 1, 7) | s -> symbol.member | s -> symbol.aligned
624                     | s -> symbol.unaligned | s -> symbol.initialed | s -> symbol.return_value then
625                     s -> symbol.variable = "1"b;
626 
627           if ^s -> symbol.variable then
628                if (s -> symbol.entry | s -> symbol.file) then
629                     s -> symbol.constant = "1"b;
630 
631           if s -> symbol.condition then
632                s -> symbol.external, s -> symbol.auto = "1"b;
633 
634           s -> symbol.variable =
635                ^s -> symbol.constant & ^(s -> symbol.builtin | s -> symbol.condition | s -> symbol.generic);
636 
637           if ((s -> symbol.file | s -> symbol.entry) & s -> symbol.constant & ^s -> symbol.internal) then
638                s -> symbol.external = "1"b;
639 
640           s -> symbol.internal = ^s -> symbol.external;
641 
642           if s -> symbol.variable & s -> symbol.external & ^s -> symbol.controlled then
643                s -> symbol.static = "1"b;
644 
645           if ^(s -> symbol.builtin | s -> symbol.condition | s -> symbol.generic | s -> symbol.member) then
646                if string (s -> symbol.storage_class) = "0"b then
647                     s -> symbol.auto = "1"b;
648 
649 /* storage alignment and packing defaults */
650 
651           if (s -> symbol.char | s -> symbol.bit | s -> symbol.picture | s -> symbol.structure)
652                & ^(s -> symbol.aligned | s -> symbol.varying) then
653                s -> symbol.unaligned = "1"b;
654 
655           s -> symbol.aligned = ^s -> symbol.unaligned;
656 
657           if (s -> symbol.fixed | s -> symbol.float) & ^(s -> symbol.signed | s -> symbol.unsigned | s -> symbol.constant)
658                then
659                s -> symbol.signed = "1"b;
660 
661      end system;
662 
663 /* include files */
664 
665 %include semant;
666 %include default;
667 %include symbol;
668 %include symbol_bits;
669 %include reference;
670 %include operator;
671 %include token;
672 %include token_types;
673 %include list;
674 %include block;
675 %include op_codes;
676 %include nodes;
677 %include system;
678 %include pl1_attribute_table;
679 %include declare_type;
680      end;