1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001 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 Error_Msg_SC ("compilation unit expected");
304 Cunit_Error_Flag := True;
307 -- If we are at an end of file, then just quit, the above error
308 -- message was complaint enough.
310 if Token = Tok_EOF then
316 -- We have a compilation unit token, so that's a reasonable choice for
317 -- determining the standard casing convention used for keywords in case
318 -- it hasn't already been done on seeing a WITH or PRIVATE.
320 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
321 if Style_Check then Style.Check_Indentation; end if;
323 -- Remaining processing depends on particular type of compilation unit
325 if Token = Tok_Package then
327 -- A common error is to omit the body keyword after package. We can
328 -- often diagnose this early on (before getting loads of errors from
329 -- contained subprogram bodies), by knowing that that the file we
330 -- are compiling has a name that requires a body to be found.
332 -- However, we do not do this check if we are operating in syntax
333 -- checking only mode, because in that case there may be multiple
334 -- units in the same file, and the file name is not a reliable guide.
336 Save_Scan_State (Scan_State);
337 Scan; -- past Package keyword
340 and then Operating_Mode /= Check_Syntax
342 Get_Expected_Unit_Type
343 (File_Name (Current_Source_File)) = Expect_Body
345 Error_Msg_BC ("keyword BODY expected here [see file name]");
346 Restore_Scan_State (Scan_State);
347 Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
349 Restore_Scan_State (Scan_State);
350 Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
353 elsif Token = Tok_Generic then
354 Set_Unit (Comp_Unit_Node, P_Generic);
356 elsif Token = Tok_Separate then
357 Set_Unit (Comp_Unit_Node, P_Subunit);
359 elsif Token = Tok_Procedure
360 or else Token = Tok_Function
362 Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
364 -- A little bit of an error recovery check here. If we just scanned
365 -- a subprogram declaration (as indicated by an SIS entry being
366 -- active), then if the following token is BEGIN or an identifier,
367 -- or a token which can reasonably start a declaration but cannot
368 -- start a compilation unit, then we assume that the semicolon in
369 -- the declaration should have been IS.
371 if SIS_Entry_Active then
374 or else Token = Tok_Identifier
375 or else Token in Token_Class_Deckn
378 Scope.Table (Scope.Last).Etyp := E_Name;
379 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
380 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
381 Scope.Table (Scope.Last).Lreq := False;
382 SIS_Entry_Active := False;
384 -- If we had a missing semicolon in the declaration, then
385 -- change the message to from <missing ";"> to <missing "is">
387 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
388 Change_Error_Text -- Replace: "missing "";"" "
389 (SIS_Missing_Semicolon_Message, "missing IS");
391 -- Otherwise we saved the semicolon position, so complain
394 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
397 Body_Node := Unit (Comp_Unit_Node);
398 Specification_Node := Specification (Body_Node);
399 Change_Node (Body_Node, N_Subprogram_Body);
400 Set_Specification (Body_Node, Specification_Node);
401 Parse_Decls_Begin_End (Body_Node);
402 Set_Unit (Comp_Unit_Node, Body_Node);
405 -- If we scanned a subprogram body, make sure we did not have private
407 elsif Private_Sloc /= No_Location
408 and then Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
409 and then Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
411 Error_Msg ("cannot have private subprogram body", Private_Sloc);
413 -- P_Subprogram can yield an abstract subprogram, but this cannot
414 -- be a compilation unit. Treat as a subprogram declaration.
417 Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
420 ("compilation unit cannot be abstract subprogram",
421 Unit (Comp_Unit_Node));
424 New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
425 Set_Specification (Unit_Node,
426 Specification (Unit (Comp_Unit_Node)));
427 Set_Unit (Comp_Unit_Node, Unit_Node);
430 -- Otherwise we have TASK. This is not really an acceptable token,
431 -- but we accept it to improve error recovery.
433 elsif Token = Tok_Task then
436 if Token = Tok_Type then
438 ("task type cannot be used as compilation unit");
441 ("task declaration cannot be used as compilation unit");
444 -- If in check syntax mode, accept the task anyway. This is done
445 -- particularly to improve the behavior of GNATCHOP in this case.
447 if Operating_Mode = Check_Syntax then
448 Set_Unit (Comp_Unit_Node, P_Task);
450 -- If not in syntax only mode, treat this as horrible error
453 Cunit_Error_Flag := True;
457 else pragma Assert (Token = Tok_Protected);
458 Scan; -- Past PROTECTED
460 if Token = Tok_Type then
462 ("protected type cannot be used as compilation unit");
465 ("protected declaration cannot be used as compilation unit");
468 -- If in check syntax mode, accept protected anyway. This is done
469 -- particularly to improve the behavior of GNATCHOP in this case.
471 if Operating_Mode = Check_Syntax then
472 Set_Unit (Comp_Unit_Node, P_Protected);
474 -- If not in syntax only mode, treat this as horrible error
477 Cunit_Error_Flag := True;
482 -- Here is where locate the compilation unit entity. This is a little
483 -- tricky, since it is buried in various places.
485 Unit_Node := Unit (Comp_Unit_Node);
487 -- Another error from which it is hard to recover
489 if Nkind (Unit_Node) = N_Subprogram_Body_Stub
490 or else Nkind (Unit_Node) = N_Package_Body_Stub
492 Cunit_Error_Flag := True;
496 -- Only try this if we got an OK unit!
498 if Unit_Node /= Error then
499 if Nkind (Unit_Node) = N_Subunit then
500 Unit_Node := Proper_Body (Unit_Node);
503 if Nkind (Unit_Node) in N_Generic_Declaration then
504 Unit_Node := Specification (Unit_Node);
507 if Nkind (Unit_Node) = N_Package_Declaration
508 or else Nkind (Unit_Node) = N_Subprogram_Declaration
509 or else Nkind (Unit_Node) = N_Subprogram_Body
510 or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
512 Unit_Node := Specification (Unit_Node);
514 elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
517 ("(Ada 83) library unit renaming not allowed", Unit_Node);
521 if Nkind (Unit_Node) = N_Task_Body
522 or else Nkind (Unit_Node) = N_Protected_Body
523 or else Nkind (Unit_Node) = N_Task_Type_Declaration
524 or else Nkind (Unit_Node) = N_Protected_Type_Declaration
525 or else Nkind (Unit_Node) = N_Single_Task_Declaration
526 or else Nkind (Unit_Node) = N_Single_Protected_Declaration
528 Name_Node := Defining_Identifier (Unit_Node);
530 Name_Node := Defining_Unit_Name (Unit_Node);
533 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
534 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
536 -- Set Entity field in file table. Easier now that we have name!
537 -- Note that this is also skipped if we had a bad unit
539 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
541 (Current_Source_Unit, Defining_Identifier (Name_Node));
543 Set_Cunit_Entity (Current_Source_Unit, Name_Node);
547 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
549 -- If we had a bad unit, make sure the fatal flag is set in the file
550 -- table entry, since this is surely a fatal error and also set our
551 -- flag to inhibit the requirement that we be at end of file.
554 Cunit_Error_Flag := True;
555 Set_Fatal_Error (Current_Source_Unit);
558 -- Clear away any missing semicolon indication, we are done with that
559 -- unit, so what's done is done, and we don't want anything hanging
560 -- around from the attempt to parse it!
562 SIS_Entry_Active := False;
564 -- Scan out pragmas after unit
566 while Token = Tok_Pragma loop
567 Save_Scan_State (Scan_State);
569 -- If we are in syntax scan mode allowing multiple units, then
570 -- start the next unit if we encounter a configuration pragma,
571 -- or a source reference pragma. We take care not to actually
572 -- scan the pragma in this case since we don't want it to take
573 -- effect for the current unit.
575 if Operating_Mode = Check_Syntax then
578 if Token = Tok_Identifier
581 First_Pragma_Name .. Last_Configuration_Pragma_Name
582 or else Token_Name = Name_Source_Reference)
584 Restore_Scan_State (Scan_State); -- to Pragma
589 -- Otherwise eat the pragma, it definitely belongs with the
590 -- current unit, and not with the following unit.
592 Restore_Scan_State (Scan_State); -- to Pragma
595 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
597 (Aux_Decls_Node (Comp_Unit_Node), New_List);
600 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
603 -- Cancel effect of any outstanding pragma Warnings (Off)
605 Set_Warnings_Mode_On (Scan_Ptr);
607 -- Ada 83 error checks
611 -- Check we did not with any child units
613 Item := First (Context_Items (Comp_Unit_Node));
615 while Present (Item) loop
616 if Nkind (Item) = N_With_Clause
617 and then Nkind (Name (Item)) /= N_Identifier
619 Error_Msg_N ("(Ada 83) child units not allowed", Item);
625 -- Check that we did not have a PRIVATE keyword present
627 if Private_Present (Comp_Unit_Node) then
629 ("(Ada 83) private units not allowed", Private_Sloc);
633 -- If no serious error, then output possible unit information line
634 -- for gnatchop if we are in syntax only, list units mode.
636 if not Cunit_Error_Flag
638 and then Operating_Mode = Check_Syntax
640 Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);
643 -- And now we should be at the end of file
645 if Token /= Tok_EOF then
647 -- If we already had to scan for a compilation unit, then don't
648 -- give any further error message, since it just sems to make
649 -- things worse, and we already gave a serious error message.
651 if Cunit_Error_Flag then
654 -- If we are in check syntax mode, then we allow multiple units
655 -- so we just return with Token not set to Tok_EOF and no message.
657 elsif Operating_Mode = Check_Syntax then
658 return Comp_Unit_Node;
660 -- Otherwise we have an error. We suppress the error message
661 -- if we already had a fatal error, since this stops junk
662 -- cascaded messages in some situations.
665 if not Fatal_Error (Current_Source_Unit) then
667 if Token in Token_Class_Cunit then
669 ("end of file expected, " &
670 "file can have only one compilation unit");
673 Error_Msg_SC ("end of file expected");
678 -- Skip tokens to end of file, so that the -gnatl listing
679 -- will be complete in this situation, but no error checking
680 -- other than that provided at the token level.
682 while Token /= Tok_EOF loop
688 -- Normal return (we were at the end of file as expected)
691 return Comp_Unit_Node;
696 -- An error resync is a serious bomb, so indicate result unit no good
699 Set_Fatal_Error (Current_Source_Unit);
702 end P_Compilation_Unit;
704 --------------------------
705 -- 10.1.1 Library Item --
706 --------------------------
708 -- Parsed by P_Compilation_Unit (10.1.1)
710 --------------------------------------
711 -- 10.1.1 Library Unit Declaration --
712 --------------------------------------
714 -- Parsed by P_Compilation_Unit (10.1.1)
716 ------------------------------------------------
717 -- 10.1.1 Library Unit Renaming Declaration --
718 ------------------------------------------------
720 -- Parsed by P_Compilation_Unit (10.1.1)
722 -------------------------------
723 -- 10.1.1 Library Unit Body --
724 -------------------------------
726 -- Parsed by P_Compilation_Unit (10.1.1)
728 ------------------------------
729 -- 10.1.1 Parent Unit Name --
730 ------------------------------
732 -- Parsed (as a name) by its parent construct
734 ----------------------------
735 -- 10.1.2 Context Clause --
736 ----------------------------
738 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
740 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
743 -- with library_unit_NAME {,library_unit_NAME};
745 -- WITH_TYPE_CLAUSE ::=
746 -- with type type_NAME is access; | with type type_NAME is tagged;
748 -- Error recovery: Cannot raise Error_Resync
750 function P_Context_Clause return List_Id is
753 First_Flag : Boolean;
756 Item_List := New_List;
758 -- Get keyword casing from WITH keyword in case not set yet
760 if Token = Tok_With then
761 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
764 -- Loop through context items
767 if Style_Check then Style.Check_Indentation; end if;
769 -- Gather any pragmas appearing in the context clause
771 P_Pragmas_Opt (Item_List);
773 -- Processing for WITH clause
775 if Token = Tok_With then
778 if Token = Tok_Type then
780 -- WITH TYPE is an extension
782 if not Extensions_Allowed then
783 Error_Msg_SP ("`WITH TYPE` is a non-standard extension");
787 ("\unit must be compiled with " &
788 "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
791 ("\unit must be compiled with -gnatX switch");
796 With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
797 Append (With_Node, Item_List);
798 Set_Name (With_Node, P_Qualified_Simple_Name);
802 if Token = Tok_Tagged then
803 Set_Tagged_Present (With_Node);
806 elsif Token = Tok_Access then
810 Error_Msg_SC ("expect tagged or access qualifier");
818 -- Loop through names in one with clause, generating a separate
819 -- N_With_Clause node for each nam encountered.
822 With_Node := New_Node (N_With_Clause, Token_Ptr);
823 Append (With_Node, Item_List);
825 -- Note that we allow with'ing of child units, even in
826 -- Ada 83 mode, since presumably if this is not desired,
827 -- then the compilation of the child unit itself is the
828 -- place where such an "error" should be caught.
830 Set_Name (With_Node, P_Qualified_Simple_Name);
831 Set_First_Name (With_Node, First_Flag);
833 exit when Token /= Tok_Comma;
837 Set_Last_Name (With_Node, True);
841 -- Processing for USE clause
843 elsif Token = Tok_Use then
844 Append (P_Use_Clause, Item_List);
846 -- Anything else is end of context clause
854 end P_Context_Clause;
856 --------------------------
857 -- 10.1.2 Context Item --
858 --------------------------
860 -- Parsed by P_Context_Clause (10.1.2)
862 -------------------------
863 -- 10.1.2 With Clause --
864 -------------------------
866 -- Parsed by P_Context_Clause (10.1.2)
868 -----------------------
869 -- 10.1.3 Body Stub --
870 -----------------------
872 -- Subprogram stub parsed by P_Subprogram (6.1)
873 -- Package stub parsed by P_Package (7.1)
874 -- Task stub parsed by P_Task (9.1)
875 -- Protected stub parsed by P_Protected (9.4)
877 ----------------------------------
878 -- 10.1.3 Subprogram Body Stub --
879 ----------------------------------
881 -- Parsed by P_Subprogram (6.1)
883 -------------------------------
884 -- 10.1.3 Package Body Stub --
885 -------------------------------
887 -- Parsed by P_Package (7.1)
889 ----------------------------
890 -- 10.1.3 Task Body Stub --
891 ----------------------------
893 -- Parsed by P_Task (9.1)
895 ---------------------------------
896 -- 10.1.3 Protected Body Stub --
897 ---------------------------------
899 -- Parsed by P_Protected (9.4)
901 ---------------------
903 ---------------------
905 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
907 -- PARENT_UNIT_NAME ::= NAME
909 -- The caller has checked that the initial token is SEPARATE
911 -- Error recovery: cannot raise Error_Resync
913 function P_Subunit return Node_Id is
914 Subunit_Node : Node_Id;
918 Subunit_Node := New_Node (N_Subunit, Token_Ptr);
919 Body_Node := Error; -- in case no good body found
920 Scan; -- past SEPARATE;
923 Set_Name (Subunit_Node, P_Qualified_Simple_Name);
926 if Token = Tok_Semicolon then
927 Error_Msg_SC ("unexpected semicolon ignored");
931 if Token = Tok_Function or else Token = Tok_Procedure then
932 Body_Node := P_Subprogram (Pf_Pbod);
934 elsif Token = Tok_Package then
935 Body_Node := P_Package (Pf_Pbod);
937 elsif Token = Tok_Protected then
938 Scan; -- past PROTECTED
940 if Token = Tok_Body then
941 Body_Node := P_Protected;
943 Error_Msg_AP ("BODY expected");
947 elsif Token = Tok_Task then
950 if Token = Tok_Body then
953 Error_Msg_AP ("BODY expected");
958 Error_Msg_SC ("proper body expected");
962 Set_Proper_Body (Subunit_Node, Body_Node);
971 function Set_Location return Source_Ptr is
974 Scan_State : Saved_Scan_State;
977 -- A special check. If the first token is pragma, and this is a
978 -- Source_Reference pragma, then do NOT eat previous comments, since
979 -- the Source_Reference pragma is required to be the first line in
982 if Token = Tok_Pragma then
983 Save_Scan_State (Scan_State);
986 if Token = Tok_Identifier
987 and then Token_Name = Name_Source_Reference
989 Restore_Scan_State (Scan_State);
993 Restore_Scan_State (Scan_State);
996 -- Otherwise acquire previous comments and blank lines
998 if Prev_Token = No_Token then
999 return Source_First (Current_Source_File);
1002 Loc := Prev_Token_Ptr;
1004 exit when Loc = Token_Ptr;
1006 if Source (Loc) in Line_Terminator then
1007 Skip_Line_Terminators (Loc, Physical);
1022 -- The format of the generated line, as expected by GNATCHOP is
1024 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1028 -- {unit} unit name with terminating (spec) or (body)
1029 -- {line} starting line number
1030 -- {offs} offset to start of text in file
1031 -- {file} source file name
1033 -- The SR parameter is present only if a source reference pragma was
1034 -- scanned for this unit. The significance is that gnatchop should not
1035 -- attempt to add another one.
1037 procedure Unit_Display
1040 SR_Present : Boolean)
1042 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
1043 Sind : constant Source_File_Index := Source_Index (Unum);
1044 Unam : constant Unit_Name_Type := Unit_Name (Unum);
1048 Write_Str ("Unit ");
1049 Write_Unit_Name (Unit_Name (Unum));
1050 Unit_Location (Sind, Loc);
1056 Write_Str (", file name ");
1057 Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
1066 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
1067 Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
1068 -- Should the above be the physical line number ???
1071 Write_Str (" line ");
1072 Write_Int (Int (Line));
1074 Write_Str (", file offset ");
1075 Write_Int (Int (Loc) - Int (Source_First (Sind)));