1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33 validate:
34 proc (sp);
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54 dcl sp pointer parameter;
55
56
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
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
70
71 dcl (binary, hbound, index, lbound, length, null, string, substr, unspec) builtin;
72 ^L
73
74
75 s = sp;
76
77
78
79
80
81 do adam = s repeat (adam -> symbol.father) while (adam -> symbol.father ^= null);
82 end;
83
84
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
100 if s -> symbol.token -> token.declaration -> symbol.location = 0 then
101 call print (97);
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
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
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
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) 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
182 & ^valid_attribute_set then
183 call print (206);
184 end;
185 end;
186
187 call system;
188
189
190
191
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;
197 call validate (s);
198 end;
199
200
201
202 call check_extent_type;
203
204
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
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
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
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
289
290 if s -> symbol.unaligned & s -> symbol.decimal & ^s -> symbol.temporary then
291 pl1_stat_$unaligned_dec = "1"b;
292
293
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
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
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330 s -> symbol.precision = "1"b;
331 return;
332 end;
333
334
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;
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
386
387
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 ;
395 ^L
396
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
408
409 inconsistent:
410 procedure (bv_attributes) returns (1 aligned like symbol.attributes);
411
412
413
414 dcl 1 bv_attributes aligned like symbol.attributes;
415
416
417
418 dcl 1 a aligned like symbol.attributes,
419 1 b aligned like symbol.attributes;
420 dcl i fixed bin;
421
422
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
437
438 evaluate:
439 procedure (d, bv_s, bv_adam, e) returns (bit (1) aligned);
440
441
442
443 dcl (d, bv_s, bv_adam, e) ptr parameter;
444
445
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
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
533
534
535 err0:
536 m = 207;
537 go to print;
538 err1:
539 m = 208;
540 go to print;
541 err2:
542 m = 209;
543
544
545
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
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
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
576
577 if string (s -> symbol.file_attributes) then
578 s -> symbol.file = "1"b;
579
580
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
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
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
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
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
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
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;