1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
30 with Fname
.UF
; use Fname
.UF
;
31 with Uname
; use Uname
;
36 -- Local functions, used only in this chapter
38 function P_Context_Clause
return List_Id
;
39 function P_Subunit
return Node_Id
;
41 function Set_Location
return Source_Ptr
;
42 -- The current compilation unit starts with Token at Token_Ptr. This
43 -- function determines the corresponding source location for the start
44 -- of the unit, including any preceding comment lines.
46 procedure Unit_Display
49 SR_Present
: Boolean);
50 -- This procedure is used to generate a line of output for a unit in
51 -- the source program. Cunit is the node for the compilation unit, and
52 -- Loc is the source location for the start of the unit in the source
53 -- file (which is not necessarily the Sloc of the Cunit node). This
54 -- output is written to the standard output file for use by gnatchop.
56 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
);
57 -- This routine has the same calling sequence as Unit_Display, but
58 -- it outputs only the line number and offset of the location, Loc,
59 -- using Cunit to obtain the proper source file index.
61 -------------------------
62 -- 10.1.1 Compilation --
63 -------------------------
65 -- COMPILATION ::= {COMPILATION_UNIT}
67 -- There is no specific parsing routine for a compilation, since we only
68 -- permit a single compilation in a source file, so there is no explicit
69 -- occurrence of compilations as such (our representation of a compilation
70 -- is a series of separate source files).
72 ------------------------------
73 -- 10.1.1 Compilation unit --
74 ------------------------------
76 -- COMPILATION_UNIT ::=
77 -- CONTEXT_CLAUSE LIBRARY_ITEM
78 -- | CONTEXT_CLAUSE SUBUNIT
81 -- private LIBRARY_UNIT_DECLARATION
82 -- | LIBRARY_UNIT_BODY
83 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
85 -- LIBRARY_UNIT_DECLARATION ::=
86 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
87 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
89 -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
90 -- PACKAGE_RENAMING_DECLARATION
91 -- | GENERIC_RENAMING_DECLARATION
92 -- | SUBPROGRAM_RENAMING_DECLARATION
94 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
96 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
97 -- are skipped up to the next possible beginning of a compilation unit.
99 -- Note: if only configuration pragmas are found, Empty is returned
101 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit
102 -- to return strange things that are not really compilation units.
103 -- This is done to help out gnatchop when it is faced with nonsense.
105 function P_Compilation_Unit
return Node_Id
is
106 Scan_State
: Saved_Scan_State
;
108 Specification_Node
: Node_Id
;
110 Comp_Unit_Node
: Node_Id
;
113 Private_Sloc
: Source_Ptr
:= No_Location
;
114 Config_Pragmas
: List_Id
;
116 SR_Present
: Boolean;
119 Cunit_Error_Flag
: Boolean := False;
120 -- This flag is set True if we have to scan for a compilation unit
121 -- token. It is used to ensure clean termination in such cases by
122 -- not insisting on being at the end of file, and, in the syntax only
123 -- case by not scanning for additional compilation units.
125 Cunit_Location
: Source_Ptr
;
126 -- Location of unit for unit identification output (List_Unit option)
129 Num_Library_Units
:= Num_Library_Units
+ 1;
131 -- Set location of the compilation unit if unit list option set
132 -- and we are in syntax check only mode
134 if List_Units
and then Operating_Mode
= Check_Syntax
then
135 Cunit_Location
:= Set_Location
;
137 Cunit_Location
:= No_Location
;
140 -- Deal with initial pragmas
142 Config_Pragmas
:= No_List
;
144 -- If we have an initial Source_Reference pragma, then remember the fact
145 -- to generate an NR parameter in the output line.
149 -- If we see a pragma No_Body, remember not to complain about no body
153 if Token
= Tok_Pragma
then
154 Save_Scan_State
(Scan_State
);
158 or else Pragma_Name
(Item
) /= Name_Source_Reference
160 Restore_Scan_State
(Scan_State
);
165 -- If first unit, record the file name for gnatchop use
167 if Operating_Mode
= Check_Syntax
169 and then Num_Library_Units
= 1
171 Write_Str
("Source_Reference pragma for file """);
172 Write_Name
(Full_Ref_Name
(Current_Source_File
));
177 Config_Pragmas
:= New_List
(Item
);
181 -- Scan out any configuration pragmas
183 while Token
= Tok_Pragma
loop
184 Save_Scan_State
(Scan_State
);
187 if Item
/= Error
and then Pragma_Name
(Item
) = Name_No_Body
then
192 or else not Is_Configuration_Pragma_Name
(Pragma_Name
(Item
))
194 Restore_Scan_State
(Scan_State
);
198 if Config_Pragmas
= No_List
then
199 Config_Pragmas
:= Empty_List
;
201 if Operating_Mode
= Check_Syntax
and then List_Units
then
202 Write_Str
("Configuration pragmas at");
203 Unit_Location
(Current_Source_File
, Cunit_Location
);
208 Append
(Item
, Config_Pragmas
);
209 Cunit_Location
:= Set_Location
;
212 -- Establish compilation unit node and scan context items
214 Comp_Unit_Node
:= New_Node
(N_Compilation_Unit
, No_Location
);
215 Set_Cunit
(Current_Source_Unit
, Comp_Unit_Node
);
216 Set_Context_Items
(Comp_Unit_Node
, P_Context_Clause
);
218 (Comp_Unit_Node
, New_Node
(N_Compilation_Unit_Aux
, No_Location
));
220 if Present
(Config_Pragmas
) then
222 -- Check for case of only configuration pragmas present
225 and then Is_Empty_List
(Context_Items
(Comp_Unit_Node
))
227 if Operating_Mode
= Check_Syntax
then
231 Item
:= First
(Config_Pragmas
);
233 ("cannot compile configuration pragmas with gcc!", Item
);
235 ("\use gnatchop -c to process configuration pragmas!", Item
);
236 raise Unrecoverable_Error
;
239 -- Otherwise configuration pragmas are simply prepended to the
240 -- context of the current unit.
243 Append_List
(Context_Items
(Comp_Unit_Node
), Config_Pragmas
);
244 Set_Context_Items
(Comp_Unit_Node
, Config_Pragmas
);
248 -- Check for PRIVATE. Note that for the moment we allow this in
249 -- Ada_83 mode, since we do not yet know if we are compiling a
250 -- predefined unit, and if we are then it would be allowed anyway.
252 if Token
= Tok_Private
then
253 Private_Sloc
:= Token_Ptr
;
254 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
257 Style
.Check_Indentation
;
260 Save_Scan_State
(Scan_State
); -- at PRIVATE
261 Scan
; -- past PRIVATE
263 if Token
= Tok_Separate
then
264 Error_Msg_SP
("cannot have private subunits!");
266 elsif Token
= Tok_Package
then
267 Scan
; -- past PACKAGE
269 if Token
= Tok_Body
then
270 Restore_Scan_State
(Scan_State
); -- to PRIVATE
271 Error_Msg_SC
("cannot have private package body!");
272 Scan
; -- ignore PRIVATE
275 Restore_Scan_State
(Scan_State
); -- to PRIVATE
276 Scan
; -- past PRIVATE
277 Set_Private_Present
(Comp_Unit_Node
, True);
280 elsif Token
= Tok_Procedure
281 or else Token
= Tok_Function
282 or else Token
= Tok_Generic
284 Set_Private_Present
(Comp_Unit_Node
, True);
288 -- Loop to find our way to a compilation unit token
291 exit when Token
in Token_Class_Cunit
and then Token
/= Tok_With
;
293 exit when Bad_Spelling_Of
(Tok_Package
)
294 or else Bad_Spelling_Of
(Tok_Function
)
295 or else Bad_Spelling_Of
(Tok_Generic
)
296 or else Bad_Spelling_Of
(Tok_Separate
)
297 or else Bad_Spelling_Of
(Tok_Procedure
);
299 -- Allow task and protected for nice error recovery purposes
301 exit when Token
= Tok_Task
302 or else Token
= Tok_Protected
;
304 if Token
= Tok_With
then
305 Error_Msg_SC
("misplaced WITH");
306 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
308 elsif Bad_Spelling_Of
(Tok_With
) then
309 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
312 if Operating_Mode
= Check_Syntax
and then Token
= Tok_EOF
then
314 -- Do not complain if there is a pragma No_Body
317 Error_Msg_SC
("?file contains no compilation units");
320 Error_Msg_SC
("compilation unit expected");
321 Cunit_Error_Flag
:= True;
325 -- If we are at an end of file, then just quit, the above error
326 -- message was complaint enough.
328 if Token
= Tok_EOF
then
334 -- We have a compilation unit token, so that's a reasonable choice for
335 -- determining the standard casing convention used for keywords in case
336 -- it hasn't already been done on seeing a WITH or PRIVATE.
338 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
341 Style
.Check_Indentation
;
344 -- Remaining processing depends on particular type of compilation unit
346 if Token
= Tok_Package
then
348 -- A common error is to omit the body keyword after package. We can
349 -- often diagnose this early on (before getting loads of errors from
350 -- contained subprogram bodies), by knowing that the file we
351 -- are compiling has a name that requires a body to be found.
353 Save_Scan_State
(Scan_State
);
354 Scan
; -- past Package keyword
358 Get_Expected_Unit_Type
359 (File_Name
(Current_Source_File
)) = Expect_Body
361 Error_Msg_BC
-- CODEFIX
362 ("keyword BODY expected here [see file name]");
363 Restore_Scan_State
(Scan_State
);
364 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Pbod_Pexp
));
366 Restore_Scan_State
(Scan_State
);
367 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Decl_Gins_Pbod_Rnam_Pexp
));
370 elsif Token
= Tok_Generic
then
371 Set_Unit
(Comp_Unit_Node
, P_Generic
);
373 elsif Token
= Tok_Separate
then
374 Set_Unit
(Comp_Unit_Node
, P_Subunit
);
376 elsif Token
= Tok_Function
377 or else Token
= Tok_Not
378 or else Token
= Tok_Overriding
379 or else Token
= Tok_Procedure
381 Set_Unit
(Comp_Unit_Node
, P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Pexp
));
383 -- A little bit of an error recovery check here. If we just scanned
384 -- a subprogram declaration (as indicated by an SIS entry being
385 -- active), then if the following token is BEGIN or an identifier,
386 -- or a token which can reasonably start a declaration but cannot
387 -- start a compilation unit, then we assume that the semicolon in
388 -- the declaration should have been IS.
390 if SIS_Entry_Active
then
393 or else Token
= Tok_Identifier
394 or else Token
in Token_Class_Deckn
397 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
398 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
399 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
400 Scope
.Table
(Scope
.Last
).Lreq
:= False;
401 SIS_Entry_Active
:= False;
403 -- If we had a missing semicolon in the declaration, then
404 -- change the message to from <missing ";"> to <missing "is">
406 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
407 Change_Error_Text
-- Replace: "missing "";"" "
408 (SIS_Missing_Semicolon_Message
, "missing IS");
410 -- Otherwise we saved the semicolon position, so complain
414 (""";"" should be IS", SIS_Semicolon_Sloc
);
417 Body_Node
:= Unit
(Comp_Unit_Node
);
418 Specification_Node
:= Specification
(Body_Node
);
419 Change_Node
(Body_Node
, N_Subprogram_Body
);
420 Set_Specification
(Body_Node
, Specification_Node
);
421 Parse_Decls_Begin_End
(Body_Node
);
422 Set_Unit
(Comp_Unit_Node
, Body_Node
);
425 -- If we scanned a subprogram body, make sure we did not have private
427 elsif Private_Sloc
/= No_Location
429 Nkind
(Unit
(Comp_Unit_Node
)) not in N_Subprogram_Instantiation
431 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Subprogram_Renaming_Declaration
433 Error_Msg
("cannot have private subprogram body", Private_Sloc
);
435 -- P_Subprogram can yield an abstract subprogram, but this cannot
436 -- be a compilation unit. Treat as a subprogram declaration.
439 Nkind
(Unit
(Comp_Unit_Node
)) = N_Abstract_Subprogram_Declaration
442 ("compilation unit cannot be abstract subprogram",
443 Unit
(Comp_Unit_Node
));
446 New_Node
(N_Subprogram_Declaration
, Sloc
(Comp_Unit_Node
));
447 Set_Specification
(Unit_Node
,
448 Specification
(Unit
(Comp_Unit_Node
)));
449 Set_Unit
(Comp_Unit_Node
, Unit_Node
);
452 -- Otherwise we have TASK. This is not really an acceptable token,
453 -- but we accept it to improve error recovery.
455 elsif Token
= Tok_Task
then
458 if Token
= Tok_Type
then
460 ("task type cannot be used as compilation unit");
463 ("task declaration cannot be used as compilation unit");
466 -- If in check syntax mode, accept the task anyway. This is done
467 -- particularly to improve the behavior of GNATCHOP in this case.
469 if Operating_Mode
= Check_Syntax
then
470 Set_Unit
(Comp_Unit_Node
, P_Task
);
472 -- If not in syntax only mode, treat this as horrible error
475 Cunit_Error_Flag
:= True;
479 else pragma Assert
(Token
= Tok_Protected
);
480 Scan
; -- Past PROTECTED
482 if Token
= Tok_Type
then
484 ("protected type cannot be used as compilation unit");
487 ("protected declaration cannot be used as compilation unit");
490 -- If in check syntax mode, accept protected anyway. This is done
491 -- particularly to improve the behavior of GNATCHOP in this case.
493 if Operating_Mode
= Check_Syntax
then
494 Set_Unit
(Comp_Unit_Node
, P_Protected
);
496 -- If not in syntax only mode, treat this as horrible error
499 Cunit_Error_Flag
:= True;
504 -- Here is where locate the compilation unit entity. This is a little
505 -- tricky, since it is buried in various places.
507 Unit_Node
:= Unit
(Comp_Unit_Node
);
509 -- Another error from which it is hard to recover
511 if Nkind_In
(Unit_Node
, N_Subprogram_Body_Stub
, N_Package_Body_Stub
) then
512 Cunit_Error_Flag
:= True;
516 -- Only try this if we got an OK unit!
518 if Unit_Node
/= Error
then
519 if Nkind
(Unit_Node
) = N_Subunit
then
520 Unit_Node
:= Proper_Body
(Unit_Node
);
523 if Nkind
(Unit_Node
) in N_Generic_Declaration
then
524 Unit_Node
:= Specification
(Unit_Node
);
527 if Nkind_In
(Unit_Node
, N_Package_Declaration
,
528 N_Subprogram_Declaration
,
530 N_Subprogram_Renaming_Declaration
)
532 Unit_Node
:= Specification
(Unit_Node
);
534 elsif Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
then
535 if Ada_Version
= Ada_83
then
537 ("(Ada 83) library unit renaming not allowed", Unit_Node
);
541 if Nkind_In
(Unit_Node
, N_Task_Body
,
543 N_Task_Type_Declaration
,
544 N_Protected_Type_Declaration
,
545 N_Single_Task_Declaration
,
546 N_Single_Protected_Declaration
)
548 Name_Node
:= Defining_Identifier
(Unit_Node
);
550 elsif Nkind_In
(Unit_Node
, N_Function_Instantiation
,
551 N_Function_Specification
,
552 N_Generic_Function_Renaming_Declaration
,
553 N_Generic_Package_Renaming_Declaration
,
554 N_Generic_Procedure_Renaming_Declaration
)
556 Nkind_In
(Unit_Node
, N_Package_Body
,
557 N_Package_Instantiation
,
558 N_Package_Renaming_Declaration
,
559 N_Package_Specification
,
560 N_Procedure_Instantiation
,
561 N_Procedure_Specification
)
563 Name_Node
:= Defining_Unit_Name
(Unit_Node
);
565 elsif Nkind
(Unit_Node
) = N_Expression_Function
then
567 ("expression function cannot be used as compilation unit");
568 return Comp_Unit_Node
;
570 -- Anything else is a serious error, abandon scan
576 Set_Sloc
(Comp_Unit_Node
, Sloc
(Name_Node
));
577 Set_Sloc
(Aux_Decls_Node
(Comp_Unit_Node
), Sloc
(Name_Node
));
579 -- Set Entity field in file table. Easier now that we have name!
580 -- Note that this is also skipped if we had a bad unit
582 if Nkind
(Name_Node
) = N_Defining_Program_Unit_Name
then
584 (Current_Source_Unit
, Defining_Identifier
(Name_Node
));
586 Set_Cunit_Entity
(Current_Source_Unit
, Name_Node
);
590 (Current_Source_Unit
, Get_Unit_Name
(Unit
(Comp_Unit_Node
)));
592 -- If we had a bad unit, make sure the fatal flag is set in the file
593 -- table entry, since this is surely a fatal error and also set our
594 -- flag to inhibit the requirement that we be at end of file.
597 Cunit_Error_Flag
:= True;
598 Set_Fatal_Error
(Current_Source_Unit
);
601 -- Clear away any missing semicolon indication, we are done with that
602 -- unit, so what's done is done, and we don't want anything hanging
603 -- around from the attempt to parse it!
605 SIS_Entry_Active
:= False;
607 -- Scan out pragmas after unit
609 while Token
= Tok_Pragma
loop
610 Save_Scan_State
(Scan_State
);
612 -- If we are in syntax scan mode allowing multiple units, then start
613 -- the next unit if we encounter a configuration pragma, or a source
614 -- reference pragma. We take care not to actually scan the pragma in
615 -- this case (we don't want it to take effect for the current unit).
617 if Operating_Mode
= Check_Syntax
then
620 if Token
= Tok_Identifier
622 (Is_Configuration_Pragma_Name
(Token_Name
)
623 or else Token_Name
= Name_Source_Reference
)
625 Restore_Scan_State
(Scan_State
); -- to Pragma
630 -- Otherwise eat the pragma, it definitely belongs with the
631 -- current unit, and not with the following unit.
633 Restore_Scan_State
(Scan_State
); -- to Pragma
636 if No
(Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
))) then
638 (Aux_Decls_Node
(Comp_Unit_Node
), New_List
);
641 Append
(P
, Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
)));
644 -- Cancel effect of any outstanding pragma Warnings (Off)
646 Set_Warnings_Mode_On
(Scan_Ptr
);
648 -- Ada 83 error checks
650 if Ada_Version
= Ada_83
then
652 -- Check we did not with any child units
654 Item
:= First
(Context_Items
(Comp_Unit_Node
));
655 while Present
(Item
) loop
656 if Nkind
(Item
) = N_With_Clause
657 and then Nkind
(Name
(Item
)) /= N_Identifier
659 Error_Msg_N
("(Ada 83) child units not allowed", Item
);
665 -- Check that we did not have a PRIVATE keyword present
667 if Private_Present
(Comp_Unit_Node
) then
669 ("(Ada 83) private units not allowed", Private_Sloc
);
673 -- If no serious error, then output possible unit information line
674 -- for gnatchop if we are in syntax only, list units mode.
676 if not Cunit_Error_Flag
678 and then Operating_Mode
= Check_Syntax
680 Unit_Display
(Comp_Unit_Node
, Cunit_Location
, SR_Present
);
683 -- And now we should be at the end of file
685 if Token
/= Tok_EOF
then
687 -- If we already had to scan for a compilation unit, then don't
688 -- give any further error message, since it just seems to make
689 -- things worse, and we already gave a serious error message.
691 if Cunit_Error_Flag
then
694 -- If we are in check syntax mode, then we allow multiple units
695 -- so we just return with Token not set to Tok_EOF and no message.
697 elsif Operating_Mode
= Check_Syntax
then
698 return Comp_Unit_Node
;
700 -- We also allow multiple units if we are in multiple unit mode
702 elsif Multiple_Unit_Index
/= 0 then
704 -- Skip tokens to end of file, so that the -gnatl listing
705 -- will be complete in this situation, but no need to parse
706 -- the remaining units; no style checking either.
709 Save_Style_Check
: constant Boolean := Style_Check
;
712 Style_Check
:= False;
714 while Token
/= Tok_EOF
loop
718 Style_Check
:= Save_Style_Check
;
721 return Comp_Unit_Node
;
723 -- Otherwise we have an error. We suppress the error message
724 -- if we already had a fatal error, since this stops junk
725 -- cascaded messages in some situations.
728 if not Fatal_Error
(Current_Source_Unit
) then
729 if Token
in Token_Class_Cunit
then
731 ("end of file expected, " &
732 "file can have only one compilation unit");
734 Error_Msg_SC
("end of file expected");
739 -- Skip tokens to end of file, so that the -gnatl listing
740 -- will be complete in this situation, but no error checking
741 -- other than that provided at the token level.
743 while Token
/= Tok_EOF
loop
749 -- Normal return (we were at the end of file as expected)
752 return Comp_Unit_Node
;
757 -- An error resync is a serious bomb, so indicate result unit no good
760 Set_Fatal_Error
(Current_Source_Unit
);
762 end P_Compilation_Unit
;
764 --------------------------
765 -- 10.1.1 Library Item --
766 --------------------------
768 -- Parsed by P_Compilation_Unit (10.1.1)
770 --------------------------------------
771 -- 10.1.1 Library Unit Declaration --
772 --------------------------------------
774 -- Parsed by P_Compilation_Unit (10.1.1)
776 ------------------------------------------------
777 -- 10.1.1 Library Unit Renaming Declaration --
778 ------------------------------------------------
780 -- Parsed by P_Compilation_Unit (10.1.1)
782 -------------------------------
783 -- 10.1.1 Library Unit Body --
784 -------------------------------
786 -- Parsed by P_Compilation_Unit (10.1.1)
788 ------------------------------
789 -- 10.1.1 Parent Unit Name --
790 ------------------------------
792 -- Parsed (as a name) by its parent construct
794 ----------------------------
795 -- 10.1.2 Context Clause --
796 ----------------------------
798 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
800 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
803 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
804 -- Note: the two qualifiers are Ada 2005 extensions.
806 -- WITH_TYPE_CLAUSE ::=
807 -- with type type_NAME is access; | with type type_NAME is tagged;
808 -- Note: this form is obsolete (old GNAT extension).
810 -- Error recovery: Cannot raise Error_Resync
812 function P_Context_Clause
return List_Id
is
814 Has_Limited
: Boolean := False;
815 Has_Private
: Boolean := False;
816 Scan_State
: Saved_Scan_State
;
818 First_Flag
: Boolean;
821 Item_List
:= New_List
;
823 -- Get keyword casing from WITH keyword in case not set yet
825 if Token
= Tok_With
then
826 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
829 -- Loop through context items
833 Style
.Check_Indentation
;
836 -- Gather any pragmas appearing in the context clause
838 P_Pragmas_Opt
(Item_List
);
840 -- Processing for WITH clause
842 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
843 -- PRIVATE WITH, or both.
845 if Token
= Tok_Limited
then
847 Has_Private
:= False;
848 Scan
; -- past LIMITED
850 -- In the context, LIMITED can only appear in a with_clause
852 if Token
= Tok_Private
then
854 Scan
; -- past PRIVATE
857 if Token
/= Tok_With
then
858 Error_Msg_SC
-- CODEFIX
859 ("unexpected LIMITED ignored");
862 if Ada_Version
< Ada_2005
then
863 Error_Msg_SP
("LIMITED WITH is an Ada 2005 extension");
865 ("\unit must be compiled with -gnat05 switch");
868 elsif Token
= Tok_Private
then
869 Has_Limited
:= False;
871 Save_Scan_State
(Scan_State
);
872 Scan
; -- past PRIVATE
874 if Token
/= Tok_With
then
876 -- Keyword is beginning of private child unit
878 Restore_Scan_State
(Scan_State
); -- to PRIVATE
881 elsif Ada_Version
< Ada_2005
then
882 Error_Msg_SP
("`PRIVATE WITH` is an Ada 2005 extension");
884 ("\unit must be compiled with -gnat05 switch");
888 Has_Limited
:= False;
889 Has_Private
:= False;
892 if Token
= Tok_With
then
895 if Token
= Tok_Type
then
897 -- WITH TYPE is an obsolete GNAT specific extension
899 Error_Msg_SP
("`WITH TYPE` is an obsolete 'G'N'A'T extension");
900 Error_Msg_SP
("\use Ada 2005 `LIMITED WITH` clause instead");
906 if Token
= Tok_Tagged
then
909 elsif Token
= Tok_Access
then
913 Error_Msg_SC
("expect tagged or access qualifier");
921 -- Loop through names in one with clause, generating a separate
922 -- N_With_Clause node for each name encountered.
925 With_Node
:= New_Node
(N_With_Clause
, Token_Ptr
);
926 Append
(With_Node
, Item_List
);
928 -- Note that we allow with'ing of child units, even in
929 -- Ada 83 mode, since presumably if this is not desired,
930 -- then the compilation of the child unit itself is the
931 -- place where such an "error" should be caught.
933 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
934 if Name
(With_Node
) = Error
then
938 Set_First_Name
(With_Node
, First_Flag
);
939 Set_Limited_Present
(With_Node
, Has_Limited
);
940 Set_Private_Present
(With_Node
, Has_Private
);
943 -- All done if no comma
945 exit when Token
/= Tok_Comma
;
947 -- If comma is followed by compilation unit token
948 -- or by USE, or PRAGMA, then it should have been a
949 -- semicolon after all
951 Save_Scan_State
(Scan_State
);
954 if Token
in Token_Class_Cunit
955 or else Token
= Tok_Use
956 or else Token
= Tok_Pragma
958 Restore_Scan_State
(Scan_State
);
963 Set_Last_Name
(With_Node
, True);
967 -- Processing for USE clause
969 elsif Token
= Tok_Use
then
970 Append
(P_Use_Clause
, Item_List
);
972 -- Anything else is end of context clause
980 end P_Context_Clause
;
982 --------------------------
983 -- 10.1.2 Context Item --
984 --------------------------
986 -- Parsed by P_Context_Clause (10.1.2)
988 -------------------------
989 -- 10.1.2 With Clause --
990 -------------------------
992 -- Parsed by P_Context_Clause (10.1.2)
994 -----------------------
995 -- 10.1.3 Body Stub --
996 -----------------------
998 -- Subprogram stub parsed by P_Subprogram (6.1)
999 -- Package stub parsed by P_Package (7.1)
1000 -- Task stub parsed by P_Task (9.1)
1001 -- Protected stub parsed by P_Protected (9.4)
1003 ----------------------------------
1004 -- 10.1.3 Subprogram Body Stub --
1005 ----------------------------------
1007 -- Parsed by P_Subprogram (6.1)
1009 -------------------------------
1010 -- 10.1.3 Package Body Stub --
1011 -------------------------------
1013 -- Parsed by P_Package (7.1)
1015 ----------------------------
1016 -- 10.1.3 Task Body Stub --
1017 ----------------------------
1019 -- Parsed by P_Task (9.1)
1021 ---------------------------------
1022 -- 10.1.3 Protected Body Stub --
1023 ---------------------------------
1025 -- Parsed by P_Protected (9.4)
1027 ---------------------
1028 -- 10.1.3 Subunit --
1029 ---------------------
1031 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
1033 -- PARENT_UNIT_NAME ::= NAME
1035 -- The caller has checked that the initial token is SEPARATE
1037 -- Error recovery: cannot raise Error_Resync
1039 function P_Subunit
return Node_Id
is
1040 Subunit_Node
: Node_Id
;
1041 Body_Node
: Node_Id
;
1044 Subunit_Node
:= New_Node
(N_Subunit
, Token_Ptr
);
1045 Body_Node
:= Error
; -- in case no good body found
1046 Scan
; -- past SEPARATE;
1049 Set_Name
(Subunit_Node
, P_Qualified_Simple_Name
);
1052 Ignore
(Tok_Semicolon
);
1054 if Token
= Tok_Function
1055 or else Token
= Tok_Not
1056 or else Token
= Tok_Overriding
1057 or else Token
= Tok_Procedure
1059 Body_Node
:= P_Subprogram
(Pf_Pbod_Pexp
);
1061 elsif Token
= Tok_Package
then
1062 Body_Node
:= P_Package
(Pf_Pbod_Pexp
);
1064 elsif Token
= Tok_Protected
then
1065 Scan
; -- past PROTECTED
1067 if Token
= Tok_Body
then
1068 Body_Node
:= P_Protected
;
1070 Error_Msg_AP
("BODY expected");
1074 elsif Token
= Tok_Task
then
1077 if Token
= Tok_Body
then
1078 Body_Node
:= P_Task
;
1080 Error_Msg_AP
("BODY expected");
1085 Error_Msg_SC
("proper body expected");
1089 Set_Proper_Body
(Subunit_Node
, Body_Node
);
1090 return Subunit_Node
;
1097 function Set_Location
return Source_Ptr
is
1100 Scan_State
: Saved_Scan_State
;
1103 -- A special check. If the first token is pragma, and this is a
1104 -- Source_Reference pragma, then do NOT eat previous comments, since
1105 -- the Source_Reference pragma is required to be the first line in
1108 if Token
= Tok_Pragma
then
1109 Save_Scan_State
(Scan_State
);
1110 Scan
; -- past Pragma
1112 if Token
= Tok_Identifier
1113 and then Token_Name
= Name_Source_Reference
1115 Restore_Scan_State
(Scan_State
);
1119 Restore_Scan_State
(Scan_State
);
1122 -- Otherwise acquire previous comments and blank lines
1124 if Prev_Token
= No_Token
then
1125 return Source_First
(Current_Source_File
);
1128 Loc
:= Prev_Token_Ptr
;
1130 exit when Loc
= Token_Ptr
;
1132 -- Should we worry about UTF_32 line terminators here
1134 if Source
(Loc
) in Line_Terminator
then
1135 Skip_Line_Terminators
(Loc
, Physical
);
1150 -- The format of the generated line, as expected by GNATCHOP is
1152 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1156 -- {unit} unit name with terminating (spec) or (body)
1157 -- {line} starting line number
1158 -- {offs} offset to start of text in file
1159 -- {file} source file name
1161 -- The SR parameter is present only if a source reference pragma was
1162 -- scanned for this unit. The significance is that gnatchop should not
1163 -- attempt to add another one.
1165 procedure Unit_Display
1168 SR_Present
: Boolean)
1170 Unum
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Cunit
);
1171 Sind
: constant Source_File_Index
:= Source_Index
(Unum
);
1172 Unam
: constant Unit_Name_Type
:= Unit_Name
(Unum
);
1176 Write_Str
("Unit ");
1177 Write_Unit_Name
(Unit_Name
(Unum
));
1178 Unit_Location
(Sind
, Loc
);
1184 Write_Str
(", file name ");
1185 Write_Name
(Get_File_Name
(Unam
, Nkind
(Unit
(Cunit
)) = N_Subunit
));
1194 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
) is
1195 Line
: constant Logical_Line_Number
:= Get_Logical_Line_Number
(Loc
);
1196 -- Should the above be the physical line number ???
1199 Write_Str
(" line ");
1200 Write_Int
(Int
(Line
));
1202 Write_Str
(", file offset ");
1203 Write_Int
(Int
(Loc
) - Int
(Source_First
(Sind
)));