1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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);
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);
326 Style.Check_Indentation;
329 -- Remaining processing depends on particular type of compilation unit
331 if Token = Tok_Package then
333 -- A common error is to omit the body keyword after package. We can
334 -- often diagnose this early on (before getting loads of errors from
335 -- contained subprogram bodies), by knowing that that the file we
336 -- are compiling has a name that requires a body to be found.
338 Save_Scan_State (Scan_State);
339 Scan; -- past Package keyword
343 Get_Expected_Unit_Type
344 (File_Name (Current_Source_File)) = Expect_Body
346 Error_Msg_BC ("keyword BODY expected here [see file name]");
347 Restore_Scan_State (Scan_State);
348 Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
350 Restore_Scan_State (Scan_State);
351 Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
354 elsif Token = Tok_Generic then
355 Set_Unit (Comp_Unit_Node, P_Generic);
357 elsif Token = Tok_Separate then
358 Set_Unit (Comp_Unit_Node, P_Subunit);
360 elsif Token = Tok_Function
361 or else Token = Tok_Not
362 or else Token = Tok_Overriding
363 or else Token = Tok_Procedure
365 Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
367 -- A little bit of an error recovery check here. If we just scanned
368 -- a subprogram declaration (as indicated by an SIS entry being
369 -- active), then if the following token is BEGIN or an identifier,
370 -- or a token which can reasonably start a declaration but cannot
371 -- start a compilation unit, then we assume that the semicolon in
372 -- the declaration should have been IS.
374 if SIS_Entry_Active then
377 or else Token = Tok_Identifier
378 or else Token in Token_Class_Deckn
381 Scope.Table (Scope.Last).Etyp := E_Name;
382 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
383 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
384 Scope.Table (Scope.Last).Lreq := False;
385 SIS_Entry_Active := False;
387 -- If we had a missing semicolon in the declaration, then
388 -- change the message to from <missing ";"> to <missing "is">
390 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
391 Change_Error_Text -- Replace: "missing "";"" "
392 (SIS_Missing_Semicolon_Message, "missing IS");
394 -- Otherwise we saved the semicolon position, so complain
397 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
400 Body_Node := Unit (Comp_Unit_Node);
401 Specification_Node := Specification (Body_Node);
402 Change_Node (Body_Node, N_Subprogram_Body);
403 Set_Specification (Body_Node, Specification_Node);
404 Parse_Decls_Begin_End (Body_Node);
405 Set_Unit (Comp_Unit_Node, Body_Node);
408 -- If we scanned a subprogram body, make sure we did not have private
410 elsif Private_Sloc /= No_Location
412 Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation
414 Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
416 Error_Msg ("cannot have private subprogram body", Private_Sloc);
418 -- P_Subprogram can yield an abstract subprogram, but this cannot
419 -- be a compilation unit. Treat as a subprogram declaration.
422 Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
425 ("compilation unit cannot be abstract subprogram",
426 Unit (Comp_Unit_Node));
429 New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
430 Set_Specification (Unit_Node,
431 Specification (Unit (Comp_Unit_Node)));
432 Set_Unit (Comp_Unit_Node, Unit_Node);
435 -- Otherwise we have TASK. This is not really an acceptable token,
436 -- but we accept it to improve error recovery.
438 elsif Token = Tok_Task then
441 if Token = Tok_Type then
443 ("task type cannot be used as compilation unit");
446 ("task declaration cannot be used as compilation unit");
449 -- If in check syntax mode, accept the task anyway. This is done
450 -- particularly to improve the behavior of GNATCHOP in this case.
452 if Operating_Mode = Check_Syntax then
453 Set_Unit (Comp_Unit_Node, P_Task);
455 -- If not in syntax only mode, treat this as horrible error
458 Cunit_Error_Flag := True;
462 else pragma Assert (Token = Tok_Protected);
463 Scan; -- Past PROTECTED
465 if Token = Tok_Type then
467 ("protected type cannot be used as compilation unit");
470 ("protected declaration cannot be used as compilation unit");
473 -- If in check syntax mode, accept protected anyway. This is done
474 -- particularly to improve the behavior of GNATCHOP in this case.
476 if Operating_Mode = Check_Syntax then
477 Set_Unit (Comp_Unit_Node, P_Protected);
479 -- If not in syntax only mode, treat this as horrible error
482 Cunit_Error_Flag := True;
487 -- Here is where locate the compilation unit entity. This is a little
488 -- tricky, since it is buried in various places.
490 Unit_Node := Unit (Comp_Unit_Node);
492 -- Another error from which it is hard to recover
494 if Nkind (Unit_Node) = N_Subprogram_Body_Stub
495 or else Nkind (Unit_Node) = N_Package_Body_Stub
497 Cunit_Error_Flag := True;
501 -- Only try this if we got an OK unit!
503 if Unit_Node /= Error then
504 if Nkind (Unit_Node) = N_Subunit then
505 Unit_Node := Proper_Body (Unit_Node);
508 if Nkind (Unit_Node) in N_Generic_Declaration then
509 Unit_Node := Specification (Unit_Node);
512 if Nkind (Unit_Node) = N_Package_Declaration
513 or else Nkind (Unit_Node) = N_Subprogram_Declaration
514 or else Nkind (Unit_Node) = N_Subprogram_Body
515 or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
517 Unit_Node := Specification (Unit_Node);
519 elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
520 if Ada_Version = Ada_83 then
522 ("(Ada 83) library unit renaming not allowed", Unit_Node);
526 if Nkind (Unit_Node) = N_Task_Body
527 or else Nkind (Unit_Node) = N_Protected_Body
528 or else Nkind (Unit_Node) = N_Task_Type_Declaration
529 or else Nkind (Unit_Node) = N_Protected_Type_Declaration
530 or else Nkind (Unit_Node) = N_Single_Task_Declaration
531 or else Nkind (Unit_Node) = N_Single_Protected_Declaration
533 Name_Node := Defining_Identifier (Unit_Node);
535 elsif Nkind (Unit_Node) = N_Function_Instantiation
536 or else Nkind (Unit_Node) = N_Function_Specification
537 or else Nkind (Unit_Node) = N_Generic_Function_Renaming_Declaration
538 or else Nkind (Unit_Node) = N_Generic_Package_Renaming_Declaration
539 or else Nkind (Unit_Node) = N_Generic_Procedure_Renaming_Declaration
540 or else Nkind (Unit_Node) = N_Package_Body
541 or else Nkind (Unit_Node) = N_Package_Instantiation
542 or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
543 or else Nkind (Unit_Node) = N_Package_Specification
544 or else Nkind (Unit_Node) = N_Procedure_Instantiation
545 or else Nkind (Unit_Node) = N_Procedure_Specification
547 Name_Node := Defining_Unit_Name (Unit_Node);
549 -- Anything else is a serious error, abandon scan
555 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
556 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
558 -- Set Entity field in file table. Easier now that we have name!
559 -- Note that this is also skipped if we had a bad unit
561 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
563 (Current_Source_Unit, Defining_Identifier (Name_Node));
565 Set_Cunit_Entity (Current_Source_Unit, Name_Node);
569 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
571 -- If we had a bad unit, make sure the fatal flag is set in the file
572 -- table entry, since this is surely a fatal error and also set our
573 -- flag to inhibit the requirement that we be at end of file.
576 Cunit_Error_Flag := True;
577 Set_Fatal_Error (Current_Source_Unit);
580 -- Clear away any missing semicolon indication, we are done with that
581 -- unit, so what's done is done, and we don't want anything hanging
582 -- around from the attempt to parse it!
584 SIS_Entry_Active := False;
586 -- Scan out pragmas after unit
588 while Token = Tok_Pragma loop
589 Save_Scan_State (Scan_State);
591 -- If we are in syntax scan mode allowing multiple units, then
592 -- start the next unit if we encounter a configuration pragma,
593 -- or a source reference pragma. We take care not to actually
594 -- scan the pragma in this case since we don't want it to take
595 -- effect for the current unit.
597 if Operating_Mode = Check_Syntax then
600 if Token = Tok_Identifier
603 First_Pragma_Name .. Last_Configuration_Pragma_Name
604 or else Token_Name = Name_Source_Reference)
606 Restore_Scan_State (Scan_State); -- to Pragma
611 -- Otherwise eat the pragma, it definitely belongs with the
612 -- current unit, and not with the following unit.
614 Restore_Scan_State (Scan_State); -- to Pragma
617 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
619 (Aux_Decls_Node (Comp_Unit_Node), New_List);
622 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
625 -- Cancel effect of any outstanding pragma Warnings (Off)
627 Set_Warnings_Mode_On (Scan_Ptr);
629 -- Ada 83 error checks
631 if Ada_Version = Ada_83 then
633 -- Check we did not with any child units
635 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 sems 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 ("unexpected LIMITED ignored");
843 if Ada_Version < Ada_05 then
844 Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
846 ("\unit must be compiled with -gnat05 switch");
849 elsif Token = Tok_Private then
850 Has_Limited := False;
852 Save_Scan_State (Scan_State);
853 Scan; -- past PRIVATE
855 if Token /= Tok_With then
857 -- Keyword is beginning of private child unit
859 Restore_Scan_State (Scan_State); -- to PRIVATE
862 elsif Ada_Version < Ada_05 then
863 Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension");
865 ("\unit must be compiled with -gnat05 switch");
869 Has_Limited := False;
870 Has_Private := False;
873 if Token = Tok_With then
876 if Token = Tok_Type then
878 -- WITH TYPE is an obsolete GNAT specific extension
881 ("`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 nam 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 if Token = Tok_Semicolon then
1031 Error_Msg_SC ("unexpected semicolon ignored");
1035 if Token = Tok_Function or else Token = Tok_Procedure then
1036 Body_Node := P_Subprogram (Pf_Pbod);
1038 elsif Token = Tok_Package then
1039 Body_Node := P_Package (Pf_Pbod);
1041 elsif Token = Tok_Protected then
1042 Scan; -- past PROTECTED
1044 if Token = Tok_Body then
1045 Body_Node := P_Protected;
1047 Error_Msg_AP ("BODY expected");
1051 elsif Token = Tok_Task then
1054 if Token = Tok_Body then
1055 Body_Node := P_Task;
1057 Error_Msg_AP ("BODY expected");
1062 Error_Msg_SC ("proper body expected");
1066 Set_Proper_Body (Subunit_Node, Body_Node);
1067 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)));