1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks
(All_Checks
);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
31 with Fname
.UF
; use Fname
.UF
;
32 with Uname
; use Uname
;
37 -- Local functions, used only in this chapter
39 function P_Context_Clause
return List_Id
;
40 function P_Subunit
return Node_Id
;
42 function Set_Location
return Source_Ptr
;
43 -- The current compilation unit starts with Token at Token_Ptr. This
44 -- function determines the corresponding source location for the start
45 -- of the unit, including any preceding comment lines.
47 procedure Unit_Display
50 SR_Present
: Boolean);
51 -- This procedure is used to generate a line of output for the a unit in
52 -- the source program. Cunit is the node for the compilation unit, and
53 -- Loc is the source location for the start of the unit in the source
54 -- file (which is not necessarily the Sloc of the Cunit node). This
55 -- output is written to the standard output file for use by gnatchop.
57 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
);
58 -- This routine has the same calling sequence as Unit_Display, but
59 -- it outputs only the line number and offset of the location, Loc,
60 -- using Cunit to obtain the proper source file index.
62 -------------------------
63 -- 10.1.1 Compilation --
64 -------------------------
66 -- COMPILATION ::= {COMPILATION_UNIT}
68 -- There is no specific parsing routine for a compilation, since we only
69 -- permit a single compilation in a source file, so there is no explicit
70 -- occurrence of compilations as such (our representation of a compilation
71 -- is a series of separate source files).
73 ------------------------------
74 -- 10.1.1 Compilation unit --
75 ------------------------------
77 -- COMPILATION_UNIT ::=
78 -- CONTEXT_CLAUSE LIBRARY_ITEM
79 -- | CONTEXT_CLAUSE SUBUNIT
82 -- private LIBRARY_UNIT_DECLARATION
83 -- | LIBRARY_UNIT_BODY
84 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
86 -- LIBRARY_UNIT_DECLARATION ::=
87 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
88 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
90 -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
91 -- PACKAGE_RENAMING_DECLARATION
92 -- | GENERIC_RENAMING_DECLARATION
93 -- | SUBPROGRAM_RENAMING_DECLARATION
95 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
97 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
98 -- are skipped up to the next possible beginning of a compilation unit.
100 -- Note: if only configuration pragmas are found, Empty is returned
102 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit
103 -- to return strange things that are not really compilation units.
104 -- This is done to help out gnatchop when it is faced with nonsense.
106 function P_Compilation_Unit
return Node_Id
is
107 Scan_State
: Saved_Scan_State
;
109 Specification_Node
: Node_Id
;
111 Comp_Unit_Node
: Node_Id
;
114 Private_Sloc
: Source_Ptr
:= No_Location
;
115 Config_Pragmas
: List_Id
;
117 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 sytax 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
145 -- the fact to generate an NR parameter in the output line.
149 if Token
= Tok_Pragma
then
150 Save_Scan_State
(Scan_State
);
154 or else Chars
(Item
) /= Name_Source_Reference
156 Restore_Scan_State
(Scan_State
);
161 -- If first unit, record the file name for gnatchop use
163 if Operating_Mode
= Check_Syntax
165 and then Num_Library_Units
= 1
167 Write_Str
("Source_Reference pragma for file """);
168 Write_Name
(Full_Ref_Name
(Current_Source_File
));
173 Config_Pragmas
:= New_List
(Item
);
177 -- Scan out any configuration pragmas
179 while Token
= Tok_Pragma
loop
180 Save_Scan_State
(Scan_State
);
184 or else Chars
(Item
) > Last_Configuration_Pragma_Name
186 Restore_Scan_State
(Scan_State
);
190 if Config_Pragmas
= No_List
then
191 Config_Pragmas
:= Empty_List
;
193 if Operating_Mode
= Check_Syntax
and then List_Units
then
194 Write_Str
("Configuration pragmas at");
195 Unit_Location
(Current_Source_File
, Cunit_Location
);
200 Append
(Item
, Config_Pragmas
);
201 Cunit_Location
:= Set_Location
;
204 -- Establish compilation unit node and scan context items
206 Comp_Unit_Node
:= New_Node
(N_Compilation_Unit
, No_Location
);
207 Set_Cunit
(Current_Source_Unit
, Comp_Unit_Node
);
208 Set_Context_Items
(Comp_Unit_Node
, P_Context_Clause
);
210 (Comp_Unit_Node
, New_Node
(N_Compilation_Unit_Aux
, No_Location
));
212 if Present
(Config_Pragmas
) then
214 -- Check for case of only configuration pragmas present
217 and then Is_Empty_List
(Context_Items
(Comp_Unit_Node
))
219 if Operating_Mode
= Check_Syntax
then
223 Item
:= First
(Config_Pragmas
);
225 ("cannot compile configuration pragmas with gcc", Item
);
227 ("use gnatchop -c to process configuration pragmas!", Item
);
228 raise Unrecoverable_Error
;
231 -- Otherwise configuration pragmas are simply prepended to the
232 -- context of the current unit.
235 Append_List
(Context_Items
(Comp_Unit_Node
), Config_Pragmas
);
236 Set_Context_Items
(Comp_Unit_Node
, Config_Pragmas
);
240 -- Check for PRIVATE. Note that for the moment we allow this in
241 -- Ada_83 mode, since we do not yet know if we are compiling a
242 -- predefined unit, and if we are then it would be allowed anyway.
244 if Token
= Tok_Private
then
245 Private_Sloc
:= Token_Ptr
;
246 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
247 if Style_Check
then Style
.Check_Indentation
; end if;
249 Save_Scan_State
(Scan_State
); -- at PRIVATE
250 Scan
; -- past PRIVATE
252 if Token
= Tok_Separate
then
253 Error_Msg_SP
("cannot have private subunits!");
255 elsif Token
= Tok_Package
then
256 Scan
; -- past PACKAGE
258 if Token
= Tok_Body
then
259 Restore_Scan_State
(Scan_State
); -- to PRIVATE
260 Error_Msg_SC
("cannot have private package body!");
261 Scan
; -- ignore PRIVATE
264 Restore_Scan_State
(Scan_State
); -- to PRIVATE
265 Scan
; -- past PRIVATE
266 Set_Private_Present
(Comp_Unit_Node
, True);
269 elsif Token
= Tok_Procedure
270 or else Token
= Tok_Function
271 or else Token
= Tok_Generic
273 Set_Private_Present
(Comp_Unit_Node
, True);
277 -- Loop to find our way to a compilation unit token
280 exit when Token
in Token_Class_Cunit
and then Token
/= Tok_With
;
282 exit when Bad_Spelling_Of
(Tok_Package
)
283 or else Bad_Spelling_Of
(Tok_Function
)
284 or else Bad_Spelling_Of
(Tok_Generic
)
285 or else Bad_Spelling_Of
(Tok_Separate
)
286 or else Bad_Spelling_Of
(Tok_Procedure
);
288 -- Allow task and protected for nice error recovery purposes
290 exit when Token
= Tok_Task
291 or else Token
= Tok_Protected
;
293 if Token
= Tok_With
then
294 Error_Msg_SC
("misplaced WITH");
295 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
297 elsif Bad_Spelling_Of
(Tok_With
) then
298 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
301 if Operating_Mode
= Check_Syntax
and then Token
= Tok_EOF
then
302 Error_Msg_SC
("?file contains no compilation units");
304 Error_Msg_SC
("compilation unit expected");
305 Cunit_Error_Flag
:= True;
309 -- If we are at an end of file, then just quit, the above error
310 -- message was complaint enough.
312 if Token
= Tok_EOF
then
318 -- We have a compilation unit token, so that's a reasonable choice for
319 -- determining the standard casing convention used for keywords in case
320 -- it hasn't already been done on seeing a WITH or PRIVATE.
322 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
323 if Style_Check
then Style
.Check_Indentation
; end if;
325 -- Remaining processing depends on particular type of compilation unit
327 if Token
= Tok_Package
then
329 -- A common error is to omit the body keyword after package. We can
330 -- often diagnose this early on (before getting loads of errors from
331 -- contained subprogram bodies), by knowing that that the file we
332 -- are compiling has a name that requires a body to be found.
334 Save_Scan_State
(Scan_State
);
335 Scan
; -- past Package keyword
339 Get_Expected_Unit_Type
340 (File_Name
(Current_Source_File
)) = Expect_Body
342 Error_Msg_BC
("keyword BODY expected here [see file name]");
343 Restore_Scan_State
(Scan_State
);
344 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Pbod
));
346 Restore_Scan_State
(Scan_State
);
347 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Decl_Gins_Pbod_Rnam
));
350 elsif Token
= Tok_Generic
then
351 Set_Unit
(Comp_Unit_Node
, P_Generic
);
353 elsif Token
= Tok_Separate
then
354 Set_Unit
(Comp_Unit_Node
, P_Subunit
);
356 elsif Token
= Tok_Function
357 or else Token
= Tok_Not
358 or else Token
= Tok_Overriding
359 or else Token
= Tok_Procedure
361 Set_Unit
(Comp_Unit_Node
, P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam
));
363 -- A little bit of an error recovery check here. If we just scanned
364 -- a subprogram declaration (as indicated by an SIS entry being
365 -- active), then if the following token is BEGIN or an identifier,
366 -- or a token which can reasonably start a declaration but cannot
367 -- start a compilation unit, then we assume that the semicolon in
368 -- the declaration should have been IS.
370 if SIS_Entry_Active
then
373 or else Token
= Tok_Identifier
374 or else Token
in Token_Class_Deckn
377 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
378 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
379 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
380 Scope
.Table
(Scope
.Last
).Lreq
:= False;
381 SIS_Entry_Active
:= False;
383 -- If we had a missing semicolon in the declaration, then
384 -- change the message to from <missing ";"> to <missing "is">
386 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
387 Change_Error_Text
-- Replace: "missing "";"" "
388 (SIS_Missing_Semicolon_Message
, "missing IS");
390 -- Otherwise we saved the semicolon position, so complain
393 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
396 Body_Node
:= Unit
(Comp_Unit_Node
);
397 Specification_Node
:= Specification
(Body_Node
);
398 Change_Node
(Body_Node
, N_Subprogram_Body
);
399 Set_Specification
(Body_Node
, Specification_Node
);
400 Parse_Decls_Begin_End
(Body_Node
);
401 Set_Unit
(Comp_Unit_Node
, Body_Node
);
404 -- If we scanned a subprogram body, make sure we did not have private
406 elsif Private_Sloc
/= No_Location
408 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Function_Instantiation
410 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Procedure_Instantiation
412 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Subprogram_Renaming_Declaration
414 Error_Msg
("cannot have private subprogram body", Private_Sloc
);
416 -- P_Subprogram can yield an abstract subprogram, but this cannot
417 -- be a compilation unit. Treat as a subprogram declaration.
420 Nkind
(Unit
(Comp_Unit_Node
)) = N_Abstract_Subprogram_Declaration
423 ("compilation unit cannot be abstract subprogram",
424 Unit
(Comp_Unit_Node
));
427 New_Node
(N_Subprogram_Declaration
, Sloc
(Comp_Unit_Node
));
428 Set_Specification
(Unit_Node
,
429 Specification
(Unit
(Comp_Unit_Node
)));
430 Set_Unit
(Comp_Unit_Node
, Unit_Node
);
433 -- Otherwise we have TASK. This is not really an acceptable token,
434 -- but we accept it to improve error recovery.
436 elsif Token
= Tok_Task
then
439 if Token
= Tok_Type
then
441 ("task type cannot be used as compilation unit");
444 ("task declaration cannot be used as compilation unit");
447 -- If in check syntax mode, accept the task anyway. This is done
448 -- particularly to improve the behavior of GNATCHOP in this case.
450 if Operating_Mode
= Check_Syntax
then
451 Set_Unit
(Comp_Unit_Node
, P_Task
);
453 -- If not in syntax only mode, treat this as horrible error
456 Cunit_Error_Flag
:= True;
460 else pragma Assert
(Token
= Tok_Protected
);
461 Scan
; -- Past PROTECTED
463 if Token
= Tok_Type
then
465 ("protected type cannot be used as compilation unit");
468 ("protected declaration cannot be used as compilation unit");
471 -- If in check syntax mode, accept protected anyway. This is done
472 -- particularly to improve the behavior of GNATCHOP in this case.
474 if Operating_Mode
= Check_Syntax
then
475 Set_Unit
(Comp_Unit_Node
, P_Protected
);
477 -- If not in syntax only mode, treat this as horrible error
480 Cunit_Error_Flag
:= True;
485 -- Here is where locate the compilation unit entity. This is a little
486 -- tricky, since it is buried in various places.
488 Unit_Node
:= Unit
(Comp_Unit_Node
);
490 -- Another error from which it is hard to recover
492 if Nkind
(Unit_Node
) = N_Subprogram_Body_Stub
493 or else Nkind
(Unit_Node
) = N_Package_Body_Stub
495 Cunit_Error_Flag
:= True;
499 -- Only try this if we got an OK unit!
501 if Unit_Node
/= Error
then
502 if Nkind
(Unit_Node
) = N_Subunit
then
503 Unit_Node
:= Proper_Body
(Unit_Node
);
506 if Nkind
(Unit_Node
) in N_Generic_Declaration
then
507 Unit_Node
:= Specification
(Unit_Node
);
510 if Nkind
(Unit_Node
) = N_Package_Declaration
511 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
512 or else Nkind
(Unit_Node
) = N_Subprogram_Body
513 or else Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
515 Unit_Node
:= Specification
(Unit_Node
);
517 elsif Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
then
518 if Ada_Version
= Ada_83
then
520 ("(Ada 83) library unit renaming not allowed", Unit_Node
);
524 if Nkind
(Unit_Node
) = N_Task_Body
525 or else Nkind
(Unit_Node
) = N_Protected_Body
526 or else Nkind
(Unit_Node
) = N_Task_Type_Declaration
527 or else Nkind
(Unit_Node
) = N_Protected_Type_Declaration
528 or else Nkind
(Unit_Node
) = N_Single_Task_Declaration
529 or else Nkind
(Unit_Node
) = N_Single_Protected_Declaration
531 Name_Node
:= Defining_Identifier
(Unit_Node
);
533 Name_Node
:= Defining_Unit_Name
(Unit_Node
);
536 Set_Sloc
(Comp_Unit_Node
, Sloc
(Name_Node
));
537 Set_Sloc
(Aux_Decls_Node
(Comp_Unit_Node
), Sloc
(Name_Node
));
539 -- Set Entity field in file table. Easier now that we have name!
540 -- Note that this is also skipped if we had a bad unit
542 if Nkind
(Name_Node
) = N_Defining_Program_Unit_Name
then
544 (Current_Source_Unit
, Defining_Identifier
(Name_Node
));
546 Set_Cunit_Entity
(Current_Source_Unit
, Name_Node
);
550 (Current_Source_Unit
, Get_Unit_Name
(Unit
(Comp_Unit_Node
)));
552 -- If we had a bad unit, make sure the fatal flag is set in the file
553 -- table entry, since this is surely a fatal error and also set our
554 -- flag to inhibit the requirement that we be at end of file.
557 Cunit_Error_Flag
:= True;
558 Set_Fatal_Error
(Current_Source_Unit
);
561 -- Clear away any missing semicolon indication, we are done with that
562 -- unit, so what's done is done, and we don't want anything hanging
563 -- around from the attempt to parse it!
565 SIS_Entry_Active
:= False;
567 -- Scan out pragmas after unit
569 while Token
= Tok_Pragma
loop
570 Save_Scan_State
(Scan_State
);
572 -- If we are in syntax scan mode allowing multiple units, then
573 -- start the next unit if we encounter a configuration pragma,
574 -- or a source reference pragma. We take care not to actually
575 -- scan the pragma in this case since we don't want it to take
576 -- effect for the current unit.
578 if Operating_Mode
= Check_Syntax
then
581 if Token
= Tok_Identifier
584 First_Pragma_Name
.. Last_Configuration_Pragma_Name
585 or else Token_Name
= Name_Source_Reference
)
587 Restore_Scan_State
(Scan_State
); -- to Pragma
592 -- Otherwise eat the pragma, it definitely belongs with the
593 -- current unit, and not with the following unit.
595 Restore_Scan_State
(Scan_State
); -- to Pragma
598 if No
(Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
))) then
600 (Aux_Decls_Node
(Comp_Unit_Node
), New_List
);
603 Append
(P
, Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
)));
606 -- Cancel effect of any outstanding pragma Warnings (Off)
608 Set_Warnings_Mode_On
(Scan_Ptr
);
610 -- Ada 83 error checks
612 if Ada_Version
= Ada_83
then
614 -- Check we did not with any child units
616 Item
:= First
(Context_Items
(Comp_Unit_Node
));
618 while Present
(Item
) loop
619 if Nkind
(Item
) = N_With_Clause
620 and then Nkind
(Name
(Item
)) /= N_Identifier
622 Error_Msg_N
("(Ada 83) child units not allowed", Item
);
628 -- Check that we did not have a PRIVATE keyword present
630 if Private_Present
(Comp_Unit_Node
) then
632 ("(Ada 83) private units not allowed", Private_Sloc
);
636 -- If no serious error, then output possible unit information line
637 -- for gnatchop if we are in syntax only, list units mode.
639 if not Cunit_Error_Flag
641 and then Operating_Mode
= Check_Syntax
643 Unit_Display
(Comp_Unit_Node
, Cunit_Location
, SR_Present
);
646 -- And now we should be at the end of file
648 if Token
/= Tok_EOF
then
650 -- If we already had to scan for a compilation unit, then don't
651 -- give any further error message, since it just sems to make
652 -- things worse, and we already gave a serious error message.
654 if Cunit_Error_Flag
then
657 -- If we are in check syntax mode, then we allow multiple units
658 -- so we just return with Token not set to Tok_EOF and no message.
660 elsif Operating_Mode
= Check_Syntax
then
661 return Comp_Unit_Node
;
663 -- We also allow multiple units if we are in multiple unit mode
665 elsif Multiple_Unit_Index
/= 0 then
667 -- Skip tokens to end of file, so that the -gnatl listing
668 -- will be complete in this situation, but no need to parse
669 -- the remaining units; no style checking either.
672 Save_Style_Check
: constant Boolean := Style_Check
;
675 Style_Check
:= False;
677 while Token
/= Tok_EOF
loop
681 Style_Check
:= Save_Style_Check
;
684 return Comp_Unit_Node
;
686 -- Otherwise we have an error. We suppress the error message
687 -- if we already had a fatal error, since this stops junk
688 -- cascaded messages in some situations.
691 if not Fatal_Error
(Current_Source_Unit
) then
692 if Token
in Token_Class_Cunit
then
694 ("end of file expected, " &
695 "file can have only one compilation unit");
697 Error_Msg_SC
("end of file expected");
702 -- Skip tokens to end of file, so that the -gnatl listing
703 -- will be complete in this situation, but no error checking
704 -- other than that provided at the token level.
706 while Token
/= Tok_EOF
loop
712 -- Normal return (we were at the end of file as expected)
715 return Comp_Unit_Node
;
720 -- An error resync is a serious bomb, so indicate result unit no good
723 Set_Fatal_Error
(Current_Source_Unit
);
725 end P_Compilation_Unit
;
727 --------------------------
728 -- 10.1.1 Library Item --
729 --------------------------
731 -- Parsed by P_Compilation_Unit (10.1.1)
733 --------------------------------------
734 -- 10.1.1 Library Unit Declaration --
735 --------------------------------------
737 -- Parsed by P_Compilation_Unit (10.1.1)
739 ------------------------------------------------
740 -- 10.1.1 Library Unit Renaming Declaration --
741 ------------------------------------------------
743 -- Parsed by P_Compilation_Unit (10.1.1)
745 -------------------------------
746 -- 10.1.1 Library Unit Body --
747 -------------------------------
749 -- Parsed by P_Compilation_Unit (10.1.1)
751 ------------------------------
752 -- 10.1.1 Parent Unit Name --
753 ------------------------------
755 -- Parsed (as a name) by its parent construct
757 ----------------------------
758 -- 10.1.2 Context Clause --
759 ----------------------------
761 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
763 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
766 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
767 -- Note: the two qualifiers are Ada 2005 extensions.
769 -- WITH_TYPE_CLAUSE ::=
770 -- with type type_NAME is access; | with type type_NAME is tagged;
771 -- Note: this form is obsolete (old GNAT extension).
773 -- Error recovery: Cannot raise Error_Resync
775 function P_Context_Clause
return List_Id
is
777 Has_Limited
: Boolean := False;
778 Has_Private
: Boolean := False;
779 Scan_State
: Saved_Scan_State
;
781 First_Flag
: Boolean;
784 Item_List
:= New_List
;
786 -- Get keyword casing from WITH keyword in case not set yet
788 if Token
= Tok_With
then
789 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
792 -- Loop through context items
795 if Style_Check
then Style
.Check_Indentation
; end if;
797 -- Gather any pragmas appearing in the context clause
799 P_Pragmas_Opt
(Item_List
);
801 -- Processing for WITH clause
803 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
804 -- PRIVATE WITH, or both.
806 if Token
= Tok_Limited
then
808 Has_Private
:= False;
809 Scan
; -- past LIMITED
811 -- In the context, LIMITED can only appear in a with_clause
813 if Token
= Tok_Private
then
815 Scan
; -- past PRIVATE
818 if Token
/= Tok_With
then
819 Error_Msg_SC
("unexpected LIMITED ignored");
822 if Ada_Version
< Ada_05
then
823 Error_Msg_SP
("LIMITED WITH is an Ada 2005 extension");
825 ("\unit must be compiled with -gnat05 switch");
828 elsif Token
= Tok_Private
then
829 Has_Limited
:= False;
831 Save_Scan_State
(Scan_State
);
832 Scan
; -- past PRIVATE
834 if Token
/= Tok_With
then
836 -- Keyword is beginning of private child unit
838 Restore_Scan_State
(Scan_State
); -- to PRIVATE
841 elsif Ada_Version
< Ada_05
then
842 Error_Msg_SP
("PRIVATE WITH is an Ada 2005 extension");
844 ("\unit must be compiled with -gnat05 switch");
848 Has_Limited
:= False;
849 Has_Private
:= False;
852 if Token
= Tok_With
then
855 if Token
= Tok_Type
then
857 -- WITH TYPE is an GNAT specific extension
859 if not Extensions_Allowed
then
860 Error_Msg_SP
("`WITH TYPE` is a 'G'N'A'T extension");
861 Error_Msg_SP
("\unit must be compiled with -gnatX switch");
865 With_Node
:= New_Node
(N_With_Type_Clause
, Token_Ptr
);
866 Append
(With_Node
, Item_List
);
867 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
871 if Token
= Tok_Tagged
then
872 Set_Tagged_Present
(With_Node
);
875 elsif Token
= Tok_Access
then
879 Error_Msg_SC
("expect tagged or access qualifier");
887 -- Loop through names in one with clause, generating a separate
888 -- N_With_Clause node for each nam encountered.
891 With_Node
:= New_Node
(N_With_Clause
, Token_Ptr
);
892 Append
(With_Node
, Item_List
);
894 -- Note that we allow with'ing of child units, even in
895 -- Ada 83 mode, since presumably if this is not desired,
896 -- then the compilation of the child unit itself is the
897 -- place where such an "error" should be caught.
899 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
900 Set_First_Name
(With_Node
, First_Flag
);
901 Set_Limited_Present
(With_Node
, Has_Limited
);
902 Set_Private_Present
(With_Node
, Has_Private
);
905 -- All done if no comma
907 exit when Token
/= Tok_Comma
;
909 -- If comma is followed by compilation unit token
910 -- or by USE, or PRAGMA, then it should have been a
911 -- semicolon after all
913 Save_Scan_State
(Scan_State
);
916 if Token
in Token_Class_Cunit
917 or else Token
= Tok_Use
918 or else Token
= Tok_Pragma
920 Restore_Scan_State
(Scan_State
);
925 Set_Last_Name
(With_Node
, True);
929 -- Processing for USE clause
931 elsif Token
= Tok_Use
then
932 Append
(P_Use_Clause
, Item_List
);
934 -- Anything else is end of context clause
942 end P_Context_Clause
;
944 --------------------------
945 -- 10.1.2 Context Item --
946 --------------------------
948 -- Parsed by P_Context_Clause (10.1.2)
950 -------------------------
951 -- 10.1.2 With Clause --
952 -------------------------
954 -- Parsed by P_Context_Clause (10.1.2)
956 -----------------------
957 -- 10.1.3 Body Stub --
958 -----------------------
960 -- Subprogram stub parsed by P_Subprogram (6.1)
961 -- Package stub parsed by P_Package (7.1)
962 -- Task stub parsed by P_Task (9.1)
963 -- Protected stub parsed by P_Protected (9.4)
965 ----------------------------------
966 -- 10.1.3 Subprogram Body Stub --
967 ----------------------------------
969 -- Parsed by P_Subprogram (6.1)
971 -------------------------------
972 -- 10.1.3 Package Body Stub --
973 -------------------------------
975 -- Parsed by P_Package (7.1)
977 ----------------------------
978 -- 10.1.3 Task Body Stub --
979 ----------------------------
981 -- Parsed by P_Task (9.1)
983 ---------------------------------
984 -- 10.1.3 Protected Body Stub --
985 ---------------------------------
987 -- Parsed by P_Protected (9.4)
989 ---------------------
991 ---------------------
993 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
995 -- PARENT_UNIT_NAME ::= NAME
997 -- The caller has checked that the initial token is SEPARATE
999 -- Error recovery: cannot raise Error_Resync
1001 function P_Subunit
return Node_Id
is
1002 Subunit_Node
: Node_Id
;
1003 Body_Node
: Node_Id
;
1006 Subunit_Node
:= New_Node
(N_Subunit
, Token_Ptr
);
1007 Body_Node
:= Error
; -- in case no good body found
1008 Scan
; -- past SEPARATE;
1011 Set_Name
(Subunit_Node
, P_Qualified_Simple_Name
);
1014 if Token
= Tok_Semicolon
then
1015 Error_Msg_SC
("unexpected semicolon ignored");
1019 if Token
= Tok_Function
or else Token
= Tok_Procedure
then
1020 Body_Node
:= P_Subprogram
(Pf_Pbod
);
1022 elsif Token
= Tok_Package
then
1023 Body_Node
:= P_Package
(Pf_Pbod
);
1025 elsif Token
= Tok_Protected
then
1026 Scan
; -- past PROTECTED
1028 if Token
= Tok_Body
then
1029 Body_Node
:= P_Protected
;
1031 Error_Msg_AP
("BODY expected");
1035 elsif Token
= Tok_Task
then
1038 if Token
= Tok_Body
then
1039 Body_Node
:= P_Task
;
1041 Error_Msg_AP
("BODY expected");
1046 Error_Msg_SC
("proper body expected");
1050 Set_Proper_Body
(Subunit_Node
, Body_Node
);
1051 return Subunit_Node
;
1059 function Set_Location
return Source_Ptr
is
1062 Scan_State
: Saved_Scan_State
;
1065 -- A special check. If the first token is pragma, and this is a
1066 -- Source_Reference pragma, then do NOT eat previous comments, since
1067 -- the Source_Reference pragma is required to be the first line in
1070 if Token
= Tok_Pragma
then
1071 Save_Scan_State
(Scan_State
);
1072 Scan
; -- past Pragma
1074 if Token
= Tok_Identifier
1075 and then Token_Name
= Name_Source_Reference
1077 Restore_Scan_State
(Scan_State
);
1081 Restore_Scan_State
(Scan_State
);
1084 -- Otherwise acquire previous comments and blank lines
1086 if Prev_Token
= No_Token
then
1087 return Source_First
(Current_Source_File
);
1090 Loc
:= Prev_Token_Ptr
;
1092 exit when Loc
= Token_Ptr
;
1094 -- Should we worry about UTF_32 line terminators here
1096 if Source
(Loc
) in Line_Terminator
then
1097 Skip_Line_Terminators
(Loc
, Physical
);
1112 -- The format of the generated line, as expected by GNATCHOP is
1114 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1118 -- {unit} unit name with terminating (spec) or (body)
1119 -- {line} starting line number
1120 -- {offs} offset to start of text in file
1121 -- {file} source file name
1123 -- The SR parameter is present only if a source reference pragma was
1124 -- scanned for this unit. The significance is that gnatchop should not
1125 -- attempt to add another one.
1127 procedure Unit_Display
1130 SR_Present
: Boolean)
1132 Unum
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Cunit
);
1133 Sind
: constant Source_File_Index
:= Source_Index
(Unum
);
1134 Unam
: constant Unit_Name_Type
:= Unit_Name
(Unum
);
1138 Write_Str
("Unit ");
1139 Write_Unit_Name
(Unit_Name
(Unum
));
1140 Unit_Location
(Sind
, Loc
);
1146 Write_Str
(", file name ");
1147 Write_Name
(Get_File_Name
(Unam
, Nkind
(Unit
(Cunit
)) = N_Subunit
));
1156 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
) is
1157 Line
: constant Logical_Line_Number
:= Get_Logical_Line_Number
(Loc
);
1158 -- Should the above be the physical line number ???
1161 Write_Str
(" line ");
1162 Write_Int
(Int
(Line
));
1164 Write_Str
(", file offset ");
1165 Write_Int
(Int
(Loc
) - Int
(Source_First
(Sind
)));