Mercurial > hg > CbC > CbC_gcc
view gcc/ada/par-ch10.adb @ 158:494b0b89df80 default tip
...
| author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
|---|---|
| date | Mon, 25 May 2020 18:13:55 +0900 |
| parents | 1830386684a0 |
| children |
line wrap: on
line source
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 1 0 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); -- Turn off subprogram body ordering check. Subprograms are in order -- by RM section rather than alphabetical with Fname.UF; use Fname.UF; with Uname; use Uname; separate (Par) package body Ch10 is -- Local functions, used only in this chapter function P_Context_Clause return List_Id; function P_Subunit return Node_Id; function Set_Location return Source_Ptr; -- The current compilation unit starts with Token at Token_Ptr. This -- function determines the corresponding source location for the start -- of the unit, including any preceding comment lines. procedure Unit_Display (Cunit : Node_Id; Loc : Source_Ptr; SR_Present : Boolean); -- This procedure is used to generate a line of output for a unit in -- the source program. Cunit is the node for the compilation unit, and -- Loc is the source location for the start of the unit in the source -- file (which is not necessarily the Sloc of the Cunit node). This -- output is written to the standard output file for use by gnatchop. procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr); -- This routine has the same calling sequence as Unit_Display, but -- it outputs only the line number and offset of the location, Loc, -- using Cunit to obtain the proper source file index. ------------------------- -- 10.1.1 Compilation -- ------------------------- -- COMPILATION ::= {COMPILATION_UNIT} -- There is no specific parsing routine for a compilation, since we only -- permit a single compilation in a source file, so there is no explicit -- occurrence of compilations as such (our representation of a compilation -- is a series of separate source files). ------------------------------ -- 10.1.1 Compilation unit -- ------------------------------ -- COMPILATION_UNIT ::= -- CONTEXT_CLAUSE LIBRARY_ITEM -- | CONTEXT_CLAUSE SUBUNIT -- LIBRARY_ITEM ::= -- private LIBRARY_UNIT_DECLARATION -- | LIBRARY_UNIT_BODY -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION -- LIBRARY_UNIT_DECLARATION ::= -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION -- LIBRARY_UNIT_RENAMING_DECLARATION ::= -- PACKAGE_RENAMING_DECLARATION -- | GENERIC_RENAMING_DECLARATION -- | SUBPROGRAM_RENAMING_DECLARATION -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens -- are skipped up to the next possible beginning of a compilation unit. -- Note: if only configuration pragmas are found, Empty is returned -- Note: in syntax-only mode, it is possible for P_Compilation_Unit -- to return strange things that are not really compilation units. -- This is done to help out gnatchop when it is faced with nonsense. function P_Compilation_Unit return Node_Id is Scan_State : Saved_Scan_State; Body_Node : Node_Id; Specification_Node : Node_Id; Unit_Node : Node_Id; Comp_Unit_Node : Node_Id; Name_Node : Node_Id; Item : Node_Id; Private_Sloc : Source_Ptr := No_Location; Config_Pragmas : List_Id; P : Node_Id; SR_Present : Boolean; No_Body : Boolean; Cunit_Error_Flag : Boolean := False; -- This flag is set True if we have to scan for a compilation unit -- token. It is used to ensure clean termination in such cases by -- not insisting on being at the end of file, and, in the syntax only -- case by not scanning for additional compilation units. Cunit_Location : Source_Ptr; -- Location of unit for unit identification output (List_Unit option) begin Num_Library_Units := Num_Library_Units + 1; -- Set location of the compilation unit if unit list option set -- and we are in syntax check only mode if List_Units and then Operating_Mode = Check_Syntax then Cunit_Location := Set_Location; else Cunit_Location := No_Location; end if; -- Deal with initial pragmas Config_Pragmas := No_List; -- If we have an initial Source_Reference pragma, then remember the fact -- to generate an NR parameter in the output line. SR_Present := False; -- If we see a pragma No_Body, remember not to complain about no body No_Body := False; if Token = Tok_Pragma then Save_Scan_State (Scan_State); Item := P_Pragma; if Item = Error or else Pragma_Name_Unmapped (Item) /= Name_Source_Reference then Restore_Scan_State (Scan_State); else SR_Present := True; -- If first unit, record the file name for gnatchop use if Operating_Mode = Check_Syntax and then List_Units and then Num_Library_Units = 1 then Write_Str ("Source_Reference pragma for file """); Write_Name (Full_Ref_Name (Current_Source_File)); Write_Char ('"'); Write_Eol; end if; Config_Pragmas := New_List (Item); end if; end if; -- Scan out any configuration pragmas while Token = Tok_Pragma loop Save_Scan_State (Scan_State); Item := P_Pragma; if Item /= Error and then Pragma_Name_Unmapped (Item) = Name_No_Body then No_Body := True; end if; if Item = Error or else not Is_Configuration_Pragma_Name (Pragma_Name_Unmapped (Item)) then Restore_Scan_State (Scan_State); exit; end if; if Config_Pragmas = No_List then Config_Pragmas := Empty_List; if Operating_Mode = Check_Syntax and then List_Units then Write_Str ("Configuration pragmas at"); Unit_Location (Current_Source_File, Cunit_Location); Write_Eol; end if; end if; Append (Item, Config_Pragmas); Cunit_Location := Set_Location; end loop; -- Establish compilation unit node and scan context items Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location); Set_Cunit (Current_Source_Unit, Comp_Unit_Node); Set_Context_Items (Comp_Unit_Node, P_Context_Clause); Set_Aux_Decls_Node (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location)); if Present (Config_Pragmas) then -- Check for case of only configuration pragmas present if Token = Tok_EOF and then Is_Empty_List (Context_Items (Comp_Unit_Node)) then if Operating_Mode = Check_Syntax then return Empty; else Item := First (Config_Pragmas); Error_Msg_N ("cannot compile configuration pragmas with gcc!", Item); Error_Msg_N ("\use gnatchop -c to process configuration pragmas!", Item); raise Unrecoverable_Error; end if; -- Otherwise configuration pragmas are simply prepended to the -- context of the current unit. else Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas); Set_Context_Items (Comp_Unit_Node, Config_Pragmas); end if; end if; -- Check for PRIVATE. Note that for the moment we allow this in -- Ada_83 mode, since we do not yet know if we are compiling a -- predefined unit, and if we are then it would be allowed anyway. if Token = Tok_Private then Private_Sloc := Token_Ptr; Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); if Style_Check then Style.Check_Indentation; end if; Save_Scan_State (Scan_State); -- at PRIVATE Scan; -- past PRIVATE if Token = Tok_Separate then Error_Msg_SP ("cannot have private subunits!"); elsif Token = Tok_Package then Scan; -- past PACKAGE if Token = Tok_Body then Restore_Scan_State (Scan_State); -- to PRIVATE Error_Msg_SC ("cannot have private package body!"); Scan; -- ignore PRIVATE else Restore_Scan_State (Scan_State); -- to PRIVATE Scan; -- past PRIVATE Set_Private_Present (Comp_Unit_Node, True); end if; elsif Token = Tok_Procedure or else Token = Tok_Function or else Token = Tok_Generic then Set_Private_Present (Comp_Unit_Node, True); end if; end if; -- Loop to find our way to a compilation unit token loop exit when Token in Token_Class_Cunit and then Token /= Tok_With; exit when Bad_Spelling_Of (Tok_Package) or else Bad_Spelling_Of (Tok_Function) or else Bad_Spelling_Of (Tok_Generic) or else Bad_Spelling_Of (Tok_Separate) or else Bad_Spelling_Of (Tok_Procedure); -- Allow task and protected for nice error recovery purposes exit when Token = Tok_Task or else Token = Tok_Protected; if Token = Tok_With then Error_Msg_SC ("misplaced WITH"); Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); elsif Bad_Spelling_Of (Tok_With) then Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); else if Operating_Mode = Check_Syntax and then Token = Tok_EOF then -- Do not complain if there is a pragma No_Body if not No_Body then Error_Msg_SC ("??file contains no compilation units"); end if; else Error_Msg_SC ("compilation unit expected"); Cunit_Error_Flag := True; Resync_Cunit; end if; -- If we are at an end of file, then just quit, the above error -- message was complaint enough. if Token = Tok_EOF then return Error; end if; end if; end loop; -- We have a compilation unit token, so that's a reasonable choice for -- determining the standard casing convention used for keywords in case -- it hasn't already been done on seeing a WITH or PRIVATE. Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); if Style_Check then Style.Check_Indentation; end if; -- Remaining processing depends on particular type of compilation unit if Token = Tok_Package then -- A common error is to omit the body keyword after package. We can -- often diagnose this early on (before getting loads of errors from -- contained subprogram bodies), by knowing that the file we -- are compiling has a name that requires a body to be found. Save_Scan_State (Scan_State); Scan; -- past Package keyword if Token /= Tok_Body and then Get_Expected_Unit_Type (File_Name (Current_Source_File)) = Expect_Body then Error_Msg_BC -- CODEFIX ("keyword BODY expected here '[see file name']"); Restore_Scan_State (Scan_State); Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp)); else Restore_Scan_State (Scan_State); Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp)); end if; elsif Token = Tok_Generic then Set_Unit (Comp_Unit_Node, P_Generic); elsif Token = Tok_Separate then Set_Unit (Comp_Unit_Node, P_Subunit); elsif Token = Tok_Function or else Token = Tok_Not or else Token = Tok_Overriding or else Token = Tok_Procedure then Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp)); -- A little bit of an error recovery check here. If we just scanned -- a subprogram declaration (as indicated by an SIS entry being -- active), then if the following token is BEGIN or an identifier, -- or a token which can reasonably start a declaration but cannot -- start a compilation unit, then we assume that the semicolon in -- the declaration should have been IS. if SIS_Entry_Active then if Token = Tok_Begin or else Token = Tok_Identifier or else Token in Token_Class_Deckn then Push_Scope_Stack; Scopes (Scope.Last).Etyp := E_Name; Scopes (Scope.Last).Sloc := SIS_Sloc; Scopes (Scope.Last).Ecol := SIS_Ecol; Scopes (Scope.Last).Lreq := False; SIS_Entry_Active := False; -- If we had a missing semicolon in the declaration, then -- change the message to from <missing ";"> to <missing "is"> if SIS_Missing_Semicolon_Message /= No_Error_Msg then Change_Error_Text -- Replace: "missing "";"" " (SIS_Missing_Semicolon_Message, "missing IS"); -- Otherwise we saved the semicolon position, so complain else Error_Msg -- CODEFIX (""";"" should be IS", SIS_Semicolon_Sloc); end if; Body_Node := Unit (Comp_Unit_Node); Specification_Node := Specification (Body_Node); Change_Node (Body_Node, N_Subprogram_Body); Set_Specification (Body_Node, Specification_Node); Parse_Decls_Begin_End (Body_Node); Set_Unit (Comp_Unit_Node, Body_Node); end if; -- If we scanned a subprogram body, make sure we did not have private elsif Private_Sloc /= No_Location and then Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation and then Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration then Error_Msg ("cannot have private subprogram body", Private_Sloc); -- P_Subprogram can yield an abstract subprogram, but this cannot -- be a compilation unit. Treat as a subprogram declaration. elsif Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration then Error_Msg_N ("compilation unit cannot be abstract subprogram", Unit (Comp_Unit_Node)); Unit_Node := New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node)); Set_Specification (Unit_Node, Specification (Unit (Comp_Unit_Node))); Set_Unit (Comp_Unit_Node, Unit_Node); end if; -- Otherwise we have TASK. This is not really an acceptable token, -- but we accept it to improve error recovery. elsif Token = Tok_Task then Scan; -- Past TASK if Token = Tok_Type then Error_Msg_SP ("task type cannot be used as compilation unit"); else Error_Msg_SP ("task declaration cannot be used as compilation unit"); end if; -- If in check syntax mode, accept the task anyway. This is done -- particularly to improve the behavior of GNATCHOP in this case. if Operating_Mode = Check_Syntax then Set_Unit (Comp_Unit_Node, P_Task); -- If not in syntax only mode, treat this as horrible error else Cunit_Error_Flag := True; return Error; end if; else pragma Assert (Token = Tok_Protected); Scan; -- Past PROTECTED if Token = Tok_Type then Error_Msg_SP ("protected type cannot be used as compilation unit"); else Error_Msg_SP ("protected declaration cannot be used as compilation unit"); end if; -- If in check syntax mode, accept protected anyway. This is done -- particularly to improve the behavior of GNATCHOP in this case. if Operating_Mode = Check_Syntax then Set_Unit (Comp_Unit_Node, P_Protected); -- If not in syntax only mode, treat this as horrible error else Cunit_Error_Flag := True; return Error; end if; end if; -- Here is where locate the compilation unit entity. This is a little -- tricky, since it is buried in various places. Unit_Node := Unit (Comp_Unit_Node); -- Another error from which it is hard to recover if Nkind_In (Unit_Node, N_Subprogram_Body_Stub, N_Package_Body_Stub) then Cunit_Error_Flag := True; return Error; end if; -- Only try this if we got an OK unit if Unit_Node /= Error then if Nkind (Unit_Node) = N_Subunit then Unit_Node := Proper_Body (Unit_Node); end if; if Nkind (Unit_Node) in N_Generic_Declaration then Unit_Node := Specification (Unit_Node); end if; if Nkind_In (Unit_Node, N_Package_Declaration, N_Subprogram_Declaration, N_Subprogram_Body, N_Subprogram_Renaming_Declaration) then Unit_Node := Specification (Unit_Node); elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then if Ada_Version = Ada_83 then Error_Msg_N ("(Ada 83) library unit renaming not allowed", Unit_Node); end if; end if; if Nkind_In (Unit_Node, N_Task_Body, N_Protected_Body, N_Task_Type_Declaration, N_Protected_Type_Declaration, N_Single_Task_Declaration, N_Single_Protected_Declaration) then Name_Node := Defining_Identifier (Unit_Node); elsif Nkind_In (Unit_Node, N_Function_Instantiation, N_Function_Specification, N_Generic_Function_Renaming_Declaration, N_Generic_Package_Renaming_Declaration, N_Generic_Procedure_Renaming_Declaration) or else Nkind_In (Unit_Node, N_Package_Body, N_Package_Instantiation, N_Package_Renaming_Declaration, N_Package_Specification, N_Procedure_Instantiation, N_Procedure_Specification) then Name_Node := Defining_Unit_Name (Unit_Node); elsif Nkind (Unit_Node) = N_Expression_Function then Error_Msg_SP ("expression function cannot be used as compilation unit"); return Comp_Unit_Node; -- Anything else is a serious error, abandon scan else raise Error_Resync; end if; Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node)); -- Set Entity field in file table. Easier now that we have name. -- Note that this is also skipped if we had a bad unit if Nkind (Name_Node) = N_Defining_Program_Unit_Name then Set_Cunit_Entity (Current_Source_Unit, Defining_Identifier (Name_Node)); else Set_Cunit_Entity (Current_Source_Unit, Name_Node); end if; Set_Unit_Name (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node))); -- If we had a bad unit, make sure the fatal flag is set in the file -- table entry, since this is surely a fatal error and also set our -- flag to inhibit the requirement that we be at end of file. else Cunit_Error_Flag := True; Set_Fatal_Error (Current_Source_Unit, Error_Detected); end if; -- Clear away any missing semicolon indication, we are done with that -- unit, so what's done is done, and we don't want anything hanging -- around from the attempt to parse it. SIS_Entry_Active := False; -- Scan out pragmas after unit while Token = Tok_Pragma loop Save_Scan_State (Scan_State); -- If we are in syntax scan mode allowing multiple units, then start -- the next unit if we encounter a configuration pragma, or a source -- reference pragma. We take care not to actually scan the pragma in -- this case (we don't want it to take effect for the current unit). if Operating_Mode = Check_Syntax then Scan; -- past Pragma if Token = Tok_Identifier and then (Is_Configuration_Pragma_Name (Token_Name) or else Token_Name = Name_Source_Reference) then Restore_Scan_State (Scan_State); -- to Pragma exit; end if; end if; -- Otherwise eat the pragma, it definitely belongs with the -- current unit, and not with the following unit. Restore_Scan_State (Scan_State); -- to Pragma P := P_Pragma; if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then Set_Pragmas_After (Aux_Decls_Node (Comp_Unit_Node), New_List); end if; Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))); end loop; -- Cancel effect of any outstanding pragma Warnings (Off) Set_Warnings_Mode_On (Scan_Ptr); -- Ada 83 error checks if Ada_Version = Ada_83 then -- Check we did not with any child units Item := First (Context_Items (Comp_Unit_Node)); while Present (Item) loop if Nkind (Item) = N_With_Clause and then Nkind (Name (Item)) /= N_Identifier then Error_Msg_N ("(Ada 83) child units not allowed", Item); end if; Next (Item); end loop; -- Check that we did not have a PRIVATE keyword present if Private_Present (Comp_Unit_Node) then Error_Msg ("(Ada 83) private units not allowed", Private_Sloc); end if; end if; -- If no serious error, then output possible unit information line -- for gnatchop if we are in syntax only, list units mode. if not Cunit_Error_Flag and then List_Units and then Operating_Mode = Check_Syntax then Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present); end if; -- And now we should be at the end of file if Token /= Tok_EOF then -- If we already had to scan for a compilation unit, then don't -- give any further error message, since it just seems to make -- things worse, and we already gave a serious error message. if Cunit_Error_Flag then null; -- If we are in check syntax mode, then we allow multiple units -- so we just return with Token not set to Tok_EOF and no message. elsif Operating_Mode = Check_Syntax then return Comp_Unit_Node; -- We also allow multiple units if we are in multiple unit mode elsif Multiple_Unit_Index /= 0 then -- Skip tokens to end of file, so that the -gnatl listing -- will be complete in this situation, but no need to parse -- the remaining units; no style checking either. declare Save_Style_Check : constant Boolean := Style_Check; begin Style_Check := False; while Token /= Tok_EOF loop Scan; end loop; Style_Check := Save_Style_Check; end; return Comp_Unit_Node; -- Otherwise we have an error. We suppress the error message -- if we already had a fatal error, since this stops junk -- cascaded messages in some situations. else if Fatal_Error (Current_Source_Unit) /= Error_Detected then if Token in Token_Class_Cunit then Error_Msg_SC ("end of file expected, " & "file can have only one compilation unit"); else Error_Msg_SC ("end of file expected"); end if; end if; end if; -- Skip tokens to end of file, so that the -gnatl listing -- will be complete in this situation, but no error checking -- other than that provided at the token level. while Token /= Tok_EOF loop Scan; end loop; return Error; -- Normal return (we were at the end of file as expected) else return Comp_Unit_Node; end if; exception -- An error resync is a serious bomb, so indicate result unit no good when Error_Resync => Set_Fatal_Error (Current_Source_Unit, Error_Detected); return Error; end P_Compilation_Unit; -------------------------- -- 10.1.1 Library Item -- -------------------------- -- Parsed by P_Compilation_Unit (10.1.1) -------------------------------------- -- 10.1.1 Library Unit Declaration -- -------------------------------------- -- Parsed by P_Compilation_Unit (10.1.1) ------------------------------------------------ -- 10.1.1 Library Unit Renaming Declaration -- ------------------------------------------------ -- Parsed by P_Compilation_Unit (10.1.1) ------------------------------- -- 10.1.1 Library Unit Body -- ------------------------------- -- Parsed by P_Compilation_Unit (10.1.1) ------------------------------ -- 10.1.1 Parent Unit Name -- ------------------------------ -- Parsed (as a name) by its parent construct ---------------------------- -- 10.1.2 Context Clause -- ---------------------------- -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE -- WITH_CLAUSE ::= -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; -- Note: the two qualifiers are Ada 2005 extensions. -- WITH_TYPE_CLAUSE ::= -- with type type_NAME is access; | with type type_NAME is tagged; -- Note: this form is obsolete (old GNAT extension). -- Error recovery: Cannot raise Error_Resync function P_Context_Clause return List_Id is Item_List : List_Id; Has_Limited : Boolean := False; Has_Private : Boolean := False; Scan_State : Saved_Scan_State; With_Node : Node_Id; First_Flag : Boolean; begin Item_List := New_List; -- Get keyword casing from WITH keyword in case not set yet if Token = Tok_With then Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); end if; -- Loop through context items loop if Style_Check then Style.Check_Indentation; end if; -- Gather any pragmas appearing in the context clause P_Pragmas_Opt (Item_List); -- Processing for WITH clause -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, -- PRIVATE WITH, or both. if Token = Tok_Limited then Has_Limited := True; Has_Private := False; Scan; -- past LIMITED -- In the context, LIMITED can only appear in a with_clause if Token = Tok_Private then Has_Private := True; Scan; -- past PRIVATE end if; if Token /= Tok_With then Error_Msg_SC -- CODEFIX ("unexpected LIMITED ignored"); end if; if Ada_Version < Ada_2005 then Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; elsif Token = Tok_Private then Has_Limited := False; Has_Private := True; Save_Scan_State (Scan_State); Scan; -- past PRIVATE if Token /= Tok_With then -- Keyword is beginning of private child unit Restore_Scan_State (Scan_State); -- to PRIVATE return Item_List; elsif Ada_Version < Ada_2005 then Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; else Has_Limited := False; Has_Private := False; end if; if Token = Tok_With then Scan; -- past WITH if Token = Tok_Type then -- WITH TYPE is an obsolete GNAT specific extension Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); Scan; -- past TYPE T_Is; if Token = Tok_Tagged then Scan; elsif Token = Tok_Access then Scan; else Error_Msg_SC ("expect tagged or access qualifier"); end if; TF_Semicolon; else First_Flag := True; -- Loop through names in one with clause, generating a separate -- N_With_Clause node for each name encountered. loop With_Node := New_Node (N_With_Clause, Token_Ptr); Append (With_Node, Item_List); -- Note that we allow with'ing of child units, even in -- Ada 83 mode, since presumably if this is not desired, -- then the compilation of the child unit itself is the -- place where such an "error" should be caught. Set_Name (With_Node, P_Qualified_Simple_Name); if Name (With_Node) = Error then Remove (With_Node); end if; Set_First_Name (With_Node, First_Flag); Set_Limited_Present (With_Node, Has_Limited); Set_Private_Present (With_Node, Has_Private); First_Flag := False; -- All done if no comma exit when Token /= Tok_Comma; -- If comma is followed by compilation unit token -- or by USE, or PRAGMA, then it should have been a -- semicolon after all Save_Scan_State (Scan_State); Scan; -- past comma if Token in Token_Class_Cunit or else Token = Tok_Use or else Token = Tok_Pragma then Restore_Scan_State (Scan_State); exit; end if; end loop; Set_Last_Name (With_Node, True); TF_Semicolon; end if; -- Processing for USE clause elsif Token = Tok_Use then P_Use_Clause (Item_List); -- Anything else is end of context clause else exit; end if; end loop; return Item_List; end P_Context_Clause; -------------------------- -- 10.1.2 Context Item -- -------------------------- -- Parsed by P_Context_Clause (10.1.2) ------------------------- -- 10.1.2 With Clause -- ------------------------- -- Parsed by P_Context_Clause (10.1.2) ----------------------- -- 10.1.3 Body Stub -- ----------------------- -- Subprogram stub parsed by P_Subprogram (6.1) -- Package stub parsed by P_Package (7.1) -- Task stub parsed by P_Task (9.1) -- Protected stub parsed by P_Protected (9.4) ---------------------------------- -- 10.1.3 Subprogram Body Stub -- ---------------------------------- -- Parsed by P_Subprogram (6.1) ------------------------------- -- 10.1.3 Package Body Stub -- ------------------------------- -- Parsed by P_Package (7.1) ---------------------------- -- 10.1.3 Task Body Stub -- ---------------------------- -- Parsed by P_Task (9.1) --------------------------------- -- 10.1.3 Protected Body Stub -- --------------------------------- -- Parsed by P_Protected (9.4) --------------------- -- 10.1.3 Subunit -- --------------------- -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY -- PARENT_UNIT_NAME ::= NAME -- The caller has checked that the initial token is SEPARATE -- Error recovery: cannot raise Error_Resync function P_Subunit return Node_Id is Subunit_Node : Node_Id; Body_Node : Node_Id; begin Subunit_Node := New_Node (N_Subunit, Token_Ptr); Body_Node := Error; -- in case no good body found Scan; -- past SEPARATE; U_Left_Paren; Set_Name (Subunit_Node, P_Qualified_Simple_Name); U_Right_Paren; Ignore (Tok_Semicolon); if Token = Tok_Function or else Token = Tok_Not or else Token = Tok_Overriding or else Token = Tok_Procedure then Body_Node := P_Subprogram (Pf_Pbod_Pexp); elsif Token = Tok_Package then Body_Node := P_Package (Pf_Pbod_Pexp); elsif Token = Tok_Protected then Scan; -- past PROTECTED if Token = Tok_Body then Body_Node := P_Protected; else Error_Msg_AP ("BODY expected"); return Error; end if; elsif Token = Tok_Task then Scan; -- past TASK if Token = Tok_Body then Body_Node := P_Task; else Error_Msg_AP ("BODY expected"); return Error; end if; else Error_Msg_SC ("proper body expected"); return Error; end if; Set_Proper_Body (Subunit_Node, Body_Node); return Subunit_Node; end P_Subunit; ------------------ -- Set_Location -- ------------------ function Set_Location return Source_Ptr is Physical : Boolean; Loc : Source_Ptr; Scan_State : Saved_Scan_State; begin -- A special check. If the first token is pragma, and this is a -- Source_Reference pragma, then do NOT eat previous comments, since -- the Source_Reference pragma is required to be the first line in -- the source file. if Token = Tok_Pragma then Save_Scan_State (Scan_State); Scan; -- past Pragma if Token = Tok_Identifier and then Token_Name = Name_Source_Reference then Restore_Scan_State (Scan_State); return Token_Ptr; end if; Restore_Scan_State (Scan_State); end if; -- Otherwise acquire previous comments and blank lines if Prev_Token = No_Token then return Source_First (Current_Source_File); else Loc := Prev_Token_Ptr; loop exit when Loc = Token_Ptr; -- Should we worry about UTF_32 line terminators here if Source (Loc) in Line_Terminator then Skip_Line_Terminators (Loc, Physical); exit when Physical; end if; Loc := Loc + 1; end loop; return Loc; end if; end Set_Location; ------------------ -- Unit_Display -- ------------------ -- The format of the generated line, as expected by GNATCHOP is -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file} -- where -- {unit} unit name with terminating (spec) or (body) -- {line} starting line number -- {offs} offset to start of text in file -- {file} source file name -- The SR parameter is present only if a source reference pragma was -- scanned for this unit. The significance is that gnatchop should not -- attempt to add another one. procedure Unit_Display (Cunit : Node_Id; Loc : Source_Ptr; SR_Present : Boolean) is Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit); Sind : constant Source_File_Index := Source_Index (Unum); Unam : constant Unit_Name_Type := Unit_Name (Unum); begin if List_Units then Write_Str ("Unit "); Write_Unit_Name (Unit_Name (Unum)); Unit_Location (Sind, Loc); if SR_Present then Write_Str (", SR"); end if; Write_Str (", file name "); Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit)); Write_Eol; end if; end Unit_Display; ------------------- -- Unit_Location -- ------------------- procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc); -- Should the above be the physical line number ??? begin Write_Str (" line "); Write_Int (Int (Line)); Write_Str (", file offset "); Write_Int (Int (Loc) - Int (Source_First (Sind))); end Unit_Location; end Ch10;