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
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66 lex:
67 procedure (cblock);
68
69
70
71 declare cblock pointer parameter;
72
73
74
75 declare action_index fixed bin,
76 bitcount fixed bin (24),
77 char_value fixed bin (9),
78 code fixed bin (35),
79 current_char char (1) aligned,
80 depthx fixed bin,
81 decimal_value bit (9) aligned,
82 dx fixed bin,
83 error_number fixed bin (15),
84 error_token ptr,
85 first_bit fixed bin,
86 float_value bit (9) aligned,
87 imaginary_value bit (9) aligned,
88 include_file_length fixed bin (21),
89 include_file_name char (32) varying,
90 include_file_ptr ptr,
91 integral_value bit (9) aligned,
92 k fixed bin,
93 line_length fixed bin (21),
94 listing_on bit (1) aligned,
95 max_in_chars fixed bin,
96 n fixed bin (21),
97 new_file_number fixed bin (8),
98 new_file_token_ptr ptr,
99 page_macro bit (1) aligned,
100 parenthesis_level fixed bin (21),
101 percent_sign_seen bit (1) aligned,
102 protected bit (18) aligned,
103 radix fixed bin,
104 rep_factor fixed bin,
105 saved_token_index fixed bin,
106 scan_index fixed bin (21),
107 string_max fixed bin (21),
108 string_token_start fixed bin (21),
109
110 strx fixed bin,
111 temp_token_string char (256) varying,
112 token_index fixed bin,
113 token_length fixed bin (21),
114 token_ptr ptr unal,
115 token_start fixed bin (21),
116 token_string char (256) varying,
117 token_string_ptr ptr,
118 token_type bit (9) aligned;
119
120
121
122 declare source_string char (source_length) based (source_ptr),
123
124 token_overlay char (token_length) based (token_string_ptr);
125
126
127
128
129 declare (addr, addrel, binary, bit, char, copy, divide, hbound, index, lbound, length, ltrim, null, rank, rtrim, search,
130 string, substr, verify) builtin;
131
132
133
134 declare com_err_ entry options (variable);
135 declare constant_token entry (ptr, ptr, bit(9) aligned, bit(9) aligned) returns (bit(9));
136 declare date_time_ entry (fixed bin (71), char (*));
137 declare find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
138 declare hcs_$terminate_noname entry (ptr, fixed bin (35));
139
140
141
142 declare error_table_$noentry fixed bin (35) external static;
143 declare (
144 pl1_stat_$cur_statement ptr,
145 pl1_stat_$level_0_colon bit (1) aligned,
146 pl1_stat_$level_0_equal bit (1) aligned,
147 pl1_stat_$line_count fixed bin,
148 pl1_stat_$listing_on bit (1) aligned,
149 pl1_stat_$seg_name char (32) varying,
150 pl1_stat_$st_length fixed bin (21),
151 pl1_stat_$st_start fixed bin (21)
152
153 ) external static;
154
155
156
157 declare (
158 file_token_ptr ptr,
159 lexing_after_end_stmt bit (1) aligned,
160
161 line_begins_in_comment bit (1) aligned,
162 line_number fixed bin (14),
163 line_start fixed bin (21),
164 source_depth fixed bin,
165 source_index fixed bin (21),
166 source_length fixed bin (21),
167 source_ptr ptr,
168 statement_number fixed bin (5),
169 suppress_line_numbers bit (1) aligned
170 ) internal static;
171
172 declare (and_token_ptr, arrow_token_ptr, assignment_token_ptr, asterisk_token_ptr, cat_token_ptr, colon_token_ptr,
173 comma_token_ptr, expon_token_ptr, ge_token_ptr, gt_token_ptr, le_token_ptr, left_parn_token_ptr, lt_token_ptr,
174 minus_token_ptr, ne_token_ptr, ngt_token_ptr, nlt_token_ptr, not_token_ptr, or_token_ptr, percent_token_ptr,
175 period_token_ptr, plus_token_ptr, right_parn_token_ptr, semi_colon_token_ptr, slash_token_ptr) ptr
176 unaligned internal static;
177
178 declare 1 file_stack (0:32) aligned internal static,
179 2 source_ptr ptr,
180 2 file_token_ptr ptr,
181 2 source_index fixed bin (21),
182 2 source_length fixed bin (21),
183 2 line_number fixed bin (14),
184 2 file_number fixed bin (8);
185
186 declare action_table (0:128) fixed bin internal static initial ( (9) 9,
187
188 1,
189 8,
190 (2) 1,
191 (19) 9,
192 1,
193 9,
194 2,
195 9,
196 9,
197 4,
198 17,
199 9,
200 18,
201 19,
202 10,
203 20,
204 21,
205 11,
206 7,
207 5,
208 (10) 6,
209 22,
210 16,
211 12,
212 23,
213 13,
214 (2) 9,
215 (26) 3,
216 (3) 9,
217 14,
218 (2) 9,
219 (26) 3,
220 9,
221 15,
222 (3) 9,
223 9);
224
225 declare command char (3) internal static options (constant) initial ("pl1");
226 declare (
227 asterisk_or_newline char (2) initial ("*
228 "),
229 double_quote char (1) initial (""""),
230 double_quote_or_newline char (2) initial ("""
231 "),
232 HT_VT_NP_SP char (4) initial (" ^K^L "),
233 identifier_characters char (64) initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"),
234 newline char (1) initial ("
235 "),
236 newpage char (1) initial ("^L")
237 ) internal static;
238
239
240
241 %include language_utility;
242 %include nodes;
243 %include pl1_tree_areas;
244 %include radix_factor_constants;
245 %include source_list;
246 %include system;
247 %include token;
248 %include token_list;
249 %include token_types;
250 ^L
251
252
253
254
255 token_index = 0;
256 protected = ""b;
257 listing_on = pl1_stat_$listing_on;
258 parenthesis_level = 0;
259 pl1_stat_$level_0_colon = "0"b;
260 pl1_stat_$level_0_equal = "0"b;
261 percent_sign_seen = "0"b;
262
263 action (1):
264 scan_index = verify (substr (source_string, source_index), HT_VT_NP_SP);
265
266 if scan_index = 0 then
267 go to end_of_source_reached_but_no_pending_token;
268
269 source_index = source_index + scan_index;
270 current_char = substr (source_string, source_index - 1, 1);
271 char_value = rank (current_char);
272
273 if char_value >= hbound (action_table, 1) then
274 action_index = action_table (hbound (action_table, 1));
275 else
276 action_index = action_table (char_value);
277
278 go to action (action_index);
279 ^L
280 action (2):
281 if source_index > source_length then do;
282 call lex_error (362, file_token_ptr);
283 go to end_of_source_reached_but_no_pending_token;
284 end;
285
286 token_start = source_index;
287 string_token_start = source_index - 1;
288 token_length = 0;
289 token_type = char_string;
290
291 rescan:
292 scan_index = search (substr (source_string, source_index), double_quote_or_newline);
293
294 if scan_index = 0 then do;
295 call lex_error (362, file_token_ptr);
296
297 if token_start = 0 then
298 token_string = token_string || substr (source_string, source_index);
299 else
300 token_length = source_length - token_start + 1;
301
302 go to end_of_source_reached;
303 end;
304
305 if substr (source_string, source_index + scan_index - 1, 1) = newline then do;
306 if token_start = 0 then
307 token_string = token_string || substr (source_string, source_index, scan_index);
308 else
309 token_length = token_length + scan_index;
310
311 source_index = source_index + scan_index;
312 call print_line;
313 go to rescan;
314 end;
315
316
317
318 if token_start = 0 then
319 token_string = token_string || substr (source_string, source_index, scan_index - 1);
320 else
321 token_length = token_length + scan_index - 1;
322
323 source_index = source_index + scan_index;
324
325 if source_index > source_length then
326 go to end_of_source_reached;
327
328 if substr (source_string, source_index, 1) = double_quote then do;
329 if token_start > 0 then do;
330 token_string = substr (source_string, token_start, token_length);
331 token_start = 0;
332 end;
333
334 token_string = token_string || double_quote;
335 source_index = source_index + 1;
336 go to rescan;
337 end;
338 else if substr (source_string, source_index, 1) = "b" then do;
339 token_type = bit_string;
340 source_index = source_index + 1;
341
342 if source_index <= source_length then do;
343 radix = index ("1234", substr (source_string, source_index, 1));
344
345 if radix > 0 then
346 source_index = source_index + 1;
347 else
348 radix = 1;
349 end;
350 else
351 radix = 1;
352
353 if token_start > 0 then do;
354 temp_token_string = substr (source_string, token_start, token_length);
355 token_start = 0;
356 end;
357 else
358 temp_token_string = token_string;
359
360
361
362
363 if radix = 4 then
364 if search (temp_token_string, capital_hex) ^= 0 then
365 dx = 5;
366 else
367 dx = 4;
368 else
369 dx = radix;
370
371 if verify (temp_token_string, digits (dx)) ^= 0 then do;
372
373 error_token = create_token (temp_token_string || "b", bit_string);
374 call lex_error (152, error_token);
375 token_type = char_string;
376 token_string = temp_token_string;
377 end;
378 else if radix > 1 then do;
379 max_in_chars = divide (max_bit_string_constant, radix, 21, 0);
380 token_string = "";
381
382 if length (temp_token_string) > max_in_chars then do;
383
384 temp_token_string = substr (temp_token_string, 1, max_in_chars);
385 error_token =
386 create_token ("""" || temp_token_string || """b" || substr ("1234", radix, 1),
387 no_token );
388 call lex_error (154, error_token);
389 end;
390
391 do strx = 1 to length (temp_token_string);
392 first_bit = radix * (index (digits (dx), substr (temp_token_string, strx, 1)) - 1) + 1;
393 token_string = token_string || substr (expand_bit_chars (radix), first_bit, radix);
394 end;
395 end;
396 else
397 token_string = temp_token_string;
398 end;
399
400 if token_index >= 3 then
401 if token_list (token_index - 2) -> token.type = left_parn
402 & token_list (token_index) -> token.type = right_parn then do;
403 token_index = token_index - 3;
404
405 if constant_token (cblock, token_list (token_index + 2), "777"b3, dec_integer) ^= dec_integer then
406 call lex_error (110, token_list (token_index + 2));
407
408 else do;
409 rep_factor = token_to_binary (token_list (token_index + 2));
410
411 if token_start > 0 then do;
412 temp_token_string = substr (source_string, token_start, token_length);
413 token_start = 0;
414 end;
415 else
416 temp_token_string = token_string;
417
418 if token_type = bit_string then
419 string_max = max_bit_string_constant;
420 else
421 string_max = max_char_string_constant;
422
423 if length (temp_token_string) * rep_factor > string_max then do;
424 error_token = create_token (temp_token_string || "b", bit_string);
425 call lex_error (109, error_token);
426
427 rep_factor = divide (string_max, length (temp_token_string), 21, 0);
428 end;
429
430 token_string = "";
431 do strx = 1 to rep_factor;
432 token_string = token_string || temp_token_string;
433 end;
434 end;
435 end;
436
437 if token_type = bit_string then do;
438 if length (token_string) > max_bit_string_constant then do;
439
440 token_string = substr (token_string, 1, max_bit_string_constant);
441 error_token = create_token (token_string || "b", bit_string);
442 call lex_error (100, error_token);
443 end;
444
445 token_string = token_string || "b";
446 end;
447 else if token_start > 0 then
448 if token_length > max_char_string_constant then do;
449 token_length = max_char_string_constant;
450 error_token = create_token (substr (source_string, token_start, token_length), char_string);
451 call lex_error (100, error_token);
452 end;
453 else
454 ;
455 else if length (token_string) > max_char_string_constant then do;
456
457 token_string = substr (token_string, 1, max_char_string_constant);
458 call lex_error (100, create_token ((token_string), char_string));
459 end;
460
461 if source_index > source_length then
462 go to end_of_source_reached;
463
464 call make_token;
465 go to check_syntax_after_constant;
466 ^L
467 action (3):
468 token_type = identifier;
469 token_start = source_index - 1;
470
471 scan_index = verify (substr (source_string, source_index), identifier_characters);
472
473 if scan_index = 0 then do;
474 source_index = source_length + 1;
475 go to end_of_source_reached;
476 end;
477
478 source_index = source_index + scan_index - 1;
479 call make_token;
480
481
482
483 current_char = substr (source_string, source_index, 1);
484 char_value = rank (current_char);
485 source_index = source_index + 1;
486
487 if char_value >= hbound (action_table, 1) then
488 action_index = action_table (hbound (action_table, 1));
489 else
490 action_index = action_table (char_value);
491
492 if action_index = 2 then do;
493 error_token = token_list (token_index);
494
495 if error_token -> token.string ^= "p" & error_token -> token.string ^= "pic"
496 & error_token -> token.string ^= "picture" then
497 call lex_error (158, error_token);
498 end;
499
500 go to action (action_index);
501 ^L
502
503
504 action (4):
505 token_start = source_index - 1;
506 if percent_sign_seen then
507 call lex_error (125, null);
508
509 percent_sign_seen = "1"b;
510 saved_token_index = token_index;
511 call print_line_before_include;
512 call enter_token (percent_token_ptr);
513 go to action (1);
514
515 action (17):
516 token_start = source_index - 1;
517 call enter_token (and_token_ptr);
518 go to action (1);
519
520 action (18):
521 token_start = source_index - 1;
522 parenthesis_level = parenthesis_level + 1;
523 call enter_token (left_parn_token_ptr);
524 go to action (1);
525
526 action (19):
527 token_start = source_index - 1;
528 parenthesis_level = parenthesis_level - 1;
529 call enter_token (right_parn_token_ptr);
530 go to action (1);
531
532 action (20):
533 token_start = source_index - 1;
534 call enter_token (plus_token_ptr);
535 go to action (1);
536
537 action (21):
538 token_start = source_index - 1;
539 call enter_token (comma_token_ptr);
540 go to action (1);
541
542 action (22):
543 token_start = source_index - 1;
544 if parenthesis_level = 0 then
545 pl1_stat_$level_0_colon = "1"b;
546
547 call enter_token (colon_token_ptr);
548 go to action (1);
549
550 action (23):
551 token_start = source_index - 1;
552 if parenthesis_level = 0 then
553 pl1_stat_$level_0_equal = "1"b;
554
555 call enter_token (assignment_token_ptr);
556 go to action (1);
557 ^L
558 action (5):
559 token_start = source_index - 1;
560 token_type = slash;
561
562 if source_index > source_length then
563 go to end_of_source_reached;
564
565 if substr (source_string, source_index, 1) ^= "*" then do;
566 call enter_token (slash_token_ptr);
567 go to action (1);
568 end;
569
570
571
572 source_index = source_index + 1;
573
574 rescan_comment:
575 scan_index = search (substr (source_string, source_index), asterisk_or_newline);
576 if scan_index = 0 then do;
577 call lex_error (360, file_token_ptr);
578 go to end_of_source_reached_but_no_pending_token;
579 end;
580
581 source_index = source_index + scan_index;
582
583 if substr (source_string, source_index - 1, 1) = newline then do;
584 call print_line;
585 line_begins_in_comment = "1"b;
586 go to rescan_comment;
587 end;
588
589
590
591 if substr (source_string, source_index, 1) = "/" then do;
592 source_index = source_index + 1;
593 go to action (1);
594 end;
595
596 go to rescan_comment;
597 ^L
598 action (6):
599 token_start = source_index - 1;
600 token_type = fixed_bin;
601 decimal_value = is_decimal_constant;
602 imaginary_value = "0"b;
603 float_value = "0"b;
604 integral_value = is_integral_constant;
605
606 if source_index > source_length then
607 go to end_of_source_reached;
608
609 call scan_past_digits;
610
611 if substr (source_string, source_index, 1) = "." then do;
612 integral_value = "0"b;
613
614 scan_fraction:
615 source_index = source_index + 1;
616
617 if source_index > source_length then
618 go to end_of_source_reached;
619
620 call scan_past_digits;
621 end;
622 else if source_index + 2 <= source_length then
623 if substr (source_string, source_index, 3) = "sub" then do;
624 source_index = source_index + 3;
625 token_type = isub;
626 call make_token;
627 go to action (1);
628 end;
629
630 token_length = source_index - token_start;
631
632 if (substr (source_string, source_index, 1) = "e") | (substr (source_string, source_index, 1) = "f") then do;
633 if substr (source_string, source_index, 1) = "e" then
634 float_value = is_float_constant;
635
636 integral_value = "0"b;
637 source_index = source_index + 1;
638
639 if source_index > source_length then do;
640 call missing_exponent;
641 go to end_of_source_reached;
642 end;
643
644 if (substr (source_string, source_index, 1) = "+") | (substr (source_string, source_index, 1) = "-")
645 then do;
646 source_index = source_index + 1;
647
648 if source_index > source_length then do;
649 call missing_exponent;
650 go to end_of_source_reached;
651 end;
652 end;
653
654 call scan_past_digits;
655 end;
656
657 if substr (source_string, source_index, 1) = "b" then do;
658 decimal_value = "0"b;
659 scan_index = source_index;
660 source_index = source_index + 1;
661 end;
662
663 if source_index <= source_length then
664 if substr (source_string, source_index, 1) = "p" then do;
665 source_index = source_index + 1;
666 protected = "1"b;
667 end;
668
669 if source_index <= source_length then
670 if substr (source_string, source_index, 1) = "i" then do;
671 imaginary_value = is_imaginary_constant;
672 source_index = source_index + 1;
673 end;
674
675 if decimal_value = ""b then
676 if verify (substr (source_string, token_start, token_length), ".01") > 0 then do;
677 error_token =
678 create_token (substr (source_string, token_start, source_index - token_start), i_float_dec);
679
680 call lex_error (153, error_token);
681
682
683
684
685 decimal_value = is_decimal_constant;
686 token_string = substr (source_string, token_start, scan_index - token_start);
687
688 if imaginary_value ^= ""b then
689 token_string = token_string || "i";
690
691 string_token_start = token_start;
692 token_start = 0;
693 end;
694
695
696
697
698
699 if (protected ^= ""b) & token_start > 0 then do;
700 if imaginary_value ^= ""b then
701 token_length = source_index - token_start - 2;
702 else
703 token_length = source_index - token_start - 1;
704
705 token_string = substr (source_string, token_start, token_length);
706 token_start = 0;
707
708 if imaginary_value ^= ""b then
709 token_string = token_string || "i";
710 end;
711
712 if source_index > source_length then
713 go to end_of_source_reached;
714
715 call make_token;
716
717
718
719 check_syntax_after_constant:
720 current_char = substr (source_string, source_index, 1);
721 char_value = rank (current_char);
722 source_index = source_index + 1;
723
724 if char_value >= hbound (action_table, 1) then
725 action_index = action_table (hbound (action_table, 1));
726 else
727 action_index = action_table (char_value);
728
729 if action_index = 3 | action_index = 6 | action_index = 2 then
730 call lex_error (157, token_list (token_index));
731
732
733 go to action (action_index);
734 ^L
735 action (7):
736 token_start = source_index - 1;
737 token_type = period;
738
739 if source_index > source_length then
740 go to end_of_source_reached;
741
742 current_char = substr (source_string, source_index, 1);
743
744 char_value = rank (current_char);
745
746 if char_value <= hbound (action_table, 1) then
747 if action_table (char_value) = 6 then do;
748 token_type = fixed_bin;
749 decimal_value = is_decimal_constant;
750 imaginary_value = "0"b;
751 float_value = "0"b;
752 integral_value = "0"b;
753 go to scan_fraction;
754 end;
755
756 call enter_token (period_token_ptr);
757 go to action (1);
758 ^L
759 action (8):
760 call print_line;
761 go to action (1);
762 ^L
763 action (9):
764 if char_value < 32 | char_value >= 128 then do;
765 error_number = 159;
766 error_token = create_token (char (bit (char_value, 9)) || "b", bit_string);
767 end;
768 else if (current_char = "_") | (current_char = "$") then do;
769 error_number = 151;
770 error_token = null;
771 end;
772 else do;
773 error_number = 363;
774 error_token = create_token ((current_char), char_string);
775 end;
776
777 call lex_error (error_number, error_token);
778 go to action (1);
779 ^L
780 action (10):
781 token_start = source_index - 1;
782 token_type = asterisk;
783 token_ptr = asterisk_token_ptr;
784
785 if source_index > source_length then
786 go to end_of_source_reached;
787
788 if substr (source_string, source_index, 1) = "*" then do;
789 source_index = source_index + 1;
790 token_ptr = expon_token_ptr;
791 end;
792
793 call enter_token (token_ptr);
794 go to action (1);
795 ^L
796 action (11):
797 token_start = source_index - 1;
798 token_type = minus;
799 token_ptr = minus_token_ptr;
800
801 if source_index > source_length then
802 go to end_of_source_reached;
803
804 if substr (source_string, source_index, 1) = ">" then do;
805 source_index = source_index + 1;
806 token_ptr = arrow_token_ptr;
807 end;
808
809 call enter_token (token_ptr);
810 go to action (1);
811 ^L
812 action (12):
813 token_start = source_index - 1;
814 token_type = lt;
815 token_ptr = lt_token_ptr;
816
817 if source_index > source_length then
818 go to end_of_source_reached;
819
820 if substr (source_string, source_index, 1) = "=" then do;
821 source_index = source_index + 1;
822 token_ptr = le_token_ptr;
823 end;
824
825 call enter_token (token_ptr);
826 go to action (1);
827 ^L
828 action (13):
829 token_start = source_index - 1;
830 token_type = gt;
831 token_ptr = gt_token_ptr;
832
833 if source_index > source_length then
834 go to end_of_source_reached;
835
836 if substr (source_string, source_index, 1) = "=" then do;
837 source_index = source_index + 1;
838 token_ptr = ge_token_ptr;
839 end;
840
841 call enter_token (token_ptr);
842 go to action (1);
843 ^L
844 action (14):
845 token_start = source_index - 1;
846 token_type = not;
847 token_ptr = not_token_ptr;
848
849 if source_index > source_length then
850 go to end_of_source_reached;
851
852 if substr (source_string, source_index, 1) = "=" then do;
853 source_index = source_index + 1;
854 token_ptr = ne_token_ptr;
855 end;
856 else if substr (source_string, source_index, 1) = "<" then do;
857 source_index = source_index + 1;
858 token_ptr = nlt_token_ptr;
859 end;
860 else if substr (source_string, source_index, 1) = ">" then do;
861 source_index = source_index + 1;
862 token_ptr = ngt_token_ptr;
863 end;
864
865 call enter_token (token_ptr);
866 go to action (1);
867 ^L
868 action (15):
869 token_start = source_index - 1;
870 token_type = or;
871 token_ptr = or_token_ptr;
872
873 if source_index > source_length then
874 go to end_of_source_reached;
875
876 if substr (source_string, source_index, 1) = "|" then do;
877 source_index = source_index + 1;
878 token_ptr = cat_token_ptr;
879 end;
880
881 call enter_token (token_ptr);
882 go to action (1);
883 ^L
884 action (16):
885 token_start = source_index - 1;
886
887 if percent_sign_seen then do;
888 percent_sign_seen = "0"b;
889 listing_on = pl1_stat_$listing_on;
890 line_start = source_index;
891 k = saved_token_index + 1;
892
893 if token_list (token_index) -> token.type = percent then do;
894 token_index = saved_token_index;
895 go to action (1);
896 end;
897
898 k = k + 1;
899
900 if t_table.string = "page" | t_table.string = "skip" then do;
901 if t_table.string = "page" then
902 page_macro = "1"b;
903 else
904 page_macro = "0"b;
905
906 if k = token_index then
907 n = 1;
908 else do;
909 k = k + 1;
910
911 if token_index - k + 1 < 3 then
912 go to error_376;
913
914 if t_table.type ^= left_parn | token_list (k + 1) -> token.type ^= dec_integer
915 | token_list (k + 2) -> token.type ^= right_parn then do;
916 error_376:
917 call lex_error (376, null);
918 k = token_index;
919 n = 1;
920 end;
921 else do;
922 n = token_to_binary (token_list (k + 1));
923 k = k + 2;
924 end;
925 end;
926
927 if listing_on then
928 if page_macro then
929 call pl1_print$non_varying (copy (newpage, n), 0);
930 else
931 call pl1_print$non_varying (copy (newline, n), 0);
932
933 if k ^= token_index then
934 call lex_error (375, null);
935
936 token_index = saved_token_index;
937 go to action (1);
938 end;
939
940 if t_table.string ^= "include" then do;
941 token_index = saved_token_index;
942 call lex_error (103, null);
943 go to action (1);
944 end;
945
946 k = k + 1;
947
948 if (t_table.type = identifier) | (t_table.type = char_string) then
949 include_file_name = t_table.string;
950 else do;
951 token_index = saved_token_index;
952 call lex_error (104, null);
953 go to action (1);
954 end;
955
956 if k ^= token_index then do;
957 token_index = saved_token_index;
958 call lex_error (441, null);
959 go to action (1);
960 end;
961
962 token_index = saved_token_index;
963
964 if length (include_file_name) >= 24 then do;
965 call lex_error (106, token_list (k));
966 go to action (1);
967 end;
968
969 include_file_name = include_file_name || ".incl.pl1";
970 new_file_token_ptr = create_token ((include_file_name), identifier);
971
972 call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount,
973 include_file_ptr, code);
974
975 if include_file_ptr = null () then do;
976 if index (include_file_name, ">") ^= 0 | index (include_file_name, "<") ^= 0 then
977 call lex_error (392, new_file_token_ptr);
978
979 else
980 call lex_error (107, new_file_token_ptr);
981
982
983 end;
984 else if code ^= 0 then
985 call com_err_ (code, command, "^a", include_file_name);
986
987 if pl1_stat_$last_source = source_list_length then do;
988 call hcs_$terminate_noname (include_file_ptr, code);
989 call lex_error (129, new_file_token_ptr);
990
991 go to action (1);
992 end;
993
994 if source_depth > hbound (file_stack, 1) then do;
995 call hcs_$terminate_noname (include_file_ptr, code);
996 call lex_error (112, new_file_token_ptr);
997
998 go to action (1);
999 end;
1000
1001 file_stack (source_depth).source_ptr = source_ptr;
1002 file_stack (source_depth).file_token_ptr = file_token_ptr;
1003 file_stack (source_depth).source_index = source_index;
1004 file_stack (source_depth).source_length = source_length;
1005 file_stack (source_depth).line_number = line_number;
1006 file_stack (source_depth).file_number = pl1_stat_$source_seg;
1007
1008 do depthx = lbound (file_stack, 1) to source_depth;
1009 if file_stack (depthx).source_ptr = include_file_ptr then do;
1010 call hcs_$terminate_noname (include_file_ptr, code);
1011 call lex_error (108, new_file_token_ptr);
1012
1013 go to action (1);
1014 end;
1015 end;
1016
1017
1018
1019 source_depth = source_depth + 1;
1020 include_file_length = divide (bitcount + 8, 9, 24, 0);
1021 new_file_number =
1022 create_source (include_file_ptr, include_file_length, new_file_token_ptr, pl1_stat_$source_seg,
1023 line_number);
1024
1025 call enter_source_segment (include_file_ptr, include_file_length, new_file_token_ptr, new_file_number);
1026 go to action (1);
1027 end;
1028
1029 call emit_semicolon;
1030
1031 if lexing_after_end_stmt then
1032 call lex_error (99, null);
1033
1034 return;
1035 ^L
1036
1037
1038 end_of_source_reached:
1039 call make_token;
1040
1041 end_of_source_reached_but_no_pending_token:
1042 if percent_sign_seen then do;
1043 call lex_error (71, null);
1044 percent_sign_seen = "0"b;
1045 token_index = saved_token_index;
1046 end;
1047
1048 call print_line_at_eof;
1049
1050 pl1_stat_$line_count = pl1_stat_$line_count + line_number;
1051
1052 if source_depth = 0 then do;
1053 if lexing_after_end_stmt then do;
1054 if token_index > 0 then
1055 call lex_error (99, null);
1056
1057 return;
1058 end;
1059
1060 if token_index > 0 then do;
1061 call lex_error (361, null);
1062 call emit_semicolon;
1063 return;
1064 end;
1065
1066 call lex_error (101, null);
1067
1068 if token_index < token_list_length then
1069 token_index = token_index + 1;
1070 token_list (token_index) = create_token ("end", identifier);
1071
1072 call emit_semicolon;
1073 pl1_stat_$st_length = 0;
1074 return;
1075 end;
1076
1077 source_depth = source_depth - 1;
1078 call enter_source_segment (file_stack (source_depth).source_ptr, file_stack (source_depth).source_length,
1079 file_stack (source_depth).file_token_ptr, file_stack (source_depth).file_number);
1080
1081 source_index = file_stack (source_depth).source_index;
1082 line_start = source_index;
1083 line_number = file_stack (source_depth).line_number;
1084 go to action (1);
1085 ^L
1086
1087
1088
1089 initialize_lex:
1090 entry (bv_source_ptr, bv_source_length);
1091
1092
1093
1094 declare (
1095 bv_source_ptr ptr,
1096 bv_source_length fixed bin (21)
1097 ) parameter;
1098
1099
1100
1101
1102
1103 call create_token$init_hash_table;
1104
1105
1106
1107 statement_number = 1;
1108
1109 suppress_line_numbers = "0"b;
1110 line_begins_in_comment = "0"b;
1111 lexing_after_end_stmt = "0"b;
1112
1113
1114
1115 plus_token_ptr = create_token ("+", plus);
1116 minus_token_ptr = create_token ("-", minus);
1117 asterisk_token_ptr = create_token ("*", asterisk);
1118 slash_token_ptr = create_token ("/", slash);
1119 expon_token_ptr = create_token ("**", expon);
1120 not_token_ptr = create_token ("^", not);
1121 and_token_ptr = create_token ("&", and);
1122 or_token_ptr = create_token ("|", or);
1123 cat_token_ptr = create_token ("||", cat);
1124 ne_token_ptr = create_token ("^=", ne);
1125 lt_token_ptr = create_token ("<", lt);
1126 gt_token_ptr = create_token (">", gt);
1127 le_token_ptr = create_token ("<=", le);
1128 ge_token_ptr = create_token (">=", ge);
1129 ngt_token_ptr = create_token ("^>", ngt);
1130 nlt_token_ptr = create_token ("^<", nlt);
1131 assignment_token_ptr = create_token ("=", assignment);
1132 colon_token_ptr = create_token (":", colon);
1133 semi_colon_token_ptr = create_token (";", semi_colon);
1134 comma_token_ptr = create_token (",", comma);
1135 period_token_ptr = create_token (".", period);
1136 arrow_token_ptr = create_token ("->", arrow);
1137 left_parn_token_ptr = create_token ("(", left_parn);
1138 right_parn_token_ptr = create_token (")", right_parn);
1139 percent_token_ptr = create_token ("%", percent);
1140
1141 source_depth = 0;
1142 pl1_stat_$source_seg = -1;
1143 pl1_stat_$last_source = -1;
1144 pl1_stat_$line_count = 0;
1145
1146 new_file_token_ptr = create_token (pl1_stat_$seg_name || ".pl1", identifier);
1147
1148
1149
1150 new_file_number = create_source (bv_source_ptr, bv_source_length, new_file_token_ptr, 0, 0);
1151
1152
1153
1154 call enter_source_segment (bv_source_ptr, bv_source_length, new_file_token_ptr, new_file_number);
1155 return;
1156 ^L
1157
1158
1159 terminate_source:
1160 entry;
1161
1162 do pl1_stat_$last_source = pl1_stat_$last_source to 0 by -1;
1163 m = pl1_stat_$last_source;
1164 call hcs_$terminate_noname ((source.seg_ptr), code);
1165 end;
1166 return;
1167 ^L
1168
1169
1170 write_last_line:
1171 entry (cblock);
1172
1173 declare 1 source_info aligned,
1174 2 line_id char (9) unal,
1175 2 sp1 char (2) unal,
1176 2 file_id char (3) unal,
1177 2 sp2 char (4) unal,
1178 2 dtm char (16) unal,
1179 2 sp3 char (2) unal,
1180 2 include_name char (32) unal,
1181 2 sp4 char (2) unal,
1182 2 pathname char (168) unal;
1183
1184 declare line_id char (9) varying aligned;
1185 declare five_digits picture "zzzzz";
1186 declare three_digits picture "zz9";
1187
1188
1189
1190 declare header char (93) varying aligned int static options (constant) init ("^L SOURCE FILES USED IN THIS COMPILATION.
1191
1192 LINE NUMBER DATE MODIFIED NAME PATHNAME");
1193
1194
1195
1196 lexing_after_end_stmt = "1"b;
1197 call lex (cblock);
1198
1199 listing_on = pl1_stat_$listing_on;
1200
1201 if ^listing_on then
1202 return;
1203
1204 call pl1_print$varying_nl (header);
1205
1206 do m = 0 to pl1_stat_$last_source;
1207 string (source_info) = "";
1208
1209 if source.file_number = ""b then
1210 line_id = "";
1211 else do;
1212 three_digits = binary (source.file_number, 8);
1213
1214 line_id = ltrim (three_digits) || "-";
1215 end;
1216
1217 five_digits = binary (source.line_number, 14);
1218
1219 source_info.line_id = line_id || ltrim (five_digits);
1220
1221 three_digits = m;
1222 source_info.file_id = three_digits;
1223
1224 call date_time_ (source.dtm, source_info.dtm);
1225 source_info.include_name = source.name -> token.string;
1226 source_info.pathname = source.pathname;
1227 n = length (string (source_info)) - length (source_info.pathname) + source.pathlen;
1228 call pl1_print$non_varying_nl (string (source_info), (n));
1229 end;
1230 return;
1231 ^L
1232
1233
1234
1235
1236
1237 create_source:
1238 procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number, bv_line_number)
1239 returns (fixed bin (8));
1240
1241
1242
1243 declare (
1244 bv_source_ptr ptr,
1245 bv_source_length fixed bin (21),
1246 bv_file_token_ptr ptr,
1247 bv_file_number fixed bin (8),
1248 bv_line_number fixed bin (14)
1249 ) parameter;
1250
1251
1252
1253 declare cname char (32),
1254 dname char (256),
1255 dtm fixed bin (71),
1256 ename char (32),
1257 include_path char (256) varying,
1258 uid bit (36) aligned;
1259
1260
1261
1262 declare translator_info_$component_get_source_info
1263 entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35));
1264
1265
1266
1267 declare pl1_stat_$node_uses (18) fixed bin external static;
1268
1269
1270
1271
1272 call translator_info_$component_get_source_info (bv_source_ptr, dname, ename, cname, dtm, uid, code);
1273 if code ^= 0 then do;
1274 call lex_error (344, bv_file_token_ptr);
1275 include_path = "UNKNOWN DIRECTORY NAME" || bv_file_token_ptr -> token.string;
1276
1277 uid = ""b;
1278 dtm = 0;
1279 end;
1280 else if cname = "" then
1281 include_path = rtrim (dname, "> ") || ">" || rtrim (ename);
1282 else
1283 include_path = rtrim (dname, "> ") || ">" || before (ename || " ", ".archive ") || "::" || rtrim (cname);
1284
1285 n = length (include_path);
1286
1287 pl1_stat_$node_uses (14) = pl1_stat_$node_uses (14) + 1;
1288
1289 m, pl1_stat_$last_source = pl1_stat_$last_source + 1;
1290 allocate source in (tree_area) set (source_list (m));
1291 source.node_type = source_node;
1292 source.seg_ptr = bv_source_ptr;
1293 source.name = bv_file_token_ptr;
1294 source.source_length = bv_source_length;
1295 source.pathname = include_path;
1296 source.file_number = bit (bv_file_number, 8);
1297 source.line_number = bit (bv_line_number, 14);
1298 source.uid = uid;
1299 source.dtm = dtm;
1300 return (m);
1301
1302 end create_source;
1303 ^L
1304
1305
1306 emit_semicolon:
1307 procedure;
1308
1309 if token_index = token_list_length then
1310 call lex_error (105, null);
1311 else
1312 token_index = token_index + 1;
1313
1314 token_list (token_index) = semi_colon_token_ptr;
1315
1316 if token_index = 1 then do;
1317 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1318 pl1_stat_$statement_id.line_number = bit (line_number, 14);
1319 pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1320 pl1_stat_$st_start = token_start - 1;
1321 end;
1322
1323 statement_number = statement_number + 1;
1324
1325 if statement_number >= 1f5b then do;
1326 call lex_error (111, null);
1327 statement_number = 1;
1328 end;
1329
1330 if pl1_stat_$st_start ^= -1 then
1331 pl1_stat_$st_length = (source_index - 1) - pl1_stat_$st_start;
1332 pl1_stat_$cur_statement = null;
1333 return;
1334
1335 end emit_semicolon;
1336 ^L
1337
1338
1339 enter_source_segment:
1340 procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number);
1341
1342
1343
1344 declare (
1345 bv_source_ptr ptr,
1346 bv_source_length fixed bin (21),
1347 bv_file_token_ptr ptr,
1348 bv_file_number fixed bin (8)
1349 ) parameter;
1350
1351
1352
1353 source_ptr = bv_source_ptr;
1354 source_length = bv_source_length;
1355 source_index = 1;
1356 file_token_ptr = bv_file_token_ptr;
1357 pl1_stat_$source_seg = bv_file_number;
1358 line_number = 1;
1359 line_start = 1;
1360 pl1_stat_$st_start = -1;
1361 pl1_stat_$st_length = 0;
1362 return;
1363
1364 end enter_source_segment;
1365 ^L
1366
1367
1368 lex_error:
1369 procedure (bv_error_number, bv_token_ptr);
1370
1371
1372
1373 declare (
1374 bv_error_number fixed bin (15),
1375 bv_token_ptr ptr
1376 ) parameter;
1377
1378
1379
1380 declare statement_length fixed bin (21);
1381
1382
1383
1384 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1385 pl1_stat_$statement_id.line_number = bit (line_number, 14);
1386 pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1387
1388 if pl1_stat_$st_start = -1 then do;
1389 pl1_stat_$st_start = line_start - 1;
1390
1391 if source_index > source_length then
1392 statement_length = 0;
1393 else
1394 statement_length = (source_index - 1) - pl1_stat_$st_start;
1395 end;
1396 else
1397 statement_length = (source_index - 1) - pl1_stat_$st_start;
1398
1399 call error_ (bv_error_number, pl1_stat_$statement_id, bv_token_ptr, pl1_stat_$source_seg, (pl1_stat_$st_start),
1400 (statement_length));
1401 return;
1402
1403 end lex_error;
1404 ^L
1405
1406
1407
1408 enter_token:
1409 procedure (P_token_ptr);
1410
1411
1412
1413 declare P_token_ptr ptr unal parameter;
1414
1415
1416
1417 if token_index < token_list_length then
1418 token_index = token_index + 1;
1419
1420 token_list (token_index) = P_token_ptr;
1421
1422 if token_index = 1 then do;
1423 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8);
1424 pl1_stat_$statement_id.line_number = bit (line_number, 14);
1425 pl1_stat_$statement_id.statement_number = bit (statement_number, 5);
1426
1427 if token_start = 0 then
1428 pl1_stat_$st_start = string_token_start - 1;
1429
1430 else
1431 pl1_stat_$st_start = token_start - 1;
1432 end;
1433
1434 return;
1435
1436 end enter_token;
1437 ^L
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447 make_token:
1448 procedure;
1449
1450
1451
1452 declare token_ptr ptr unal;
1453
1454
1455
1456 if token_type = fixed_bin then
1457 token_type = token_type | imaginary_value | float_value | decimal_value | integral_value;
1458
1459 if token_start > 0 then do;
1460 token_string_ptr = addr (substr (source_string, token_start, 1));
1461
1462
1463 if token_type ^= char_string then
1464 token_length = source_index - token_start;
1465
1466 if token_length > max_identifier_length then do;
1467 token_length = max_identifier_length;
1468 call lex_error (100, create_token (token_overlay, (token_type)));
1469 end;
1470 end;
1471 else do;
1472 token_string_ptr = addrel (addr (token_string), 1);
1473
1474 token_length = length (token_string);
1475 end;
1476
1477 token_ptr = create_token$protected (token_overlay, (token_type), protected);
1478
1479
1480 protected = ""b;
1481
1482 call enter_token (token_ptr);
1483 return;
1484 ^L
1485
1486
1487 %include create_token;
1488 end create_token;
1489
1490 end make_token;
1491 ^L
1492
1493
1494 missing_exponent:
1495 procedure;
1496
1497 token_string = substr (source_string, token_start, source_index - token_start);
1498 token_string = token_string || "0";
1499 token_start = 0;
1500 call lex_error (155, create_token ((token_string), char_string));
1501
1502 return;
1503
1504 end missing_exponent;
1505 ^L
1506
1507
1508
1509 print_line:
1510 procedure;
1511
1512 line_length = source_index - line_start;
1513
1514 if listing_on then
1515 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1516 (line_begins_in_comment));
1517
1518 line_start = source_index;
1519 line_number = line_number + 1;
1520
1521 if line_number >= 1f14b then
1522 if ^lexing_after_end_stmt then do;
1523 call lex_error (46, null);
1524 line_number = 1;
1525 end;
1526
1527 statement_number = 1;
1528 suppress_line_numbers = "0"b;
1529 line_begins_in_comment = "0"b;
1530 return;
1531
1532 end print_line;
1533
1534
1535
1536
1537 print_line_at_eof:
1538 procedure;
1539
1540 line_length = source_index - line_start;
1541
1542 if line_length = 0 then
1543 return;
1544
1545 if listing_on then
1546 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1547 (line_begins_in_comment));
1548
1549 line_begins_in_comment = "0"b;
1550
1551 if substr (source_string, source_index - 1, 1) = newline then do;
1552 suppress_line_numbers = "0"b;
1553 statement_number = 1;
1554 end;
1555 else
1556 suppress_line_numbers = "1"b;
1557
1558 return;
1559
1560 end print_line_at_eof;
1561 ^L
1562
1563
1564 print_line_before_include:
1565 procedure;
1566
1567 line_length = source_index - line_start - 1;
1568
1569 if line_length > 0 then do;
1570 if listing_on then
1571 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers),
1572 (line_begins_in_comment));
1573
1574 suppress_line_numbers = "1"b;
1575 line_begins_in_comment = "0"b;
1576 end;
1577
1578 listing_on = "0"b;
1579 return;
1580
1581 end print_line_before_include;
1582 ^L
1583
1584
1585
1586
1587 scan_past_digits:
1588 procedure;
1589
1590 scan_index = verify (substr (source_string, source_index), "0123456789");
1591
1592 if scan_index = 0 then do;
1593 source_index = source_length + 1;
1594 go to end_of_source_reached;
1595 end;
1596 else
1597 source_index = source_index + scan_index - 1;
1598 return;
1599
1600 end scan_past_digits;
1601
1602 end lex;