1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 Uname; use Uname;
38 -- Local functions, used only in this chapter
40 function P_Context_Clause return List_Id;
41 function P_Subunit return Node_Id;
43 function Set_Location return Source_Ptr;
44 -- The current compilation unit starts with Token at Token_Ptr. This
45 -- function determines the corresponding source location for the start
46 -- of the unit, including any preceding comment lines.
48 procedure Unit_Display
51 SR_Present : Boolean);
52 -- This procedure is used to generate a line of output for the a unit in
53 -- the source program. Cunit is the node for the compilation unit, and
54 -- Loc is the source location for the start of the unit in the source
55 -- file (which is not necessarily the Sloc of the Cunit node). This
56 -- output is written to the standard output file for use by gnatchop.
58 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
59 -- This routine has the same calling sequence as Unit_Display, but
60 -- it outputs only the line number and offset of the location, Loc,
61 -- using Cunit to obtain the proper source file index.
63 -------------------------
64 -- 10.1.1 Compilation --
65 -------------------------
67 -- COMPILATION ::= {COMPILATION_UNIT}
69 -- There is no specific parsing routine for a compilation, since we only
70 -- permit a single compilation in a source file, so there is no explicit
71 -- occurrence of compilations as such (our representation of a compilation
72 -- is a series of separate source files).
74 ------------------------------
75 -- 10.1.1 Compilation unit --
76 ------------------------------
78 -- COMPILATION_UNIT ::=
79 -- CONTEXT_CLAUSE LIBRARY_ITEM
80 -- | CONTEXT_CLAUSE SUBUNIT
83 -- private LIBRARY_UNIT_DECLARATION
84 -- | LIBRARY_UNIT_BODY
85 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
87 -- LIBRARY_UNIT_DECLARATION ::=
88 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
89 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
91 -- LIBRARY_UNIT_RENAMING_DECLARATION ::=
92 -- PACKAGE_RENAMING_DECLARATION
93 -- | GENERIC_RENAMING_DECLARATION
94 -- | SUBPROGRAM_RENAMING_DECLARATION
96 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
98 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
99 -- are skipped up to the next possible beginning of a compilation unit.
101 -- Note: if only configuration pragmas are found, Empty is returned
103 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit
104 -- to return strange things that are not really compilation units.
105 -- This is done to help out gnatchop when it is faced with nonsense.
107 function P_Compilation_Unit return Node_Id is
108 Scan_State : Saved_Scan_State;
110 Specification_Node : Node_Id;
112 Comp_Unit_Node : Node_Id;
115 Private_Sloc : Source_Ptr := No_Location;
116 Config_Pragmas : List_Id;
118 SR_Present : Boolean;
120 Cunit_Error_Flag : Boolean := False;
121 -- This flag is set True if we have to scan for a compilation unit
122 -- token. It is used to ensure clean termination in such cases by
123 -- not insisting on being at the end of file, and, in the sytax only
124 -- case by not scanning for additional compilation units.
126 Cunit_Location : Source_Ptr;
127 -- Location of unit for unit identification output (List_Unit option)
130 Num_Library_Units := Num_Library_Units + 1;
132 -- Set location of the compilation unit if unit list option set
133 -- and we are in syntax check only mode
135 if List_Units and then Operating_Mode = Check_Syntax then
136 Cunit_Location := Set_Location;
138 Cunit_Location := No_Location;
141 -- Deal with initial pragmas
143 Config_Pragmas := No_List;
145 -- If we have an initial Source_Reference pragma, then remember
146 -- the fact to generate an NR parameter in the output line.
150 if Token = Tok_Pragma then
151 Save_Scan_State (Scan_State);
155 or else Chars (Item) /= Name_Source_Reference
157 Restore_Scan_State (Scan_State);
162 -- If first unit, record the file name for gnatchop use
164 if Operating_Mode = Check_Syntax
166 and then Num_Library_Units = 1
168 Write_Str ("Source_Reference pragma for file """);
169 Write_Name (Full_Ref_Name (Current_Source_File));
174 Config_Pragmas := New_List (Item);
178 -- Scan out any configuration pragmas
180 while Token = Tok_Pragma loop
181 Save_Scan_State (Scan_State);
185 or else Chars (Item) > Last_Configuration_Pragma_Name
187 Restore_Scan_State (Scan_State);
191 if Config_Pragmas = No_List then
192 Config_Pragmas := Empty_List;
194 if Operating_Mode = Check_Syntax and then List_Units then
195 Write_Str ("Configuration pragmas at");
196 Unit_Location (Current_Source_File, Cunit_Location);
201 Append (Item, Config_Pragmas);
202 Cunit_Location := Set_Location;
205 -- Establish compilation unit node and scan context items
207 Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);
208 Set_Cunit (Current_Source_Unit, Comp_Unit_Node);
209 Set_Context_Items (Comp_Unit_Node, P_Context_Clause);
211 (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));
213 if Present (Config_Pragmas) then
215 -- Check for case of only configuration pragmas present
218 and then Is_Empty_List (Context_Items (Comp_Unit_Node))
220 if Operating_Mode = Check_Syntax then
224 Item := First (Config_Pragmas);
226 ("cannot compile configuration pragmas with gcc", Item);
228 ("use gnatchop -c to process configuration pragmas!", Item);
229 raise Unrecoverable_Error;
232 -- Otherwise configuration pragmas are simply prepended to the
233 -- context of the current unit.
236 Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
237 Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
241 -- Check for PRIVATE. Note that for the moment we allow this in
242 -- Ada_83 mode, since we do not yet know if we are compiling a
243 -- predefined unit, and if we are then it would be allowed anyway.
245 if Token = Tok_Private then
246 Private_Sloc := Token_Ptr;
247 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
248 if Style_Check then Style.Check_Indentation; end if;
250 Save_Scan_State (Scan_State); -- at PRIVATE
251 Scan; -- past PRIVATE
253 if Token = Tok_Separate then
254 Error_Msg_SP ("cannot have private subunits!");
256 elsif Token = Tok_Package then
257 Scan; -- past PACKAGE
259 if Token = Tok_Body then
260 Restore_Scan_State (Scan_State); -- to PRIVATE
261 Error_Msg_SC ("cannot have private package body!");
262 Scan; -- ignore PRIVATE
265 Restore_Scan_State (Scan_State); -- to PRIVATE
266 Scan; -- past PRIVATE
267 Set_Private_Present (Comp_Unit_Node, True);
270 elsif Token = Tok_Procedure
271 or else Token = Tok_Function
272 or else Token = Tok_Generic
274 Set_Private_Present (Comp_Unit_Node, True);
278 -- Loop to find our way to a compilation unit token
281 exit when Token in Token_Class_Cunit and then Token /= Tok_With;
283 exit when Bad_Spelling_Of (Tok_Package)
284 or else Bad_Spelling_Of (Tok_Function)
285 or else Bad_Spelling_Of (Tok_Generic)
286 or else Bad_Spelling_Of (Tok_Separate)
287 or else Bad_Spelling_Of (Tok_Procedure);
289 -- Allow task and protected for nice error recovery purposes
291 exit when Token = Tok_Task
292 or else Token = Tok_Protected;
294 if Token = Tok_With then
295 Error_Msg_SC ("misplaced WITH");
296 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
298 elsif Bad_Spelling_Of (Tok_With) then
299 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
302 if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
303 Error_Msg_SC ("?file contains no compilation units");
305 Error_Msg_SC ("compilation unit expected");
306 Cunit_Error_Flag := True;
310 -- If we are at an end of file, then just quit, the above error
311 -- message was complaint enough.
313 if Token = Tok_EOF then
319 -- We have a compilation unit token, so that's a reasonable choice for
320 -- determining the standard casing convention used for keywords in case
321 -- it hasn't already been done on seeing a WITH or PRIVATE.
323 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
324 if Style_Check then Style.Check_Indentation; end if;
326 -- Remaining processing depends on particular type of compilation unit
328 if Token = Tok_Package then
330 -- A common error is to omit the body keyword after package. We can
331 -- often diagnose this early on (before getting loads of errors from
332 -- contained subprogram bodies), by knowing that that the file we
333 -- are compiling has a name that requires a body to be found.
335 Save_Scan_State (Scan_State);
336 Scan; -- past Package keyword
340 Get_Expected_Unit_Type
341 (File_Name (Current_Source_File)) = Expect_Body
343 Error_Msg_BC ("keyword BODY expected here [see file name]");
344 Restore_Scan_State (Scan_State);
345 Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
347 Restore_Scan_State (Scan_State);
348 Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
351 elsif Token = Tok_Generic then
352 Set_Unit (Comp_Unit_Node, P_Generic);
354 elsif Token = Tok_Separate then
355 Set_Unit (Comp_Unit_Node, P_Subunit);
357 elsif Token = Tok_Procedure
358 or else Token = Tok_Function
360 Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
362 -- A little bit of an error recovery check here. If we just scanned
363 -- a subprogram declaration (as indicated by an SIS entry being
364 -- active), then if the following token is BEGIN or an identifier,
365 -- or a token which can reasonably start a declaration but cannot
366 -- start a compilation unit, then we assume that the semicolon in
367 -- the declaration should have been IS.
369 if SIS_Entry_Active then
372 or else Token = Tok_Identifier
373 or else Token in Token_Class_Deckn
376 Scope.Table (Scope.Last).Etyp := E_Name;
377 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
378 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
379 Scope.Table (Scope.Last).Lreq := False;
380 SIS_Entry_Active := False;
382 -- If we had a missing semicolon in the declaration, then
383 -- change the message to from <missing ";"> to <missing "is">
385 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
386 Change_Error_Text -- Replace: "missing "";"" "
387 (SIS_Missing_Semicolon_Message, "missing IS");
389 -- Otherwise we saved the semicolon position, so complain
392 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
395 Body_Node := Unit (Comp_Unit_Node);
396 Specification_Node := Specification (Body_Node);
397 Change_Node (Body_Node, N_Subprogram_Body);
398 Set_Specification (Body_Node, Specification_Node);
399 Parse_Decls_Begin_End (Body_Node);
400 Set_Unit (Comp_Unit_Node, Body_Node);
403 -- If we scanned a subprogram body, make sure we did not have private
405 elsif Private_Sloc /= No_Location
407 Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
409 Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
411 Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
413 Error_Msg ("cannot have private subprogram body", Private_Sloc);
415 -- P_Subprogram can yield an abstract subprogram, but this cannot
416 -- be a compilation unit. Treat as a subprogram declaration.
419 Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
422 ("compilation unit cannot be abstract subprogram",
423 Unit (Comp_Unit_Node));
426 New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
427 Set_Specification (Unit_Node,
428 Specification (Unit (Comp_Unit_Node)));
429 Set_Unit (Comp_Unit_Node, Unit_Node);
432 -- Otherwise we have TASK. This is not really an acceptable token,
433 -- but we accept it to improve error recovery.
435 elsif Token = Tok_Task then
438 if Token = Tok_Type then
440 ("task type cannot be used as compilation unit");
443 ("task declaration cannot be used as compilation unit");
446 -- If in check syntax mode, accept the task anyway. This is done
447 -- particularly to improve the behavior of GNATCHOP in this case.
449 if Operating_Mode = Check_Syntax then
450 Set_Unit (Comp_Unit_Node, P_Task);
452 -- If not in syntax only mode, treat this as horrible error
455 Cunit_Error_Flag := True;
459 else pragma Assert (Token = Tok_Protected);
460 Scan; -- Past PROTECTED
462 if Token = Tok_Type then
464 ("protected type cannot be used as compilation unit");
467 ("protected declaration cannot be used as compilation unit");
470 -- If in check syntax mode, accept protected anyway. This is done
471 -- particularly to improve the behavior of GNATCHOP in this case.
473 if Operating_Mode = Check_Syntax then
474 Set_Unit (Comp_Unit_Node, P_Protected);
476 -- If not in syntax only mode, treat this as horrible error
479 Cunit_Error_Flag := True;
484 -- Here is where locate the compilation unit entity. This is a little
485 -- tricky, since it is buried in various places.
487 Unit_Node := Unit (Comp_Unit_Node);
489 -- Another error from which it is hard to recover
491 if Nkind (Unit_Node) = N_Subprogram_Body_Stub
492 or else Nkind (Unit_Node) = N_Package_Body_Stub
494 Cunit_Error_Flag := True;
498 -- Only try this if we got an OK unit!
500 if Unit_Node /= Error then
501 if Nkind (Unit_Node) = N_Subunit then
502 Unit_Node := Proper_Body (Unit_Node);
505 if Nkind (Unit_Node) in N_Generic_Declaration then
506 Unit_Node := Specification (Unit_Node);
509 if Nkind (Unit_Node) = N_Package_Declaration
510 or else Nkind (Unit_Node) = N_Subprogram_Declaration
511 or else Nkind (Unit_Node) = N_Subprogram_Body
512 or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
514 Unit_Node := Specification (Unit_Node);
516 elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
517 if Ada_Version = Ada_83 then
519 ("(Ada 83) library unit renaming not allowed", Unit_Node);
523 if Nkind (Unit_Node) = N_Task_Body
524 or else Nkind (Unit_Node) = N_Protected_Body
525 or else Nkind (Unit_Node) = N_Task_Type_Declaration
526 or else Nkind (Unit_Node) = N_Protected_Type_Declaration
527 or else Nkind (Unit_Node) = N_Single_Task_Declaration
528 or else Nkind (Unit_Node) = N_Single_Protected_Declaration
530 Name_Node := Defining_Identifier (Unit_Node);
532 Name_Node := Defining_Unit_Name (Unit_Node);
535 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
536 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
538 -- Set Entity field in file table. Easier now that we have name!
539 -- Note that this is also skipped if we had a bad unit
541 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
543 (Current_Source_Unit, Defining_Identifier (Name_Node));
545 Set_Cunit_Entity (Current_Source_Unit, Name_Node);
549 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
551 -- If we had a bad unit, make sure the fatal flag is set in the file
552 -- table entry, since this is surely a fatal error and also set our
553 -- flag to inhibit the requirement that we be at end of file.
556 Cunit_Error_Flag := True;
557 Set_Fatal_Error (Current_Source_Unit);
560 -- Clear away any missing semicolon indication, we are done with that
561 -- unit, so what's done is done, and we don't want anything hanging
562 -- around from the attempt to parse it!
564 SIS_Entry_Active := False;
566 -- Scan out pragmas after unit
568 while Token = Tok_Pragma loop
569 Save_Scan_State (Scan_State);
571 -- If we are in syntax scan mode allowing multiple units, then
572 -- start the next unit if we encounter a configuration pragma,
573 -- or a source reference pragma. We take care not to actually
574 -- scan the pragma in this case since we don't want it to take
575 -- effect for the current unit.
577 if Operating_Mode = Check_Syntax then
580 if Token = Tok_Identifier
583 First_Pragma_Name .. Last_Configuration_Pragma_Name
584 or else Token_Name = Name_Source_Reference)
586 Restore_Scan_State (Scan_State); -- to Pragma
591 -- Otherwise eat the pragma, it definitely belongs with the
592 -- current unit, and not with the following unit.
594 Restore_Scan_State (Scan_State); -- to Pragma
597 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
599 (Aux_Decls_Node (Comp_Unit_Node), New_List);
602 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
605 -- Cancel effect of any outstanding pragma Warnings (Off)
607 Set_Warnings_Mode_On (Scan_Ptr);
609 -- Ada 83 error checks
611 if Ada_Version = Ada_83 then
613 -- Check we did not with any child units
615 Item := First (Context_Items (Comp_Unit_Node));
617 while Present (Item) loop
618 if Nkind (Item) = N_With_Clause
619 and then Nkind (Name (Item)) /= N_Identifier
621 Error_Msg_N ("(Ada 83) child units not allowed", Item);
627 -- Check that we did not have a PRIVATE keyword present
629 if Private_Present (Comp_Unit_Node) then
631 ("(Ada 83) private units not allowed", Private_Sloc);
635 -- If no serious error, then output possible unit information line
636 -- for gnatchop if we are in syntax only, list units mode.
638 if not Cunit_Error_Flag
640 and then Operating_Mode = Check_Syntax
642 Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);
645 -- And now we should be at the end of file
647 if Token /= Tok_EOF then
649 -- If we already had to scan for a compilation unit, then don't
650 -- give any further error message, since it just sems to make
651 -- things worse, and we already gave a serious error message.
653 if Cunit_Error_Flag then
656 -- If we are in check syntax mode, then we allow multiple units
657 -- so we just return with Token not set to Tok_EOF and no message.
659 elsif Operating_Mode = Check_Syntax then
660 return Comp_Unit_Node;
662 -- We also allow multiple units if we are in multiple unit mode
664 elsif Multiple_Unit_Index /= 0 then
666 -- Skip tokens to end of file, so that the -gnatl listing
667 -- will be complete in this situation, but no need to parse
668 -- the remaining units; no style checking either.
671 Save_Style_Check : constant Boolean := Style_Check;
674 Style_Check := False;
676 while Token /= Tok_EOF loop
680 Style_Check := Save_Style_Check;
683 return Comp_Unit_Node;
685 -- Otherwise we have an error. We suppress the error message
686 -- if we already had a fatal error, since this stops junk
687 -- cascaded messages in some situations.
690 if not Fatal_Error (Current_Source_Unit) then
691 if Token in Token_Class_Cunit then
693 ("end of file expected, " &
694 "file can have only one compilation unit");
696 Error_Msg_SC ("end of file expected");
701 -- Skip tokens to end of file, so that the -gnatl listing
702 -- will be complete in this situation, but no error checking
703 -- other than that provided at the token level.
705 while Token /= Tok_EOF loop
711 -- Normal return (we were at the end of file as expected)
714 return Comp_Unit_Node;
719 -- An error resync is a serious bomb, so indicate result unit no good
722 Set_Fatal_Error (Current_Source_Unit);
724 end P_Compilation_Unit;
726 --------------------------
727 -- 10.1.1 Library Item --
728 --------------------------
730 -- Parsed by P_Compilation_Unit (10.1.1)
732 --------------------------------------
733 -- 10.1.1 Library Unit Declaration --
734 --------------------------------------
736 -- Parsed by P_Compilation_Unit (10.1.1)
738 ------------------------------------------------
739 -- 10.1.1 Library Unit Renaming Declaration --
740 ------------------------------------------------
742 -- Parsed by P_Compilation_Unit (10.1.1)
744 -------------------------------
745 -- 10.1.1 Library Unit Body --
746 -------------------------------
748 -- Parsed by P_Compilation_Unit (10.1.1)
750 ------------------------------
751 -- 10.1.1 Parent Unit Name --
752 ------------------------------
754 -- Parsed (as a name) by its parent construct
756 ----------------------------
757 -- 10.1.2 Context Clause --
758 ----------------------------
760 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
762 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
765 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
766 -- Note: the two qualifiers are Ada 2005 extensions.
768 -- WITH_TYPE_CLAUSE ::=
769 -- with type type_NAME is access; | with type type_NAME is tagged;
770 -- Note: this form is obsolete (old GNAT extension).
772 -- Error recovery: Cannot raise Error_Resync
774 function P_Context_Clause return List_Id is
776 Has_Limited : Boolean := False;
777 Has_Private : Boolean := False;
778 Scan_State : Saved_Scan_State;
780 First_Flag : Boolean;
783 Item_List := New_List;
785 -- Get keyword casing from WITH keyword in case not set yet
787 if Token = Tok_With then
788 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
791 -- Loop through context items
794 if Style_Check then Style.Check_Indentation; end if;
796 -- Gather any pragmas appearing in the context clause
798 P_Pragmas_Opt (Item_List);
800 -- Processing for WITH clause
802 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
803 -- PRIVATE WITH, or both.
805 if Token = Tok_Limited then
807 Has_Private := False;
808 Scan; -- past LIMITED
810 -- In the context, LIMITED can only appear in a with_clause
812 if Token = Tok_Private then
814 Scan; -- past PRIVATE
817 if Token /= Tok_With then
818 Error_Msg_SC ("unexpected LIMITED ignored");
821 if Ada_Version < Ada_05 then
822 Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
824 ("\unit must be compiled with -gnat05 switch");
827 elsif Token = Tok_Private then
828 Has_Limited := False;
830 Save_Scan_State (Scan_State);
831 Scan; -- past PRIVATE
833 if Token /= Tok_With then
835 -- Keyword is beginning of private child unit
837 Restore_Scan_State (Scan_State); -- to PRIVATE
840 elsif Ada_Version < Ada_05 then
841 Error_Msg_SP ("PRIVATE WITH is an Ada 2005 extension");
843 ("\unit must be compiled with -gnat05 switch");
847 Has_Limited := False;
848 Has_Private := False;
851 if Token = Tok_With then
854 if Token = Tok_Type then
856 -- WITH TYPE is an GNAT specific extension
858 if not Extensions_Allowed then
859 Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension");
860 Error_Msg_SP ("\unit must be compiled with -gnatX switch");
864 With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
865 Append (With_Node, Item_List);
866 Set_Name (With_Node, P_Qualified_Simple_Name);
870 if Token = Tok_Tagged then
871 Set_Tagged_Present (With_Node);
874 elsif Token = Tok_Access then
878 Error_Msg_SC ("expect tagged or access qualifier");
886 -- Loop through names in one with clause, generating a separate
887 -- N_With_Clause node for each nam encountered.
890 With_Node := New_Node (N_With_Clause, Token_Ptr);
891 Append (With_Node, Item_List);
893 -- Note that we allow with'ing of child units, even in
894 -- Ada 83 mode, since presumably if this is not desired,
895 -- then the compilation of the child unit itself is the
896 -- place where such an "error" should be caught.
898 Set_Name (With_Node, P_Qualified_Simple_Name);
899 Set_First_Name (With_Node, First_Flag);
900 Set_Limited_Present (With_Node, Has_Limited);
901 Set_Private_Present (With_Node, Has_Private);
904 -- All done if no comma
906 exit when Token /= Tok_Comma;
908 -- If comma is followed by compilation unit token
909 -- or by USE, or PRAGMA, then it should have been a
910 -- semicolon after all
912 Save_Scan_State (Scan_State);
915 if Token in Token_Class_Cunit
916 or else Token = Tok_Use
917 or else Token = Tok_Pragma
919 Restore_Scan_State (Scan_State);
924 Set_Last_Name (With_Node, True);
928 -- Processing for USE clause
930 elsif Token = Tok_Use then
931 Append (P_Use_Clause, Item_List);
933 -- Anything else is end of context clause
941 end P_Context_Clause;
943 --------------------------
944 -- 10.1.2 Context Item --
945 --------------------------
947 -- Parsed by P_Context_Clause (10.1.2)
949 -------------------------
950 -- 10.1.2 With Clause --
951 -------------------------
953 -- Parsed by P_Context_Clause (10.1.2)
955 -----------------------
956 -- 10.1.3 Body Stub --
957 -----------------------
959 -- Subprogram stub parsed by P_Subprogram (6.1)
960 -- Package stub parsed by P_Package (7.1)
961 -- Task stub parsed by P_Task (9.1)
962 -- Protected stub parsed by P_Protected (9.4)
964 ----------------------------------
965 -- 10.1.3 Subprogram Body Stub --
966 ----------------------------------
968 -- Parsed by P_Subprogram (6.1)
970 -------------------------------
971 -- 10.1.3 Package Body Stub --
972 -------------------------------
974 -- Parsed by P_Package (7.1)
976 ----------------------------
977 -- 10.1.3 Task Body Stub --
978 ----------------------------
980 -- Parsed by P_Task (9.1)
982 ---------------------------------
983 -- 10.1.3 Protected Body Stub --
984 ---------------------------------
986 -- Parsed by P_Protected (9.4)
988 ---------------------
990 ---------------------
992 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
994 -- PARENT_UNIT_NAME ::= NAME
996 -- The caller has checked that the initial token is SEPARATE
998 -- Error recovery: cannot raise Error_Resync
1000 function P_Subunit return Node_Id is
1001 Subunit_Node : Node_Id;
1002 Body_Node : Node_Id;
1005 Subunit_Node := New_Node (N_Subunit, Token_Ptr);
1006 Body_Node := Error; -- in case no good body found
1007 Scan; -- past SEPARATE;
1010 Set_Name (Subunit_Node, P_Qualified_Simple_Name);
1013 if Token = Tok_Semicolon then
1014 Error_Msg_SC ("unexpected semicolon ignored");
1018 if Token = Tok_Function or else Token = Tok_Procedure then
1019 Body_Node := P_Subprogram (Pf_Pbod);
1021 elsif Token = Tok_Package then
1022 Body_Node := P_Package (Pf_Pbod);
1024 elsif Token = Tok_Protected then
1025 Scan; -- past PROTECTED
1027 if Token = Tok_Body then
1028 Body_Node := P_Protected;
1030 Error_Msg_AP ("BODY expected");
1034 elsif Token = Tok_Task then
1037 if Token = Tok_Body then
1038 Body_Node := P_Task;
1040 Error_Msg_AP ("BODY expected");
1045 Error_Msg_SC ("proper body expected");
1049 Set_Proper_Body (Subunit_Node, Body_Node);
1050 return Subunit_Node;
1058 function Set_Location return Source_Ptr is
1061 Scan_State : Saved_Scan_State;
1064 -- A special check. If the first token is pragma, and this is a
1065 -- Source_Reference pragma, then do NOT eat previous comments, since
1066 -- the Source_Reference pragma is required to be the first line in
1069 if Token = Tok_Pragma then
1070 Save_Scan_State (Scan_State);
1071 Scan; -- past Pragma
1073 if Token = Tok_Identifier
1074 and then Token_Name = Name_Source_Reference
1076 Restore_Scan_State (Scan_State);
1080 Restore_Scan_State (Scan_State);
1083 -- Otherwise acquire previous comments and blank lines
1085 if Prev_Token = No_Token then
1086 return Source_First (Current_Source_File);
1089 Loc := Prev_Token_Ptr;
1091 exit when Loc = Token_Ptr;
1093 if Source (Loc) in Line_Terminator then
1094 Skip_Line_Terminators (Loc, Physical);
1109 -- The format of the generated line, as expected by GNATCHOP is
1111 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1115 -- {unit} unit name with terminating (spec) or (body)
1116 -- {line} starting line number
1117 -- {offs} offset to start of text in file
1118 -- {file} source file name
1120 -- The SR parameter is present only if a source reference pragma was
1121 -- scanned for this unit. The significance is that gnatchop should not
1122 -- attempt to add another one.
1124 procedure Unit_Display
1127 SR_Present : Boolean)
1129 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
1130 Sind : constant Source_File_Index := Source_Index (Unum);
1131 Unam : constant Unit_Name_Type := Unit_Name (Unum);
1135 Write_Str ("Unit ");
1136 Write_Unit_Name (Unit_Name (Unum));
1137 Unit_Location (Sind, Loc);
1143 Write_Str (", file name ");
1144 Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
1153 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
1154 Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
1155 -- Should the above be the physical line number ???
1158 Write_Str (" line ");
1159 Write_Int (Int (Line));
1161 Write_Str (", file offset ");
1162 Write_Int (Int (Loc) - Int (Source_First (Sind)));