diff options
Diffstat (limited to 'gcc-4.8.1/gcc/ada/par-ch10.adb')
| -rw-r--r-- | gcc-4.8.1/gcc/ada/par-ch10.adb | 1207 |
1 files changed, 1207 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/par-ch10.adb b/gcc-4.8.1/gcc/ada/par-ch10.adb new file mode 100644 index 000000000..ddd88b3ee --- /dev/null +++ b/gcc-4.8.1/gcc/ada/par-ch10.adb @@ -0,0 +1,1207 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, 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 (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 (Item) = Name_No_Body then + No_Body := True; + end if; + + if Item = Error + or else not Is_Configuration_Pragma_Name (Pragma_Name (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; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Sloc := SIS_Sloc; + Scope.Table (Scope.Last).Ecol := SIS_Ecol; + Scope.Table (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); + 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 not Fatal_Error (Current_Source_Unit) 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); + 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 + Append (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; |