diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/par-ch10.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/par-ch10.adb | 1183 |
1 files changed, 0 insertions, 1183 deletions
diff --git a/gcc-4.2.1/gcc/ada/par-ch10.adb b/gcc-4.2.1/gcc/ada/par-ch10.adb deleted file mode 100644 index bedb67908..000000000 --- a/gcc-4.2.1/gcc/ada/par-ch10.adb +++ /dev/null @@ -1,1183 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P A R . C H 1 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- 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 the 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; - - 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 sytax 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 Token = Tok_Pragma then - Save_Scan_State (Scan_State); - Item := P_Pragma; - - if Item = Error - or else Chars (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 - or else Chars (Item) > Last_Configuration_Pragma_Name - 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 - Error_Msg_SC ("?file contains no compilation units"); - 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 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 ("keyword BODY expected here [see file name]"); - Restore_Scan_State (Scan_State); - Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod)); - else - Restore_Scan_State (Scan_State); - Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam)); - 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)); - - -- 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 (""";"" 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 (Unit_Node) = N_Subprogram_Body_Stub - or else Nkind (Unit_Node) = 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 (Unit_Node) = N_Package_Declaration - or else Nkind (Unit_Node) = N_Subprogram_Declaration - or else Nkind (Unit_Node) = N_Subprogram_Body - or else Nkind (Unit_Node) = 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 (Unit_Node) = N_Task_Body - or else Nkind (Unit_Node) = N_Protected_Body - or else Nkind (Unit_Node) = N_Task_Type_Declaration - or else Nkind (Unit_Node) = N_Protected_Type_Declaration - or else Nkind (Unit_Node) = N_Single_Task_Declaration - or else Nkind (Unit_Node) = N_Single_Protected_Declaration - then - Name_Node := Defining_Identifier (Unit_Node); - - elsif Nkind (Unit_Node) = N_Function_Instantiation - or else Nkind (Unit_Node) = N_Function_Specification - or else Nkind (Unit_Node) = N_Generic_Function_Renaming_Declaration - or else Nkind (Unit_Node) = N_Generic_Package_Renaming_Declaration - or else Nkind (Unit_Node) = N_Generic_Procedure_Renaming_Declaration - or else Nkind (Unit_Node) = N_Package_Body - or else Nkind (Unit_Node) = N_Package_Instantiation - or else Nkind (Unit_Node) = N_Package_Renaming_Declaration - or else Nkind (Unit_Node) = N_Package_Specification - or else Nkind (Unit_Node) = N_Procedure_Instantiation - or else Nkind (Unit_Node) = N_Procedure_Specification - then - Name_Node := Defining_Unit_Name (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 since 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 - (Token_Name in - First_Pragma_Name .. Last_Configuration_Pragma_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 sems 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 ("unexpected LIMITED ignored"); - end if; - - if Ada_Version < Ada_05 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_05 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 GNAT specific extension - - if not Extensions_Allowed then - Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension"); - Error_Msg_SP ("\unit must be compiled with -gnatX switch"); - end if; - - Scan; -- past TYPE - With_Node := New_Node (N_With_Type_Clause, Token_Ptr); - Append (With_Node, Item_List); - Set_Name (With_Node, P_Qualified_Simple_Name); - - T_Is; - - if Token = Tok_Tagged then - Set_Tagged_Present (With_Node); - 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 nam 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); - 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; - - T_Left_Paren; - Set_Name (Subunit_Node, P_Qualified_Simple_Name); - T_Right_Paren; - - if Token = Tok_Semicolon then - Error_Msg_SC ("unexpected semicolon ignored"); - Scan; - end if; - - if Token = Tok_Function or else Token = Tok_Procedure then - Body_Node := P_Subprogram (Pf_Pbod); - - elsif Token = Tok_Package then - Body_Node := P_Package (Pf_Pbod); - - 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; |