1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
; use Fname
;
32 with Fname
.UF
; use Fname
.UF
;
33 with Hostparm
; use Hostparm
;
34 with Uname
; use Uname
;
39 -- Local functions, used only in this chapter
41 function P_Context_Clause
return List_Id
;
42 function P_Subunit
return Node_Id
;
44 function Set_Location
return Source_Ptr
;
45 -- The current compilation unit starts with Token at Token_Ptr. This
46 -- function determines the corresponding source location for the start
47 -- of the unit, including any preceding comment lines.
49 procedure Unit_Display
52 SR_Present
: Boolean);
53 -- This procedure is used to generate a line of output for the a unit in
54 -- the source program. Cunit is the node for the compilation unit, and
55 -- Loc is the source location for the start of the unit in the source
56 -- file (which is not necessarily the Sloc of the Cunit node). This
57 -- output is written to the standard output file for use by gnatchop.
59 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
);
60 -- This routine has the same calling sequence as Unit_Display, but
61 -- it outputs only the line number and offset of the location, Loc,
62 -- using Cunit to obtain the proper source file index.
64 -------------------------
65 -- 10.1.1 Compilation --
66 -------------------------
68 -- COMPILATION ::= {COMPILATION_UNIT}
70 -- There is no specific parsing routine for a compilation, since we only
71 -- permit a single compilation in a source file, so there is no explicit
72 -- occurrence of compilations as such (our representation of a compilation
73 -- is a series of separate source files).
75 ------------------------------
76 -- 10.1.1 Compilation unit --
77 ------------------------------
79 -- COMPILATION_UNIT ::=
80 -- CONTEXT_CLAUSE LIBRARY_ITEM
81 -- | CONTEXT_CLAUSE SUBUNIT
84 -- private LIBRARY_UNIT_DECLARATION
85 -- | LIBRARY_UNIT_BODY
86 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
88 -- LIBRARY_UNIT_DECLARATION ::=
89 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
90 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
92 -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
93 -- PACKAGE_RENAMING_DECLARATION
94 -- | GENERIC_RENAMING_DECLARATION
95 -- | SUBPROGRAM_RENAMING_DECLARATION
97 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
99 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
100 -- are skipped up to the next possible beginning of a compilation unit.
102 -- Note: if only configuration pragmas are found, Empty is returned
104 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit
105 -- to return strange things that are not really compilation units.
106 -- This is done to help out gnatchop when it is faced with nonsense.
108 function P_Compilation_Unit
return Node_Id
is
109 Scan_State
: Saved_Scan_State
;
111 Specification_Node
: Node_Id
;
113 Comp_Unit_Node
: Node_Id
;
116 Private_Sloc
: Source_Ptr
:= No_Location
;
117 Config_Pragmas
: List_Id
;
119 SR_Present
: Boolean;
121 Cunit_Error_Flag
: Boolean := False;
122 -- This flag is set True if we have to scan for a compilation unit
123 -- token. It is used to ensure clean termination in such cases by
124 -- not insisting on being at the end of file, and, in the sytax only
125 -- case by not scanning for additional compilation units.
127 Cunit_Location
: Source_Ptr
;
128 -- Location of unit for unit identification output (List_Unit option)
131 Num_Library_Units
:= Num_Library_Units
+ 1;
133 -- Set location of the compilation unit if unit list option set
134 -- and we are in syntax check only mode
136 if List_Units
and then Operating_Mode
= Check_Syntax
then
137 Cunit_Location
:= Set_Location
;
139 Cunit_Location
:= No_Location
;
142 -- Deal with initial pragmas
144 Config_Pragmas
:= No_List
;
146 -- If we have an initial Source_Reference pragma, then remember
147 -- the fact to generate an NR parameter in the output line.
151 if Token
= Tok_Pragma
then
152 Save_Scan_State
(Scan_State
);
156 or else Chars
(Item
) /= Name_Source_Reference
158 Restore_Scan_State
(Scan_State
);
163 -- If first unit, record the file name for gnatchop use
165 if Operating_Mode
= Check_Syntax
167 and then Num_Library_Units
= 1
169 Write_Str
("Source_Reference pragma for file """);
170 Write_Name
(Full_Ref_Name
(Current_Source_File
));
175 Config_Pragmas
:= New_List
(Item
);
179 -- Scan out any configuration pragmas
181 while Token
= Tok_Pragma
loop
182 Save_Scan_State
(Scan_State
);
186 or else Chars
(Item
) > Last_Configuration_Pragma_Name
188 Restore_Scan_State
(Scan_State
);
192 if Config_Pragmas
= No_List
then
193 Config_Pragmas
:= Empty_List
;
195 if Operating_Mode
= Check_Syntax
and then List_Units
then
196 Write_Str
("Configuration pragmas at");
197 Unit_Location
(Current_Source_File
, Cunit_Location
);
202 Append
(Item
, Config_Pragmas
);
203 Cunit_Location
:= Set_Location
;
206 -- Establish compilation unit node and scan context items
208 Comp_Unit_Node
:= New_Node
(N_Compilation_Unit
, No_Location
);
209 Set_Cunit
(Current_Source_Unit
, Comp_Unit_Node
);
210 Set_Context_Items
(Comp_Unit_Node
, P_Context_Clause
);
212 (Comp_Unit_Node
, New_Node
(N_Compilation_Unit_Aux
, No_Location
));
214 if Present
(Config_Pragmas
) then
216 -- Check for case of only configuration pragmas present
219 and then Is_Empty_List
(Context_Items
(Comp_Unit_Node
))
221 if Operating_Mode
= Check_Syntax
then
225 Item
:= First
(Config_Pragmas
);
227 ("cannot compile configuration pragmas with gcc", Item
);
229 ("use gnatchop -c to process configuration pragmas!", Item
);
230 raise Unrecoverable_Error
;
233 -- Otherwise configuration pragmas are simply prepended to the
234 -- context of the current unit.
237 Append_List
(Context_Items
(Comp_Unit_Node
), Config_Pragmas
);
238 Set_Context_Items
(Comp_Unit_Node
, Config_Pragmas
);
242 -- Check for PRIVATE. Note that for the moment we allow this in
243 -- Ada_83 mode, since we do not yet know if we are compiling a
244 -- predefined unit, and if we are then it would be allowed anyway.
246 if Token
= Tok_Private
then
247 Private_Sloc
:= Token_Ptr
;
248 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
249 if Style_Check
then Style
.Check_Indentation
; end if;
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");
307 Error_Msg_SC
("compilation unit expected");
308 Cunit_Error_Flag
:= True;
312 -- If we are at an end of file, then just quit, the above error
313 -- message was complaint enough.
315 if Token
= Tok_EOF
then
321 -- We have a compilation unit token, so that's a reasonable choice for
322 -- determining the standard casing convention used for keywords in case
323 -- it hasn't already been done on seeing a WITH or PRIVATE.
325 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
326 if Style_Check
then Style
.Check_Indentation
; end if;
328 -- Remaining processing depends on particular type of compilation unit
330 if Token
= Tok_Package
then
332 -- A common error is to omit the body keyword after package. We can
333 -- often diagnose this early on (before getting loads of errors from
334 -- contained subprogram bodies), by knowing that that the file we
335 -- are compiling has a name that requires a body to be found.
337 -- However, we do not do this check if we are operating in syntax
338 -- checking only mode, because in that case there may be multiple
339 -- units in the same file, and the file name is not a reliable guide.
341 Save_Scan_State
(Scan_State
);
342 Scan
; -- past Package keyword
345 and then Operating_Mode
/= Check_Syntax
347 Get_Expected_Unit_Type
348 (File_Name
(Current_Source_File
)) = Expect_Body
350 Error_Msg_BC
("keyword BODY expected here [see file name]");
351 Restore_Scan_State
(Scan_State
);
352 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Pbod
));
354 Restore_Scan_State
(Scan_State
);
355 Set_Unit
(Comp_Unit_Node
, P_Package
(Pf_Decl_Gins_Pbod_Rnam
));
358 elsif Token
= Tok_Generic
then
359 Set_Unit
(Comp_Unit_Node
, P_Generic
);
361 elsif Token
= Tok_Separate
then
362 Set_Unit
(Comp_Unit_Node
, P_Subunit
);
364 elsif Token
= Tok_Procedure
365 or else Token
= Tok_Function
367 Set_Unit
(Comp_Unit_Node
, P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam
));
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
399 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
402 Body_Node
:= Unit
(Comp_Unit_Node
);
403 Specification_Node
:= Specification
(Body_Node
);
404 Change_Node
(Body_Node
, N_Subprogram_Body
);
405 Set_Specification
(Body_Node
, Specification_Node
);
406 Parse_Decls_Begin_End
(Body_Node
);
407 Set_Unit
(Comp_Unit_Node
, Body_Node
);
410 -- If we scanned a subprogram body, make sure we did not have private
412 elsif Private_Sloc
/= No_Location
414 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Function_Instantiation
416 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Procedure_Instantiation
418 Nkind
(Unit
(Comp_Unit_Node
)) /= N_Subprogram_Renaming_Declaration
420 Error_Msg
("cannot have private subprogram body", Private_Sloc
);
422 -- P_Subprogram can yield an abstract subprogram, but this cannot
423 -- be a compilation unit. Treat as a subprogram declaration.
426 Nkind
(Unit
(Comp_Unit_Node
)) = N_Abstract_Subprogram_Declaration
429 ("compilation unit cannot be abstract subprogram",
430 Unit
(Comp_Unit_Node
));
433 New_Node
(N_Subprogram_Declaration
, Sloc
(Comp_Unit_Node
));
434 Set_Specification
(Unit_Node
,
435 Specification
(Unit
(Comp_Unit_Node
)));
436 Set_Unit
(Comp_Unit_Node
, Unit_Node
);
439 -- Otherwise we have TASK. This is not really an acceptable token,
440 -- but we accept it to improve error recovery.
442 elsif Token
= Tok_Task
then
445 if Token
= Tok_Type
then
447 ("task type cannot be used as compilation unit");
450 ("task declaration cannot be used as compilation unit");
453 -- If in check syntax mode, accept the task anyway. This is done
454 -- particularly to improve the behavior of GNATCHOP in this case.
456 if Operating_Mode
= Check_Syntax
then
457 Set_Unit
(Comp_Unit_Node
, P_Task
);
459 -- If not in syntax only mode, treat this as horrible error
462 Cunit_Error_Flag
:= True;
466 else pragma Assert
(Token
= Tok_Protected
);
467 Scan
; -- Past PROTECTED
469 if Token
= Tok_Type
then
471 ("protected type cannot be used as compilation unit");
474 ("protected declaration cannot be used as compilation unit");
477 -- If in check syntax mode, accept protected anyway. This is done
478 -- particularly to improve the behavior of GNATCHOP in this case.
480 if Operating_Mode
= Check_Syntax
then
481 Set_Unit
(Comp_Unit_Node
, P_Protected
);
483 -- If not in syntax only mode, treat this as horrible error
486 Cunit_Error_Flag
:= True;
491 -- Here is where locate the compilation unit entity. This is a little
492 -- tricky, since it is buried in various places.
494 Unit_Node
:= Unit
(Comp_Unit_Node
);
496 -- Another error from which it is hard to recover
498 if Nkind
(Unit_Node
) = N_Subprogram_Body_Stub
499 or else Nkind
(Unit_Node
) = N_Package_Body_Stub
501 Cunit_Error_Flag
:= True;
505 -- Only try this if we got an OK unit!
507 if Unit_Node
/= Error
then
508 if Nkind
(Unit_Node
) = N_Subunit
then
509 Unit_Node
:= Proper_Body
(Unit_Node
);
512 if Nkind
(Unit_Node
) in N_Generic_Declaration
then
513 Unit_Node
:= Specification
(Unit_Node
);
516 if Nkind
(Unit_Node
) = N_Package_Declaration
517 or else Nkind
(Unit_Node
) = N_Subprogram_Declaration
518 or else Nkind
(Unit_Node
) = N_Subprogram_Body
519 or else Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
521 Unit_Node
:= Specification
(Unit_Node
);
523 elsif Nkind
(Unit_Node
) = N_Subprogram_Renaming_Declaration
then
526 ("(Ada 83) library unit renaming not allowed", Unit_Node
);
530 if Nkind
(Unit_Node
) = N_Task_Body
531 or else Nkind
(Unit_Node
) = N_Protected_Body
532 or else Nkind
(Unit_Node
) = N_Task_Type_Declaration
533 or else Nkind
(Unit_Node
) = N_Protected_Type_Declaration
534 or else Nkind
(Unit_Node
) = N_Single_Task_Declaration
535 or else Nkind
(Unit_Node
) = N_Single_Protected_Declaration
537 Name_Node
:= Defining_Identifier
(Unit_Node
);
539 Name_Node
:= Defining_Unit_Name
(Unit_Node
);
542 Set_Sloc
(Comp_Unit_Node
, Sloc
(Name_Node
));
543 Set_Sloc
(Aux_Decls_Node
(Comp_Unit_Node
), Sloc
(Name_Node
));
545 -- Set Entity field in file table. Easier now that we have name!
546 -- Note that this is also skipped if we had a bad unit
548 if Nkind
(Name_Node
) = N_Defining_Program_Unit_Name
then
550 (Current_Source_Unit
, Defining_Identifier
(Name_Node
));
552 Set_Cunit_Entity
(Current_Source_Unit
, Name_Node
);
556 (Current_Source_Unit
, Get_Unit_Name
(Unit
(Comp_Unit_Node
)));
558 -- If we had a bad unit, make sure the fatal flag is set in the file
559 -- table entry, since this is surely a fatal error and also set our
560 -- flag to inhibit the requirement that we be at end of file.
563 Cunit_Error_Flag
:= True;
564 Set_Fatal_Error
(Current_Source_Unit
);
567 -- Clear away any missing semicolon indication, we are done with that
568 -- unit, so what's done is done, and we don't want anything hanging
569 -- around from the attempt to parse it!
571 SIS_Entry_Active
:= False;
573 -- Scan out pragmas after unit
575 while Token
= Tok_Pragma
loop
576 Save_Scan_State
(Scan_State
);
578 -- If we are in syntax scan mode allowing multiple units, then
579 -- start the next unit if we encounter a configuration pragma,
580 -- or a source reference pragma. We take care not to actually
581 -- scan the pragma in this case since we don't want it to take
582 -- effect for the current unit.
584 if Operating_Mode
= Check_Syntax
then
587 if Token
= Tok_Identifier
590 First_Pragma_Name
.. Last_Configuration_Pragma_Name
591 or else Token_Name
= Name_Source_Reference
)
593 Restore_Scan_State
(Scan_State
); -- to Pragma
598 -- Otherwise eat the pragma, it definitely belongs with the
599 -- current unit, and not with the following unit.
601 Restore_Scan_State
(Scan_State
); -- to Pragma
604 if No
(Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
))) then
606 (Aux_Decls_Node
(Comp_Unit_Node
), New_List
);
609 Append
(P
, Pragmas_After
(Aux_Decls_Node
(Comp_Unit_Node
)));
612 -- Cancel effect of any outstanding pragma Warnings (Off)
614 Set_Warnings_Mode_On
(Scan_Ptr
);
616 -- Ada 83 error checks
620 -- Check we did not with any child units
622 Item
:= First
(Context_Items
(Comp_Unit_Node
));
624 while Present
(Item
) loop
625 if Nkind
(Item
) = N_With_Clause
626 and then Nkind
(Name
(Item
)) /= N_Identifier
628 Error_Msg_N
("(Ada 83) child units not allowed", Item
);
634 -- Check that we did not have a PRIVATE keyword present
636 if Private_Present
(Comp_Unit_Node
) then
638 ("(Ada 83) private units not allowed", Private_Sloc
);
642 -- If no serious error, then output possible unit information line
643 -- for gnatchop if we are in syntax only, list units mode.
645 if not Cunit_Error_Flag
647 and then Operating_Mode
= Check_Syntax
649 Unit_Display
(Comp_Unit_Node
, Cunit_Location
, SR_Present
);
652 -- And now we should be at the end of file
654 if Token
/= Tok_EOF
then
656 -- If we already had to scan for a compilation unit, then don't
657 -- give any further error message, since it just sems to make
658 -- things worse, and we already gave a serious error message.
660 if Cunit_Error_Flag
then
663 -- If we are in check syntax mode, then we allow multiple units
664 -- so we just return with Token not set to Tok_EOF and no message.
666 elsif Operating_Mode
= Check_Syntax
then
667 return Comp_Unit_Node
;
669 -- Otherwise we have an error. We suppress the error message
670 -- if we already had a fatal error, since this stops junk
671 -- cascaded messages in some situations.
674 if not Fatal_Error
(Current_Source_Unit
) then
676 if Token
in Token_Class_Cunit
then
678 ("end of file expected, " &
679 "file can have only one compilation unit");
682 Error_Msg_SC
("end of file expected");
687 -- Skip tokens to end of file, so that the -gnatl listing
688 -- will be complete in this situation, but no error checking
689 -- other than that provided at the token level.
691 while Token
/= Tok_EOF
loop
697 -- Normal return (we were at the end of file as expected)
700 return Comp_Unit_Node
;
705 -- An error resync is a serious bomb, so indicate result unit no good
708 Set_Fatal_Error
(Current_Source_Unit
);
711 end P_Compilation_Unit
;
713 --------------------------
714 -- 10.1.1 Library Item --
715 --------------------------
717 -- Parsed by P_Compilation_Unit (10.1.1)
719 --------------------------------------
720 -- 10.1.1 Library Unit Declaration --
721 --------------------------------------
723 -- Parsed by P_Compilation_Unit (10.1.1)
725 ------------------------------------------------
726 -- 10.1.1 Library Unit Renaming Declaration --
727 ------------------------------------------------
729 -- Parsed by P_Compilation_Unit (10.1.1)
731 -------------------------------
732 -- 10.1.1 Library Unit Body --
733 -------------------------------
735 -- Parsed by P_Compilation_Unit (10.1.1)
737 ------------------------------
738 -- 10.1.1 Parent Unit Name --
739 ------------------------------
741 -- Parsed (as a name) by its parent construct
743 ----------------------------
744 -- 10.1.2 Context Clause --
745 ----------------------------
747 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
749 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
752 -- with library_unit_NAME {,library_unit_NAME};
754 -- WITH_TYPE_CLAUSE ::=
755 -- with type type_NAME is access; | with type type_NAME is tagged;
757 -- Error recovery: Cannot raise Error_Resync
759 function P_Context_Clause
return List_Id
is
761 Has_Limited
: Boolean := False;
763 First_Flag
: Boolean;
766 Item_List
:= New_List
;
768 -- Get keyword casing from WITH keyword in case not set yet
770 if Token
= Tok_With
then
771 Set_Keyword_Casing
(Current_Source_File
, Determine_Token_Casing
);
774 -- Loop through context items
777 if Style_Check
then Style
.Check_Indentation
; end if;
779 -- Gather any pragmas appearing in the context clause
781 P_Pragmas_Opt
(Item_List
);
783 -- Processing for WITH clause
785 -- Ada0Y (AI-50217): First check for LIMITED WITH
787 if Token
= Tok_Limited
then
789 Scan
; -- past LIMITED
791 -- In the context, LIMITED can only appear in a with_clause
793 if Token
/= Tok_With
then
794 Error_Msg_SC
("unexpected LIMITED ignored");
797 if not Extensions_Allowed
then
798 Error_Msg_SP
("`LIMITED WITH` is an Ada0X extension");
802 ("\unit must be compiled with " &
803 "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
806 ("\unit must be compiled with -gnatX switch");
810 Has_Limited
:= False;
813 if Token
= Tok_With
then
816 if Token
= Tok_Type
then
818 -- WITH TYPE is an extension
820 if not Extensions_Allowed
then
821 Error_Msg_SP
("`WITH TYPE` is a non-standard extension");
825 ("\unit must be compiled with " &
826 "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
829 ("\unit must be compiled with -gnatX switch");
834 With_Node
:= New_Node
(N_With_Type_Clause
, Token_Ptr
);
835 Append
(With_Node
, Item_List
);
836 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
840 if Token
= Tok_Tagged
then
841 Set_Tagged_Present
(With_Node
);
844 elsif Token
= Tok_Access
then
848 Error_Msg_SC
("expect tagged or access qualifier");
856 -- Loop through names in one with clause, generating a separate
857 -- N_With_Clause node for each nam encountered.
860 With_Node
:= New_Node
(N_With_Clause
, Token_Ptr
);
861 Append
(With_Node
, Item_List
);
863 -- Note that we allow with'ing of child units, even in
864 -- Ada 83 mode, since presumably if this is not desired,
865 -- then the compilation of the child unit itself is the
866 -- place where such an "error" should be caught.
868 Set_Name
(With_Node
, P_Qualified_Simple_Name
);
869 Set_First_Name
(With_Node
, First_Flag
);
870 Set_Limited_Present
(With_Node
, Has_Limited
);
872 exit when Token
/= Tok_Comma
;
876 Set_Last_Name
(With_Node
, True);
880 -- Processing for USE clause
882 elsif Token
= Tok_Use
then
883 Append
(P_Use_Clause
, Item_List
);
885 -- Anything else is end of context clause
893 end P_Context_Clause
;
895 --------------------------
896 -- 10.1.2 Context Item --
897 --------------------------
899 -- Parsed by P_Context_Clause (10.1.2)
901 -------------------------
902 -- 10.1.2 With Clause --
903 -------------------------
905 -- Parsed by P_Context_Clause (10.1.2)
907 -----------------------
908 -- 10.1.3 Body Stub --
909 -----------------------
911 -- Subprogram stub parsed by P_Subprogram (6.1)
912 -- Package stub parsed by P_Package (7.1)
913 -- Task stub parsed by P_Task (9.1)
914 -- Protected stub parsed by P_Protected (9.4)
916 ----------------------------------
917 -- 10.1.3 Subprogram Body Stub --
918 ----------------------------------
920 -- Parsed by P_Subprogram (6.1)
922 -------------------------------
923 -- 10.1.3 Package Body Stub --
924 -------------------------------
926 -- Parsed by P_Package (7.1)
928 ----------------------------
929 -- 10.1.3 Task Body Stub --
930 ----------------------------
932 -- Parsed by P_Task (9.1)
934 ---------------------------------
935 -- 10.1.3 Protected Body Stub --
936 ---------------------------------
938 -- Parsed by P_Protected (9.4)
940 ---------------------
942 ---------------------
944 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
946 -- PARENT_UNIT_NAME ::= NAME
948 -- The caller has checked that the initial token is SEPARATE
950 -- Error recovery: cannot raise Error_Resync
952 function P_Subunit
return Node_Id
is
953 Subunit_Node
: Node_Id
;
957 Subunit_Node
:= New_Node
(N_Subunit
, Token_Ptr
);
958 Body_Node
:= Error
; -- in case no good body found
959 Scan
; -- past SEPARATE;
962 Set_Name
(Subunit_Node
, P_Qualified_Simple_Name
);
965 if Token
= Tok_Semicolon
then
966 Error_Msg_SC
("unexpected semicolon ignored");
970 if Token
= Tok_Function
or else Token
= Tok_Procedure
then
971 Body_Node
:= P_Subprogram
(Pf_Pbod
);
973 elsif Token
= Tok_Package
then
974 Body_Node
:= P_Package
(Pf_Pbod
);
976 elsif Token
= Tok_Protected
then
977 Scan
; -- past PROTECTED
979 if Token
= Tok_Body
then
980 Body_Node
:= P_Protected
;
982 Error_Msg_AP
("BODY expected");
986 elsif Token
= Tok_Task
then
989 if Token
= Tok_Body
then
992 Error_Msg_AP
("BODY expected");
997 Error_Msg_SC
("proper body expected");
1001 Set_Proper_Body
(Subunit_Node
, Body_Node
);
1002 return Subunit_Node
;
1010 function Set_Location
return Source_Ptr
is
1013 Scan_State
: Saved_Scan_State
;
1016 -- A special check. If the first token is pragma, and this is a
1017 -- Source_Reference pragma, then do NOT eat previous comments, since
1018 -- the Source_Reference pragma is required to be the first line in
1021 if Token
= Tok_Pragma
then
1022 Save_Scan_State
(Scan_State
);
1023 Scan
; -- past Pragma
1025 if Token
= Tok_Identifier
1026 and then Token_Name
= Name_Source_Reference
1028 Restore_Scan_State
(Scan_State
);
1032 Restore_Scan_State
(Scan_State
);
1035 -- Otherwise acquire previous comments and blank lines
1037 if Prev_Token
= No_Token
then
1038 return Source_First
(Current_Source_File
);
1041 Loc
:= Prev_Token_Ptr
;
1043 exit when Loc
= Token_Ptr
;
1045 if Source
(Loc
) in Line_Terminator
then
1046 Skip_Line_Terminators
(Loc
, Physical
);
1061 -- The format of the generated line, as expected by GNATCHOP is
1063 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1067 -- {unit} unit name with terminating (spec) or (body)
1068 -- {line} starting line number
1069 -- {offs} offset to start of text in file
1070 -- {file} source file name
1072 -- The SR parameter is present only if a source reference pragma was
1073 -- scanned for this unit. The significance is that gnatchop should not
1074 -- attempt to add another one.
1076 procedure Unit_Display
1079 SR_Present
: Boolean)
1081 Unum
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Cunit
);
1082 Sind
: constant Source_File_Index
:= Source_Index
(Unum
);
1083 Unam
: constant Unit_Name_Type
:= Unit_Name
(Unum
);
1087 Write_Str
("Unit ");
1088 Write_Unit_Name
(Unit_Name
(Unum
));
1089 Unit_Location
(Sind
, Loc
);
1095 Write_Str
(", file name ");
1096 Write_Name
(Get_File_Name
(Unam
, Nkind
(Unit
(Cunit
)) = N_Subunit
));
1105 procedure Unit_Location
(Sind
: Source_File_Index
; Loc
: Source_Ptr
) is
1106 Line
: constant Logical_Line_Number
:= Get_Logical_Line_Number
(Loc
);
1107 -- Should the above be the physical line number ???
1110 Write_Str
(" line ");
1111 Write_Int
(Int
(Line
));
1113 Write_Str
(", file offset ");
1114 Write_Int
(Int
(Loc
) - Int
(Source_First
(Sind
)));