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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
with Fname; use Fname;
with Lib; use Lib;
with Namet; use Namet;
with Namet.Sp; use Namet.Sp;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Scans; use Scans;
with Scn; use Scn;
with Sem_Util; use Sem_Util;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Style;
with Stylesw; use Stylesw;
with Table;
with Tbuild; use Tbuild;
---------
-- Par --
---------
function Par (Configuration_Pragmas : Boolean) return List_Id is
Num_Library_Units : Natural := 0;
-- Count number of units parsed (relevant only in syntax check only mode,
-- since in semantics check mode only a single unit is permitted anyway).
Save_Config_Switches : Config_Switches_Type;
-- Variable used to save values of config switches while we parse the
-- new unit, to be restored on exit for proper recursive behavior.
Loop_Block_Count : Nat := 0;
-- Counter used for constructing loop/block names (see the routine
-- Par.Ch5.Get_Loop_Block_Name).
Inside_Record_Definition : Boolean := False;
-- Flag set True within a record definition. Used to control warning
-- for redefinition of standard entities (not issued for field names).
--------------------
-- Error Recovery --
--------------------
-- When an error is encountered, a call is made to one of the Error_Msg
-- routines to record the error. If the syntax scan is not derailed by the
-- error (e.g. a complaint that logical operators are inconsistent in an
-- EXPRESSION), then control returns from the Error_Msg call, and the
-- parse continues unimpeded.
-- If on the other hand, the Error_Msg represents a situation from which
-- the parser cannot recover locally, the exception Error_Resync is raised
-- immediately after the call to Error_Msg. Handlers for Error_Resync
-- are located at strategic points to resynchronize the parse. For example,
-- when an error occurs in a statement, the handler skips to the next
-- semicolon and continues the scan from there.
-- Each parsing procedure contains a note with the heading "Error recovery"
-- which shows if it can propagate the Error_Resync exception. In order
-- not to propagate the exception, a procedure must either contain its own
-- handler for this exception, or it must not call any other routines which
-- propagate the exception.
-- Note: the arrangement of Error_Resync handlers is such that it should
-- never be possible to transfer control through a procedure which made
-- an entry in the scope stack, invalidating the contents of the stack.
Error_Resync : exception;
-- Exception raised on error that is not handled locally, see above
Last_Resync_Point : Source_Ptr;
-- The resynchronization routines in Par.Sync run a risk of getting
-- stuck in an infinite loop if they do not skip a token, and the caller
-- keeps repeating the same resync call. On the other hand, if they skip
-- a token unconditionally, some recovery opportunities are missed. The
-- variable Last_Resync_Point records the token location previously set
-- by a Resync call, and if a subsequent Resync call occurs at the same
-- location, then the Resync routine does guarantee to skip a token.
--------------------------------------------
-- Handling Semicolon Used in Place of IS --
--------------------------------------------
-- The following global variables are used in handling the error situation
-- of using a semicolon in place of IS in a subprogram declaration as in:
-- procedure X (Y : Integer);
-- Q : Integer;
-- begin
-- ...
-- end;
-- The two contexts in which this can appear are at the outer level, and
-- within a declarative region. At the outer level, we know something is
-- wrong as soon as we see the Q (or begin, if there are no declarations),
-- and we can immediately decide that the semicolon should have been IS.
-- The situation in a declarative region is more complex. The declaration
-- of Q could belong to the outer region, and we do not know that we have
-- an error until we hit the begin. It is still not clear at this point
-- from a syntactic point of view that something is wrong, because the
-- begin could belong to the enclosing subprogram or package. However, we
-- can incorporate a bit of semantic knowledge and note that the body of
-- X is missing, so we definitely DO have an error. We diagnose this error
-- as semicolon in place of IS on the subprogram line.
-- There are two styles for this diagnostic. If the begin immediately
-- follows the semicolon, then we can place a flag (IS expected) right
-- on the semicolon. Otherwise we do not detect the error until we hit
-- the begin which refers back to the line with the semicolon.
-- To control the process in the second case, the following global
-- variables are set to indicate that we have a subprogram declaration
-- whose body is required and has not yet been found. The prefix SIS
-- stands for "Subprogram IS" handling.
SIS_Entry_Active : Boolean := False;
-- Set True to indicate that an entry is active (i.e. that a subprogram
-- declaration has been encountered, and no body for this subprogram has
-- been encountered). The remaining fields are valid only if this is True.
SIS_Labl : Node_Id;
-- Subprogram designator
SIS_Sloc : Source_Ptr;
-- Source location of FUNCTION/PROCEDURE keyword
SIS_Ecol : Column_Number;
-- Column number of FUNCTION/PROCEDURE keyword
SIS_Semicolon_Sloc : Source_Ptr;
-- Source location of semicolon at end of subprogram declaration
SIS_Declaration_Node : Node_Id;
-- Pointer to tree node for subprogram declaration
SIS_Missing_Semicolon_Message : Error_Msg_Id;
-- Used to save message ID of missing semicolon message (which will be
-- modified to missing IS if necessary). Set to No_Error_Msg in the
-- normal (non-error) case.
-- Five things can happen to an active SIS entry
-- 1. If a BEGIN is encountered with an SIS entry active, then we have
-- exactly the situation in which we know the body of the subprogram is
-- missing. After posting an error message, we change the spec to a body,
-- rechaining the declarations that intervened between the spec and BEGIN.
-- 2. Another subprogram declaration or body is encountered. In this
-- case the entry gets overwritten with the information for the new
-- subprogram declaration. We don't catch some nested cases this way,
-- but it doesn't seem worth the effort.
-- 3. A nested declarative region (e.g. package declaration or package
-- body) is encountered. The SIS active indication is reset at the start
-- of such a nested region. Again, like case 2, this causes us to miss
-- some nested cases, but it doesn't seen worth the effort to stack and
-- unstack the SIS information. Maybe we will reconsider this if we ever
-- get a complaint about a missed case.
-- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively
-- supplies the missing body. In this case we reset the entry.
-- 5. We encounter the end of the declarative region without encountering
-- a BEGIN first. In this situation we simply reset the entry. We know
-- that there is a missing body, but it seems more reasonable to let the
-- later semantic checking discover this.
----------------------------------------------------
-- Handling of Reserved Words Used as Identifiers --
----------------------------------------------------
-- Note: throughout the parser, the terms reserved word and keyword are
-- used interchangeably to refer to the same set of reserved keywords
-- (including until, protected, etc).
-- If a reserved word is used in place of an identifier, the parser where
-- possible tries to recover gracefully. In particular, if the keyword is
-- clearly spelled using identifier casing, e.g. Until in a source program
-- using mixed case identifiers and lower case keywords, then the keyword
-- is treated as an identifier if it appears in a place where an identifier
-- is required.
-- The situation is more complex if the keyword is spelled with normal
-- keyword casing. In this case, the parser is more reluctant to consider
-- it to be intended as an identifier, unless it has some further
-- confirmation.
-- In the case of an identifier appearing in the identifier list of a
-- declaration, the appearance of a comma or colon right after the keyword
-- on the same line is taken as confirmation. For an enumeration literal,
-- a comma or right paren right after the identifier is also treated as
-- adequate confirmation.
-- The following type is used in calls to Is_Reserved_Identifier and
-- also to P_Defining_Identifier and P_Identifier. The default for all
-- these functions is that reserved words in reserved word case are not
-- considered to be reserved identifiers. The Id_Check value indicates
-- tokens, which if they appear immediately after the identifier, are
-- taken as confirming that the use of an identifier was expected
type Id_Check is
(None,
-- Default, no special token test
C_Comma_Right_Paren,
-- Consider as identifier if followed by comma or right paren
C_Comma_Colon,
-- Consider as identifier if followed by comma or colon
C_Do,
-- Consider as identifier if followed by DO
C_Dot,
-- Consider as identifier if followed by period
C_Greater_Greater,
-- Consider as identifier if followed by >>
C_In,
-- Consider as identifier if followed by IN
C_Is,
-- Consider as identifier if followed by IS
C_Left_Paren_Semicolon,
-- Consider as identifier if followed by left paren or semicolon
C_Use,
-- Consider as identifier if followed by USE
C_Vertical_Bar_Arrow);
-- Consider as identifier if followed by | or =>
--------------------------------------------
-- Handling IS Used in Place of Semicolon --
--------------------------------------------
-- This is a somewhat trickier situation, and we can't catch it in all
-- cases, but we do our best to detect common situations resulting from
-- a "cut and paste" operation which forgets to change the IS to semicolon.
-- Consider the following example:
-- package body X is
-- procedure A;
-- procedure B is
-- procedure C;
-- ...
-- procedure D is
-- begin
-- ...
-- end;
-- begin
-- ...
-- end;
-- The trouble is that the section of text from PROCEDURE B through END;
-- constitutes a valid procedure body, and the danger is that we find out
-- far too late that something is wrong (indeed most compilers will behave
-- uncomfortably on the above example).
-- We have two approaches to helping to control this situation. First we
-- make every attempt to avoid swallowing the last END; if we can be sure
-- that some error will result from doing so. In particular, we won't
-- accept the END; unless it is exactly correct (in particular it must not
-- have incorrect name tokens), and we won't accept it if it is immediately
-- followed by end of file, WITH or SEPARATE (all tokens that unmistakeably
-- signal the start of a compilation unit, and which therefore allow us to
-- reserve the END; for the outer level.) For more details on this aspect
-- of the handling, see package Par.Endh.
-- If we can avoid eating up the END; then the result in the absence of
-- any additional steps would be to post a missing END referring back to
-- the subprogram with the bogus IS. Similarly, if the enclosing package
-- has no BEGIN, then the result is a missing BEGIN message, which again
-- refers back to the subprogram header.
-- Such an error message is not too bad (it's already a big improvement
-- over what many parsers do), but it's not ideal, because the declarations
-- following the IS have been absorbed into the wrong scope. In the above
-- case, this could result for example in a bogus complaint that the body
-- of D was missing from the package.
-- To catch at least some of these cases, we take the following additional
-- steps. First, a subprogram body is marked as having a suspicious IS if
-- the declaration line is followed by a line which starts with a symbol
-- that can start a declaration in the same column, or to the left of the
-- column in which the FUNCTION or PROCEDURE starts (normal style is to
-- indent any declarations which really belong a subprogram). If such a
-- subprogram encounters a missing BEGIN or missing END, then we decide
-- that the IS should have been a semicolon, and the subprogram body node
-- is marked (by setting the Bad_Is_Detected flag true. Note that we do
-- not do this for library level procedures, only for nested procedures,
-- since for library level procedures, we must have a body.
-- The processing for a declarative part checks to see if the last
-- declaration scanned is marked in this way, and if it is, the tree
-- is modified to reflect the IS being interpreted as a semicolon.
---------------------------------------------------
-- Parser Type Definitions and Control Variables --
---------------------------------------------------
-- The following variable and associated type declaration are used by the
-- expression parsing routines to return more detailed information about
-- the categorization of a parsed expression.
type Expr_Form_Type is (
EF_Simple_Name, -- Simple name, i.e. possibly qualified identifier
EF_Name, -- Simple expression which could also be a name
EF_Simple, -- Simple expression which is not call or name
EF_Range_Attr, -- Range attribute reference
EF_Non_Simple); -- Expression that is not a simple expression
Expr_Form : Expr_Form_Type;
-- The following type is used for calls to P_Subprogram, P_Package, P_Task,
-- P_Protected to indicate which of several possibilities is acceptable.
type Pf_Rec is record
Spcn : Boolean; -- True if specification OK
Decl : Boolean; -- True if declaration OK
Gins : Boolean; -- True if generic instantiation OK
Pbod : Boolean; -- True if proper body OK
Rnam : Boolean; -- True if renaming declaration OK
Stub : Boolean; -- True if body stub OK
Pexp : Boolean; -- True if parametrized expression OK
Fil2 : Boolean; -- Filler to fill to 8 bits
end record;
pragma Pack (Pf_Rec);
function T return Boolean renames True;
function F return Boolean renames False;
Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, T, T, F);
Pf_Decl_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, F, F, F, F, T, F);
Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, T, T, T, F, T, F);
Pf_Decl_Pbod_Pexp : constant Pf_Rec :=
Pf_Rec'(F, T, F, T, F, F, T, F);
Pf_Pbod_Pexp : constant Pf_Rec :=
Pf_Rec'(F, F, F, T, F, F, T, F);
Pf_Spcn : constant Pf_Rec :=
Pf_Rec'(T, F, F, F, F, F, F, F);
-- The above are the only allowed values of Pf_Rec arguments
type SS_Rec is record
Eftm : Boolean; -- ELSIF can terminate sequence
Eltm : Boolean; -- ELSE can terminate sequence
Extm : Boolean; -- EXCEPTION can terminate sequence
Ortm : Boolean; -- OR can terminate sequence
Sreq : Boolean; -- at least one statement required
Tatm : Boolean; -- THEN ABORT can terminate sequence
Whtm : Boolean; -- WHEN can terminate sequence
Unco : Boolean; -- Unconditional terminate after one statement
end record;
pragma Pack (SS_Rec);
SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F);
SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F);
SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F);
SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F);
SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F);
SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F);
SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F);
SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F);
SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T);
Goto_List : Elist_Id;
-- List of goto nodes appearing in the current compilation. Used to
-- recognize natural loops and convert them into bona fide loops for
-- optimization purposes.
Label_List : Elist_Id;
-- List of label nodes for labels appearing in the current compilation.
-- Used by Par.Labl to construct the corresponding implicit declarations.
-----------------
-- Scope Table --
-----------------
-- The scope table, also referred to as the scope stack, is used to record
-- the current scope context. It is organized as a stack, with inner nested
-- entries corresponding to higher entries on the stack. An entry is made
-- when the parser encounters the opening of a nested construct (such as a
-- record, task, package etc.), and then package Par.Endh uses this stack
-- to deal with END lines (including properly dealing with END nesting
-- errors).
type SS_End_Type is
-- Type of end entry required for this scope. The last two entries are
-- used only in the subprogram body case to mark the case of a suspicious
-- IS, or a bad IS (i.e. suspicions confirmed by missing BEGIN or END).
-- See separate section on dealing with IS used in place of semicolon.
-- Note that for many purposes E_Name, E_Suspicious_Is and E_Bad_Is are
-- treated the same (E_Suspicious_Is and E_Bad_Is are simply special cases
-- of E_Name). They are placed at the end of the enumeration so that a
-- test for >= E_Name catches all three cases efficiently.
(E_Dummy, -- dummy entry at outer level
E_Case, -- END CASE;
E_If, -- END IF;
E_Loop, -- END LOOP;
E_Record, -- END RECORD;
E_Return, -- END RETURN;
E_Select, -- END SELECT;
E_Name, -- END [name];
E_Suspicious_Is, -- END [name]; (case of suspicious IS)
E_Bad_Is); -- END [name]; (case of bad IS)
-- The following describes a single entry in the scope table
type Scope_Table_Entry is record
Etyp : SS_End_Type;
-- Type of end entry, as per above description
Lreq : Boolean;
-- A flag indicating whether the label, if present, is required to
-- appear on the end line. It is referenced only in the case of Etyp is
-- equal to E_Name or E_Suspicious_Is where the name may or may not be
-- required (yes for labeled block, no in other cases). Note that for
-- all cases except begin, the question of whether a label is required
-- can be determined from the other fields (for loop, it is required if
-- it is present, and for the other constructs it is never required or
-- allowed).
Ecol : Column_Number;
-- Contains the absolute column number (with tabs expanded) of the
-- expected column of the end assuming normal Ada indentation usage. If
-- the RM_Column_Check mode is set, this value is used for generating
-- error messages about indentation. Otherwise it is used only to
-- control heuristic error recovery actions.
Labl : Node_Id;
-- This field is used to provide the name of the construct being parsed
-- and indirectly its kind. For loops and blocks, the field contains the
-- source name or the generated one. For package specifications, bodies,
-- subprogram specifications and bodies the field holds the correponding
-- program unit name. For task declarations and bodies, protected types
-- and bodies, and accept statements the field hold the name of the type
-- or operation. For if-statements, case-statements, and selects, the
-- field is initialized to Error.
-- Note: this is a bit of an odd (mis)use of Error, since there is no
-- Error, but we use this value as a place holder to indicate that it
-- is an error to have a label on the end line.
-- Whenever the field is a name, it is attached to the parent node of
-- the construct being parsed. Thus the parent node indicates the kind
-- of construct whose parse tree is being built. This is used in error
-- recovery.
Decl : List_Id;
-- Points to the list of declarations (i.e. the declarative part)
-- associated with this construct. It is set only in the END [name]
-- cases, and is set to No_List for all other cases which do not have a
-- declarative unit associated with them. This is used for determining
-- the proper location for implicit label declarations.
Node : Node_Id;
-- Empty except in the case of entries for IF and CASE statements, in
-- which case it contains the N_If_Statement or N_Case_Statement node.
-- This is used for setting the End_Span field.
Sloc : Source_Ptr;
-- Source location of the opening token of the construct. This is used
-- to refer back to this line in error messages (such as missing or
-- incorrect end lines). The Sloc field is not used, and is not set, if
-- a label is present (the Labl field provides the text name of the
-- label in this case, which is fine for error messages).
S_Is : Source_Ptr;
-- S_Is is relevant only if Etyp is set to E_Suspicious_Is or E_Bad_Is.
-- It records the location of the IS that is considered to be
-- suspicious.
Junk : Boolean;
-- A boolean flag that is set true if the opening entry is the dubious
-- result of some prior error, e.g. a record entry where the record
-- keyword was missing. It is used to suppress the issuing of a
-- corresponding junk complaint about the end line (we do not want
-- to complain about a missing end record when there was no record).
end record;
-- The following declares the scope table itself. The Last field is the
-- stack pointer, so that Scope.Table (Scope.Last) is the top entry. The
-- oldest entry, at Scope_Stack (0), is a dummy entry with Etyp set to
-- E_Dummy, and the other fields undefined. This dummy entry ensures that
-- Scope_Stack (Scope_Stack_Ptr).Etyp can always be tested, and that the
-- scope stack pointer is always in range.
package Scope is new Table.Table (
Table_Component_Type => Scope_Table_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 50,
Table_Increment => 100,
Table_Name => "Scope");
------------------------------------------
-- Table for Handling Suspicious Labels --
------------------------------------------
-- This is a special data structure which is used to deal very spefifically
-- with the following error case
-- label;
-- loop
-- ...
-- end loop label;
-- Similar cases apply to FOR, WHILE, DECLARE, or BEGIN
-- In each case the opening line looks like a procedure call because of
-- the semicolon. And the end line looks illegal because of an unexpected
-- label. If we did nothing special, we would just diagnose the label on
-- the end as unexpected. But that does not help point to the real error
-- which is that the semicolon after label should be a colon.
-- To deal with this, we build an entry in the Suspicious_Labels table
-- whenever we encounter an identifier followed by a semicolon, followed
-- by one of LOOP, FOR, WHILE, DECLARE, BEGIN. Then this entry is used to
-- issue the right message when we hit the END that confirms that this was
-- a bad label.
type Suspicious_Label_Entry is record
Proc_Call : Node_Id;
-- Node for the procedure call statement built for the label; construct
Semicolon_Loc : Source_Ptr;
-- Location of the possibly wrong semicolon
Start_Token : Source_Ptr;
-- Source location of the LOOP, FOR, WHILE, DECLARE, BEGIN token
end record;
package Suspicious_Labels is new Table.Table (
Table_Component_Type => Suspicious_Label_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 50,
Table_Increment => 100,
Table_Name => "Suspicious_Labels");
-- Now when we are about to issue a message complaining about an END label
-- that should not be there because it appears to end a construct that has
-- no label, we first search the suspicious labels table entry, using the
-- source location stored in the scope table as a key. If we find a match,
-- then we check that the label on the end matches the name in the call,
-- and if so, we issue a message saying the semicolon should be a colon.
-- Quite a bit of work, but really helpful in the case where it helps, and
-- the need for this is based on actual experience with tracking down this
-- kind of error (the eye often easily mistakes semicolon for colon!)
-- Note: we actually have enough information to patch up the tree, but
-- this may not be worth the effort! Also we could deal with the same
-- situation for EXIT with a label, but for now don't bother with that!
---------------------------------
-- Parsing Routines by Chapter --
---------------------------------
-- Uncommented declarations in this section simply parse the construct
-- corresponding to their name, and return an ID value for the Node or
-- List that is created.
-------------
-- Par.Ch2 --
-------------
package Ch2 is
function P_Pragma (Skipping : Boolean := False) return Node_Id;
-- Scan out a pragma. If Skipping is True, then the caller is skipping
-- the pragma in the context of illegal placement (this is used to avoid
-- some junk cascaded messages).
function P_Identifier (C : Id_Check := None) return Node_Id;
-- Scans out an identifier. The parameter C determines the treatment
-- of reserved identifiers. See declaration of Id_Check for details.
function P_Pragmas_Opt return List_Id;
-- This function scans for a sequence of pragmas in other than a
-- declaration sequence or statement sequence context. All pragmas
-- can appear except pragmas Assert and Debug, which are only allowed
-- in a declaration or statement sequence context.
procedure P_Pragmas_Misplaced;
-- Skips misplaced pragmas with a complaint
procedure P_Pragmas_Opt (List : List_Id);
-- Parses optional pragmas and appends them to the List
end Ch2;
-------------
-- Par.Ch3 --
-------------
package Ch3 is
Missing_Begin_Msg : Error_Msg_Id;
-- This variable is set by a call to P_Declarative_Part. Normally it
-- is set to No_Error_Msg, indicating that no special processing is
-- required by the caller. The special case arises when a statement
-- is found in the sequence of declarations. In this case the Id of
-- the message issued ("declaration expected") is preserved in this
-- variable, then the caller can change it to an appropriate missing
-- begin message if indeed the BEGIN is missing.
function P_Array_Type_Definition return Node_Id;
function P_Basic_Declarative_Items return List_Id;
function P_Constraint_Opt return Node_Id;
function P_Declarative_Part return List_Id;
function P_Discrete_Choice_List return List_Id;
function P_Discrete_Range return Node_Id;
function P_Discrete_Subtype_Definition return Node_Id;
function P_Known_Discriminant_Part_Opt return List_Id;
function P_Signed_Integer_Type_Definition return Node_Id;
function P_Range return Node_Id;
function P_Range_Constraint return Node_Id;
function P_Record_Definition return Node_Id;
function P_Subtype_Mark return Node_Id;
function P_Subtype_Mark_Resync return Node_Id;
function P_Unknown_Discriminant_Part_Opt return Boolean;
function P_Access_Definition
(Null_Exclusion_Present : Boolean) return Node_Id;
-- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part
-- and indicates if it was present
function P_Access_Type_Definition
(Header_Already_Parsed : Boolean := False) return Node_Id;
-- Ada 2005 (AI-254): The formal is used to indicate if the caller has
-- parsed the null_exclusion part. In this case the caller has also
-- removed the ACCESS token
procedure P_Component_Items (Decls : List_Id);
-- Scan out one or more component items and append them to the given
-- list. Only scans out more than one declaration in the case where the
-- source has a single declaration with multiple defining identifiers.
function P_Defining_Identifier (C : Id_Check := None) return Node_Id;
-- Scan out a defining identifier. The parameter C controls the
-- treatment of errors in case a reserved word is scanned. See the
-- declaration of this type for details.
function P_Interface_Type_Definition
(Abstract_Present : Boolean) return Node_Id;
-- Ada 2005 (AI-251): Parse the interface type definition part. Abstract
-- Present indicates if the reserved word "abstract" has been previously
-- found. It is used to report an error message because interface types
-- are by definition abstract tagged. We generate a record_definition
-- node if the list of interfaces is empty; otherwise we generate a
-- derived_type_definition node (the first interface in this list is the
-- ancestor interface).
function P_Null_Exclusion
(Allow_Anonymous_In_95 : Boolean := False) return Boolean;
-- Ada 2005 (AI-231): Parse the null-excluding part. A True result
-- indicates that the null-excluding part was present.
--
-- Allow_Anonymous_In_95 is True if we are in a context that allows
-- anonymous access types in Ada 95, in which case "not null" is legal
-- if it precedes "access".
function P_Subtype_Indication
(Not_Null_Present : Boolean := False) return Node_Id;
-- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
-- null-excluding part has been scanned out and it was present.
function P_Range_Or_Subtype_Mark
(Allow_Simple_Expression : Boolean := False) return Node_Id;
-- Scans out a range or subtype mark, and also permits a general simple
-- expression if Allow_Simple_Expression is set to True.
function Init_Expr_Opt (P : Boolean := False) return Node_Id;
-- If an initialization expression is present (:= expression), then
-- it is scanned out and returned, otherwise Empty is returned if no
-- initialization expression is present. This procedure also handles
-- certain common error cases cleanly. The parameter P indicates if
-- a right paren can follow the expression (default = no right paren
-- allowed).
procedure Skip_Declaration (S : List_Id);
-- Used when scanning statements to skip past a misplaced declaration
-- The declaration is scanned out and appended to the given list.
-- Token is known to be a declaration token (in Token_Class_Declk)
-- on entry, so there definition is a declaration to be scanned.
function P_Subtype_Indication
(Subtype_Mark : Node_Id;
Not_Null_Present : Boolean := False) return Node_Id;
-- This version of P_Subtype_Indication is called when the caller has
-- already scanned out the subtype mark which is passed as a parameter.
-- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the
-- null-excluding part has been scanned out and it was present.
function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id;
-- Parse a subtype mark attribute. The caller has already parsed the
-- subtype mark, which is passed in as the argument, and has checked
-- that the current token is apostrophe.
end Ch3;
-------------
-- Par.Ch4 --
-------------
package Ch4 is
function P_Aggregate return Node_Id;
function P_Expression return Node_Id;
function P_Expression_Or_Range_Attribute return Node_Id;
function P_Function_Name return Node_Id;
function P_Name return Node_Id;
function P_Qualified_Simple_Name return Node_Id;
function P_Qualified_Simple_Name_Resync return Node_Id;
function P_Simple_Expression return Node_Id;
function P_Simple_Expression_Or_Range_Attribute return Node_Id;
function P_Case_Expression return Node_Id;
-- Scans out a case expression. Called with Token pointing to the CASE
-- keyword, and returns pointing to the terminating right parent,
-- semicolon, or comma, but does not consume this terminating token.
function P_Expression_If_OK return Node_Id;
-- Scans out an expression allowing an unparenthesized case expression,
-- if expression, or quantified expression to appear without enclosing
-- parentheses. However, if such an expression is not preceded by a left
-- paren, and followed by a right paren, an error message will be output
-- noting that parenthesization is required.
function P_Expression_No_Right_Paren return Node_Id;
-- Scans out an expression in contexts where the expression cannot be
-- terminated by a right paren (gives better error recovery if an errant
-- right paren is found after the expression).
function P_Expression_Or_Range_Attribute_If_OK return Node_Id;
-- Scans out an expression or range attribute where a conditional
-- expression is permitted to appear without surrounding parentheses.
-- However, if such an expression is not preceded by a left paren, and
-- followed by a right paren, an error message will be output noting
-- that parenthesization is required.
function P_If_Expression return Node_Id;
-- Scans out an if expression. Called with Token pointing to the
-- IF keyword, and returns pointing to the terminating right paren,
-- semicolon or comma, but does not consume this terminating token.
function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id;
-- This routine scans out a qualified expression when the caller has
-- already scanned out the name and apostrophe of the construct.
function P_Quantified_Expression return Node_Id;
-- This routine scans out a quantified expression when the caller has
-- already scanned out the keyword "for" of the construct.
end Ch4;
-------------
-- Par.Ch5 --
-------------
package Ch5 is
function P_Condition return Node_Id;
-- Scan out and return a condition. Note that an error is given if
-- the condition is followed by a right parenthesis.
function P_Condition (Cond : Node_Id) return Node_Id;
-- Similar to the above, but the caller has already scanned out the
-- conditional expression and passes it as an argument. This form of
-- the call does not check for a following right parenthesis.
function P_Loop_Parameter_Specification return Node_Id;
-- Used in loop constructs and quantified expressions.
function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id;
-- The argument indicates the acceptable termination tokens.
-- See body in Par.Ch5 for details of the use of this parameter.
procedure Parse_Decls_Begin_End (Parent : Node_Id);
-- Parses declarations and handled statement sequence, setting
-- fields of Parent node appropriately.
end Ch5;
-------------
-- Par.Ch6 --
-------------
package Ch6 is
function P_Designator return Node_Id;
function P_Defining_Program_Unit_Name return Node_Id;
function P_Formal_Part return List_Id;
function P_Parameter_Profile return List_Id;
function P_Return_Statement return Node_Id;
function P_Subprogram_Specification return Node_Id;
procedure P_Mode (Node : Node_Id);
-- Sets In_Present and/or Out_Present flags in Node scanning past IN,
-- OUT or IN OUT tokens in the source.
function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id;
-- Scans out any construct starting with either of the keywords
-- PROCEDURE or FUNCTION. The parameter indicates which possible
-- possible kinds of construct (body, spec, instantiation etc.)
-- are permissible in the current context.
end Ch6;
-------------
-- Par.Ch7 --
-------------
package Ch7 is
function P_Package (Pf_Flags : Pf_Rec) return Node_Id;
-- Scans out any construct starting with the keyword PACKAGE. The
-- parameter indicates which possible kinds of construct (body, spec,
-- instantiation etc.) are permissible in the current context.
end Ch7;
-------------
-- Par.Ch8 --
-------------
package Ch8 is
function P_Use_Clause return Node_Id;
end Ch8;
-------------
-- Par.Ch9 --
-------------
package Ch9 is
function P_Abort_Statement return Node_Id;
function P_Abortable_Part return Node_Id;
function P_Accept_Statement return Node_Id;
function P_Delay_Statement return Node_Id;
function P_Entry_Body return Node_Id;
function P_Protected return Node_Id;
function P_Requeue_Statement return Node_Id;
function P_Select_Statement return Node_Id;
function P_Task return Node_Id;
function P_Terminate_Alternative return Node_Id;
end Ch9;
--------------
-- Par.Ch10 --
--------------
package Ch10 is
function P_Compilation_Unit return Node_Id;
-- Note: this function scans a single compilation unit, and checks that
-- an end of file follows this unit, diagnosing any unexpected input as
-- an error, and then skipping it, so that Token is set to Tok_EOF on
-- return. An exception is in syntax-only mode, where multiple
-- compilation units are permitted. In this case, P_Compilation_Unit
-- does not check for end of file and there may be more compilation
-- units to scan. The caller can uniquely detect this situation by the
-- fact that Token is not set to Tok_EOF on return.
--
-- What about multiple unit/file capability that now exists???
--
-- The Ignore parameter is normally set False. It is set True in the
-- multiple unit per file mode if we are skipping past a unit that we
-- are not interested in.
end Ch10;
--------------
-- Par.Ch11 --
--------------
package Ch11 is
function P_Handled_Sequence_Of_Statements return Node_Id;
function P_Raise_Expression return Node_Id;
function P_Raise_Statement return Node_Id;
function Parse_Exception_Handlers return List_Id;
-- Parses the partial construct EXCEPTION followed by a list of
-- exception handlers which appears in a number of productions, and
-- returns the list of exception handlers.
end Ch11;
--------------
-- Par.Ch12 --
--------------
package Ch12 is
function P_Generic return Node_Id;
function P_Generic_Actual_Part_Opt return List_Id;
end Ch12;
--------------
-- Par.Ch13 --
--------------
package Ch13 is
function P_Representation_Clause return Node_Id;
function Aspect_Specifications_Present
(Strict : Boolean := Ada_Version < Ada_2012) return Boolean;
-- This function tests whether the next keyword is WITH followed by
-- something that looks reasonably like an aspect specification. If so,
-- True is returned. Otherwise False is returned. In either case control
-- returns with the token pointer unchanged (i.e. pointing to the WITH
-- token in the case where True is returned). This function takes care
-- of generating appropriate messages if aspect specifications appear
-- in versions of Ada prior to Ada 2012. The parameter strict can be
-- set to True, to be rather strict about considering something to be
-- an aspect specification. If Strict is False, then the circuitry is
-- rather more generous in considering something ill-formed to be an
-- attempt at an aspect specification. The default is more strict for
-- Ada versions before Ada 2012 (where aspect specifications are not
-- permitted). Note: this routine never checks the terminator token
-- for aspects so it does not matter whether the aspect specifications
-- are terminated by semicolon or some other character.
function Get_Aspect_Specifications
(Semicolon : Boolean := True) return List_Id;
-- Parse a list of aspects but do not attach them to a declaration node.
-- Subsidiary to the following procedure. Used when parsing a subprogram
-- specification that may be a declaration or a body.
procedure P_Aspect_Specifications
(Decl : Node_Id;
Semicolon : Boolean := True);
-- This procedure scans out a series of aspect spefications. If argument
-- Semicolon is True, a terminating semicolon is also scanned. If this
-- argument is False, the scan pointer is left pointing past the aspects
-- and the caller must check for a proper terminator.
--
-- P_Aspect_Specifications is called with the current token pointing to
-- either a WITH keyword starting an aspect specification, or an
-- instance of the terminator token. In the former case, the aspect
-- specifications are scanned out including the terminator token if it
-- it is a semicolon, and the Has_Aspect_Specifications flag is set in
-- the given declaration node. A list of aspects is built and stored for
-- this declaration node using a call to Set_Aspect_Specifications. If
-- no WITH keyword is present, then this call has no effect other than
-- scanning out the terminator if it is a semicolon.
-- If Decl is Error on entry, any scanned aspect specifications are
-- ignored and a message is output saying aspect specifications not
-- permitted here. If Decl is Empty, then scanned aspect specifications
-- are also ignored, but no error message is given (this is used when
-- the caller has already taken care of the error message).
function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
-- Function to parse a code statement. The caller has scanned out
-- the name to be used as the subtype mark (but has not checked that
-- it is suitable for use as a subtype mark, i.e. is either an
-- identifier or a selected component). The current token is an
-- apostrophe and the following token is either a left paren or
-- RANGE (the latter being an error to be caught by P_Code_Statement.
end Ch13;
-- Note: the parsing for annexe J features (i.e. obsolescent features)
-- is found in the logical section where these features would be if
-- they were not obsolescent. In particular:
-- Delta constraint is parsed by P_Delta_Constraint (3.5.9)
-- At clause is parsed by P_At_Clause (13.1)
-- Mod clause is parsed by P_Mod_Clause (13.5.1)
--------------
-- Par.Endh --
--------------
-- Routines for handling end lines, including scope recovery
package Endh is
function Check_End
(Decl : Node_Id := Empty;
Is_Loc : Source_Ptr := No_Location) return Boolean;
-- Called when an end sequence is required. In the absence of an error
-- situation, Token contains Tok_End on entry, but in a missing end
-- case, this may not be the case. Pop_End_Context is used to determine
-- the appropriate action to be taken. The returned result is True if
-- an End sequence was encountered and False if no End sequence was
-- present. This occurs if the END keyword encountered was determined
-- to be improper and deleted (i.e. Pop_End_Context set End_Action to
-- Skip_And_Reject). Note that the END sequence includes a semicolon,
-- except in the case of END RECORD, where a semicolon follows the END
-- RECORD, but is not part of the record type definition itself.
--
-- If Decl is non-empty, then aspect specifications are permitted
-- following the end, and Decl is the declaration node with which
-- these aspect specifications are to be associated. If Decl is empty,
-- then aspect specifications are not permitted and will generate an
-- error message.
--
-- Is_Loc is set to other than the default only for the case of a
-- package declaration. It points to the IS keyword of the declaration,
-- and is used to specialize the error messages for misplaced aspect
-- specifications in this case. Note that Decl is always Empty if Is_Loc
-- is set.
procedure End_Skip;
-- Skip past an end sequence. On entry Token contains Tok_End, and we
-- we know that the end sequence is syntactically incorrect, and that
-- an appropriate error message has already been posted. The mission
-- is simply to position the scan pointer to be the best guess of the
-- position after the end sequence. We do not issue any additional
-- error messages while carrying this out.
procedure End_Statements
(Parent : Node_Id := Empty;
Decl : Node_Id := Empty;
Is_Sloc : Source_Ptr := No_Location);
-- Called when an end is required or expected to terminate a sequence
-- of statements. The caller has already made an appropriate entry in
-- the Scope.Table to describe the expected form of the end. This can
-- only be used in cases where the only appropriate terminator is end.
-- If Parent is non-empty, then if a correct END line is encountered,
-- the End_Label field of Parent is set appropriately.
--
-- If Decl is non-null, then it is a declaration node, and aspect
-- specifications are permitted after the end statement. These aspect
-- specifications, if present, are stored in this declaration node.
-- If Decl is null, then aspect specifications are not permitted after
-- the end statement.
--
-- In the case where Decl is null, Is_Sloc determines the handling. If
-- it is set to No_Location, then aspect specifications are ignored and
-- an error message is given. Is_Sloc is used in the package declaration
-- case to point to the IS, and is used to specialize the error emssages
-- issued in this case.
end Endh;
--------------
-- Par.Sync --
--------------
-- These procedures are used to resynchronize after errors. Following an
-- error which is not immediately locally recoverable, the exception
-- Error_Resync is raised. The handler for Error_Resync typically calls
-- one of these recovery procedures to resynchronize the source position
-- to a point from which parsing can be restarted.
-- Note: these procedures output an information message that tokens are
-- being skipped, but this message is output only if the option for
-- Multiple_Errors_Per_Line is set in Options.
package Sync is
procedure Resync_Choice;
-- Used if an error occurs scanning a choice. The scan pointer is
-- advanced to the next vertical bar, arrow, or semicolon, whichever
-- comes first. We also quit if we encounter an end of file.
procedure Resync_Expression;
-- Used if an error is detected during the parsing of an expression.
-- It skips past tokens until either a token which cannot be part of
-- an expression is encountered (an expression terminator), or if a
-- comma or right parenthesis or vertical bar is encountered at the
-- current parenthesis level (a parenthesis level counter is maintained
-- to carry out this test).
procedure Resync_Past_Semicolon;
-- Used if an error occurs while scanning a sequence of declarations.
-- The scan pointer is positioned past the next semicolon and the scan
-- resumes. The scan is also resumed on encountering a token which
-- starts a declaration (but we make sure to skip at least one token
-- in this case, to avoid getting stuck in a loop).
procedure Resync_To_Semicolon;
-- Similar to Resync_Past_Semicolon, except that the scan pointer is
-- left pointing to the semicolon rather than past it.
procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then;
-- Used if an error occurs while scanning a sequence of statements. The
-- scan pointer is positioned past the next semicolon, or to the next
-- occurrence of either then or loop, and the scan resumes.
procedure Resync_To_When;
-- Used when an error occurs scanning an entry index specification. The
-- scan pointer is positioned to the next WHEN (or to IS or semicolon if
-- either of these appear before WHEN, indicating another error has
-- occurred).
procedure Resync_Semicolon_List;
-- Used if an error occurs while scanning a parenthesized list of items
-- separated by semicolons. The scan pointer is advanced to the next
-- semicolon or right parenthesis at the outer parenthesis level, or
-- to the next is or RETURN keyword occurrence, whichever comes first.
procedure Resync_Cunit;
-- Synchronize to next token which could be the start of a compilation
-- unit, or to the end of file token.
end Sync;
--------------
-- Par.Tchk --
--------------
-- Routines to check for expected tokens
package Tchk is
-- Procedures with names of the form T_xxx, where Tok_xxx is a token
-- name, check that the current token matches the required token, and
-- if so, scan past it. If not, an error is issued indicating that
-- the required token is not present (xxx expected). In most cases, the
-- scan pointer is not moved in the not-found case, but there are some
-- exceptions to this, see for example T_Id, where the scan pointer is
-- moved across a literal appearing where an identifier is expected.
procedure T_Abort;
procedure T_Arrow;
procedure T_At;
procedure T_Body;
procedure T_Box;
procedure T_Colon;
procedure T_Colon_Equal;
procedure T_Comma;
procedure T_Dot_Dot;
procedure T_For;
procedure T_Greater_Greater;
procedure T_Identifier;
procedure T_In;
procedure T_Is;
procedure T_Left_Paren;
procedure T_Loop;
procedure T_Mod;
procedure T_New;
procedure T_Of;
procedure T_Or;
procedure T_Private;
procedure T_Range;
procedure T_Record;
procedure T_Right_Paren;
procedure T_Semicolon;
procedure T_Then;
procedure T_Type;
procedure T_Use;
procedure T_When;
procedure T_With;
-- Procedures having names of the form TF_xxx, where Tok_xxx is a token
-- name check that the current token matches the required token, and
-- if so, scan past it. If not, an error message is issued indicating
-- that the required token is not present (xxx expected).
-- If the missing token is at the end of the line, then control returns
-- immediately after posting the message. If there are remaining tokens
-- on the current line, a search is conducted to see if the token
-- appears later on the current line, as follows:
-- A call to Scan_Save is issued and a forward search for the token
-- is carried out. If the token is found on the current line before a
-- semicolon, then it is scanned out and the scan continues from that
-- point. If not the scan is restored to the point where it was missing.
procedure TF_Arrow;
procedure TF_Is;
procedure TF_Loop;
procedure TF_Return;
procedure TF_Semicolon;
procedure TF_Then;
procedure TF_Use;
-- Procedures with names of the form U_xxx, where Tok_xxx is a token
-- name, are just like the corresponding T_xxx procedures except that
-- an error message, if given, is unconditional.
procedure U_Left_Paren;
procedure U_Right_Paren;
end Tchk;
--------------
-- Par.Util --
--------------
package Util is
function Bad_Spelling_Of (T : Token_Type) return Boolean;
-- This function is called in an error situation. It checks if the
-- current token is an identifier whose name is a plausible bad
-- spelling of the given keyword token, and if so, issues an error
-- message, sets Token from T, and returns True. Otherwise Token is
-- unchanged, and False is returned.
procedure Check_Bad_Layout;
-- Check for bad indentation in RM checking mode. Used for statements
-- and declarations. Checks if current token is at start of line and
-- is exdented from the current expected end column, and if so an
-- error message is generated.
procedure Check_Misspelling_Of (T : Token_Type);
pragma Inline (Check_Misspelling_Of);
-- This is similar to the function above, except that it does not
-- return a result. It is typically used in a situation where any
-- identifier is an error, and it makes sense to simply convert it
-- to the given token if it is a plausible misspelling of it.
procedure Check_95_Keyword (Token_95, Next : Token_Type);
-- This routine checks if the token after the current one matches the
-- Next argument. If so, the scan is backed up to the current token
-- and Token_Type is changed to Token_95 after issuing an appropriate
-- error message ("(Ada 83) keyword xx cannot be used"). If not,
-- the scan is backed up with Token_Type unchanged. This routine
-- is used to deal with an attempt to use a 95 keyword in Ada 83
-- mode. The caller has typically checked that the current token,
-- an identifier, matches one of the 95 keywords.
procedure Check_Future_Keyword;
-- Emit a warning if the current token is a valid identifier in the
-- language version in use, but is a reserved word in a later language
-- version (unless the language version in use is Ada 83).
procedure Check_Simple_Expression (E : Node_Id);
-- Given an expression E, that has just been scanned, so that Expr_Form
-- is still set, outputs an error if E is a non-simple expression. E is
-- not modified by this call.
procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id);
-- Like Check_Simple_Expression, except that the error message is only
-- given when operating in Ada 83 mode, and includes "in Ada 83".
function Check_Subtype_Mark (Mark : Node_Id) return Node_Id;
-- Called to check that a node representing a name (or call) is
-- suitable for a subtype mark, i.e, that it is an identifier or
-- a selected component. If so, or if it is already Error, then
-- it is returned unchanged. Otherwise an error message is issued
-- and Error is returned.
function Comma_Present return Boolean;
-- Used in comma delimited lists to determine if a comma is present, or
-- can reasonably be assumed to have been present (an error message is
-- generated in the latter case). If True is returned, the scan has been
-- positioned past the comma. If False is returned, the scan position
-- is unchanged. Note that all comma-delimited lists are terminated by
-- a right paren, so the only legitimate tokens when Comma_Present is
-- called are right paren and comma. If some other token is found, then
-- Comma_Present has the job of deciding whether it is better to pretend
-- a comma was present, post a message for a missing comma and return
-- True, or return False and let the caller diagnose the missing right
-- parenthesis.
procedure Discard_Junk_Node (N : Node_Id);
procedure Discard_Junk_List (L : List_Id);
pragma Inline (Discard_Junk_Node);
pragma Inline (Discard_Junk_List);
-- These procedures do nothing at all, their effect is simply to discard
-- the argument. A typical use is to skip by some junk that is not
-- expected in the current context.
procedure Ignore (T : Token_Type);
-- If current token matches T, then give an error message and skip
-- past it, otherwise the call has no effect at all. T may be any
-- reserved word token, or comma, left or right paren, or semicolon.
function Is_Reserved_Identifier (C : Id_Check := None) return Boolean;
-- Test if current token is a reserved identifier. This test is based
-- on the token being a keyword and being spelled in typical identifier
-- style (i.e. starting with an upper case letter). The parameter C
-- determines the special treatment if a reserved word is encountered
-- that has the normal casing of a reserved word.
procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type);
-- Called when the previous token is an identifier (whose Token_Node
-- value is given by Prev) to check if current token is an identifier
-- that can be merged with the previous one adding an underscore. The
-- merge is only attempted if the following token matches Nxt. If all
-- conditions are met, an error message is issued, and the merge is
-- carried out, modifying the Chars field of Prev.
function Next_Token_Is (Tok : Token_Type) return Boolean;
-- Looks at token after current one and returns True if the token type
-- matches Tok. The scan is unconditionally restored on return.
procedure No_Constraint;
-- Called in a place where no constraint is allowed, but one might
-- appear due to a common error (e.g. after the type mark in a procedure
-- parameter. If a constraint is present, an error message is posted,
-- and the constraint is scanned and discarded.
procedure Push_Scope_Stack;
pragma Inline (Push_Scope_Stack);
-- Push a new entry onto the scope stack. Scope.Last (the stack pointer)
-- is incremented. The Junk field is preinitialized to False. The caller
-- is expected to fill in all remaining entries of the new top stack
-- entry at Scope.Table (Scope.Last).
procedure Pop_Scope_Stack;
-- Pop an entry off the top of the scope stack. Scope_Last (the scope
-- table stack pointer) is decremented by one. It is a fatal error to
-- try to pop off the dummy entry at the bottom of the stack (i.e.
-- Scope.Last must be non-zero at the time of call).
function Separate_Present return Boolean;
-- Determines if the current token is either Tok_Separate, or an
-- identifier that is a possible misspelling of "separate" followed
-- by a semicolon. True is returned if so, otherwise False.
procedure Signal_Bad_Attribute;
-- The current token is an identifier that is supposed to be an
-- attribute identifier but is not. This routine posts appropriate
-- error messages, including a check for a near misspelling.
function Token_Is_At_Start_Of_Line return Boolean;
pragma Inline (Token_Is_At_Start_Of_Line);
-- Determines if the current token is the first token on the line
function Token_Is_At_End_Of_Line return Boolean;
-- Determines if the current token is the last token on the line
procedure Warn_If_Standard_Redefinition (N : Node_Id);
-- Issues a warning if Warn_On_Standard_Redefinition is set True, and
-- the Node N (which is a Defining_Identifier node with the Chars field
-- set) is a renaming of an entity in package Standard.
end Util;
--------------
-- Par.Prag --
--------------
-- The processing for pragmas is split off from chapter 2
function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id;
-- This function is passed a tree for a pragma that has been scanned out.
-- The pragma is syntactically well formed according to the general syntax
-- for pragmas and the pragma identifier is for one of the recognized
-- pragmas. It performs specific syntactic checks for specific pragmas.
-- The result is the input node if it is OK, or Error otherwise. The
-- reason that this is separated out is to facilitate the addition
-- of implementation defined pragmas. The second parameter records the
-- location of the semicolon following the pragma (this is needed for
-- correct processing of the List and Page pragmas). The returned value
-- is a copy of Pragma_Node, or Error if an error is found. Note that
-- at the point where Prag is called, the right paren ending the pragma
-- has been scanned out, and except in the case of pragma Style_Checks,
-- so has the following semicolon. For Style_Checks, the caller delays
-- the scanning of the semicolon so that it will be scanned using the
-- settings from the Style_Checks pragma preceding it.
--------------
-- Par.Labl --
--------------
procedure Labl;
-- This procedure creates implicit label declarations for all labels that
-- are declared in the current unit. Note that this could conceptually be
-- done at the point where the labels are declared, but it is tricky to do
-- it then, since the tree is not hooked up at the point where the label is
-- declared (e.g. a sequence of statements is not yet attached to its
-- containing scope at the point a label in the sequence is found).
--------------
-- Par.Load --
--------------
procedure Load;
-- This procedure loads all subsidiary units that are required by this
-- unit, including with'ed units, specs for bodies, and parents for child
-- units. It does not load bodies for inlined procedures and generics,
-- since we don't know till semantic analysis is complete what is needed.
-----------
-- Stubs --
-----------
-- The package bodies can see all routines defined in all other subpackages
use Ch2;
use Ch3;
use Ch4;
use Ch5;
use Ch6;
use Ch7;
use Ch8;
use Ch9;
use Ch10;
use Ch11;
use Ch12;
use Ch13;
use Endh;
use Tchk;
use Sync;
use Util;
package body Ch2 is separate;
package body Ch3 is separate;
package body Ch4 is separate;
package body Ch5 is separate;
package body Ch6 is separate;
package body Ch7 is separate;
package body Ch8 is separate;
package body Ch9 is separate;
package body Ch10 is separate;
package body Ch11 is separate;
package body Ch12 is separate;
package body Ch13 is separate;
package body Endh is separate;
package body Tchk is separate;
package body Sync is separate;
package body Util is separate;
function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id
is separate;
procedure Labl is separate;
procedure Load is separate;
-- Start of processing for Par
begin
Compiler_State := Parsing;
-- Deal with configuration pragmas case first
if Configuration_Pragmas then
declare
Pragmas : constant List_Id := Empty_List;
P_Node : Node_Id;
begin
loop
if Token = Tok_EOF then
Compiler_State := Analyzing;
return Pragmas;
elsif Token /= Tok_Pragma then
Error_Msg_SC ("only pragmas allowed in configuration file");
Compiler_State := Analyzing;
return Error_List;
else
P_Node := P_Pragma;
if Nkind (P_Node) = N_Pragma then
-- Give error if bad pragma
if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node))
and then Pragma_Name (P_Node) /= Name_Source_Reference
then
if Is_Pragma_Name (Pragma_Name (P_Node)) then
Error_Msg_N
("only configuration pragmas allowed " &
"in configuration file", P_Node);
else
Error_Msg_N
("unrecognized pragma in configuration file",
P_Node);
end if;
-- Pragma is OK config pragma, so collect it
else
Append (P_Node, Pragmas);
end if;
end if;
end if;
end loop;
end;
-- Normal case of compilation unit
else
Save_Opt_Config_Switches (Save_Config_Switches);
-- The following loop runs more than once in syntax check mode
-- where we allow multiple compilation units in the same file
-- and in Multiple_Unit_Per_file mode where we skip units till
-- we get to the unit we want.
for Ucount in Pos loop
Set_Opt_Config_Switches
(Is_Internal_File_Name (File_Name (Current_Source_File)),
Current_Source_Unit = Main_Unit);
-- Initialize scope table and other parser control variables
Compiler_State := Parsing;
Scope.Init;
Scope.Increment_Last;
Scope.Table (0).Etyp := E_Dummy;
SIS_Entry_Active := False;
Last_Resync_Point := No_Location;
Goto_List := New_Elmt_List;
Label_List := New_Elmt_List;
-- If in multiple unit per file mode, skip past ignored unit
if Ucount < Multiple_Unit_Index then
-- We skip in syntax check only mode, since we don't want to do
-- anything more than skip past the unit and ignore it. This means
-- we skip processing like setting up a unit table entry.
declare
Save_Operating_Mode : constant Operating_Mode_Type :=
Operating_Mode;
Save_Style_Check : constant Boolean := Style_Check;
begin
Operating_Mode := Check_Syntax;
Style_Check := False;
Discard_Node (P_Compilation_Unit);
Operating_Mode := Save_Operating_Mode;
Style_Check := Save_Style_Check;
-- If we are at an end of file, and not yet at the right unit,
-- then we have a fatal error. The unit is missing.
if Token = Tok_EOF then
Error_Msg_SC ("file has too few compilation units");
raise Unrecoverable_Error;
end if;
end;
-- Here if we are not skipping a file in multiple unit per file mode.
-- Parse the unit that we are interested in. Note that in check
-- syntax mode we are interested in all units in the file.
else
declare
Comp_Unit_Node : constant Node_Id := P_Compilation_Unit;
begin
-- If parsing was successful and we are not in check syntax
-- mode, check that language-defined units are compiled in GNAT
-- mode. For this purpose we do NOT consider renamings in annex
-- J as predefined. That allows users to compile their own
-- versions of these files, and in particular, in the VMS
-- implementation, the DEC versions can be substituted for the
-- standard Ada 95 versions. Another exception is System.RPC
-- and its children. This allows a user to supply their own
-- communication layer.
if Comp_Unit_Node /= Error
and then Operating_Mode = Generate_Code
and then Current_Source_Unit = Main_Unit
and then not GNAT_Mode
then
declare
Uname : constant String :=
Get_Name_String
(Unit_Name (Current_Source_Unit));
Name : String (1 .. Uname'Length - 2);
begin
-- Because Unit_Name includes "%s"/"%b", we need to strip
-- the last two characters to get the real unit name.
Name := Uname (Uname'First .. Uname'Last - 2);
if Name = "ada" or else
Name = "interfaces" or else
Name = "system"
then
Error_Msg
("language-defined units cannot be recompiled",
Sloc (Unit (Comp_Unit_Node)));
elsif Name'Length > 4
and then
Name (Name'First .. Name'First + 3) = "ada."
then
Error_Msg
("user-defined descendents of package Ada " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
elsif Name'Length > 11
and then
Name (Name'First .. Name'First + 10) = "interfaces."
then
Error_Msg
("user-defined descendents of package Interfaces " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
elsif Name'Length > 7
and then Name (Name'First .. Name'First + 6) = "system."
and then Name /= "system.rpc"
and then
(Name'Length < 11
or else Name (Name'First .. Name'First + 10) /=
"system.rpc.")
then
Error_Msg
("user-defined descendents of package System " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
end if;
end;
end if;
end;
-- All done if at end of file
exit when Token = Tok_EOF;
-- If we are not at an end of file, it means we are in syntax
-- check only mode, and we keep the loop going to parse all
-- remaining units in the file.
end if;
Restore_Opt_Config_Switches (Save_Config_Switches);
end loop;
-- Now that we have completely parsed the source file, we can complete
-- the source file table entry.
Complete_Source_File_Entry;
-- An internal error check, the scope stack should now be empty
pragma Assert (Scope.Last = 0);
-- Here we make the SCO table entries for the main unit
if Generate_SCO then
SCO_Record (Main_Unit);
end if;
-- Remaining steps are to create implicit label declarations and to load
-- required subsidiary sources. These steps are required only if we are
-- doing semantic checking.
if Operating_Mode /= Check_Syntax or else Debug_Flag_F then
Par.Labl;
Par.Load;
end if;
-- Restore settings of switches saved on entry
Restore_Opt_Config_Switches (Save_Config_Switches);
Set_Comes_From_Source_Default (False);
Compiler_State := Analyzing;
return Empty_List;
end if;
end Par;
|