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;
118 Cunit_Error_Flag
: Boolean := False;
119 -- This flag is set True if we have to scan for a compilation unit
120 -- token. It is used to ensure clean termination in such cases by
121 -- not insisting on being at the end of file, and, in the syntax only
122 -- case by not scanning for additional compilation units.
124 Cunit_Location
: Source_Ptr
;
125 -- Location of unit for unit identification output (List_Unit option)
128 Num_Library_Units
:= Num_Library_Units
+ 1;
130 -- Set location of the compilation unit if unit list option set
131 -- and we are in syntax check only mode
133 if List_Units
and then Operating_Mode
= Check_Syntax
then
134 Cunit_Location
:= Set_Location
;
136 Cunit_Location
:= No_Location
;
139 -- Deal with initial pragmas
141 Config_Pragmas
:= No_List
;
143 -- If we have an initial Source_Reference pragma, then remember the fact
144 -- to generate an NR parameter in the output line.
148 if Token
= Tok_Pragma
then
149 Save_Scan_State
(Scan_State
);
153 or else Pragma_Name
(Item
) /= Name_Source_Reference
155 Restore_Scan_State
(Scan_State
);
160 -- If first unit, record the file name for gnatchop use
162 if Operating_Mode
= Check_Syntax
164 and then Num_Library_Units
= 1
166 Write_Str
("Source_Reference pragma for file """);
167 Write_Name
(Full_Ref_Name
(Current_Source_File
));
172 Config_Pragmas
:= New_List
(Item
);
176 -- Scan out any configuration pragmas
178 while Token
= Tok_Pragma
loop
179 Save_Scan_State
(Scan_State
);
183 or else not Is_Configuration_Pragma_Name
(Pragma_Name
(Item
))
185 Restore_Scan_State
(Scan_State
);
189 if Config_Pragmas
= No_List
then
190 Config_Pragmas
:= Empty_List
;
192 if Operating_Mode
= Check_Syntax
and then List_Units
then
193 Write_Str
("Configuration pragmas at");
194 Unit_Location
(Current_Source_File
, Cunit_Location
);
199 Append
(Item
, Config_Pragmas
);
200 Cunit_Location
:= Set_Location
;
203 -- Establish compilation unit node and scan context items
205 Comp_Unit_Node
:= New_Node
(N_Compilation_Unit
, No_Location
);
206 Set_Cunit
(Current_Source_Unit
, Comp_Unit_Node
);
207 Set_Context_Items
(Comp_Unit_Node
, P_Context_Clause
);
209 (Comp_Unit_Node
, New_Node
(N_Compilation_Unit_Aux
, No_Location
));
211 if Present
(Config_Pragmas
) then
213 -- Check for case of only configuration pragmas present
216 and then Is_Empty_List
(Context_Items
(Comp_Unit_Node
))
218 if Operating_Mode
= Check_Syntax
then
222 Item
:= First
(Config_Pragmas
);
224 ("cannot compile configuration pragmas with gcc!", Item
);
226 ("\use gnatchop -c to process configuration pragmas!", Item
);
227 raise Unrecoverable_Error
;
230 -- Otherwise configuration pragmas are simply prepended to the
231 -- context of the current unit.
234 Append_List
(Context_Items
(Comp_Unit_Node
), Config_Pragmas
);
235 Set_Context_Items
(Comp_Unit_Node
, Config_Pragmas
);
239 -- Check for PRIVATE. Note that for the moment we allow this in
240 -- Ada_83 mode, since we do not yet know if we are compiling a
241 -- predefined unit, and if we are then it would be allowed anyway.
243 if Token
= Tok_Private
then
244 Private_Sloc
:= Token_Ptr
;
245 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
248 Style
.Check_Indentation
;
251 Save_Scan_State
(Scan_State
); -- at PRIVATE
252 Scan
; -- past PRIVATE
254 if Token
= Tok_Separate
then
255 Error_Msg_SP
("cannot have private subunits!");
257 elsif Token
= Tok_Package
then
258 Scan
; -- past PACKAGE
260 if Token
= Tok_Body
then
261 Restore_Scan_State
(Scan_State
); -- to PRIVATE
262 Error_Msg_SC
("cannot have private package body!");
263 Scan
; -- ignore PRIVATE
266 Restore_Scan_State
(Scan_State
); -- to PRIVATE
267 Scan
; -- past PRIVATE
268 Set_Private_Present
(Comp_Unit_Node
, True);
271 elsif Token
= Tok_Procedure
272 or else Token
= Tok_Function
273 or else Token
= Tok_Generic
275 Set_Private_Present
(Comp_Unit_Node
, True);
279 -- Loop to find our way to a compilation unit token
282 exit when Token
in Token_Class_Cunit
and then Token
/= Tok_With
;
284 exit when Bad_Spelling_Of
(Tok_Package
)
285 or else Bad_Spelling_Of
(Tok_Function
)
286 or else Bad_Spelling_Of
(Tok_Generic
)
287 or else Bad_Spelling_Of
(Tok_Separate
)
288 or else Bad_Spelling_Of
(Tok_Procedure
);
290 -- Allow task and protected for nice error recovery purposes
292 exit when Token
= Tok_Task
293 or else Token
= Tok_Protected
;
295 if Token
= Tok_With
then
296 Error_Msg_SC
("misplaced WITH");
297 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
299 elsif Bad_Spelling_Of
(Tok_With
) then
300 Append_List
(P_Context_Clause
, Context_Items
(Comp_Unit_Node
));
303 if Operating_Mode
= Check_Syntax
and then Token
= Tok_EOF
then
304 Error_Msg_SC
("?file contains no compilation units");
306 Error_Msg_SC
("compilation unit expected");
307 Cunit_Error_Flag
:= True;
311 -- If we are at an end of file, then just quit, the above error
312 -- message was complaint enough.
314 if Token
= Tok_EOF
then
320 -- We have a compilation unit token, so that's a reasonable choice for
321 -- determining the standard casing convention used for keywords in case
322 -- it hasn't already been done on seeing a WITH or PRIVATE.
324 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
327 Style
.Check_Indentation
;
330 -- Remaining processing depends on particular type of compilation unit
332 if Token
= Tok_Package
then
334 -- A common error is to omit the body keyword after package. We can
335 -- often diagnose this early on (before getting loads of errors from
336 -- contained subprogram bodies), by knowing that the file we
337 -- are compiling has a name that requires a body to be found.
339 Save_Scan_State
(Scan_State
);
340 Scan
; -- past Package keyword
344 Get_Expected_Unit_Type
345 (File_Name
(Current_Source_File
)) = Expect_Body
347 Error_Msg_BC
-- CODEFIX
348 ("keyword BODY expected here [see file name]");
349 Restore_Scan_State
(Scan_State
);
350 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Pbod_Pexp
));
352 Restore_Scan_State
(Scan_State
);
353 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Decl_Gins_Pbod_Rnam_Pexp
));
356 elsif Token
= Tok_Generic
then
357 Set_Unit
(Comp_Unit_Node
, P_Generic
);
359 elsif Token
= Tok_Separate
then
360 Set_Unit
(Comp_Unit_Node
, P_Subunit
);
362 elsif Token
= Tok_Function
363 or else Token
= Tok_Not
364 or else Token
= Tok_Overriding
365 or else Token
= Tok_Procedure
367 Set_Unit
(Comp_Unit_Node
, P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Pexp
));
369 -- A little bit of an error recovery check here. If we just scanned
370 -- a subprogram declaration (as indicated by an SIS entry being
371 -- active), then if the following token is BEGIN or an identifier,
372 -- or a token which can reasonably start a declaration but cannot
373 -- start a compilation unit, then we assume that the semicolon in
374 -- the declaration should have been IS.
376 if SIS_Entry_Active
then
379 or else Token
= Tok_Identifier
380 or else Token
in Token_Class_Deckn
383 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
384 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
385 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
386 Scope
.Table
(Scope
.Last
).Lreq
:= False;
387 SIS_Entry_Active
:= False;
389 -- If we had a missing semicolon in the declaration, then
390 -- change the message to from <missing ";"> to <missing "is">
392 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
393 Change_Error_Text
-- Replace: "missing "";"" "
394 (SIS_Missing_Semicolon_Message
, "missing IS");
396 -- Otherwise we saved the semicolon position, so complain
400 (""";"" should be IS", SIS_Semicolon_Sloc
);
403 Body_Node
:= Unit
(Comp_Unit_Node
);
404 Specification_Node
:= Specification
(Body_Node
);
405 Change_Node
(Body_Node
, N_Subprogram_Body
);
406 Set_Specification
(Body_Node
, Specification_Node
);
407 Parse_Decls_Begin_End
(Body_Node
);
408 Set_Unit
(Comp_Unit_Node
, Body_Node
);
411 -- If we scanned a subprogram body, make sure we did not have private
413 elsif Private_Sloc
/= No_Location
415 Nkind
(Unit
(Comp_Unit_Node
)) not in N_Subprogram_Instantiation
417 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Subprogram_Renaming_Declaration
419 Error_Msg
("cannot have private subprogram body", Private_Sloc
);
421 -- P_Subprogram can yield an abstract subprogram, but this cannot
422 -- be a compilation unit. Treat as a subprogram declaration.
425 Nkind
(Unit
(Comp_Unit_Node
)) = N_Abstract_Subprogram_Declaration
428 ("compilation unit cannot be abstract subprogram",
429 Unit
(Comp_Unit_Node
));
432 New_Node
(N_Subprogram_Declaration
, Sloc
(Comp_Unit_Node
));
433 Set_Specification
(Unit_Node
,
434 Specification
(Unit
(Comp_Unit_Node
)));
435 Set_Unit
(Comp_Unit_Node
, Unit_Node
);
438 -- Otherwise we have TASK. This is not really an acceptable token,
439 -- but we accept it to improve error recovery.
441 elsif Token
= Tok_Task
then
444 if Token
= Tok_Type
then
446 ("task type cannot be used as compilation unit");
449 ("task declaration cannot be used as compilation unit");
452 -- If in check syntax mode, accept the task anyway. This is done
453 -- particularly to improve the behavior of GNATCHOP in this case.
455 if Operating_Mode
= Check_Syntax
then
456 Set_Unit
(Comp_Unit_Node
, P_Task
);
458 -- If not in syntax only mode, treat this as horrible error
461 Cunit_Error_Flag
:= True;
465 else pragma Assert
(Token
= Tok_Protected
);
466 Scan
; -- Past PROTECTED
468 if Token
= Tok_Type
then
470 ("protected type cannot be used as compilation unit");
473 ("protected declaration cannot be used as compilation unit");
476 -- If in check syntax mode, accept protected anyway. This is done
477 -- particularly to improve the behavior of GNATCHOP in this case.
479 if Operating_Mode
= Check_Syntax
then
480 Set_Unit
(Comp_Unit_Node
, P_Protected
);
482 -- If not in syntax only mode, treat this as horrible error
485 Cunit_Error_Flag
:= True;
490 -- Here is where locate the compilation unit entity. This is a little
491 -- tricky, since it is buried in various places.
493 Unit_Node
:= Unit
(Comp_Unit_Node
);
495 -- Another error from which it is hard to recover
497 if Nkind
(Unit_Node
) = N_Subprogram_Body_Stub
498 or else Nkind
(Unit_Node
) = N_Package_Body_Stub
500 Cunit_Error_Flag
:= True;
504 -- Only try this if we got an OK unit!
506 if Unit_Node
/= Error
then
507 if Nkind
(Unit_Node
) = N_Subunit
then
508 Unit_Node
:= Proper_Body
(Unit_Node
);
511 if Nkind
(Unit_Node
) in N_Generic_Declaration
then
512 Unit_Node
:= Specification
(Unit_Node
);
515 if Nkind
(Unit_Node
) = N_Package_Declaration
516 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
517 or else Nkind
(Unit_Node
) = N_Subprogram_Body
518 or else Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
520 Unit_Node
:= Specification
(Unit_Node
);
522 elsif Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
then
523 if Ada_Version
= Ada_83
then
525 ("(Ada 83) library unit renaming not allowed", Unit_Node
);
529 if Nkind
(Unit_Node
) = N_Task_Body
530 or else Nkind
(Unit_Node
) = N_Protected_Body
531 or else Nkind
(Unit_Node
) = N_Task_Type_Declaration
532 or else Nkind
(Unit_Node
) = N_Protected_Type_Declaration
533 or else Nkind
(Unit_Node
) = N_Single_Task_Declaration
534 or else Nkind
(Unit_Node
) = N_Single_Protected_Declaration
536 Name_Node
:= Defining_Identifier
(Unit_Node
);
538 elsif Nkind
(Unit_Node
) = N_Function_Instantiation
539 or else Nkind
(Unit_Node
) = N_Function_Specification
540 or else Nkind
(Unit_Node
) = N_Generic_Function_Renaming_Declaration
541 or else Nkind
(Unit_Node
) = N_Generic_Package_Renaming_Declaration
542 or else Nkind
(Unit_Node
) = N_Generic_Procedure_Renaming_Declaration
543 or else Nkind
(Unit_Node
) = N_Package_Body
544 or else Nkind
(Unit_Node
) = N_Package_Instantiation
545 or else Nkind
(Unit_Node
) = N_Package_Renaming_Declaration
546 or else Nkind
(Unit_Node
) = N_Package_Specification
547 or else Nkind
(Unit_Node
) = N_Procedure_Instantiation
548 or else Nkind
(Unit_Node
) = N_Procedure_Specification
550 Name_Node
:= Defining_Unit_Name
(Unit_Node
);
552 -- Anything else is a serious error, abandon scan
558 Set_Sloc
(Comp_Unit_Node
, Sloc
(Name_Node
));
559 Set_Sloc
(Aux_Decls_Node
(Comp_Unit_Node
), Sloc
(Name_Node
));
561 -- Set Entity field in file table. Easier now that we have name!
562 -- Note that this is also skipped if we had a bad unit
564 if Nkind
(Name_Node
) = N_Defining_Program_Unit_Name
then
566 (Current_Source_Unit
, Defining_Identifier
(Name_Node
));
568 Set_Cunit_Entity
(Current_Source_Unit
, Name_Node
);
572 (Current_Source_Unit
, Get_Unit_Name
(Unit
(Comp_Unit_Node
)));
574 -- If we had a bad unit, make sure the fatal flag is set in the file
575 -- table entry, since this is surely a fatal error and also set our
576 -- flag to inhibit the requirement that we be at end of file.
579 Cunit_Error_Flag
:= True;
580 Set_Fatal_Error
(Current_Source_Unit
);
583 -- Clear away any missing semicolon indication, we are done with that
584 -- unit, so what's done is done, and we don't want anything hanging
585 -- around from the attempt to parse it!
587 SIS_Entry_Active
:= False;
589 -- Scan out pragmas after unit
591 while Token
= Tok_Pragma
loop
592 Save_Scan_State
(Scan_State
);
594 -- If we are in syntax scan mode allowing multiple units, then start
595 -- the next unit if we encounter a configuration pragma, or a source
596 -- reference pragma. We take care not to actually scan the pragma in
597 -- this case (we don't want it to take effect for the current unit).
599 if Operating_Mode
= Check_Syntax
then
602 if Token
= Tok_Identifier
604 (Is_Configuration_Pragma_Name
(Token_Name
)
605 or else Token_Name
= Name_Source_Reference
)
607 Restore_Scan_State
(Scan_State
); -- to Pragma
612 -- Otherwise eat the pragma, it definitely belongs with the
613 -- current unit, and not with the following unit.
615 Restore_Scan_State
(Scan_State
); -- to Pragma
618 if No
(Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
))) then
620 (Aux_Decls_Node
(Comp_Unit_Node
), New_List
);
623 Append
(P
, Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
)));
626 -- Cancel effect of any outstanding pragma Warnings (Off)
628 Set_Warnings_Mode_On
(Scan_Ptr
);
630 -- Ada 83 error checks
632 if Ada_Version
= Ada_83
then
634 -- Check we did not with any child units
636 Item
:= First
(Context_Items
(Comp_Unit_Node
));
637 while Present
(Item
) loop
638 if Nkind
(Item
) = N_With_Clause
639 and then Nkind
(Name
(Item
)) /= N_Identifier
641 Error_Msg_N
("(Ada 83) child units not allowed", Item
);
647 -- Check that we did not have a PRIVATE keyword present
649 if Private_Present
(Comp_Unit_Node
) then
651 ("(Ada 83) private units not allowed", Private_Sloc
);
655 -- If no serious error, then output possible unit information line
656 -- for gnatchop if we are in syntax only, list units mode.
658 if not Cunit_Error_Flag
660 and then Operating_Mode
= Check_Syntax
662 Unit_Display
(Comp_Unit_Node
, Cunit_Location
, SR_Present
);
665 -- And now we should be at the end of file
667 if Token
/= Tok_EOF
then
669 -- If we already had to scan for a compilation unit, then don't
670 -- give any further error message, since it just seems to make
671 -- things worse, and we already gave a serious error message.
673 if Cunit_Error_Flag
then
676 -- If we are in check syntax mode, then we allow multiple units
677 -- so we just return with Token not set to Tok_EOF and no message.
679 elsif Operating_Mode
= Check_Syntax
then
680 return Comp_Unit_Node
;
682 -- We also allow multiple units if we are in multiple unit mode
684 elsif Multiple_Unit_Index
/= 0 then
686 -- Skip tokens to end of file, so that the -gnatl listing
687 -- will be complete in this situation, but no need to parse
688 -- the remaining units; no style checking either.
691 Save_Style_Check
: constant Boolean := Style_Check
;
694 Style_Check
:= False;
696 while Token
/= Tok_EOF
loop
700 Style_Check
:= Save_Style_Check
;
703 return Comp_Unit_Node
;
705 -- Otherwise we have an error. We suppress the error message
706 -- if we already had a fatal error, since this stops junk
707 -- cascaded messages in some situations.
710 if not Fatal_Error
(Current_Source_Unit
) then
711 if Token
in Token_Class_Cunit
then
713 ("end of file expected, " &
714 "file can have only one compilation unit");
716 Error_Msg_SC
("end of file expected");
721 -- Skip tokens to end of file, so that the -gnatl listing
722 -- will be complete in this situation, but no error checking
723 -- other than that provided at the token level.
725 while Token
/= Tok_EOF
loop
731 -- Normal return (we were at the end of file as expected)
734 return Comp_Unit_Node
;
739 -- An error resync is a serious bomb, so indicate result unit no good
742 Set_Fatal_Error
(Current_Source_Unit
);
744 end P_Compilation_Unit
;
746 --------------------------
747 -- 10.1.1 Library Item --
748 --------------------------
750 -- Parsed by P_Compilation_Unit (10.1.1)
752 --------------------------------------
753 -- 10.1.1 Library Unit Declaration --
754 --------------------------------------
756 -- Parsed by P_Compilation_Unit (10.1.1)
758 ------------------------------------------------
759 -- 10.1.1 Library Unit Renaming Declaration --
760 ------------------------------------------------
762 -- Parsed by P_Compilation_Unit (10.1.1)
764 -------------------------------
765 -- 10.1.1 Library Unit Body --
766 -------------------------------
768 -- Parsed by P_Compilation_Unit (10.1.1)
770 ------------------------------
771 -- 10.1.1 Parent Unit Name --
772 ------------------------------
774 -- Parsed (as a name) by its parent construct
776 ----------------------------
777 -- 10.1.2 Context Clause --
778 ----------------------------
780 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
782 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
785 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
786 -- Note: the two qualifiers are Ada 2005 extensions.
788 -- WITH_TYPE_CLAUSE ::=
789 -- with type type_NAME is access; | with type type_NAME is tagged;
790 -- Note: this form is obsolete (old GNAT extension).
792 -- Error recovery: Cannot raise Error_Resync
794 function P_Context_Clause
return List_Id
is
796 Has_Limited
: Boolean := False;
797 Has_Private
: Boolean := False;
798 Scan_State
: Saved_Scan_State
;
800 First_Flag
: Boolean;
803 Item_List
:= New_List
;
805 -- Get keyword casing from WITH keyword in case not set yet
807 if Token
= Tok_With
then
808 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
811 -- Loop through context items
815 Style
.Check_Indentation
;
818 -- Gather any pragmas appearing in the context clause
820 P_Pragmas_Opt
(Item_List
);
822 -- Processing for WITH clause
824 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
825 -- PRIVATE WITH, or both.
827 if Token
= Tok_Limited
then
829 Has_Private
:= False;
830 Scan
; -- past LIMITED
832 -- In the context, LIMITED can only appear in a with_clause
834 if Token
= Tok_Private
then
836 Scan
; -- past PRIVATE
839 if Token
/= Tok_With
then
840 Error_Msg_SC
-- CODEFIX
841 ("unexpected LIMITED ignored");
844 if Ada_Version
< Ada_2005
then
845 Error_Msg_SP
("LIMITED WITH is an Ada 2005 extension");
847 ("\unit must be compiled with -gnat05 switch");
850 elsif Token
= Tok_Private
then
851 Has_Limited
:= False;
853 Save_Scan_State
(Scan_State
);
854 Scan
; -- past PRIVATE
856 if Token
/= Tok_With
then
858 -- Keyword is beginning of private child unit
860 Restore_Scan_State
(Scan_State
); -- to PRIVATE
863 elsif Ada_Version
< Ada_2005
then
864 Error_Msg_SP
("`PRIVATE WITH` is an Ada 2005 extension");
866 ("\unit must be compiled with -gnat05 switch");
870 Has_Limited
:= False;
871 Has_Private
:= False;
874 if Token
= Tok_With
then
877 if Token
= Tok_Type
then
879 -- WITH TYPE is an obsolete GNAT specific extension
881 Error_Msg_SP
("`WITH TYPE` is an obsolete 'G'N'A'T extension");
882 Error_Msg_SP
("\use Ada 2005 `LIMITED WITH` clause instead");
888 if Token
= Tok_Tagged
then
891 elsif Token
= Tok_Access
then
895 Error_Msg_SC
("expect tagged or access qualifier");
903 -- Loop through names in one with clause, generating a separate
904 -- N_With_Clause node for each name encountered.
907 With_Node
:= New_Node
(N_With_Clause
, Token_Ptr
);
908 Append
(With_Node
, Item_List
);
910 -- Note that we allow with'ing of child units, even in
911 -- Ada 83 mode, since presumably if this is not desired,
912 -- then the compilation of the child unit itself is the
913 -- place where such an "error" should be caught.
915 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
916 Set_First_Name
(With_Node
, First_Flag
);
917 Set_Limited_Present
(With_Node
, Has_Limited
);
918 Set_Private_Present
(With_Node
, Has_Private
);
921 -- All done if no comma
923 exit when Token
/= Tok_Comma
;
925 -- If comma is followed by compilation unit token
926 -- or by USE, or PRAGMA, then it should have been a
927 -- semicolon after all
929 Save_Scan_State
(Scan_State
);
932 if Token
in Token_Class_Cunit
933 or else Token
= Tok_Use
934 or else Token
= Tok_Pragma
936 Restore_Scan_State
(Scan_State
);
941 Set_Last_Name
(With_Node
, True);
945 -- Processing for USE clause
947 elsif Token
= Tok_Use
then
948 Append
(P_Use_Clause
, Item_List
);
950 -- Anything else is end of context clause
958 end P_Context_Clause
;
960 --------------------------
961 -- 10.1.2 Context Item --
962 --------------------------
964 -- Parsed by P_Context_Clause (10.1.2)
966 -------------------------
967 -- 10.1.2 With Clause --
968 -------------------------
970 -- Parsed by P_Context_Clause (10.1.2)
972 -----------------------
973 -- 10.1.3 Body Stub --
974 -----------------------
976 -- Subprogram stub parsed by P_Subprogram (6.1)
977 -- Package stub parsed by P_Package (7.1)
978 -- Task stub parsed by P_Task (9.1)
979 -- Protected stub parsed by P_Protected (9.4)
981 ----------------------------------
982 -- 10.1.3 Subprogram Body Stub --
983 ----------------------------------
985 -- Parsed by P_Subprogram (6.1)
987 -------------------------------
988 -- 10.1.3 Package Body Stub --
989 -------------------------------
991 -- Parsed by P_Package (7.1)
993 ----------------------------
994 -- 10.1.3 Task Body Stub --
995 ----------------------------
997 -- Parsed by P_Task (9.1)
999 ---------------------------------
1000 -- 10.1.3 Protected Body Stub --
1001 ---------------------------------
1003 -- Parsed by P_Protected (9.4)
1005 ---------------------
1006 -- 10.1.3 Subunit --
1007 ---------------------
1009 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
1011 -- PARENT_UNIT_NAME ::= NAME
1013 -- The caller has checked that the initial token is SEPARATE
1015 -- Error recovery: cannot raise Error_Resync
1017 function P_Subunit
return Node_Id
is
1018 Subunit_Node
: Node_Id
;
1019 Body_Node
: Node_Id
;
1022 Subunit_Node
:= New_Node
(N_Subunit
, Token_Ptr
);
1023 Body_Node
:= Error
; -- in case no good body found
1024 Scan
; -- past SEPARATE;
1027 Set_Name
(Subunit_Node
, P_Qualified_Simple_Name
);
1030 Ignore
(Tok_Semicolon
);
1032 if Token
= Tok_Function
1033 or else Token
= Tok_Not
1034 or else Token
= Tok_Overriding
1035 or else Token
= Tok_Procedure
1037 Body_Node
:= P_Subprogram
(Pf_Pbod_Pexp
);
1039 elsif Token
= Tok_Package
then
1040 Body_Node
:= P_Package
(Pf_Pbod_Pexp
);
1042 elsif Token
= Tok_Protected
then
1043 Scan
; -- past PROTECTED
1045 if Token
= Tok_Body
then
1046 Body_Node
:= P_Protected
;
1048 Error_Msg_AP
("BODY expected");
1052 elsif Token
= Tok_Task
then
1055 if Token
= Tok_Body
then
1056 Body_Node
:= P_Task
;
1058 Error_Msg_AP
("BODY expected");
1063 Error_Msg_SC
("proper body expected");
1067 Set_Proper_Body
(Subunit_Node
, Body_Node
);
1068 return Subunit_Node
;
1075 function Set_Location
return Source_Ptr
is
1078 Scan_State
: Saved_Scan_State
;
1081 -- A special check. If the first token is pragma, and this is a
1082 -- Source_Reference pragma, then do NOT eat previous comments, since
1083 -- the Source_Reference pragma is required to be the first line in
1086 if Token
= Tok_Pragma
then
1087 Save_Scan_State
(Scan_State
);
1088 Scan
; -- past Pragma
1090 if Token
= Tok_Identifier
1091 and then Token_Name
= Name_Source_Reference
1093 Restore_Scan_State
(Scan_State
);
1097 Restore_Scan_State
(Scan_State
);
1100 -- Otherwise acquire previous comments and blank lines
1102 if Prev_Token
= No_Token
then
1103 return Source_First
(Current_Source_File
);
1106 Loc
:= Prev_Token_Ptr
;
1108 exit when Loc
= Token_Ptr
;
1110 -- Should we worry about UTF_32 line terminators here
1112 if Source
(Loc
) in Line_Terminator
then
1113 Skip_Line_Terminators
(Loc
, Physical
);
1128 -- The format of the generated line, as expected by GNATCHOP is
1130 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1134 -- {unit} unit name with terminating (spec) or (body)
1135 -- {line} starting line number
1136 -- {offs} offset to start of text in file
1137 -- {file} source file name
1139 -- The SR parameter is present only if a source reference pragma was
1140 -- scanned for this unit. The significance is that gnatchop should not
1141 -- attempt to add another one.
1143 procedure Unit_Display
1146 SR_Present
: Boolean)
1148 Unum
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Cunit
);
1149 Sind
: constant Source_File_Index
:= Source_Index
(Unum
);
1150 Unam
: constant Unit_Name_Type
:= Unit_Name
(Unum
);
1154 Write_Str
("Unit ");
1155 Write_Unit_Name
(Unit_Name
(Unum
));
1156 Unit_Location
(Sind
, Loc
);
1162 Write_Str
(", file name ");
1163 Write_Name
(Get_File_Name
(Unam
, Nkind
(Unit
(Cunit
)) = N_Subunit
));
1172 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
) is
1173 Line
: constant Logical_Line_Number
:= Get_Logical_Line_Number
(Loc
);
1174 -- Should the above be the physical line number ???
1177 Write_Str
(" line ");
1178 Write_Int
(Int
(Line
));
1180 Write_Str
(", file offset ");
1181 Write_Int
(Int
(Loc
) - Int
(Source_First
(Sind
)));