diff options
| author | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:23:52 +0000 |
|---|---|---|
| committer | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:23:52 +0000 |
| commit | 49d882a7d8c985758c04737e801f6028d5b7240f (patch) | |
| tree | 0509e847916fc00cfe5c311617e039600afa9622 | |
| parent | 83cce46b47d48de4c71b02a20f5bf36296a48568 (diff) | |
| download | gcc-49d882a7d8c985758c04737e801f6028d5b7240f.tar.gz | |
New Language: Ada
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45956 138bc75d-0d04-0410-961f-82ee72b054a4
57 files changed, 38371 insertions, 0 deletions
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb new file mode 100644 index 00000000000..a4fa121ed16 --- /dev/null +++ b/gcc/ada/par-ch10.adb @@ -0,0 +1,1080 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 0 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.115 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Hostparm; use Hostparm; +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 + Error_Msg_SC ("compilation unit expected"); + Cunit_Error_Flag := True; + Resync_Cunit; + + -- 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. + + -- However, we do not do this check if we are operating in syntax + -- checking only mode, because in that case there may be multiple + -- units in the same file, and the file name is not a reliable guide. + + Save_Scan_State (Scan_State); + Scan; -- past Package keyword + + if Token /= Tok_Body + and then Operating_Mode /= Check_Syntax + 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_Procedure + or else Token = Tok_Function + 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)) /= N_Function_Instantiation + and then Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation + 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_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); + else + Name_Node := Defining_Unit_Name (Unit_Node); + 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_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; + + -- 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 ::= + -- with library_unit_NAME {,library_unit_NAME}; + + -- WITH_TYPE_CLAUSE ::= + -- with type type_NAME is access; | with type type_NAME is tagged; + + -- Error recovery: Cannot raise Error_Resync + + function P_Context_Clause return List_Id is + Item_List : List_Id; + 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 + + if Token = Tok_With then + Scan; -- past WITH + + if Token = Tok_Type then + + -- WITH TYPE is an extension + + if not Extensions_Allowed then + Error_Msg_SP ("`WITH TYPE` is a non-standard extension"); + + if OpenVMS then + Error_Msg_SP + ("\unit must be compiled with " & + "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier"); + else + Error_Msg_SP + ("\unit must be compiled with -gnatX switch"); + end if; + 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); + First_Flag := False; + exit when Token /= Tok_Comma; + Scan; -- past comma + 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; + + 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; diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb new file mode 100644 index 00000000000..8b59c54ea13 --- /dev/null +++ b/gcc/ada/par-ch11.adb @@ -0,0 +1,246 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.22 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) +package body Ch11 is + + -- Local functions, used only in this chapter + + function P_Exception_Handler return Node_Id; + function P_Exception_Choice return Node_Id; + + --------------------------------- + -- 11.1 Exception Declaration -- + --------------------------------- + + -- Parsed by P_Identifier_Declaration (3.3.1) + + ------------------------------------------ + -- 11.2 Handled Sequence Of Statements -- + ------------------------------------------ + + -- HANDLED_SEQUENCE_OF_STATEMENTS ::= + -- SEQUENCE_OF_STATEMENTS + -- [exception + -- EXCEPTION_HANDLER + -- {EXCEPTION_HANDLER}] + + -- Error_Recovery : Cannot raise Error_Resync + + function P_Handled_Sequence_Of_Statements return Node_Id is + Handled_Stmt_Seq_Node : Node_Id; + + begin + Handled_Stmt_Seq_Node := + New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr); + Set_Statements + (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq)); + + if Token = Tok_Exception then + Scan; -- past EXCEPTION + Set_Exception_Handlers + (Handled_Stmt_Seq_Node, Parse_Exception_Handlers); + end if; + + return Handled_Stmt_Seq_Node; + end P_Handled_Sequence_Of_Statements; + + ----------------------------- + -- 11.2 Exception Handler -- + ----------------------------- + + -- EXCEPTION_HANDLER ::= + -- when [CHOICE_PARAMETER_SPECIFICATION :] + -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} => + -- SEQUENCE_OF_STATEMENTS + + -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER + + -- Error recovery: cannot raise Error_Resync + + function P_Exception_Handler return Node_Id is + Scan_State : Saved_Scan_State; + Handler_Node : Node_Id; + Choice_Param_Node : Node_Id; + + begin + Handler_Node := New_Node (N_Exception_Handler, Token_Ptr); + T_When; + + -- Test for possible choice parameter present + + if Token = Tok_Identifier then + Choice_Param_Node := Token_Node; + Save_Scan_State (Scan_State); -- at identifier + Scan; -- past identifier + + if Token = Tok_Colon then + if Ada_83 then + Error_Msg_SP ("(Ada 83) choice parameter not allowed!"); + end if; + + Scan; -- past : + Change_Identifier_To_Defining_Identifier (Choice_Param_Node); + Set_Choice_Parameter (Handler_Node, Choice_Param_Node); + + elsif Token = Tok_Others then + Error_Msg_AP ("missing "":"""); + Change_Identifier_To_Defining_Identifier (Choice_Param_Node); + Set_Choice_Parameter (Handler_Node, Choice_Param_Node); + + else + Restore_Scan_State (Scan_State); -- to identifier + end if; + end if; + + -- Loop through exception choices + + Set_Exception_Choices (Handler_Node, New_List); + + loop + Append (P_Exception_Choice, Exception_Choices (Handler_Node)); + exit when Token /= Tok_Vertical_Bar; + Scan; -- past vertical bar + end loop; + + TF_Arrow; + Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); + return Handler_Node; + end P_Exception_Handler; + + ------------------------------------------ + -- 11.2 Choice Parameter Specification -- + ------------------------------------------ + + -- Parsed by P_Exception_Handler (11.2) + + ---------------------------- + -- 11.2 Exception Choice -- + ---------------------------- + + -- EXCEPTION_CHOICE ::= exception_NAME | others + + -- Error recovery: cannot raise Error_Resync. If an error occurs, then the + -- scan pointer is advanced to the next arrow or vertical bar or semicolon. + + function P_Exception_Choice return Node_Id is + begin + + if Token = Tok_Others then + Scan; -- past OTHERS + return New_Node (N_Others_Choice, Prev_Token_Ptr); + + else + return P_Name; -- exception name + end if; + + exception + when Error_Resync => + Resync_Choice; + return Error; + end P_Exception_Choice; + + --------------------------- + -- 11.3 Raise Statement -- + --------------------------- + + -- RAISE_STATEMENT ::= raise [exception_NAME]; + + -- The caller has verified that the initial token is RAISE + + -- Error recovery: can raise Error_Resync + + function P_Raise_Statement return Node_Id is + Raise_Node : Node_Id; + + begin + Raise_Node := New_Node (N_Raise_Statement, Token_Ptr); + Scan; -- past RAISE + + if Token /= Tok_Semicolon then + Set_Name (Raise_Node, P_Name); + end if; + + TF_Semicolon; + return Raise_Node; + end P_Raise_Statement; + + ------------------------------ + -- Parse_Exception_Handlers -- + ------------------------------ + + -- This routine scans out a list of exception handlers appearing in a + -- construct as: + + -- exception + -- EXCEPTION_HANDLER {EXCEPTION_HANDLER} + + -- The caller has scanned out the EXCEPTION keyword + + -- Control returns after scanning the last exception handler, presumably + -- at the keyword END, but this is not checked in this routine. + + -- Error recovery: cannot raise Error_Resync + + function Parse_Exception_Handlers return List_Id is + Handler : Node_Id; + Handlers_List : List_Id; + Pragmas_List : List_Id; + + begin + Handlers_List := New_List; + P_Pragmas_Opt (Handlers_List); + + if Token = Tok_End then + Error_Msg_SC ("must have at least one exception handler!"); + + else + loop + Handler := P_Exception_Handler; + Pragmas_List := No_List; + Append (Handler, Handlers_List); + + -- Note: no need to check for pragmas here. Although the + -- syntax officially allows them in this position, they + -- will have been swallowed up as part of the statement + -- sequence of the handler we just scanned out. + + exit when Token /= Tok_When; + end loop; + end if; + + return Handlers_List; + end Parse_Exception_Handlers; + +end Ch11; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb new file mode 100644 index 00000000000..139243e67e2 --- /dev/null +++ b/gcc/ada/par-ch12.adb @@ -0,0 +1,882 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.46 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch12 is + + -- Local functions, used only in this chapter + + function P_Formal_Derived_Type_Definition return Node_Id; + function P_Formal_Discrete_Type_Definition return Node_Id; + function P_Formal_Fixed_Point_Definition return Node_Id; + function P_Formal_Floating_Point_Definition return Node_Id; + function P_Formal_Modular_Type_Definition return Node_Id; + function P_Formal_Package_Declaration return Node_Id; + function P_Formal_Private_Type_Definition return Node_Id; + function P_Formal_Signed_Integer_Type_Definition return Node_Id; + function P_Formal_Subprogram_Declaration return Node_Id; + function P_Formal_Type_Declaration return Node_Id; + function P_Formal_Type_Definition return Node_Id; + function P_Generic_Association return Node_Id; + + procedure P_Formal_Object_Declarations (Decls : List_Id); + -- Scans one or more formal object declarations and appends them to + -- Decls. Scans more than one declaration only in the case where the + -- source has a declaration with multiple defining identifiers. + + -------------------------------- + -- 12.1 Generic (also 8.5.5) -- + -------------------------------- + + -- This routine parses either one of the forms of a generic declaration + -- or a generic renaming declaration. + + -- GENERIC_DECLARATION ::= + -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION + + -- GENERIC_SUBPROGRAM_DECLARATION ::= + -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; + + -- GENERIC_PACKAGE_DECLARATION ::= + -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; + + -- GENERIC_FORMAL_PART ::= + -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} + + -- GENERIC_RENAMING_DECLARATION ::= + -- generic package DEFINING_PROGRAM_UNIT_NAME + -- renames generic_package_NAME + -- | generic procedure DEFINING_PROGRAM_UNIT_NAME + -- renames generic_procedure_NAME + -- | generic function DEFINING_PROGRAM_UNIT_NAME + -- renames generic_function_NAME + + -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= + -- FORMAL_OBJECT_DECLARATION + -- | FORMAL_TYPE_DECLARATION + -- | FORMAL_SUBPROGRAM_DECLARATION + -- | FORMAL_PACKAGE_DECLARATION + + -- The caller has checked that the initial token is GENERIC + + -- Error recovery: can raise Error_Resync + + function P_Generic return Node_Id is + Gen_Sloc : constant Source_Ptr := Token_Ptr; + Gen_Decl : Node_Id; + Decl_Node : Node_Id; + Decls : List_Id; + Def_Unit : Node_Id; + Ren_Token : Token_Type; + Scan_State : Saved_Scan_State; + + begin + Scan; -- past GENERIC + + if Token = Tok_Private then + Error_Msg_SC ("PRIVATE goes before GENERIC, not after"); + Scan; -- past junk PRIVATE token + end if; + + Save_Scan_State (Scan_State); -- at token past GENERIC + + -- Check for generic renaming declaration case + + if Token = Tok_Package + or else Token = Tok_Function + or else Token = Tok_Procedure + then + Ren_Token := Token; + Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE + + if Token = Tok_Identifier then + Def_Unit := P_Defining_Program_Unit_Name; + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if Ren_Token = Tok_Package then + Decl_Node := New_Node + (N_Generic_Package_Renaming_Declaration, Gen_Sloc); + + elsif Ren_Token = Tok_Procedure then + Decl_Node := New_Node + (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc); + + else -- Ren_Token = Tok_Function then + Decl_Node := New_Node + (N_Generic_Function_Renaming_Declaration, Gen_Sloc); + end if; + + Scan; -- past RENAMES + Set_Defining_Unit_Name (Decl_Node, Def_Unit); + Set_Name (Decl_Node, P_Name); + TF_Semicolon; + return Decl_Node; + end if; + end if; + end if; + + -- Fall through if this is *not* a generic renaming declaration + + Restore_Scan_State (Scan_State); + Decls := New_List; + + -- Loop through generic parameter declarations and use clauses + + Decl_Loop : loop + P_Pragmas_Opt (Decls); + Ignore (Tok_Private); + + if Token = Tok_Use then + Append (P_Use_Clause, Decls); + else + -- Parse a generic parameter declaration + + if Token = Tok_Identifier then + P_Formal_Object_Declarations (Decls); + + elsif Token = Tok_Type then + Append (P_Formal_Type_Declaration, Decls); + + elsif Token = Tok_With then + Scan; -- past WITH + + if Token = Tok_Package then + Append (P_Formal_Package_Declaration, Decls); + + elsif Token = Tok_Procedure or Token = Tok_Function then + Append (P_Formal_Subprogram_Declaration, Decls); + + else + Error_Msg_BC + ("FUNCTION, PROCEDURE or PACKAGE expected here"); + Resync_Past_Semicolon; + end if; + + elsif Token = Tok_Subtype then + Error_Msg_SC ("subtype declaration not allowed " & + "as generic parameter declaration!"); + Resync_Past_Semicolon; + + else + exit Decl_Loop; + end if; + end if; + + end loop Decl_Loop; + + -- Generic formal part is scanned, scan out subprogram or package spec + + if Token = Tok_Package then + Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); + Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); + else + Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); + Set_Specification (Gen_Decl, P_Subprogram_Specification); + TF_Semicolon; + end if; + + Set_Generic_Formal_Declarations (Gen_Decl, Decls); + return Gen_Decl; + end P_Generic; + + ------------------------------- + -- 12.1 Generic Declaration -- + ------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------------------ + -- 12.1 Generic Subprogram Declaration -- + ------------------------------------------ + + -- Parsed by P_Generic (12.1) + + --------------------------------------- + -- 12.1 Generic Package Declaration -- + --------------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------- + -- 12.1 Generic Formal Part -- + ------------------------------- + + -- Parsed by P_Generic (12.1) + + ------------------------------------------------- + -- 12.1 Generic Formal Parameter Declaration -- + ------------------------------------------------- + + -- Parsed by P_Generic (12.1) + + --------------------------------- + -- 12.3 Generic Instantiation -- + --------------------------------- + + -- Generic package instantiation parsed by P_Package (7.1) + -- Generic procedure instantiation parsed by P_Subprogram (6.1) + -- Generic function instantiation parsed by P_Subprogram (6.1) + + ------------------------------- + -- 12.3 Generic Actual Part -- + ------------------------------- + + -- GENERIC_ACTUAL_PART ::= + -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) + + -- Returns a list of generic associations, or Empty if none are present + + -- Error recovery: cannot raise Error_Resync + + function P_Generic_Actual_Part_Opt return List_Id is + Association_List : List_Id; + + begin + -- Figure out if a generic actual part operation is present. Clearly + -- there is no generic actual part if the current token is semicolon + + if Token = Tok_Semicolon then + return No_List; + + -- If we don't have a left paren, then we have an error, and the job + -- is to figure out whether a left paren or semicolon was intended. + -- We assume a missing left paren (and hence a generic actual part + -- present) if the current token is not on a new line, or if it is + -- indented from the subprogram token. Otherwise assume missing + -- semicolon (which will be diagnosed by caller) and no generic part + + elsif Token /= Tok_Left_Paren + and then Token_Is_At_Start_Of_Line + and then Start_Column <= Scope.Table (Scope.Last).Ecol + then + return No_List; + + -- Otherwise we have a generic actual part (either a left paren is + -- present, or we have decided that there must be a missing left paren) + + else + Association_List := New_List; + T_Left_Paren; + + loop + Append (P_Generic_Association, Association_List); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + return Association_List; + end if; + + end P_Generic_Actual_Part_Opt; + + ------------------------------- + -- 12.3 Generic Association -- + ------------------------------- + + -- GENERIC_ASSOCIATION ::= + -- [generic_formal_parameter_SELECTOR_NAME =>] + -- EXPLICIT_GENERIC_ACTUAL_PARAMETER + + -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= + -- EXPRESSION | variable_NAME | subprogram_NAME + -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME + + -- Error recovery: cannot raise Error_Resync + + function P_Generic_Association return Node_Id is + Scan_State : Saved_Scan_State; + Param_Name_Node : Node_Id; + Generic_Assoc_Node : Node_Id; + + begin + Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); + + if Token in Token_Class_Desig then + Param_Name_Node := Token_Node; + Save_Scan_State (Scan_State); -- at designator + Scan; -- past simple name or operator symbol + + if Token = Tok_Arrow then + Scan; -- past arrow + Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node); + else + Restore_Scan_State (Scan_State); -- to designator + end if; + end if; + + Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, P_Expression); + return Generic_Assoc_Node; + end P_Generic_Association; + + --------------------------------------------- + -- 12.3 Explicit Generic Actual Parameter -- + --------------------------------------------- + + -- Parsed by P_Generic_Association (12.3) + + -------------------------------------- + -- 12.4 Formal Object Declarations -- + -------------------------------------- + + -- FORMAL_OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : + -- MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; + + -- The caller has checked that the initial token is an identifier + + -- Error recovery: cannot raise Error_Resync + + procedure P_Formal_Object_Declarations (Decls : List_Id) is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr); + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + P_Mode (Decl_Node); + Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync); + No_Constraint; + Set_Expression (Decl_Node, Init_Expr_Opt); + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + Append (Decl_Node, Decls); + + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_Loop; + + TF_Semicolon; + end P_Formal_Object_Declarations; + + ----------------------------------- + -- 12.5 Formal Type Declaration -- + ----------------------------------- + + -- FORMAL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is FORMAL_TYPE_DEFINITION; + + -- The caller has checked that the initial token is TYPE + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Type_Declaration return Node_Id is + Decl_Node : Node_Id; + + begin + Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr); + Scan; -- past TYPE + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); + + if P_Unknown_Discriminant_Part_Opt then + Set_Unknown_Discriminants_Present (Decl_Node, True); + else + Set_Discriminant_Specifications + (Decl_Node, P_Known_Discriminant_Part_Opt); + end if; + + T_Is; + + Set_Formal_Type_Definition (Decl_Node, P_Formal_Type_Definition); + TF_Semicolon; + return Decl_Node; + end P_Formal_Type_Declaration; + + ---------------------------------- + -- 12.5 Formal Type Definition -- + ---------------------------------- + + -- FORMAL_TYPE_DEFINITION ::= + -- FORMAL_PRIVATE_TYPE_DEFINITION + -- | FORMAL_DERIVED_TYPE_DEFINITION + -- | FORMAL_DISCRETE_TYPE_DEFINITION + -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION + -- | FORMAL_MODULAR_TYPE_DEFINITION + -- | FORMAL_FLOATING_POINT_DEFINITION + -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION + -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION + -- | FORMAL_ARRAY_TYPE_DEFINITION + -- | FORMAL_ACCESS_TYPE_DEFINITION + + -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION + + -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION + + function P_Formal_Type_Definition return Node_Id is + Scan_State : Saved_Scan_State; + + begin + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Tagged); + end if; + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + end if; + + case Token is + + -- Mostly we can tell what we have from the initial token. The one + -- exception is ABSTRACT, where we have to scan ahead to see if we + -- have a formal derived type or a formal private type definition. + + when Tok_Abstract => + Save_Scan_State (Scan_State); + Scan; -- past ABSTRACT + + if Token = Tok_New then + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Derived_Type_Definition; + + else + Restore_Scan_State (Scan_State); -- to ABSTRACT + return P_Formal_Private_Type_Definition; + end if; + + when Tok_Private | Tok_Limited | Tok_Tagged => + return P_Formal_Private_Type_Definition; + + when Tok_New => + return P_Formal_Derived_Type_Definition; + + when Tok_Left_Paren => + return P_Formal_Discrete_Type_Definition; + + when Tok_Range => + return P_Formal_Signed_Integer_Type_Definition; + + when Tok_Mod => + return P_Formal_Modular_Type_Definition; + + when Tok_Digits => + return P_Formal_Floating_Point_Definition; + + when Tok_Delta => + return P_Formal_Fixed_Point_Definition; + + when Tok_Array => + return P_Array_Type_Definition; + + when Tok_Access => + return P_Access_Type_Definition; + + when Tok_Record => + Error_Msg_SC ("record not allowed in generic type definition!"); + Discard_Junk_Node (P_Record_Definition); + return Error; + + when others => + Error_Msg_BC ("expecting generic type definition here"); + Resync_Past_Semicolon; + return Error; + + end case; + end P_Formal_Type_Definition; + + -------------------------------------------- + -- 12.5.1 Formal Private Type Definition -- + -------------------------------------------- + + -- FORMAL_PRIVATE_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] private + + -- The caller has checked the initial token is PRIVATE, ABSTRACT, + -- TAGGED or LIMITED + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Private_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr); + + if Token = Tok_Abstract then + Scan; -- past ABSTRACT + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + end if; + + if Token /= Tok_Tagged then + Error_Msg_SP ("ABSTRACT must be followed by TAGGED"); + else + Set_Abstract_Present (Def_Node, True); + end if; + end if; + + if Token = Tok_Tagged then + Set_Tagged_Present (Def_Node, True); + Scan; -- past TAGGED + end if; + + if Token = Tok_Limited then + Set_Limited_Present (Def_Node, True); + Scan; -- past LIMITED + end if; + + Set_Sloc (Def_Node, Token_Ptr); + T_Private; + return Def_Node; + end P_Formal_Private_Type_Definition; + + -------------------------------------------- + -- 12.5.1 Formal Derived Type Definition -- + -------------------------------------------- + + -- FORMAL_DERIVED_TYPE_DEFINITION ::= + -- [abstract] new SUBTYPE_MARK [with private] + + -- The caller has checked the initial token(s) is/are NEW or ASTRACT NEW + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Derived_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr); + + if Token = Tok_Abstract then + Set_Abstract_Present (Def_Node); + Scan; -- past ABSTRACT + end if; + + Scan; -- past NEW; + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); + No_Constraint; + + if Token = Tok_With then + Scan; -- past WITH + Set_Private_Present (Def_Node, True); + T_Private; + end if; + + return Def_Node; + end P_Formal_Derived_Type_Definition; + + --------------------------------------------- + -- 12.5.2 Formal Discrete Type Definition -- + --------------------------------------------- + + -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) + + -- The caller has checked the initial token is left paren + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Discrete_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr); + Scan; -- past left paren + T_Box; + T_Right_Paren; + return Def_Node; + end P_Formal_Discrete_Type_Definition; + + --------------------------------------------------- + -- 12.5.2 Formal Signed Integer Type Definition -- + --------------------------------------------------- + + -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> + + -- The caller has checked the initial token is RANGE + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Signed_Integer_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr); + Scan; -- past RANGE + T_Box; + return Def_Node; + end P_Formal_Signed_Integer_Type_Definition; + + -------------------------------------------- + -- 12.5.2 Formal Modular Type Definition -- + -------------------------------------------- + + -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> + + -- The caller has checked the initial token is MOD + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Modular_Type_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Modular_Type_Definition, Token_Ptr); + Scan; -- past MOD + T_Box; + return Def_Node; + end P_Formal_Modular_Type_Definition; + + ---------------------------------------------- + -- 12.5.2 Formal Floating Point Definition -- + ---------------------------------------------- + + -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> + + -- The caller has checked the initial token is DIGITS + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Floating_Point_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := + New_Node (N_Formal_Floating_Point_Definition, Token_Ptr); + Scan; -- past DIGITS + T_Box; + return Def_Node; + end P_Formal_Floating_Point_Definition; + + ------------------------------------------- + -- 12.5.2 Formal Fixed Point Definition -- + ------------------------------------------- + + -- This routine parses either a formal ordinary fixed point definition + -- or a formal decimal fixed point definition: + + -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> + + -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> + + -- The caller has checked the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Fixed_Point_Definition return Node_Id is + Def_Node : Node_Id; + Delta_Sloc : Source_Ptr; + + begin + Delta_Sloc := Token_Ptr; + Scan; -- past DELTA + T_Box; + + if Token = Tok_Digits then + Def_Node := + New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc); + Scan; -- past DIGITS + T_Box; + else + Def_Node := + New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc); + end if; + + return Def_Node; + end P_Formal_Fixed_Point_Definition; + + ---------------------------------------------------- + -- 12.5.2 Formal Ordinary Fixed Point Definition -- + ---------------------------------------------------- + + -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) + + --------------------------------------------------- + -- 12.5.2 Formal Decimal Fixed Point Definition -- + --------------------------------------------------- + + -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) + + ------------------------------------------ + -- 12.5.3 Formal Array Type Definition -- + ------------------------------------------ + + -- Parsed by P_Formal_Type_Definition (12.5) + + ------------------------------------------- + -- 12.5.4 Formal Access Type Definition -- + ------------------------------------------- + + -- Parsed by P_Formal_Type_Definition (12.5) + + ----------------------------------------- + -- 12.6 Formal Subprogram Declaration -- + ----------------------------------------- + + -- FORMAL_SUBPROGRAM_DECLARATION ::= + -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; + + -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> + + -- DEFAULT_NAME ::= NAME + + -- The caller has checked that the initial tokens are WITH FUNCTION or + -- WITH PROCEDURE, and the initial WITH has been scanned out. + + -- Note: we separate this into two procedures because the name is allowed + -- to be an operator symbol for a function, but not for a procedure. + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Subprogram_Declaration return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Formal_Subprogram_Declaration, Prev_Token_Ptr); + Set_Specification (Def_Node, P_Subprogram_Specification); + + if Token = Tok_Is then + T_Is; -- past IS, skip extra IS or ";" + + if Token = Tok_Box then + Set_Box_Present (Def_Node, True); + Scan; -- past <> + + else + Set_Default_Name (Def_Node, P_Name); + end if; + + end if; + + T_Semicolon; + return Def_Node; + end P_Formal_Subprogram_Declaration; + + ------------------------------ + -- 12.6 Subprogram Default -- + ------------------------------ + + -- Parsed by P_Formal_Procedure_Declaration (12.6) + + ------------------------ + -- 12.6 Default Name -- + ------------------------ + + -- Parsed by P_Formal_Procedure_Declaration (12.6) + + -------------------------------------- + -- 12.7 Formal Package Declaration -- + -------------------------------------- + + -- FORMAL_PACKAGE_DECLARATION ::= + -- with package DEFINING_IDENTIFIER + -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; + + -- FORMAL_PACKAGE_ACTUAL_PART ::= + -- (<>) | [GENERIC_ACTUAL_PART] + + -- The caller has checked that the initial tokens are WITH PACKAGE, + -- and the initial WITH has been scanned out (so Token = Tok_Package). + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Package_Declaration return Node_Id is + Def_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr); + Scan; -- past PACKAGE + Set_Defining_Identifier (Def_Node, P_Defining_Identifier); + T_Is; + T_New; + Set_Name (Def_Node, P_Qualified_Simple_Name); + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at the left paren + Scan; -- past the left paren + + if Token = Tok_Box then + Set_Box_Present (Def_Node, True); + Scan; -- past box + T_Right_Paren; + + else + Restore_Scan_State (Scan_State); -- to the left paren + Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt); + end if; + end if; + + T_Semicolon; + return Def_Node; + end P_Formal_Package_Declaration; + + -------------------------------------- + -- 12.7 Formal Package Actual Part -- + -------------------------------------- + + -- Parsed by P_Formal_Package_Declaration (12.7) + +end Ch12; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb new file mode 100644 index 00000000000..03bd7bf1275 --- /dev/null +++ b/gcc/ada/par-ch13.adb @@ -0,0 +1,441 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 1 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.34 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch13 is + + -- Local functions, used only in this chapter + + function P_Component_Clause return Node_Id; + function P_Mod_Clause return Node_Id; + + -------------------------------------------- + -- 13.1 Representation Clause (also I.7) -- + -------------------------------------------- + + -- REPRESENTATION_CLAUSE ::= + -- ATTRIBUTE_DEFINITION_CLAUSE + -- | ENUMERATION_REPRESENTATION_CLAUSE + -- | RECORD_REPRESENTATION_CLAUSE + -- | AT_CLAUSE + + -- ATTRIBUTE_DEFINITION_CLAUSE ::= + -- for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION; + -- | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME; + + -- Note: in Ada 83, the expression must be a simple expression + + -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION; + + -- Note: in Ada 83, the expression must be a simple expression + + -- ENUMERATION_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE; + + -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE + + -- RECORD_REPRESENTATION_CLAUSE ::= + -- for first_subtype_LOCAL_NAME use + -- record [MOD_CLAUSE] + -- {COMPONENT_CLAUSE} + -- end record; + + -- Note: for now we allow only a direct name as the local name in the + -- above constructs. This probably needs changing later on ??? + + -- The caller has checked that the initial token is FOR + + -- Error recovery: cannot raise Error_Resync, if an error occurs, + -- the scan is repositioned past the next semicolon. + + function P_Representation_Clause return Node_Id is + For_Loc : Source_Ptr; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + Attr_Name : Name_Id; + Identifier_Node : Node_Id; + Rep_Clause_Node : Node_Id; + Expr_Node : Node_Id; + Record_Items : List_Id; + + begin + For_Loc := Token_Ptr; + Scan; -- past FOR + + -- Note that the name in a representation clause is always a simple + -- name, even in the attribute case, see AI-300 which made this so! + + Identifier_Node := P_Identifier; + + -- Check case of qualified name to give good error message + + if Token = Tok_Dot then + Error_Msg_SC + ("representation clause requires simple name!"); + + loop + exit when Token /= Tok_Dot; + Scan; -- past dot + Discard_Junk_Node (P_Identifier); + end loop; + end if; + + -- Attribute Definition Clause + + if Token = Tok_Apostrophe then + + -- Allow local names of the form a'b'.... This enables + -- us to parse class-wide streams attributes correctly. + + Name_Node := Identifier_Node; + while Token = Tok_Apostrophe loop + + Scan; -- past apostrophe + + Identifier_Node := Token_Node; + Attr_Name := No_Name; + + if Token = Tok_Identifier then + Attr_Name := Token_Name; + + if not Is_Attribute_Name (Attr_Name) then + Signal_Bad_Attribute; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Attr_Name := Name_Delta; + + elsif Token = Tok_Digits then + Attr_Name := Name_Digits; + + elsif Token = Tok_Access then + Attr_Name := Name_Access; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- We come here with an OK attribute scanned, and the + -- corresponding Attribute identifier node stored in Ident_Node. + + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Attribute_Name (Name_Node, Attr_Name); + Scan; + end loop; + + Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc); + Set_Name (Rep_Clause_Node, Prefix_Node); + Set_Chars (Rep_Clause_Node, Attr_Name); + T_Use; + + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Rep_Clause_Node, Expr_Node); + + else + TF_Use; + Rep_Clause_Node := Empty; + + -- AT follows USE (At Clause) + + if Token = Tok_At then + Scan; -- past AT + Rep_Clause_Node := New_Node (N_At_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Rep_Clause_Node, Expr_Node); + + -- RECORD follows USE (Record Representation Clause) + + elsif Token = Tok_Record then + Record_Items := P_Pragmas_Opt; + Rep_Clause_Node := + New_Node (N_Record_Representation_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Record; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past RECORD + Record_Items := P_Pragmas_Opt; + + -- Possible Mod Clause + + if Token = Tok_At then + Set_Mod_Clause (Rep_Clause_Node, P_Mod_Clause); + Set_Pragmas_Before (Mod_Clause (Rep_Clause_Node), Record_Items); + Record_Items := P_Pragmas_Opt; + end if; + + if No (Record_Items) then + Record_Items := New_List; + end if; + + Set_Component_Clauses (Rep_Clause_Node, Record_Items); + + -- Loop through component clauses + + loop + if Token not in Token_Class_Name then + exit when Check_End; + end if; + + Append (P_Component_Clause, Record_Items); + P_Pragmas_Opt (Record_Items); + end loop; + + -- Left paren follows USE (Enumeration Representation Clause) + + elsif Token = Tok_Left_Paren then + Rep_Clause_Node := + New_Node (N_Enumeration_Representation_Clause, For_Loc); + Set_Identifier (Rep_Clause_Node, Identifier_Node); + Set_Array_Aggregate (Rep_Clause_Node, P_Aggregate); + + -- Some other token follows FOR (invalid representation clause) + + else + Error_Msg_SC ("invalid representation clause"); + raise Error_Resync; + end if; + end if; + + TF_Semicolon; + return Rep_Clause_Node; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + + end P_Representation_Clause; + + ---------------------- + -- 13.1 Local Name -- + ---------------------- + + -- Local name is always parsed by its parent. In the case of its use in + -- pragmas, the check for a local name is handled in Par.Prag and allows + -- all the possible forms of local name. For the uses in chapter 13, we + -- currently only allow a direct name, but this should probably change??? + + --------------------------- + -- 13.1 At Clause (I.7) -- + --------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + --------------------------------------- + -- 13.3 Attribute Definition Clause -- + --------------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + --------------------------------------------- + -- 13.4 Enumeration Representation Clause -- + --------------------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + --------------------------------- + -- 13.4 Enumeration Aggregate -- + --------------------------------- + + -- Parsed by P_Representation_Clause (13.1) + + ------------------------------------------ + -- 13.5.1 Record Representation Clause -- + ------------------------------------------ + + -- Parsed by P_Representation_Clause (13.1) + + ------------------------------ + -- 13.5.1 Mod Clause (I.8) -- + ------------------------------ + + -- MOD_CLAUSE ::= at mod static_EXPRESSION; + + -- Note: in Ada 83, the expression must be a simple expression + + -- The caller has checked that the initial Token is AT + + -- Error recovery: cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before field + + function P_Mod_Clause return Node_Id is + Mod_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Mod_Node := New_Node (N_Mod_Clause, Token_Ptr); + Scan; -- past AT + T_Mod; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Expression (Mod_Node, Expr_Node); + TF_Semicolon; + return Mod_Node; + end P_Mod_Clause; + + ------------------------------ + -- 13.5.1 Component Clause -- + ------------------------------ + + -- COMPONENT_CLAUSE ::= + -- COMPONENT_CLAUSE_COMPONENT_NAME at POSITION + -- range FIRST_BIT .. LAST_BIT; + + -- COMPONENT_CLAUSE_COMPONENT_NAME ::= + -- component_DIRECT_NAME + -- | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR + + -- POSITION ::= static_EXPRESSION + + -- Note: in Ada 83, the expression must be a simple expression + + -- FIRST_BIT ::= static_SIMPLE_EXPRESSION + -- LAST_BIT ::= static_SIMPLE_EXPRESSION + + -- Note: the AARM V2.0 grammar has an error at this point, it uses + -- EXPRESSION instead of SIMPLE_EXPRESSION for FIRST_BIT and LAST_BIT + + -- Error recovery: cannot raise Error_Resync + + function P_Component_Clause return Node_Id is + Component_Node : Node_Id; + Comp_Name : Node_Id; + Expr_Node : Node_Id; + + begin + Component_Node := New_Node (N_Component_Clause, Token_Ptr); + Comp_Name := P_Name; + + if Nkind (Comp_Name) = N_Identifier + or else Nkind (Comp_Name) = N_Attribute_Reference + then + Set_Component_Name (Component_Node, Comp_Name); + else + Error_Msg_N + ("component name must be direct name or attribute", Comp_Name); + Set_Component_Name (Component_Node, Error); + end if; + + Set_Sloc (Component_Node, Token_Ptr); + T_At; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Position (Component_Node, Expr_Node); + T_Range; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_First_Bit (Component_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Last_Bit (Component_Node, Expr_Node); + TF_Semicolon; + return Component_Node; + end P_Component_Clause; + + ---------------------- + -- 13.5.1 Position -- + ---------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + ----------------------- + -- 13.5.1 First Bit -- + ----------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + ---------------------- + -- 13.5.1 Last Bit -- + ---------------------- + + -- Parsed by P_Component_Clause (13.5.1) + + -------------------------- + -- 13.8 Code Statement -- + -------------------------- + + -- CODE_STATEMENT ::= QUALIFIED_EXPRESSION + + -- On entry the caller has scanned the SUBTYPE_MARK (passed in as the + -- single argument, and the scan points to the apostrophe. + + -- Error recovery: can raise Error_Resync + + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id is + Node1 : Node_Id; + + begin + Scan; -- past apostrophe + + -- If left paren, then we have a possible code statement + + if Token = Tok_Left_Paren then + Node1 := New_Node (N_Code_Statement, Sloc (Subtype_Mark)); + Set_Expression (Node1, P_Qualified_Expression (Subtype_Mark)); + TF_Semicolon; + return Node1; + + -- Otherwise we have an illegal range attribute. Note that P_Name + -- ensures that Token = Tok_Range is the only possibility left here. + + else -- Token = Tok_Range + Error_Msg_SC ("RANGE attribute illegal here!"); + raise Error_Resync; + end if; + + end P_Code_Statement; + +end Ch13; diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb new file mode 100644 index 00000000000..0eeacead811 --- /dev/null +++ b/gcc/ada/par-ch2.adb @@ -0,0 +1,405 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.35 $ -- +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch2 is + + -- Local functions, used only in this chapter + + function P_Pragma_Argument_Association return Node_Id; + + --------------------- + -- 2.3 Identifier -- + --------------------- + + -- IDENTIFIER ::= LETTER {[UNDERLINE] LETTER_OR_DIGIT} + + -- LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT + + -- An IDENTIFIER shall not be a reserved word + + -- Error recovery: can raise Error_Resync (cannot return Error) + + function P_Identifier return Node_Id is + Ident_Node : Node_Id; + + begin + -- All set if we do indeed have an identifier + + if Token = Tok_Identifier then + Ident_Node := Token_Node; + Scan; -- past Identifier + return Ident_Node; + + -- If we have a reserved identifier, manufacture an identifier with + -- a corresponding name after posting an appropriate error message + + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => False); + Ident_Node := Token_Node; + Scan; -- past the node + return Ident_Node; + + -- Otherwise we have junk that cannot be interpreted as an identifier + + else + T_Identifier; -- to give message + raise Error_Resync; + end if; + end P_Identifier; + + -------------------------- + -- 2.3 Letter Or Digit -- + -------------------------- + + -- Parsed by P_Identifier (2.3) + + -------------------------- + -- 2.4 Numeric Literal -- + -------------------------- + + -- NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL + + -- Numeric literal is returned by the scanner as either + -- Tok_Integer_Literal or Tok_Real_Literal + + ---------------------------- + -- 2.4.1 Decimal Literal -- + ---------------------------- + + -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] + + -- Handled by scanner as part of numeric lIteral handing (see 2.4) + + -------------------- + -- 2.4.1 Numeral -- + -------------------- + + -- NUMERAL ::= DIGIT {[UNDERLINE] DIGIT} + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + --------------------- + -- 2.4.1 Exponent -- + --------------------- + + -- EXPONENT ::= E [+] NUMERAL | E - NUMERAL + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + -------------------------- + -- 2.4.2 Based Literal -- + -------------------------- + + -- BASED_LITERAL ::= + -- BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT] + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + ----------------- + -- 2.4.2 Base -- + ----------------- + + -- BASE ::= NUMERAL + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + -------------------------- + -- 2.4.2 Based Numeral -- + -------------------------- + + -- BASED_NUMERAL ::= + -- EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT} + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + --------------------------- + -- 2.4.2 Extended Digit -- + --------------------------- + + -- EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F + + -- Handled by scanner as part of numeric literal handling (see 2.4) + + ---------------------------- + -- 2.5 Character Literal -- + ---------------------------- + + -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' + + -- Handled by the scanner and returned as Tok_Character_Literal + + ------------------------- + -- 2.6 String Literal -- + ------------------------- + + -- STRING LITERAL ::= "{STRING_ELEMENT}" + + -- Handled by the scanner and returned as Tok_Character_Literal + -- or if the string looks like an operator as Tok_Operator_Symbol. + + ------------------------- + -- 2.6 String Element -- + ------------------------- + + -- STRING_ELEMENT ::= "" | non-quotation_mark_GRAPHIC_CHARACTER + + -- A STRING_ELEMENT is either a pair of quotation marks ("), + -- or a single GRAPHIC_CHARACTER other than a quotation mark. + + -- Handled by scanner as part of string literal handling (see 2.4) + + ------------------ + -- 2.7 Comment -- + ------------------ + + -- A COMMENT starts with two adjacent hyphens and extends up to the + -- end of the line. A COMMENT may appear on any line of a program. + + -- Handled by the scanner which simply skips past encountered comments + + ----------------- + -- 2.8 Pragma -- + ----------------- + + -- PRAGMA ::= pragma IDENTIFIER + -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})]; + + -- The caller has checked that the initial token is PRAGMA + + -- Error recovery: cannot raise Error_Resync + + -- One special piece of processing is needed in this routine. As described + -- in the section on "Handling semicolon used in place of IS" in module + -- Parse, the parser detects the case of missing subprogram bodies to + -- allow recovery from this syntactic error. Pragma INTERFACE (and, for + -- Ada 95, pragma IMPORT) can appear in place of the body. The parser must + -- recognize the use of these two pragmas in this context, otherwise it + -- will think there are missing bodies, and try to change ; to IS, when + -- in fact the bodies ARE present, supplied by these pragmas. + + function P_Pragma return Node_Id is + + Interface_Check_Required : Boolean := False; + -- Set True if check of pragma INTERFACE is required + + Import_Check_Required : Boolean := False; + -- Set True if check of pragma IMPORT is required + + Arg_Count : Int := 0; + -- Number of argument associations processed + + Pragma_Node : Node_Id; + Pragma_Name : Name_Id; + Semicolon_Loc : Source_Ptr; + Ident_Node : Node_Id; + Assoc_Node : Node_Id; + + begin + Pragma_Node := New_Node (N_Pragma, Token_Ptr); + Scan; -- past PRAGMA + Pragma_Name := Token_Name; + + if Style_Check then + Style.Check_Pragma_Name; + end if; + + Ident_Node := P_Identifier; + Set_Chars (Pragma_Node, Pragma_Name); + Delete_Node (Ident_Node); + + -- See if special INTERFACE/IMPORT check is required + + if SIS_Entry_Active then + Interface_Check_Required := (Pragma_Name = Name_Interface); + Import_Check_Required := (Pragma_Name = Name_Import); + else + Interface_Check_Required := False; + Import_Check_Required := False; + end if; + + -- Scan arguments. We assume that arguments are present if there is + -- a left paren, or if a semicolon is missing and there is another + -- token on the same line as the pragma name. + + if Token = Tok_Left_Paren + or else (Token /= Tok_Semicolon + and then not Token_Is_At_Start_Of_Line) + then + Set_Pragma_Argument_Associations (Pragma_Node, New_List); + T_Left_Paren; + + loop + Arg_Count := Arg_Count + 1; + Assoc_Node := P_Pragma_Argument_Association; + + if Arg_Count = 2 + and then (Interface_Check_Required or else Import_Check_Required) + then + -- Here is where we cancel the SIS active status if this pragma + -- supplies a body for the currently active subprogram spec. + + if Nkind (Expression (Assoc_Node)) in N_Direct_Name + and then Chars (Expression (Assoc_Node)) = Chars (SIS_Labl) + then + SIS_Entry_Active := False; + end if; + end if; + + Append (Assoc_Node, Pragma_Argument_Associations (Pragma_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + T_Right_Paren; + end if; + + Semicolon_Loc := Token_Ptr; + + if Token /= Tok_Semicolon then + T_Semicolon; + Resync_Past_Semicolon; + else + Scan; -- past semicolon + end if; + + if Is_Pragma_Name (Chars (Pragma_Node)) then + return Par.Prag (Pragma_Node, Semicolon_Loc); + + else + -- Unrecognized pragma, warning generated in Sem_Prag + + return Pragma_Node; + end if; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + + end P_Pragma; + + -- This routine is called if a pragma is encountered in an inappropriate + -- position, the pragma is scanned out and control returns to continue. + + -- The caller has checked that the initial token is pragma + + -- Error recovery: cannot raise Error_Resync + + procedure P_Pragmas_Misplaced is + begin + while Token = Tok_Pragma loop + Error_Msg_SC ("pragma not allowed here"); + Discard_Junk_Node (P_Pragma); + end loop; + end P_Pragmas_Misplaced; + + -- This function is called to scan out an optional sequence of pragmas. + -- If no pragmas are found, then No_List is returned. + + -- Error recovery: Cannot raise Error_Resync + + function P_Pragmas_Opt return List_Id is + L : List_Id; + + begin + if Token = Tok_Pragma then + L := New_List; + P_Pragmas_Opt (L); + return L; + + else + return No_List; + end if; + end P_Pragmas_Opt; + + -- This procedure is called to scan out an optional sequence of pragmas. + -- Any pragmas found are appended to the list provided as an argument. + + -- Error recovery: Cannot raise Error_Resync + + procedure P_Pragmas_Opt (List : List_Id) is + P : Node_Id; + + begin + while Token = Tok_Pragma loop + P := P_Pragma; + + if Chars (P) = Name_Assert or else Chars (P) = Name_Debug then + Error_Msg_Name_1 := Chars (P); + Error_Msg_N + ("pragma% must be in declaration/statement context", P); + else + Append (P, List); + end if; + end loop; + end P_Pragmas_Opt; + + -------------------------------------- + -- 2.8 Pragma_Argument Association -- + -------------------------------------- + + -- PRAGMA_ARGUMENT_ASSOCIATION ::= + -- [pragma_argument_IDENTIFIER =>] NAME + -- | [pragma_argument_IDENTIFIER =>] EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + function P_Pragma_Argument_Association return Node_Id is + Scan_State : Saved_Scan_State; + Pragma_Arg_Node : Node_Id; + Identifier_Node : Node_Id; + + begin + Pragma_Arg_Node := New_Node (N_Pragma_Argument_Association, Token_Ptr); + Set_Chars (Pragma_Arg_Node, No_Name); + + if Token = Tok_Identifier then + Identifier_Node := Token_Node; + Save_Scan_State (Scan_State); -- at Identifier + Scan; -- past Identifier + + if Token = Tok_Arrow then + Scan; -- past arrow + Set_Chars (Pragma_Arg_Node, Chars (Identifier_Node)); + Delete_Node (Identifier_Node); + else + Restore_Scan_State (Scan_State); -- to Identifier + end if; + end if; + + Set_Expression (Pragma_Arg_Node, P_Expression); + return Pragma_Arg_Node; + + end P_Pragma_Argument_Association; + +end Ch2; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb new file mode 100644 index 00000000000..937f02d0e7c --- /dev/null +++ b/gcc/ada/par-ch3.adb @@ -0,0 +1,3724 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.148 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) + +package body Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Component_List return Node_Id; + function P_Defining_Character_Literal return Node_Id; + function P_Delta_Constraint return Node_Id; + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; + function P_Digits_Constraint return Node_Id; + function P_Discriminant_Association return Node_Id; + function P_Enumeration_Literal_Specification return Node_Id; + function P_Enumeration_Type_Definition return Node_Id; + function P_Fixed_Point_Definition return Node_Id; + function P_Floating_Point_Definition return Node_Id; + function P_Index_Or_Discriminant_Constraint return Node_Id; + function P_Real_Range_Specification_Opt return Node_Id; + function P_Subtype_Declaration return Node_Id; + function P_Type_Declaration return Node_Id; + function P_Modular_Type_Definition return Node_Id; + function P_Variant return Node_Id; + function P_Variant_Part return Node_Id; + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a single declarative item, or, in the case of a declaration + -- with a list of identifiers, a list of declarations, one for each of + -- the identifiers in the list. The declaration or declarations scanned + -- are appended to the given list. Done indicates whether or not there + -- may be additional declarative items to scan. If Done is True, then + -- a decision has been made that there are no more items to scan. If + -- Done is False, then there may be additional declarations to scan. + -- In_Spec is true if we are scanning a package declaration, and is used + -- to generate an appropriate message if a statement is encountered in + -- such a context. + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a set of declarations for an identifier or list of + -- identifiers, and appends them to the given list. The parameters have + -- the same significance as for P_Declarative_Items. + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Called when a statement is found at a point where a declaration was + -- expected. The parameters are as described for P_Declarative_Items. + + procedure Set_Declaration_Expected; + -- Posts a "declaration expected" error messages at the start of the + -- current token, and if this is the first such message issued, saves + -- the message id in Missing_Begin_Msg, for possible later replacement. + + ------------------- + -- Init_Expr_Opt -- + ------------------- + + function Init_Expr_Opt (P : Boolean := False) return Node_Id is + begin + if Token = Tok_Colon_Equal + or else Token = Tok_Equal + or else Token = Tok_Colon + or else Token = Tok_Is + then + null; + + -- One other possibility. If we have a literal followed by a semicolon, + -- we assume that we have a missing colon-equal. + + elsif Token in Token_Class_Literal then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past literal or identifier + + if Token = Tok_Semicolon then + Restore_Scan_State (Scan_State); + else + Restore_Scan_State (Scan_State); + return Empty; + end if; + end; + + -- Otherwise we definitely have no initialization expression + + else + return Empty; + end if; + + -- Merge here if we have an initialization expression + + T_Colon_Equal; + + if P then + return P_Expression; + else + return P_Expression_No_Right_Paren; + end if; + end Init_Expr_Opt; + + ---------------------------- + -- 3.1 Basic Declaration -- + ---------------------------- + + -- Parsed by P_Basic_Declarative_Items (3.9) + + ------------------------------ + -- 3.1 Defining Identifier -- + ------------------------------ + + -- DEFINING_IDENTIFIER ::= IDENTIFIER + + -- Error recovery: can raise Error_Resync + + function P_Defining_Identifier return Node_Id is + Ident_Node : Node_Id; + + begin + -- Scan out the identifier. Note that this code is essentially identical + -- to P_Identifier, except that in the call to Scan_Reserved_Identifier + -- we set Force_Msg to True, since we want at least one message for each + -- separate declaration (but not use) of a reserved identifier. + + if Token = Tok_Identifier then + null; + + -- If we have a reserved identifier, manufacture an identifier with + -- a corresponding name after posting an appropriate error message + + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => True); + + -- Otherwise we have junk that cannot be interpreted as an identifier + + else + T_Identifier; -- to give message + raise Error_Resync; + end if; + + Ident_Node := Token_Node; + Scan; -- past the reserved identifier + + if Ident_Node /= Error then + Change_Identifier_To_Defining_Identifier (Ident_Node); + end if; + + return Ident_Node; + end P_Defining_Identifier; + + ----------------------------- + -- 3.2.1 Type Declaration -- + ----------------------------- + + -- TYPE_DECLARATION ::= + -- FULL_TYPE_DECLARATION + -- | INCOMPLETE_TYPE_DECLARATION + -- | PRIVATE_TYPE_DECLARATION + -- | PRIVATE_EXTENSION_DECLARATION + + -- FULL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; + -- | CONCURRENT_TYPE_DECLARATION + + -- INCOMPLETE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]; + + -- PRIVATE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is [abstract] [tagged] [limited] private; + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] new ancestor_SUBTYPE_INDICATION with private; + + -- TYPE_DEFINITION ::= + -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION + -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION + -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION + -- | DERIVED_TYPE_DEFINITION + + -- INTEGER_TYPE_DEFINITION ::= + -- SIGNED_INTEGER_TYPE_DEFINITION + -- MODULAR_TYPE_DEFINITION + + -- Error recovery: can raise Error_Resync + + -- Note: The processing for full type declaration, incomplete type + -- declaration, private type declaration and type definition is + -- included in this function. The processing for concurrent type + -- declarations is NOT here, but rather in chapter 9 (i.e. this + -- function handles only declarations starting with TYPE). + + function P_Type_Declaration return Node_Id is + Type_Loc : Source_Ptr; + Type_Start_Col : Column_Number; + Ident_Node : Node_Id; + Decl_Node : Node_Id; + Discr_List : List_Id; + Unknown_Dis : Boolean; + Discr_Sloc : Source_Ptr; + Abstract_Present : Boolean; + Abstract_Loc : Source_Ptr; + End_Labl : Node_Id; + + Typedef_Node : Node_Id; + -- Normally holds type definition, except in the case of a private + -- extension declaration, in which case it holds the declaration itself + + begin + Type_Loc := Token_Ptr; + Type_Start_Col := Start_Column; + T_Type; + Ident_Node := P_Defining_Identifier; + Discr_Sloc := Token_Ptr; + + if P_Unknown_Discriminant_Part_Opt then + Unknown_Dis := True; + Discr_List := No_List; + else + Unknown_Dis := False; + Discr_List := P_Known_Discriminant_Part_Opt; + end if; + + -- Incomplete type declaration. We complete the processing for this + -- case here and return the resulting incomplete type declaration node + + if Token = Tok_Semicolon then + Scan; -- past ; + Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + return Decl_Node; + + else + Decl_Node := Empty; + end if; + + -- Full type declaration or private type declaration, must have IS + + if Token = Tok_Equal then + TF_Is; + Scan; -- past = used in place of IS + + elsif Token = Tok_Renames then + Error_Msg_SC ("RENAMES should be IS"); + Scan; -- past RENAMES used in place of IS + + else + TF_Is; + end if; + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Abstract) or else + Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode + + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Tagged); + Check_95_Keyword (Tok_Abstract, Tok_New); + end if; + + -- Check cases of misuse of ABSTRACT + + if Token = Tok_Abstract then + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + + if Token = Tok_Limited + or else Token = Tok_Private + or else Token = Tok_Record + or else Token = Tok_Null + then + Error_Msg_AP ("TAGGED expected"); + end if; + + else + Abstract_Present := False; + Abstract_Loc := No_Location; + end if; + + -- Check for misuse of Ada 95 keyword Tagged + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + Check_95_Keyword (Tok_Tagged, Tok_Record); + end if; + + -- Special check for misuse of Aliased + + if Token = Tok_Aliased or else Token_Name = Name_Aliased then + Error_Msg_SC ("ALIASED not allowed in type definition"); + Scan; -- past ALIASED + end if; + + -- The following procesing deals with either a private type declaration + -- or a full type declaration. In the private type case, we build the + -- N_Private_Type_Declaration node, setting its Tagged_Present and + -- Limited_Present flags, on encountering the Private keyword, and + -- leave Typedef_Node set to Empty. For the full type declaration + -- case, Typedef_Node gets set to the type definition. + + Typedef_Node := Empty; + + -- Switch on token following the IS. The loop normally runs once. It + -- only runs more than once if an error is detected, to try again after + -- detecting and fixing up the error. + + loop + case Token is + + when Tok_Access => + Typedef_Node := P_Access_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Array => + Typedef_Node := P_Array_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Delta => + Typedef_Node := P_Fixed_Point_Definition; + TF_Semicolon; + exit; + + when Tok_Digits => + Typedef_Node := P_Floating_Point_Definition; + TF_Semicolon; + exit; + + when Tok_In => + Ignore (Tok_In); + + when Tok_Integer_Literal => + T_Range; + Typedef_Node := P_Signed_Integer_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Null => + Typedef_Node := P_Record_Definition; + TF_Semicolon; + exit; + + when Tok_Left_Paren => + Typedef_Node := P_Enumeration_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Mod => + Typedef_Node := P_Modular_Type_Definition; + TF_Semicolon; + exit; + + when Tok_New => + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + TF_Semicolon; + exit; + + when Tok_Range => + Typedef_Node := P_Signed_Integer_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Record => + Typedef_Node := P_Record_Definition; + + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + TF_Semicolon; + exit; + + when Tok_Tagged => + Scan; -- past TAGGED + + if Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before TAGGED"); + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + end if; + + if Token = Tok_Limited then + Scan; -- past LIMITED + + -- TAGGED LIMITED PRIVATE case + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Set_Limited_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED LIMITED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + Set_Limited_Present (Typedef_Node, True); + end if; + + else + -- TAGGED PRIVATE + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + end if; + end if; + + TF_Semicolon; + exit; + + when Tok_Private => + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Scan; -- past PRIVATE + TF_Semicolon; + exit; + + when Tok_Limited => + Scan; -- past LIMITED + + loop + if Token = Tok_Tagged then + Error_Msg_SC ("TAGGED must come before LIMITED"); + Scan; -- past TAGGED + + elsif Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before LIMITED"); + Scan; -- past ABSTRACT + + else + exit; + end if; + end loop; + + -- LIMITED RECORD or LIMITED NULL RECORD + + if Token = Tok_Record or else Token = Tok_Null then + if Ada_83 then + Error_Msg_SP + ("(Ada 83) limited record declaration not allowed!"); + end if; + + Typedef_Node := P_Record_Definition; + Set_Limited_Present (Typedef_Node, True); + + -- LIMITED PRIVATE is the only remaining possibility here + + else + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Limited_Present (Decl_Node, True); + T_Private; -- past PRIVATE (or complain if not there!) + end if; + + TF_Semicolon; + exit; + + -- Here we have an identifier after the IS, which is certainly + -- wrong and which might be one of several different mistakes. + + when Tok_Identifier => + + -- First case, if identifier is on same line, then probably we + -- have something like "type X is Integer .." and the best + -- diagnosis is a missing NEW. Note: the missing new message + -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. + + if not Token_Is_At_Start_Of_Line then + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + TF_Semicolon; + + -- If the identifier is at the start of the line, and is in the + -- same column as the type declaration itself then we consider + -- that we had a missing type definition on the previous line + + elsif Start_Column <= Type_Start_Col then + Error_Msg_AP ("type definition expected"); + Typedef_Node := Error; + + -- If the identifier is at the start of the line, and is in + -- a column to the right of the type declaration line, then we + -- may have something like: + + -- type x is + -- r : integer + + -- and the best diagnosis is a missing record keyword + + else + Typedef_Node := P_Record_Definition; + TF_Semicolon; + end if; + + exit; + + -- Anything else is an error + + when others => + if Bad_Spelling_Of (Tok_Access) + or else + Bad_Spelling_Of (Tok_Array) + or else + Bad_Spelling_Of (Tok_Delta) + or else + Bad_Spelling_Of (Tok_Digits) + or else + Bad_Spelling_Of (Tok_Limited) + or else + Bad_Spelling_Of (Tok_Private) + or else + Bad_Spelling_Of (Tok_Range) + or else + Bad_Spelling_Of (Tok_Record) + or else + Bad_Spelling_Of (Tok_Tagged) + then + null; + + else + Error_Msg_AP ("type definition expected"); + raise Error_Resync; + end if; + + end case; + end loop; + + -- For the private type declaration case, the private type declaration + -- node has been built, with the Tagged_Present and Limited_Present + -- flags set as needed, and Typedef_Node is left set to Empty. + + if No (Typedef_Node) then + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Decl_Node, Abstract_Present); + + -- For a private extension declaration, Typedef_Node contains the + -- N_Private_Extension_Declaration node, which we now complete. Note + -- that the private extension declaration, unlike a full type + -- declaration, does permit unknown discriminants. + + elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then + Decl_Node := Typedef_Node; + Set_Sloc (Decl_Node, Type_Loc); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + -- In the full type declaration case, Typedef_Node has the type + -- definition and here is where we build the full type declaration + -- node. This is also where we check for improper use of an unknown + -- discriminant part (not allowed for full type declaration). + + else + if Nkind (Typedef_Node) = N_Record_Definition + or else (Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node))) + then + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + elsif Abstract_Present then + Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); + end if; + + Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); + Set_Type_Definition (Decl_Node, Typedef_Node); + + if Unknown_Dis then + Error_Msg + ("Full type declaration cannot have unknown discriminants", + Discr_Sloc); + end if; + end if; + + -- Remaining processing is common for all three cases + + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + return Decl_Node; + + end P_Type_Declaration; + + ---------------------------------- + -- 3.2.1 Full Type Declaration -- + ---------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.2.1 Type Definition -- + ---------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------- + -- 3.2.2 Subtype Declaration -- + -------------------------------- + + -- SUBTYPE_DECLARATION ::= + -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; + + -- The caller has checked that the initial token is SUBTYPE + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Declaration return Node_Id is + Decl_Node : Node_Id; + + begin + Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); + Scan; -- past SUBTYPE + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); + TF_Is; + + if Token = Tok_New then + Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); + Scan; -- past NEW + end if; + + Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); + TF_Semicolon; + return Decl_Node; + end P_Subtype_Declaration; + + ------------------------------- + -- 3.2.2 Subtype Indication -- + ------------------------------- + + -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Indication return Node_Id is + Type_Node : Node_Id; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Type_Node := P_Subtype_Mark; + return P_Subtype_Indication (Type_Node); + + else + -- Check for error of using record definition and treat it nicely, + -- otherwise things are really messed up, so resynchronize. + + if Token = Tok_Record then + Error_Msg_SC ("anonymous record definitions are not permitted"); + Discard_Junk_Node (P_Record_Definition); + return Error; + + else + Error_Msg_AP ("subtype indication expected"); + raise Error_Resync; + end if; + end if; + end P_Subtype_Indication; + + -- The following function is identical except that it is called with + -- the subtype mark already scanned out, and it scans out the constraint + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is + Indic_Node : Node_Id; + Constr_Node : Node_Id; + + begin + Constr_Node := P_Constraint_Opt; + + if No (Constr_Node) then + return Subtype_Mark; + else + Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); + Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Constraint (Indic_Node, Constr_Node); + return Indic_Node; + end if; + + end P_Subtype_Indication; + + ------------------------- + -- 3.2.2 Subtype Mark -- + ------------------------- + + -- SUBTYPE_MARK ::= subtype_NAME; + + -- Note: The subtype mark which appears after an IN or NOT IN + -- operator is parsed by P_Range_Or_Subtype_Mark (3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Subtype_Mark return Node_Id is + begin + return P_Subtype_Mark_Resync; + + exception + when Error_Resync => + return Error; + end P_Subtype_Mark; + + -- This routine differs from P_Subtype_Mark in that it insists that an + -- identifier be present, and if it is not, it raises Error_Resync. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Resync return Node_Id is + Type_Node : Node_Id; + + begin + if Token = Tok_Access then + Error_Msg_SC ("anonymous access type definition not allowed here"); + Scan; -- past ACCESS + end if; + + if Token = Tok_Array then + Error_Msg_SC ("anonymous array definition not allowed here"); + Discard_Junk_Node (P_Array_Type_Definition); + return Empty; + + else + Type_Node := P_Qualified_Simple_Name_Resync; + + -- Check for a subtype mark attribute. The only valid possibilities + -- are 'CLASS and 'BASE. Anything else is a definite error. We may + -- as well catch it here. + + if Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Type_Node); + else + return Type_Node; + end if; + end if; + end P_Subtype_Mark_Resync; + + -- The following function is called to scan out a subtype mark attribute. + -- The caller has already scanned out the subtype mark, which is passed in + -- as the argument, and has checked that the current token is apostrophe. + + -- Only a special subclass of attributes, called type attributes + -- (see Snames package) are allowed in this syntactic position. + + -- Note: if the apostrophe is followed by other than an identifier, then + -- the input expression is returned unchanged, and the scan pointer is + -- left pointing to the apostrophe. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is + Attr_Node : Node_Id := Empty; + Scan_State : Saved_Scan_State; + Prefix : Node_Id; + + begin + Prefix := Check_Subtype_Mark (Type_Node); + + if Prefix = Error then + raise Error_Resync; + end if; + + -- Loop through attributes appearing (more than one can appear as for + -- for example in X'Base'Class). We are at an apostrophe on entry to + -- this loop, and it runs once for each attribute parsed, with + -- Prefix being the current possible prefix if it is an attribute. + + loop + Save_Scan_State (Scan_State); -- at Apostrophe + Scan; -- past apostrophe + + if Token /= Tok_Identifier then + Restore_Scan_State (Scan_State); -- to apostrophe + return Prefix; -- no attribute after all + + elsif not Is_Type_Attribute_Name (Token_Name) then + Error_Msg_N + ("attribute & may not be used in a subtype mark", Token_Node); + raise Error_Resync; + + else + Attr_Node := + Make_Attribute_Reference (Prev_Token_Ptr, + Prefix => Prefix, + Attribute_Name => Token_Name); + Delete_Node (Token_Node); + Scan; -- past type attribute identifier + end if; + + exit when Token /= Tok_Apostrophe; + Prefix := Attr_Node; + end loop; + + -- Fall through here after scanning type attribute + + return Attr_Node; + end P_Subtype_Mark_Attribute; + + ----------------------- + -- 3.2.2 Constraint -- + ----------------------- + + -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT + + -- SCALAR_CONSTRAINT ::= + -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT + + -- COMPOSITE_CONSTRAINT ::= + -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT + + -- If no constraint is present, this function returns Empty + + -- Error recovery: can raise Error_Resync + + function P_Constraint_Opt return Node_Id is + begin + if Token = Tok_Range + or else Bad_Spelling_Of (Tok_Range) + then + return P_Range_Constraint; + + elsif Token = Tok_Digits + or else Bad_Spelling_Of (Tok_Digits) + then + return P_Digits_Constraint; + + elsif Token = Tok_Delta + or else Bad_Spelling_Of (Tok_Delta) + then + return P_Delta_Constraint; + + elsif Token = Tok_Left_Paren then + return P_Index_Or_Discriminant_Constraint; + + elsif Token = Tok_In then + Ignore (Tok_In); + return P_Constraint_Opt; + + else + return Empty; + end if; + + end P_Constraint_Opt; + + ------------------------------ + -- 3.2.2 Scalar Constraint -- + ------------------------------ + + -- Parsed by P_Constraint_Opt (3.2.2) + + --------------------------------- + -- 3.2.2 Composite Constraint -- + --------------------------------- + + -- Parsed by P_Constraint_Opt (3.2.2) + + -------------------------------------------------------- + -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) -- + -------------------------------------------------------- + + -- This routine scans out a declaration starting with an identifier: + + -- OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [constant] [aliased] + -- SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + + -- NUMBER_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; + + -- OBJECT_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME; + + -- EXCEPTION_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : exception renames exception_NAME; + + -- EXCEPTION_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : exception; + + -- Note that the ALIASED indication in an object declaration is + -- marked by a flag in the parent node. + + -- The caller has checked that the initial token is an identifier + + -- The value returned is a list of declarations, one for each identifier + -- in the list (as described in Sinfo, we always split up multiple + -- declarations into the equivalent sequence of single declarations + -- using the More_Ids and Prev_Ids flags to preserve the source). + + -- If the identifier turns out to be a probable statement rather than + -- an identifier, then the scan is left pointing to the identifier and + -- No_List is returned. + + -- Error recovery: can raise Error_Resync + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Decl_Node : Node_Id; + Type_Node : Node_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + List_OK : Boolean := True; + Ident : Nat; + Init_Expr : Node_Id; + Init_Loc : Source_Ptr; + Con_Loc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- Used to save identifiers in the identifier list. The upper bound + -- of 4096 is expected to be infinite in practice, and we do not even + -- bother to check if this upper bound is exceeded. + + Num_Idents : Nat := 1; + -- Number of identifiers stored in Idents + + procedure No_List; + -- This procedure is called in renames cases to make sure that we do + -- not have more than one identifier. If we do have more than one + -- then an error message is issued (and the declaration is split into + -- multiple declarations) + + function Token_Is_Renames return Boolean; + -- Checks if current token is RENAMES, and if so, scans past it and + -- returns True, otherwise returns False. Includes checking for some + -- common error cases. + + procedure No_List is + begin + if Num_Idents > 1 then + Error_Msg ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); + end if; + + List_OK := False; + end No_List; + + function Token_Is_Renames return Boolean is + At_Colon : Saved_Scan_State; + + begin + if Token = Tok_Colon then + Save_Scan_State (At_Colon); + Scan; -- past colon + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Error_Msg_SP ("extra "":"" ignored"); + Scan; -- past RENAMES + return True; + else + Restore_Scan_State (At_Colon); + return False; + end if; + + else + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Scan; -- past RENAMES + return True; + else + return False; + end if; + end if; + end Token_Is_Renames; + + -- Start of processing for P_Identifier_Declarations + + begin + Ident_Sloc := Token_Ptr; + Save_Scan_State (Scan_State); -- at first identifier + Idents (1) := P_Defining_Identifier; + + -- If we have a colon after the identifier, then we can assume that + -- this is in fact a valid identifier declaration and can steam ahead. + + if Token = Tok_Colon then + Scan; -- past colon + + -- If we have a comma, then scan out the list of identifiers + + elsif Token = Tok_Comma then + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + Save_Scan_State (Scan_State); -- at colon + T_Colon; + + -- If we have identifier followed by := then we assume that what is + -- really meant is an assignment statement. The assignment statement + -- is scanned out and added to the list of declarations. An exception + -- occurs if the := is followed by the keyword constant, in which case + -- we assume it was meant to be a colon. + + elsif Token = Tok_Colon_Equal then + Scan; -- past := + + if Token = Tok_Constant then + Error_Msg_SP ("colon expected"); + + else + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- If we have an IS keyword, then assume the TYPE keyword was missing + + elsif Token = Tok_Is then + Restore_Scan_State (Scan_State); + Append_To (Decls, P_Type_Declaration); + Done := False; + return; + + -- Otherwise we have an error situation + + else + Restore_Scan_State (Scan_State); + + -- First case is possible misuse of PROTECTED in Ada 83 mode. If + -- so, fix the keyword and return to scan the protected declaration. + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Identifier); + Check_95_Keyword (Tok_Protected, Tok_Type); + Check_95_Keyword (Tok_Protected, Tok_Body); + + if Token = Tok_Protected then + Done := False; + return; + end if; + + -- Check misspelling possibilities. If so, correct the misspelling + -- and return to scan out the resulting declaration. + + elsif Bad_Spelling_Of (Tok_Function) + or else Bad_Spelling_Of (Tok_Procedure) + or else Bad_Spelling_Of (Tok_Package) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Protected) + or else Bad_Spelling_Of (Tok_Generic) + or else Bad_Spelling_Of (Tok_Subtype) + or else Bad_Spelling_Of (Tok_Type) + or else Bad_Spelling_Of (Tok_Task) + or else Bad_Spelling_Of (Tok_Use) + or else Bad_Spelling_Of (Tok_For) + then + Done := False; + return; + + -- Otherwise we definitely have an ordinary identifier with a junk + -- token after it. Just complain that we expect a declaration, and + -- skip to a semicolon + + else + Set_Declaration_Expected; + Resync_Past_Semicolon; + Done := False; + return; + end if; + end if; + + -- Come here with an identifier list and colon scanned out. We now + -- build the nodes for the declarative items. One node is built for + -- each identifier in the list, with the type information being + -- repeated by rescanning the appropriate section of source. + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Loop through identifiers + + Ident := 1; + Ident_Loop : loop + + -- Check for some cases of misused Ada 95 keywords + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + Check_95_Keyword (Tok_Aliased, Tok_Constant); + end if; + + -- Constant cases + + if Token = Tok_Constant then + Con_Loc := Token_Ptr; + Scan; -- past CONSTANT + + -- Number declaration, initialization required + + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); + Set_Expression (Decl_Node, Init_Expr); + + -- Constant object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Constant_Present (Decl_Node, True); + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Error_Msg_SC ("ALIASED should be before CONSTANT"); + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + else + Set_Object_Definition (Decl_Node, P_Subtype_Indication); + end if; + + if Token = Tok_Renames then + Error_Msg + ("CONSTANT not permitted in renaming declaration", + Con_Loc); + Scan; -- Past renames + Discard_Junk_Node (P_Name); + end if; + end if; + + -- Exception cases + + elsif Token = Tok_Exception then + Scan; -- past EXCEPTION + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); + Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); + No_Constraint; + else + Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); + end if; + + -- Aliased case (note that an object definition is required) + + elsif Token = Tok_Aliased then + Scan; -- past ALIASED + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Aliased_Present (Decl_Node, True); + + if Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + else + Set_Object_Definition (Decl_Node, P_Subtype_Indication); + end if; + + -- Array case + + elsif Token = Tok_Array then + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + + -- Subtype indication case + + else + Type_Node := P_Subtype_Mark; + + -- Object renaming declaration + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Subtype_Mark (Decl_Node, Type_Node); + Set_Name (Decl_Node, P_Name); + + -- Object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Type_Node)); + + -- RENAMES at this point means that we had the combination of + -- a constraint on the Type_Node and renames, which is illegal + + if Token_Is_Renames then + Error_Msg_N + ("constraint not allowed in object renaming declaration", + Constraint (Object_Definition (Decl_Node))); + raise Error_Resync; + end if; + end if; + end if; + + -- Scan out initialization, allowed only for object declaration + + Init_Loc := Token_Ptr; + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + if Nkind (Decl_Node) = N_Object_Declaration then + Set_Expression (Decl_Node, Init_Expr); + else + Error_Msg ("initialization not allowed here", Init_Loc); + end if; + end if; + + TF_Semicolon; + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + + if List_OK then + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + end if; + + Append (Decl_Node, Decls); + exit Ident_Loop when Ident = Num_Idents; + Restore_Scan_State (Scan_State); + T_Colon; + Ident := Ident + 1; + end loop Ident_Loop; + + Done := False; + + end P_Identifier_Declarations; + + ------------------------------- + -- 3.3.1 Object Declaration -- + ------------------------------- + + -- OBJECT DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- | SINGLE_TASK_DECLARATION + -- | SINGLE_PROTECTED_DECLARATION + + -- Cases starting with TASK are parsed by P_Task (9.1) + -- Cases starting with PROTECTED are parsed by P_Protected (9.4) + -- All other cases are parsed by P_Identifier_Declarations (3.3) + + ------------------------------------- + -- 3.3.1 Defining Identifier List -- + ------------------------------------- + + -- DEFINING_IDENTIFIER_LIST ::= + -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} + + -- Always parsed by the construct in which it appears. See special + -- section on "Handling of Defining Identifier Lists" in this unit. + + ------------------------------- + -- 3.3.2 Number Declaration -- + ------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3) + + ------------------------------------------------------------------------- + -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) -- + ------------------------------------------------------------------------- + + -- DERIVED_TYPE_DEFINITION ::= + -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART] + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE; + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- The caller has already scanned out the part up to the NEW, and Token + -- either contains Tok_New (or ought to, if it doesn't this procedure + -- will post an appropriate "NEW expected" message). + + -- Note: the caller is responsible for filling in the Sloc field of + -- the returned node in the private extension declaration case as + -- well as the stuff relating to the discriminant part. + + -- Error recovery: can raise Error_Resync; + + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is + Typedef_Node : Node_Id; + Typedecl_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); + T_New; + + if Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before NEW, not after"); + Scan; + end if; + + Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication); + + -- Deal with record extension, note that we assume that a WITH is + -- missing in the case of "type X is new Y record ..." or in the + -- case of "type X is new Y null record". + + if Token = Tok_With + or else Token = Tok_Record + or else Token = Tok_Null + then + T_With; -- past WITH or give error message + + if Token = Tok_Limited then + Error_Msg_SC + ("LIMITED keyword not allowed in private extension"); + Scan; -- ignore LIMITED + end if; + + -- Private extension declaration + + if Token = Tok_Private then + Scan; -- past PRIVATE + + -- Throw away the type definition node and build the type + -- declaration node. Note the caller must set the Sloc, + -- Discriminant_Specifications, Unknown_Discriminants_Present, + -- and Defined_Identifier fields in the returned node. + + Typedecl_Node := + Make_Private_Extension_Declaration (No_Location, + Defining_Identifier => Empty, + Subtype_Indication => Subtype_Indication (Typedef_Node), + Abstract_Present => Abstract_Present (Typedef_Node)); + + Delete_Node (Typedef_Node); + return Typedecl_Node; + + -- Derived type definition with record extension part + + else + Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); + return Typedef_Node; + end if; + + -- Derived type definition with no record extension part + + else + return Typedef_Node; + end if; + end P_Derived_Type_Def_Or_Private_Ext_Decl; + + --------------------------- + -- 3.5 Range Constraint -- + --------------------------- + + -- RANGE_CONSTRAINT ::= range RANGE + + -- The caller has checked that the initial token is RANGE + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Constraint return Node_Id is + Range_Node : Node_Id; + + begin + Range_Node := New_Node (N_Range_Constraint, Token_Ptr); + Scan; -- past RANGE + Set_Range_Expression (Range_Node, P_Range); + return Range_Node; + end P_Range_Constraint; + + ---------------- + -- 3.5 Range -- + ---------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- Note: the range that appears in a membership test is parsed by + -- P_Range_Or_Subtype_Mark (3.5). + + -- Error recovery: cannot raise Error_Resync + + function P_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Dot_Dot then + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + return Range_Node; + + -- Anything else is an error + + else + T_Dot_Dot; -- force missing .. message + return Error; + end if; + end P_Range; + + ---------------------------------- + -- 3.5 P_Range_Or_Subtype_Mark -- + ---------------------------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE + -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- This routine scans out the range or subtype mark that forms the right + -- operand of a membership test. + + -- Note: as documented in the Sinfo interface, although the syntax only + -- allows a subtype mark, we in fact allow any simple expression to be + -- returned from this routine. The semantics is responsible for issuing + -- an appropriate message complaining if the argument is not a name. + -- This simplifies the coding and error recovery processing in the + -- parser, and in any case it is preferable not to consider this a + -- syntax error and to continue with the semantic analysis. + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Or_Subtype_Mark return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + -- Simple_Expression .. Simple_Expression + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Set_High_Bound (Range_Node, P_Simple_Expression); + return Range_Node; + + -- Case of subtype mark (optionally qualified simple name or an + -- attribute whose prefix is an optionally qualifed simple name) + + elsif Expr_Form = EF_Simple_Name + or else Nkind (Expr_Node) = N_Attribute_Reference + then + -- Check for error of range constraint after a subtype mark + + if Token = Tok_Range then + Error_Msg_SC + ("range constraint not allowed in membership test"); + Scan; -- past RANGE + raise Error_Resync; + + -- Check for error of DIGITS or DELTA after a subtype mark + + elsif Token = Tok_Digits or else Token = Tok_Delta then + Error_Msg_SC + ("accuracy definition not allowed in membership test"); + Scan; -- past DIGITS or DELTA + raise Error_Resync; + + elsif Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Expr_Node); + + else + return Expr_Node; + end if; + + -- At this stage, we have some junk following the expression. We + -- really can't tell what is wrong, might be a missing semicolon, + -- or a missing THEN, or whatever. Our caller will figure it out! + + else + return Expr_Node; + end if; + end P_Range_Or_Subtype_Mark; + + ---------------------------------------- + -- 3.5.1 Enumeration Type Definition -- + ---------------------------------------- + + -- ENUMERATION_TYPE_DEFINITION ::= + -- (ENUMERATION_LITERAL_SPECIFICATION + -- {, ENUMERATION_LITERAL_SPECIFICATION}) + + -- The caller has already scanned out the TYPE keyword + + -- Error recovery: can raise Error_Resync; + + function P_Enumeration_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); + Set_Literals (Typedef_Node, New_List); + + T_Left_Paren; + + loop + Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + return Typedef_Node; + end P_Enumeration_Type_Definition; + + ---------------------------------------------- + -- 3.5.1 Enumeration Literal Specification -- + ---------------------------------------------- + + -- ENUMERATION_LITERAL_SPECIFICATION ::= + -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL + + -- Error recovery: can raise Error_Resync + + function P_Enumeration_Literal_Specification return Node_Id is + begin + if Token = Tok_Char_Literal then + return P_Defining_Character_Literal; + else + return P_Defining_Identifier; + end if; + end P_Enumeration_Literal_Specification; + + --------------------------------------- + -- 3.5.1 Defining_Character_Literal -- + --------------------------------------- + + -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL + + -- Error recovery: cannot raise Error_Resync + + -- The caller has checked that the current token is a character literal + + function P_Defining_Character_Literal return Node_Id is + Literal_Node : Node_Id; + + begin + Literal_Node := Token_Node; + Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); + Scan; -- past character literal + return Literal_Node; + end P_Defining_Character_Literal; + + ------------------------------------ + -- 3.5.4 Integer Type Definition -- + ------------------------------------ + + -- Parsed by P_Type_Declaration (3.2.1) + + ------------------------------------------- + -- 3.5.4 Signed Integer Type Definition -- + ------------------------------------------- + + -- SIGNED_INTEGER_TYPE_DEFINITION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Normally the initial token on entry is RANGE, but in some + -- error conditions, the range token was missing and control is + -- passed with Token pointing to first token of the first expression. + + -- Error recovery: cannot raise Error_Resync + + function P_Signed_Integer_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); + + if Token = Tok_Range then + Scan; -- past RANGE + end if; + + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Typedef_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Typedef_Node, Expr_Node); + return Typedef_Node; + end P_Signed_Integer_Type_Definition; + + ------------------------------------ + -- 3.5.4 Modular Type Definition -- + ------------------------------------ + + -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION + + -- The caller has checked that the initial token is MOD + + -- Error recovery: cannot raise Error_Resync + + function P_Modular_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + if Ada_83 then + Error_Msg_SC ("(Ada 83): modular types not allowed"); + end if; + + Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); + Scan; -- past MOD + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + + -- Handle mod L..R cleanly + + if Token = Tok_Dot_Dot then + Error_Msg_SC ("range not allowed for modular type"); + Scan; -- past .. + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + end if; + + return Typedef_Node; + end P_Modular_Type_Definition; + + --------------------------------- + -- 3.5.6 Real Type Definition -- + --------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------------- + -- 3.5.7 Floating Point Definition -- + -------------------------------------- + + -- FLOATING_POINT_DEFINITION ::= + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + -- Error recovery: cannot raise Error_Resync + + function P_Floating_Point_Definition return Node_Id is + Digits_Loc : constant Source_Ptr := Token_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + + -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order + + if Token = Tok_Delta then + Error_Msg_SC ("DELTA must come before DIGITS"); + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); + Scan; -- past DELTA + Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); + + -- OK floating-point definition + + else + Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc); + end if; + + Set_Digits_Expression (Def_Node, Expr_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Floating_Point_Definition; + + ------------------------------------- + -- 3.5.7 Real Range Specification -- + ------------------------------------- + + -- REAL_RANGE_SPECIFICATION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + function P_Real_Range_Specification_Opt return Node_Id is + Specification_Node : Node_Id; + Expr_Node : Node_Id; + + begin + if Token = Tok_Range then + Specification_Node := + New_Node (N_Real_Range_Specification, Token_Ptr); + Scan; -- past RANGE + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Specification_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Specification_Node, Expr_Node); + return Specification_Node; + else + return Empty; + end if; + end P_Real_Range_Specification_Opt; + + ----------------------------------- + -- 3.5.9 Fixed Point Definition -- + ----------------------------------- + + -- FIXED_POINT_DEFINITION ::= + -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION + + -- ORDINARY_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION + + -- DECIMAL_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Fixed_Point_Definition return Node_Id is + Delta_Node : Node_Id; + Delta_Loc : Source_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Delta_Loc := Token_Ptr; + Scan; -- past DELTA + Delta_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Delta_Node); + + if Token = Tok_Digits then + if Ada_83 then + Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); + end if; + + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Def_Node, Expr_Node); + + else + Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); + + -- Range is required in ordinary fixed point case + + if Token /= Tok_Range then + Error_Msg_AP ("range must be given for fixed-point type"); + T_Range; + end if; + end if; + + Set_Delta_Expression (Def_Node, Delta_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Fixed_Point_Definition; + + -------------------------------------------- + -- 3.5.9 Ordinary Fixed Point Definition -- + -------------------------------------------- + + -- Parsed by P_Fixed_Point_Definition (3.5.9) + + ------------------------------------------- + -- 3.5.9 Decimal Fixed Point Definition -- + ------------------------------------------- + + -- Parsed by P_Decimal_Point_Definition (3.5.9) + + ------------------------------ + -- 3.5.9 Digits Constraint -- + ------------------------------ + + -- DIGITS_CONSTRAINT ::= + -- digits static_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + function P_Digits_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Digits_Constraint; + + ----------------------------- + -- 3.5.9 Delta Constraint -- + ----------------------------- + + -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: this is an obsolescent feature in Ada 95 (I.3) + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Delta_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); + Scan; -- past DELTA + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Delta_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Delta_Constraint; + + -------------------------------- + -- 3.6 Array Type Definition -- + -------------------------------- + + -- ARRAY_TYPE_DEFINITION ::= + -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION + + -- UNCONSTRAINED_ARRAY_DEFINITION ::= + -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> + + -- CONSTRAINED_ARRAY_DEFINITION ::= + -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- DISCRETE_SUBTYPE_INDICATION | RANGE + + -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION + + -- The caller has checked that the initial token is ARRAY + + -- Error recovery: can raise Error_Resync + + function P_Array_Type_Definition return Node_Id is + Array_Loc : Source_Ptr; + Def_Node : Node_Id; + Subs_List : List_Id; + Scan_State : Saved_Scan_State; + + begin + Array_Loc := Token_Ptr; + Scan; -- past ARRAY + Subs_List := New_List; + T_Left_Paren; + + -- It's quite tricky to disentangle these two possibilities, so we do + -- a prescan to determine which case we have and then reset the scan. + -- The prescan skips past possible subtype mark tokens. + + Save_Scan_State (Scan_State); -- just after paren + + while Token in Token_Class_Desig or else + Token = Tok_Dot or else + Token = Tok_Apostrophe -- because of 'BASE, 'CLASS + loop + Scan; + end loop; + + -- If we end up on RANGE <> then we have the unconstrained case. We + -- will also allow the RANGE to be omitted, just to improve error + -- handling for a case like array (integer <>) of integer; + + Scan; -- past possible RANGE or <> + + if (Prev_Token = Tok_Range and then Token = Tok_Box) or else + Prev_Token = Tok_Box + then + Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first subtype mark + + loop + Append (P_Subtype_Mark_Resync, Subs_List); + T_Range; + T_Box; + exit when Token = Tok_Right_Paren or else Token = Tok_Of; + T_Comma; + end loop; + + Set_Subtype_Marks (Def_Node, Subs_List); + + else + Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first discrete range + + loop + Append (P_Discrete_Subtype_Definition, Subs_List); + exit when not Comma_Present; + end loop; + + Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); + end if; + + T_Right_Paren; + T_Of; + + if Token = Tok_Aliased then + Set_Aliased_Present (Def_Node, True); + Scan; -- past ALIASED + end if; + + Set_Subtype_Indication (Def_Node, P_Subtype_Indication); + return Def_Node; + end P_Array_Type_Definition; + + ----------------------------------------- + -- 3.6 Unconstrained Array Definition -- + ----------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + --------------------------------------- + -- 3.6 Constrained Array Definition -- + --------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + -------------------------------------- + -- 3.6 Discrete Subtype Definition -- + -------------------------------------- + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- discrete_SUBTYPE_INDICATION | RANGE + + -- Note: the discrete subtype definition appearing in a constrained + -- array definition is parsed by P_Array_Type_Definition (3.6) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Subtype_Definition return Node_Id is + begin + + -- The syntax of a discrete subtype definition is identical to that + -- of a discrete range, so we simply share the same parsing code. + + return P_Discrete_Range; + end P_Discrete_Subtype_Definition; + + ------------------------------- + -- 3.6 Component Definition -- + ------------------------------- + + -- For the array case, parsed by P_Array_Type_Definition (3.6) + -- For the record case, parsed by P_Component_Declaration (3.8) + + ----------------------------- + -- 3.6.1 Index Constraint -- + ----------------------------- + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + --------------------------- + -- 3.6.1 Discrete Range -- + --------------------------- + + -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE + + -- The possible forms for a discrete range are: + + -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) + -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) + -- Range_Attribute (RANGE, 3.5) + -- Simple_Expression .. Simple_Expression (RANGE, 3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("range must be preceded by subtype mark"); + end if; + + return P_Subtype_Indication (Expr_Node); + + -- Check Expression .. Expression case + + elsif Token = Tok_Dot_Dot then + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + return Range_Node; + + -- Otherwise we must have a subtype mark + + elsif Expr_Form = EF_Simple_Name then + return Expr_Node; + + -- If incorrect, complain that we expect .. + + else + T_Dot_Dot; + return Expr_Node; + end if; + end P_Discrete_Range; + + ---------------------------- + -- 3.7 Discriminant Part -- + ---------------------------- + + -- DISCRIMINANT_PART ::= + -- UNKNOWN_DISCRIMINANT_PART + -- | KNOWN_DISCRIMINANT_PART + + -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7) + -- or P_Unknown_Discriminant_Part (3.7), since we know which we want. + + ------------------------------------ + -- 3.7 Unknown Discriminant Part -- + ------------------------------------ + + -- UNKNOWN_DISCRIMINANT_PART ::= (<>) + + -- If no unknown discriminant part is present, then False is returned, + -- otherwise the unknown discriminant is scanned out and True is returned. + + -- Error recovery: cannot raise Error_Resync + + function P_Unknown_Discriminant_Part_Opt return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token /= Tok_Left_Paren then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past the left paren + + if Token = Tok_Box then + + if Ada_83 then + Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); + end if; + + Scan; -- past the box + T_Right_Paren; -- must be followed by right paren + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end P_Unknown_Discriminant_Part_Opt; + + ---------------------------------- + -- 3.7 Known Discriminant Part -- + ---------------------------------- + + -- KNOWN_DISCRIMINANT_PART ::= + -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) + + -- DISCRIMINANT_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- If no known discriminant part is present, then No_List is returned + + -- Error recovery: cannot raise Error_Resync + + function P_Known_Discriminant_Part_Opt return List_Id is + Specification_Node : Node_Id; + Specification_List : List_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token = Tok_Left_Paren then + Specification_List := New_List; + Scan; -- past ( + P_Pragmas_Misplaced; + + Specification_Loop : loop + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + Specification_Node := + New_Node (N_Discriminant_Specification, Ident_Sloc); + Set_Defining_Identifier (Specification_Node, Idents (Ident)); + + if Token = Tok_Access then + if Ada_83 then + Error_Msg_SC + ("(Ada 83) access discriminant not allowed!"); + end if; + + Set_Discriminant_Type + (Specification_Node, P_Access_Definition); + else + Set_Discriminant_Type + (Specification_Node, P_Subtype_Mark); + No_Constraint; + end if; + + Set_Expression + (Specification_Node, Init_Expr_Opt (True)); + + if Ident > 1 then + Set_Prev_Ids (Specification_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Specification_Node, True); + end if; + + Append (Specification_Node, Specification_List); + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_Loop; + + exit Specification_Loop when Token /= Tok_Semicolon; + Scan; -- past ; + P_Pragmas_Misplaced; + end loop Specification_Loop; + + T_Right_Paren; + return Specification_List; + + else + return No_List; + end if; + end P_Known_Discriminant_Part_Opt; + + ------------------------------------- + -- 3.7 DIscriminant Specification -- + ------------------------------------- + + -- Parsed by P_Known_Discriminant_Part_Opt (3.7) + + ----------------------------- + -- 3.7 Default Expression -- + ----------------------------- + + -- Always parsed (simply as an Expression) by the parent construct + + ------------------------------------ + -- 3.7.1 Discriminant Constraint -- + ------------------------------------ + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + -------------------------------------------------------- + -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- + -------------------------------------------------------- + + -- DISCRIMINANT_CONSTRAINT ::= + -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine parses either an index or a discriminant constraint. As + -- is clear from the above grammar, it is often possible to clearly + -- determine which of the two possibilities we have, but there are + -- cases (those in which we have a series of expressions of the same + -- syntactic form as subtype indications), where we cannot tell. Since + -- this means that in any case the semantic phase has to distinguish + -- between the two, there is not much point in the parser trying to + -- distinguish even those cases where the difference is clear. In any + -- case, if we have a situation like: + + -- (A => 123, 235 .. 500) + + -- it is not clear which of the two items is the wrong one, better to + -- let the semantic phase give a clear message. Consequently, this + -- routine in general returns a list of items which can be either + -- discrete ranges or discriminant associations. + + -- The caller has checked that the initial token is a left paren + + -- Error recovery: can raise Error_Resync + + function P_Index_Or_Discriminant_Constraint return Node_Id is + Scan_State : Saved_Scan_State; + Constr_Node : Node_Id; + Constr_List : List_Id; + Expr_Node : Node_Id; + Result_Node : Node_Id; + + begin + Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); + Scan; -- past ( + Constr_List := New_List; + Set_Constraints (Result_Node, Constr_List); + + -- The two syntactic forms are a little mixed up, so what we are doing + -- here is looking at the first entry to determine which case we have + + -- A discriminant constraint is a list of discriminant associations, + -- which have one of the following possible forms: + + -- Expression + -- Id => Expression + -- Id | Id | .. | Id => Expression + + -- An index constraint is a list of discrete ranges which have one + -- of the following possible forms: + + -- Subtype_Mark + -- Subtype_Mark range Range + -- Range_Attribute + -- Simple_Expression .. Simple_Expression + + -- Loop through discriminants in list + + loop + -- Check cases of Id => Expression or Id | Id => Expression + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then + Restore_Scan_State (Scan_State); -- to Id + Append (P_Discriminant_Association, Constr_List); + goto Loop_Continue; + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Otherwise scan out an expression and see what we have got + + Expr_Node := P_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + Append (Expr_Node, Constr_List); + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark required before RANGE"); + end if; + + Append (P_Subtype_Indication (Expr_Node), Constr_List); + goto Loop_Continue; + + -- Check Simple_Expression .. Simple_Expression case + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Constr_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Constr_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Constr_Node, Expr_Node); + Append (Constr_Node, Constr_List); + goto Loop_Continue; + + -- Case of an expression which could be either form + + else + Append (Expr_Node, Constr_List); + goto Loop_Continue; + end if; + + -- Here with a single entry scanned + + <<Loop_Continue>> + exit when not Comma_Present; + + end loop; + + T_Right_Paren; + return Result_Node; + + end P_Index_Or_Discriminant_Constraint; + + ------------------------------------- + -- 3.7.1 Discriminant Association -- + ------------------------------------- + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine is used only when the name list is present and the caller + -- has already checked this (by scanning ahead and repositioning the + -- scan). + + -- Error_Recovery: cannot raise Error_Resync; + + function P_Discriminant_Association return Node_Id is + Discr_Node : Node_Id; + Names_List : List_Id; + Ident_Sloc : Source_Ptr; + + begin + Ident_Sloc := Token_Ptr; + Names_List := New_List; + + loop + Append (P_Identifier, Names_List); + exit when Token /= Tok_Vertical_Bar; + Scan; -- past | + end loop; + + Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); + Set_Selector_Names (Discr_Node, Names_List); + TF_Arrow; + Set_Expression (Discr_Node, P_Expression); + return Discr_Node; + end P_Discriminant_Association; + + --------------------------------- + -- 3.8 Record Type Definition -- + --------------------------------- + + -- RECORD_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] RECORD_DEFINITION + + -- There is no node in the tree for a record type definition. Instead + -- a record definition node appears, with possible Abstract_Present, + -- Tagged_Present, and Limited_Present flags set appropriately. + + ---------------------------- + -- 3.8 Record Definition -- + ---------------------------- + + -- RECORD_DEFINITION ::= + -- record + -- COMPONENT_LIST + -- end record + -- | null record + + -- Note: in the case where a record definition node is used to represent + -- a record type definition, the caller sets the Tagged_Present and + -- Limited_Present flags in the resulting N_Record_Definition node as + -- required. + + -- Note that the RECORD token at the start may be missing in certain + -- error situations, so this function is expected to post the error + + -- Error recovery: can raise Error_Resync + + function P_Record_Definition return Node_Id is + Rec_Node : Node_Id; + + begin + Rec_Node := New_Node (N_Record_Definition, Token_Ptr); + + -- Null record case + + if Token = Tok_Null then + Scan; -- past NULL + T_Record; + Set_Null_Present (Rec_Node, True); + + -- Case starting with RECORD keyword. Build scope stack entry. For the + -- column, we use the first non-blank character on the line, to deal + -- with situations such as: + + -- type X is record + -- ... + -- end record; + + -- which is not official RM indentation, but is not uncommon usage + + else + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Record; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); + + T_Record; + + Set_Component_List (Rec_Node, P_Component_List); + + loop + exit when Check_End; + Discard_Junk_Node (P_Component_List); + end loop; + end if; + + return Rec_Node; + end P_Record_Definition; + + ------------------------- + -- 3.8 Component List -- + ------------------------- + + -- COMPONENT_LIST ::= + -- COMPONENT_ITEM {COMPONENT_ITEM} + -- | {COMPONENT_ITEM} VARIANT_PART + -- | null; + + -- Error recovery: cannot raise Error_Resync + + function P_Component_List return Node_Id is + Component_List_Node : Node_Id; + Decls_List : List_Id; + Scan_State : Saved_Scan_State; + + begin + Component_List_Node := New_Node (N_Component_List, Token_Ptr); + Decls_List := New_List; + + if Token = Tok_Null then + Scan; -- past NULL + TF_Semicolon; + P_Pragmas_Opt (Decls_List); + Set_Null_Present (Component_List_Node, True); + return Component_List_Node; + + else + P_Pragmas_Opt (Decls_List); + + if Token /= Tok_Case then + Component_Scan_Loop : loop + P_Component_Items (Decls_List); + P_Pragmas_Opt (Decls_List); + + exit Component_Scan_Loop when Token = Tok_End + or else Token = Tok_Case + or else Token = Tok_When; + + -- We are done if we do not have an identifier. However, if + -- we have a misspelled reserved identifier that is in a column + -- to the right of the record definition, we will treat it as + -- an identifier. It turns out to be too dangerous in practice + -- to accept such a mis-spelled identifier which does not have + -- this additional clue that confirms the incorrect spelling. + + if Token /= Tok_Identifier then + if Start_Column > Scope.Table (Scope.Last).Ecol + and then Is_Reserved_Identifier + then + Save_Scan_State (Scan_State); -- at reserved id + Scan; -- possible reserved id + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + + -- Note reserved identifier used as field name after + -- all because not followed by colon or comma + + else + Restore_Scan_State (Scan_State); + exit Component_Scan_Loop; + end if; + + -- Non-identifier that definitely was not reserved id + + else + exit Component_Scan_Loop; + end if; + end if; + end loop Component_Scan_Loop; + end if; + + if Token = Tok_Case then + Set_Variant_Part (Component_List_Node, P_Variant_Part); + + -- Check for junk after variant part + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("component may not follow variant part"); + Discard_Junk_Node (P_Component_List); + + elsif Token = Tok_Case then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("only one variant part allowed in a record"); + Discard_Junk_Node (P_Component_List); + + else + Restore_Scan_State (Scan_State); + end if; + end if; + end if; + end if; + + Set_Component_Items (Component_List_Node, Decls_List); + return Component_List_Node; + + end P_Component_List; + + ------------------------- + -- 3.8 Component Item -- + ------------------------- + + -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE + + -- COMPONENT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION + -- [:= DEFAULT_EXPRESSION]; + + -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION + + -- Error recovery: cannot raise Error_Resync, if an error occurs, + -- the scan is positioned past the following semicolon. + + -- Note: we do not yet allow representation clauses to appear as component + -- items, do we need to add this capability sometime in the future ??? + + procedure P_Component_Items (Decls : List_Id) is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token /= Tok_Identifier then + Error_Msg_SC ("component declaration expected"); + Resync_Past_Semicolon; + return; + end if; + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + + -- The following block is present to catch Error_Resync + -- which causes the parse to be reset past the semicolon + + begin + Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + + if Token = Tok_Constant then + Error_Msg_SC ("constant components are not permitted"); + Scan; + end if; + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Error_Msg_SC ("anonymous arrays not allowed as components"); + raise Error_Resync; + end if; + + Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); + Set_Expression (Decl_Node, Init_Expr_Opt); + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + Append (Decl_Node, Decls); + + exception + when Error_Resync => + if Token /= Tok_End then + Resync_Past_Semicolon; + end if; + end; + + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + + end loop Ident_Loop; + + TF_Semicolon; + + end P_Component_Items; + + -------------------------------- + -- 3.8 Component Declaration -- + -------------------------------- + + -- Parsed by P_Component_Items (3.8) + + ------------------------- + -- 3.8.1 Variant Part -- + ------------------------- + + -- VARIANT_PART ::= + -- case discriminant_DIRECT_NAME is + -- VARIANT + -- {VARIANT} + -- end case; + + -- The caller has checked that the initial token is CASE + + -- Error recovery: cannot raise Error_Resync + + function P_Variant_Part return Node_Id is + Variant_Part_Node : Node_Id; + Variants_List : List_Id; + Case_Node : Node_Id; + Case_Sloc : Source_Ptr; + + begin + Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Scan; -- past CASE + Case_Node := P_Expression; + Case_Sloc := Token_Ptr; + Set_Name (Variant_Part_Node, Case_Node); + + if Nkind (Case_Node) /= N_Identifier then + Set_Name (Variant_Part_Node, Error); + Error_Msg ("discriminant name expected", Sloc (Case_Node)); + end if; + + TF_Is; + Variants_List := New_List; + P_Pragmas_Opt (Variants_List); + + -- Test missing variant + + if Token = Tok_End then + Error_Msg_BC ("WHEN expected (must have at least one variant)"); + else + Append (P_Variant, Variants_List); + end if; + + -- Loop through variants, note that we allow if in place of when, + -- this error will be detected and handled in P_Variant. + + loop + P_Pragmas_Opt (Variants_List); + + if Token /= Tok_When + and then Token /= Tok_If + and then Token /= Tok_Others + then + exit when Check_End; + end if; + + Append (P_Variant, Variants_List); + end loop; + + Set_Variants (Variant_Part_Node, Variants_List); + return Variant_Part_Node; + + end P_Variant_Part; + + -------------------- + -- 3.8.1 Variant -- + -------------------- + + -- VARIANT ::= + -- when DISCRETE_CHOICE_LIST => + -- COMPONENT_LIST + + -- Error recovery: cannot raise Error_Resync + + -- The initial token on entry is either WHEN, IF or OTHERS + + function P_Variant return Node_Id is + Variant_Node : Node_Id; + + begin + -- Special check to recover nicely from use of IF in place of WHEN + + if Token = Tok_If then + T_When; + Scan; -- past IF + else + T_When; + end if; + + Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); + Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Component_List (Variant_Node, P_Component_List); + return Variant_Node; + end P_Variant; + + --------------------------------- + -- 3.8.1 Discrete Choice List -- + --------------------------------- + + -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} + + -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others + + -- Note: in Ada 83, the expression must be a simple expression + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Choice_List return List_Id is + Choices : List_Id; + Expr_Node : Node_Id; + Choice_Node : Node_Id; + + begin + Choices := New_List; + + loop + if Token = Tok_Others then + Append (New_Node (N_Others_Choice, Token_Ptr), Choices); + Scan; -- past OTHERS + + else + begin + Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute); + + if Token = Tok_Colon + and then Nkind (Expr_Node) = N_Identifier + then + Error_Msg_SP ("label not permitted in this context"); + Scan; -- past colon + + elsif Expr_Form = EF_Range_Attr then + Append (Expr_Node, Choices); + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Choice_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Choice_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Choice_Node, Expr_Node); + Append (Choice_Node, Choices); + + elsif Expr_Form = EF_Simple_Name then + if Token = Tok_Range then + Append (P_Subtype_Indication (Expr_Node), Choices); + + elsif Token in Token_Class_Consk then + Error_Msg_SC + ("the only constraint allowed here " & + "is a range constraint"); + Discard_Junk_Node (P_Constraint_Opt); + Append (Expr_Node, Choices); + + else + Append (Expr_Node, Choices); + end if; + + else + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Append (Expr_Node, Choices); + end if; + + exception + when Error_Resync => + Resync_Choice; + return Error_List; + end; + end if; + + if Token = Tok_Comma then + Error_Msg_SC (""","" should be ""|"""); + else + exit when Token /= Tok_Vertical_Bar; + end if; + + Scan; -- past | or comma + end loop; + + return Choices; + end P_Discrete_Choice_List; + + ---------------------------- + -- 3.8.1 Discrete Choice -- + ---------------------------- + + -- Parsed by P_Discrete_Choice_List (3.8.1) + + ---------------------------------- + -- 3.9.1 Record Extension Part -- + ---------------------------------- + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) + + ---------------------------------- + -- 3.10 Access Type Definition -- + ---------------------------------- + + -- ACCESS_TYPE_DEFINITION ::= + -- ACCESS_TO_OBJECT_DEFINITION + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -- ACCESS_TO_OBJECT_DEFINITION ::= + -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION + + -- GENERAL_ACCESS_MODIFIER ::= all | constant + + -- ACCESS_TO_SUBPROGRAM_DEFINITION + -- access [protected] procedure PARAMETER_PROFILE + -- | access [protected] function PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK + + -- The caller has checked that the initial token is ACCESS + + -- Error recovery: can raise Error_Resync + + function P_Access_Type_Definition return Node_Id is + Prot_Flag : Boolean; + Access_Loc : Source_Ptr; + Type_Def_Node : Node_Id; + + procedure Check_Junk_Subprogram_Name; + -- Used in access to subprogram definition cases to check for an + -- identifier or operator symbol that does not belong. + + procedure Check_Junk_Subprogram_Name is + Saved_State : Saved_Scan_State; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Save_Scan_State (Saved_State); + Scan; -- past possible junk subprogram name + + if Token = Tok_Left_Paren or else Token = Tok_Semicolon then + Error_Msg_SP ("unexpected subprogram name ignored"); + return; + + else + Restore_Scan_State (Saved_State); + end if; + end if; + end Check_Junk_Subprogram_Name; + + -- Start of processing for P_Access_Type_Definition + + begin + Access_Loc := Token_Ptr; + Scan; -- past ACCESS + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Procedure); + Check_95_Keyword (Tok_Protected, Tok_Function); + end if; + + Prot_Flag := (Token = Tok_Protected); + + if Prot_Flag then + Scan; -- past PROTECTED + if Token /= Tok_Procedure and then Token /= Tok_Function then + Error_Msg_SC ("FUNCTION or PROCEDURE expected"); + end if; + end if; + + if Token = Tok_Procedure then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); + Scan; -- past PROCEDURE + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + + elsif Token = Tok_Function then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access to function not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); + Scan; -- past FUNCTION + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + TF_Return; + Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark); + No_Constraint; + + else + Type_Def_Node := + New_Node (N_Access_To_Object_Definition, Access_Loc); + + if Token = Tok_All or else Token = Tok_Constant then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access modifier not allowed!"); + end if; + + if Token = Tok_All then + Set_All_Present (Type_Def_Node, True); + + else + Set_Constant_Present (Type_Def_Node, True); + end if; + + Scan; -- past ALL or CONSTANT + end if; + + Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication); + end if; + + return Type_Def_Node; + end P_Access_Type_Definition; + + --------------------------------------- + -- 3.10 Access To Object Definition -- + --------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------------- + -- 3.10 General Access Modifier -- + ----------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ------------------------------------------- + -- 3.10 Access To Subprogram Definition -- + ------------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------- + -- 3.10 Access Definition -- + ----------------------------- + + -- ACCESS_DEFINITION ::= access SUBTYPE_MARK + + -- The caller has checked that the initial token is ACCESS + + -- Error recovery: cannot raise Error_Resync + + function P_Access_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Access_Definition, Token_Ptr); + Scan; -- past ACCESS + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); + No_Constraint; + return Def_Node; + end P_Access_Definition; + + ----------------------------------------- + -- 3.10.1 Incomplete Type Declaration -- + ----------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.11 Declarative Part -- + ---------------------------- + + -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} + + -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items + -- handles errors, and returns cleanly after an error has occurred) + + function P_Declarative_Part return List_Id is + Decls : List_Id; + Done : Boolean; + + begin + -- Indicate no bad declarations detected yet. This will be reset by + -- P_Declarative_Items if a bad declaration is discovered. + + Missing_Begin_Msg := No_Error_Msg; + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + Decls := New_List; + + -- Loop to scan out the declarations + + loop + P_Declarative_Items (Decls, Done, In_Spec => False); + exit when Done; + end loop; + + -- Get rid of active SIS entry which is left set only if we scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a missing body case). + + SIS_Entry_Active := False; + return Decls; + end P_Declarative_Part; + + ---------------------------- + -- 3.11 Declarative Item -- + ---------------------------- + + -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY + + -- Can return Error if a junk declaration is found, or Empty if no + -- declaration is found (i.e. a token ending declarations, such as + -- BEGIN or END is encountered). + + -- Error recovery: cannot raise Error_Resync. If an error resync occurs, + -- then the scan is set past the next semicolon and Error is returned. + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Scan_State : Saved_Scan_State; + + begin + if Style_Check then Style.Check_Indentation; end if; + + case Token is + + when Tok_Function => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_For => + Check_Bad_Layout; + + -- Check for loop (premature statement) + + Save_Scan_State (Scan_State); + Scan; -- past FOR + + if Token = Tok_Identifier then + Scan; -- past identifier + + if Token = Tok_In then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + end if; + + -- Not a loop, so must be rep clause + + Restore_Scan_State (Scan_State); + Append (P_Representation_Clause, Decls); + Done := False; + + when Tok_Generic => + Check_Bad_Layout; + Append (P_Generic, Decls); + Done := False; + + when Tok_Identifier => + Check_Bad_Layout; + P_Identifier_Declarations (Decls, Done, In_Spec); + + when Tok_Package => + Check_Bad_Layout; + Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_Pragma => + Append (P_Pragma, Decls); + Done := False; + + when Tok_Procedure => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_Protected => + Check_Bad_Layout; + Scan; -- past PROTECTED + Append (P_Protected, Decls); + Done := False; + + when Tok_Subtype => + Check_Bad_Layout; + Append (P_Subtype_Declaration, Decls); + Done := False; + + when Tok_Task => + Check_Bad_Layout; + Scan; -- past TASK + Append (P_Task, Decls); + Done := False; + + when Tok_Type => + Check_Bad_Layout; + Append (P_Type_Declaration, Decls); + Done := False; + + when Tok_Use => + Check_Bad_Layout; + Append (P_Use_Clause, Decls); + Done := False; + + when Tok_With => + Check_Bad_Layout; + Error_Msg_SC ("WITH can only appear in context clause"); + raise Error_Resync; + + -- BEGIN terminates the scan of a sequence of declarations unless + -- there is a missing subprogram body, see section on handling + -- semicolon in place of IS. We only treat the begin as satisfying + -- the subprogram declaration if it falls in the expected column + -- or to its right. + + when Tok_Begin => + if SIS_Entry_Active and then Start_Column >= SIS_Ecol then + + -- Here we have the case where a BEGIN is encountered during + -- declarations in a declarative part, or at the outer level, + -- and there is a subprogram declaration outstanding for which + -- no body has been supplied. This is the case where we assume + -- that the semicolon in the subprogram declaration should + -- really have been is. The active SIS entry describes the + -- subprogram declaration. On return the declaration has been + -- modified to become a body. + + declare + Specification_Node : Node_Id; + Decl_Node : Node_Id; + Body_Node : Node_Id; + + begin + -- First issue the error message. If we had a missing + -- semicolon in the declaration, then change the message + -- 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; + + -- The next job is to fix up any declarations that occurred + -- between the procedure header and the BEGIN. These got + -- chained to the outer declarative region (immediately + -- after the procedure declaration) and they should be + -- chained to the subprogram itself, which is a body + -- rather than a spec. + + Specification_Node := Specification (SIS_Declaration_Node); + Change_Node (SIS_Declaration_Node, N_Subprogram_Body); + Body_Node := SIS_Declaration_Node; + Set_Specification (Body_Node, Specification_Node); + Set_Declarations (Body_Node, New_List); + + loop + Decl_Node := Remove_Next (Body_Node); + exit when Decl_Node = Empty; + Append (Decl_Node, Declarations (Body_Node)); + end loop; + + -- Now make the scope table entry for the Begin-End and + -- scan it out + + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := SIS_Sloc; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := SIS_Ecol; + Scope.Table (Scope.Last).Labl := SIS_Labl; + Scope.Table (Scope.Last).Lreq := False; + SIS_Entry_Active := False; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Body_Node, + P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Body_Node)); + end; + + Done := False; + + else + Done := True; + end if; + + -- Normally an END terminates the scan for basic declarative + -- items. The one exception is END RECORD, which is probably + -- left over from some other junk. + + when Tok_End => + Save_Scan_State (Scan_State); -- at END + Scan; -- past END + + if Token = Tok_Record then + Error_Msg_SP ("no RECORD for this `end record`!"); + Scan; -- past RECORD + TF_Semicolon; + + else + Restore_Scan_State (Scan_State); -- to END + Done := True; + end if; + + -- The following tokens which can only be the start of a statement + -- are considered to end a declarative part (i.e. we have a missing + -- BEGIN situation). We are fairly conservative in making this + -- judgment, because it is a real mess to go into statement mode + -- prematurely in reponse to a junk declaration. + + when Tok_Abort | + Tok_Accept | + Tok_Declare | + Tok_Delay | + Tok_Exit | + Tok_Goto | + Tok_If | + Tok_Loop | + Tok_Null | + Tok_Requeue | + Tok_Select | + Tok_While => + + -- But before we decide that it's a statement, let's check for + -- a reserved word misused as an identifier. + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + -- If reserved identifier not followed by colon or comma, then + -- this is most likely an assignment statement to the bad id. + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + + -- Otherwise we have a declaration of the bad id + + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + -- If not reserved identifier, then it's definitely a statement + + else + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- The token RETURN may well also signal a missing BEGIN situation, + -- however, we never let it end the declarative part, because it may + -- also be part of a half-baked function declaration. + + when Tok_Return => + Error_Msg_SC ("misplaced RETURN statement"); + raise Error_Resync; + + -- PRIVATE definitely terminates the declarations in a spec, + -- and is an error in a body. + + when Tok_Private => + if In_Spec then + Done := True; + else + Error_Msg_SC ("PRIVATE not allowed in body"); + Scan; -- past PRIVATE + end if; + + -- An end of file definitely terminates the declarations! + + when Tok_EOF => + Done := True; + + -- The remaining tokens do not end the scan, but cannot start a + -- valid declaration, so we signal an error and resynchronize. + -- But first check for misuse of a reserved identifier. + + when others => + + -- Here we check for a reserved identifier + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Set_Declaration_Expected; + raise Error_Resync; + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + Check_Bad_Layout; + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + else + Set_Declaration_Expected; + raise Error_Resync; + end if; + end case; + + -- To resynchronize after an error, we scan to the next semicolon and + -- return with Done = False, indicating that there may still be more + -- valid declarations to come. + + exception + when Error_Resync => + Resync_Past_Semicolon; + Done := False; + + end P_Declarative_Items; + + ---------------------------------- + -- 3.11 Basic Declarative Item -- + ---------------------------------- + + -- BASIC_DECLARATIVE_ITEM ::= + -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE + + -- Scan zero or more basic declarative items + + -- Error recovery: cannot raise Error_Resync. If an error is detected, then + -- the scan pointer is repositioned past the next semicolon, and the scan + -- for declarative items continues. + + function P_Basic_Declarative_Items return List_Id is + Decl : Node_Id; + Decls : List_Id; + Kind : Node_Kind; + Done : Boolean; + + begin + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan out declarations + + Decls := New_List; + + loop + P_Declarative_Items (Decls, Done, In_Spec => True); + exit when Done; + end loop; + + -- Get rid of active SIS entry. This is set only if we have scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a case of a missing body). + + SIS_Entry_Active := False; + + -- Test for assorted illegal declarations not diagnosed elsewhere. + + Decl := First (Decls); + + while Present (Decl) loop + Kind := Nkind (Decl); + + -- Test for body scanned, not acceptable as basic decl item + + if Kind = N_Subprogram_Body or else + Kind = N_Package_Body or else + Kind = N_Task_Body or else + Kind = N_Protected_Body + then + Error_Msg + ("proper body not allowed in package spec", Sloc (Decl)); + + -- Test for body stub scanned, not acceptable as basic decl item + + elsif Kind in N_Body_Stub then + Error_Msg + ("body stub not allowed in package spec", Sloc (Decl)); + + elsif Kind = N_Assignment_Statement then + Error_Msg + ("assignment statement not allowed in package spec", + Sloc (Decl)); + end if; + + Next (Decl); + end loop; + + return Decls; + end P_Basic_Declarative_Items; + + ---------------- + -- 3.11 Body -- + ---------------- + + -- For proper body, see below + -- For body stub, see 10.1.3 + + ----------------------- + -- 3.11 Proper Body -- + ----------------------- + + -- Subprogram body is parsed by P_Subprogram (6.1) + -- Package body is parsed by P_Package (7.1) + -- Task body is parsed by P_Task (9.1) + -- Protected body is parsed by P_Protected (9.4) + + ------------------------------ + -- Set_Declaration_Expected -- + ------------------------------ + + procedure Set_Declaration_Expected is + begin + Error_Msg_SC ("declaration expected"); + + if Missing_Begin_Msg = No_Error_Msg then + Missing_Begin_Msg := Get_Msg_Id; + end if; + end Set_Declaration_Expected; + + ---------------------- + -- Skip_Declaration -- + ---------------------- + + procedure Skip_Declaration (S : List_Id) is + Dummy_Done : Boolean; + + begin + P_Declarative_Items (S, Dummy_Done, False); + end Skip_Declaration; + + ----------------------------------------- + -- Statement_When_Declaration_Expected -- + ----------------------------------------- + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + begin + -- Case of second occurrence of statement in one declaration sequence + + if Missing_Begin_Msg /= No_Error_Msg then + + -- In the procedure spec case, just ignore it, we only give one + -- message for the first occurrence, since otherwise we may get + -- horrible cascading if BODY was missing in the header line. + + if In_Spec then + null; + + -- In the declarative part case, take a second statement as a sure + -- sign that we really have a missing BEGIN, and end the declarative + -- part now. Note that the caller will fix up the first message to + -- say "missing BEGIN" so that's how the error will be signalled. + + else + Done := True; + return; + end if; + + -- Case of first occurrence of unexpected statement + + else + -- If we are in a package spec, then give message of statement + -- not allowed in package spec. This message never gets changed. + + if In_Spec then + Error_Msg_SC ("statement not allowed in package spec"); + + -- If in declarative part, then we give the message complaining + -- about finding a statement when a declaration is expected. This + -- gets changed to a complaint about a missing BEGIN if we later + -- find that no BEGIN is present. + + else + Error_Msg_SC ("statement not allowed in declarative part"); + end if; + + -- Capture message Id. This is used for two purposes, first to + -- stop multiple messages, see test above, and second, to allow + -- the replacement of the message in the declarative part case. + + Missing_Begin_Msg := Get_Msg_Id; + end if; + + -- In all cases except the case in which we decided to terminate the + -- declaration sequence on a second error, we scan out the statement + -- and append it to the list of declarations (note that the semantics + -- can handle statements in a declaration list so if we proceed to + -- call the semantic phase, all will be (reasonably) well! + + Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); + + -- Done is set to False, since we want to continue the scan of + -- declarations, hoping that this statement was a temporary glitch. + -- If we indeed are now in the statement part (i.e. this was a missing + -- BEGIN, then it's not terrible, we will simply keep calling this + -- procedure to process the statements one by one, and then finally + -- hit the missing BEGIN, which will clean up the error message. + + Done := False; + + end Statement_When_Declaration_Expected; + +end Ch3; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb new file mode 100644 index 00000000000..30fba5619cc --- /dev/null +++ b/gcc/ada/par-ch4.adb @@ -0,0 +1,2298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.91 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch4 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Aggregate_Or_Paren_Expr return Node_Id; + function P_Allocator return Node_Id; + function P_Record_Or_Array_Component_Association return Node_Id; + function P_Factor return Node_Id; + function P_Primary return Node_Id; + function P_Relation return Node_Id; + function P_Term return Node_Id; + + function P_Binary_Adding_Operator return Node_Kind; + function P_Logical_Operator return Node_Kind; + function P_Multiplying_Operator return Node_Kind; + function P_Relational_Operator return Node_Kind; + function P_Unary_Adding_Operator return Node_Kind; + + procedure Bad_Range_Attribute (Loc : Source_Ptr); + -- Called to place complaint about bad range attribute at the given + -- source location. Terminates by raising Error_Resync. + + function P_Range_Attribute_Reference + (Prefix_Node : Node_Id) + return Node_Id; + -- Scan a range attribute reference. The caller has scanned out the + -- prefix. The current token is known to be an apostrophe and the + -- following token is known to be RANGE. + + procedure Set_Op_Name (Node : Node_Id); + -- Procedure to set name field (Chars) in operator node + + ------------------------- + -- Bad_Range_Attribute -- + ------------------------- + + procedure Bad_Range_Attribute (Loc : Source_Ptr) is + begin + Error_Msg ("range attribute cannot be used in expression", Loc); + Resync_Expression; + end Bad_Range_Attribute; + + ------------------ + -- Set_Op_Name -- + ------------------ + + procedure Set_Op_Name (Node : Node_Id) is + type Name_Of_Type is array (N_Op) of Name_Id; + Name_Of : Name_Of_Type := Name_Of_Type'( + N_Op_And => Name_Op_And, + N_Op_Or => Name_Op_Or, + N_Op_Xor => Name_Op_Xor, + N_Op_Eq => Name_Op_Eq, + N_Op_Ne => Name_Op_Ne, + N_Op_Lt => Name_Op_Lt, + N_Op_Le => Name_Op_Le, + N_Op_Gt => Name_Op_Gt, + N_Op_Ge => Name_Op_Ge, + N_Op_Add => Name_Op_Add, + N_Op_Subtract => Name_Op_Subtract, + N_Op_Concat => Name_Op_Concat, + N_Op_Multiply => Name_Op_Multiply, + N_Op_Divide => Name_Op_Divide, + N_Op_Mod => Name_Op_Mod, + N_Op_Rem => Name_Op_Rem, + N_Op_Expon => Name_Op_Expon, + N_Op_Plus => Name_Op_Add, + N_Op_Minus => Name_Op_Subtract, + N_Op_Abs => Name_Op_Abs, + N_Op_Not => Name_Op_Not, + + -- We don't really need these shift operators, since they never + -- appear as operators in the source, but the path of least + -- resistance is to put them in (the aggregate must be complete) + + N_Op_Rotate_Left => Name_Rotate_Left, + N_Op_Rotate_Right => Name_Rotate_Right, + N_Op_Shift_Left => Name_Shift_Left, + N_Op_Shift_Right => Name_Shift_Right, + N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); + + begin + if Nkind (Node) in N_Op then + Set_Chars (Node, Name_Of (Nkind (Node))); + end if; + end Set_Op_Name; + + -------------------------- + -- 4.1 Name (also 6.4) -- + -------------------------- + + -- NAME ::= + -- DIRECT_NAME | EXPLICIT_DEREFERENCE + -- | INDEXED_COMPONENT | SLICE + -- | SELECTED_COMPONENT | ATTRIBUTE + -- | TYPE_CONVERSION | FUNCTION_CALL + -- | CHARACTER_LITERAL + + -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL + + -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE + + -- EXPLICIT_DEREFERENCE ::= NAME . all + + -- IMPLICIT_DEREFERENCE ::= NAME + + -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) + + -- SLICE ::= PREFIX (DISCRETE_RANGE) + + -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME + + -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL + + -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR + + -- ATTRIBUTE_DESIGNATOR ::= + -- IDENTIFIER [(static_EXPRESSION)] + -- | access | delta | digits + + -- FUNCTION_CALL ::= + -- function_NAME + -- | function_PREFIX ACTUAL_PARAMETER_PART + + -- ACTUAL_PARAMETER_PART ::= + -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION}) + + -- PARAMETER_ASSOCIATION ::= + -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER + + -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME + + -- Note: syntactically a procedure call looks just like a function call, + -- so this routine is in practice used to scan out procedure calls as well. + + -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name + + -- Error recovery: can raise Error_Resync + + -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be + -- followed by either a left paren (qualified expression case), or by + -- range (range attribute case). All other uses of apostrophe (i.e. all + -- other attributes) are handled in this routine. + + -- Error recovery: can raise Error_Resync + + function P_Name return Node_Id is + Scan_State : Saved_Scan_State; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + Ident_Node : Node_Id; + Expr_Node : Node_Id; + Range_Node : Node_Id; + Arg_Node : Node_Id; + + Arg_List : List_Id := No_List; -- kill junk warning + Attr_Name : Name_Id := No_Name; -- kill junk warning + + begin + if Token not in Token_Class_Name then + Error_Msg_AP ("name expected"); + raise Error_Resync; + end if; + + -- Loop through designators in qualified name + + Name_Node := Token_Node; + + loop + Scan; -- past designator + exit when Token /= Tok_Dot; + Save_Scan_State (Scan_State); -- at dot + Scan; -- past dot + + -- If we do not have another designator after the dot, then join + -- the normal circuit to handle a dot extension (may be .all or + -- character literal case). Otherwise loop back to scan the next + -- designator. + + if Token not in Token_Class_Desig then + goto Scan_Name_Extension_Dot; + else + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + end if; + end loop; + + -- We have now scanned out a qualified designator. If the last token is + -- an operator symbol, then we certainly do not have the Snam case, so + -- we can just use the normal name extension check circuit + + if Prev_Token = Tok_Operator_Symbol then + goto Scan_Name_Extension; + end if; + + -- We have scanned out a qualified simple name, check for name extension + -- Note that we know there is no dot here at this stage, so the only + -- possible cases of name extension are apostrophe and left paren. + + if Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- If left paren, then this might be a qualified expression, but we + -- are only in the business of scanning out names, so return with + -- Token backed up to point to the apostrophe. The treatment for + -- the range attribute is similar (we do not consider x'range to + -- be a name in this grammar). + + if Token = Tok_Left_Paren or else Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Simple_Name; + return Name_Node; + + -- Otherwise we have the case of a name extended by an attribute + + else + goto Scan_Name_Extension_Apostrophe; + end if; + + -- Check case of qualified simple name extended by a left parenthesis + + elsif Token = Tok_Left_Paren then + Scan; -- past left paren + goto Scan_Name_Extension_Left_Paren; + + -- Otherwise the qualified simple name is not extended, so return + + else + Expr_Form := EF_Simple_Name; + return Name_Node; + end if; + + -- Loop scanning past name extensions. A label is used for control + -- transfer for this loop for ease of interfacing with the finite state + -- machine in the parenthesis scanning circuit, and also to allow for + -- passing in control to the appropriate point from the above code. + + <<Scan_Name_Extension>> + + -- Character literal used as name cannot be extended. Also this + -- cannot be a call, since the name for a call must be a designator. + -- Return in these cases, or if there is no name extension + + if Token not in Token_Class_Namext + or else Prev_Token = Tok_Char_Literal + then + Expr_Form := EF_Name; + return Name_Node; + end if; + + -- Merge here when we know there is a name extension + + <<Scan_Name_Extension_OK>> + + if Token = Tok_Left_Paren then + Scan; -- past left paren + goto Scan_Name_Extension_Left_Paren; + + elsif Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + goto Scan_Name_Extension_Apostrophe; + + else -- Token = Tok_Dot + Save_Scan_State (Scan_State); -- at dot + Scan; -- past dot + goto Scan_Name_Extension_Dot; + end if; + + -- Case of name extended by dot (selection), dot is already skipped + -- and the scan state at the point of the dot is saved in Scan_State. + + <<Scan_Name_Extension_Dot>> + + -- Explicit dereference case + + if Token = Tok_All then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Scan; -- past ALL + goto Scan_Name_Extension; + + -- Selected component case + + elsif Token in Token_Class_Name then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past selector + goto Scan_Name_Extension; + + -- Reserved identifier as selector + + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => False); + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past identifier used as selector + goto Scan_Name_Extension; + + -- If dot is at end of line and followed by nothing legal, + -- then assume end of name and quit (dot will be taken as + -- an erroneous form of some other punctuation by our caller). + + elsif Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); + return Name_Node; + + -- Here if nothing legal after the dot + + else + Error_Msg_AP ("selector expected"); + raise Error_Resync; + end if; + + -- Here for an apostrophe as name extension. The scan position at the + -- apostrophe has already been saved, and the apostrophe scanned out. + + <<Scan_Name_Extension_Apostrophe>> + + Scan_Apostrophe : declare + function Apostrophe_Should_Be_Semicolon return Boolean; + -- Checks for case where apostrophe should probably be + -- a semicolon, and if so, gives appropriate message, + -- resets the scan pointer to the apostrophe, changes + -- the current token to Tok_Semicolon, and returns True. + -- Otherwise returns False. + + function Apostrophe_Should_Be_Semicolon return Boolean is + begin + if Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); -- to apostrophe + Error_Msg_SC ("""''"" should be "";"""); + Token := Tok_Semicolon; + return True; + else + return False; + end if; + end Apostrophe_Should_Be_Semicolon; + + -- Start of processing for Scan_Apostrophe + + begin + -- If range attribute after apostrophe, then return with Token + -- pointing to the apostrophe. Note that in this case the prefix + -- need not be a simple name (cases like A.all'range). Similarly + -- if there is a left paren after the apostrophe, then we also + -- return with Token pointing to the apostrophe (this is the + -- qualified expression case). + + if Token = Tok_Range or else Token = Tok_Left_Paren then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Name; + return Name_Node; + + -- Here for cases where attribute designator is an identifier + + elsif Token = Tok_Identifier then + Attr_Name := Token_Name; + + if not Is_Attribute_Name (Attr_Name) then + if Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; + else + Signal_Bad_Attribute; + end if; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + Delete_Node (Token_Node); + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Attr_Name := Name_Delta; + + elsif Token = Tok_Digits then + Attr_Name := Name_Digits; + + elsif Token = Tok_Access then + Attr_Name := Name_Access; + + elsif Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- We come here with an OK attribute scanned, and the + -- corresponding Attribute identifier node stored in Ident_Node. + + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Scan; -- past attribute designator + Set_Prefix (Name_Node, Prefix_Node); + Set_Attribute_Name (Name_Node, Attr_Name); + + -- Scan attribute arguments/designator + + if Token = Tok_Left_Paren then + Set_Expressions (Name_Node, New_List); + Scan; -- past left paren + + loop + declare + Expr : constant Node_Id := P_Expression; + + begin + if Token = Tok_Arrow then + Error_Msg_SC + ("named parameters not permitted for attributes"); + Scan; -- past junk arrow + + else + Append (Expr, Expressions (Name_Node)); + exit when not Comma_Present; + end if; + end; + end loop; + + T_Right_Paren; + end if; + + goto Scan_Name_Extension; + end Scan_Apostrophe; + + -- Here for left parenthesis extending name (left paren skipped) + + <<Scan_Name_Extension_Left_Paren>> + + -- We now have to scan through a list of items, terminated by a + -- right parenthesis. The scan is handled by a finite state + -- machine. The possibilities are: + + -- (discrete_range) + + -- This is a slice. This case is handled in LP_State_Init. + + -- (expression, expression, ..) + + -- This is interpreted as an indexed component, i.e. as a + -- case of a name which can be extended in the normal manner. + -- This case is handled by LP_State_Name or LP_State_Expr. + + -- (..., identifier => expression , ...) + + -- If there is at least one occurence of identifier => (but + -- none of the other cases apply), then we have a call. + + -- Test for Id => case + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- Test for => (allow := as an error substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + Arg_List := New_List; + goto LP_State_Call; + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here we have an expression after all + + Expr_Node := P_Expression_Or_Range_Attribute; + + -- Check cases of discrete range for a slice + + -- First possibility: Range_Attribute_Reference + + if Expr_Form = EF_Range_Attr then + Range_Node := Expr_Node; + + -- Second possibility: Simple_expression .. Simple_expression + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + + -- Third possibility: Type_name range Range + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark must precede RANGE"); + raise Error_Resync; + end if; + + Range_Node := P_Subtype_Indication (Expr_Node); + + -- Otherwise we just have an expression. It is true that we might + -- have a subtype mark without a range constraint but this case + -- is syntactically indistinguishable from the expression case. + + else + Arg_List := New_List; + goto LP_State_Expr; + end if; + + -- Fall through here with unmistakable Discrete range scanned, + -- which means that we definitely have the case of a slice. The + -- Discrete range is in Range_Node. + + if Token = Tok_Comma then + Error_Msg_SC ("slice cannot have more than one dimension"); + raise Error_Resync; + + elsif Token /= Tok_Right_Paren then + T_Right_Paren; + raise Error_Resync; + + else + Scan; -- past right paren + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Slice, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Discrete_Range (Name_Node, Range_Node); + + -- An operator node is legal as a prefix to other names, + -- but not for a slice. + + if Nkind (Prefix_Node) = N_Operator_Symbol then + Error_Msg_N ("illegal prefix for slice", Prefix_Node); + end if; + + -- If we have a name extension, go scan it + + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; + + -- Otherwise return (a slice is a name, but is not a call) + + else + Expr_Form := EF_Name; + return Name_Node; + end if; + end if; + + -- In LP_State_Expr, we have scanned one or more expressions, and + -- so we have a call or an indexed component which is a name. On + -- entry we have the expression just scanned in Expr_Node and + -- Arg_List contains the list of expressions encountered so far + + <<LP_State_Expr>> + Append (Expr_Node, Arg_List); + + if Token = Tok_Arrow then + Error_Msg + ("expect identifier in parameter association", + Sloc (Expr_Node)); + Scan; -- past arrow. + + elsif not Comma_Present then + T_Right_Paren; + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Expressions (Name_Node, Arg_List); + goto Scan_Name_Extension; + end if; + + -- Comma present (and scanned out), test for identifier => case + -- Test for identifer => case + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- Test for => (allow := as error substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + goto LP_State_Call; + + -- Otherwise it's just an expression after all, so backup + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here we have an expression after all, so stay in this state + + Expr_Node := P_Expression; + goto LP_State_Expr; + + -- LP_State_Call corresponds to the situation in which at least + -- one instance of Id => Expression has been encountered, so we + -- know that we do not have a name, but rather a call. We enter + -- it with the scan pointer pointing to the next argument to scan, + -- and Arg_List containing the list of arguments scanned so far. + + <<LP_State_Call>> + + -- Test for case of Id => Expression (named parameter) + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Ident_Node := Token_Node; + Scan; -- past Id + + -- Deal with => (allow := as erroneous substitute) + + if Token = Tok_Arrow or else Token = Tok_Colon_Equal then + Arg_Node := + New_Node (N_Parameter_Association, Prev_Token_Ptr); + Set_Selector_Name (Arg_Node, Ident_Node); + T_Arrow; + Set_Explicit_Actual_Parameter (Arg_Node, P_Expression); + Append (Arg_Node, Arg_List); + + -- If a comma follows, go back and scan next entry + + if Comma_Present then + goto LP_State_Call; + + -- Otherwise we have the end of a call + + else + Prefix_Node := Name_Node; + Name_Node := + New_Node (N_Function_Call, Sloc (Prefix_Node)); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Arg_List); + T_Right_Paren; + + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; + + -- This is a case of a call which cannot be a name + + else + Expr_Form := EF_Name; + return Name_Node; + end if; + end if; + + -- Not named parameter: Id started an expression after all + + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Here if entry did not start with Id => which means that it + -- is a positional parameter, which is not allowed, since we + -- have seen at least one named parameter already. + + Error_Msg_SC + ("positional parameter association " & + "not allowed after named one"); + + Expr_Node := P_Expression; + + -- Leaving the '>' in an association is not unusual, so suggest + -- a possible fix. + + if Nkind (Expr_Node) = N_Op_Eq then + Error_Msg_N ("\maybe `=>` was intended", Expr_Node); + end if; + + -- We go back to scanning out expressions, so that we do not get + -- multiple error messages when several positional parameters + -- follow a named parameter. + + goto LP_State_Expr; + + -- End of treatment for name extensions starting with left paren + + -- End of loop through name extensions + + end P_Name; + + -- This function parses a restricted form of Names which are either + -- designators, or designators preceded by a sequence of prefixes + -- that are direct names. + + -- Error recovery: cannot raise Error_Resync + + function P_Function_Name return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + -- Prefix_Node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token not in Token_Class_Desig then + return P_Identifier; -- let P_Identifier issue the error message + + else -- Token in Token_Class_Desig + Scan; -- past designator + exit when Token /= Tok_Dot; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past dot + end loop; + + -- Fall out of the loop having just scanned a designator + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + + exception + when Error_Resync => + return Error; + + end P_Function_Name; + + -- This function parses a restricted form of Names which are either + -- identifiers, or identifiers preceded by a sequence of prefixes + -- that are direct names. + + -- Error recovery: cannot raise Error_Resync + + function P_Qualified_Simple_Name return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + -- Prefix node is set to the gathered prefix so far, Empty means that + -- no prefix has been scanned. This allows us to build up the result + -- in the required right recursive manner. + + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token = Tok_Identifier then + Scan; -- past identifier + exit when Token /= Tok_Dot; + + elsif Token not in Token_Class_Desig then + return P_Identifier; -- let P_Identifier issue the error message + + else + Scan; -- past designator + + if Token /= Tok_Dot then + Error_Msg_SP ("identifier expected"); + return Error; + end if; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past dot + end loop; + + -- Fall out of the loop having just scanned an identifier + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + + exception + when Error_Resync => + return Error; + + end P_Qualified_Simple_Name; + + -- This procedure differs from P_Qualified_Simple_Name only in that it + -- raises Error_Resync if any error is encountered. It only returns after + -- scanning a valid qualified simple name. + + -- Error recovery: can raise Error_Resync + + function P_Qualified_Simple_Name_Resync return Node_Id is + Designator_Node : Node_Id; + Prefix_Node : Node_Id; + Selector_Node : Node_Id; + Dot_Sloc : Source_Ptr := No_Location; + + begin + Prefix_Node := Empty; + + -- Loop through prefixes + + loop + Designator_Node := Token_Node; + + if Token = Tok_Identifier then + Scan; -- past identifier + exit when Token /= Tok_Dot; + + elsif Token not in Token_Class_Desig then + Discard_Junk_Node (P_Identifier); -- to issue the error message + raise Error_Resync; + + else + Scan; -- past designator + + if Token /= Tok_Dot then + Error_Msg_SP ("identifier expected"); + raise Error_Resync; + end if; + end if; + + -- Here at a dot, with token just before it in Designator_Node + + if No (Prefix_Node) then + Prefix_Node := Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + Prefix_Node := Selector_Node; + end if; + + Dot_Sloc := Token_Ptr; + Scan; -- past period + end loop; + + -- Fall out of the loop having just scanned an identifier + + if No (Prefix_Node) then + return Designator_Node; + else + Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); + Set_Prefix (Selector_Node, Prefix_Node); + Set_Selector_Name (Selector_Node, Designator_Node); + return Selector_Node; + end if; + + end P_Qualified_Simple_Name_Resync; + + ---------------------- + -- 4.1 Direct_Name -- + ---------------------- + + -- Parsed by P_Name and other functions in section 4.1 + + ----------------- + -- 4.1 Prefix -- + ----------------- + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Explicit Dereference -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Implicit_Dereference -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + ---------------------------- + -- 4.1 Indexed Component -- + ---------------------------- + + -- Parsed by P_Name (4.1) + + ---------------- + -- 4.1 Slice -- + ---------------- + + -- Parsed by P_Name (4.1) + + ----------------------------- + -- 4.1 Selected_Component -- + ----------------------------- + + -- Parsed by P_Name (4.1) + + ------------------------ + -- 4.1 Selector Name -- + ------------------------ + + -- Parsed by P_Name (4.1) + + ------------------------------ + -- 4.1 Attribute Reference -- + ------------------------------ + + -- Parsed by P_Name (4.1) + + ------------------------------- + -- 4.1 Attribute Designator -- + ------------------------------- + + -- Parsed by P_Name (4.1) + + -------------------------------------- + -- 4.1.4 Range Attribute Reference -- + -------------------------------------- + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- In the grammar, a RANGE attribute is simply a name, but its use is + -- highly restricted, so in the parser, we do not regard it as a name. + -- Instead, P_Name returns without scanning the 'RANGE part of the + -- attribute, and the caller uses the following function to construct + -- a range attribute in places where it is appropriate. + + -- Note that RANGE here is treated essentially as an identifier, + -- rather than a reserved word. + + -- The caller has parsed the prefix, i.e. a name, and Token points to + -- the apostrophe. The token after the apostrophe is known to be RANGE + -- at this point. The prefix node becomes the prefix of the attribute. + + -- Error_Recovery: Cannot raise Error_Resync + + function P_Range_Attribute_Reference + (Prefix_Node : Node_Id) + return Node_Id + is + Attr_Node : Node_Id; + + begin + Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr); + Set_Prefix (Attr_Node, Prefix_Node); + Scan; -- past apostrophe + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + + Set_Attribute_Name (Attr_Node, Name_Range); + Scan; -- past RANGE + + if Token = Tok_Left_Paren then + Scan; -- past left paren + Set_Expressions (Attr_Node, New_List (P_Expression)); + T_Right_Paren; + end if; + + return Attr_Node; + end P_Range_Attribute_Reference; + + --------------------------------------- + -- 4.1.4 Range Attribute Designator -- + --------------------------------------- + + -- Parsed by P_Range_Attribute_Reference (4.4) + + -------------------- + -- 4.3 Aggregate -- + -------------------- + + -- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where + -- an aggregate is known to be required (code statement, extension + -- aggregate), in which cases this routine performs the necessary check + -- that we have an aggregate rather than a parenthesized expression + + -- Error recovery: can raise Error_Resync + + function P_Aggregate return Node_Id is + Aggr_Sloc : constant Source_Ptr := Token_Ptr; + Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr; + + begin + if Nkind (Aggr_Node) /= N_Aggregate + and then + Nkind (Aggr_Node) /= N_Extension_Aggregate + then + Error_Msg + ("aggregate may not have single positional component", Aggr_Sloc); + return Error; + else + return Aggr_Node; + end if; + end P_Aggregate; + + ------------------------------------------------- + -- 4.3 Aggregate or Parenthesized Expresssion -- + ------------------------------------------------- + + -- This procedure parses out either an aggregate or a parenthesized + -- expression (these two constructs are closely related, since a + -- parenthesized expression looks like an aggregate with a single + -- positional component). + + -- AGGREGATE ::= + -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE + + -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) + + -- RECORD_COMPONENT_ASSOCIATION_LIST ::= + -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION} + -- | null record + + -- RECORD_COMPONENT_ASSOCIATION ::= + -- [COMPONENT_CHOICE_LIST =>] EXPRESSION + + -- COMPONENT_CHOICE_LIST ::= + -- component_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- EXTENSION_AGGREGATE ::= + -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST) + + -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK + + -- ARRAY_AGGREGATE ::= + -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE + + -- POSITIONAL_ARRAY_AGGREGATE ::= + -- (EXPRESSION, EXPRESSION {, EXPRESSION}) + -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION) + + -- NAMED_ARRAY_AGGREGATE ::= + -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) + + -- PRIMARY ::= (EXPRESSION); + + -- Error recovery: can raise Error_Resync + + function P_Aggregate_Or_Paren_Expr return Node_Id is + Aggregate_Node : Node_Id; + Expr_List : List_Id; + Assoc_List : List_Id; + Expr_Node : Node_Id; + Lparen_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + + begin + Lparen_Sloc := Token_Ptr; + T_Left_Paren; + + -- Note: the mechanism used here of rescanning the initial expression + -- is distinctly unpleasant, but it saves a lot of fiddling in scanning + -- out the discrete choice list. + + -- Deal with expression and extension aggregate cases first + + if Token /= Tok_Others then + Save_Scan_State (Scan_State); -- at start of expression + + -- Deal with (NULL RECORD) case + + if Token = Tok_Null then + Scan; -- past NULL + + if Token = Tok_Record then + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + Set_Null_Record_Present (Aggregate_Node, True); + Scan; -- past RECORD + T_Right_Paren; + return Aggregate_Node; + else + Restore_Scan_State (Scan_State); -- to NULL that must be expr + end if; + end if; + + Expr_Node := P_Expression_Or_Range_Attribute; + + -- Extension aggregate case + + if Token = Tok_With then + + if Nkind (Expr_Node) = N_Attribute_Reference + and then Attribute_Name (Expr_Node) = Name_Range + then + Bad_Range_Attribute (Sloc (Expr_Node)); + return Error; + end if; + + if Ada_83 then + Error_Msg_SC ("(Ada 83) extension aggregate not allowed"); + end if; + + Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc); + Set_Ancestor_Part (Aggregate_Node, Expr_Node); + Scan; -- past WITH + + -- Deal with WITH NULL RECORD case + + if Token = Tok_Null then + Save_Scan_State (Scan_State); -- at NULL + Scan; -- past NULL + + if Token = Tok_Record then + Scan; -- past RECORD + Set_Null_Record_Present (Aggregate_Node, True); + T_Right_Paren; + return Aggregate_Node; + + else + Restore_Scan_State (Scan_State); -- to NULL that must be expr + end if; + end if; + + if Token /= Tok_Others then + Save_Scan_State (Scan_State); + Expr_Node := P_Expression; + else + Expr_Node := Empty; + end if; + + -- Expression case + + elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then + + if Nkind (Expr_Node) = N_Attribute_Reference + and then Attribute_Name (Expr_Node) = Name_Range + then + Bad_Range_Attribute (Sloc (Expr_Node)); + return Error; + end if; + + -- Bump paren count of expression, note that if the paren count + -- is already at the maximum, then we leave it alone. This will + -- cause some failures in pathalogical conformance tests, which + -- we do not shed a tear over! + + if Expr_Node /= Error then + if Paren_Count (Expr_Node) /= Paren_Count_Type'Last then + Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1); + end if; + end if; + + T_Right_Paren; -- past right paren (error message if none) + return Expr_Node; + + -- Normal aggregate case + + else + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + end if; + + -- Others case + + else + Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); + Expr_Node := Empty; + end if; + + -- Prepare to scan list of component associations + + Expr_List := No_List; -- don't set yet, maybe all named entries + Assoc_List := No_List; -- don't set yet, maybe all positional entries + + -- This loop scans through component associations. On entry to the + -- loop, an expression has been scanned at the start of the current + -- association unless initial token was OTHERS, in which case + -- Expr_Node is set to Empty. + + loop + -- Deal with others association first. This is a named association + + if No (Expr_Node) then + if No (Assoc_List) then + Assoc_List := New_List; + end if; + + Append (P_Record_Or_Array_Component_Association, Assoc_List); + + -- Improper use of WITH + + elsif Token = Tok_With then + Error_Msg_SC ("WITH must be preceded by single expression in " & + "extension aggregate"); + raise Error_Resync; + + -- Assume positional case if comma, right paren, or literal or + -- identifier or OTHERS follows (the latter cases are missing + -- comma cases). Also assume positional if a semicolon follows, + -- which can happen if there are missing parens + + elsif Token = Tok_Comma + or else Token = Tok_Right_Paren + or else Token = Tok_Others + or else Token in Token_Class_Lit_Or_Name + or else Token = Tok_Semicolon + then + if Present (Assoc_List) then + Error_Msg_BC + ("""=>"" expected (positional association cannot follow " & + "named association)"); + end if; + + if No (Expr_List) then + Expr_List := New_List; + end if; + + Append (Expr_Node, Expr_List); + + -- Anything else is assumed to be a named association + + else + Restore_Scan_State (Scan_State); -- to start of expression + + if No (Assoc_List) then + Assoc_List := New_List; + end if; + + Append (P_Record_Or_Array_Component_Association, Assoc_List); + end if; + + exit when not Comma_Present; + + -- If we are at an expression terminator, something is seriously + -- wrong, so let's get out now, before we start eating up stuff + -- that doesn't belong to us! + + if Token in Token_Class_Eterm then + Error_Msg_AP ("expecting expression or component association"); + exit; + end if; + + -- Otherwise initiate for reentry to top of loop by scanning an + -- initial expression, unless the first token is OTHERS. + + if Token = Tok_Others then + Expr_Node := Empty; + else + Save_Scan_State (Scan_State); -- at start of expression + Expr_Node := P_Expression; + end if; + end loop; + + -- All component associations (positional and named) have been scanned + + T_Right_Paren; + Set_Expressions (Aggregate_Node, Expr_List); + Set_Component_Associations (Aggregate_Node, Assoc_List); + return Aggregate_Node; + end P_Aggregate_Or_Paren_Expr; + + ------------------------------------------------ + -- 4.3 Record or Array Component Association -- + ------------------------------------------------ + + -- RECORD_COMPONENT_ASSOCIATION ::= + -- [COMPONENT_CHOICE_LIST =>] EXPRESSION + + -- COMPONENT_CHOICE_LIST => + -- component_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- ARRAY_COMPONENT_ASSOCIATION ::= + -- DISCRETE_CHOICE_LIST => EXPRESSION + + -- Note: this routine only handles the named cases, including others. + -- Cases where the component choice list is not present have already + -- been handled directly. + + -- Error recovery: can raise Error_Resync + + function P_Record_Or_Array_Component_Association return Node_Id is + Assoc_Node : Node_Id; + + begin + Assoc_Node := New_Node (N_Component_Association, Token_Ptr); + Set_Choices (Assoc_Node, P_Discrete_Choice_List); + Set_Sloc (Assoc_Node, Token_Ptr); + TF_Arrow; + Set_Expression (Assoc_Node, P_Expression); + return Assoc_Node; + end P_Record_Or_Array_Component_Association; + + ----------------------------- + -- 4.3.1 Record Aggregate -- + ----------------------------- + + -- Case of enumeration aggregate is parsed by P_Aggregate (4.3) + -- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------------------- + -- 4.3.1 Record Component Association List -- + ---------------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------- + -- 4.3.1 Component Choice List -- + ---------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + -------------------------------- + -- 4.3.1 Extension Aggregate -- + -------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + -------------------------- + -- 4.3.1 Ancestor Part -- + -------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------- + -- 4.3.1 Array Aggregate -- + ---------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + --------------------------------------- + -- 4.3.1 Positional Array Aggregate -- + --------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------- + -- 4.3.1 Named Array Aggregate -- + ---------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + ---------------------------------------- + -- 4.3.1 Array Component Association -- + ---------------------------------------- + + -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) + + --------------------- + -- 4.4 Expression -- + --------------------- + + -- EXPRESSION ::= + -- RELATION {and RELATION} | RELATION {and then RELATION} + -- | RELATION {or RELATION} | RELATION {or else RELATION} + -- | RELATION {xor RELATION} + + -- On return, Expr_Form indicates the categorization of the expression + -- EF_Range_Attr is not a possible value (if a range attribute is found, + -- an error message is given, and Error is returned). + + -- Error recovery: cannot raise Error_Resync + + function P_Expression return Node_Id is + Logical_Op : Node_Kind; + Prev_Logical_Op : Node_Kind; + Op_Location : Source_Ptr; + Node1 : Node_Id; + Node2 : Node_Id; + + begin + Node1 := P_Relation; + + if Token in Token_Class_Logop then + Prev_Logical_Op := N_Empty; + + loop + Op_Location := Token_Ptr; + Logical_Op := P_Logical_Operator; + + if Prev_Logical_Op /= N_Empty and then + Logical_Op /= Prev_Logical_Op + then + Error_Msg + ("mixed logical operators in expression", Op_Location); + Prev_Logical_Op := N_Empty; + else + Prev_Logical_Op := Logical_Op; + end if; + + Node2 := Node1; + Node1 := New_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + Set_Op_Name (Node1); + exit when Token not in Token_Class_Logop; + end loop; + + Expr_Form := EF_Non_Simple; + end if; + + if Token = Tok_Apostrophe then + Bad_Range_Attribute (Token_Ptr); + return Error; + else + return Node1; + end if; + + end P_Expression; + + -- This function is identical to the normal P_Expression, except that it + -- checks that the expression scan did not stop on a right paren. It is + -- called in all contexts where a right parenthesis cannot legitimately + -- follow an expression. + + function P_Expression_No_Right_Paren return Node_Id is + begin + return No_Right_Paren (P_Expression); + end P_Expression_No_Right_Paren; + + ---------------------------------------- + -- 4.4 Expression_Or_Range_Attribute -- + ---------------------------------------- + + -- EXPRESSION ::= + -- RELATION {and RELATION} | RELATION {and then RELATION} + -- | RELATION {or RELATION} | RELATION {or else RELATION} + -- | RELATION {xor RELATION} + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- On return, Expr_Form indicates the categorization of the expression + -- and EF_Range_Attr is one of the possibilities. + + -- Error recovery: cannot raise Error_Resync + + -- In the grammar, a RANGE attribute is simply a name, but its use is + -- highly restricted, so in the parser, we do not regard it as a name. + -- Instead, P_Name returns without scanning the 'RANGE part of the + -- attribute, and P_Expression_Or_Range_Attribute handles the range + -- attribute reference. In the normal case where a range attribute is + -- not allowed, an error message is issued by P_Expression. + + function P_Expression_Or_Range_Attribute return Node_Id is + Logical_Op : Node_Kind; + Prev_Logical_Op : Node_Kind; + Op_Location : Source_Ptr; + Node1 : Node_Id; + Node2 : Node_Id; + Attr_Node : Node_Id; + + begin + Node1 := P_Relation; + + if Token = Tok_Apostrophe then + Attr_Node := P_Range_Attribute_Reference (Node1); + Expr_Form := EF_Range_Attr; + return Attr_Node; + + elsif Token in Token_Class_Logop then + Prev_Logical_Op := N_Empty; + + loop + Op_Location := Token_Ptr; + Logical_Op := P_Logical_Operator; + + if Prev_Logical_Op /= N_Empty and then + Logical_Op /= Prev_Logical_Op + then + Error_Msg + ("mixed logical operators in expression", Op_Location); + Prev_Logical_Op := N_Empty; + else + Prev_Logical_Op := Logical_Op; + end if; + + Node2 := Node1; + Node1 := New_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + Set_Op_Name (Node1); + exit when Token not in Token_Class_Logop; + end loop; + + Expr_Form := EF_Non_Simple; + end if; + + if Token = Tok_Apostrophe then + Bad_Range_Attribute (Token_Ptr); + return Error; + else + return Node1; + end if; + end P_Expression_Or_Range_Attribute; + + ------------------- + -- 4.4 Relation -- + ------------------- + + -- RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + -- | SIMPLE_EXPRESSION [not] in RANGE + -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK + + -- On return, Expr_Form indicates the categorization of the expression + + -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to + -- EF_Simple_Name and the following token is RANGE (range attribute case). + + -- Error recovery: cannot raise Error_Resync. If an error occurs within an + -- expression, then tokens are scanned until either a non-expression token, + -- a right paren (not matched by a left paren) or a comma, is encountered. + + function P_Relation return Node_Id is + Node1, Node2 : Node_Id; + Optok : Source_Ptr; + + begin + Node1 := P_Simple_Expression; + + if Token not in Token_Class_Relop then + return Node1; + + else + -- Here we have a relational operator following. If so then scan it + -- out. Note that the assignment symbol := is treated as a relational + -- operator to improve the error recovery when it is misused for =. + -- P_Relational_Operator also parses the IN and NOT IN operations. + + Optok := Token_Ptr; + Node2 := New_Node (P_Relational_Operator, Optok); + Set_Left_Opnd (Node2, Node1); + Set_Op_Name (Node2); + + -- Case of IN or NOT IN + + if Prev_Token = Tok_In then + Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark); + + -- Case of relational operator (= /= < <= > >=) + + else + Set_Right_Opnd (Node2, P_Simple_Expression); + end if; + + Expr_Form := EF_Non_Simple; + + if Token in Token_Class_Relop then + Error_Msg_SC ("unexpected relational operator"); + raise Error_Resync; + end if; + + return Node2; + end if; + + -- If any error occurs, then scan to the next expression terminator symbol + -- or comma or right paren at the outer (i.e. current) parentheses level. + -- The flags are set to indicate a normal simple expression. + + exception + when Error_Resync => + Resync_Expression; + Expr_Form := EF_Simple; + return Error; + end P_Relation; + + ---------------------------- + -- 4.4 Simple Expression -- + ---------------------------- + + -- SIMPLE_EXPRESSION ::= + -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} + + -- On return, Expr_Form indicates the categorization of the expression + + -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to + -- EF_Simple_Name and the following token is RANGE (range attribute case). + + -- Error recovery: cannot raise Error_Resync. If an error occurs within an + -- expression, then tokens are scanned until either a non-expression token, + -- a right paren (not matched by a left paren) or a comma, is encountered. + + -- Note: P_Simple_Expression is called only internally by higher level + -- expression routines. In cases in the grammar where a simple expression + -- is required, the approach is to scan an expression, and then post an + -- appropriate error message if the expression obtained is not simple. This + -- gives better error recovery and treatment. + + function P_Simple_Expression return Node_Id is + Scan_State : Saved_Scan_State; + Node1 : Node_Id; + Node2 : Node_Id; + Tokptr : Source_Ptr; + + begin + -- Check for cases starting with a name. There are two reasons for + -- special casing. First speed things up by catching a common case + -- without going through several routine layers. Second the caller must + -- be informed via Expr_Form when the simple expression is a name. + + if Token in Token_Class_Name then + Node1 := P_Name; + + -- Deal with apostrophe cases + + if Token = Tok_Apostrophe then + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- If qualified expression, scan it out and fall through + + if Token = Tok_Left_Paren then + Node1 := P_Qualified_Expression (Node1); + Expr_Form := EF_Simple; + + -- If range attribute, then we return with Token pointing to the + -- apostrophe. Note: avoid the normal error check on exit. We + -- know that the expression really is complete in this case! + + else -- Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Simple_Name; + return Node1; + end if; + end if; + + -- If an expression terminator follows, the previous processing + -- completely scanned out the expression (a common case), and + -- left Expr_Form set appropriately for returning to our caller. + + if Token in Token_Class_Sterm then + null; + + -- If we do not have an expression terminator, then complete the + -- scan of a simple expression. This code duplicates the code + -- found in P_Term and P_Factor. + + else + if Token = Tok_Double_Asterisk then + if Style_Check then Style.Check_Exponentiation_Operator; end if; + Node2 := New_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + Set_Op_Name (Node2); + Node1 := Node2; + end if; + + loop + exit when Token not in Token_Class_Mulop; + Tokptr := Token_Ptr; + Node2 := New_Node (P_Multiplying_Operator, Tokptr); + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Factor); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + loop + exit when Token not in Token_Class_Binary_Addop; + Tokptr := Token_Ptr; + Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Term); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + Expr_Form := EF_Simple; + end if; + + -- Cases where simple expression does not start with a name + + else + -- Scan initial sign and initial Term + + if Token in Token_Class_Unary_Addop then + Tokptr := Token_Ptr; + Node1 := New_Node (P_Unary_Adding_Operator, Tokptr); + if Style_Check then Style.Check_Unary_Plus_Or_Minus; end if; + Scan; -- past operator + Set_Right_Opnd (Node1, P_Term); + Set_Op_Name (Node1); + else + Node1 := P_Term; + end if; + + -- Scan out sequence of terms separated by binary adding operators + + loop + exit when Token not in Token_Class_Binary_Addop; + Tokptr := Token_Ptr; + Node2 := New_Node (P_Binary_Adding_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Term); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + -- All done, we clearly do not have name or numeric literal so this + -- is a case of a simple expression which is some other possibility. + + Expr_Form := EF_Simple; + end if; + + -- Come here at end of simple expression, where we do a couple of + -- special checks to improve error recovery. + + -- Special test to improve error recovery. If the current token + -- is a period, then someone is trying to do selection on something + -- that is not a name, e.g. a qualified expression. + + if Token = Tok_Dot then + Error_Msg_SC ("prefix for selection is not a name"); + raise Error_Resync; + end if; + + -- Special test to improve error recovery: If the current token is + -- not the first token on a line (as determined by checking the + -- previous token position with the start of the current line), + -- then we insist that we have an appropriate terminating token. + -- Consider the following two examples: + + -- 1) if A nad B then ... + + -- 2) A := B + -- C := D + + -- In the first example, we would like to issue a binary operator + -- expected message and resynchronize to the then. In the second + -- example, we do not want to issue a binary operator message, so + -- that instead we will get the missing semicolon message. This + -- distinction is of course a heuristic which does not always work, + -- but in practice it is quite effective. + + -- Note: the one case in which we do not go through this circuit is + -- when we have scanned a range attribute and want to return with + -- Token pointing to the apostrophe. The apostrophe is not normally + -- an expression terminator, and is not in Token_Class_Sterm, but + -- in this special case we know that the expression is complete. + + if not Token_Is_At_Start_Of_Line + and then Token not in Token_Class_Sterm + then + Error_Msg_AP ("binary operator expected"); + raise Error_Resync; + else + return Node1; + end if; + + -- If any error occurs, then scan to next expression terminator symbol + -- or comma, right paren or vertical bar at the outer (i.e. current) paren + -- level. Expr_Form is set to indicate a normal simple expression. + + exception + when Error_Resync => + Resync_Expression; + Expr_Form := EF_Simple; + return Error; + + end P_Simple_Expression; + + ----------------------------------------------- + -- 4.4 Simple Expression or Range Attribute -- + ----------------------------------------------- + + -- SIMPLE_EXPRESSION ::= + -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} + + -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR + + -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)] + + -- Error recovery: cannot raise Error_Resync + + function P_Simple_Expression_Or_Range_Attribute return Node_Id is + Sexpr : Node_Id; + Attr_Node : Node_Id; + + begin + Sexpr := P_Simple_Expression; + + if Token = Tok_Apostrophe then + Attr_Node := P_Range_Attribute_Reference (Sexpr); + Expr_Form := EF_Range_Attr; + return Attr_Node; + + else + return Sexpr; + end if; + end P_Simple_Expression_Or_Range_Attribute; + + --------------- + -- 4.4 Term -- + --------------- + + -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR} + + -- Error recovery: can raise Error_Resync + + function P_Term return Node_Id is + Node1, Node2 : Node_Id; + Tokptr : Source_Ptr; + + begin + Node1 := P_Factor; + + loop + exit when Token not in Token_Class_Mulop; + Tokptr := Token_Ptr; + Node2 := New_Node (P_Multiplying_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Factor); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + return Node1; + end P_Term; + + ----------------- + -- 4.4 Factor -- + ----------------- + + -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY + + -- Error recovery: can raise Error_Resync + + function P_Factor return Node_Id is + Node1 : Node_Id; + Node2 : Node_Id; + + begin + if Token = Tok_Abs then + Node1 := New_Node (N_Op_Abs, Token_Ptr); + if Style_Check then Style.Check_Abs_Not; end if; + Scan; -- past ABS + Set_Right_Opnd (Node1, P_Primary); + Set_Op_Name (Node1); + return Node1; + + elsif Token = Tok_Not then + Node1 := New_Node (N_Op_Not, Token_Ptr); + if Style_Check then Style.Check_Abs_Not; end if; + Scan; -- past NOT + Set_Right_Opnd (Node1, P_Primary); + Set_Op_Name (Node1); + return Node1; + + else + Node1 := P_Primary; + + if Token = Tok_Double_Asterisk then + Node2 := New_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + Set_Op_Name (Node2); + return Node2; + else + return Node1; + end if; + end if; + end P_Factor; + + ------------------ + -- 4.4 Primary -- + ------------------ + + -- PRIMARY ::= + -- NUMERIC_LITERAL | null + -- | STRING_LITERAL | AGGREGATE + -- | NAME | QUALIFIED_EXPRESSION + -- | ALLOCATOR | (EXPRESSION) + + -- Error recovery: can raise Error_Resync + + function P_Primary return Node_Id is + Scan_State : Saved_Scan_State; + Node1 : Node_Id; + + begin + -- The loop runs more than once only if misplaced pragmas are found + + loop + case Token is + + -- Name token can start a name, call or qualified expression, all + -- of which are acceptable possibilities for primary. Note also + -- that string literal is included in name (as operator symbol) + -- and type conversion is included in name (as indexed component). + + when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier => + Node1 := P_Name; + + -- All done unless apostrophe follows + + if Token /= Tok_Apostrophe then + return Node1; + + -- Apostrophe following means that we have either just parsed + -- the subtype mark of a qualified expression, or the prefix + -- or a range attribute. + + else -- Token = Tok_Apostrophe + Save_Scan_State (Scan_State); -- at apostrophe + Scan; -- past apostrophe + + -- If range attribute, then this is always an error, since + -- the only legitimate case (where the scanned expression is + -- a qualified simple name) is handled at the level of the + -- Simple_Expression processing. This case corresponds to a + -- usage such as 3 + A'Range, which is always illegal. + + if Token = Tok_Range then + Restore_Scan_State (Scan_State); -- to apostrophe + Bad_Range_Attribute (Token_Ptr); + return Error; + + -- If left paren, then we have a qualified expression. + -- Note that P_Name guarantees that in this case, where + -- Token = Tok_Apostrophe on return, the only two possible + -- tokens following the apostrophe are left paren and + -- RANGE, so we know we have a left paren here. + + else -- Token = Tok_Left_Paren + return P_Qualified_Expression (Node1); + + end if; + end if; + + -- Numeric or string literal + + when Tok_Integer_Literal | + Tok_Real_Literal | + Tok_String_Literal => + + Node1 := Token_Node; + Scan; -- past number + return Node1; + + -- Left paren, starts aggregate or parenthesized expression + + when Tok_Left_Paren => + return P_Aggregate_Or_Paren_Expr; + + -- Allocator + + when Tok_New => + return P_Allocator; + + -- Null + + when Tok_Null => + Scan; -- past NULL + return New_Node (N_Null, Prev_Token_Ptr); + + -- Pragma, not allowed here, so just skip past it + + when Tok_Pragma => + P_Pragmas_Misplaced; + + -- Anything else is illegal as the first token of a primary, but + -- we test for a reserved identifier so that it is treated nicely + + when others => + if Is_Reserved_Identifier then + return P_Identifier; + + elsif Prev_Token = Tok_Comma then + Error_Msg_SP ("extra "","" ignored"); + raise Error_Resync; + + else + Error_Msg_AP ("missing operand"); + raise Error_Resync; + end if; + + end case; + end loop; + end P_Primary; + + --------------------------- + -- 4.5 Logical Operator -- + --------------------------- + + -- LOGICAL_OPERATOR ::= and | or | xor + + -- Note: AND THEN and OR ELSE are also treated as logical operators + -- by the parser (even though they are not operators semantically) + + -- The value returned is the appropriate Node_Kind code for the operator + -- On return, Token points to the token following the scanned operator. + + -- The caller has checked that the first token is a legitimate logical + -- operator token (i.e. is either XOR, AND, OR). + + -- Error recovery: cannot raise Error_Resync + + function P_Logical_Operator return Node_Kind is + begin + if Token = Tok_And then + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past AND + + if Token = Tok_Then then + Scan; -- past THEN + return N_And_Then; + else + return N_Op_And; + end if; + + elsif Token = Tok_Or then + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past OR + + if Token = Tok_Else then + Scan; -- past ELSE + return N_Or_Else; + else + return N_Op_Or; + end if; + + else -- Token = Tok_Xor + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past XOR + return N_Op_Xor; + end if; + end P_Logical_Operator; + + ------------------------------ + -- 4.5 Relational Operator -- + ------------------------------ + + -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >= + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token, NOT past it. + + -- The caller has checked that the first token is a legitimate relational + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Relational_Operator return Node_Kind is + Op_Kind : Node_Kind; + Relop_Node : constant array (Token_Class_Relop) of Node_Kind := + (Tok_Less => N_Op_Lt, + Tok_Equal => N_Op_Eq, + Tok_Greater => N_Op_Gt, + Tok_Not_Equal => N_Op_Ne, + Tok_Greater_Equal => N_Op_Ge, + Tok_Less_Equal => N_Op_Le, + Tok_In => N_In, + Tok_Not => N_Not_In, + Tok_Box => N_Op_Ne); + + begin + if Token = Tok_Box then + Error_Msg_SC ("""<>"" should be ""/="""); + end if; + + Op_Kind := Relop_Node (Token); + if Style_Check then Style.Check_Binary_Operator; end if; + Scan; -- past operator token + + if Prev_Token = Tok_Not then + T_In; + end if; + + return Op_Kind; + end P_Relational_Operator; + + --------------------------------- + -- 4.5 Binary Adding Operator -- + --------------------------------- + + -- BINARY_ADDING_OPERATOR ::= + | - | & + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate adding + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Binary_Adding_Operator return Node_Kind is + Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind := + (Tok_Ampersand => N_Op_Concat, + Tok_Minus => N_Op_Subtract, + Tok_Plus => N_Op_Add); + begin + return Addop_Node (Token); + end P_Binary_Adding_Operator; + + -------------------------------- + -- 4.5 Unary Adding Operator -- + -------------------------------- + + -- UNARY_ADDING_OPERATOR ::= + | - + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate adding + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Unary_Adding_Operator return Node_Kind is + Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind := + (Tok_Minus => N_Op_Minus, + Tok_Plus => N_Op_Plus); + begin + return Addop_Node (Token); + end P_Unary_Adding_Operator; + + ------------------------------- + -- 4.5 Multiplying Operator -- + ------------------------------- + + -- MULTIPLYING_OPERATOR ::= * | / | mod | rem + + -- The value returned is the appropriate Node_Kind code for the operator. + -- On return, Token points to the operator token (NOT past it). + + -- The caller has checked that the first token is a legitimate multiplying + -- operator token (i.e. is one of the operator tokens listed above). + + -- Error recovery: cannot raise Error_Resync + + function P_Multiplying_Operator return Node_Kind is + Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind := + (Tok_Asterisk => N_Op_Multiply, + Tok_Mod => N_Op_Mod, + Tok_Rem => N_Op_Rem, + Tok_Slash => N_Op_Divide); + begin + return Mulop_Node (Token); + end P_Multiplying_Operator; + + -------------------------------------- + -- 4.5 Highest Precedence Operator -- + -------------------------------------- + + -- Parsed by P_Factor (4.4) + + -- Note: this rule is not in fact used by the grammar at any point! + + -------------------------- + -- 4.6 Type Conversion -- + -------------------------- + + -- Parsed by P_Primary as a Name (4.1) + + ------------------------------- + -- 4.7 Qualified Expression -- + ------------------------------- + + -- QUALIFIED_EXPRESSION ::= + -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE + + -- The caller has scanned the name which is the Subtype_Mark parameter + -- and scanned past the single quote following the subtype mark. The + -- caller has not checked that this name is in fact appropriate for + -- a subtype mark name (i.e. it is a selected component or identifier). + + -- Error_Recovery: cannot raise Error_Resync + + function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is + Qual_Node : Node_Id; + + begin + Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr); + Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr); + return Qual_Node; + end P_Qualified_Expression; + + -------------------- + -- 4.8 Allocator -- + -------------------- + + -- ALLOCATOR ::= + -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + + -- The caller has checked that the initial token is NEW + + -- Error recovery: can raise Error_Resync + + function P_Allocator return Node_Id is + Alloc_Node : Node_Id; + Type_Node : Node_Id; + + begin + Alloc_Node := New_Node (N_Allocator, Token_Ptr); + T_New; + Type_Node := P_Subtype_Mark_Resync; + + if Token = Tok_Apostrophe then + Scan; -- past apostrophe + Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node)); + else + Set_Expression (Alloc_Node, P_Subtype_Indication (Type_Node)); + end if; + + return Alloc_Node; + end P_Allocator; + +end Ch4; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb new file mode 100644 index 00000000000..2ec56726e6b --- /dev/null +++ b/gcc/ada/par-ch5.adb @@ -0,0 +1,2184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.95 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch5 is + + -- Local functions, used only in this chapter + + function P_Case_Statement return Node_Id; + function P_Case_Statement_Alternative return Node_Id; + function P_Condition return Node_Id; + function P_Exit_Statement return Node_Id; + function P_Goto_Statement return Node_Id; + function P_If_Statement return Node_Id; + function P_Label return Node_Id; + function P_Loop_Parameter_Specification return Node_Id; + function P_Null_Statement return Node_Id; + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id; + -- Parse assignment statement. On entry, the caller has scanned the left + -- hand side (passed in as Lhs), and the colon-equal (or some symbol + -- taken to be an error equivalent such as equal). + + function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id; + -- Parse declare block. If Block_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the block. If Block_Name is + -- Empty on entry (the default), then the block statement is unlabeled. + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse for statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the for statement is unlabeled. + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse loop statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the loop statement is unlabeled. + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id; + -- Parse while statement. If Loop_Name is non-Empty on entry, it is + -- the N_Identifier node for the label on the loop. If Loop_Name is + -- Empty on entry (the default), then the while statement is unlabeled. + + function Set_Loop_Block_Name (L : Character) return Name_Id; + -- Given a letter 'L' for a loop or 'B' for a block, returns a name + -- of the form L_nn or B_nn where nn is a serial number obtained by + -- incrementing the variable Loop_Block_Count. + + procedure Then_Scan; + -- Scan past THEN token, testing for illegal junk after it + + --------------------------------- + -- 5.1 Sequence of Statements -- + --------------------------------- + + -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} + + -- STATEMENT ::= + -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT + + -- SIMPLE_STATEMENT ::= NULL_STATEMENT + -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT + -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT + -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT + -- | REQUEUE_STATEMENT | DELAY_STATEMENT + -- | ABORT_STATEMENT | RAISE_STATEMENT + -- | CODE_STATEMENT + + -- COMPOUND_STATEMENT ::= + -- IF_STATEMENT | CASE_STATEMENT + -- | LOOP_STATEMENT | BLOCK_STATEMENT + -- | ACCEPT_STATEMENT | SELECT_STATEMENT + + -- This procedure scans a sequence of statements. The caller sets SS_Flags + -- to indicate acceptable termination conditions for the sequence: + + -- SS_Flags.Eftm Terminate on ELSIF + -- SS_Flags.Eltm Terminate on ELSE + -- SS_Flags.Extm Terminate on EXCEPTION + -- SS_Flags.Ortm Terminate on OR + -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) + -- SS_Flags.Whtm Terminate on WHEN + -- SS_Flags.Unco Unconditional terminate after scanning one statement + + -- In addition, the scan is always terminated by encountering END or the + -- end of file (EOF) condition. If one of the six above terminators is + -- encountered with the corresponding SS_Flags flag not set, then the + -- action taken is as follows: + + -- If the keyword occurs to the left of the expected column of the end + -- for the current sequence (as recorded in the current end context), + -- then it is assumed to belong to an outer context, and is considered + -- to terminate the sequence of statements. + + -- If the keyword occurs to the right of, or in the expected column of + -- the end for the current sequence, then an error message is output, + -- the keyword together with its associated context is skipped, and + -- the statement scan continues until another terminator is found. + + -- Note that the first action means that control can return to the caller + -- with Token set to a terminator other than one of those specified by the + -- SS parameter. The caller should treat such a case as equivalent to END. + + -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at + -- least one real statement (other than a pragma) is required in the + -- statement sequence. During the processing of the sequence, this + -- flag is manipulated to indicate the current status of the requirement + -- for a statement. For example, it is turned off by the occurrence of a + -- statement, and back on by a label (which requires a following statement) + + -- Error recovery: cannot raise Error_Resync. If an error occurs during + -- parsing a statement, then the scan pointer is advanced past the next + -- semicolon and the parse continues. + + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is + + Statement_Required : Boolean; + -- This flag indicates if a subsequent statement (other than a pragma) + -- is required. It is initialized from the Sreq flag, and modified as + -- statements are scanned (a statement turns it off, and a label turns + -- it back on again since a statement must follow a label). + + Declaration_Found : Boolean := False; + -- This flag is set True if a declaration is encountered, so that the + -- error message about declarations in the statement part is only + -- given once for a given sequence of statements. + + Scan_State_Label : Saved_Scan_State; + Scan_State : Saved_Scan_State; + + Statement_List : List_Id; + Block_Label : Name_Id; + Id_Node : Node_Id; + Name_Node : Node_Id; + + procedure Junk_Declaration; + -- Procedure called to handle error of declaration encountered in + -- statement sequence. + + procedure Test_Statement_Required; + -- Flag error if Statement_Required flag set + + procedure Junk_Declaration is + begin + if (not Declaration_Found) or All_Errors_Mode then + Error_Msg_SC ("declarations must come before BEGIN"); + Declaration_Found := True; + end if; + + Skip_Declaration (Statement_List); + end Junk_Declaration; + + procedure Test_Statement_Required is + begin + if Statement_Required then + Error_Msg_BC ("statement expected"); + end if; + end Test_Statement_Required; + + -- Start of processing for P_Sequence_Of_Statements + + begin + Statement_List := New_List; + Statement_Required := SS_Flags.Sreq; + + loop + while Token = Tok_Semicolon loop + Error_Msg_SC ("unexpected semicolon ignored"); + Scan; -- past junk semicolon + end loop; + + begin + if Style_Check then Style.Check_Indentation; end if; + + -- Deal with reserved identifier (in assignment or call) + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); -- at possible bad identifier + Scan; -- and scan past it + + -- We have an reserved word which is spelled in identifier + -- style, so the question is whether it really is intended + -- to be an identifier. + + if + -- If followed by a semicolon, then it is an identifier, + -- with the exception of the cases tested for below. + + (Token = Tok_Semicolon + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_Null + and then Prev_Token /= Tok_Raise + and then Prev_Token /= Tok_End + and then Prev_Token /= Tok_Exit) + + -- If followed by colon, colon-equal, or dot, then we + -- definitely have an identifier (could not be reserved) + + or else Token = Tok_Colon + or else Token = Tok_Colon_Equal + or else Token = Tok_Dot + + -- Left paren means we have an identifier except for those + -- reserved words that can legitimately be followed by a + -- left paren. + + or else + (Token = Tok_Left_Paren + and then Prev_Token /= Tok_Case + and then Prev_Token /= Tok_Delay + and then Prev_Token /= Tok_If + and then Prev_Token /= Tok_Elsif + and then Prev_Token /= Tok_Return + and then Prev_Token /= Tok_When + and then Prev_Token /= Tok_While + and then Prev_Token /= Tok_Separate) + then + -- Here we have an apparent reserved identifier and the + -- token past it is appropriate to this usage (and would + -- be a definite error if this is not an identifier). What + -- we do is to use P_Identifier to fix up the identifier, + -- and then fall into the normal processing. + + Restore_Scan_State (Scan_State); -- back to the ID + Scan_Reserved_Identifier (Force_Msg => False); + + -- Not a reserved identifier after all (or at least we can't + -- be sure that it is), so reset the scan and continue. + + else + Restore_Scan_State (Scan_State); -- back to the reserved word + end if; + end if; + + -- Now look to see what kind of statement we have + + case Token is + + -- Case of end or EOF + + when Tok_End | Tok_EOF => + + -- These tokens always terminate the statement sequence + + Test_Statement_Required; + exit; + + -- Case of ELSIF + + when Tok_Elsif => + + -- Terminate if Eftm set or if the ELSIF is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eftm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past ELSIF Condition then + + else + Error_Msg_SC ("ELSIF not allowed here"); + Scan; -- past ELSIF + Discard_Junk_Node (P_Expression_No_Right_Paren); + Then_Scan; + Statement_Required := False; + end if; + + -- Case of ELSE + + when Tok_Else => + + -- Terminate if Eltm set or if the else is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Eltm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past else + + else + Error_Msg_SC ("ELSE not allowed here"); + Scan; -- past ELSE + Statement_Required := False; + end if; + + -- Case of exception + + when Tok_Exception => + Test_Statement_Required; + + -- If Extm not set and the exception is not to the left + -- of the expected column of the end for this sequence, then + -- we assume it belongs to the current sequence, even though + -- it is not permitted. + + if not SS_Flags.Extm and then + Start_Column >= Scope.Table (Scope.Last).Ecol + + then + Error_Msg_SC ("exception handler not permitted here"); + Scan; -- past EXCEPTION + Discard_Junk_List (Parse_Exception_Handlers); + end if; + + -- Always return, in the case where we scanned out handlers + -- that we did not expect, Parse_Exception_Handlers returned + -- with Token being either end or EOF, so we are OK + + exit; + + -- Case of OR + + when Tok_Or => + + -- Terminate if Ortm set or if the or is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Ortm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip past or + + else + Error_Msg_SC ("OR not allowed here"); + Scan; -- past or + Statement_Required := False; + end if; + + -- Case of THEN (deal also with THEN ABORT) + + when Tok_Then => + Save_Scan_State (Scan_State); -- at THEN + Scan; -- past THEN + + -- Terminate if THEN ABORT allowed (ATC case) + + exit when SS_Flags.Tatm and then Token = Tok_Abort; + + -- Otherwise we treat THEN as some kind of mess where we + -- did not see the associated IF, but we pick up assuming + -- it had been there! + + Restore_Scan_State (Scan_State); -- to THEN + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Case of WHEN (error because we are not in a case) + + when Tok_When | Tok_Others => + + -- Terminate if Whtm set or if the WHEN is to the left + -- of the expected column of the end for this sequence + + if SS_Flags.Whtm + or else Start_Column < Scope.Table (Scope.Last).Ecol + then + Test_Statement_Required; + exit; + + -- Otherwise complain and skip when Choice {| Choice} => + + else + Error_Msg_SC ("WHEN not allowed here"); + Scan; -- past when + Discard_Junk_List (P_Discrete_Choice_List); + TF_Arrow; + Statement_Required := False; + end if; + + -- Cases of statements starting with an identifier + + when Tok_Identifier => + Check_Bad_Layout; + + -- Save scan pointers and line number in case block label + + Id_Node := Token_Node; + Block_Label := Token_Name; + Save_Scan_State (Scan_State_Label); -- at possible label + Scan; -- past Id + + -- Check for common case of assignment, since it occurs + -- frequently, and we want to process it efficiently. + + if Token = Tok_Colon_Equal then + Scan; -- past the colon-equal + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check common case of procedure call, another case that + -- we want to speed up as much as possible. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- Check for case of "go to" in place of "goto" + + elsif Token = Tok_Identifier + and then Block_Label = Name_Go + and then Token_Name = Name_To + then + Error_Msg_SP ("goto is one word"); + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- Check common case of = used instead of :=, just so we + -- give a better error message for this special misuse. + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Id_Node)); + Statement_Required := False; + + -- Check case of loop label or block label + + elsif Token = Tok_Colon + or else (Token in Token_Class_Labeled_Stmt + and then not Token_Is_At_Start_Of_Line) + then + T_Colon; -- past colon (if there, or msg for missing one) + + -- Test for more than one label + + loop + exit when Token /= Tok_Identifier; + Save_Scan_State (Scan_State); -- at second Id + Scan; -- past Id + + if Token = Tok_Colon then + Error_Msg_SP + ("only one label allowed on block or loop"); + Scan; -- past colon on extra label + + -- Use the second label as the "real" label + + Scan_State_Label := Scan_State; + + -- We will set Error_name as the Block_Label since + -- we really don't know which of the labels might + -- be used at the end of the loop or block! + + Block_Label := Error_Name; + + -- If Id with no colon, then backup to point to the + -- Id and we will issue the message below when we try + -- to scan out the statement as some other form. + + else + Restore_Scan_State (Scan_State); -- to second Id + exit; + end if; + end loop; + + -- Loop_Statement (labeled Loop_Statement) + + if Token = Tok_Loop then + Append_To (Statement_List, + P_Loop_Statement (Id_Node)); + + -- While statement (labeled loop statement with WHILE) + + elsif Token = Tok_While then + Append_To (Statement_List, + P_While_Statement (Id_Node)); + + -- Declare statement (labeled block statement with + -- DECLARE part) + + elsif Token = Tok_Declare then + Append_To (Statement_List, + P_Declare_Statement (Id_Node)); + + -- Begin statement (labeled block statement with no + -- DECLARE part) + + elsif Token = Tok_Begin then + Append_To (Statement_List, + P_Begin_Statement (Id_Node)); + + -- For statement (labeled loop statement with FOR) + + elsif Token = Tok_For then + Append_To (Statement_List, + P_For_Statement (Id_Node)); + + -- Improper statement follows label. If we have an + -- expression token, then assume the colon was part + -- of a misplaced declaration. + + elsif Token not in Token_Class_Eterm then + Restore_Scan_State (Scan_State_Label); + Junk_Declaration; + + -- Otherwise complain we have inappropriate statement + + else + Error_Msg_AP + ("loop or block statement must follow label"); + end if; + + Statement_Required := False; + + -- Here we have an identifier followed by something + -- other than a colon, semicolon or assignment symbol. + -- The only valid possibility is a name extension symbol + + elsif Token in Token_Class_Namext then + Restore_Scan_State (Scan_State_Label); -- to Id + Name_Node := P_Name; + + -- Skip junk right parens in this context + + while Token = Tok_Right_Paren loop + Error_Msg_SC ("extra right paren"); + Scan; -- past ) + end loop; + + -- Check context following call + + if Token = Tok_Colon_Equal then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check common case of = used instead of := + + elsif Token = Tok_Equal then + T_Colon_Equal; -- give := expected message + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + Statement_Required := False; + + -- Check apostrophe cases + + elsif Token = Tok_Apostrophe then + Append_To (Statement_List, + P_Code_Statement (Name_Node)); + Statement_Required := False; + + -- The only other valid item after a name is ; which + -- means that the item we just scanned was a call. + + elsif Token = Tok_Semicolon then + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + Scan; -- past semicolon + Statement_Required := False; + + -- Else we have a missing semicolon + + else + TF_Semicolon; + Statement_Required := False; + end if; + + -- If junk after identifier, check if identifier is an + -- instance of an incorrectly spelled keyword. If so, we + -- do nothing. The Bad_Spelling_Of will have reset Token + -- to the appropriate keyword, so the next time round the + -- loop we will process the modified token. Note that we + -- check for ELSIF before ELSE here. That's not accidental. + -- We don't want to identify a misspelling of ELSE as + -- ELSIF, and in particular we do not want to treat ELSEIF + -- as ELSE IF. + + else + Restore_Scan_State (Scan_State_Label); -- to identifier + + if Bad_Spelling_Of (Tok_Abort) + or else Bad_Spelling_Of (Tok_Accept) + or else Bad_Spelling_Of (Tok_Case) + or else Bad_Spelling_Of (Tok_Declare) + or else Bad_Spelling_Of (Tok_Delay) + or else Bad_Spelling_Of (Tok_Elsif) + or else Bad_Spelling_Of (Tok_Else) + or else Bad_Spelling_Of (Tok_End) + or else Bad_Spelling_Of (Tok_Exception) + or else Bad_Spelling_Of (Tok_Exit) + or else Bad_Spelling_Of (Tok_For) + or else Bad_Spelling_Of (Tok_Goto) + or else Bad_Spelling_Of (Tok_If) + or else Bad_Spelling_Of (Tok_Loop) + or else Bad_Spelling_Of (Tok_Or) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Raise) + or else Bad_Spelling_Of (Tok_Requeue) + or else Bad_Spelling_Of (Tok_Return) + or else Bad_Spelling_Of (Tok_Select) + or else Bad_Spelling_Of (Tok_When) + or else Bad_Spelling_Of (Tok_While) + then + null; + + -- If not a bad spelling, then we really have junk + + else + Scan; -- past identifier again + + -- If next token is first token on line, then we + -- consider that we were missing a semicolon after + -- the identifier, and process it as a procedure + -- call with no parameters. + + if Token_Is_At_Start_Of_Line then + Append_To (Statement_List, + P_Statement_Name (Id_Node)); + T_Semicolon; -- to give error message + Statement_Required := False; + + -- Otherwise we give a missing := message and + -- simply abandon the junk that is there now. + + else + T_Colon_Equal; -- give := expected message + raise Error_Resync; + end if; + + end if; + end if; + + -- Statement starting with operator symbol. This could be + -- a call, a name starting an assignment, or a qualified + -- expression. + + when Tok_Operator_Symbol => + Check_Bad_Layout; + Name_Node := P_Name; + + -- An attempt at a range attribute or a qualified expression + -- must be illegal here (a code statement cannot possibly + -- allow qualification by a function name). + + if Token = Tok_Apostrophe then + Error_Msg_SC ("apostrophe illegal here"); + raise Error_Resync; + end if; + + -- Scan possible assignment if we have a name + + if Expr_Form = EF_Name + and then Token = Tok_Colon_Equal + then + Scan; -- past colon equal + Append_To (Statement_List, + P_Assignment_Statement (Name_Node)); + else + Append_To (Statement_List, + P_Statement_Name (Name_Node)); + end if; + + TF_Semicolon; + Statement_Required := False; + + -- Label starting with << which must precede real statement + + when Tok_Less_Less => + Append_To (Statement_List, P_Label); + Statement_Required := True; + + -- Pragma appearing as a statement in a statement sequence + + when Tok_Pragma => + Check_Bad_Layout; + Append_To (Statement_List, P_Pragma); + + -- Abort_Statement + + when Tok_Abort => + Check_Bad_Layout; + Append_To (Statement_List, P_Abort_Statement); + Statement_Required := False; + + -- Accept_Statement + + when Tok_Accept => + Check_Bad_Layout; + Append_To (Statement_List, P_Accept_Statement); + Statement_Required := False; + + -- Begin_Statement (Block_Statement with no declare, no label) + + when Tok_Begin => + Check_Bad_Layout; + Append_To (Statement_List, P_Begin_Statement); + Statement_Required := False; + + -- Case_Statement + + when Tok_Case => + Check_Bad_Layout; + Append_To (Statement_List, P_Case_Statement); + Statement_Required := False; + + -- Block_Statement with DECLARE and no label + + when Tok_Declare => + Check_Bad_Layout; + Append_To (Statement_List, P_Declare_Statement); + Statement_Required := False; + + -- Delay_Statement + + when Tok_Delay => + Check_Bad_Layout; + Append_To (Statement_List, P_Delay_Statement); + Statement_Required := False; + + -- Exit_Statement + + when Tok_Exit => + Check_Bad_Layout; + Append_To (Statement_List, P_Exit_Statement); + Statement_Required := False; + + -- Loop_Statement with FOR and no label + + when Tok_For => + Check_Bad_Layout; + Append_To (Statement_List, P_For_Statement); + Statement_Required := False; + + -- Goto_Statement + + when Tok_Goto => + Check_Bad_Layout; + Append_To (Statement_List, P_Goto_Statement); + Statement_Required := False; + + -- If_Statement + + when Tok_If => + Check_Bad_Layout; + Append_To (Statement_List, P_If_Statement); + Statement_Required := False; + + -- Loop_Statement + + when Tok_Loop => + Check_Bad_Layout; + Append_To (Statement_List, P_Loop_Statement); + Statement_Required := False; + + -- Null_Statement + + when Tok_Null => + Check_Bad_Layout; + Append_To (Statement_List, P_Null_Statement); + Statement_Required := False; + + -- Raise_Statement + + when Tok_Raise => + Check_Bad_Layout; + Append_To (Statement_List, P_Raise_Statement); + Statement_Required := False; + + -- Requeue_Statement + + when Tok_Requeue => + Check_Bad_Layout; + Append_To (Statement_List, P_Requeue_Statement); + Statement_Required := False; + + -- Return_Statement + + when Tok_Return => + Check_Bad_Layout; + Append_To (Statement_List, P_Return_Statement); + Statement_Required := False; + + -- Select_Statement + + when Tok_Select => + Check_Bad_Layout; + Append_To (Statement_List, P_Select_Statement); + Statement_Required := False; + + -- While_Statement (Block_Statement with while and no loop) + + when Tok_While => + Check_Bad_Layout; + Append_To (Statement_List, P_While_Statement); + Statement_Required := False; + + -- Anything else is some kind of junk, signal an error message + -- and then raise Error_Resync, to merge with the normal + -- handling of a bad statement. + + when others => + + if Token in Token_Class_Declk then + Junk_Declaration; + + else + Error_Msg_BC ("statement expected"); + raise Error_Resync; + end if; + end case; + + -- On error resynchronization, skip past next semicolon, and, since + -- we are still in the statement loop, look for next statement. We + -- set Statement_Required False to avoid an unnecessary error message + -- complaining that no statement was found (i.e. we consider the + -- junk to satisfy the requirement for a statement being present). + + exception + when Error_Resync => + Resync_Past_Semicolon_Or_To_Loop_Or_Then; + Statement_Required := False; + end; + + exit when SS_Flags.Unco; + + end loop; + + return Statement_List; + + end P_Sequence_Of_Statements; + + -------------------- + -- 5.1 Statement -- + -------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1), except for the case + -- of a statement of the form of a name, which is handled here. The + -- argument passed in is the tree for the name which has been scanned + -- The returned value is the corresponding statement form. + + -- This routine is also used by Par.Prag for processing the procedure + -- call that appears as the second argument of a pragma Assert. + + -- Error recovery: cannot raise Error_Resync + + function P_Statement_Name (Name_Node : Node_Id) return Node_Id is + Stmt_Node : Node_Id; + + begin + -- Case of Indexed component, which is a procedure call with arguments + + if Nkind (Name_Node) = N_Indexed_Component then + declare + Prefix_Node : Node_Id := Prefix (Name_Node); + Exprs_Node : List_Id := Expressions (Name_Node); + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Exprs_Node); + return Name_Node; + end; + + -- Case of function call node, which is a really a procedure call + + elsif Nkind (Name_Node) = N_Function_Call then + declare + Fname_Node : Node_Id := Name (Name_Node); + Params_List : List_Id := Parameter_Associations (Name_Node); + + begin + Change_Node (Name_Node, N_Procedure_Call_Statement); + Set_Name (Name_Node, Fname_Node); + Set_Parameter_Associations (Name_Node, Params_List); + return Name_Node; + end; + + -- Case of call to attribute that denotes a procedure. Here we + -- just leave the attribute reference unchanged. + + elsif Nkind (Name_Node) = N_Attribute_Reference + and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node)) + then + return Name_Node; + + -- All other cases of names are parameterless procedure calls + + else + Stmt_Node := + New_Node (N_Procedure_Call_Statement, Sloc (Name_Node)); + Set_Name (Stmt_Node, Name_Node); + return Stmt_Node; + end if; + + end P_Statement_Name; + + --------------------------- + -- 5.1 Simple Statement -- + --------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ----------------------------- + -- 5.1 Compound Statement -- + ----------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ------------------------- + -- 5.1 Null Statement -- + ------------------------- + + -- NULL_STATEMENT ::= null; + + -- The caller has already checked that the current token is null + + -- Error recovery: cannot raise Error_Resync + + function P_Null_Statement return Node_Id is + Null_Stmt_Node : Node_Id; + + begin + Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr); + Scan; -- past NULL + TF_Semicolon; + return Null_Stmt_Node; + end P_Null_Statement; + + ---------------- + -- 5.1 Label -- + ---------------- + + -- LABEL ::= <<label_STATEMENT_IDENTIFIER>> + + -- STATEMENT_INDENTIFIER ::= DIRECT_NAME + + -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier + -- (not an OPERATOR_SYMBOL) + + -- The caller has already checked that the current token is << + + -- Error recovery: can raise Error_Resync + + function P_Label return Node_Id is + Label_Node : Node_Id; + + begin + Label_Node := New_Node (N_Label, Token_Ptr); + Scan; -- past << + Set_Identifier (Label_Node, P_Identifier); + T_Greater_Greater; + Append_Elmt (Label_Node, Label_List); + return Label_Node; + end P_Label; + + ------------------------------- + -- 5.1 Statement Identifier -- + ------------------------------- + + -- Statement label is parsed by P_Label (5.1) + + -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5) + -- or P_While_Statement (5.5) + + -- Block label is parsed by P_Begin_Statement (5.6) or + -- P_Declare_Statement (5.6) + + ------------------------------- + -- 5.2 Assignment Statement -- + ------------------------------- + + -- ASSIGNMENT_STATEMENT ::= + -- variable_NAME := EXPRESSION; + + -- Error recovery: can raise Error_Resync + + function P_Assignment_Statement (LHS : Node_Id) return Node_Id is + Assign_Node : Node_Id; + + begin + Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr); + Set_Name (Assign_Node, LHS); + Set_Expression (Assign_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Assign_Node; + end P_Assignment_Statement; + + ----------------------- + -- 5.3 If Statement -- + ----------------------- + + -- IF_STATEMENT ::= + -- if CONDITION then + -- SEQUENCE_OF_STATEMENTS + -- {elsif CONDITION then + -- SEQUENCE_OF_STATEMENTS} + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end if; + + -- The caller has checked that the initial token is IF (or in the error + -- case of a mysterious THEN, the initial token may simply be THEN, in + -- which case, no condition (or IF) was scanned). + + -- Error recovery: can raise Error_Resync + + function P_If_Statement return Node_Id is + If_Node : Node_Id; + Elsif_Node : Node_Id; + Loc : Source_Ptr; + + procedure Add_Elsif_Part; + -- An internal procedure used to scan out a single ELSIF part. On entry + -- the ELSIF (or an ELSE which has been determined should be ELSIF) is + -- scanned out and is in Prev_Token. + + procedure Check_If_Column; + -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF + -- appear in the right place if column checking is enabled (i.e. if + -- they are the first token on the line, then they must appear in + -- the same column as the opening IF). + + procedure Check_Then_Column; + -- This procedure carries out the style checks for a THEN token + -- Note that the caller has set Loc to the Source_Ptr value for + -- the previous IF or ELSIF token. These checks apply only to a + -- THEN at the start of a line. + + function Else_Should_Be_Elsif return Boolean; + -- An internal routine used to do a special error recovery check when + -- an ELSE is encountered. It determines if the ELSE should be treated + -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE + -- is followed by a sequence of tokens, starting on the same line as + -- the ELSE, which are not expression terminators, followed by a THEN. + -- On entry, the ELSE has been scanned out. + + procedure Add_Elsif_Part is + begin + if No (Elsif_Parts (If_Node)) then + Set_Elsif_Parts (If_Node, New_List); + end if; + + Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr); + Loc := Prev_Token_Ptr; + Set_Condition (Elsif_Node, P_Condition); + Check_Then_Column; + Then_Scan; + Set_Then_Statements + (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + Append (Elsif_Node, Elsif_Parts (If_Node)); + end Add_Elsif_Part; + + procedure Check_If_Column is + begin + if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line + and then Start_Column /= Scope.Table (Scope.Last).Ecol + then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg_SC ("(style) this token should be@"); + end if; + end Check_If_Column; + + procedure Check_Then_Column is + begin + if Token_Is_At_Start_Of_Line and then Token = Tok_Then then + Check_If_Column; + if Style_Check then Style.Check_Then (Loc); end if; + end if; + end Check_Then_Column; + + function Else_Should_Be_Elsif return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token_Is_At_Start_Of_Line then + return False; + + else + Save_Scan_State (Scan_State); + + loop + if Token in Token_Class_Eterm then + Restore_Scan_State (Scan_State); + return False; + else + Scan; -- past non-expression terminating token + + if Token = Tok_Then then + Restore_Scan_State (Scan_State); + return True; + end if; + end if; + end loop; + end if; + end Else_Should_Be_Elsif; + + -- Start of processing for P_If_Statement + + begin + If_Node := New_Node (N_If_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_If; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := If_Node; + + if Token = Tok_If then + Loc := Token_Ptr; + Scan; -- past IF + Set_Condition (If_Node, P_Condition); + + -- Deal with misuse of IF expression => used instead + -- of WHEN expression => + + if Token = Tok_Arrow then + Error_Msg_SC ("THEN expected"); + Scan; -- past the arrow + Pop_Scope_Stack; -- remove unneeded entry + raise Error_Resync; + end if; + + Check_Then_Column; + + else + Error_Msg_SC ("no IF for this THEN"); + Set_Condition (If_Node, Error); + end if; + + Then_Scan; + + Set_Then_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + + -- This loop scans out else and elsif parts + + loop + if Token = Tok_Elsif then + Check_If_Column; + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("ELSIF cannot appear after ELSE"); + end if; + + Scan; -- past ELSIF + Add_Elsif_Part; + + elsif Token = Tok_Else then + Check_If_Column; + Scan; -- past ELSE + + if Else_Should_Be_Elsif then + Error_Msg_SP ("ELSE should be ELSIF"); + Add_Elsif_Part; + + else + -- Here we have an else that really is an else + + if Present (Else_Statements (If_Node)) then + Error_Msg_SP ("Only one ELSE part allowed"); + Append_List + (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq), + Else_Statements (If_Node)); + else + Set_Else_Statements + (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); + end if; + end if; + + -- If anything other than ELSE or ELSIF, exit the loop. The token + -- had better be END (and in fact it had better be END IF), but + -- we will let End_Statements take care of checking that. + + else + exit; + end if; + end loop; + + End_Statements; + return If_Node; + + end P_If_Statement; + + -------------------- + -- 5.3 Condition -- + -------------------- + + -- CONDITION ::= boolean_EXPRESSION + + function P_Condition return Node_Id is + Cond : Node_Id; + + begin + Cond := P_Expression_No_Right_Paren; + + -- It is never possible for := to follow a condition, so if we get + -- a := we assume it is a mistyped equality. Note that we do not try + -- to reconstruct the tree correctly in this case, but we do at least + -- give an accurate error message. + + while Token = Tok_Colon_Equal loop + Error_Msg_SC (""":="" should be ""="""); + Scan; -- past junk := + Discard_Junk_Node (P_Expression_No_Right_Paren); + end loop; + + return Cond; + end P_Condition; + + ------------------------- + -- 5.4 Case Statement -- + ------------------------- + + -- CASE_STATEMENT ::= + -- case EXPRESSION is + -- CASE_STATEMENT_ALTERNATIVE + -- {CASE_STATEMENT_ALTERNATIVE} + -- end case; + + -- The caller has checked that the first token is CASE + + -- Can raise Error_Resync + + function P_Case_Statement return Node_Id is + Case_Node : Node_Id; + Alternatives_List : List_Id; + First_When_Loc : Source_Ptr; + + begin + Case_Node := New_Node (N_Case_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Node := Case_Node; + + Scan; -- past CASE + Set_Expression (Case_Node, P_Expression_No_Right_Paren); + TF_Is; + + -- Prepare to parse case statement alternatives + + Alternatives_List := New_List; + P_Pragmas_Opt (Alternatives_List); + First_When_Loc := Token_Ptr; + + -- Loop through case statement alternatives + + loop + -- If we have a WHEN or OTHERS, then that's fine keep going. Note + -- that it is a semantic check to ensure the proper use of OTHERS + + if Token = Tok_When or else Token = Tok_Others then + Append (P_Case_Statement_Alternative, Alternatives_List); + + -- If we have an END, then probably we are at the end of the case + -- but we only exit if Check_End thinks the END was reasonable. + + elsif Token = Tok_End then + exit when Check_End; + + -- Here if token is other than WHEN, OTHERS or END. We definitely + -- have an error, but the question is whether or not to get out of + -- the case statement. We don't want to get out early, or we will + -- get a slew of junk error messages for subsequent when tokens. + + -- If the token is not at the start of the line, or if it is indented + -- with respect to the current case statement, then the best guess is + -- that we are still supposed to be inside the case statement. We + -- complain about the missing WHEN, and discard the junk statements. + + elsif not Token_Is_At_Start_Of_Line + or else Start_Column > Scope.Table (Scope.Last).Ecol + then + Error_Msg_BC ("WHEN (case statement alternative) expected"); + + -- Here is a possibility for infinite looping if we don't make + -- progress. So try to process statements, otherwise exit + + declare + Error_Ptr : constant Source_Ptr := Scan_Ptr; + begin + Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); + exit when Scan_Ptr = Error_Ptr and then Check_End; + end; + + -- Here we have a junk token at the start of the line and it is + -- not indented. If Check_End thinks there is a missing END, then + -- we will get out of the case, otherwise we keep going. + + else + exit when Check_End; + end if; + end loop; + + -- Make sure we have at least one alternative + + if No (First_Non_Pragma (Alternatives_List)) then + Error_Msg + ("WHEN expected, must have at least one alternative in case", + First_When_Loc); + return Error; + + else + Set_Alternatives (Case_Node, Alternatives_List); + return Case_Node; + end if; + end P_Case_Statement; + + ------------------------------------- + -- 5.4 Case Statement Alternative -- + ------------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- SEQUENCE_OF_STATEMENTS + + -- The caller has checked that the initial token is WHEN or OTHERS + -- Error recovery: can raise Error_Resync + + function P_Case_Statement_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + + begin + if Style_Check then Style.Check_Indentation; end if; + Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); + T_When; -- past WHEN (or give error in OTHERS case) + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); + return Case_Alt_Node; + end P_Case_Statement_Alternative; + + ------------------------- + -- 5.5 Loop Statement -- + ------------------------- + + -- LOOP_STATEMENT ::= + -- [LOOP_STATEMENT_IDENTIFIER:] + -- [ITERATION_SCHEME] loop + -- SEQUENCE_OF_STATEMENTS + -- end loop [loop_IDENTIFIER]; + + -- ITERATION_SCHEME ::= + -- while CONDITION + -- | for LOOP_PARAMETER_SPECIFICATION + + -- The parsing of loop statements is handled by one of three functions + -- P_Loop_Statement, P_For_Statement or P_While_Statement depending + -- on the initial keyword in the construct (excluding the identifier) + + -- P_Loop_Statement + + -- This function parses the case where no iteration scheme is present + + -- The caller has checked that the initial token is LOOP. The parameter + -- is the node identifiers for the loop label if any (or is set to Empty + -- if there is no loop label). + + -- Error recovery : cannot raise Error_Resync + + function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + return Loop_Node; + end P_Loop_Statement; + + -- P_For_Statement + + -- This function parses a loop statement with a FOR iteration scheme + + -- The caller has checked that the initial token is FOR. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Note: the caller fills in the Identifier field if a label was present + + -- Error recovery: can raise Error_Resync + + function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_For_Flag : Boolean; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_For_Flag := (Prev_Token = Tok_Loop); + Scan; -- past FOR + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Set_Loop_Parameter_Specification + (Iter_Scheme_Node, P_Loop_Parameter_Specification); + + -- The following is a special test so that a miswritten for loop such + -- as "loop for I in 1..10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_For_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before FOR"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + return Loop_Node; + end if; + + end P_For_Statement; + + -- P_While_Statement + + -- This procedure scans a loop statement with a WHILE iteration scheme + + -- The caller has checked that the initial token is WHILE. The parameter + -- is the node identifier for the block label if any (or is set to Empty + -- if there is no block label). + + -- Error recovery: cannot raise Error_Resync + + function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is + Loop_Node : Node_Id; + Iter_Scheme_Node : Node_Id; + Loop_While_Flag : Boolean; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Labl := Loop_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Loop; + + Loop_While_Flag := (Prev_Token = Tok_Loop); + Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); + Scan; -- past WHILE + Set_Condition (Iter_Scheme_Node, P_Condition); + + -- The following is a special test so that a miswritten for loop such + -- as "loop while I > 10;" is handled nicely, without making an extra + -- entry in the scope stack. We don't bother to actually fix up the + -- tree in this case since it's not worth the effort. Instead we just + -- eat up the loop junk, leaving the entry for what now looks like an + -- unmodified loop intact. + + if Loop_While_Flag and then Token = Tok_Semicolon then + Error_Msg_SC ("LOOP belongs here, not before WHILE"); + Pop_Scope_Stack; + return Error; + + -- Normal case + + else + Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); + TF_Loop; + Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); + End_Statements (Loop_Node); + Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); + + if No (Loop_Name) then + Set_Has_Created_Identifier (Loop_Node, True); + Set_Identifier (Loop_Node, + Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L'))); + else + Set_Identifier (Loop_Node, Loop_Name); + end if; + + Append_Elmt (Loop_Node, Label_List); + + return Loop_Node; + end if; + + end P_While_Statement; + + --------------------------------------- + -- 5.5 Loop Parameter Specification -- + --------------------------------------- + + -- LOOP_PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: cannot raise Error_Resync + + function P_Loop_Parameter_Specification return Node_Id is + Loop_Param_Specification_Node : Node_Id; + + ID_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Loop_Param_Specification_Node := + New_Node (N_Loop_Parameter_Specification, Token_Ptr); + + Save_Scan_State (Scan_State); + ID_Node := P_Defining_Identifier; + Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC ("subscripted loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + + elsif Token = Tok_Dot then + Error_Msg_SC ("selected loop parameter not allowed"); + Restore_Scan_State (Scan_State); + Discard_Junk_Node (P_Name); + end if; + + T_In; + + if Token = Tok_Reverse then + Scan; -- past REVERSE + Set_Reverse_Present (Loop_Param_Specification_Node, True); + end if; + + Set_Discrete_Subtype_Definition + (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); + return Loop_Param_Specification_Node; + + exception + when Error_Resync => + return Error; + end P_Loop_Parameter_Specification; + + -------------------------- + -- 5.6 Block Statement -- + -------------------------- + + -- BLOCK_STATEMENT ::= + -- [block_STATEMENT_IDENTIFIER:] + -- [declare + -- DECLARATIVE_PART] + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [block_IDENTIFIER]; + + -- The parsing of block statements is handled by one of the two functions + -- P_Declare_Statement or P_Begin_Statement depending on whether or not + -- a declare section is present + + -- P_Declare_Statement + + -- This function parses a block statement with DECLARE present + + -- The caller has checked that the initial token is DECLARE. + + -- Error recovery: cannot raise Error_Resync + + function P_Declare_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + Scan; -- past DECLARE + + if No (Block_Name) then + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'))); + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + Parse_Decls_Begin_End (Block_Node); + return Block_Node; + end P_Declare_Statement; + + -- P_Begin_Statement + + -- This function parses a block statement with no DECLARE present + + -- The caller has checked that the initial token is BEGIN + + -- Error recovery: cannot raise Error_Resync + + function P_Begin_Statement + (Block_Name : Node_Id := Empty) + return Node_Id + is + Block_Node : Node_Id; + + begin + Block_Node := New_Node (N_Block_Statement, Token_Ptr); + + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := Present (Block_Name); + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Labl := Block_Name; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + + if No (Block_Name) then + Set_Has_Created_Identifier (Block_Node, True); + Set_Identifier (Block_Node, + Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B'))); + else + Set_Identifier (Block_Node, Block_Name); + end if; + + Append_Elmt (Block_Node, Label_List); + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence + (Block_Node, P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Block_Node)); + return Block_Node; + end P_Begin_Statement; + + ------------------------- + -- 5.7 Exit Statement -- + ------------------------- + + -- EXIT_STATEMENT ::= + -- exit [loop_NAME] [when CONDITION]; + + -- The caller has checked that the initial token is EXIT + + -- Error recovery: can raise Error_Resync + + function P_Exit_Statement return Node_Id is + Exit_Node : Node_Id; + + function Missing_Semicolon_On_Exit return Boolean; + -- This function deals with the following specialized situation + -- + -- when 'x' => + -- exit [identifier] + -- when 'y' => + -- + -- This looks like a messed up EXIT WHEN, when in fact the problem + -- is a missing semicolon. It is called with Token pointing to the + -- WHEN token, and returns True if a semicolon is missing before + -- the WHEN as in the above example. + + function Missing_Semicolon_On_Exit return Boolean is + State : Saved_Scan_State; + + begin + if not Token_Is_At_Start_Of_Line then + return False; + + elsif Scope.Table (Scope.Last).Etyp /= E_Case then + return False; + + else + Save_Scan_State (State); + Scan; -- past WHEN + Scan; -- past token after WHEN + + if Token = Tok_Arrow then + Restore_Scan_State (State); + return True; + else + Restore_Scan_State (State); + return False; + end if; + end if; + end Missing_Semicolon_On_Exit; + + -- Start of processing for P_Exit_Statement + + begin + Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); + Scan; -- past EXIT + + if Token = Tok_Identifier then + Set_Name (Exit_Node, P_Qualified_Simple_Name); + + elsif Style_Check then + -- This EXIT has no name, so check that + -- the innermost loop is unnamed too. + + Check_No_Exit_Name : + for J in reverse 1 .. Scope.Last loop + if Scope.Table (J).Etyp = E_Loop then + if Present (Scope.Table (J).Labl) then + + -- Innermost loop in fact had a name, style check fails + + Style.No_Exit_Name (Scope.Table (J).Labl); + end if; + + exit Check_No_Exit_Name; + end if; + end loop Check_No_Exit_Name; + end if; + + if Token = Tok_When and then not Missing_Semicolon_On_Exit then + Scan; -- past WHEN + Set_Condition (Exit_Node, P_Condition); + + -- Allow IF instead of WHEN, giving error message + + elsif Token = Tok_If then + T_When; + Scan; -- past IF used in place of WHEN + Set_Condition (Exit_Node, P_Expression_No_Right_Paren); + end if; + + TF_Semicolon; + return Exit_Node; + end P_Exit_Statement; + + ------------------------- + -- 5.8 Goto Statement -- + ------------------------- + + -- GOTO_STATEMENT ::= goto label_NAME; + + -- The caller has checked that the initial token is GOTO (or TO in the + -- error case where GO and TO were incorrectly separated). + + -- Error recovery: can raise Error_Resync + + function P_Goto_Statement return Node_Id is + Goto_Node : Node_Id; + + begin + Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); + Scan; -- past GOTO (or TO) + Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); + No_Constraint; + TF_Semicolon; + return Goto_Node; + end P_Goto_Statement; + + --------------------------- + -- Parse_Decls_Begin_End -- + --------------------------- + + -- This function parses the construct: + + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [NAME]; + + -- The caller has built the scope stack entry, and created the node to + -- whose Declarations and Handled_Statement_Sequence fields are to be + -- set. On return these fields are filled in (except in the case of a + -- task body, where the handled statement sequence is optional, and may + -- thus be Empty), and the scan is positioned past the End sequence. + + -- If the BEGIN is missing, then the parent node is used to help construct + -- an appropriate missing BEGIN message. Possibilities for the parent are: + + -- N_Block_Statement declare block + -- N_Entry_Body entry body + -- N_Package_Body package body (begin part optional) + -- N_Subprogram_Body procedure or function body + -- N_Task_Body task body + + -- Note: in the case of a block statement, there is definitely a DECLARE + -- present (because a Begin statement without a DECLARE is handled by the + -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End. + + -- Error recovery: cannot raise Error_Resync + + procedure Parse_Decls_Begin_End (Parent : Node_Id) is + Body_Decl : Node_Id; + Body_Sloc : Source_Ptr; + Decls : List_Id; + Decl : Node_Id; + Parent_Nkind : Node_Kind; + Spec_Node : Node_Id; + HSS : Node_Id; + + procedure Missing_Begin (Msg : String); + -- Called to post a missing begin message. In the normal case this is + -- posted at the start of the current token. A special case arises when + -- P_Declarative_Items has previously found a missing begin, in which + -- case we replace the original error message. + + procedure Set_Null_HSS (Parent : Node_Id); + -- Construct an empty handled statement sequence and install in Parent + -- Leaves HSS set to reference the newly constructed statement sequence. + + ------------------- + -- Missing_Begin -- + ------------------- + + procedure Missing_Begin (Msg : String) is + begin + if Missing_Begin_Msg = No_Error_Msg then + Error_Msg_BC (Msg); + else + Change_Error_Text (Missing_Begin_Msg, Msg); + + -- Purge any messages issued after than, since a missing begin + -- can cause a lot of havoc, and it is better not to dump these + -- cascaded messages on the user. + + Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr); + end if; + end Missing_Begin; + + ------------------ + -- Set_Null_HSS -- + ------------------ + + procedure Set_Null_HSS (Parent : Node_Id) is + Null_Stm : Node_Id; + + begin + Null_Stm := + Make_Null_Statement (Token_Ptr); + Set_Comes_From_Source (Null_Stm, False); + + HSS := + Make_Handled_Sequence_Of_Statements (Token_Ptr, + Statements => New_List (Null_Stm)); + Set_Comes_From_Source (HSS, False); + + Set_Handled_Statement_Sequence (Parent, HSS); + end Set_Null_HSS; + + -- Start of processing for Parse_Decls_Begin_End + + begin + Decls := P_Declarative_Part; + + -- Check for misplacement of later vs basic declarations in Ada 83 + + if Ada_83 then + Decl := First (Decls); + + -- Loop through sequence of basic declarative items + + Outer : while Present (Decl) loop + if Nkind (Decl) /= N_Subprogram_Body + and then Nkind (Decl) /= N_Package_Body + and then Nkind (Decl) /= N_Task_Body + and then Nkind (Decl) not in N_Body_Stub + then + Next (Decl); + + -- Once a body is encountered, we only allow later declarative + -- items. The inner loop checks the rest of the list. + + else + Body_Sloc := Sloc (Decl); + + Inner : while Present (Decl) loop + if Nkind (Decl) not in N_Later_Decl_Item + and then Nkind (Decl) /= N_Pragma + then + if Ada_83 then + Error_Msg_Sloc := Body_Sloc; + Error_Msg_N + ("(Ada 83) decl cannot appear after body#", Decl); + end if; + end if; + + Next (Decl); + end loop Inner; + end if; + end loop Outer; + end if; + + -- Here is where we deal with the case of IS used instead of semicolon. + -- Specifically, if the last declaration in the declarative part is a + -- subprogram body still marked as having a bad IS, then this is where + -- we decide that the IS should really have been a semicolon and that + -- the body should have been a declaration. Note that if the bad IS + -- had turned out to be OK (i.e. a decent begin/end was found for it), + -- then the Bad_Is_Detected flag would have been reset by now. + + Body_Decl := Last (Decls); + + if Present (Body_Decl) + and then Nkind (Body_Decl) = N_Subprogram_Body + and then Bad_Is_Detected (Body_Decl) + then + -- OK, we have the case of a bad IS, so we need to fix up the tree. + -- What we have now is a subprogram body with attached declarations + -- and a possible statement sequence. + + -- First step is to take the declarations that were part of the bogus + -- subprogram body and append them to the outer declaration chain. + -- In other words we append them past the body (which we will later + -- convert into a declaration). + + Append_List (Declarations (Body_Decl), Decls); + + -- Now take the handled statement sequence of the bogus body and + -- set it as the statement sequence for the outer construct. Note + -- that it may be empty (we specially allowed a missing BEGIN for + -- a subprogram body marked as having a bad IS -- see below). + + Set_Handled_Statement_Sequence (Parent, + Handled_Statement_Sequence (Body_Decl)); + + -- Next step is to convert the old body node to a declaration node + + Spec_Node := Specification (Body_Decl); + Change_Node (Body_Decl, N_Subprogram_Declaration); + Set_Specification (Body_Decl, Spec_Node); + + -- Final step is to put the declarations for the parent where + -- they belong, and then fall through the IF to scan out the + -- END statements. + + Set_Declarations (Parent, Decls); + + -- This is the normal case (i.e. any case except the bad IS case) + -- If we have a BEGIN, then scan out the sequence of statements, and + -- also reset the expected column for the END to match the BEGIN. + + else + Set_Declarations (Parent, Decls); + + if Token = Tok_Begin then + if Style_Check then Style.Check_Indentation; end if; + + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if Style.RM_Column_Check + and then Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); + + else + Scope.Table (Scope.Last).Ecol := Start_Column; + end if; + + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + + -- No BEGIN present + + else + Parent_Nkind := Nkind (Parent); + + -- A special check for the missing IS case. If we have a + -- subprogram body that was marked as having a suspicious + -- IS, and the current token is END, then we simply confirm + -- the suspicion, and do not require a BEGIN to be present + + if Parent_Nkind = N_Subprogram_Body + and then Token = Tok_End + and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is + then + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + + -- Otherwise BEGIN is not required for a package body, so we + -- don't mind if it is missing, but we do construct a dummy + -- one (so that we have somewhere to set End_Label). + + -- However if we have something other than a BEGIN which + -- looks like it might be statements, then we signal a missing + -- BEGIN for these cases as well. We define "something which + -- looks like it might be statements" as a token other than + -- END, EOF, or a token which starts declarations. + + elsif Parent_Nkind = N_Package_Body + and then (Token = Tok_End + or else Token = Tok_EOF + or else Token in Token_Class_Declk) + then + Set_Null_HSS (Parent); + + -- These are cases in which a BEGIN is required and not present + + else + Set_Null_HSS (Parent); + + -- Prepare to issue error message + + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + + -- Now issue appropriate message + + if Parent_Nkind = N_Block_Statement then + Missing_Begin ("missing BEGIN for DECLARE#!"); + + elsif Parent_Nkind = N_Entry_Body then + Missing_Begin ("missing BEGIN for ENTRY#!"); + + elsif Parent_Nkind = N_Subprogram_Body then + if Nkind (Specification (Parent)) + = N_Function_Specification + then + Missing_Begin ("missing BEGIN for function&#!"); + else + Missing_Begin ("missing BEGIN for procedure&#!"); + end if; + + -- The case for package body arises only when + -- we have possible statement junk present. + + elsif Parent_Nkind = N_Package_Body then + Missing_Begin ("missing BEGIN for package body&#!"); + + else + pragma Assert (Parent_Nkind = N_Task_Body); + Missing_Begin ("missing BEGIN for task body&#!"); + end if; + + -- Here we pick up the statements after the BEGIN that + -- should have been present but was not. We don't insist + -- on statements being present if P_Declarative_Part had + -- already found a missing BEGIN, since it might have + -- swallowed a lone statement into the declarative part. + + if Missing_Begin_Msg /= No_Error_Msg + and then Token = Tok_End + then + null; + else + Set_Handled_Statement_Sequence (Parent, + P_Handled_Sequence_Of_Statements); + end if; + end if; + end if; + end if; + + -- Here with declarations and handled statement sequence scanned + + if Present (Handled_Statement_Sequence (Parent)) then + End_Statements (Handled_Statement_Sequence (Parent)); + else + End_Statements; + end if; + + -- We know that End_Statements removed an entry from the scope stack + -- (because it is required to do so under all circumstances). We can + -- therefore reference the entry it removed one past the stack top. + -- What we are interested in is whether it was a case of a bad IS. + + if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then + Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); + Set_Bad_Is_Detected (Parent, True); + end if; + + end Parse_Decls_Begin_End; + + ------------------------- + -- Set_Loop_Block_Name -- + ------------------------- + + function Set_Loop_Block_Name (L : Character) return Name_Id is + begin + Name_Buffer (1) := L; + Name_Buffer (2) := '_'; + Name_Len := 2; + Loop_Block_Count := Loop_Block_Count + 1; + Add_Nat_To_Name_Buffer (Loop_Block_Count); + return Name_Find; + end Set_Loop_Block_Name; + + --------------- + -- Then_Scan -- + --------------- + + procedure Then_Scan is + begin + TF_Then; + + while Token = Tok_Then loop + Error_Msg_SC ("redundant THEN"); + TF_Then; + end loop; + + if Token = Tok_And or else Token = Tok_Or then + Error_Msg_SC ("unexpected logical operator"); + Scan; + + if (Prev_Token = Tok_And and then Token = Tok_Then) + or else + (Prev_Token = Tok_Or and then Token = Tok_Else) + then + Scan; + end if; + + Discard_Junk_Node (P_Expression); + end if; + + if Token = Tok_Then then + Scan; + end if; + end Then_Scan; + +end Ch5; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb new file mode 100644 index 00000000000..d5d1d3daaa1 --- /dev/null +++ b/gcc/ada/par-ch6.adb @@ -0,0 +1,1165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 6 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.81 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) +package body Ch6 is + + -- Local subprograms, used only in this chapter + + function P_Defining_Designator return Node_Id; + function P_Defining_Operator_Symbol return Node_Id; + + procedure Check_Junk_Semicolon_Before_Return; + -- Check for common error of junk semicolon before RETURN keyword of + -- function specification. If present, skip over it with appropriate + -- error message, leaving Scan_Ptr pointing to the RETURN after. This + -- routine also deals with a possibly misspelled version of Return. + + ---------------------------------------- + -- Check_Junk_Semicolon_Before_Return -- + ---------------------------------------- + + procedure Check_Junk_Semicolon_Before_Return is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past the semicolon + + if Token = Tok_Return then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("Unexpected semicolon ignored"); + Scan; -- rescan past junk semicolon + + else + Restore_Scan_State (Scan_State); + end if; + + elsif Bad_Spelling_Of (Tok_Return) then + null; + end if; + end Check_Junk_Semicolon_Before_Return; + + ----------------------------------------------------- + -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) -- + ----------------------------------------------------- + + -- This routine scans out a subprogram declaration, subprogram body, + -- subprogram renaming declaration or subprogram generic instantiation. + + -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; + + -- ABSTRACT_SUBPROGRAM_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION is abstract; + + -- SUBPROGRAM_SPECIFICATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE + -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK + + -- SUBPROGRAM_BODY ::= + -- SUBPROGRAM_SPECIFICATION is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [DESIGNATOR]; + + -- SUBPROGRAM_RENAMING_DECLARATION ::= + -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; + + -- SUBPROGRAM_BODY_STUB ::= + -- SUBPROGRAM_SPECIFICATION is separate; + + -- GENERIC_INSTANTIATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME is + -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; + -- | function DEFINING_DESIGNATOR is + -- new generic_function_NAME [GENERIC_ACTUAL_PART]; + + -- The value in Pf_Flags indicates which of these possible declarations + -- is acceptable to the caller: + + -- Pf_Flags.Decl Set if declaration OK + -- Pf_Flags.Gins Set if generic instantiation OK + -- Pf_Flags.Pbod Set if proper body OK + -- Pf_Flags.Rnam Set if renaming declaration OK + -- Pf_Flags.Stub Set if body stub OK + + -- If an inappropriate form is encountered, it is scanned out but an + -- error message indicating that it is appearing in an inappropriate + -- context is issued. The only possible values for Pf_Flags are those + -- defined as constants in the Par package. + + -- The caller has checked that the initial token is FUNCTION or PROCEDURE + + -- Error recovery: cannot raise Error_Resync + + function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is + Specification_Node : Node_Id; + Name_Node : Node_Id; + Fpart_List : List_Id; + Fpart_Sloc : Source_Ptr; + Return_Node : Node_Id; + Inst_Node : Node_Id; + Body_Node : Node_Id; + Decl_Node : Node_Id; + Rename_Node : Node_Id; + Absdec_Node : Node_Id; + Stub_Node : Node_Id; + Fproc_Sloc : Source_Ptr; + Func : Boolean; + Scan_State : Saved_Scan_State; + + begin + -- Set up scope stack entry. Note that the Labl field will be set later + + SIS_Entry_Active := False; + SIS_Missing_Semicolon_Message := No_Error_Msg; + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + + Func := (Token = Tok_Function); + Fproc_Sloc := Token_Ptr; + Scan; -- past FUNCTION or PROCEDURE + Ignore (Tok_Type); + Ignore (Tok_Body); + + if Func then + Name_Node := P_Defining_Designator; + + if Nkind (Name_Node) = N_Defining_Operator_Symbol + and then Scope.Last = 1 + then + Error_Msg_SP ("operator symbol not allowed at library level"); + Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node)); + + -- Set name from file name, we need some junk name, and that's + -- as good as anything. This is only approximate, since we do + -- not do anything with non-standard name translations. + + Get_Name_String (File_Name (Current_Source_File)); + + for J in 1 .. Name_Len loop + if Name_Buffer (J) = '.' then + Name_Len := J - 1; + exit; + end if; + end loop; + + Set_Chars (Name_Node, Name_Find); + Set_Error_Posted (Name_Node); + end if; + + else + Name_Node := P_Defining_Program_Unit_Name; + end if; + + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Colon then + Error_Msg_SC ("redundant colon ignored"); + Scan; -- past colon + end if; + + -- Deal with generic instantiation, the one case in which we do not + -- have a subprogram specification as part of whatever we are parsing + + if Token = Tok_Is then + Save_Scan_State (Scan_State); -- at the IS + T_Is; -- checks for redundant IS's + + if Token = Tok_New then + if not Pf_Flags.Gins then + Error_Msg_SC ("generic instantation not allowed here!"); + end if; + + Scan; -- past NEW + + if Func then + Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); + Set_Name (Inst_Node, P_Function_Name); + else + Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); + Set_Name (Inst_Node, P_Qualified_Simple_Name); + end if; + + Set_Defining_Unit_Name (Inst_Node, Name_Node); + Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); + TF_Semicolon; + Pop_Scope_Stack; -- Don't need scope stack entry in this case + return Inst_Node; + + else + Restore_Scan_State (Scan_State); -- to the IS + end if; + end if; + + -- If not a generic instantiation, then we definitely have a subprogram + -- specification (all possibilities at this stage include one here) + + Fpart_Sloc := Token_Ptr; + + Check_Misspelling_Of (Tok_Return); + + -- Scan formal part. First a special error check. If we have an + -- identifier here, then we have a definite error. If this identifier + -- is on the same line as the designator, then we assume it is the + -- first formal after a missing left parenthesis + + if Token = Tok_Identifier + and then not Token_Is_At_Start_Of_Line + then + T_Left_Paren; -- to generate message + Fpart_List := P_Formal_Part; + + -- Otherwise scan out an optional formal part in the usual manner + + else + Fpart_List := P_Parameter_Profile; + end if; + + -- We treat what we have as a function specification if FUNCTION was + -- used, or if a RETURN is present. This gives better error recovery + -- since later RETURN statements will be valid in either case. + + Check_Junk_Semicolon_Before_Return; + Return_Node := Error; + + if Token = Tok_Return then + if not Func then + Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc); + Func := True; + end if; + + Scan; -- past RETURN + Return_Node := P_Subtype_Mark; + No_Constraint; + + else + if Func then + Ignore (Tok_Right_Paren); + TF_Return; + end if; + end if; + + if Func then + Specification_Node := + New_Node (N_Function_Specification, Fproc_Sloc); + Set_Subtype_Mark (Specification_Node, Return_Node); + + else + Specification_Node := + New_Node (N_Procedure_Specification, Fproc_Sloc); + end if; + + Set_Defining_Unit_Name (Specification_Node, Name_Node); + Set_Parameter_Specifications (Specification_Node, Fpart_List); + + -- Error check: barriers not allowed on protected functions/procedures + + if Token = Tok_When then + if Func then + Error_Msg_SC ("barrier not allowed on function, only on entry"); + else + Error_Msg_SC ("barrier not allowed on procedure, only on entry"); + end if; + + Scan; -- past WHEN + Discard_Junk_Node (P_Expression); + end if; + + -- Deal with case of semicolon ending a subprogram declaration + + if Token = Tok_Semicolon then + if not Pf_Flags.Decl then + T_Is; + end if; + + Scan; -- past semicolon + + -- If semicolon is immediately followed by IS, then ignore the + -- semicolon, and go process the body. + + if Token = Tok_Is then + Error_Msg_SP ("unexpected semicolon ignored"); + T_Is; -- ignroe redundant IS's + goto Subprogram_Body; + + -- If BEGIN follows in an appropriate column, we immediately + -- commence the error action of assuming that the previous + -- subprogram declaration should have been a subprogram body, + -- i.e. that the terminating semicolon should have been IS. + + elsif Token = Tok_Begin + and then Start_Column >= Scope.Table (Scope.Last).Ecol + then + Error_Msg_SP (""";"" should be IS!"); + goto Subprogram_Body; + + else + goto Subprogram_Declaration; + end if; + + -- Case of not followed by semicolon + + else + -- Subprogram renaming declaration case + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if not Pf_Flags.Rnam then + Error_Msg_SC ("renaming declaration not allowed here!"); + end if; + + Rename_Node := + New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr); + Scan; -- past RENAMES + Set_Name (Rename_Node, P_Name); + Set_Specification (Rename_Node, Specification_Node); + TF_Semicolon; + Pop_Scope_Stack; + return Rename_Node; + + -- Case of IS following subprogram specification + + elsif Token = Tok_Is then + T_Is; -- ignore redundant Is's + + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Semicolon); + end if; + + -- Deal nicely with (now obsolete) use of <> in place of abstract + + if Token = Tok_Box then + Error_Msg_SC ("ABSTRACT expected"); + Token := Tok_Abstract; + end if; + + -- Abstract subprogram declaration case + + if Token = Tok_Abstract then + Absdec_Node := + New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); + Set_Specification (Absdec_Node, Specification_Node); + Pop_Scope_Stack; -- discard unneeded entry + Scan; -- past ABSTRACT + TF_Semicolon; + return Absdec_Node; + + -- Check for IS NEW with Formal_Part present and handle nicely + + elsif Token = Tok_New then + Error_Msg + ("formal part not allowed in instantiation", Fpart_Sloc); + Scan; -- past NEW + + if Func then + Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); + else + Inst_Node := + New_Node (N_Procedure_Instantiation, Fproc_Sloc); + end if; + + Set_Defining_Unit_Name (Inst_Node, Name_Node); + Set_Name (Inst_Node, P_Name); + Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); + TF_Semicolon; + Pop_Scope_Stack; -- Don't need scope stack entry in this case + return Inst_Node; + + else + goto Subprogram_Body; + end if; + + -- Here we have a missing IS or missing semicolon, we always guess + -- a missing semicolon, since we are pretty good at fixing up a + -- semicolon which should really be an IS + + else + Error_Msg_AP ("missing "";"""); + SIS_Missing_Semicolon_Message := Get_Msg_Id; + goto Subprogram_Declaration; + end if; + end if; + + -- Processing for subprogram body + + <<Subprogram_Body>> + if not Pf_Flags.Pbod then + Error_Msg_SP ("subprogram body not allowed here!"); + end if; + + -- Subprogram body stub case + + if Separate_Present then + if not Pf_Flags.Stub then + Error_Msg_SC ("body stub not allowed here!"); + end if; + + if Nkind (Name_Node) = N_Defining_Operator_Symbol then + Error_Msg + ("operator symbol cannot be used as subunit name", + Sloc (Name_Node)); + end if; + + Stub_Node := + New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); + Set_Specification (Stub_Node, Specification_Node); + Scan; -- past SEPARATE + Pop_Scope_Stack; + TF_Semicolon; + return Stub_Node; + + -- Subprogram body case + + else + -- Here is the test for a suspicious IS (i.e. one that looks + -- like it might more properly be a semicolon). See separate + -- section discussing use of IS instead of semicolon in + -- package Parse. + + if (Token in Token_Class_Declk + or else + Token = Tok_Identifier) + and then Start_Column <= Scope.Table (Scope.Last).Ecol + and then Scope.Last /= 1 + then + Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; + Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; + end if; + + Body_Node := + New_Node (N_Subprogram_Body, Sloc (Specification_Node)); + Set_Specification (Body_Node, Specification_Node); + Parse_Decls_Begin_End (Body_Node); + return Body_Node; + end if; + + -- Processing for subprogram declaration + + <<Subprogram_Declaration>> + Decl_Node := + New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); + Set_Specification (Decl_Node, Specification_Node); + + -- If this is a context in which a subprogram body is permitted, + -- set active SIS entry in case (see section titled "Handling + -- Semicolon Used in Place of IS" in body of Parser package) + -- Note that SIS_Missing_Semicolon_Message is already set properly. + + if Pf_Flags.Pbod then + SIS_Labl := Scope.Table (Scope.Last).Labl; + SIS_Sloc := Scope.Table (Scope.Last).Sloc; + SIS_Ecol := Scope.Table (Scope.Last).Ecol; + SIS_Declaration_Node := Decl_Node; + SIS_Semicolon_Sloc := Prev_Token_Ptr; + SIS_Entry_Active := True; + end if; + + Pop_Scope_Stack; + return Decl_Node; + + end P_Subprogram; + + --------------------------------- + -- 6.1 Subprogram Declaration -- + --------------------------------- + + -- Parsed by P_Subprogram (6.1) + + ------------------------------------------ + -- 6.1 Abstract Subprogram Declaration -- + ------------------------------------------ + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------- + -- 6.1 Subprogram Specification -- + ----------------------------------- + + -- SUBPROGRAM_SPECIFICATION ::= + -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE + -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK + + -- Subprogram specifications that appear in subprogram declarations + -- are parsed by P_Subprogram (6.1). This routine is used in other + -- contexts where subprogram specifications occur. + + -- Note: this routine does not affect the scope stack in any way + + -- Error recovery: can raise Error_Resync + + function P_Subprogram_Specification return Node_Id is + Specification_Node : Node_Id; + + begin + if Token = Tok_Function then + Specification_Node := New_Node (N_Function_Specification, Token_Ptr); + Scan; -- past FUNCTION + Ignore (Tok_Body); + Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); + Set_Parameter_Specifications + (Specification_Node, P_Parameter_Profile); + Check_Junk_Semicolon_Before_Return; + TF_Return; + Set_Subtype_Mark (Specification_Node, P_Subtype_Mark); + No_Constraint; + return Specification_Node; + + elsif Token = Tok_Procedure then + Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); + Scan; -- past PROCEDURE + Ignore (Tok_Body); + Set_Defining_Unit_Name + (Specification_Node, P_Defining_Program_Unit_Name); + Set_Parameter_Specifications + (Specification_Node, P_Parameter_Profile); + return Specification_Node; + + else + Error_Msg_SC ("subprogram specification expected"); + raise Error_Resync; + end if; + end P_Subprogram_Specification; + + --------------------- + -- 6.1 Designator -- + --------------------- + + -- DESIGNATOR ::= + -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL + + -- The caller has checked that the initial token is an identifier, + -- operator symbol, or string literal. Note that we don't bother to + -- do much error diagnosis in this routine, since it is only used for + -- the label on END lines, and the routines in package Par.Endh will + -- check that the label is appropriate. + + -- Error recovery: cannot raise Error_Resync + + function P_Designator return Node_Id is + Ident_Node : Node_Id; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + + function Real_Dot return Boolean; + -- Tests if a current token is an interesting period, i.e. is followed + -- by an identifier or operator symbol or string literal. If not, it is + -- probably just incorrect punctuation to be caught by our caller. Note + -- that the case of an operator symbol or string literal is also an + -- error, but that is an error that we catch here. If the result is + -- True, a real dot has been scanned and we are positioned past it, + -- if the result is False, the scan position is unchanged. + + function Real_Dot return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token /= Tok_Dot then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past dot + + if Token = Tok_Identifier + or else Token = Tok_Operator_Symbol + or else Token = Tok_String_Literal + then + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end Real_Dot; + + -- Start of processing for P_Designator + + begin + Ident_Node := Token_Node; + Scan; -- past initial token + + if Prev_Token = Tok_Operator_Symbol + or else Prev_Token = Tok_String_Literal + or else not Real_Dot + then + return Ident_Node; + + -- Child name case + + else + Prefix_Node := Ident_Node; + + -- Loop through child names, on entry to this loop, Prefix contains + -- the name scanned so far, and Ident_Node is the last identifier. + + loop + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Ident_Node := P_Identifier; + Set_Selector_Name (Name_Node, Ident_Node); + Prefix_Node := Name_Node; + exit when not Real_Dot; + end loop; + + -- On exit from the loop, Ident_Node is the last identifier scanned, + -- i.e. the defining identifier, and Prefix_Node is a node for the + -- entire name, structured (incorrectly!) as a selected component. + + Name_Node := Prefix (Prefix_Node); + Change_Node (Prefix_Node, N_Designator); + Set_Name (Prefix_Node, Name_Node); + Set_Identifier (Prefix_Node, Ident_Node); + return Prefix_Node; + end if; + + exception + when Error_Resync => + while Token = Tok_Dot or else Token = Tok_Identifier loop + Scan; + end loop; + + return Error; + end P_Designator; + + ------------------------------ + -- 6.1 Defining Designator -- + ------------------------------ + + -- DEFINING_DESIGNATOR ::= + -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL + + -- Error recovery: cannot raise Error_Resync + + function P_Defining_Designator return Node_Id is + begin + if Token = Tok_Operator_Symbol then + return P_Defining_Operator_Symbol; + + elsif Token = Tok_String_Literal then + Error_Msg_SC ("invalid operator name"); + Scan; -- past junk string + return Error; + + else + return P_Defining_Program_Unit_Name; + end if; + end P_Defining_Designator; + + ------------------------------------- + -- 6.1 Defining Program Unit Name -- + ------------------------------------- + + -- DEFINING_PROGRAM_UNIT_NAME ::= + -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER + + -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level + + -- Error recovery: cannot raise Error_Resync + + function P_Defining_Program_Unit_Name return Node_Id is + Ident_Node : Node_Id; + Name_Node : Node_Id; + Prefix_Node : Node_Id; + + begin + -- Set identifier casing if not already set and scan initial identifier + + if Token = Tok_Identifier + and then Identifier_Casing (Current_Source_File) = Unknown + then + Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing); + end if; + + Ident_Node := P_Identifier; + Merge_Identifier (Ident_Node, Tok_Return); + + -- Normal case (not child library unit name) + + if Token /= Tok_Dot then + Change_Identifier_To_Defining_Identifier (Ident_Node); + return Ident_Node; + + -- Child library unit name case + + else + if Scope.Last > 1 then + Error_Msg_SP ("child unit allowed only at library level"); + raise Error_Resync; + + elsif Ada_83 then + Error_Msg_SP ("(Ada 83) child unit not allowed!"); + + end if; + + Prefix_Node := Ident_Node; + + -- Loop through child names, on entry to this loop, Prefix contains + -- the name scanned so far, and Ident_Node is the last identifier. + + loop + exit when Token /= Tok_Dot; + Name_Node := New_Node (N_Selected_Component, Token_Ptr); + Scan; -- past period + Set_Prefix (Name_Node, Prefix_Node); + Ident_Node := P_Identifier; + Set_Selector_Name (Name_Node, Ident_Node); + Prefix_Node := Name_Node; + end loop; + + -- On exit from the loop, Ident_Node is the last identifier scanned, + -- i.e. the defining identifier, and Prefix_Node is a node for the + -- entire name, structured (incorrectly!) as a selected component. + + Name_Node := Prefix (Prefix_Node); + Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); + Set_Name (Prefix_Node, Name_Node); + Change_Identifier_To_Defining_Identifier (Ident_Node); + Set_Defining_Identifier (Prefix_Node, Ident_Node); + + -- All set with unit name parsed + + return Prefix_Node; + end if; + + exception + when Error_Resync => + while Token = Tok_Dot or else Token = Tok_Identifier loop + Scan; + end loop; + + return Error; + end P_Defining_Program_Unit_Name; + + -------------------------- + -- 6.1 Operator Symbol -- + -------------------------- + + -- OPERATOR_SYMBOL ::= STRING_LITERAL + + -- Operator symbol is returned by the scanner as Tok_Operator_Symbol + + ----------------------------------- + -- 6.1 Defining Operator Symbol -- + ----------------------------------- + + -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL + + -- The caller has checked that the initial symbol is an operator symbol + + function P_Defining_Operator_Symbol return Node_Id is + Op_Node : Node_Id; + + begin + Op_Node := Token_Node; + Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); + Scan; -- past operator symbol + return Op_Node; + end P_Defining_Operator_Symbol; + + ---------------------------- + -- 6.1 Parameter_Profile -- + ---------------------------- + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- Empty is returned if no formal part is present + + -- Error recovery: cannot raise Error_Resync + + function P_Parameter_Profile return List_Id is + begin + if Token = Tok_Left_Paren then + Scan; -- part left paren + return P_Formal_Part; + else + return No_List; + end if; + end P_Parameter_Profile; + + --------------------------------------- + -- 6.1 Parameter And Result Profile -- + --------------------------------------- + + -- Parsed by its parent construct, which uses P_Parameter_Profile to + -- parse the parameters, and P_Subtype_Mark to parse the return type. + + ---------------------- + -- 6.1 Formal part -- + ---------------------- + + -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) + + -- PARAMETER_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- This scans the construct Formal_Part. The caller has already checked + -- that the initial token is a left parenthesis, and skipped past it, so + -- that on entry Token is the first token following the left parenthesis. + + -- Error recovery: cannot raise Error_Resync + + function P_Formal_Part return List_Id is + Specification_List : List_Id; + Specification_Node : Node_Id; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + Specification_List := New_List; + + Specification_Loop : loop + begin + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + end if; + + Ignore (Tok_Left_Paren); + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + Ident_Loop : loop + exit Ident_Loop when Token = Tok_Colon; + + -- The only valid tokens are colon and comma, so if we have + -- neither do a bit of investigation to see which is the + -- better choice for insertion. + + if Token /= Tok_Comma then + + -- Assume colon if IN or OUT keyword found + + exit Ident_Loop when Token = Tok_In or else Token = Tok_Out; + + -- Otherwise scan ahead + + Save_Scan_State (Scan_State); + Look_Ahead : loop + + -- If we run into a semicolon, then assume that a + -- colon was missing, e.g. Parms (X Y; ...). Also + -- assume missing colon on EOF (a real disaster!) + -- and on a right paren, e.g. Parms (X Y), and also + -- on an assignment symbol, e.g. Parms (X Y := ..) + + if Token = Tok_Semicolon + or else Token = Tok_Right_Paren + or else Token = Tok_EOF + or else Token = Tok_Colon_Equal + then + Restore_Scan_State (Scan_State); + exit Ident_Loop; + + -- If we run into a colon, assume that we had a missing + -- comma, e.g. Parms (A B : ...). Also assume a missing + -- comma if we hit another comma, e.g. Parms (A B, C ..) + + elsif Token = Tok_Colon + or else Token = Tok_Comma + then + Restore_Scan_State (Scan_State); + exit Look_Ahead; + end if; + + Scan; + end loop Look_Ahead; + end if; + + -- Here if a comma is present, or to be assumed + + T_Comma; + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop Ident_Loop; + + -- Fall through the loop on encountering a colon, or deciding + -- that there is a missing colon. + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + + Ident_List_Loop : loop + Specification_Node := + New_Node (N_Parameter_Specification, Ident_Sloc); + Set_Defining_Identifier (Specification_Node, Idents (Ident)); + + if Token = Tok_Access then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access parameters not allowed"); + end if; + + Set_Parameter_Type + (Specification_Node, P_Access_Definition); + + else + P_Mode (Specification_Node); + + if Token = Tok_Procedure + or else + Token = Tok_Function + then + Error_Msg_SC ("formal subprogram parameter not allowed"); + Scan; + + if Token = Tok_Left_Paren then + Discard_Junk_List (P_Formal_Part); + end if; + + if Token = Tok_Return then + Scan; + Discard_Junk_Node (P_Subtype_Mark); + end if; + + Set_Parameter_Type (Specification_Node, Error); + + else + Set_Parameter_Type (Specification_Node, P_Subtype_Mark); + No_Constraint; + end if; + end if; + + Set_Expression (Specification_Node, Init_Expr_Opt (True)); + + if Ident > 1 then + Set_Prev_Ids (Specification_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Specification_Node, True); + end if; + + Append (Specification_Node, Specification_List); + exit Ident_List_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_List_Loop; + + exception + when Error_Resync => + Resync_Semicolon_List; + end; + + if Token = Tok_Semicolon then + Scan; -- past semicolon + + -- If we have RETURN or IS after the semicolon, then assume + -- that semicolon should have been a right parenthesis and exit + + if Token = Tok_Is or else Token = Tok_Return then + Error_Msg_SP ("expected "")"" in place of "";"""); + exit Specification_Loop; + end if; + + elsif Token = Tok_Right_Paren then + Scan; -- past right paren + exit Specification_Loop; + + -- Special check for common error of using comma instead of semicolon + + elsif Token = Tok_Comma then + T_Semicolon; + Scan; -- past comma + + -- Special check for omitted separator + + elsif Token = Tok_Identifier then + T_Semicolon; + + -- If nothing sensible, skip to next semicolon or right paren + + else + T_Semicolon; + Resync_Semicolon_List; + + if Token = Tok_Semicolon then + Scan; -- past semicolon + else + T_Right_Paren; + exit Specification_Loop; + end if; + end if; + end loop Specification_Loop; + + return Specification_List; + end P_Formal_Part; + + ---------------------------------- + -- 6.1 Parameter Specification -- + ---------------------------------- + + -- Parsed by P_Formal_Part (6.1) + + --------------- + -- 6.1 Mode -- + --------------- + + -- MODE ::= [in] | in out | out + + -- There is no explicit node in the tree for the Mode. Instead the + -- In_Present and Out_Present flags are set in the parent node to + -- record the presence of keywords specifying the mode. + + -- Error_Recovery: cannot raise Error_Resync + + procedure P_Mode (Node : Node_Id) is + begin + if Token = Tok_In then + Scan; -- past IN + Set_In_Present (Node, True); + end if; + + if Token = Tok_Out then + Scan; -- past OUT + Set_Out_Present (Node, True); + end if; + + if Token = Tok_In then + Error_Msg_SC ("IN must preceed OUT in parameter mode"); + Scan; -- past IN + Set_In_Present (Node, True); + end if; + end P_Mode; + + -------------------------- + -- 6.3 Subprogram Body -- + -------------------------- + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------- + -- 6.4 Procedure Call Statement -- + ----------------------------------- + + -- Parsed by P_Sequence_Of_Statements (5.1) + + ------------------------ + -- 6.4 Function Call -- + ------------------------ + + -- Parsed by P_Call_Or_Name (4.1) + + -------------------------------- + -- 6.4 Actual Parameter Part -- + -------------------------------- + + -- Parsed by P_Call_Or_Name (4.1) + + -------------------------------- + -- 6.4 Parameter Association -- + -------------------------------- + + -- Parsed by P_Call_Or_Name (4.1) + + ------------------------------------ + -- 6.4 Explicit Actual Parameter -- + ------------------------------------ + + -- Parsed by P_Call_Or_Name (4.1) + + --------------------------- + -- 6.5 Return Statement -- + --------------------------- + + -- RETURN_STATEMENT ::= return [EXPRESSION]; + + -- The caller has checked that the initial token is RETURN + + -- Error recovery: can raise Error_Resync + + function P_Return_Statement return Node_Id is + Return_Node : Node_Id; + + begin + Return_Node := New_Node (N_Return_Statement, Token_Ptr); + + -- Sloc points to RETURN + -- Expression (Op3) + + Scan; -- past RETURN + + if Token /= Tok_Semicolon then + + -- If no semicolon, then scan an expression, except that + -- we avoid trying to scan an expression if we are at an + -- expression terminator since in that case the best error + -- message is probably that we have a missing semicolon. + + if Token not in Token_Class_Eterm then + Set_Expression (Return_Node, P_Expression_No_Right_Paren); + end if; + end if; + + TF_Semicolon; + return Return_Node; + end P_Return_Statement; + +end Ch6; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb new file mode 100644 index 00000000000..de632133f4b --- /dev/null +++ b/gcc/ada/par-ch7.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 7 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.29 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch7 is + + --------------------------------------------- + -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) -- + --------------------------------------------- + + -- This routine scans out a package declaration, package body, or a + -- renaming declaration or generic instantiation starting with PACKAGE + + -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; + + -- PACKAGE_SPECIFICATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- {BASIC_DECLARATIVE_ITEM} + -- [private + -- {BASIC_DECLARATIVE_ITEM}] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_BODY ::= + -- package body DEFINING_PROGRAM_UNIT_NAME is + -- DECLARATIVE_PART + -- [begin + -- HANDLED_SEQUENCE_OF_STATEMENTS] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_RENAMING_DECLARATION ::= + -- package DEFINING_IDENTIFIER renames package_NAME; + + -- PACKAGE_BODY_STUB ::= + -- package body DEFINING_IDENTIFIER is separate; + + -- The value in Pf_Flags indicates which of these possible declarations + -- is acceptable to the caller: + + -- Pf_Flags.Spcn Set if specification OK + -- Pf_Flags.Decl Set if declaration OK + -- Pf_Flags.Gins Set if generic instantiation OK + -- Pf_Flags.Pbod Set if proper body OK + -- Pf_Flags.Rnam Set if renaming declaration OK + -- Pf_Flags.Stub Set if body stub OK + + -- If an inappropriate form is encountered, it is scanned out but an + -- error message indicating that it is appearing in an inappropriate + -- context is issued. The only possible settings for Pf_Flags are those + -- defined as constants in package Par. + + -- Note: in all contexts where a package specification is required, there + -- is a terminating semicolon. This semicolon is scanned out in the case + -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part + -- of the package specification (it's just too much trouble, and really + -- quite unnecessary, to deal with scanning out an END where the semicolon + -- after the END is not considered to be part of the END. + + -- The caller has checked that the initial token is PACKAGE + + -- Error recovery: cannot raise Error_Resync + + function P_Package (Pf_Flags : Pf_Rec) return Node_Id is + Package_Node : Node_Id; + Specification_Node : Node_Id; + Name_Node : Node_Id; + Package_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + + Package_Sloc := Token_Ptr; + Scan; -- past PACKAGE + + if Token = Tok_Type then + Error_Msg_SC ("TYPE not allowed here"); + Scan; -- past TYPE + end if; + + -- Case of package body. Note that we demand a package body if that + -- is the only possibility (even if the BODY keyword is not present) + + if Token = Tok_Body or else Pf_Flags = Pf_Pbod then + if not Pf_Flags.Pbod then + Error_Msg_SC ("package body cannot appear here!"); + end if; + + T_Body; + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + TF_Is; + + if Separate_Present then + if not Pf_Flags.Stub then + Error_Msg_SC ("body stub cannot appear here!"); + end if; + + Scan; -- past SEPARATE + TF_Semicolon; + Pop_Scope_Stack; + + Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); + Set_Defining_Identifier (Package_Node, Name_Node); + + else + Package_Node := New_Node (N_Package_Body, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Parse_Decls_Begin_End (Package_Node); + end if; + + return Package_Node; + + -- Cases other than Package_Body + + else + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + + -- Case of renaming declaration + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if not Pf_Flags.Rnam then + Error_Msg_SC ("renaming declaration cannot appear here!"); + end if; + + Scan; -- past RENAMES; + + Package_Node := + New_Node (N_Package_Renaming_Declaration, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + + No_Constraint; + TF_Semicolon; + Pop_Scope_Stack; + return Package_Node; + + else + TF_Is; + + -- Case of generic instantiation + + if Token = Tok_New then + if not Pf_Flags.Gins then + Error_Msg_SC + ("generic instantiation cannot appear here!"); + end if; + + Scan; -- past NEW + + Package_Node := + New_Node (N_Package_Instantiation, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + Set_Generic_Associations + (Package_Node, P_Generic_Actual_Part_Opt); + TF_Semicolon; + Pop_Scope_Stack; + + -- Case of package declaration or package specification + + else + Specification_Node := + New_Node (N_Package_Specification, Package_Sloc); + + Set_Defining_Unit_Name (Specification_Node, Name_Node); + Set_Visible_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + if Token = Tok_Private then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if Style.RM_Column_Check then + if Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC + ("(style) PRIVATE in wrong column, should be@"); + end if; + end if; + + Scan; -- past PRIVATE + Set_Private_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC + ("only one private part allowed per package"); + Scan; -- past PRIVATE + Append_List (P_Basic_Declarative_Items, + Private_Declarations (Specification_Node)); + end loop; + end if; + + if Pf_Flags = Pf_Spcn then + Package_Node := Specification_Node; + else + Package_Node := + New_Node (N_Package_Declaration, Package_Sloc); + Set_Specification (Package_Node, Specification_Node); + end if; + + if Token = Tok_Begin then + Error_Msg_SC ("begin block not allowed in package spec"); + Scan; -- past BEGIN + Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); + end if; + + End_Statements (Specification_Node); + end if; + + return Package_Node; + end if; + end if; + end P_Package; + + ------------------------------ + -- 7.1 Package Declaration -- + ------------------------------ + + -- Parsed by P_Package (7.1) + + -------------------------------- + -- 7.1 Package Specification -- + -------------------------------- + + -- Parsed by P_Package (7.1) + + ----------------------- + -- 7.1 Package Body -- + ----------------------- + + -- Parsed by P_Package (7.1) + + ----------------------------------- + -- 7.3 Private Type Declaration -- + ----------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------------------- + -- 7.3 Private Extension Declaration -- + ---------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + +end Ch7; diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb new file mode 100644 index 00000000000..9d1b386280d --- /dev/null +++ b/gcc/ada/par-ch8.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 8 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch8 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Use_Package_Clause return Node_Id; + function P_Use_Type_Clause return Node_Id; + + --------------------- + -- 8.4 Use Clause -- + --------------------- + + -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE + + -- The caller has checked that the initial token is USE + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Clause return Node_Id is + begin + Scan; -- past USE + + if Token = Tok_Type then + return P_Use_Type_Clause; + + else + return P_Use_Package_Clause; + end if; + end P_Use_Clause; + + ----------------------------- + -- 8.4 Use Package Clause -- + ----------------------------- + + -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME}; + + -- The caller has scanned out the USE keyword + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Package_Clause return Node_Id is + Use_Node : Node_Id; + + begin + Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr); + Set_Names (Use_Node, New_List); + + if Token = Tok_Package then + Error_Msg_SC ("PACKAGE should not appear here"); + Scan; -- past PACKAGE + end if; + + loop + Append (P_Qualified_Simple_Name, Names (Use_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Use_Node; + end P_Use_Package_Clause; + + -------------------------- + -- 8.4 Use Type Clause -- + -------------------------- + + -- USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK}; + + -- The caller has checked that the initial token is USE, scanned it out + -- and that the current token is TYPE. + + -- Error recovery: cannot raise Error_Resync + + function P_Use_Type_Clause return Node_Id is + Use_Node : Node_Id; + + begin + Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr); + Set_Subtype_Marks (Use_Node, New_List); + + if Ada_83 then + Error_Msg_SC ("(Ada 83) use type not allowed!"); + end if; + + Scan; -- past TYPE + + loop + Append (P_Subtype_Mark, Subtype_Marks (Use_Node)); + No_Constraint; + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Use_Node; + end P_Use_Type_Clause; + + ------------------------------- + -- 8.5 Renaming Declaration -- + ------------------------------- + + -- Object renaming declarations and exception renaming declarations + -- are parsed by P_Identifier_Declaration (3.3.1) + + -- Subprogram renaming declarations are parsed by P_Subprogram (6.1) + + -- Package renaming declarations are parsed by P_Package (7.1) + + -- Generic renaming declarations are parsed by P_Generic (12.1) + + ---------------------------------------- + -- 8.5.1 Object Renaming Declaration -- + ---------------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3.1) + + ---------------------------------------- + -- 8.5.2 Exception Renaming Declaration -- + ---------------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3.1) + + ----------------------------------------- + -- 8.5.3 Package Renaming Declaration -- + ----------------------------------------- + + -- Parsed by P_Package (7.1) + + -------------------------------------------- + -- 8.5.4 Subprogram Renaming Declaration -- + -------------------------------------------- + + -- Parsed by P_Subprogram (6.1) + + ----------------------------------------- + -- 8.5.2 Generic Renaming Declaration -- + ----------------------------------------- + + -- Parsed by P_Generic (12.1) + +end Ch8; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb new file mode 100644 index 00000000000..87d6be6ae5f --- /dev/null +++ b/gcc/ada/par-ch9.adb @@ -0,0 +1,1616 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.82 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch9 is + + -- Local subprograms, used only in this chapter + + function P_Accept_Alternative return Node_Id; + function P_Delay_Alternative return Node_Id; + function P_Delay_Relative_Statement return Node_Id; + function P_Delay_Until_Statement return Node_Id; + function P_Entry_Barrier return Node_Id; + function P_Entry_Body_Formal_Part return Node_Id; + function P_Entry_Declaration return Node_Id; + function P_Entry_Index_Specification return Node_Id; + function P_Protected_Definition return Node_Id; + function P_Protected_Operation_Declaration_Opt return Node_Id; + function P_Protected_Operation_Items return List_Id; + function P_Task_Definition return Node_Id; + function P_Task_Items return List_Id; + + ----------------------------- + -- 9.1 Task (also 10.1.3) -- + ----------------------------- + + -- TASK_TYPE_DECLARATION ::= + -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- [is TASK_DEFINITION]; + + -- SINGLE_TASK_DECLARATION ::= + -- task DEFINING_IDENTIFIER [is TASK_DEFINITION]; + + -- TASK_BODY ::= + -- task body DEFINING_IDENTIFIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [task_IDENTIFIER] + + -- TASK_BODY_STUB ::= + -- task body DEFINING_IDENTIFIER is separate; + + -- This routine scans out a task declaration, task body, or task stub + + -- The caller has checked that the initial token is TASK and scanned + -- past it, so that Token is set to the token after TASK + + -- Error recovery: cannot raise Error_Resync + + function P_Task return Node_Id is + Name_Node : Node_Id; + Task_Node : Node_Id; + Task_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Lreq := False; + Task_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier; + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in task body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + TF_Is; + + -- Task stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Task body + + else + Task_Node := New_Node (N_Task_Body, Task_Sloc); + Set_Defining_Identifier (Task_Node, Name_Node); + Parse_Decls_Begin_End (Task_Node); + end if; + + return Task_Node; + + -- Otherwise we must have a task declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Task_Node, P_Known_Discriminant_Part_Opt); + + else + Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Task_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed for single task"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + end if; + + -- Parse optional task definition. Note that P_Task_Definition scans + -- out the semicolon as well as the task definition itself. + + if Token = Tok_Semicolon then + + -- A little check, if the next token after semicolon is + -- Entry, then surely the semicolon should really be IS + + Scan; -- past semicolon + + if Token = Tok_Entry then + Error_Msg_SP (""";"" should be IS"); + Set_Task_Definition (Task_Node, P_Task_Definition); + else + Pop_Scope_Stack; -- Remove unused entry + end if; + else + TF_Is; -- must have IS if no semicolon + Set_Task_Definition (Task_Node, P_Task_Definition); + end if; + + return Task_Node; + end if; + end P_Task; + + -------------------------------- + -- 9.1 Task Type Declaration -- + -------------------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.1 Single Task Declaration -- + ---------------------------------- + + -- Parsed by P_Task (9.1) + + -------------------------- + -- 9.1 Task Definition -- + -------------------------- + + -- TASK_DEFINITION ::= + -- {TASK_ITEM} + -- [private + -- {TASK_ITEM}] + -- end [task_IDENTIFIER]; + + -- The caller has already made the scope stack entry + + -- Note: there is a small deviation from official syntax here in that we + -- regard the semicolon after end as part of the Task_Definition, and in + -- the official syntax, it's part of the enclosing declaration. The reason + -- for this deviation is that otherwise the end processing would have to + -- be special cased, which would be a nuisance! + + -- Error recovery: cannot raise Error_Resync + + function P_Task_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Task_Definition, Token_Ptr); + Set_Visible_Declarations (Def_Node, P_Task_Items); + + if Token = Tok_Private then + Scan; -- past PRIVATE + Set_Private_Declarations (Def_Node, P_Task_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC ("Only one private part allowed per task"); + Scan; -- past PRIVATE + Append_List (P_Task_Items, Private_Declarations (Def_Node)); + end loop; + end if; + + End_Statements (Def_Node); + return Def_Node; + end P_Task_Definition; + + -------------------- + -- 9.1 Task Item -- + -------------------- + + -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE + + -- This subprogram scans a (possibly empty) list of task items and pragmas + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + function P_Task_Items return List_Id is + Items : List_Id; + Item_Node : Node_Id; + Decl_Sloc : Source_Ptr; + + begin + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan out task items + + Items := New_List; + + Decl_Loop : loop + Decl_Sloc := Token_Ptr; + + if Token = Tok_Pragma then + Append (P_Pragma, Items); + + elsif Token = Tok_Entry then + Append (P_Entry_Declaration, Items); + + elsif Token = Tok_For then + -- Representation clause in task declaration. The only rep + -- clause which is legal in a protected is an address clause, + -- so that is what we try to scan out. + + Item_Node := P_Representation_Clause; + + if Nkind (Item_Node) = N_At_Clause then + Append (Item_Node, Items); + + elsif Nkind (Item_Node) = N_Attribute_Definition_Clause + and then Chars (Item_Node) = Name_Address + then + Append (Item_Node, Items); + + else + Error_Msg + ("the only representation clause " & + "allowed here is an address clause!", Decl_Sloc); + end if; + + elsif Token = Tok_Identifier + or else Token in Token_Class_Declk + then + Error_Msg_SC ("Illegal declaration in task definition"); + Resync_Past_Semicolon; + + else + exit Decl_Loop; + end if; + end loop Decl_Loop; + + return Items; + end P_Task_Items; + + -------------------- + -- 9.1 Task Body -- + -------------------- + + -- Parsed by P_Task (9.1) + + ---------------------------------- + -- 9.4 Protected (also 10.1.3) -- + ---------------------------------- + + -- PROTECTED_TYPE_DECLARATION ::= + -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] + -- is PROTECTED_DEFINITION; + + -- SINGLE_PROTECTED_DECLARATION ::= + -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION; + + -- PROTECTED_BODY ::= + -- protected body DEFINING_IDENTIFIER is + -- {PROTECTED_OPERATION_ITEM} + -- end [protected_IDENTIFIER]; + + -- PROTECTED_BODY_STUB ::= + -- protected body DEFINING_IDENTIFIER is separate; + + -- This routine scans out a protected declaration, protected body + -- or a protected stub. + + -- The caller has checked that the initial token is PROTECTED and + -- scanned past it, so Token is set to the following token. + + -- Error recovery: cannot raise Error_Resync + + function P_Protected return Node_Id is + Name_Node : Node_Id; + Protected_Node : Node_Id; + Protected_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Protected_Sloc := Prev_Token_Ptr; + + if Token = Tok_Body then + Scan; -- past BODY + Name_Node := P_Defining_Identifier; + Scope.Table (Scope.Last).Labl := Name_Node; + + if Token = Tok_Left_Paren then + Error_Msg_SC ("discriminant part not allowed in protected body"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + TF_Is; + + -- Protected stub + + if Token = Tok_Separate then + Scan; -- past SEPARATE + Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + TF_Semicolon; + Pop_Scope_Stack; -- remove unused entry + + -- Protected body + + else + Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); + Set_Defining_Identifier (Protected_Node, Name_Node); + Set_Declarations (Protected_Node, P_Protected_Operation_Items); + End_Statements (Protected_Node); + end if; + + return Protected_Node; + + -- Otherwise we must have a protected declaration + + else + if Token = Tok_Type then + Scan; -- past TYPE + Protected_Node := + New_Node (N_Protected_Type_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Protected_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + Set_Discriminant_Specifications + (Protected_Node, P_Known_Discriminant_Part_Opt); + + else + Protected_Node := + New_Node (N_Single_Protected_Declaration, Protected_Sloc); + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Protected_Node, Name_Node); + + if Token = Tok_Left_Paren then + Error_Msg_SC + ("discriminant part not allowed for single protected"); + Discard_Junk_List (P_Known_Discriminant_Part_Opt); + end if; + + Scope.Table (Scope.Last).Labl := Name_Node; + end if; + + T_Is; + Set_Protected_Definition (Protected_Node, P_Protected_Definition); + return Protected_Node; + end if; + end P_Protected; + + ------------------------------------- + -- 9.4 Protected Type Declaration -- + ------------------------------------- + + -- Parsed by P_Protected (9.4) + + --------------------------------------- + -- 9.4 Single Protected Declaration -- + --------------------------------------- + + -- Parsed by P_Protected (9.4) + + ------------------------------- + -- 9.4 Protected Definition -- + ------------------------------- + + -- PROTECTED_DEFINITION ::= + -- {PROTECTED_OPERATION_DECLARATION} + -- [private + -- {PROTECTED_ELEMENT_DECLARATION}] + -- end [protected_IDENTIFIER] + + -- PROTECTED_ELEMENT_DECLARATION ::= + -- PROTECTED_OPERATION_DECLARATION + -- | COMPONENT_DECLARATION + + -- The caller has already established the scope stack entry + + -- Error recovery: cannot raise Error_Resync + + function P_Protected_Definition return Node_Id is + Def_Node : Node_Id; + Item_Node : Node_Id; + + begin + Def_Node := New_Node (N_Protected_Definition, Token_Ptr); + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan visible declarations (protected operation declarations) + + Set_Visible_Declarations (Def_Node, New_List); + + loop + Item_Node := P_Protected_Operation_Declaration_Opt; + exit when No (Item_Node); + Append (Item_Node, Visible_Declarations (Def_Node)); + end loop; + + -- Deal with PRIVATE part (including graceful handling + -- of multiple PRIVATE parts). + + Private_Loop : while Token = Tok_Private loop + if No (Private_Declarations (Def_Node)) then + Set_Private_Declarations (Def_Node, New_List); + else + Error_Msg_SC ("duplicate private part"); + end if; + + Scan; -- past PRIVATE + + Declaration_Loop : loop + if Token = Tok_Identifier then + P_Component_Items (Private_Declarations (Def_Node)); + else + Item_Node := P_Protected_Operation_Declaration_Opt; + exit Declaration_Loop when No (Item_Node); + Append (Item_Node, Private_Declarations (Def_Node)); + end if; + end loop Declaration_Loop; + end loop Private_Loop; + + End_Statements (Def_Node); + return Def_Node; + end P_Protected_Definition; + + ------------------------------------------ + -- 9.4 Protected Operation Declaration -- + ------------------------------------------ + + -- PROTECTED_OPERATION_DECLARATION ::= + -- SUBPROGRAM_DECLARATION + -- | ENTRY_DECLARATION + -- | REPRESENTATION_CLAUSE + + -- Error recovery: cannot raise Error_Resync + + -- Note: a pragma can also be returned in this position + + -- We are not currently permitting representation clauses to appear as + -- protected operation declarations, do we have to rethink this??? + + function P_Protected_Operation_Declaration_Opt return Node_Id is + L : List_Id; + P : Source_Ptr; + + begin + -- This loop runs more than once only when a junk declaration + -- is skipped. + + loop + if Token = Tok_Pragma then + return P_Pragma; + + elsif Token = Tok_Entry then + return P_Entry_Declaration; + + elsif Token = Tok_Function or else Token = Tok_Procedure then + return P_Subprogram (Pf_Decl); + + elsif Token = Tok_Identifier then + L := New_List; + P := Token_Ptr; + Skip_Declaration (L); + + if Nkind (First (L)) = N_Object_Declaration then + Error_Msg + ("component must be declared in private part of " & + "protected type", P); + else + Error_Msg + ("illegal declaration in protected definition", P); + end if; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("illegal declaration in protected definition"); + Resync_Past_Semicolon; + + -- Return now to avoid cascaded messages if next declaration + -- is a valid component declaration. + + return Error; + + elsif Token = Tok_For then + Error_Msg_SC + ("representation clause not allowed in protected definition"); + Resync_Past_Semicolon; + + else + return Empty; + end if; + end loop; + end P_Protected_Operation_Declaration_Opt; + + ----------------------------------- + -- 9.4 Protected Operation Item -- + ----------------------------------- + + -- PROTECTED_OPERATION_ITEM ::= + -- SUBPROGRAM_DECLARATION + -- | SUBPROGRAM_BODY + -- | ENTRY_BODY + -- | REPRESENTATION_CLAUSE + + -- This procedure parses and returns a list of protected operation items + + -- We are not currently permitting representation clauses to appear + -- as protected operation items, do we have to rethink this??? + + function P_Protected_Operation_Items return List_Id is + Item_List : List_Id; + + begin + Item_List := New_List; + + loop + if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then + Append (P_Entry_Body, Item_List); + + elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function) + or else + Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure) + then + Append (P_Subprogram (Pf_Decl_Pbod), Item_List); + + elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then + P_Pragmas_Opt (Item_List); + + elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then + Error_Msg_SC ("PRIVATE not allowed in protected body"); + Scan; -- past PRIVATE + + elsif Token = Tok_Identifier then + Error_Msg_SC + ("all components must be declared in spec!"); + Resync_Past_Semicolon; + + elsif Token in Token_Class_Declk then + Error_Msg_SC ("this declaration not allowed in protected body"); + Resync_Past_Semicolon; + + else + exit; + end if; + end loop; + + return Item_List; + end P_Protected_Operation_Items; + + ------------------------------ + -- 9.5.2 Entry Declaration -- + ------------------------------ + + -- ENTRY_DECLARATION ::= + -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] + -- PARAMETER_PROFILE; + + -- The caller has checked that the initial token is ENTRY + + -- Error recovery: cannot raise Error_Resync + + function P_Entry_Declaration return Node_Id is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); + Scan; -- past ENTRY + + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); + + -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part + + if Token = Tok_Left_Paren then + Scan; -- past ( + + -- If identifier after left paren, could still be either + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + -- If comma or colon after Id, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to Id + Set_Parameter_Specifications (Decl_Node, P_Formal_Part); + + -- Else if Id wi no comma or colon, must be discrete subtype defn + + else + Restore_Scan_State (Scan_State); -- to Id + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + + -- If no Id, must be discrete subtype definition + + else + Set_Discrete_Subtype_Definition + (Decl_Node, P_Discrete_Subtype_Definition); + T_Right_Paren; + Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile); + end if; + end if; + + -- Error recovery check for illegal return + + if Token = Tok_Return then + Error_Msg_SC ("entry cannot have return value!"); + Scan; + Discard_Junk_Node (P_Subtype_Indication); + end if; + + -- Error recovery check for improper use of entry barrier in spec + + if Token = Tok_When then + Error_Msg_SC ("barrier not allowed here (belongs in body)"); + Scan; -- past WHEN; + Discard_Junk_Node (P_Expression_No_Right_Paren); + end if; + + TF_Semicolon; + return Decl_Node; + end P_Entry_Declaration; + + ----------------------------- + -- 9.5.2 Accept Statement -- + ----------------------------- + + -- ACCEPT_STATEMENT ::= + -- accept entry_DIRECT_NAME + -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]]; + + -- The caller has checked that the initial token is ACCEPT + + -- Error recovery: cannot raise Error_Resync. If an error occurs, the + -- scan is resynchronized past the next semicolon and control returns. + + function P_Accept_Statement return Node_Id is + Scan_State : Saved_Scan_State; + Accept_Node : Node_Id; + Hand_Seq : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); + Scan; -- past ACCEPT + Scope.Table (Scope.Last).Labl := Token_Node; + + Set_Entry_Direct_Name (Accept_Node, P_Identifier); + + -- Left paren could be (Entry_Index) or Formal_Part, determine which + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + -- If first token after left paren not identifier, then Entry_Index + + if Token /= Tok_Identifier then + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- First token after left paren is identifier, could be either case + + else -- Token = Tok_Identifier + Scan; -- past identifier + + -- If identifier followed by comma or colon, must be Formal_Part + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); -- to left paren + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + + -- If identifier not followed by comma/colon, must be entry index + + else + Restore_Scan_State (Scan_State); -- to left paren + Scan; -- past left paren (again!) + Set_Entry_Index (Accept_Node, P_Expression); + T_Right_Paren; + Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); + end if; + end if; + end if; + + -- Scan out DO if present + + if Token = Tok_Do then + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Lreq := False; + Scan; -- past DO + Hand_Seq := P_Handled_Sequence_Of_Statements; + Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq); + End_Statements (Handled_Statement_Sequence (Accept_Node)); + + -- Exception handlers not allowed in Ada 95 node + + if Present (Exception_Handlers (Hand_Seq)) then + if Ada_83 then + Error_Msg_N + ("(Ada 83) exception handlers in accept not allowed", + First_Non_Pragma (Exception_Handlers (Hand_Seq))); + end if; + end if; + + else + Pop_Scope_Stack; -- discard unused entry + TF_Semicolon; + end if; + + return Accept_Node; + + -- If error, resynchronize past semicolon + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + + end P_Accept_Statement; + + ------------------------ + -- 9.5.2 Entry Index -- + ------------------------ + + -- Parsed by P_Expression (4.4) + + ----------------------- + -- 9.5.2 Entry Body -- + ----------------------- + + -- ENTRY_BODY ::= + -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is + -- DECLARATIVE_PART + -- begin + -- HANDLED_SEQUENCE_OF_STATEMENTS + -- end [entry_IDENTIFIER]; + + -- The caller has checked that the initial token is ENTRY + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body return Node_Id is + Entry_Node : Node_Id; + Formal_Part_Node : Node_Id; + Name_Node : Node_Id; + + begin + Push_Scope_Stack; + Entry_Node := New_Node (N_Entry_Body, Token_Ptr); + Scan; -- past ENTRY + + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + Scope.Table (Scope.Last).Etyp := E_Name; + + Name_Node := P_Defining_Identifier; + Set_Defining_Identifier (Entry_Node, Name_Node); + Scope.Table (Scope.Last).Labl := Name_Node; + + Formal_Part_Node := P_Entry_Body_Formal_Part; + Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node); + + Set_Condition (Formal_Part_Node, P_Entry_Barrier); + Parse_Decls_Begin_End (Entry_Node); + return Entry_Node; + end P_Entry_Body; + + ----------------------------------- + -- 9.5.2 Entry Body Formal Part -- + ----------------------------------- + + -- ENTRY_BODY_FORMAL_PART ::= + -- [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART] + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Body_Formal_Part return Node_Id is + Fpart_Node : Node_Id; + Scan_State : Saved_Scan_State; + + begin + Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr); + + -- See if entry index specification present, and if so parse it + + if Token = Tok_Left_Paren then + Save_Scan_State (Scan_State); -- at left paren + Scan; -- past left paren + + if Token = Tok_For then + Set_Entry_Index_Specification + (Fpart_Node, P_Entry_Index_Specification); + T_Right_Paren; + else + Restore_Scan_State (Scan_State); -- to left paren + end if; + + -- Check for (common?) case of left paren omitted before FOR. This + -- is a tricky case, because the corresponding missing left paren + -- can cause real havoc if a formal part is present which gets + -- treated as part of the discrete subtype definition of the + -- entry index specification, so just give error and resynchronize + + elsif Token = Tok_For then + T_Left_Paren; -- to give error message + Resync_To_When; + end if; + + Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile); + return Fpart_Node; + end P_Entry_Body_Formal_Part; + + -------------------------- + -- 9.5.2 Entry Barrier -- + -------------------------- + + -- ENTRY_BARRIER ::= when CONDITION + + -- Error_Recovery: cannot raise Error_Resync + + function P_Entry_Barrier return Node_Id is + Bnode : Node_Id; + + begin + if Token = Tok_When then + Scan; -- past WHEN; + Bnode := P_Expression_No_Right_Paren; + + if Token = Tok_Colon_Equal then + Error_Msg_SC (""":="" should be ""="""); + Scan; + Bnode := P_Expression_No_Right_Paren; + end if; + + else + T_When; -- to give error message + Bnode := Error; + end if; + + TF_Is; + return Bnode; + end P_Entry_Barrier; + + -------------------------------------- + -- 9.5.2 Entry Index Specification -- + -------------------------------------- + + -- ENTRY_INDEX_SPECIFICATION ::= + -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION + + -- Error recovery: can raise Error_Resync + + function P_Entry_Index_Specification return Node_Id is + Iterator_Node : Node_Id; + + begin + Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr); + T_For; -- past FOR + Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier); + T_In; + Set_Discrete_Subtype_Definition + (Iterator_Node, P_Discrete_Subtype_Definition); + return Iterator_Node; + end P_Entry_Index_Specification; + + --------------------------------- + -- 9.5.3 Entry Call Statement -- + --------------------------------- + + -- Parsed by P_Name (4.1). Within a select, an entry call is parsed + -- by P_Select_Statement (9.7) + + ------------------------------ + -- 9.5.4 Requeue Statement -- + ------------------------------ + + -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; + + -- The caller has checked that the initial token is requeue + + -- Error recovery: can raise Error_Resync + + function P_Requeue_Statement return Node_Id is + Requeue_Node : Node_Id; + + begin + Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr); + Scan; -- past REQUEUE + Set_Name (Requeue_Node, P_Name); + + if Token = Tok_With then + Scan; -- past WITH + T_Abort; + Set_Abort_Present (Requeue_Node, True); + end if; + + TF_Semicolon; + return Requeue_Node; + end P_Requeue_Statement; + + -------------------------- + -- 9.6 Delay Statement -- + -------------------------- + + -- DELAY_STATEMENT ::= + -- DELAY_UNTIL_STATEMENT + -- | DELAY_RELATIVE_STATEMENT + + -- The caller has checked that the initial token is DELAY + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Statement return Node_Id is + begin + Scan; -- past DELAY + + -- The following check for delay until misused in Ada 83 doesn't catch + -- all cases, but it's good enough to catch most of them! + + if Token_Name = Name_Until then + Check_95_Keyword (Tok_Until, Tok_Left_Paren); + Check_95_Keyword (Tok_Until, Tok_Identifier); + end if; + + if Token = Tok_Until then + return P_Delay_Until_Statement; + else + return P_Delay_Relative_Statement; + end if; + end P_Delay_Statement; + + -------------------------------- + -- 9.6 Delay Until Statement -- + -------------------------------- + + -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and checked that the current token is UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Until_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr); + Scan; -- past UNTIL + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + TF_Semicolon; + return Delay_Node; + end P_Delay_Until_Statement; + + ----------------------------------- + -- 9.6 Delay Relative Statement -- + ----------------------------------- + + -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; + + -- The caller has checked that the initial token is DELAY, scanned it + -- out and determined that the current token is not UNTIL + + -- Error recovery: cannot raise Error_Resync + + function P_Delay_Relative_Statement return Node_Id is + Delay_Node : Node_Id; + + begin + Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr); + Set_Expression (Delay_Node, P_Expression_No_Right_Paren); + Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node)); + TF_Semicolon; + return Delay_Node; + end P_Delay_Relative_Statement; + + --------------------------- + -- 9.7 Select Statement -- + --------------------------- + + -- SELECT_STATEMENT ::= + -- SELECTIVE_ACCEPT + -- | TIMED_ENTRY_CALL + -- | CONDITIONAL_ENTRY_CALL + -- | ASYNCHRONOUS_SELECT + + -- SELECTIVE_ACCEPT ::= + -- select + -- [GUARD] + -- SELECT_ALTERNATIVE + -- {or + -- [GUARD] + -- SELECT_ALTERNATIVE + -- [else + -- SEQUENCE_OF_STATEMENTS] + -- end select; + + -- GUARD ::= when CONDITION => + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- TIMED_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- or + -- DELAY_ALTERNATIVE + -- end select; + + -- CONDITIONAL_ENTRY_CALL ::= + -- select + -- ENTRY_CALL_ALTERNATIVE + -- else + -- SEQUENCE_OF_STATEMENTS + -- end select; + + -- ENTRY_CALL_ALTERNATIVE ::= + -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- ASYNCHRONOUS_SELECT ::= + -- select + -- TRIGGERING_ALTERNATIVE + -- then abort + -- ABORTABLE_PART + -- end select; + + -- TRIGGERING_ALTERNATIVE ::= + -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT + + -- The caller has checked that the initial token is SELECT + + -- Error recovery: can raise Error_Resync + + function P_Select_Statement return Node_Id is + Select_Node : Node_Id; + Select_Sloc : Source_Ptr; + Stmnt_Sloc : Source_Ptr; + Ecall_Node : Node_Id; + Alternative : Node_Id; + Select_Pragmas : List_Id; + Alt_Pragmas : List_Id; + Statement_List : List_Id; + Alt_List : List_Id; + Cond_Expr : Node_Id; + Delay_Stmnt : Node_Id; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Select; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + + Select_Sloc := Token_Ptr; + Scan; -- past SELECT + Stmnt_Sloc := Token_Ptr; + Select_Pragmas := P_Pragmas_Opt; + + -- If first token after select is designator, then we have an entry + -- call, which must be the start of a conditional entry call, timed + -- entry call or asynchronous select + + if Token in Token_Class_Desig then + + -- Scan entry call statement + + begin + Ecall_Node := P_Name; + + -- ?? The following two clauses exactly parallel code in ch5 + -- and should be commoned sometime + + if Nkind (Ecall_Node) = N_Indexed_Component then + declare + Prefix_Node : Node_Id := Prefix (Ecall_Node); + Exprs_Node : List_Id := Expressions (Ecall_Node); + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Prefix_Node); + Set_Parameter_Associations (Ecall_Node, Exprs_Node); + end; + + elsif Nkind (Ecall_Node) = N_Function_Call then + declare + Fname_Node : Node_Id := Name (Ecall_Node); + Params_List : List_Id := Parameter_Associations (Ecall_Node); + + begin + Change_Node (Ecall_Node, N_Procedure_Call_Statement); + Set_Name (Ecall_Node, Fname_Node); + Set_Parameter_Associations (Ecall_Node, Params_List); + end; + + elsif Nkind (Ecall_Node) = N_Identifier + or else Nkind (Ecall_Node) = N_Selected_Component + then + -- Case of a call to a parameterless entry. + + declare + C_Node : constant Node_Id := + New_Node (N_Procedure_Call_Statement, Stmnt_Sloc); + begin + Set_Name (C_Node, Ecall_Node); + Set_Parameter_Associations (C_Node, No_List); + Ecall_Node := C_Node; + end; + end if; + + TF_Semicolon; + + exception + when Error_Resync => + Resync_Past_Semicolon; + return Error; + end; + + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- OR follows, we have a timed entry call + + if Token = Tok_Or then + Scan; -- past OR + Alt_Pragmas := P_Pragmas_Opt; + + Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc); + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + -- Only possibility is delay alternative. If we have anything + -- else, give message, and treat as conditional entry call. + + if Token /= Tok_Delay then + Error_Msg_SC + ("only allowed alternative in timed entry call is delay!"); + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + Set_Delay_Alternative (Select_Node, Error); + + else + Set_Delay_Alternative (Select_Node, P_Delay_Alternative); + Set_Pragmas_Before + (Delay_Alternative (Select_Node), Alt_Pragmas); + end if; + + -- ELSE follows, we have a conditional entry call + + elsif Token = Tok_Else then + Scan; -- past ELSE + Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc); + + Set_Entry_Call_Alternative (Select_Node, + Make_Entry_Call_Alternative (Stmnt_Sloc, + Entry_Call_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Sreq)); + + -- Only remaining case is THEN ABORT (asynchronous select) + + elsif Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Ecall_Node, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + -- Else error + + else + if Ada_83 then + Error_Msg_BC ("OR or ELSE expected"); + else + Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); + end if; + + Select_Node := Error; + end if; + + End_Statements; + + -- Here we have a selective accept or an an asynchronous select (first + -- token after SELECT is other than a designator token). + + else + -- If we have delay with no guard, could be asynchronous select + + if Token = Tok_Delay then + Delay_Stmnt := P_Delay_Statement; + Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); + + -- Asynchronous select + + if Token = Tok_Abort then + Select_Node := + Make_Asynchronous_Select (Select_Sloc, + Triggering_Alternative => + Make_Triggering_Alternative (Stmnt_Sloc, + Triggering_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List), + Abortable_Part => P_Abortable_Part); + + End_Statements; + return Select_Node; + + -- Delay which was not an asynchronous select. Must be a selective + -- accept, and since at least one accept statement is required, + -- we must have at least one OR phrase present. + + else + Alt_List := New_List ( + Make_Delay_Alternative (Stmnt_Sloc, + Delay_Statement => Delay_Stmnt, + Pragmas_Before => Select_Pragmas, + Statements => Statement_List)); + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end if; + + -- If not a delay statement, then must be another possibility for + -- a selective accept alternative, or perhaps a guard is present + + else + Alt_List := New_List; + Alt_Pragmas := Select_Pragmas; + end if; + + Select_Node := New_Node (N_Selective_Accept, Select_Sloc); + Set_Select_Alternatives (Select_Node, Alt_List); + + -- Scan out selective accept alternatives. On entry to this loop, + -- we are just past a SELECT or OR token, and any pragmas that + -- immediately follow the SELECT or OR are in Alt_Pragmas. + + loop + if Token = Tok_When then + + if Present (Alt_Pragmas) then + Error_Msg_SC ("pragmas may not precede guard"); + end if; + + Scan; -- past WHEN + Cond_Expr := P_Expression_No_Right_Paren; + T_Arrow; + Alt_Pragmas := P_Pragmas_Opt; + + else + Cond_Expr := Empty; + end if; + + if Token = Tok_Accept then + Alternative := P_Accept_Alternative; + + -- Check for junk attempt at asynchronous select using + -- an Accept alternative as the triggering statement + + if Token = Tok_Abort + and then Is_Empty_List (Alt_List) + and then No (Cond_Expr) + then + Error_Msg + ("triggering statement must be entry call or delay", + Sloc (Alternative)); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + end if; + + elsif Token = Tok_Delay then + Alternative := P_Delay_Alternative; + + elsif Token = Tok_Terminate then + Alternative := P_Terminate_Alternative; + + else + Error_Msg_SC + ("Select alternative (ACCEPT, ABORT, DELAY) expected"); + Alternative := Error; + + if Token = Tok_Semicolon then + Scan; -- past junk semicolon + end if; + end if; + + -- THEN ABORT at this stage is just junk + + if Token = Tok_Abort then + Error_Msg_SP ("misplaced `THEN ABORT`"); + Scan; -- past junk ABORT + Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); + End_Statements; + return Error; + + else + if Alternative /= Error then + Set_Condition (Alternative, Cond_Expr); + Set_Pragmas_Before (Alternative, Alt_Pragmas); + Append (Alternative, Alt_List); + end if; + + exit when Token /= Tok_Or; + end if; + + T_Or; + Alt_Pragmas := P_Pragmas_Opt; + end loop; + + if Token = Tok_Else then + Scan; -- past ELSE + Set_Else_Statements + (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq)); + + if Token = Tok_Or then + Error_Msg_SC ("select alternative cannot follow else part!"); + end if; + end if; + + End_Statements; + end if; + + return Select_Node; + end P_Select_Statement; + + ----------------------------- + -- 9.7.1 Selective Accept -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ------------------ + -- 9.7.1 Guard -- + ------------------ + + -- Parsed by P_Select_Statement (9.7) + + ------------------------------- + -- 9.7.1 Select Alternative -- + ------------------------------- + + -- SELECT_ALTERNATIVE ::= + -- ACCEPT_ALTERNATIVE + -- | DELAY_ALTERNATIVE + -- | TERMINATE_ALTERNATIVE + + -- Note: the guard preceding a select alternative is included as part + -- of the node generated for a selective accept alternative. + + -- Error recovery: cannot raise Error_Resync + + ------------------------------- + -- 9.7.1 Accept Alternative -- + ------------------------------- + + -- ACCEPT_ALTERNATIVE ::= + -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Accept_Alternative return Node_Id is + Accept_Alt_Node : Node_Id; + + begin + Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr); + Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statememt. + + Set_Statements + (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Accept_Alt_Node; + end P_Accept_Alternative; + + ------------------------------ + -- 9.7.1 Delay Alternative -- + ------------------------------ + + -- DELAY_ALTERNATIVE ::= + -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Delay_Alternative return Node_Id is + Delay_Alt_Node : Node_Id; + + begin + Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr); + Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement); + + -- Note: the reason that we accept THEN ABORT as a terminator for + -- the sequence of statements is for error recovery which allows + -- for misuse of an accept statement as a triggering statememt. + + Set_Statements + (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); + return Delay_Alt_Node; + end P_Delay_Alternative; + + ---------------------------------- + -- 9.7.1 Terminate Alternative -- + ---------------------------------- + + -- TERMINATE_ALTERNATIVE ::= terminate; + + -- Error_Recovery: Cannot raise Error_Resync + + -- Note: the caller is responsible for setting the Pragmas_Before + -- field of the returned N_Terminate_Alternative node. + + function P_Terminate_Alternative return Node_Id is + Terminate_Alt_Node : Node_Id; + + begin + Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr); + Scan; -- past TERMINATE + TF_Semicolon; + + -- For all other select alternatives, the sequence of statements + -- after the alternative statement will swallow up any pragmas + -- coming in this position. But the terminate alternative has no + -- sequence of statements, so the pragmas here must be treated + -- specially. + + Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt); + return Terminate_Alt_Node; + end P_Terminate_Alternative; + + ----------------------------- + -- 9.7.2 Timed Entry Call -- + ----------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.2 Entry Call Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.3 Conditional Entry Call -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + -------------------------------- + -- 9.7.4 Asynchronous Select -- + -------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + ----------------------------------- + -- 9.7.4 Triggering Alternative -- + ----------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------------- + -- 9.7.4 Triggering Statement -- + --------------------------------- + + -- Parsed by P_Select_Statement (9.7) + + --------------------------- + -- 9.7.4 Abortable Part -- + --------------------------- + + -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS + + -- The caller has verified that THEN ABORT is present, and Token is + -- pointing to the ABORT on entry (or if not, then we have an error) + + -- Error recovery: cannot raise Error_Resync + + function P_Abortable_Part return Node_Id is + Abortable_Part_Node : Node_Id; + + begin + Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); + T_Abort; -- scan past ABORT + + if Ada_83 then + Error_Msg_SP ("(Ada 83) asynchronous select not allowed!"); + end if; + + Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq)); + return Abortable_Part_Node; + end P_Abortable_Part; + + -------------------------- + -- 9.8 Abort Statement -- + -------------------------- + + -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; + + -- The caller has checked that the initial token is ABORT + + -- Error recovery: cannot raise Error_Resync + + function P_Abort_Statement return Node_Id is + Abort_Node : Node_Id; + + begin + Abort_Node := New_Node (N_Abort_Statement, Token_Ptr); + Scan; -- past ABORT + Set_Names (Abort_Node, New_List); + + loop + Append (P_Name, Names (Abort_Node)); + exit when Token /= Tok_Comma; + Scan; -- past comma + end loop; + + TF_Semicolon; + return Abort_Node; + end P_Abort_Statement; + +end Ch9; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb new file mode 100644 index 00000000000..fa5b8c20a1a --- /dev/null +++ b/gcc/ada/par-endh.adb @@ -0,0 +1,1191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . E N D H -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.61 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Stringt; use Stringt; +with Uintp; use Uintp; + +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +separate (Par) +package body Endh is + + ---------------- + -- Local Data -- + ---------------- + + type End_Action_Type is ( + -- Type used to describe the result of the Pop_End_Context call + + Accept_As_Scanned, + -- Current end sequence is entirely c correct. In this case Token and + -- the scan pointer are left pointing past the end sequence (i.e. they + -- are unchanged from the values set on entry to Pop_End_Context). + + Insert_And_Accept, + -- Current end sequence is to be left in place to satisfy some outer + -- scope. Token and the scan pointer are set to point to the end + -- token, and should be left there. A message has been generated + -- indicating a missing end sequence. This status is also used for + -- the case when no end token is present. + + Skip_And_Accept, + -- The end sequence is incorrect (and an error message has been + -- posted), but it will still be accepted. In this case Token and + -- the scan pointer point back to the end token, and the caller + -- should skip past the end sequence before proceeding. + + Skip_And_Reject); + -- The end sequence is judged to belong to an unrecognized inner + -- scope. An appropriate message has been issued and the caller + -- should skip past the end sequence and then proceed as though + -- no end sequence had been encountered. + + End_Action : End_Action_Type; + -- The variable set by Pop_End_Context call showing which of the four + -- decisions described above is judged the best. + + End_Sloc : Source_Ptr; + -- Source location of END token + + End_OK : Boolean; + -- Set False if error is found in END line + + End_Column : Column_Number; + -- Column of END line + + End_Type : SS_End_Type; + -- Type of END expected. The special value E_Dummy is set to indicate that + -- no END token was present (so a missing END inserted message is needed) + + End_Labl : Node_Id; + -- Node_Id value for explicit name on END line, or for compiler supplied + -- name in the case where an optional name is not given. Empty if no name + -- appears. If non-empty, then it is either an N_Designator node for a + -- child unit or a node with a Chars field identifying the actual label. + + End_Labl_Present : Boolean; + -- Indicates that the value in End_Labl was for an explicit label. + + Syntax_OK : Boolean; + -- Set True if the entry is syntactically correct + + Token_OK : Boolean; + -- Set True if the keyword in the END sequence matches, or if neither + -- the END sequence nor the END stack entry has a keyword. + + Label_OK : Boolean; + -- Set True if both the END sequence and the END stack entry contained + -- labels (other than No_Name or Error_Name) and the labels matched. + -- This is a stronger condition than SYNTAX_OK, since it means that a + -- label was present, even in a case where it was optional. Note that + -- the case of no label required, and no label present does NOT set + -- Label_OK to True, it is True only if a positive label match is found. + + Column_OK : Boolean; + -- Column_OK is set True if the END sequence appears in the expected column + + Scan_State : Saved_Scan_State; + -- Save state at start of END sequence, in case we decide not to eat it up + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Evaluate_End_Entry (SS_Index : Int); + -- Compare scanned END entry (as recorded by a prior call to P_End_Scan) + -- with a specified entry in the scope stack (the single parameter is the + -- entry index in the scope stack). Note that Scan is not called. The above + -- variables xxx_OK are set to indicate the result of the evaluation. + + procedure Output_End_Deleted; + -- Output a message complaining that the current END structure does not + -- match anything and is being deleted. + + procedure Output_End_Expected (Ins : Boolean); + -- Output a message at the start of the current token which is always an + -- END, complaining that the END is not of the right form. The message + -- indicates the expected form. The information for the message is taken + -- from the top entry in the scope stack. The Ins parameter is True if + -- an end is being inserted, and false if an existing end is being + -- replaced. Note that in the case of a suspicious IS for the Ins case, + -- we do not output the message, but instead simply mark the scope stack + -- entry as being a case of a bad IS. + + procedure Output_End_Missing; + -- Output a message just before the current token, complaining that the + -- END is not of the right form. The message indicates the expected form. + -- The information for the message is taken from the top entry in the + -- scope stack. Note that in the case of a suspicious IS, we do not output + -- the message, but instead simply mark the scope stack entry as a bad IS. + + procedure Pop_End_Context; + -- Pop_End_Context is called after processing a construct, to pop the + -- top entry off the end stack. It decides on the appropriate action to + -- to take, signalling the result by setting End_Action as described in + -- the global variable section. + + function Same_Label (Label1, Label2 : Node_Id) return Boolean; + -- This function compares the two names associated with the given nodes. + -- If they are both simple (i.e. have Chars fields), then they have to + -- be the same name. Otherwise they must both be N_Selected_Component + -- nodes, referring to the same set of names, or Label1 is an N_Designator + -- referring to the same set of names as the N_Defining_Program_Unit_Name + -- in Label2. Any other combination returns False. This routine is used + -- to compare the End_Labl scanned from the End line with the saved label + -- value in the scope stack. + + --------------- + -- Check_End -- + --------------- + + function Check_End return Boolean is + Name_On_Separate_Line : Boolean; + -- Set True if the name on an END line is on a separate source line + -- from the END. This is highly suspicious, but is allowed. The point + -- is that we want to make sure that we don't just have a missing + -- semicolon misleading us into swallowing an identifier from the + -- following line. + + Name_Scan_State : Saved_Scan_State; + -- Save state at start of name if Name_On_Separate_Line is TRUE + + Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node; + + begin + End_Labl_Present := False; + End_Labl := Empty; + + -- Our first task is to scan out the END sequence if one is present. + -- If none is present, signal by setting End_Type to E_Dummy. + + if Token /= Tok_End then + End_Type := E_Dummy; + + else + Save_Scan_State (Scan_State); -- at END + End_Sloc := Token_Ptr; + End_Column := Start_Column; + End_OK := True; + Scan; -- past END + + -- Set End_Span if expected. note that this will be useless + -- if we do not have the right ending keyword, but in this + -- case we have a malformed program anyway, and the setting + -- of End_Span will simply be unreliable in this case anyway. + + if Present (Span_Node) then + Set_End_Location (Span_Node, Token_Ptr); + end if; + + -- Cases of keywords where no label is allowed + + if Token = Tok_Case then + End_Type := E_Case; + Scan; -- past CASE + + elsif Token = Tok_If then + End_Type := E_If; + Scan; -- past IF + + elsif Token = Tok_Record then + End_Type := E_Record; + Scan; -- past RECORD + + elsif Token = Tok_Select then + End_Type := E_Select; + Scan; -- past SELECT + + -- Cases which do allow labels + + else + -- LOOP + + if Token = Tok_Loop then + Scan; -- past LOOP + End_Type := E_Loop; + + -- FOR or WHILE allowed (signalling error) to substitute for LOOP + -- if on the same line as the END + + elsif (Token = Tok_For or else Token = Tok_While) + and then not Token_Is_At_Start_Of_Line + then + Scan; -- past FOR or WHILE + End_Type := E_Loop; + End_OK := False; + + -- Cases with no keyword + + else + End_Type := E_Name; + end if; + + -- Now see if a name is present + + if Token = Tok_Identifier or else + Token = Tok_String_Literal or else + Token = Tok_Operator_Symbol + then + if Token_Is_At_Start_Of_Line then + Name_On_Separate_Line := True; + Save_Scan_State (Name_Scan_State); + else + Name_On_Separate_Line := False; + end if; + + End_Labl := P_Designator; + End_Labl_Present := True; + + -- We have now scanned out a name. Here is where we do a check + -- to catch the cases like: + -- + -- end loop + -- X := 3; + -- + -- where the missing semicolon might make us swallow up the X + -- as a bogus end label. In a situation like this, where the + -- apparent name is on a separate line, we accept it only if + -- it matches the label and is followed by a semicolon. + + if Name_On_Separate_Line then + if Token /= Tok_Semicolon or else + not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl) + then + Restore_Scan_State (Name_Scan_State); + End_Labl := Empty; + End_Labl_Present := False; + end if; + end if; + + -- Here for case of name allowed, but no name present. We will + -- supply an implicit matching name, with source location set + -- to the scan location past the END token. + + else + End_Labl := Scope.Table (Scope.Last).Labl; + + if End_Labl > Empty_Or_Error then + + -- The task here is to construct a designator from the + -- opening label, with the components all marked as not + -- from source, and Is_End_Label set in the identifier + -- or operator symbol. The location for all components + -- is the curent token location. + + -- Case of child unit name + + if Nkind (End_Labl) = N_Defining_Program_Unit_Name then + declare + Eref : constant Node_Id := + Make_Identifier (Token_Ptr, + Chars => + Chars (Defining_Identifier (End_Labl))); + + function Copy_Name (N : Node_Id) return Node_Id; + -- Copies a selected component or identifier + + function Copy_Name (N : Node_Id) return Node_Id is + R : Node_Id; + + begin + if Nkind (N) = N_Selected_Component then + return + Make_Selected_Component (Token_Ptr, + Prefix => + Copy_Name (Prefix (N)), + Selector_Name => + Copy_Name (Selector_Name (N))); + + else + R := + Make_Identifier (Token_Ptr, + Chars => Chars (N)); + Set_Comes_From_Source (N, False); + return R; + end if; + end Copy_Name; + + begin + Set_Comes_From_Source (Eref, False); + + End_Labl := + Make_Designator (Token_Ptr, + Name => Copy_Name (Name (End_Labl)), + Identifier => Eref); + end; + + -- Simple identifier case + + elsif Nkind (End_Labl) = N_Defining_Identifier + or else Nkind (End_Labl) = N_Identifier + then + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (End_Labl)); + + elsif Nkind (End_Labl) = N_Defining_Operator_Symbol + or else Nkind (End_Labl) = N_Operator_Symbol + then + Get_Decoded_Name_String (Chars (End_Labl)); + + End_Labl := + Make_Operator_Symbol (Token_Ptr, + Chars => Chars (End_Labl), + Strval => String_From_Name_Buffer); + end if; + + Set_Comes_From_Source (End_Labl, False); + End_Labl_Present := False; + + -- Do style check for missing label + + if Style_Check + and then End_Type = E_Name + and then Present (Scope.Table (Scope.Last).Labl) + then + Style.No_End_Name (Scope.Table (Scope.Last).Labl); + end if; + end if; + end if; + end if; + + -- Except in case of END RECORD, semicolon must follow. For END + -- RECORD, a semicolon does follow, but it is part of a higher level + -- construct. In any case, a missing semicolon is not serious enough + -- to consider the END statement to be bad in the sense that we + -- are dealing with (i.e. to be suspicious that it is not in fact + -- the END statement we are looking for!) + + if End_Type /= E_Record then + if Token = Tok_Semicolon then + T_Semicolon; + + -- Semicolon is missing. If the missing semicolon is at the end + -- of the line, i.e. we are at the start of the line now, then + -- a missing semicolon gets flagged, but is not serious enough + -- to consider the END statement to be bad in the sense that we + -- are dealing with (i.e. to be suspicious that this END is not + -- the END statement we are looking for). + + -- Similarly, if we are at a colon, we flag it but a colon for + -- a semicolon is not serious enough to consider the END to be + -- incorrect. Same thing for a period in place of a semicolon. + + elsif Token_Is_At_Start_Of_Line + or else Token = Tok_Colon + or else Token = Tok_Dot + then + T_Semicolon; + + -- If the missing semicolon is not at the start of the line, + -- then we do consider the END line to be dubious in this sense. + + else + End_OK := False; + end if; + end if; + end if; + + -- Now we call the Pop_End_Context routine to get a recommendation + -- as to what should be done with the END sequence we have scanned. + + Pop_End_Context; + + -- Remaining action depends on End_Action set by Pop_End_Context + + case End_Action is + + -- Accept_As_Scanned. In this case, Pop_End_Context left Token + -- pointing past the last token of a syntactically correct END + + when Accept_As_Scanned => + + -- Syntactically correct included the possibility of a missing + -- semicolon. If we do have a missing semicolon, then we have + -- already given a message, but now we scan out possible rubbish + -- on the same line as the END + + while not Token_Is_At_Start_Of_Line + and then Prev_Token /= Tok_Record + and then Prev_Token /= Tok_Semicolon + and then Token /= Tok_End + and then Token /= Tok_EOF + loop + Scan; -- past junk + end loop; + + return True; + + -- Insert_And_Accept. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence, and recommends that it + -- be left in place to satisfy an outer scope level END. This means + -- that we proceed as though an END were present, and leave the scan + -- pointer unchanged. + + when Insert_And_Accept => + return True; + + -- Skip_And_Accept. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence. This END sequence is + -- syntactically incorrect, and an appropriate error message has + -- already been posted. Pop_End_Context recommends accepting the + -- END sequence as the one we want, so we skip past it and then + -- proceed as though an END were present. + + when Skip_And_Accept => + End_Skip; + return True; + + -- Skip_And_Reject. In this case, Pop_End_Context has reset Token + -- to point to the start of the END sequence. This END sequence is + -- syntactically incorrect, and an appropriate error message has + -- already been posted. Pop_End_Context recommends entirely ignoring + -- this END sequence, so we skip past it and then return False, since + -- as far as the caller is concerned, no END sequence is present. + + when Skip_And_Reject => + End_Skip; + return False; + end case; + end Check_End; + + -------------- + -- End Skip -- + -------------- + + -- This procedure skips past an END sequence. On entry Token contains + -- Tok_End, and we know that the END sequence is syntactically incorrect, + -- and that an appropriate error message has already been posted. The + -- mission is simply to position the scan pointer to be the best guess of + -- the position after the END sequence. We do not issue any additional + -- error messages while carrying this out. + + -- Error recovery: does not raise Error_Resync + + procedure End_Skip is + begin + Scan; -- past END + + -- If the scan past the END leaves us on the next line, that's probably + -- where we should quit the scan, since it is likely that what we have + -- is a missing semicolon. Consider the following: + + -- END + -- Process_Input; + + -- This will have looked like a syntactically valid END sequence to the + -- initial scan of the END, but subsequent checking will have determined + -- that the label Process_Input is not an appropriate label. The real + -- error is a missing semicolon after the END, and by leaving the scan + -- pointer just past the END, we will improve the error recovery. + + if Token_Is_At_Start_Of_Line then + return; + end if; + + -- If there is a semicolon after the END, scan it out and we are done + + if Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + + -- Otherwise skip past a token after the END on the same line. Note + -- that we do not eat a token on the following line since it seems + -- very unlikely in any case that the END gets separated from its + -- token, and we do not want to swallow up a keyword that starts a + -- legitimate construct following the bad END. + + if not Token_Is_At_Start_Of_Line + and then + + -- Cases of normal tokens following an END + + (Token = Tok_Case or else + Token = Tok_For or else + Token = Tok_If or else + Token = Tok_Loop or else + Token = Tok_Record or else + Token = Tok_Select or else + + -- Cases of bogus keywords ending loops + + Token = Tok_For or else + Token = Tok_While or else + + -- Cases of operator symbol names without quotes + + Token = Tok_Abs or else + Token = Tok_And or else + Token = Tok_Mod or else + Token = Tok_Not or else + Token = Tok_Or or else + Token = Tok_Xor) + + then + Scan; -- past token after END + + -- If that leaves us on the next line, then we are done. This is the + -- same principle described above for the case of END at line end + + if Token_Is_At_Start_Of_Line then + return; + + -- If we just scanned out record, then we are done, since the + -- semicolon after END RECORD is not part of the END sequence + + elsif Prev_Token = Tok_Record then + return; + + -- If we have a semicolon, scan it out and we are done + + elsif Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + end if; + + -- Check for a label present on the same line + + loop + if Token_Is_At_Start_Of_Line then + return; + end if; + + if Token /= Tok_Identifier + and then Token /= Tok_Operator_Symbol + and then Token /= Tok_String_Literal + then + exit; + end if; + + Scan; -- past identifier, operator symbol or string literal + + if Token_Is_At_Start_Of_Line then + return; + elsif Token = Tok_Dot then + Scan; -- past dot + end if; + end loop; + + -- Skip final semicolon + + if Token = Tok_Semicolon then + T_Semicolon; + + -- If we don't have a final semicolon, skip until we either encounter + -- an END token, or a semicolon or the start of the next line. This + -- allows general junk to follow the end line (normally it is hard to + -- think that anyone will put anything deliberate here, and remember + -- that we know there is a missing semicolon in any case). We also + -- quite on an EOF (or else we would get stuck in an infinite loop + -- if there is no line end at the end of the last line of the file) + + else + while Token /= Tok_End + and then Token /= Tok_EOF + and then Token /= Tok_Semicolon + and then not Token_Is_At_Start_Of_Line + loop + Scan; -- past junk token on same line + end loop; + end if; + + return; + end End_Skip; + + -------------------- + -- End Statements -- + -------------------- + + -- This procedure is called when END is required or expected to terminate + -- a sequence of statements. The caller has already made an appropriate + -- entry on the scope stack to describe the expected form of the END. + -- End_Statements should only be used in cases where the only appropriate + -- terminator is END. + + -- Error recovery: cannot raise Error_Resync; + + procedure End_Statements (Parent : Node_Id := Empty) is + begin + -- This loop runs more than once in the case where Check_End rejects + -- the END sequence, as indicated by Check_End returning False. + + loop + if Check_End then + if Present (Parent) then + Set_End_Label (Parent, End_Labl); + end if; + + return; + end if; + + -- Extra statements past the bogus END are discarded. This is not + -- ideal for maximum error recovery, but it's too much trouble to + -- find an appropriate place to put them! + + Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); + end loop; + end End_Statements; + + ------------------------ + -- Evaluate End Entry -- + ------------------------ + + procedure Evaluate_End_Entry (SS_Index : Int) is + begin + Column_OK := (End_Column = Scope.Table (SS_Index).Ecol); + + Token_OK := (End_Type = Scope.Table (SS_Index).Etyp or else + (End_Type = E_Name and then + Scope.Table (SS_Index).Etyp >= E_Name)); + + Label_OK := End_Labl_Present + and then + (Same_Label (End_Labl, Scope.Table (SS_Index).Labl) + or else Scope.Table (SS_Index).Labl = Error); + + -- Compute setting of Syntax_OK. We definitely have a syntax error + -- if the Token does not match properly or if P_End_Scan detected + -- a syntax error such as a missing semicolon. + + if not Token_OK or not End_OK then + Syntax_OK := False; + + -- Final check is that label is OK. Certainly it is OK if there + -- was an exact match on the label (the END label = the stack label) + + elsif Label_OK then + Syntax_OK := True; + + -- Case of label present + + elsif End_Labl_Present then + + -- If probably misspelling, then complain, and pretend it is OK + + declare + Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl; + + begin + if Nkind (End_Labl) in N_Has_Chars + and then Nkind (Nam) in N_Has_Chars + and then Chars (End_Labl) > Error_Name + and then Chars (Nam) > Error_Name + then + Get_Name_String (Chars (End_Labl)); + Error_Msg_Name_1 := Chars (Nam); + + if Error_Msg_Name_1 > Error_Name then + declare + S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + + begin + Get_Name_String (Error_Msg_Name_1); + + if Is_Bad_Spelling_Of + (Name_Buffer (1 .. Name_Len), S) + then + Error_Msg_N ("misspelling of %", End_Labl); + Syntax_OK := True; + return; + end if; + end; + end if; + end if; + end; + + Syntax_OK := False; + + -- Otherwise we have cases of no label on the END line. For the loop + -- case, this is acceptable only if the loop is unlabeled. + + elsif End_Type = E_Loop then + Syntax_OK := (Scope.Table (SS_Index).Labl = Empty); + + -- Cases where a label is definitely allowed on the END line + + elsif End_Type = E_Name then + Syntax_OK := (Scope.Table (SS_Index).Labl = Empty or else + not Scope.Table (SS_Index).Lreq); + + -- Otherwise we have cases which don't allow labels anyway, so we + -- certainly accept an END which does not have a label. + + else + Syntax_OK := True; + end if; + end Evaluate_End_Entry; + + ------------------------ + -- Output End Deleted -- + ------------------------ + + procedure Output_End_Deleted is + begin + + if End_Type = E_Loop then + Error_Msg_SC ("no LOOP for this `END LOOP`!"); + + elsif End_Type = E_Case then + Error_Msg_SC ("no CASE for this `END CASE`"); + + elsif End_Type = E_If then + Error_Msg_SC ("no IF for this `END IF`!"); + + elsif End_Type = E_Record then + Error_Msg_SC ("no RECORD for this `END RECORD`!"); + + elsif End_Type = E_Select then + Error_Msg_SC ("no SELECT for this `END SELECT`!"); + + else + Error_Msg_SC ("no BEGIN for this END!"); + end if; + end Output_End_Deleted; + + ------------------------- + -- Output End Expected -- + ------------------------- + + procedure Output_End_Expected (Ins : Boolean) is + End_Type : SS_End_Type; + + begin + -- Suppress message if this was a potentially junk entry (e.g. a + -- record entry where no record keyword was present. + + if Scope.Table (Scope.Last).Junk then + return; + end if; + + End_Type := Scope.Table (Scope.Last).Etyp; + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + + -- Suppress message if error was posted on opening label + + if Present (Error_Msg_Node_1) + and then Error_Posted (Error_Msg_Node_1) + then + return; + end if; + + if End_Type = E_Case then + Error_Msg_SC ("`END CASE;` expected@ for CASE#!"); + + elsif End_Type = E_If then + Error_Msg_SC ("`END IF;` expected@ for IF#!"); + + elsif End_Type = E_Loop then + if Error_Msg_Node_1 = Empty then + Error_Msg_SC + ("`END LOOP;` expected@ for LOOP#!"); + else + Error_Msg_SC ("`END LOOP &;` expected@!"); + end if; + + elsif End_Type = E_Record then + Error_Msg_SC + ("`END RECORD;` expected@ for RECORD#!"); + + elsif End_Type = E_Select then + Error_Msg_SC + ("`END SELECT;` expected@ for SELECT#!"); + + -- All remaining cases are cases with a name (we do not treat + -- the suspicious is cases specially for a replaced end, only + -- for an inserted end). + + elsif End_Type = E_Name or else (not Ins) then + if Error_Msg_Node_1 = Empty then + Error_Msg_SC ("`END;` expected@ for BEGIN#!"); + else + Error_Msg_SC ("`END &;` expected@!"); + end if; + + -- The other possibility is a missing END for a subprogram with a + -- suspicious IS (that probably should have been a semicolon). The + -- Missing IS confirms the suspicion! + + else -- End_Type = E_Suspicious_Is or E_Bad_Is + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + end if; + end Output_End_Expected; + + ------------------------ + -- Output End Missing -- + ------------------------ + + procedure Output_End_Missing is + End_Type : SS_End_Type; + + begin + -- Suppress message if this was a potentially junk entry (e.g. a + -- record entry where no record keyword was present. + + if Scope.Table (Scope.Last).Junk then + return; + end if; + + End_Type := Scope.Table (Scope.Last).Etyp; + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; + + if End_Type = E_Case then + Error_Msg_BC ("missing `END CASE;` for CASE#!"); + + elsif End_Type = E_If then + Error_Msg_BC ("missing `END IF;` for IF#!"); + + elsif End_Type = E_Loop then + if Error_Msg_Node_1 = Empty then + Error_Msg_BC ("missing `END LOOP;` for LOOP#!"); + else + Error_Msg_BC ("missing `END LOOP &;`!"); + end if; + + elsif End_Type = E_Record then + Error_Msg_SC + ("missing `END RECORD;` for RECORD#!"); + + elsif End_Type = E_Select then + Error_Msg_BC + ("missing `END SELECT;` for SELECT#!"); + + elsif End_Type = E_Name then + if Error_Msg_Node_1 = Empty then + Error_Msg_BC ("missing `END;` for BEGIN#!"); + else + Error_Msg_BC ("missing `END &;`!"); + end if; + + else -- End_Type = E_Suspicious_Is or E_Bad_Is + Scope.Table (Scope.Last).Etyp := E_Bad_Is; + end if; + end Output_End_Missing; + + --------------------- + -- Pop End Context -- + --------------------- + + procedure Pop_End_Context is + + Pretty_Good : Boolean; + -- This flag is set True if the END sequence is syntactically incorrect, + -- but is (from a heuristic point of view), pretty likely to be simply + -- a misspelling of the intended END. + + Outer_Match : Boolean; + -- This flag is set True if we decide that the current END sequence + -- belongs to some outer level entry in the scope stack, and thus + -- we will NOT eat it up in matching the current expected END. + + begin + -- If not at END, then output END expected message + + if End_Type = E_Dummy then + Output_End_Missing; + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + + -- Otherwise we do have an END present + + else + -- A special check. If we have END; followed by an end of file, + -- WITH or SEPARATE, then if we are not at the outer level, then + -- we have a sytax error. Consider the example: + + -- ... + -- declare + -- X : Integer; + -- begin + -- X := Father (A); + -- Process (X, X); + -- end; + -- with Package1; + -- ... + + -- Now the END; here is a syntactically correct closer for the + -- declare block, but if we eat it up, then we obviously have + -- a missing END for the outer context (since WITH can only appear + -- at the outer level. + + -- In this situation, we always reserve the END; for the outer level, + -- even if it is in the wrong column. This is because it's much more + -- useful to have the error message point to the DECLARE than to the + -- package header in this case. + + -- We also reserve an end with a name before the end of file if the + -- name is the one we expect at the outer level. + + if (Token = Tok_EOF or else + Token = Tok_With or else + Token = Tok_Separate) + and then End_Type >= E_Name + and then (not End_Labl_Present + or else Same_Label (End_Labl, Scope.Table (1).Labl)) + and then Scope.Last > 1 + then + Restore_Scan_State (Scan_State); -- to END + Output_End_Expected (Ins => True); + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + end if; + + -- Otherwise we go through the normal END evaluation procedure + + Evaluate_End_Entry (Scope.Last); + + -- If top entry in stack is syntactically correct, then we have + -- scanned it out and everything is fine. This is the required + -- action to properly process correct Ada programs. + + if Syntax_OK then + + -- Complain if checking columns and END is not in right column. + -- Right in this context means exactly right, or on the same + -- line as the opener. + + if Style.RM_Column_Check then + if End_Column /= Scope.Table (Scope.Last).Ecol + and then Current_Line_Start > Scope.Table (Scope.Last).Sloc + then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + Error_Msg + ("(style) END in wrong column, should be@", End_Sloc); + end if; + end if; + + -- One final check. If the end had a label, check for an exact + -- duplicate of this end sequence, and if so, skip it with an + -- appropriate message. + + if End_Labl_Present and then Token = Tok_End then + declare + Scan_State : Saved_Scan_State; + End_Loc : constant Source_Ptr := Token_Ptr; + Nxt_Labl : Node_Id; + Dup_Found : Boolean := False; + + begin + Save_Scan_State (Scan_State); + + Scan; -- past END + + if Token = Tok_Identifier + or else Token = Tok_Operator_Symbol + then + Nxt_Labl := P_Designator; + + -- We only consider it an error if the label is a match + -- and would be wrong for the level one above us, and + -- the indentation is the same. + + if Token = Tok_Semicolon + and then Same_Label (End_Labl, Nxt_Labl) + and then End_Column = Start_Column + and then + (Scope.Last = 1 + or else + (No (Scope.Table (Scope.Last - 1).Labl) + or else + not Same_Label + (End_Labl, + Scope.Table (Scope.Last - 1).Labl))) + then + T_Semicolon; + Error_Msg ("duplicate end line ignored", End_Loc); + Dup_Found := True; + end if; + end if; + + if not Dup_Found then + Restore_Scan_State (Scan_State); + end if; + end; + end if; + + -- All OK, so return to caller indicating END is OK + + Pop_Scope_Stack; + End_Action := Accept_As_Scanned; + return; + end if; + + -- If that check failed, then we definitely have an error. The issue + -- is how to choose among three possible courses of action: + + -- 1. Ignore the current END text completely, scanning past it, + -- deciding that it belongs neither to the current context, + -- nor to any outer context. + + -- 2. Accept the current END text, scanning past it, and issuing + -- an error message that it does not have the right form. + + -- 3. Leave the current END text in place, NOT scanning past it, + -- issuing an error message indicating the END expected for the + -- current context. In this case, the END is available to match + -- some outer END context. + + -- From a correct functioning point of view, it does not make any + -- difference which of these three approaches we take, the program + -- will work correctly in any case. However, making an accurate + -- choice among these alternatives, i.e. choosing the one that + -- corresponds to what the programmer had in mind, does make a + -- significant difference in the quality of error recovery. + + Restore_Scan_State (Scan_State); -- to END + + -- First we see how good the current END entry is with respect to + -- what we expect. It is considered pretty good if the token is OK, + -- and either the label or the column matches. an END for RECORD is + -- always considered to be pretty good in the record case. This is + -- because not only does a record disallow a nested structure, but + -- also it is unlikely that such nesting could occur by accident. + + Pretty_Good := (Token_OK and (Column_OK or Label_OK)) + or else Scope.Table (Scope.Last).Etyp = E_Record; + + -- Next check, if there is a deeper entry in the stack which + -- has a very high probability of being acceptable, then insert + -- the END entry we want, leaving the higher level entry for later + + for J in reverse 1 .. Scope.Last - 1 loop + Evaluate_End_Entry (J); + + -- To even consider the deeper entry to be immediately acceptable, + -- it must be syntactically correct. Furthermore it must either + -- have a correct label, or the correct column. If the current + -- entry was a close match (Pretty_Good set), then we are even + -- more strict in accepting the outer level one: even if it has + -- the right label, it must have the right column as well. + + if Syntax_OK then + if Pretty_Good then + Outer_Match := Label_OK and Column_OK; + else + Outer_Match := Label_OK or Column_OK; + end if; + else + Outer_Match := False; + end if; + + -- If the outer entry does convincingly match the END text, then + -- back up the scan to the start of the END sequence, issue an + -- error message indicating the END we expected, and return with + -- Token pointing to the END (case 3 from above discussion). + + if Outer_Match then + Output_End_Missing; + Pop_Scope_Stack; + End_Action := Insert_And_Accept; + return; + end if; + end loop; + + -- Here we have a situation in which the current END entry is + -- syntactically incorrect, but there is no deeper entry in the + -- END stack which convincingly matches it. + + -- If the END text was judged to be a Pretty_Good match for the + -- expected token or if it appears left of the expected column, + -- then we will accept it as the one we want, scanning past it, even + -- though it is not completely right (we issue a message showing what + -- we expected it to be). This is action 2 from the discussion above. + -- There is one other special case to consider: the LOOP case. + -- Consider the example: + + -- Lbl: loop + -- null; + -- end loop; + + -- Here the column lines up with Lbl, so END LOOP is to the right, + -- but it is still acceptable. LOOP is the one case where alignment + -- practices vary substantially in practice. + + if Pretty_Good + or else End_Column <= Scope.Table (Scope.Last).Ecol + or else (End_Type = Scope.Table (Scope.Last).Etyp + and then End_Type = E_Loop) + then + Output_End_Expected (Ins => False); + Pop_Scope_Stack; + End_Action := Skip_And_Accept; + return; + + -- Here we have the case where the END is to the right of the + -- expected column and does not have a correct label to convince + -- us that it nevertheless belongs to the current scope. For this + -- we consider that it probably belongs not to the current context, + -- but to some inner context that was not properly recognized (due to + -- other syntax errors), and for which no proper scope stack entry + -- was made. The proper action in this case is to delete the END text + -- and return False to the caller as a signal to keep on looking for + -- an acceptable END. This is action 1 from the discussion above. + + else + Output_End_Deleted; + End_Action := Skip_And_Reject; + return; + end if; + end if; + end Pop_End_Context; + + ---------------- + -- Same_Label -- + ---------------- + + function Same_Label (Label1, Label2 : Node_Id) return Boolean is + begin + if Nkind (Label1) in N_Has_Chars + and then Nkind (Label2) in N_Has_Chars + then + return Chars (Label1) = Chars (Label2); + + elsif Nkind (Label1) = N_Selected_Component + and then Nkind (Label2) = N_Selected_Component + then + return Same_Label (Prefix (Label1), Prefix (Label2)) and then + Same_Label (Selector_Name (Label1), Selector_Name (Label2)); + + elsif Nkind (Label1) = N_Designator + and then Nkind (Label2) = N_Defining_Program_Unit_Name + then + return Same_Label (Name (Label1), Name (Label2)) and then + Same_Label (Identifier (Label1), Defining_Identifier (Label2)); + + else + return False; + end if; + end Same_Label; + +end Endh; diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb new file mode 100644 index 00000000000..e43d3f3f01d --- /dev/null +++ b/gcc/ada/par-labl.adb @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L A B L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.18 $ -- +-- -- +-- Copyright (C) 1992-1998, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +separate (Par) +procedure Labl is + Enclosing_Body_Or_Block : Node_Id; + -- Innermost enclosing body or block statement + + Label_Decl_Node : Node_Id; + -- Implicit label declaration node + + Defining_Ident_Node : Node_Id; + -- Defining identifier node for implicit label declaration + + Next_Label_Elmt : Elmt_Id; + -- Next element on label element list + + Label_Node : Node_Id; + -- Next label node to process + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id; + -- Find the innermost body or block that encloses N. + + function Find_Enclosing_Body (N : Node_Id) return Node_Id; + -- Find the innermost body that encloses N. + + procedure Check_Distinct_Labels; + -- Checks the rule in RM-5.1(11), which requires distinct identifiers + -- for all the labels in a given body. + + --------------------------- + -- Check_Distinct_Labels -- + --------------------------- + + procedure Check_Distinct_Labels is + Label_Id : constant Node_Id := Identifier (Label_Node); + + Enclosing_Body : constant Node_Id := + Find_Enclosing_Body (Enclosing_Body_Or_Block); + -- Innermost enclosing body + + Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List); + -- Next element on label element list + + Other_Label : Node_Id; + -- Next label node to process + + begin + -- Loop through all the labels, and if we find some other label + -- (i.e. not Label_Node) that has the same identifier, + -- and whose innermost enclosing body is the same, + -- then we have an error. + + -- Note that in the worst case, this is quadratic in the number + -- of labels. However, labels are not all that common, and this + -- is only called for explicit labels. + -- ???Nonetheless, the efficiency could be improved. For example, + -- call Labl for each body, rather than once per compilation. + + while Present (Next_Other_Label_Elmt) loop + Other_Label := Node (Next_Other_Label_Elmt); + + exit when Label_Node = Other_Label; + + if Chars (Label_Id) = Chars (Identifier (Other_Label)) + and then Enclosing_Body = Find_Enclosing_Body (Other_Label) + then + Error_Msg_Sloc := Sloc (Other_Label); + Error_Msg_N ("& conflicts with label#", Label_Id); + exit; + end if; + + Next_Elmt (Next_Other_Label_Elmt); + end loop; + end Check_Distinct_Labels; + + ------------------------- + -- Find_Enclosing_Body -- + ------------------------- + + function Find_Enclosing_Body (N : Node_Id) return Node_Id is + Result : Node_Id := N; + + begin + -- This is the same as Find_Enclosing_Body_Or_Block, except + -- that we skip block statements and accept statements, instead + -- of stopping at them. + + while Present (Result) + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body; + + ---------------------------------- + -- Find_Enclosing_Body_Or_Block -- + ---------------------------------- + + function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is + Result : Node_Id := Parent (N); + + begin + -- Climb up the parent chain until we find a body or block. + + while Present (Result) + and then Nkind (Result) /= N_Accept_Statement + and then Nkind (Result) /= N_Entry_Body + and then Nkind (Result) /= N_Task_Body + and then Nkind (Result) /= N_Package_Body + and then Nkind (Result) /= N_Subprogram_Body + and then Nkind (Result) /= N_Block_Statement + loop + Result := Parent (Result); + end loop; + + return Result; + end Find_Enclosing_Body_Or_Block; + +-- Start of processing for Par.Labl + +begin + Next_Label_Elmt := First_Elmt (Label_List); + + while Present (Next_Label_Elmt) loop + Label_Node := Node (Next_Label_Elmt); + + if not Comes_From_Source (Label_Node) then + goto Next_Label; + end if; + + -- Find the innermost enclosing body or block, which is where + -- we need to implicitly declare this label + + Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node); + + -- If we didn't find a parent, then the label in question never got + -- hooked into a reasonable declarative part. This happens only in + -- error situations, and we simply ignore the entry (we aren't going + -- to get into the semantics in any case given the error). + + if Present (Enclosing_Body_Or_Block) then + Check_Distinct_Labels; + + -- Now create the implicit label declaration node and its + -- corresponding defining identifier. Note that the defining + -- occurrence of a label is the implicit label declaration that + -- we are creating. The label itself is an applied occurrence. + + Label_Decl_Node := + New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node)); + Defining_Ident_Node := + New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node))); + Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node))); + Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node); + Set_Label_Construct (Label_Decl_Node, Label_Node); + + -- Now attach the implicit label declaration to the appropriate + -- declarative region, creating a declaration list if none exists + + if not Present (Declarations (Enclosing_Body_Or_Block)) then + Set_Declarations (Enclosing_Body_Or_Block, New_List); + end if; + + Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block)); + end if; + + <<Next_Label>> + Next_Elmt (Next_Label_Elmt); + end loop; + +end Labl; diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb new file mode 100644 index 00000000000..39934caacb0 --- /dev/null +++ b/gcc/ada/par-load.adb @@ -0,0 +1,410 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . L O A D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.60 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The Par.Load procedure loads all units that are definitely required before +-- it makes any sense at all to proceed with semantic analysis, including +-- with'ed units, corresponding specs for bodies, parents of child specs, +-- and parents of subunits. All these units are loaded and pointers installed +-- in the tree as described in the spec of package Lib. + +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib.Load; use Lib.Load; +with Uname; use Uname; +with Namet; use Namet; +with Casing; use Casing; +with Opt; use Opt; +with Osint; use Osint; +with Sinput.L; use Sinput.L; +with Stylesw; use Stylesw; +with Validsw; use Validsw; + +separate (Par) +procedure Load is + + File_Name : File_Name_Type; + -- Name of file for current unit, derived from unit name + + Cur_Unum : Unit_Number_Type := Current_Source_Unit; + -- Unit number of unit that we just finished parsing. Note that we need + -- to capture this, because Source_Unit will change as we parse new + -- source files in the multiple main source file case. + + Curunit : constant Node_Id := Cunit (Cur_Unum); + -- Compilation unit node for current compilation unit + + Loc : Source_Ptr := Sloc (Curunit); + -- Source location for compilation unit node + + Save_Style_Check : Boolean; + Save_Style_Checks : Style_Check_Options; + -- Save style check so it can be restored later + + Save_Validity_Check : Boolean; + Save_Validity_Checks : Validity_Check_Options; + -- Save validity check so it can be restored later + + With_Cunit : Node_Id; + -- Compilation unit node for withed unit + + Context_Node : Node_Id; + -- Next node in context items list + + With_Node : Node_Id; + -- N_With_Clause node + + Spec_Name : Unit_Name_Type; + -- Unit name of required spec + + Body_Name : Unit_Name_Type; + -- Unit name of corresponding body + + Unum : Unit_Number_Type; + -- Unit number of loaded unit + + function Same_File_Name_Except_For_Case + (Expected_File_Name : File_Name_Type; + Actual_File_Name : File_Name_Type) + return Boolean; + -- Given an actual file name and an expected file name (the latter being + -- derived from the unit name), determine if they are the same except for + -- possibly different casing of letters. + + function Same_File_Name_Except_For_Case + (Expected_File_Name : File_Name_Type; + Actual_File_Name : File_Name_Type) + return Boolean + is + begin + Get_Name_String (Actual_File_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Lower_Case_Actual_File_Name : String (1 .. Name_Len); + + begin + Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len); + Get_Name_String (Expected_File_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len); + end; + + end Same_File_Name_Except_For_Case; + +-- Start of processing for Load + +begin + -- Don't do any loads if we already had a fatal error + + if Fatal_Error (Cur_Unum) then + return; + end if; + + Save_Style_Check_Options (Save_Style_Checks); + Save_Style_Check := Opt.Style_Check; + + Save_Validity_Check_Options (Save_Validity_Checks); + Save_Validity_Check := Opt.Validity_Checks_On; + + -- If main unit, set Main_Unit_Entity (this will get overwritten if + -- the main unit has a separate spec, that happens later on in Load) + + if Cur_Unum = Main_Unit then + Main_Unit_Entity := Cunit_Entity (Main_Unit); + end if; + + -- If we have no unit name, things are seriously messed up by previous + -- errors, and we should not try to continue compilation. + + if Unit_Name (Cur_Unum) = No_Name then + raise Unrecoverable_Error; + end if; + + -- Next step, make sure that the unit name matches the file name + -- and issue a warning message if not. We only output this for the + -- main unit, since for other units it is more serious and is + -- caught in a separate test below. + + File_Name := + Get_File_Name + (Unit_Name (Cur_Unum), + Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit); + + if Cur_Unum = Main_Unit + and then File_Name /= Unit_File_Name (Cur_Unum) + and then (File_Names_Case_Sensitive + or not Same_File_Name_Except_For_Case + (File_Name, Unit_File_Name (Cur_Unum))) + then + Error_Msg_Name_1 := File_Name; + Error_Msg + ("?file name does not match unit name, should be{", Sloc (Curunit)); + end if; + + -- For units other than the main unit, the expected unit name is set and + -- must be the same as the actual unit name, or we are in big trouble, and + -- abandon the compilation since there are situations where this really + -- gets us into bad trouble (e.g. some subunit situations). + + if Cur_Unum /= Main_Unit + and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum) + then + Loc := Error_Location (Cur_Unum); + Error_Msg_Name_1 := Unit_File_Name (Cur_Unum); + Get_Name_String (Error_Msg_Name_1); + + -- Check for predefined file case + + if Name_Len > 1 + and then Name_Buffer (2) = '-' + and then (Name_Buffer (1) = 'a' + or else + Name_Buffer (1) = 's' + or else + Name_Buffer (1) = 'i' + or else + Name_Buffer (1) = 'g') + then + -- In the predefined file case, we know the user did not construct + -- their own package, but we got the wrong one. This means that the + -- name supplied by the user crunched to something we recognized, + -- but then the file did not contain the unit expected. Most likely + -- this is due to a misspelling, e.g. + + -- with Ada.Calender; + + -- This crunches to a-calend, which indeed contains the unit + -- Ada.Calendar, and we can diagnose the misspelling. This is + -- a simple heuristic, but it catches many common cases of + -- misspelling of predefined unit names without needing a full + -- list of them. + + Error_Msg_Name_1 := Expected_Unit (Cur_Unum); + Error_Msg ("% is not a predefined library unit!", Loc); + Error_Msg_Name_1 := Unit_Name (Cur_Unum); + Error_Msg ("possible misspelling of %!", Loc); + + -- Non-predefined file name case + + else + Error_Msg ("file { does not contain expected unit!", Loc); + Error_Msg_Unit_1 := Expected_Unit (Cur_Unum); + Error_Msg ("expected unit $!", Loc); + Error_Msg_Unit_1 := Unit_Name (Cur_Unum); + Error_Msg ("found unit $!", Loc); + end if; + + raise Unrecoverable_Error; + end if; + + -- If current unit is a body, load its corresponding spec + + if Nkind (Unit (Curunit)) = N_Package_Body + or else Nkind (Unit (Curunit)) = N_Subprogram_Body + then + Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum)); + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => False, + Subunit => False, + Error_Node => Curunit, + Corr_Body => Cur_Unum); + + -- If we successfully load the unit, then set the spec pointer. Once + -- again note that if the loaded unit has a fatal error, Load will + -- have set our Fatal_Error flag to propagate this condition. + + if Unum /= No_Unit then + Set_Library_Unit (Curunit, Cunit (Unum)); + + -- If this is a separate spec for the main unit, then we reset + -- Main_Unit_Entity to point to the entity for this separate spec + + if Cur_Unum = Main_Unit then + Main_Unit_Entity := Cunit_Entity (Unum); + end if; + + -- If we don't find the spec, then if we have a subprogram body, we + -- are still OK, we just have a case of a body acting as its own spec + + elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then + Set_Acts_As_Spec (Curunit, True); + Set_Library_Unit (Curunit, Curunit); + + -- Otherwise we do have an error, repeat the load request for the spec + -- with Required set True to generate an appropriate error message. + + else + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => Curunit); + return; + end if; + + -- If current unit is a child unit spec, load its parent + + elsif Nkind (Unit (Curunit)) = N_Package_Declaration + or else Nkind (Unit (Curunit)) = N_Subprogram_Declaration + or else Nkind (Unit (Curunit)) in N_Generic_Declaration + or else Nkind (Unit (Curunit)) in N_Generic_Instantiation + or else Nkind (Unit (Curunit)) in N_Renaming_Declaration + then + -- Turn style and validity checks off for parent unit + + if not GNAT_Mode then + Reset_Style_Check_Options; + Reset_Validity_Check_Options; + end if; + + Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum)); + + if Spec_Name /= No_Name then + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => Curunit); + + if Unum /= No_Unit then + Set_Parent_Spec (Unit (Curunit), Cunit (Unum)); + end if; + end if; + + -- If current unit is a subunit, then load its parent body + + elsif Nkind (Unit (Curunit)) = N_Subunit then + Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum)); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => True, + Subunit => True, + Error_Node => Name (Unit (Curunit))); + + if Unum /= No_Unit then + Set_Library_Unit (Curunit, Cunit (Unum)); + end if; + + end if; + + -- Now we load with'ed units, with style/validity checks turned off + + if not GNAT_Mode then + Reset_Style_Check_Options; + Reset_Validity_Check_Options; + end if; + + -- Loop through context items + + Context_Node := First (Context_Items (Curunit)); + while Present (Context_Node) loop + + if Nkind (Context_Node) = N_With_Clause then + With_Node := Context_Node; + Spec_Name := Get_Unit_Name (With_Node); + + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => False, + Subunit => False, + Error_Node => With_Node, + Renamings => True); + + -- If we find the unit, then set spec pointer in the N_With_Clause + -- to point to the compilation unit for the spec. Remember that + -- the Load routine itself sets our Fatal_Error flag if the loaded + -- unit gets a fatal error, so we don't need to worry about that. + + if Unum /= No_Unit then + Set_Library_Unit (With_Node, Cunit (Unum)); + + -- If the spec isn't found, then try finding the corresponding + -- body, since it is possible that we have a subprogram body + -- that is acting as a spec (since no spec is present). + + else + Body_Name := Get_Body_Name (Spec_Name); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => False, + Subunit => False, + Error_Node => With_Node, + Renamings => True); + + -- If we got a subprogram body, then mark that we are using + -- the body as a spec in the file table, and set the spec + -- pointer in the N_With_Clause to point to the body entity. + + if Unum /= No_Unit + and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body + then + With_Cunit := Cunit (Unum); + Set_Library_Unit (With_Node, With_Cunit); + Set_Acts_As_Spec (With_Cunit, True); + Set_Library_Unit (With_Cunit, With_Cunit); + + -- If we couldn't find the body, or if it wasn't a body spec + -- then we are in trouble. We make one more call to Load to + -- require the spec. We know it will fail of course, the + -- purpose is to generate the required error message (we prefer + -- that this message refer to the missing spec, not the body) + + else + Unum := + Load_Unit + (Load_Name => Spec_Name, + Required => True, + Subunit => False, + Error_Node => With_Node, + Renamings => True); + + -- Here we create a dummy package unit for the missing unit + + Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name); + Set_Library_Unit (With_Node, Cunit (Unum)); + end if; + end if; + end if; + + Next (Context_Node); + end loop; + + -- Restore style/validity check mode for main unit + + Set_Style_Check_Options (Save_Style_Checks); + Opt.Style_Check := Save_Style_Check; + Set_Validity_Check_Options (Save_Validity_Checks); + Opt.Validity_Checks_On := Save_Validity_Check; +end Load; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb new file mode 100644 index 00000000000..bfca40e8c18 --- /dev/null +++ b/gcc/ada/par-prag.adb @@ -0,0 +1,950 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . P R A G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.149 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Generally the parser checks the basic syntax of pragmas, but does not +-- do specialized syntax checks for individual pragmas, these are deferred +-- to semantic analysis time (see unit Sem_Prag). There are some pragmas +-- which require recognition and either partial or complete processing +-- during parsing, and this unit performs this required processing. + +with Fname.UF; use Fname.UF; +with Osint; use Osint; +with Stringt; use Stringt; +with Stylesw; use Stylesw; +with Uintp; use Uintp; +with Uname; use Uname; + +separate (Par) + +function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is + Pragma_Name : constant Name_Id := Chars (Pragma_Node); + Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); + Arg_Count : Nat; + Arg_Node : Node_Id; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Arg1 return Node_Id; + function Arg2 return Node_Id; + function Arg3 return Node_Id; + function Arg4 return Node_Id; + -- Obtain specified Pragma_Argument_Association. It is allowable to call + -- the routine for the argument one past the last present argument, but + -- that is the only case in which a non-present argument can be referenced. + + procedure Check_Arg_Count (Required : Int); + -- Check argument count for pragma = Required. + -- If not give error and raise Error_Resync. + + procedure Check_Arg_Is_String_Literal (Arg : Node_Id); + -- Check the expression of the specified argument to make sure that it + -- is a string literal. If not give error and raise Error_Resync. + + procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); + -- Check the expression of the specified argument to make sure that it + -- is an identifier which is either ON or OFF, and if not, then issue + -- an error message and raise Error_Resync. + + procedure Check_No_Identifier (Arg : Node_Id); + -- Checks that the given argument does not have an identifier. If an + -- identifier is present, then an error message is issued, and + -- Error_Resync is raised. + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Error_Resync raised. + + procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); + -- Same as Check_Optional_Identifier, except that the name is required + -- to be present and to match the given Id value. + + ---------- + -- Arg1 -- + ---------- + + function Arg1 return Node_Id is + begin + return First (Pragma_Argument_Associations (Pragma_Node)); + end Arg1; + + ---------- + -- Arg2 -- + ---------- + + function Arg2 return Node_Id is + begin + return Next (Arg1); + end Arg2; + + ---------- + -- Arg3 -- + ---------- + + function Arg3 return Node_Id is + begin + return Next (Arg2); + end Arg3; + + ---------- + -- Arg4 -- + ---------- + + function Arg4 return Node_Id is + begin + return Next (Arg3); + end Arg4; + + --------------------- + -- Check_Arg_Count -- + --------------------- + + procedure Check_Arg_Count (Required : Int) is + begin + if Arg_Count /= Required then + Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); + raise Error_Resync; + end if; + end Check_Arg_Count; + + ---------------------------- + -- Check_Arg_Is_On_Or_Off -- + ---------------------------- + + procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is + Argx : constant Node_Id := Expression (Arg); + + begin + if Nkind (Expression (Arg)) /= N_Identifier + or else (Chars (Argx) /= Name_On + and then + Chars (Argx) /= Name_Off) + then + Error_Msg_Name_2 := Name_On; + Error_Msg_Name_3 := Name_Off; + + Error_Msg + ("argument for pragma% must be% or%", Sloc (Argx)); + raise Error_Resync; + end if; + end Check_Arg_Is_On_Or_Off; + + --------------------------------- + -- Check_Arg_Is_String_Literal -- + --------------------------------- + + procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is + begin + if Nkind (Expression (Arg)) /= N_String_Literal then + Error_Msg + ("argument for pragma% must be string literal", + Sloc (Expression (Arg))); + raise Error_Resync; + end if; + end Check_Arg_Is_String_Literal; + + ------------------------- + -- Check_No_Identifier -- + ------------------------- + + procedure Check_No_Identifier (Arg : Node_Id) is + begin + if Chars (Arg) /= No_Name then + Error_Msg_N ("pragma% does not permit named arguments", Arg); + raise Error_Resync; + end if; + end Check_No_Identifier; + + ------------------------------- + -- Check_Optional_Identifier -- + ------------------------------- + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Present (Arg) and then Chars (Arg) /= No_Name then + if Chars (Arg) /= Id then + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument expects identifier%", Arg); + end if; + end if; + end Check_Optional_Identifier; + + ------------------------------- + -- Check_Required_Identifier -- + ------------------------------- + + procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Chars (Arg) /= Id then + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument must have identifier%", Arg); + end if; + end Check_Required_Identifier; + + ---------- + -- Prag -- + ---------- + +begin + Error_Msg_Name_1 := Pragma_Name; + + -- Count number of arguments. This loop also checks if any of the arguments + -- are Error, indicating a syntax error as they were parsed. If so, we + -- simply return, because we get into trouble with cascaded errors if we + -- try to perform our error checks on junk arguments. + + Arg_Count := 0; + + if Present (Pragma_Argument_Associations (Pragma_Node)) then + Arg_Node := Arg1; + + while Arg_Node /= Empty loop + Arg_Count := Arg_Count + 1; + + if Expression (Arg_Node) = Error then + return Error; + end if; + + Next (Arg_Node); + end loop; + end if; + + -- Remaining processing is pragma dependent + + case Get_Pragma_Id (Pragma_Name) is + + ------------ + -- Ada_83 -- + ------------ + + -- This pragma must be processed at parse time, since we want to set + -- the Ada 83 and Ada 95 switches properly at parse time to recognize + -- Ada 83 syntax or Ada 95 syntax as appropriate. + + when Pragma_Ada_83 => + Ada_83 := True; + Ada_95 := False; + + ------------ + -- Ada_95 -- + ------------ + + -- This pragma must be processed at parse time, since we want to set + -- the Ada 83 and Ada_95 switches properly at parse time to recognize + -- Ada 83 syntax or Ada 95 syntax as appropriate. + + when Pragma_Ada_95 => + Ada_83 := False; + Ada_95 := True; + + ----------- + -- Debug -- + ----------- + + -- pragma Debug (PROCEDURE_CALL_STATEMENT); + + -- This has to be processed by the parser because of the very peculiar + -- form of the second parameter, which is syntactically from a formal + -- point of view a function call (since it must be an expression), but + -- semantically we treat it as a procedure call (which has exactly the + -- same syntactic form, so that's why we can get away with this!) + + when Pragma_Debug => + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + + declare + Expr : constant Node_Id := New_Copy (Expression (Arg1)); + + begin + if Nkind (Expr) /= N_Indexed_Component + and then Nkind (Expr) /= N_Function_Call + and then Nkind (Expr) /= N_Identifier + and then Nkind (Expr) /= N_Selected_Component + then + Error_Msg + ("argument of pragma% is not procedure call", Sloc (Expr)); + raise Error_Resync; + else + Set_Debug_Statement + (Pragma_Node, P_Statement_Name (Expr)); + end if; + end; + + ------------------------------- + -- Extensions_Allowed (GNAT) -- + ------------------------------- + + -- pragma Extensions_Allowed (Off | On) + + -- The processing for pragma Extensions_Allowed must be done at + -- parse time, since extensions mode may affect what is accepted. + + when Pragma_Extensions_Allowed => + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Check_Arg_Is_On_Or_Off (Arg1); + Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On); + + ---------------- + -- List (2.8) -- + ---------------- + + -- pragma List (Off | On) + + -- The processing for pragma List must be done at parse time, + -- since a listing can be generated in parse only mode. + + when Pragma_List => + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + Check_Arg_Is_On_Or_Off (Arg1); + + -- We unconditionally make a List_On entry for the pragma, so that + -- in the List (Off) case, the pragma will print even in a region + -- of code with listing turned off (this is required!) + + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := + (Ptyp => List_On, Ploc => Sloc (Pragma_Node)); + + -- Now generate the list off entry for pragma List (Off) + + if Chars (Expression (Arg1)) = Name_Off then + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := + (Ptyp => List_Off, Ploc => Semi); + end if; + + ---------------- + -- Page (2.8) -- + ---------------- + + -- pragma Page; + + -- Processing for this pragma must be done at parse time, since a + -- listing can be generated in parse only mode with semantics off. + + when Pragma_Page => + Check_Arg_Count (0); + List_Pragmas.Increment_Last; + List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi); + + ----------------------------- + -- Source_File_Name (GNAT) -- + ----------------------------- + + -- There are five forms of this pragma: + + -- pragma Source_File_Name ( + -- [UNIT_NAME =>] unit_NAME, + -- BODY_FILE_NAME => STRING_LITERAL); + + -- pragma Source_File_Name ( + -- [UNIT_NAME =>] unit_NAME, + -- SPEC_FILE_NAME => STRING_LITERAL); + + -- pragma Source_File_Name ( + -- BODY_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SPEC_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- pragma Source_File_Name ( + -- SUBUNIT_FILE_NAME => STRING_LITERAL + -- [, DOT_REPLACEMENT => STRING_LITERAL] + -- [, CASING => CASING_SPEC]); + + -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase + + -- Note: we process this during parsing, since we need to have the + -- source file names set well before the semantic analysis starts, + -- since we load the spec and with'ed packages before analysis. + + when Pragma_Source_File_Name => Source_File_Name : declare + Unam : Unit_Name_Type; + Expr1 : Node_Id; + Pat : String_Ptr; + Typ : Character; + Dot : String_Ptr; + Cas : Casing_Type; + Nast : Nat; + + function Get_Fname (Arg : Node_Id) return Name_Id; + -- Process file name from unit name form of pragma + + function Get_String_Argument (Arg : Node_Id) return String_Ptr; + -- Process string literal value from argument + + procedure Process_Casing (Arg : Node_Id); + -- Process Casing argument of pattern form of pragma + + procedure Process_Dot_Replacement (Arg : Node_Id); + -- Process Dot_Replacement argument of patterm form of pragma + + --------------- + -- Get_Fname -- + --------------- + + function Get_Fname (Arg : Node_Id) return Name_Id is + begin + String_To_Name_Buffer (Strval (Expression (Arg))); + + for J in 1 .. Name_Len loop + if Is_Directory_Separator (Name_Buffer (J)) then + Error_Msg + ("directory separator character not allowed", + Sloc (Expression (Arg)) + Source_Ptr (J)); + end if; + end loop; + + return Name_Find; + end Get_Fname; + + ------------------------- + -- Get_String_Argument -- + ------------------------- + + function Get_String_Argument (Arg : Node_Id) return String_Ptr is + Str : String_Id; + + begin + if Nkind (Expression (Arg)) /= N_String_Literal + and then + Nkind (Expression (Arg)) /= N_Operator_Symbol + then + Error_Msg_N + ("argument for pragma% must be string literal", Arg); + raise Error_Resync; + end if; + + Str := Strval (Expression (Arg)); + + -- Check string has no wide chars + + for J in 1 .. String_Length (Str) loop + if Get_String_Char (Str, J) > 255 then + Error_Msg + ("wide character not allowed in pattern for pragma%", + Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); + end if; + end loop; + + -- Acquire string + + String_To_Name_Buffer (Str); + return new String'(Name_Buffer (1 .. Name_Len)); + end Get_String_Argument; + + -------------------- + -- Process_Casing -- + -------------------- + + procedure Process_Casing (Arg : Node_Id) is + Expr : constant Node_Id := Expression (Arg); + + begin + Check_Required_Identifier (Arg, Name_Casing); + + if Nkind (Expr) = N_Identifier then + if Chars (Expr) = Name_Lowercase then + Cas := All_Lower_Case; + return; + elsif Chars (Expr) = Name_Uppercase then + Cas := All_Upper_Case; + return; + elsif Chars (Expr) = Name_Mixedcase then + Cas := Mixed_Case; + return; + end if; + end if; + + Error_Msg_N + ("Casing argument for pragma% must be " & + "one of Mixedcase, Lowercase, Uppercase", + Arg); + end Process_Casing; + + ----------------------------- + -- Process_Dot_Replacement -- + ----------------------------- + + procedure Process_Dot_Replacement (Arg : Node_Id) is + begin + Check_Required_Identifier (Arg, Name_Dot_Replacement); + Dot := Get_String_Argument (Arg); + end Process_Dot_Replacement; + + -- Start of processing for Source_File_Name pragma + + begin + -- We permit from 1 to 3 arguments + + if Arg_Count not in 1 .. 3 then + Check_Arg_Count (1); + end if; + + Expr1 := Expression (Arg1); + + -- If first argument is identifier or selected component, then + -- we have the specific file case of the Source_File_Name pragma, + -- and the first argument is a unit name. + + if Nkind (Expr1) = N_Identifier + or else + (Nkind (Expr1) = N_Selected_Component + and then + Nkind (Selector_Name (Expr1)) = N_Identifier) + then + Check_Arg_Count (2); + + Check_Optional_Identifier (Arg1, Name_Unit_Name); + Unam := Get_Unit_Name (Expr1); + + Check_Arg_Is_String_Literal (Arg2); + + if Chars (Arg2) = Name_Spec_File_Name then + Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2)); + + elsif Chars (Arg2) = Name_Body_File_Name then + Set_File_Name (Unam, Get_Fname (Arg2)); + + else + Error_Msg_N ("pragma% argument has incorrect identifier", Arg2); + return Pragma_Node; + end if; + + -- If the first argument is not an identifier, then we must have + -- the pattern form of the pragma, and the first argument must be + -- the pattern string with an appropriate name. + + else + if Chars (Arg1) = Name_Spec_File_Name then + Typ := 's'; + + elsif Chars (Arg1) = Name_Body_File_Name then + Typ := 'b'; + + elsif Chars (Arg1) = Name_Subunit_File_Name then + Typ := 'u'; + + elsif Chars (Arg1) = Name_Unit_Name then + Error_Msg_N + ("Unit_Name parameter for pragma% must be an identifier", + Arg1); + raise Error_Resync; + + else + Error_Msg_N ("pragma% argument has incorrect identifier", Arg1); + raise Error_Resync; + end if; + + Pat := Get_String_Argument (Arg1); + + -- Check pattern has exactly one asterisk + + Nast := 0; + for J in Pat'Range loop + if Pat (J) = '*' then + Nast := Nast + 1; + end if; + end loop; + + if Nast /= 1 then + Error_Msg_N + ("file name pattern must have exactly one * character", + Arg2); + return Pragma_Node; + end if; + + -- Set defaults for Casing and Dot_Separator parameters + + Cas := All_Lower_Case; + + Dot := new String'("."); + + -- Process second and third arguments if present + + if Arg_Count > 1 then + if Chars (Arg2) = Name_Casing then + Process_Casing (Arg2); + + if Arg_Count = 3 then + Process_Dot_Replacement (Arg3); + end if; + + else + Process_Dot_Replacement (Arg2); + + if Arg_Count = 3 then + Process_Casing (Arg3); + end if; + end if; + end if; + + Set_File_Name_Pattern (Pat, Typ, Dot, Cas); + end if; + end Source_File_Name; + + ----------------------------- + -- Source_Reference (GNAT) -- + ----------------------------- + + -- pragma Source_Reference + -- (INTEGER_LITERAL [, STRING_LITERAL] ); + + -- Processing for this pragma must be done at parse time, since error + -- messages needing the proper line numbers can be generated in parse + -- only mode with semantic checking turned off, and indeed we usually + -- turn off semantic checking anyway if any parse errors are found. + + when Pragma_Source_Reference => Source_Reference : declare + Fname : Name_Id; + + begin + if Arg_Count /= 1 then + Check_Arg_Count (2); + Check_No_Identifier (Arg2); + end if; + + -- Check that this is first line of file. We skip this test if + -- we are in syntax check only mode, since we may be dealing with + -- multiple compilation units. + + if Get_Physical_Line_Number (Pragma_Sloc) /= 1 + and then Num_SRef_Pragmas (Current_Source_File) = 0 + and then Operating_Mode /= Check_Syntax + then + Error_Msg + ("first % pragma must be first line of file", Pragma_Sloc); + raise Error_Resync; + end if; + + Check_No_Identifier (Arg1); + + if Arg_Count = 1 then + if Num_SRef_Pragmas (Current_Source_File) = 0 then + Error_Msg + ("file name required for first % pragma in file", + Pragma_Sloc); + raise Error_Resync; + + else + Fname := No_Name; + end if; + + -- File name present + + else + Check_Arg_Is_String_Literal (Arg2); + String_To_Name_Buffer (Strval (Expression (Arg2))); + Fname := Name_Find; + + if Num_SRef_Pragmas (Current_Source_File) > 0 then + if Fname /= Full_Ref_Name (Current_Source_File) then + Error_Msg + ("file name must be same in all % pragmas", Pragma_Sloc); + raise Error_Resync; + end if; + end if; + end if; + + if Nkind (Expression (Arg1)) /= N_Integer_Literal then + Error_Msg + ("argument for pragma% must be integer literal", + Sloc (Expression (Arg1))); + raise Error_Resync; + + -- OK, this source reference pragma is effective, however, we + -- ignore it if it is not in the first unit in the multiple unit + -- case. This is because the only purpose in this case is to + -- provide source pragmas for subsequent use by gnatchop. + + else + if Num_Library_Units = 1 then + Register_Source_Ref_Pragma + (Fname, + Strip_Directory (Fname), + UI_To_Int (Intval (Expression (Arg1))), + Get_Physical_Line_Number (Pragma_Sloc) + 1); + end if; + end if; + end Source_Reference; + + ------------------------- + -- Style_Checks (GNAT) -- + ------------------------- + + -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); + + -- This is processed by the parser since some of the style + -- checks take place during source scanning and parsing. + + when Pragma_Style_Checks => Style_Checks : declare + A : Node_Id; + S : String_Id; + C : Char_Code; + OK : Boolean := True; + + begin + -- Two argument case is only for semantics + + if Arg_Count = 2 then + null; + + else + Check_Arg_Count (1); + Check_No_Identifier (Arg1); + A := Expression (Arg1); + + if Nkind (A) = N_String_Literal then + S := Strval (A); + + declare + Slen : Natural := Natural (String_Length (S)); + Options : String (1 .. Slen); + J : Natural; + Ptr : Natural; + + begin + J := 1; + loop + C := Get_String_Char (S, Int (J)); + + if not In_Character_Range (C) then + OK := False; + Ptr := J; + exit; + + else + Options (J) := Get_Character (C); + end if; + + if J = Slen then + Set_Style_Check_Options (Options, OK, Ptr); + exit; + + else + J := J + 1; + end if; + end loop; + + if not OK then + Error_Msg + ("invalid style check option", + Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); + raise Error_Resync; + end if; + end; + + elsif Nkind (A) /= N_Identifier then + OK := False; + + elsif Chars (A) = Name_All_Checks then + Stylesw.Set_Default_Style_Check_Options; + + elsif Chars (A) = Name_On then + Style_Check := True; + + elsif Chars (A) = Name_Off then + Style_Check := False; + + else + OK := False; + end if; + + if not OK then + Error_Msg ("incorrect argument for pragma%", Sloc (A)); + raise Error_Resync; + end if; + end if; + end Style_Checks; + + --------------------- + -- Warnings (GNAT) -- + --------------------- + + -- pragma Warnings (On | Off, [LOCAL_NAME]) + + -- The one argument case is processed by the parser, since it may + -- control parser warnings as well as semantic warnings, and in any + -- case we want to be absolutely sure that the range in the warnings + -- table is set well before any semantic analysis is performed. + + when Pragma_Warnings => + if Arg_Count = 1 then + Check_No_Identifier (Arg1); + Check_Arg_Is_On_Or_Off (Arg1); + + if Chars (Expression (Arg1)) = Name_On then + Set_Warnings_Mode_On (Pragma_Sloc); + else + Set_Warnings_Mode_Off (Pragma_Sloc); + end if; + end if; + + ----------------------- + -- All Other Pragmas -- + ----------------------- + + -- For all other pragmas, checking and processing is handled + -- entirely in Sem_Prag, and no further checking is done by Par. + + when Pragma_Abort_Defer | + Pragma_AST_Entry | + Pragma_All_Calls_Remote | + Pragma_Annotate | + Pragma_Assert | + Pragma_Asynchronous | + Pragma_Atomic | + Pragma_Atomic_Components | + Pragma_Attach_Handler | + Pragma_CPP_Class | + Pragma_CPP_Constructor | + Pragma_CPP_Virtual | + Pragma_CPP_Vtable | + Pragma_C_Pass_By_Copy | + Pragma_Comment | + Pragma_Common_Object | + Pragma_Complex_Representation | + Pragma_Component_Alignment | + Pragma_Controlled | + Pragma_Convention | + Pragma_Discard_Names | + Pragma_Eliminate | + Pragma_Elaborate | + Pragma_Elaborate_All | + Pragma_Elaborate_Body | + Pragma_Elaboration_Checks | + Pragma_Export | + Pragma_Export_Exception | + Pragma_Export_Function | + Pragma_Export_Object | + Pragma_Export_Procedure | + Pragma_Export_Valued_Procedure | + Pragma_Extend_System | + Pragma_External_Name_Casing | + Pragma_Finalize_Storage_Only | + Pragma_Float_Representation | + Pragma_Ident | + Pragma_Import | + Pragma_Import_Exception | + Pragma_Import_Function | + Pragma_Import_Object | + Pragma_Import_Procedure | + Pragma_Import_Valued_Procedure | + Pragma_Initialize_Scalars | + Pragma_Inline | + Pragma_Inline_Always | + Pragma_Inline_Generic | + Pragma_Inspection_Point | + Pragma_Interface | + Pragma_Interface_Name | + Pragma_Interrupt_Handler | + Pragma_Interrupt_Priority | + Pragma_Java_Constructor | + Pragma_Java_Interface | + Pragma_License | + Pragma_Link_With | + Pragma_Linker_Alias | + Pragma_Linker_Options | + Pragma_Linker_Section | + Pragma_Locking_Policy | + Pragma_Long_Float | + Pragma_Machine_Attribute | + Pragma_Main | + Pragma_Main_Storage | + Pragma_Memory_Size | + Pragma_No_Return | + Pragma_No_Run_Time | + Pragma_Normalize_Scalars | + Pragma_Optimize | + Pragma_Pack | + Pragma_Passive | + Pragma_Polling | + Pragma_Preelaborate | + Pragma_Priority | + Pragma_Propagate_Exceptions | + Pragma_Psect_Object | + Pragma_Pure | + Pragma_Pure_Function | + Pragma_Queuing_Policy | + Pragma_Remote_Call_Interface | + Pragma_Remote_Types | + Pragma_Restrictions | + Pragma_Restricted_Run_Time | + Pragma_Ravenscar | + Pragma_Reviewable | + Pragma_Share_Generic | + Pragma_Shared | + Pragma_Shared_Passive | + Pragma_Storage_Size | + Pragma_Storage_Unit | + Pragma_Stream_Convert | + Pragma_Subtitle | + Pragma_Suppress | + Pragma_Suppress_All | + Pragma_Suppress_Debug_Info | + Pragma_Suppress_Initialization | + Pragma_System_Name | + Pragma_Task_Dispatching_Policy | + Pragma_Task_Info | + Pragma_Task_Name | + Pragma_Task_Storage | + Pragma_Time_Slice | + Pragma_Title | + Pragma_Unchecked_Union | + Pragma_Unimplemented_Unit | + Pragma_Unreserve_All_Interrupts | + Pragma_Unsuppress | + Pragma_Use_VADS_Size | + Pragma_Volatile | + Pragma_Volatile_Components | + Pragma_Weak_External | + Pragma_Validity_Checks => + null; + + end case; + + return Pragma_Node; + + -------------------- + -- Error Handling -- + -------------------- + +exception + when Error_Resync => + return Error; + +end Prag; diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb new file mode 100644 index 00000000000..d1ba793d9cd --- /dev/null +++ b/gcc/ada/par-sync.adb @@ -0,0 +1,312 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . S Y N C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +separate (Par) +package body Sync is + + procedure Resync_Init; + -- This routine is called on initiating a resynchronization action + + procedure Resync_Resume; + -- This routine is called on completing a resynchronization action + + ------------------- + -- Resync_Choice -- + ------------------- + + procedure Resync_Choice is + begin + Resync_Init; + + -- Loop till we get a token that terminates a choice. Note that EOF is + -- one such token, so we are sure to get out of this loop eventually! + + while Token not in Token_Class_Cterm loop + Scan; + end loop; + + Resync_Resume; + end Resync_Choice; + + ------------------ + -- Resync_Cunit -- + ------------------ + + procedure Resync_Cunit is + begin + Resync_Init; + + while Token not in Token_Class_Cunit + and then Token /= Tok_EOF + loop + Scan; + end loop; + + Resync_Resume; + end Resync_Cunit; + + ----------------------- + -- Resync_Expression -- + ----------------------- + + procedure Resync_Expression is + Paren_Count : Int; + + begin + Resync_Init; + Paren_Count := 0; + + loop + -- Terminating tokens are those in class Eterm and also RANGE, + -- DIGITS or DELTA if not preceded by an apostrophe (if they are + -- preceded by an apostrophe, then they are attributes). In addiion, + -- at the outer parentheses level only, we also consider a comma, + -- right parenthesis or vertical bar to terminate an expression. + + if Token in Token_Class_Eterm + + or else (Token in Token_Class_Atkwd + and then Prev_Token /= Tok_Apostrophe) + + or else (Paren_Count = 0 + and then + (Token = Tok_Comma + or else Token = Tok_Right_Paren + or else Token = Tok_Vertical_Bar)) + then + -- A special check: if we stop on the ELSE of OR ELSE or the + -- THEN of AND THEN, keep going, because this is not really an + -- expression terminator after all. Also, keep going past WITH + -- since this can be part of an extension aggregate + + if (Token = Tok_Else and then Prev_Token = Tok_Or) + or else (Token = Tok_Then and then Prev_Token = Tok_And) + or else Token = Tok_With + then + null; + else + exit; + end if; + end if; + + if Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + elsif Token = Tok_Right_Paren then + Paren_Count := Paren_Count - 1; + + end if; + + Scan; -- past token to be skipped + end loop; + + Resync_Resume; + end Resync_Expression; + + ----------------- + -- Resync_Init -- + ----------------- + + procedure Resync_Init is + begin + -- The following check makes sure we do not get stuck in an infinite + -- loop resynchonizing and getting nowhere. If we are called to do a + -- resynchronize and we are exactly at the same point that we left off + -- on the last resynchronize call, then we force at least one token to + -- be skipped so that we make progress! + + if Token_Ptr = Last_Resync_Point then + Scan; -- to skip at least one token + end if; + + -- Output extra error message if debug R flag is set + + if Debug_Flag_R then + Error_Msg_SC ("resynchronizing!"); + end if; + end Resync_Init; + + --------------------------- + -- Resync_Past_Semicolon -- + --------------------------- + + procedure Resync_Past_Semicolon is + begin + Resync_Init; + + loop + -- Done if we are at a semicolon + + if Token = Tok_Semicolon then + Scan; -- past semicolon + exit; + + -- Done if we are at a token which normally appears only after + -- a semicolon. One special glitch is that the keyword private is + -- in this category only if it does NOT appear after WITH. + + elsif Token in Token_Class_After_SM + and then (Token /= Tok_Private or else Prev_Token /= Tok_With) + then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resyncrhonization complete + + Resync_Resume; + end Resync_Past_Semicolon; + + ---------------------------------------------- + -- Resync_Past_Semicolon_Or_To_Loop_Or_Then -- + ---------------------------------------------- + + procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is + begin + Resync_Init; + + loop + -- Done if at semicolon + + if Token = Tok_Semicolon then + Scan; -- past the semicolon + exit; + + -- Done if we are at a token which normally appears only after + -- a semicolon. One special glitch is that the keyword private is + -- in this category only if it does NOT appear after WITH. + + elsif (Token in Token_Class_After_SM + and then (Token /= Tok_Private + or else Prev_Token /= Tok_With)) + then + exit; + + -- Done if we are at THEN or LOOP + + elsif Token = Tok_Then or else Token = Tok_Loop then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resyncrhonization complete + + Resync_Resume; + end Resync_Past_Semicolon_Or_To_Loop_Or_Then; + + ------------------- + -- Resync_Resume -- + ------------------- + + procedure Resync_Resume is + begin + -- Save resync point (see special test in Resync_Init) + + Last_Resync_Point := Token_Ptr; + + if Debug_Flag_R then + Error_Msg_SC ("resuming here!"); + end if; + end Resync_Resume; + + -------------------- + -- Resync_To_When -- + -------------------- + + procedure Resync_To_When is + begin + Resync_Init; + + loop + -- Done if at semicolon, WHEN or IS + + if Token = Tok_Semicolon + or else Token = Tok_When + or else Token = Tok_Is + then + exit; + + -- Otherwise keep going + + else + Scan; + end if; + end loop; + + -- Fall out of loop with resyncrhonization complete + + Resync_Resume; + end Resync_To_When; + + --------------------------- + -- Resync_Semicolon_List -- + --------------------------- + + procedure Resync_Semicolon_List is + Paren_Count : Int; + + begin + Resync_Init; + Paren_Count := 0; + + loop + if Token = Tok_EOF + or else Token = Tok_Semicolon + or else Token = Tok_Is + or else Token in Token_Class_After_SM + then + exit; + + elsif Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + elsif Token = Tok_Right_Paren then + if Paren_Count = 0 then + exit; + else + Paren_Count := Paren_Count - 1; + end if; + end if; + + Scan; + end loop; + + Resync_Resume; + end Resync_Semicolon_List; + +end Sync; diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb new file mode 100644 index 00000000000..4d49e7af738 --- /dev/null +++ b/gcc/ada/par-tchk.adb @@ -0,0 +1,812 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . T C H K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.37 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Token scan routines. + +-- Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync + +separate (Par) +package body Tchk is + + type Position is (SC, BC, AP); + -- Specify position of error message (see Error_Msg_SC/BC/AP) + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Token (T : Token_Type; P : Position); + pragma Inline (Check_Token); + -- Called by T_xx routines to check for reserved keyword token. P is the + -- position of the error message if the token is missing (see Wrong_Token) + + procedure Wrong_Token (T : Token_Type; P : Position); + -- Called when scanning a reserved keyword when the keyword is not + -- present. T is the token type for the keyword, and P indicates the + -- position to be used to place a message relative to the current + -- token if the keyword is not located nearby. + + ----------------- + -- Check_Token -- + ----------------- + + procedure Check_Token (T : Token_Type; P : Position) is + begin + if Token = T then + Scan; + return; + else + Wrong_Token (T, P); + end if; + end Check_Token; + + ------------- + -- T_Abort -- + ------------- + + procedure T_Abort is + begin + Check_Token (Tok_Abort, SC); + end T_Abort; + + ------------- + -- T_Arrow -- + ------------- + + procedure T_Arrow is + begin + if Token = Tok_Arrow then + Scan; + + -- A little recovery helper, accept then in place of => + + elsif Token = Tok_Then then + Error_Msg_BC ("missing ""=>"""); + Scan; -- past THEN used in place of => + + elsif Token = Tok_Colon_Equal then + Error_Msg_SC (""":="" should be ""=>"""); + Scan; -- past := used in place of => + + else + Error_Msg_AP ("missing ""=>"""); + end if; + end T_Arrow; + + ---------- + -- T_At -- + ---------- + + procedure T_At is + begin + Check_Token (Tok_At, SC); + end T_At; + + ------------ + -- T_Body -- + ------------ + + procedure T_Body is + begin + Check_Token (Tok_Body, BC); + end T_Body; + + ----------- + -- T_Box -- + ----------- + + procedure T_Box is + begin + if Token = Tok_Box then + Scan; + else + Error_Msg_AP ("missing ""<>"""); + end if; + end T_Box; + + ------------- + -- T_Colon -- + ------------- + + procedure T_Colon is + begin + if Token = Tok_Colon then + Scan; + else + Error_Msg_AP ("missing "":"""); + end if; + end T_Colon; + + ------------------- + -- T_Colon_Equal -- + ------------------- + + procedure T_Colon_Equal is + begin + if Token = Tok_Colon_Equal then + Scan; + + elsif Token = Tok_Equal then + Error_Msg_SC ("""="" should be "":="""); + Scan; + + elsif Token = Tok_Colon then + Error_Msg_SC (""":"" should be "":="""); + Scan; + + elsif Token = Tok_Is then + Error_Msg_SC ("IS should be "":="""); + Scan; + + else + Error_Msg_AP ("missing "":="""); + end if; + end T_Colon_Equal; + + ------------- + -- T_Comma -- + ------------- + + procedure T_Comma is + begin + if Token = Tok_Comma then + Scan; + + else + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + end if; + + if Token = Tok_Comma then + Scan; + else + Error_Msg_AP ("missing "","""); + end if; + end if; + + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + end if; + end T_Comma; + + --------------- + -- T_Dot_Dot -- + --------------- + + procedure T_Dot_Dot is + begin + if Token = Tok_Dot_Dot then + Scan; + else + Error_Msg_AP ("missing "".."""); + end if; + end T_Dot_Dot; + + ----------- + -- T_For -- + ----------- + + procedure T_For is + begin + Check_Token (Tok_For, AP); + end T_For; + + ----------------------- + -- T_Greater_Greater -- + ----------------------- + + procedure T_Greater_Greater is + begin + if Token = Tok_Greater_Greater then + Scan; + else + Error_Msg_AP ("missing "">>"""); + end if; + end T_Greater_Greater; + + ------------------ + -- T_Identifier -- + ------------------ + + procedure T_Identifier is + begin + if Token = Tok_Identifier then + Scan; + elsif Token in Token_Class_Literal then + Error_Msg_SC ("identifier expected"); + Scan; + else + Error_Msg_AP ("identifier expected"); + end if; + end T_Identifier; + + ---------- + -- T_In -- + ---------- + + procedure T_In is + begin + Check_Token (Tok_In, AP); + end T_In; + + ---------- + -- T_Is -- + ---------- + + procedure T_Is is + begin + if Token = Tok_Is then + Scan; + + Ignore (Tok_Semicolon); + + -- Allow OF, => or = to substitute for IS with complaint + + elsif Token = Tok_Arrow + or else Token = Tok_Of + or else Token = Tok_Equal + then + Error_Msg_SC ("missing IS"); + Scan; -- token used in place of IS + else + Wrong_Token (Tok_Is, AP); + end if; + + while Token = Tok_Is loop + Error_Msg_SC ("extra IS ignored"); + Scan; + end loop; + end T_Is; + + ------------------ + -- T_Left_Paren -- + ------------------ + + procedure T_Left_Paren is + begin + if Token = Tok_Left_Paren then + Scan; + else + Error_Msg_AP ("missing ""("""); + end if; + end T_Left_Paren; + + ------------ + -- T_Loop -- + ------------ + + procedure T_Loop is + begin + if Token = Tok_Do then + Error_Msg_SC ("LOOP expected"); + Scan; + else + Check_Token (Tok_Loop, AP); + end if; + end T_Loop; + + ----------- + -- T_Mod -- + ----------- + + procedure T_Mod is + begin + Check_Token (Tok_Mod, AP); + end T_Mod; + + ----------- + -- T_New -- + ----------- + + procedure T_New is + begin + Check_Token (Tok_New, AP); + end T_New; + + ---------- + -- T_Of -- + ---------- + + procedure T_Of is + begin + Check_Token (Tok_Of, AP); + end T_Of; + + ---------- + -- T_Or -- + ---------- + + procedure T_Or is + begin + Check_Token (Tok_Or, AP); + end T_Or; + + --------------- + -- T_Private -- + --------------- + + procedure T_Private is + begin + Check_Token (Tok_Private, SC); + end T_Private; + + ------------- + -- T_Range -- + ------------- + + procedure T_Range is + begin + Check_Token (Tok_Range, AP); + end T_Range; + + -------------- + -- T_Record -- + -------------- + + procedure T_Record is + begin + Check_Token (Tok_Record, AP); + end T_Record; + + ------------------- + -- T_Right_Paren -- + ------------------- + + procedure T_Right_Paren is + begin + if Token = Tok_Right_Paren then + Scan; + else + Error_Msg_AP ("missing "")"""); + end if; + end T_Right_Paren; + + ----------------- + -- T_Semicolon -- + ----------------- + + procedure T_Semicolon is + begin + + if Token = Tok_Semicolon then + Scan; + + if Token = Tok_Semicolon then + Error_Msg_SC ("extra "";"" ignored"); + Scan; + end if; + + elsif Token = Tok_Colon then + Error_Msg_SC (""":"" should be "";"""); + Scan; + + elsif Token = Tok_Comma then + Error_Msg_SC (""","" should be "";"""); + Scan; + + elsif Token = Tok_Dot then + Error_Msg_SC ("""."" should be "";"""); + Scan; + + -- An interesting little kludge here. If the previous token is a + -- semicolon, then there is no way that we can legitimately need + -- another semicolon. This could only arise in an error situation + -- where an error has already been signalled. By simply ignoring + -- the request for a semicolon in this case, we avoid some spurious + -- missing semicolon messages. + + elsif Prev_Token = Tok_Semicolon then + return; + + -- If the current token is | then this is a reasonable + -- place to suggest the possibility of a "C" confusion :-) + + elsif Token = Tok_Vertical_Bar then + Error_Msg_SC ("unexpected occurrence of ""|"", did you mean OR'?"); + Resync_Past_Semicolon; + + -- Otherwise we really do have a missing semicolon + + else + Error_Msg_AP ("missing "";"""); + return; + end if; + + end T_Semicolon; + + ------------ + -- T_Then -- + ------------ + + procedure T_Then is + begin + Check_Token (Tok_Then, AP); + end T_Then; + + ------------ + -- T_Type -- + ------------ + + procedure T_Type is + begin + Check_Token (Tok_Type, BC); + end T_Type; + + ----------- + -- T_Use -- + ----------- + + procedure T_Use is + begin + Check_Token (Tok_Use, SC); + end T_Use; + + ------------ + -- T_When -- + ------------ + + procedure T_When is + begin + Check_Token (Tok_When, SC); + end T_When; + + ------------ + -- T_With -- + ------------ + + procedure T_With is + begin + Check_Token (Tok_With, BC); + end T_With; + + -------------- + -- TF_Arrow -- + -------------- + + procedure TF_Arrow is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Arrow then + Scan; -- skip arrow and we are done + + elsif Token = Tok_Colon_Equal then + T_Arrow; -- Let T_Arrow give the message + + else + T_Arrow; -- give missing arrow message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Arrow then + Scan; -- past arrow + return; + end if; + end loop; + end if; + end TF_Arrow; + + ----------- + -- TF_Is -- + ----------- + + procedure TF_Is is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Is then + T_Is; -- past IS and we are done + + -- Allow OF or => or = in place of IS (with error message) + + elsif Token = Tok_Of + or else Token = Tok_Arrow + or else Token = Tok_Equal + then + T_Is; -- give missing IS message and skip bad token + + else + T_Is; -- give missing IS message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Is + or else Token = Tok_Of + or else Token = Tok_Arrow + then + Scan; -- past IS or OF or => + return; + end if; + end loop; + end if; + end TF_Is; + + ------------- + -- TF_Loop -- + ------------- + + procedure TF_Loop is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Loop then + Scan; -- past LOOP and we are done + + -- Allow DO or THEN in place of LOOP + + elsif Token = Tok_Then or else Token = Tok_Do then + T_Loop; -- give missing LOOP message + + else + T_Loop; -- give missing LOOP message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Loop or else Token = Tok_Then then + Scan; -- past loop or then (message already generated) + return; + end if; + end loop; + end if; + end TF_Loop; + + -------------- + -- TF_Return-- + -------------- + + procedure TF_Return is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Return then + Scan; -- skip RETURN and we are done + + else + Error_Msg_SC ("missing RETURN"); + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were! + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Return then + Scan; -- past RETURN + return; + end if; + end loop; + end if; + end TF_Return; + + ------------------ + -- TF_Semicolon -- + ------------------ + + procedure TF_Semicolon is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Semicolon then + T_Semicolon; + return; + + -- An interesting little kludge here. If the previous token is a + -- semicolon, then there is no way that we can legitimately need + -- another semicolon. This could only arise in an error situation + -- where an error has already been signalled. By simply ignoring + -- the request for a semicolon in this case, we avoid some spurious + -- missing semicolon messages. + + elsif Prev_Token = Tok_Semicolon then + return; + + else + if Token = Tok_Pragma then + P_Pragmas_Misplaced; + + if Token = Tok_Semicolon then + T_Semicolon; + return; + end if; + end if; + + T_Semicolon; -- give missing semicolon message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search + + if Token = Tok_Semicolon then + T_Semicolon; + return; + + elsif Token in Token_Class_After_SM then + return; + end if; + end loop; + end if; + end TF_Semicolon; + + ------------- + -- TF_Then -- + ------------- + + procedure TF_Then is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Then then + Scan; -- past THEN and we are done + + else + T_Then; -- give missing THEN message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Then then + Scan; -- past THEN + return; + end if; + end loop; + end if; + end TF_Then; + + ------------ + -- TF_Use -- + ------------ + + procedure TF_Use is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Use then + Scan; -- past USE and we are done + + else + T_Use; -- give USE expected message + Save_Scan_State (Scan_State); -- at start of junk tokens + + loop + if Prev_Token_Ptr < Current_Line_Start + or else Token = Tok_Semicolon + or else Token = Tok_EOF + then + Restore_Scan_State (Scan_State); -- to where we were + return; + end if; + + Scan; -- continue search! + + if Token = Tok_Use then + Scan; -- past use + return; + end if; + end loop; + end if; + end TF_Use; + + ----------------- + -- Wrong_Token -- + ----------------- + + procedure Wrong_Token (T : Token_Type; P : Position) is + Missing : constant String := "missing "; + Image : constant String := Token_Type'Image (T); + Tok_Name : constant String := Image (5 .. Image'Length); + M : String (1 .. Missing'Length + Tok_Name'Length); + + begin + -- Set M to Missing & Tok_Name. + + M (1 .. Missing'Length) := Missing; + M (Missing'Length + 1 .. M'Last) := Tok_Name; + + if Token = Tok_Semicolon then + Scan; + + if Token = T then + Error_Msg_SP ("extra "";"" ignored"); + Scan; + else + Error_Msg_SP (M); + end if; + + elsif Token = Tok_Comma then + Scan; + + if Token = T then + Error_Msg_SP ("extra "","" ignored"); + Scan; + + else + Error_Msg_SP (M); + end if; + + else + case P is + when SC => Error_Msg_SC (M); + when BC => Error_Msg_BC (M); + when AP => Error_Msg_AP (M); + end case; + end if; + end Wrong_Token; + +end Tchk; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb new file mode 100644 index 00000000000..f8082b64ee6 --- /dev/null +++ b/gcc/ada/par-util.adb @@ -0,0 +1,638 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.64 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Uintp; use Uintp; + +with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; + +separate (Par) +package body Util is + + --------------------- + -- Bad_Spelling_Of -- + --------------------- + + function Bad_Spelling_Of (T : Token_Type) return Boolean is + Tname : constant String := Token_Type'Image (T); + -- Characters of token name + + S : String (1 .. Tname'Last - 4); + -- Characters of token name folded to lower case, omitting TOK_ at start + + M1 : String (1 .. 42) := "incorrect spelling of keyword ************"; + M2 : String (1 .. 44) := "illegal abbreviation of keyword ************"; + -- Buffers used to construct error message + + P1 : constant := 30; + P2 : constant := 32; + -- Starting subscripts in M1, M2 for keyword name + + SL : constant Natural := S'Length; + -- Length of expected token name excluding TOK_ at start + + begin + if Token /= Tok_Identifier then + return False; + end if; + + for J in S'Range loop + S (J) := Fold_Lower (Tname (Integer (J) + 4)); + end loop; + + Get_Name_String (Token_Name); + + -- A special check for case of PROGRAM used for PROCEDURE + + if T = Tok_Procedure + and then Name_Len = 7 + and then Name_Buffer (1 .. 7) = "program" + then + Error_Msg_SC ("PROCEDURE expected"); + Token := T; + return True; + + -- A special check for an illegal abbrevation + + elsif Name_Len < S'Length + and then Name_Len >= 4 + and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len) + then + for J in 1 .. S'Last loop + M2 (P2 + J - 1) := Fold_Upper (S (J)); + end loop; + + Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); + Token := T; + return True; + end if; + + -- Now we go into the full circuit to check for a misspelling + + -- Never consider something a misspelling if either the actual or + -- expected string is less than 3 characters (before this check we + -- used to consider i to be a misspelled if in some cases!) + + if SL < 3 or else Name_Len < 3 then + return False; + + -- Special case: prefix matches, i.e. the leading characters of the + -- token that we have exactly match the required keyword. If there + -- are at least two characters left over, assume that we have a case + -- of two keywords joined together which should not be joined. + + elsif Name_Len > SL + 1 + and then S = Name_Buffer (1 .. SL) + then + Scan_Ptr := Token_Ptr + S'Length; + Error_Msg_S ("missing space"); + Token := T; + return True; + end if; + + if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then + + for J in 1 .. S'Last loop + M1 (P1 + J - 1) := Fold_Upper (S (J)); + end loop; + + Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last)); + Token := T; + return True; + + else + return False; + end if; + + end Bad_Spelling_Of; + + ---------------------- + -- Check_95_Keyword -- + ---------------------- + + -- On entry, the caller has checked that current token is an identifier + -- whose name matches the name of the 95 keyword New_Tok. + + procedure Check_95_Keyword (Token_95, Next : Token_Type) is + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); -- at identifier/keyword + Scan; -- past identifier/keyword + + if Token = Next then + Restore_Scan_State (Scan_State); -- to identifier + Error_Msg_Name_1 := Token_Name; + Error_Msg_SC ("(Ada 83) keyword* cannot be used!"); + Token := Token_95; + else + Restore_Scan_State (Scan_State); -- to identifier + end if; + end Check_95_Keyword; + + ---------------------- + -- Check_Bad_Layout -- + ---------------------- + + procedure Check_Bad_Layout is + begin + if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line + and then Start_Column <= Scope.Table (Scope.Last).Ecol + then + Error_Msg_BC ("(style) incorrect layout"); + end if; + end Check_Bad_Layout; + + -------------------------- + -- Check_Misspelling_Of -- + -------------------------- + + procedure Check_Misspelling_Of (T : Token_Type) is + begin + if Bad_Spelling_Of (T) then + null; + end if; + end Check_Misspelling_Of; + + ----------------------------- + -- Check_Simple_Expression -- + ----------------------------- + + procedure Check_Simple_Expression (E : Node_Id) is + begin + if Expr_Form = EF_Non_Simple then + Error_Msg_N ("this expression must be parenthesized", E); + end if; + end Check_Simple_Expression; + + --------------------------------------- + -- Check_Simple_Expression_In_Ada_83 -- + --------------------------------------- + + procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is + begin + if Expr_Form = EF_Non_Simple then + if Ada_83 then + Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E); + end if; + end if; + end Check_Simple_Expression_In_Ada_83; + + ------------------------ + -- Check_Subtype_Mark -- + ------------------------ + + function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is + begin + if Nkind (Mark) = N_Identifier + or else Nkind (Mark) = N_Selected_Component + or else (Nkind (Mark) = N_Attribute_Reference + and then Is_Type_Attribute_Name (Attribute_Name (Mark))) + or else Mark = Error + then + return Mark; + else + Error_Msg ("subtype mark expected", Sloc (Mark)); + return Error; + end if; + end Check_Subtype_Mark; + + ------------------- + -- Comma_Present -- + ------------------- + + function Comma_Present return Boolean is + Scan_State : Saved_Scan_State; + Paren_Count : Nat; + + begin + -- First check, if a comma is present, then a comma is present! + + if Token = Tok_Comma then + T_Comma; + return True; + + -- If we have a right paren, then that is taken as ending the list + -- i.e. no comma is present. + + elsif Token = Tok_Right_Paren then + return False; + + -- If pragmas, then get rid of them and make a recursive call + -- to process what follows these pragmas. + + elsif Token = Tok_Pragma then + P_Pragmas_Misplaced; + return Comma_Present; + + -- At this stage we have an error, and the goal is to decide on whether + -- or not we should diagnose an error and report a (non-existent) + -- comma as being present, or simply to report no comma is present + + -- If we are a semicolon, then the question is whether we have a missing + -- right paren, or whether the semicolon should have been a comma. To + -- guess the right answer, we scan ahead keeping track of the paren + -- level, looking for a clue that helps us make the right decision. + + -- This approach is highly accurate in the single error case, and does + -- not make bad mistakes in the multiple error case (indeed we can't + -- really make a very bad decision at this point in any case). + + elsif Token = Tok_Semicolon then + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + -- Check for being followed by identifier => which almost certainly + -- means we are still in a parameter list and the comma should have + -- been a semicolon (such a sequence could not follow a semicolon) + + if Token = Tok_Identifier then + Scan; + + if Token = Tok_Arrow then + goto Assume_Comma; + end if; + end if; + + -- If that test didn't work, loop ahead looking for a comma or + -- semicolon at the same parenthesis level. Always remember that + -- we can't go badly wrong in an error situation like this! + + Paren_Count := 0; + + -- Here is the look ahead loop, Paren_Count tells us whether the + -- token we are looking at is at the same paren level as the + -- suspicious semicolon that we are trying to figure out. + + loop + + -- If we hit another semicolon or an end of file, and we have + -- not seen a right paren or another comma on the way, then + -- probably the semicolon did end the list. Indeed that is + -- certainly the only single error correction possible here. + + if Token = Tok_Semicolon or else Token = Tok_EOF then + Restore_Scan_State (Scan_State); + return False; + + -- A comma at the same paren level as the semicolon is a strong + -- indicator that the semicolon should have been a comma, indeed + -- again this is the only possible single error correction. + + elsif Token = Tok_Comma then + exit when Paren_Count = 0; + + -- A left paren just bumps the paren count + + elsif Token = Tok_Left_Paren then + Paren_Count := Paren_Count + 1; + + -- A right paren that is at the same paren level as the semicolon + -- also means that the only possible single error correction is + -- to assume that the semicolon should have been a comma. If we + -- are not at the same paren level, then adjust the paren level. + + elsif Token = Tok_Right_Paren then + exit when Paren_Count = 0; + Paren_Count := Paren_Count - 1; + end if; + + -- Keep going, we haven't made a decision yet + + Scan; + end loop; + + -- If we fall through the loop, it means that we found a terminating + -- right paren or another comma. In either case it is reasonable to + -- assume that the semicolon was really intended to be a comma. Also + -- come here for the identifier arrow case. + + <<Assume_Comma>> + Restore_Scan_State (Scan_State); + Error_Msg_SC (""";"" illegal here, replaced by "","""); + Scan; -- past the semicolon + return True; + + -- If we are not at semicolon or a right paren, then we base the + -- decision on whether or not the next token can be part of an + -- expression. If not, then decide that no comma is present (the + -- caller will eventually generate a missing right parent message) + + elsif Token in Token_Class_Eterm then + return False; + + -- Otherwise we assume a comma is present, even if none is present, + -- since the next token must be part of an expression, so if we were + -- at the end of the list, then there is more than one error present. + + else + T_Comma; -- to give error + return True; + end if; + end Comma_Present; + + ----------------------- + -- Discard_Junk_List -- + ----------------------- + + procedure Discard_Junk_List (L : List_Id) is + begin + null; + end Discard_Junk_List; + + ----------------------- + -- Discard_Junk_Node -- + ----------------------- + + procedure Discard_Junk_Node (N : Node_Id) is + begin + null; + end Discard_Junk_Node; + + ------------ + -- Ignore -- + ------------ + + procedure Ignore (T : Token_Type) is + begin + if Token = T then + if T = Tok_Comma then + Error_Msg_SC ("unexpected "","" ignored"); + + elsif T = Tok_Left_Paren then + Error_Msg_SC ("unexpected ""("" ignored"); + + elsif T = Tok_Right_Paren then + Error_Msg_SC ("unexpected "")"" ignored"); + + elsif T = Tok_Semicolon then + Error_Msg_SC ("unexpected "";"" ignored"); + + else + declare + Tname : constant String := Token_Type'Image (Token); + Msg : String := "unexpected keyword ????????????????????????"; + + begin + -- Loop to copy characters of keyword name (ignoring Tok_) + + for J in 5 .. Tname'Last loop + Msg (J + 14) := Fold_Upper (Tname (J)); + end loop; + + Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored"; + Error_Msg_SC (Msg (1 .. Tname'Last + 22)); + end; + end if; + + Scan; -- Scan past ignored token + end if; + end Ignore; + + ---------------------------- + -- Is_Reserved_Identifier -- + ---------------------------- + + function Is_Reserved_Identifier return Boolean is + begin + if not Is_Reserved_Keyword (Token) then + return False; + + else + declare + Ident_Casing : constant Casing_Type := + Identifier_Casing (Current_Source_File); + + Key_Casing : constant Casing_Type := + Keyword_Casing (Current_Source_File); + + begin + -- If the casing of identifiers and keywords is different in + -- this source file, and the casing of this token matches the + -- keyword casing, then we return False, since it is pretty + -- clearly intended to be a keyword. + + if Ident_Casing /= Unknown + and then Key_Casing /= Unknown + and then Ident_Casing /= Key_Casing + and then Determine_Token_Casing = Key_Casing + then + return False; + + -- Otherwise assume that an identifier was intended + + else + return True; + end if; + end; + end if; + end Is_Reserved_Identifier; + + ---------------------- + -- Merge_Identifier -- + ---------------------- + + procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is + begin + if Token /= Tok_Identifier then + return; + end if; + + declare + S : Saved_Scan_State; + T : Token_Type; + + begin + Save_Scan_State (S); + Scan; + T := Token; + Restore_Scan_State (S); + + if T /= Nxt then + return; + end if; + end; + + -- Check exactly one space between identifiers + + if Source (Token_Ptr - 1) /= ' ' + or else Int (Token_Ptr) /= + Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1 + then + return; + end if; + + -- Do the merge + + Get_Name_String (Chars (Token_Node)); + + declare + Buf : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + + begin + Get_Name_String (Chars (Prev)); + Add_Char_To_Name_Buffer ('_'); + Add_Str_To_Name_Buffer (Buf); + Set_Chars (Prev, Name_Find); + end; + + Error_Msg_Node_1 := Prev; + Error_Msg_SC + ("unexpected identifier, possibly & was meant here"); + Scan; + end Merge_Identifier; + + ------------------- + -- No_Constraint -- + ------------------- + + procedure No_Constraint is + begin + if Token in Token_Class_Consk then + Error_Msg_SC ("constraint not allowed here"); + Discard_Junk_Node (P_Constraint_Opt); + end if; + end No_Constraint; + + -------------------- + -- No_Right_Paren -- + -------------------- + + function No_Right_Paren (Expr : Node_Id) return Node_Id is + begin + if Token = Tok_Right_Paren then + Error_Msg_SC ("unexpected right parenthesis"); + Resync_Expression; + return Error; + else + return Expr; + end if; + end No_Right_Paren; + + --------------------- + -- Pop_Scope_Stack -- + --------------------- + + procedure Pop_Scope_Stack is + begin + pragma Assert (Scope.Last > 0); + Scope.Decrement_Last; + + if Debug_Flag_P then + Error_Msg_Uint_1 := UI_From_Int (Scope.Last); + Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); + end if; + end Pop_Scope_Stack; + + ---------------------- + -- Push_Scope_Stack -- + ---------------------- + + procedure Push_Scope_Stack is + begin + Scope.Increment_Last; + Scope.Table (Scope.Last).Junk := False; + Scope.Table (Scope.Last).Node := Empty; + + if Debug_Flag_P then + Error_Msg_Uint_1 := UI_From_Int (Scope.Last); + Error_Msg_SC ("increment scope stack ptr, new value = ^!"); + end if; + end Push_Scope_Stack; + + ---------------------- + -- Separate_Present -- + ---------------------- + + function Separate_Present return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token = Tok_Separate then + return True; + + elsif Token /= Tok_Identifier then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Semicolon then + Restore_Scan_State (Scan_State); + return Bad_Spelling_Of (Tok_Separate); + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end Separate_Present; + + -------------------------- + -- Signal_Bad_Attribute -- + -------------------------- + + procedure Signal_Bad_Attribute is + begin + Error_Msg_N ("unrecognized attribute&", Token_Node); + + -- Check for possible misspelling + + Get_Name_String (Token_Name); + + declare + AN : constant String := Name_Buffer (1 .. Name_Len); + + begin + Error_Msg_Name_1 := First_Attribute_Name; + while Error_Msg_Name_1 <= Last_Attribute_Name loop + Get_Name_String (Error_Msg_Name_1); + + if Is_Bad_Spelling_Of + (AN, Name_Buffer (1 .. Name_Len)) + then + Error_Msg_N + ("\possible misspelling of %", Token_Node); + exit; + end if; + + Error_Msg_Name_1 := Error_Msg_Name_1 + 1; + end loop; + end; + end Signal_Bad_Attribute; + + ------------------------------- + -- Token_Is_At_Start_Of_Line -- + ------------------------------- + + function Token_Is_At_Start_Of_Line return Boolean is + begin + return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF); + end Token_Is_At_Start_Of_Line; + +end Util; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb new file mode 100644 index 00000000000..f45a83b4390 --- /dev/null +++ b/gcc/ada/par.adb @@ -0,0 +1,1181 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.126 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Elists; use Elists; +with Errout; use Errout; +with Fname; use Fname; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Scans; use Scans; +with Scn; use Scn; +with Sinput; use Sinput; +with Sinput.L; use Sinput.L; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Style; +with Table; + +function Par (Configuration_Pragmas : Boolean) return List_Id is + + Num_Library_Units : Natural := 0; + -- Count number of units parsed (relevant only in syntax check only mode, + -- since in semantics check mode only a single unit is permitted anyway) + + Unit_Node : Node_Id; + -- Stores compilation unit node for current unit + + Save_Config_Switches : Config_Switches_Type; + -- Variable used to save values of config switches while we parse the + -- new unit, to be restored on exit for proper recursive behavior. + + Loop_Block_Count : Nat := 0; + -- Counter used for constructing loop/block names (see the routine + -- Par.Ch5.Get_Loop_Block_Name) + + -------------------- + -- Error Recovery -- + -------------------- + + -- When an error is encountered, a call is made to one of the Error_Msg + -- routines to record the error. If the syntax scan is not derailed by the + -- error (e.g. a complaint that logical operators are inconsistent in an + -- EXPRESSION), then control returns from the Error_Msg call, and the + -- parse continues unimpeded. + + -- If on the other hand, the Error_Msg represents a situation from which + -- the parser cannot recover locally, the exception Error_Resync is raised + -- immediately after the call to Error_Msg. Handlers for Error_Resync + -- are located at strategic points to resynchronize the parse. For example, + -- when an error occurs in a statement, the handler skips to the next + -- semicolon and continues the scan from there. + + -- Each parsing procedure contains a note with the heading "Error recovery" + -- which shows if it can propagate the Error_Resync exception. In order + -- not to propagate the exception, a procedure must either contain its own + -- handler for this exception, or it must not call any other routines which + -- propagate the exception. + + -- Note: the arrangement of Error_Resync handlers is such that it should + -- never be possible to transfer control through a procedure which made + -- an entry in the scope stack, invalidating the contents of the stack. + + Error_Resync : exception; + -- Exception raised on error that is not handled locally, see above. + + Last_Resync_Point : Source_Ptr; + -- The resynchronization routines in Par.Sync run a risk of getting + -- stuck in an infinite loop if they do not skip a token, and the caller + -- keeps repeating the same resync call. On the other hand, if they skip + -- a token unconditionally, some recovery opportunities are missed. The + -- variable Last_Resync_Point records the token location previously set + -- by a Resync call, and if a subsequent Resync call occurs at the same + -- location, then the Resync routine does guarantee to skip a token. + + -------------------------------------------- + -- Handling Semicolon Used in Place of IS -- + -------------------------------------------- + + -- The following global variables are used in handling the error situation + -- of using a semicolon in place of IS in a subprogram declaration as in: + + -- procedure X (Y : Integer); + -- Q : Integer; + -- begin + -- ... + -- end; + + -- The two contexts in which this can appear are at the outer level, and + -- within a declarative region. At the outer level, we know something is + -- wrong as soon as we see the Q (or begin, if there are no declarations), + -- and we can immediately decide that the semicolon should have been IS. + + -- The situation in a declarative region is more complex. The declaration + -- of Q could belong to the outer region, and we do not know that we have + -- an error until we hit the begin. It is still not clear at this point + -- from a syntactic point of view that something is wrong, because the + -- begin could belong to the enclosing subprogram or package. However, we + -- can incorporate a bit of semantic knowledge and note that the body of + -- X is missing, so we definitely DO have an error. We diagnose this error + -- as semicolon in place of IS on the subprogram line. + + -- There are two styles for this diagnostic. If the begin immediately + -- follows the semicolon, then we can place a flag (IS expected) right + -- on the semicolon. Otherwise we do not detect the error until we hit + -- the begin which refers back to the line with the semicolon. + + -- To control the process in the second case, the following global + -- variables are set to indicate that we have a subprogram declaration + -- whose body is required and has not yet been found. The prefix SIS + -- stands for "Subprogram IS" handling. + + SIS_Entry_Active : Boolean; + -- Set True to indicate that an entry is active (i.e. that a subprogram + -- declaration has been encountered, and no body for this subprogram has + -- been encountered). The remaining fields are valid only if this is True. + + SIS_Labl : Node_Id; + -- Subprogram designator + + SIS_Sloc : Source_Ptr; + -- Source location of FUNCTION/PROCEDURE keyword + + SIS_Ecol : Column_Number; + -- Column number of FUNCTION/PROCEDURE keyword + + SIS_Semicolon_Sloc : Source_Ptr; + -- Source location of semicolon at end of subprogram declaration + + SIS_Declaration_Node : Node_Id; + -- Pointer to tree node for subprogram declaration + + SIS_Missing_Semicolon_Message : Error_Msg_Id; + -- Used to save message ID of missing semicolon message (which will be + -- modified to missing IS if necessary). Set to No_Error_Msg in the + -- normal (non-error) case. + + -- Five things can happen to an active SIS entry + + -- 1. If a BEGIN is encountered with an SIS entry active, then we have + -- exactly the situation in which we know the body of the subprogram is + -- missing. After posting an error message, we change the spec to a body, + -- rechaining the declarations that intervened between the spec and BEGIN. + + -- 2. Another subprogram declaration or body is encountered. In this + -- case the entry gets overwritten with the information for the new + -- subprogram declaration. We don't catch some nested cases this way, + -- but it doesn't seem worth the effort. + + -- 3. A nested declarative region (e.g. package declaration or package + -- body) is encountered. The SIS active indication is reset at the start + -- of such a nested region. Again, like case 2, this causes us to miss + -- some nested cases, but it doesn't seen worth the effort to stack and + -- unstack the SIS information. Maybe we will reconsider this if we ever + -- get a complaint about a missed case :-) + + -- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively + -- supplies the missing body. In this case we reset the entry. + + -- 5. We encounter the end of the declarative region without encoutering + -- a BEGIN first. In this situation we simply reset the entry. We know + -- that there is a missing body, but it seems more reasonable to let the + -- later semantic checking discover this. + + -------------------------------------------- + -- Handling IS Used in Place of Semicolon -- + -------------------------------------------- + + -- This is a somewhat trickier situation, and we can't catch it in all + -- cases, but we do our best to detect common situations resulting from + -- a "cut and paste" operation which forgets to change the IS to semicolon. + -- Consider the following example: + + -- package body X is + -- procedure A; + -- procedure B is + -- procedure C; + -- ... + -- procedure D is + -- begin + -- ... + -- end; + -- begin + -- ... + -- end; + + -- The trouble is that the section of text from PROCEDURE B through END; + -- consitutes a valid procedure body, and the danger is that we find out + -- far too late that something is wrong (indeed most compilers will behave + -- uncomfortably on the above example). + + -- We have two approaches to helping to control this situation. First we + -- make every attempt to avoid swallowing the last END; if we can be + -- sure that some error will result from doing so. In particular, we won't + -- accept the END; unless it is exactly correct (in particular it must not + -- have incorrect name tokens), and we won't accept it if it is immediately + -- followed by end of file, WITH or SEPARATE (all tokens that unmistakeably + -- signal the start of a compilation unit, and which therefore allow us to + -- reserve the END; for the outer level.) For more details on this aspect + -- of the handling, see package Par.Endh. + + -- If we can avoid eating up the END; then the result in the absense of + -- any additional steps would be to post a missing END referring back to + -- the subprogram with the bogus IS. Similarly, if the enclosing package + -- has no BEGIN, then the result is a missing BEGIN message, which again + -- refers back to the subprogram header. + + -- Such an error message is not too bad (it's already a big improvement + -- over what many parsers do), but it's not ideal, because the declarations + -- following the IS have been absorbed into the wrong scope. In the above + -- case, this could result for example in a bogus complaint that the body + -- of D was missing from the package. + + -- To catch at least some of these cases, we take the following additional + -- steps. First, a subprogram body is marked as having a suspicious IS if + -- the declaration line is followed by a line which starts with a symbol + -- that can start a declaration in the same column, or to the left of the + -- column in which the FUNCTION or PROCEDURE starts (normal style is to + -- indent any declarations which really belong a subprogram). If such a + -- subprogram encounters a missing BEGIN or missing END, then we decide + -- that the IS should have been a semicolon, and the subprogram body node + -- is marked (by setting the Bad_Is_Detected flag true. Note that we do + -- not do this for library level procedures, only for nested procedures, + -- since for library level procedures, we must have a body. + + -- The processing for a declarative part checks to see if the last + -- declaration scanned is marked in this way, and if it is, the tree + -- is modified to reflect the IS being interpreted as a semicolon. + + --------------------------------------------------- + -- Parser Type Definitions and Control Variables -- + --------------------------------------------------- + + -- The following variable and associated type declaration are used by the + -- expression parsing routines to return more detailed information about + -- the categorization of a parsed expression. + + type Expr_Form_Type is ( + EF_Simple_Name, -- Simple name, i.e. possibly qualified identifier + EF_Name, -- Simple expression which could also be a name + EF_Simple, -- Simple expression which is not call or name + EF_Range_Attr, -- Range attribute reference + EF_Non_Simple); -- Expression that is not a simple expression + + Expr_Form : Expr_Form_Type; + + -- The following type is used for calls to P_Subprogram, P_Package, P_Task, + -- P_Protected to indicate which of several possibilities is acceptable. + + type Pf_Rec is record + Spcn : Boolean; -- True if specification OK + Decl : Boolean; -- True if declaration OK + Gins : Boolean; -- True if generic instantiation OK + Pbod : Boolean; -- True if proper body OK + Rnam : Boolean; -- True if renaming declaration OK + Stub : Boolean; -- True if body stub OK + Fil1 : Boolean; -- Filler to fill to 8 bits + Fil2 : Boolean; -- Filler to fill to 8 bits + end record; + pragma Pack (Pf_Rec); + + function T return Boolean renames True; + function F return Boolean renames False; + + Pf_Decl_Gins_Pbod_Rnam_Stub : constant Pf_Rec := + Pf_Rec'(F, T, T, T, T, T, F, F); + Pf_Decl : constant Pf_Rec := + Pf_Rec'(F, T, F, F, F, F, F, F); + Pf_Decl_Gins_Pbod_Rnam : constant Pf_Rec := + Pf_Rec'(F, T, T, T, T, F, F, F); + Pf_Decl_Pbod : constant Pf_Rec := + Pf_Rec'(F, T, F, T, F, F, F, F); + Pf_Pbod : constant Pf_Rec := + Pf_Rec'(F, F, F, T, F, F, F, F); + Pf_Spcn : constant Pf_Rec := + Pf_Rec'(T, F, F, F, F, F, F, F); + -- The above are the only allowed values of Pf_Rec arguments + + type SS_Rec is record + Eftm : Boolean; -- ELSIF can terminate sequence + Eltm : Boolean; -- ELSE can terminate sequence + Extm : Boolean; -- EXCEPTION can terminate sequence + Ortm : Boolean; -- OR can terminate sequence + Sreq : Boolean; -- at least one statement required + Tatm : Boolean; -- THEN ABORT can terminate sequence + Whtm : Boolean; -- WHEN can terminate sequence + Unco : Boolean; -- Unconditional terminate after one statement + end record; + pragma Pack (SS_Rec); + + SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F); + SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F); + SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F); + SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F); + SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F); + SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F); + SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F); + SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F); + SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T); + + Label_List : Elist_Id; + -- List of label nodes for labels appearing in the current compilation. + -- Used by Par.Labl to construct the corresponding implicit declarations. + + ----------------- + -- Scope Table -- + ----------------- + + -- The scope table, also referred to as the scope stack, is used to + -- record the current scope context. It is organized as a stack, with + -- inner nested entries corresponding to higher entries on the stack. + -- An entry is made when the parser encounters the opening of a nested + -- construct (such as a record, task, package etc.), and then package + -- Par.Endh uses this stack to deal with END lines (including properly + -- dealing with END nesting errors). + + type SS_End_Type is + -- Type of end entry required for this scope. The last two entries are + -- used only in the subprogram body case to mark the case of a suspicious + -- IS, or a bad IS (i.e. suspicions confirmed by missing BEGIN or END). + -- See separate section on dealing with IS used in place of semicolon. + -- Note that for many purposes E_Name, E_Suspicious_Is and E_Bad_Is are + -- treated the same (E_Suspicious_Is and E_Bad_Is are simply special cases + -- of E_Name). They are placed at the end of the enumeration so that a + -- test for >= E_Name catches all three cases efficiently. + + (E_Dummy, -- dummy entry at outer level + E_Case, -- END CASE; + E_If, -- END IF; + E_Loop, -- END LOOP; + E_Record, -- END RECORD; + E_Select, -- END SELECT; + E_Name, -- END [name]; + E_Suspicious_Is, -- END [name]; (case of suspicious IS) + E_Bad_Is); -- END [name]; (case of bad IS) + + -- The following describes a single entry in the scope table + + type Scope_Table_Entry is record + Etyp : SS_End_Type; + -- Type of end entry, as per above description + + Lreq : Boolean; + -- A flag indicating whether the label, if present, is required to + -- appear on the end line. It is referenced only in the case of + -- Etyp = E_Name or E_Suspicious_Is where the name may or may not be + -- required (yes for labeled block, no in other cases). Note that for + -- all cases except begin, the question of whether a label is required + -- can be determined from the other fields (for loop, it is required if + -- it is present, and for the other constructs it is never required or + -- allowed). + + Ecol : Column_Number; + -- Contains the absolute column number (with tabs expanded) of the + -- the expected column of the end assuming normal Ada indentation + -- usage. If the RM_Column_Check mode is set, this value is used for + -- generating error messages about indentation. Otherwise it is used + -- only to control heuristic error recovery actions. + + Labl : Node_Id; + -- This field is used only for the LOOP and BEGIN cases, and is the + -- Node_Id value of the label name. For all cases except child units, + -- this value is an entity whose Chars field contains the name pointer + -- that identifies the label uniquely. For the child unit case the Labl + -- field references an N_Defining_Program_Unit_Name node for the name. + -- For cases other than LOOP or BEGIN, the Label field is set to Error, + -- indicating that it is an error to have a label on the end line. + + Decl : List_Id; + -- Points to the list of declarations (i.e. the declarative part) + -- associated with this construct. It is set only in the END [name] + -- cases, and is set to No_List for all other cases which do not have a + -- declarative unit associated with them. This is used for determining + -- the proper location for implicit label declarations. + + Node : Node_Id; + -- Empty except in the case of entries for IF and CASE statements, + -- in which case it contains the N_If_Statement or N_Case_Statement + -- node. This is used for setting the End_Span field. + + Sloc : Source_Ptr; + -- Source location of the opening token of the construct. This is + -- used to refer back to this line in error messages (such as missing + -- or incorrect end lines). The Sloc field is not used, and is not set, + -- if a label is present (the Labl field provides the text name of the + -- label in this case, which is fine for error messages). + + S_Is : Source_Ptr; + -- S_Is is relevant only if Etyp is set to E_Suspicious_Is or + -- E_Bad_Is. It records the location of the IS that is considered + -- to be suspicious. + + Junk : Boolean; + -- A boolean flag that is set true if the opening entry is the dubious + -- result of some prior error, e.g. a record entry where the record + -- keyword was missing. It is used to suppress the issuing of a + -- corresponding junk complaint about the end line (we do not want + -- to complain about a missing end record when there was no record). + end record; + + -- The following declares the scope table itself. The Last field is the + -- stack pointer, so that Scope.Table (Scope.Last) is the top entry. The + -- oldest entry, at Scope_Stack (0), is a dummy entry with Etyp set to + -- E_Dummy, and the other fields undefined. This dummy entry ensures that + -- Scope_Stack (Scope_Stack_Ptr).Etyp can always be tested, and that the + -- scope stack pointer is always in range. + + package Scope is new Table.Table ( + Table_Component_Type => Scope_Table_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Scope"); + + --------------------------------- + -- Parsing Routines by Chapter -- + --------------------------------- + + -- Uncommented declarations in this section simply parse the construct + -- corresponding to their name, and return an ID value for the Node or + -- List that is created. + + package Ch2 is + function P_Identifier return Node_Id; + function P_Pragma return Node_Id; + + function P_Pragmas_Opt return List_Id; + -- This function scans for a sequence of pragmas in other than a + -- declaration sequence or statement sequence context. All pragmas + -- can appear except pragmas Assert and Debug, which are only allowed + -- in a declaration or statement sequence context. + + procedure P_Pragmas_Misplaced; + -- Skips misplaced pragmas with a complaint + + procedure P_Pragmas_Opt (List : List_Id); + -- Parses optional pragmas and appends them to the List + end Ch2; + + package Ch3 is + Missing_Begin_Msg : Error_Msg_Id; + -- This variable is set by a call to P_Declarative_Part. Normally it + -- is set to No_Error_Msg, indicating that no special processing is + -- required by the caller. The special case arises when a statement + -- is found in the sequence of declarations. In this case the Id of + -- the message issued ("declaration expected") is preserved in this + -- variable, then the caller can change it to an appropriate missing + -- begin message if indeed the BEGIN is missing. + + function P_Access_Definition return Node_Id; + function P_Access_Type_Definition return Node_Id; + function P_Array_Type_Definition return Node_Id; + function P_Basic_Declarative_Items return List_Id; + function P_Constraint_Opt return Node_Id; + function P_Declarative_Part return List_Id; + function P_Defining_Identifier return Node_Id; + function P_Discrete_Choice_List return List_Id; + function P_Discrete_Range return Node_Id; + function P_Discrete_Subtype_Definition return Node_Id; + function P_Known_Discriminant_Part_Opt return List_Id; + function P_Signed_Integer_Type_Definition return Node_Id; + function P_Range return Node_Id; + function P_Range_Or_Subtype_Mark return Node_Id; + function P_Range_Constraint return Node_Id; + function P_Record_Definition return Node_Id; + function P_Subtype_Indication return Node_Id; + function P_Subtype_Mark return Node_Id; + function P_Subtype_Mark_Resync return Node_Id; + function P_Unknown_Discriminant_Part_Opt return Boolean; + + procedure P_Component_Items (Decls : List_Id); + -- Scan out one or more component items and append them to the + -- given list. Only scans out more than one declaration in the + -- case where the source has a single declaration with multiple + -- defining identifiers. + + function Init_Expr_Opt (P : Boolean := False) return Node_Id; + -- If an initialization expression is present (:= expression), then + -- it is scanned out and returned, otherwise Empty is returned if no + -- initialization expression is present. This procedure also handles + -- certain common error cases cleanly. The parameter P indicates if + -- a right paren can follow the expression (default = no right paren + -- allowed). + + procedure Skip_Declaration (S : List_Id); + -- Used when scanning statements to skip past a mispaced declaration + -- The declaration is scanned out and appended to the given list. + -- Token is known to be a declaration token (in Token_Class_Declk) + -- on entry, so there definition is a declaration to be scanned. + + function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id; + -- This version of P_Subtype_Indication is called when the caller has + -- already scanned out the subtype mark which is passed as a parameter. + + function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id; + -- Parse a subtype mark attribute. The caller has already parsed the + -- subtype mark, which is passed in as the argument, and has checked + -- that the current token is apostrophe. + + end Ch3; + + package Ch4 is + function P_Aggregate return Node_Id; + function P_Expression return Node_Id; + function P_Expression_No_Right_Paren return Node_Id; + function P_Expression_Or_Range_Attribute return Node_Id; + function P_Function_Name return Node_Id; + function P_Name return Node_Id; + function P_Qualified_Simple_Name return Node_Id; + function P_Qualified_Simple_Name_Resync return Node_Id; + function P_Simple_Expression return Node_Id; + function P_Simple_Expression_Or_Range_Attribute return Node_Id; + + function P_Qualified_Expression + (Subtype_Mark : Node_Id) + return Node_Id; + -- This routine scans out a qualified expression when the caller has + -- already scanned out the name and apostrophe of the construct. + + end Ch4; + + package Ch5 is + + function P_Statement_Name (Name_Node : Node_Id) return Node_Id; + -- Given a node representing a name (which is a call), converts it + -- to the syntactically corresponding procedure call statement. + + function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id; + -- The argument indicates the acceptable termination tokens. + -- See body in Par.Ch5 for details of the use of this parameter. + + procedure Parse_Decls_Begin_End (Parent : Node_Id); + -- Parses declarations and handled statement sequence, setting + -- fields of Parent node appropriately. + + end Ch5; + + package Ch6 is + function P_Designator return Node_Id; + function P_Defining_Program_Unit_Name return Node_Id; + function P_Formal_Part return List_Id; + function P_Parameter_Profile return List_Id; + function P_Return_Statement return Node_Id; + function P_Subprogram_Specification return Node_Id; + + procedure P_Mode (Node : Node_Id); + -- Sets In_Present and/or Out_Present flags in Node scanning past + -- IN, OUT or IN OUT tokens in the source. + + function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id; + -- Scans out any construct starting with either of the keywords + -- PROCEDURE or FUNCTION. The parameter indicates which possible + -- possible kinds of construct (body, spec, instantiation etc.) + -- are permissible in the current context. + + end Ch6; + + package Ch7 is + function P_Package (Pf_Flags : Pf_Rec) return Node_Id; + -- Scans out any construct starting with the keyword PACKAGE. The + -- parameter indicates which possible kinds of construct (body, spec, + -- instantiation etc.) are permissible in the current context. + end Ch7; + + package Ch8 is + function P_Use_Clause return Node_Id; + end Ch8; + + package Ch9 is + function P_Abort_Statement return Node_Id; + function P_Abortable_Part return Node_Id; + function P_Accept_Statement return Node_Id; + function P_Delay_Statement return Node_Id; + function P_Entry_Body return Node_Id; + function P_Protected return Node_Id; + function P_Requeue_Statement return Node_Id; + function P_Select_Statement return Node_Id; + function P_Task return Node_Id; + function P_Terminate_Alternative return Node_Id; + end Ch9; + + package Ch10 is + function P_Compilation_Unit return Node_Id; + -- Note: this function scans a single compilation unit, and + -- checks that an end of file follows this unit, diagnosing + -- any unexpected input as an error, and then skipping it, so + -- that Token is set to Tok_EOF on return. An exception is in + -- syntax-only mode, where multiple compilation units are + -- permitted. In this case, P_Compilation_Unit does not check + -- for end of file and there may be more compilation units to + -- scan. The caller can uniquely detect this situation by the + -- fact that Token is not set to Tok_EOF on return. + end Ch10; + + package Ch11 is + function P_Handled_Sequence_Of_Statements return Node_Id; + function P_Raise_Statement return Node_Id; + + function Parse_Exception_Handlers return List_Id; + -- Parses the partial construct EXCEPTION followed by a list of + -- exception handlers which appears in a number of productions, + -- and returns the list of exception handlers. + + end Ch11; + + package Ch12 is + function P_Generic return Node_Id; + function P_Generic_Actual_Part_Opt return List_Id; + end Ch12; + + package Ch13 is + function P_Representation_Clause return Node_Id; + + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; + -- Function to parse a code statement. The caller has scanned out + -- the name to be used as the subtype mark (but has not checked that + -- it is suitable for use as a subtype mark, i.e. is either an + -- identifier or a selected component). The current token is an + -- apostrophe and the following token is either a left paren or + -- RANGE (the latter being an error to be caught by P_Code_Statement. + end Ch13; + + -- Note: the parsing for annexe J features (i.e. obsolescent features) + -- is found in the logical section where these features would be if + -- they were not obsolescent. In particular: + + -- Delta constraint is parsed by P_Delta_Constraint (3.5.9) + -- At clause is parsed by P_At_Clause (13.1) + -- Mod clause is parsed by P_Mod_Clause (13.5.1) + + ------------------ + -- End Handling -- + ------------------ + + -- Routines for handling end lines, including scope recovery + + package Endh is + + function Check_End return Boolean; + -- Called when an end sequence is required. In the absence of an error + -- situation, Token contains Tok_End on entry, but in a missing end + -- case, this may not be the case. Pop_End_Context is used to determine + -- the appropriate action to be taken. The returned result is True if + -- an End sequence was encountered and False if no End sequence was + -- present. This occurs if the END keyword encountered was determined + -- to be improper and deleted (i.e. Pop_End_Context set End_Action to + -- Skip_And_Reject). Note that the END sequence includes a semicolon, + -- except in the case of END RECORD, where a semicolon follows the END + -- RECORD, but is not part of the record type definition itself. + + procedure End_Skip; + -- Skip past an end sequence. On entry Token contains Tok_End, and we + -- we know that the end sequence is syntactically incorrect, and that + -- an appropriate error message has already been posted. The mission + -- is simply to position the scan pointer to be the best guess of the + -- position after the end sequence. We do not issue any additional + -- error messages while carrying this out. + + procedure End_Statements (Parent : Node_Id := Empty); + -- Called when an end is required or expected to terminate a sequence + -- of statements. The caller has already made an appropriate entry in + -- the Scope.Table to describe the expected form of the end. This can + -- only be used in cases where the only appropriate terminator is end. + -- If Parent is non-empty, then if a correct END line is encountered, + -- the End_Label field of Parent is set appropriately. + + end Endh; + + ------------------------------------ + -- Resynchronization After Errors -- + ------------------------------------ + + -- These procedures are used to resynchronize after errors. Following an + -- error which is not immediately locally recoverable, the exception + -- Error_Resync is raised. The handler for Error_Resync typically calls + -- one of these recovery procedures to resynchronize the source position + -- to a point from which parsing can be restarted. + + -- Note: these procedures output an information message that tokens are + -- being skipped, but this message is output only if the option for + -- Multiple_Errors_Per_Line is set in Options. + + package Sync is + + procedure Resync_Choice; + -- Used if an error occurs scanning a choice. The scan pointer is + -- advanced to the next vertical bar, arrow, or semicolon, whichever + -- comes first. We also quit if we encounter an end of file. + + procedure Resync_Expression; + -- Used if an error is detected during the parsing of an expression. + -- It skips past tokens until either a token which cannot be part of + -- an expression is encountered (an expression terminator), or if a + -- comma or right parenthesis or vertical bar is encountered at the + -- current parenthesis level (a parenthesis level counter is maintained + -- to carry out this test). + + procedure Resync_Past_Semicolon; + -- Used if an error occurs while scanning a sequence of declarations. + -- The scan pointer is positioned past the next semicolon and the scan + -- resumes. The scan is also resumed on encountering a token which + -- starts a declaration (but we make sure to skip at least one token + -- in this case, to avoid getting stuck in a loop). + + procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then; + -- Used if an error occurs while scanning a sequence of statements. + -- The scan pointer is positioned past the next semicolon, or to the + -- next occurrence of either then or loop, and the scan resumes. + + procedure Resync_To_When; + -- Used when an error occurs scanning an entry index specification. + -- The scan pointer is positioned to the next WHEN (or to IS or + -- semicolon if either of these appear before WHEN, indicating + -- another error has occurred). + + procedure Resync_Semicolon_List; + -- Used if an error occurs while scanning a parenthesized list of items + -- separated by semicolons. The scan pointer is advanced to the next + -- semicolon or right parenthesis at the outer parenthesis level, or + -- to the next is or RETURN keyword occurence, whichever comes first. + + procedure Resync_Cunit; + -- Synchronize to next token which could be the start of a compilation + -- unit, or to the end of file token. + + end Sync; + + ------------------------- + -- Token Scan Routines -- + ------------------------- + + -- Routines to check for expected tokens + + package Tchk is + + -- Procedures with names of the form T_xxx, where Tok_xxx is a token + -- name, check that the current token matches the required token, and + -- if so, scan past it. If not, an error is issued indicating that + -- the required token is not present (xxx expected). In most cases, the + -- scan pointer is not moved in the not-found case, but there are some + -- exceptions to this, see for example T_Id, where the scan pointer is + -- moved across a literal appearing where an identifier is expected. + + procedure T_Abort; + procedure T_Arrow; + procedure T_At; + procedure T_Body; + procedure T_Box; + procedure T_Colon; + procedure T_Colon_Equal; + procedure T_Comma; + procedure T_Dot_Dot; + procedure T_For; + procedure T_Greater_Greater; + procedure T_Identifier; + procedure T_In; + procedure T_Is; + procedure T_Left_Paren; + procedure T_Loop; + procedure T_Mod; + procedure T_New; + procedure T_Of; + procedure T_Or; + procedure T_Private; + procedure T_Range; + procedure T_Record; + procedure T_Right_Paren; + procedure T_Semicolon; + procedure T_Then; + procedure T_Type; + procedure T_Use; + procedure T_When; + procedure T_With; + + -- Procedures have names of the form TF_xxx, where Tok_xxx is a token + -- name check that the current token matches the required token, and + -- if so, scan past it. If not, an error message is issued indicating + -- that the required token is not present (xxx expected). + + -- If the missing token is at the end of the line, then control returns + -- immediately after posting the message. If there are remaining tokens + -- on the current line, a search is conducted to see if the token + -- appears later on the current line, as follows: + + -- A call to Scan_Save is issued and a forward search for the token + -- is carried out. If the token is found on the current line before a + -- semicolon, then it is scanned out and the scan continues from that + -- point. If not the scan is restored to the point where it was missing. + + procedure TF_Arrow; + procedure TF_Is; + procedure TF_Loop; + procedure TF_Return; + procedure TF_Semicolon; + procedure TF_Then; + procedure TF_Use; + + end Tchk; + + ---------------------- + -- Utility Routines -- + ---------------------- + + package Util is + + function Bad_Spelling_Of (T : Token_Type) return Boolean; + -- This function is called in an error situation. It checks if the + -- current token is an identifier whose name is a plausible bad + -- spelling of the given keyword token, and if so, issues an error + -- message, sets Token from T, and returns True. Otherwise Token is + -- unchanged, and False is returned. + + procedure Check_Bad_Layout; + -- Check for bad indentation in RM checking mode. Used for statements + -- and declarations. Checks if current token is at start of line and + -- is exdented from the current expected end column, and if so an + -- error message is generated. + + procedure Check_Misspelling_Of (T : Token_Type); + pragma Inline (Check_Misspelling_Of); + -- This is similar to the function above, except that it does not + -- return a result. It is typically used in a situation where any + -- identifier is an error, and it makes sense to simply convert it + -- to the given token if it is a plausible misspelling of it. + + procedure Check_95_Keyword (Token_95, Next : Token_Type); + -- This routine checks if the token after the current one matches the + -- Next argument. If so, the scan is backed up to the current token + -- and Token_Type is changed to Token_95 after issuing an appropriate + -- error message ("(Ada 83) keyword xx cannot be used"). If not, + -- the scan is backed up with Token_Type unchanged. This routine + -- is used to deal with an attempt to use a 95 keyword in Ada 83 + -- mode. The caller has typically checked that the current token, + -- an identifier, matches one of the 95 keywords. + + procedure Check_Simple_Expression (E : Node_Id); + -- Given an expression E, that has just been scanned, so that Expr_Form + -- is still set, outputs an error if E is a non-simple expression. E is + -- not modified by this call. + + procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id); + -- Like Check_Simple_Expression, except that the error message is only + -- given when operating in Ada 83 mode, and includes "in Ada 83". + + function Check_Subtype_Mark (Mark : Node_Id) return Node_Id; + -- Called to check that a node representing a name (or call) is + -- suitable for a subtype mark, i.e, that it is an identifier or + -- a selected component. If so, or if it is already Error, then + -- it is returned unchanged. Otherwise an error message is issued + -- and Error is returned. + + function Comma_Present return Boolean; + -- Used in comma delimited lists to determine if a comma is present, or + -- can reasonably be assumed to have been present (an error message is + -- generated in the latter case). If True is returned, the scan has been + -- positioned past the comma. If False is returned, the scan position + -- is unchanged. Note that all comma-delimited lists are terminated by + -- a right paren, so the only legitimate tokens when Comma_Present is + -- called are right paren and comma. If some other token is found, then + -- Comma_Present has the job of deciding whether it is better to pretend + -- a comma was present, post a message for a missing comma and return + -- True, or return False and let the caller diagnose the missing right + -- parenthesis. + + procedure Discard_Junk_Node (N : Node_Id); + procedure Discard_Junk_List (L : List_Id); + pragma Inline (Discard_Junk_Node); + pragma Inline (Discard_Junk_List); + -- These procedures do nothing at all, their effect is simply to discard + -- the argument. A typical use is to skip by some junk that is not + -- expected in the current context. + + procedure Ignore (T : Token_Type); + -- If current token matches T, then give an error message and skip + -- past it, otherwise the call has no effect at all. T may be any + -- reserved word token, or comma, left or right paren, or semicolon. + + function Is_Reserved_Identifier return Boolean; + -- Test if current token is a reserved identifier. This test is based + -- on the token being a keyword and being spelled in typical identifier + -- style (i.e. starting with an upper case letter). + + procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type); + -- Called when the previous token is an identifier (whose Token_Node + -- value is given by Prev) to check if current token is an identifier + -- that can be merged with the previous one adding an underscore. The + -- merge is only attempted if the following token matches Nxt. If all + -- conditions are met, an error message is issued, and the merge is + -- carried out, modifying the Chars field of Prev. + + procedure No_Constraint; + -- Called in a place where no constraint is allowed, but one might + -- appear due to a common error (e.g. after the type mark in a procedure + -- parameter. If a constraint is present, an error message is posted, + -- and the constraint is scanned and discarded. + + function No_Right_Paren (Expr : Node_Id) return Node_Id; + -- Function to check for no right paren at end of expression, returns + -- its argument if no right paren, else flags paren and returns Error. + + procedure Push_Scope_Stack; + pragma Inline (Push_Scope_Stack); + -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) + -- is incremented. The Junk field is preinitialized to False. The caller + -- is expected to fill in all remaining entries of the new new top stack + -- entry at Scope.Table (Scope.Last). + + procedure Pop_Scope_Stack; + -- Pop an entry off the top of the scope stack. Scope_Last (the scope + -- table stack pointer) is decremented by one. It is a fatal error to + -- try to pop off the dummy entry at the bottom of the stack (i.e. + -- Scope.Last must be non-zero at the time of call). + + function Separate_Present return Boolean; + -- Determines if the current token is either Tok_Separate, or an + -- identifier that is a possible misspelling of "separate" followed + -- by a semicolon. True is returned if so, otherwise False. + + procedure Signal_Bad_Attribute; + -- The current token is an identifier that is supposed to be an + -- attribute identifier but is not. This routine posts appropriate + -- error messages, including a check for a near misspelling. + + function Token_Is_At_Start_Of_Line return Boolean; + pragma Inline (Token_Is_At_Start_Of_Line); + -- Determines if the current token is the first token on the line + + end Util; + + --------------------------------------- + -- Specialized Syntax Check Routines -- + --------------------------------------- + + function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id; + -- This function is passed a tree for a pragma that has been scanned out. + -- The pragma is syntactically well formed according to the general syntax + -- for pragmas and the pragma identifier is for one of the recognized + -- pragmas. It performs specific syntactic checks for specific pragmas. + -- The result is the input node if it is OK, or Error otherwise. The + -- reason that this is separated out is to facilitate the addition + -- of implementation defined pragmas. The second parameter records the + -- location of the semicolon following the pragma (this is needed for + -- correct processing of the List and Page pragmas). The returned value + -- is a copy of Pragma_Node, or Error if an error is found. + + ------------------------- + -- Subsidiary Routines -- + ------------------------- + + procedure Labl; + -- This procedure creates implicit label declarations for all label that + -- are declared in the current unit. Note that this could conceptually + -- be done at the point where the labels are declared, but it is tricky + -- to do it then, since the tree is not hooked up at the point where the + -- label is declared (e.g. a sequence of statements is not yet attached + -- to its containing scope at the point a label in the sequence is found) + + procedure Load; + -- This procedure loads all subsidiary units that are required by this + -- unit, including with'ed units, specs for bodies, and parents for child + -- units. It does not load bodies for inlined procedures and generics, + -- since we don't know till semantic analysis is complete what is needed. + + ----------- + -- Stubs -- + ----------- + + -- The package bodies can see all routines defined in all other subpackages + + use Ch2; + use Ch3; + use Ch4; + use Ch5; + use Ch6; + use Ch7; + use Ch8; + use Ch9; + use Ch10; + use Ch11; + use Ch12; + use Ch13; + + use Endh; + use Tchk; + use Sync; + use Util; + + package body Ch2 is separate; + package body Ch3 is separate; + package body Ch4 is separate; + package body Ch5 is separate; + package body Ch6 is separate; + package body Ch7 is separate; + package body Ch8 is separate; + package body Ch9 is separate; + package body Ch10 is separate; + package body Ch11 is separate; + package body Ch12 is separate; + package body Ch13 is separate; + + package body Endh is separate; + package body Tchk is separate; + package body Sync is separate; + package body Util is separate; + + function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id + is separate; + + procedure Labl is separate; + procedure Load is separate; + + --------- + -- Par -- + --------- + +-- This function is the parse routine called at the outer level. It parses +-- the current compilation unit and adds implicit label declarations. + +begin + -- Deal with configuration pragmas case first + + if Configuration_Pragmas then + declare + Ecount : constant Int := Errors_Detected; + Pragmas : List_Id := Empty_List; + P_Node : Node_Id; + + begin + loop + if Token = Tok_EOF then + return Pragmas; + + elsif Token /= Tok_Pragma then + Error_Msg_SC ("only pragmas allowed in configuration file"); + return Error_List; + + else + P_Node := P_Pragma; + + if Errors_Detected > Ecount then + return Error_List; + end if; + + if Chars (P_Node) > Last_Configuration_Pragma_Name + and then Chars (P_Node) /= Name_Source_Reference + then + Error_Msg_SC + ("only configuration pragmas allowed " & + "in configuration file"); + return Error_List; + end if; + + Append (P_Node, Pragmas); + end if; + end loop; + end; + + -- Normal case of compilation unit + + else + Save_Opt_Config_Switches (Save_Config_Switches); + + -- Special processing for language defined units. For this purpose + -- we do NOT consider the renamings in annex J as predefined. That + -- allows users to compile their own versions of these files, and + -- in particular, in the VMS implementation, the DEC versions can + -- be substituted for the standard Ada 95 versions. + + if Is_Predefined_File_Name + (Fname => File_Name (Current_Source_File), + Renamings_Included => False) + then + Set_Opt_Config_Switches + (Is_Internal_File_Name (File_Name (Current_Source_File))); + + -- If this is the main unit, disallow compilation unless the -gnatg + -- (GNAT mode) switch is set (from a user point of view, the rule is + -- that language defined units cannot be recompiled). + + -- However, an exception is s-rpc, and its children. We test this + -- by looking at the character after the minus, the rule is that + -- System.RPC and its children are the only children in System + -- whose second level name can start with the letter r. + + Get_Name_String (File_Name (Current_Source_File)); + + if (Name_Len < 3 or else Name_Buffer (1 .. 3) /= "s-r") + and then Current_Source_Unit = Main_Unit + and then not GNAT_Mode + and then Operating_Mode = Generate_Code + then + Error_Msg_SC ("language defined units may not be recompiled"); + end if; + end if; + + -- The following loop runs more than once only in syntax check mode + -- where we allow multiple compilation units in the same file. + + loop + Set_Opt_Config_Switches + (Is_Internal_File_Name (File_Name (Current_Source_File))); + + -- Initialize scope table and other parser control variables + + Compiler_State := Parsing; + Scope.Init; + Scope.Increment_Last; + Scope.Table (0).Etyp := E_Dummy; + SIS_Entry_Active := False; + Last_Resync_Point := No_Location; + + Label_List := New_Elmt_List; + Unit_Node := P_Compilation_Unit; + + -- If we are not at an end of file, then this means that we are + -- in syntax scan mode, and we can have another compilation unit, + -- otherwise we will exit from the loop. + + exit when Token = Tok_EOF; + Restore_Opt_Config_Switches (Save_Config_Switches); + Set_Comes_From_Source_Default (False); + end loop; + + -- Now that we have completely parsed the source file, we can + -- complete the source file table entry. + + Complete_Source_File_Entry; + + -- An internal error check, the scope stack should now be empty + + pragma Assert (Scope.Last = 0); + + -- Remaining steps are to create implicit label declarations and to + -- load required subsidiary sources. These steps are required only + -- if we are doing semantic checking. + + if Operating_Mode /= Check_Syntax or else Debug_Flag_F then + Par.Labl; + Par.Load; + end if; + + -- Restore settings of switches saved on entry + + Restore_Opt_Config_Switches (Save_Config_Switches); + Set_Comes_From_Source_Default (False); + return Empty_List; + end if; + +end Par; diff --git a/gcc/ada/par.ads b/gcc/ada/par.ads new file mode 100644 index 00000000000..c1110a0b135 --- /dev/null +++ b/gcc/ada/par.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.14 $ -- +-- -- +-- Copyright (C) 1992,1993,1994,1995 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The Par function and its subunits contains all the parsing routines +-- for the top down recursive descent parser that constructs the parse tree + +with Types; use Types; + +function Par (Configuration_Pragmas : Boolean) return List_Id; +-- Top level parsing routine. There are two cases: +-- +-- If Configuration_Pragmas is False, Par parses a compilation unit in the +-- current source file and sets the Cunit, Cunit_Entity and Unit_Name fields +-- of the units table entry for Current_Source_Unit. On return the parse tree +-- is complete, and decorated with any required implicit label declarations. +-- The value returned in this case is always No_List. +-- +-- If Configuration_Pragmas is True, Par parses a list of configuration +-- pragmas from the current source file, and returns the list of pragmas. diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb new file mode 100644 index 00000000000..aa793025f8a --- /dev/null +++ b/gcc/ada/prj-attr.adb @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Namet; use Namet; +with Output; use Output; + +package body Prj.Attr is + + -- Names end with '#' + -- Package names are preceded by 'P' + -- Attribute names are preceded by two capital letters: + -- 'S' for Single or 'L' for list, then + -- 'V' for single variable, 'A' for associative array, or 'B' for both. + -- End is indicated by two consecutive '#'. + + Initialisation_Data : constant String := + + -- project attributes + + "SVobject_dir#" & + "LVsource_dirs#" & + "LVsource_files#" & + "SVsource_list_file#" & + "SVlibrary_dir#" & + "SVlibrary_name#" & + "SVlibrary_kind#" & + "SVlibrary_elaboration#" & + "SVlibrary_version#" & + "LVmain#" & + + -- package Naming + + "Pnaming#" & + "SVspecification_append#" & + "SVbody_append#" & + "SVseparate_append#" & + "SVcasing#" & + "SVdot_replacement#" & + "SAspecification#" & + "SAbody_part#" & + + -- package Compiler + + "Pcompiler#" & + "LBswitches#" & + "SVlocal_configuration_pragmas#" & + + -- package gnatmake + + "Pgnatmake#" & + "LBswitches#" & + "SVglobal_configuration_pragmas#" & + + -- package gnatls + + "Pgnatls#" & + "LVswitches#" & + + -- package gnatbind + + "Pgnatbind#" & + "LBswitches#" & + + -- package gnatlink + + "Pgnatlink#" & + "LBswitches#" & + + "#"; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Start : Positive := Initialisation_Data'First; + Finish : Positive := Start; + Current_Package : Package_Node_Id := Empty_Package; + Current_Attribute : Attribute_Node_Id := Empty_Attribute; + Is_An_Attribute : Boolean := False; + Kind_1 : Variable_Kind := Undefined; + Kind_2 : Attribute_Kind := Single; + Package_Name : Name_Id := No_Name; + Attribute_Name : Name_Id := No_Name; + First_Attribute : Attribute_Node_Id := Attribute_First; + begin + + -- Make sure the two tables are empty + + Attributes.Set_Last (Attributes.First); + Package_Attributes.Set_Last (Package_Attributes.First); + + while Initialisation_Data (Start) /= '#' loop + Is_An_Attribute := True; + case Initialisation_Data (Start) is + when 'P' => + -- New allowed package + Start := Start + 1; + Finish := Start; + while Initialisation_Data (Finish) /= '#' loop + Finish := Finish + 1; + end loop; + Name_Len := Finish - Start; + Name_Buffer (1 .. Name_Len) := + To_Lower (Initialisation_Data (Start .. Finish - 1)); + Package_Name := Name_Find; + for Index in Package_First .. Package_Attributes.Last loop + if Package_Name = Package_Attributes.Table (Index).Name then + Write_Line ("Duplicate package name """ & + Initialisation_Data (Start .. Finish - 1) & + """ in Prj.Attr body."); + raise Program_Error; + end if; + end loop; + + Is_An_Attribute := False; + Current_Attribute := Empty_Attribute; + Package_Attributes.Increment_Last; + Current_Package := Package_Attributes.Last; + Package_Attributes.Table (Current_Package).Name := + Package_Name; + Start := Finish + 1; + when 'S' => + Kind_1 := Single; + when 'L' => + Kind_1 := List; + when others => + raise Program_Error; + end case; + + if Is_An_Attribute then + -- New attribute + Start := Start + 1; + case Initialisation_Data (Start) is + when 'V' => + Kind_2 := Single; + when 'A' => + Kind_2 := Associative_Array; + when 'B' => + Kind_2 := Both; + when others => + raise Program_Error; + end case; + Start := Start + 1; + Finish := Start; + while Initialisation_Data (Finish) /= '#' loop + Finish := Finish + 1; + end loop; + Name_Len := Finish - Start; + Name_Buffer (1 .. Name_Len) := + To_Lower (Initialisation_Data (Start .. Finish - 1)); + Attribute_Name := Name_Find; + Attributes.Increment_Last; + if Current_Attribute = Empty_Attribute then + First_Attribute := Attributes.Last; + if Current_Package /= Empty_Package then + Package_Attributes.Table (Current_Package).First_Attribute + := Attributes.Last; + end if; + else + -- Check that there are no duplicate attributes + for Index in First_Attribute .. Attributes.Last - 1 loop + if Attribute_Name = + Attributes.Table (Index).Name then + Write_Line ("Duplicate attribute name """ & + Initialisation_Data (Start .. Finish - 1) & + """ in Prj.Attr body."); + raise Program_Error; + end if; + end loop; + Attributes.Table (Current_Attribute).Next := + Attributes.Last; + end if; + Current_Attribute := Attributes.Last; + Attributes.Table (Current_Attribute) := + (Name => Attribute_Name, + Kind_1 => Kind_1, + Kind_2 => Kind_2, + Next => Empty_Attribute); + Start := Finish + 1; + end if; + end loop; + end Initialize; + +end Prj.Attr; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads new file mode 100644 index 00000000000..ba4bb2e543b --- /dev/null +++ b/gcc/ada/prj-attr.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This package defines allowed packages and attributes in GNAT project +-- files. + +with Types; use Types; +with Table; + +package Prj.Attr is + + -- Define the allowed attributes + + Attributes_Initial : constant := 50; + Attributes_Increment : constant := 50; + + Attribute_Node_Low_Bound : constant := 0; + Attribute_Node_High_Bound : constant := 099_999_999; + + type Attribute_Node_Id is + range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound; + + First_Attribute_Node_Id : constant Attribute_Node_Id + := Attribute_Node_Low_Bound; + + Empty_Attribute : constant Attribute_Node_Id + := Attribute_Node_Low_Bound; + + type Attribute_Kind is (Single, Associative_Array, Both); + + type Attribute_Record is record + Name : Name_Id; + Kind_1 : Variable_Kind; + Kind_2 : Attribute_Kind; + Next : Attribute_Node_Id; + end record; + + package Attributes is + new Table.Table (Table_Component_Type => Attribute_Record, + Table_Index_Type => Attribute_Node_Id, + Table_Low_Bound => First_Attribute_Node_Id, + Table_Initial => Attributes_Initial, + Table_Increment => Attributes_Increment, + Table_Name => "Prj.Attr.Attributes"); + + Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id + 1; + + -- Define the allowed packages + + Packages_Initial : constant := 10; + Packages_Increment : constant := 10; + + Package_Node_Low_Bound : constant := 0; + Package_Node_High_Bound : constant := 099_999_999; + + type Package_Node_Id is + range Package_Node_Low_Bound .. Package_Node_High_Bound; + + First_Package_Node_Id : constant Package_Node_Id + := Package_Node_Low_Bound; + + Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound; + + type Package_Record is record + Name : Name_Id; + First_Attribute : Attribute_Node_Id; + end record; + + package Package_Attributes is + new Table.Table (Table_Component_Type => Package_Record, + Table_Index_Type => Package_Node_Id, + Table_Low_Bound => First_Package_Node_Id, + Table_Initial => Packages_Initial, + Table_Increment => Packages_Increment, + Table_Name => "Prj.Attr.Packages"); + + Package_First : constant Package_Node_Id := Package_Node_Low_Bound + 1; + + procedure Initialize; + -- Initialize the two tables above (Attributes and Package_Attributes). + -- This procedure should be called by Prj.Initialize. + +end Prj.Attr; diff --git a/gcc/ada/prj-com.adb b/gcc/ada/prj-com.adb new file mode 100644 index 00000000000..3447e18f57c --- /dev/null +++ b/gcc/ada/prj-com.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Stringt; use Stringt; + +package body Prj.Com is + + ---------- + -- Hash -- + ---------- + + function Hash (Name : Name_Id) return Header_Num is + begin + return Hash (Get_Name_String (Name)); + end Hash; + + function Hash (Name : String_Id) return Header_Num is + begin + String_To_Name_Buffer (Name); + return Hash (Name_Buffer (1 .. Name_Len)); + end Hash; + +end Prj.Com; diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads new file mode 100644 index 00000000000..ddb7d0f8ef7 --- /dev/null +++ b/gcc/ada/prj-com.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . C O M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- Copyright (C) 1992-2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The following package declares data types for GNAT project. +-- These data types are used in the bodies of the Prj hierarchy. + +with GNAT.HTable; +with Table; +with Types; use Types; + +package Prj.Com is + + -- At one point, this package was private. + -- It cannot be private, because it is used outside of + -- the Prj hierarchy. + + Tool_Name : Name_Id := No_Name; + + Current_Verbosity : Verbosity := Default; + + type Spec_Or_Body is + (Specification, Body_Part); + + type File_Name_Data is record + Name : Name_Id := No_Name; + Path : Name_Id := No_Name; + Project : Project_Id := No_Project; + Needs_Pragma : Boolean := False; + end record; + -- File and Path name of a spec or body. + + type File_Names_Data is array (Spec_Or_Body) of File_Name_Data; + + type Unit_Id is new Nat; + No_Unit : constant Unit_Id := 0; + type Unit_Data is record + Name : Name_Id := No_Name; + File_Names : File_Names_Data; + end record; + -- File and Path names of a unit, with a reference to its + -- GNAT Project File. + + package Units is new Table.Table + (Table_Component_Type => Unit_Data, + Table_Index_Type => Unit_Id, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Prj.Com.Units"); + + type Header_Num is range 0 .. 2047; + + function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); + + function Hash (Name : Name_Id) return Header_Num; + + function Hash (Name : String_Id) return Header_Num; + + package Units_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Unit_Id, + No_Element => No_Unit, + Key => Name_Id, + Hash => Hash, + Equal => "="); + +end Prj.Com; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb new file mode 100644 index 00000000000..65f7e43a4b6 --- /dev/null +++ b/gcc/ada/prj-dect.adb @@ -0,0 +1,942 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . D E C T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Errout; use Errout; +with Prj.Strt; +with Prj.Tree; use Prj.Tree; +with Scans; use Scans; +with Sinfo; use Sinfo; +with Types; use Types; +with Prj.Attr; use Prj.Attr; + +package body Prj.Dect is + + type Zone is (In_Project, In_Package, In_Case_Construction); + + procedure Parse_Attribute_Declaration + (Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse an attribute declaration. + + procedure Parse_Case_Construction + (Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse a case construction + + procedure Parse_Declarative_Items + (Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse declarative items. Depending on In_Zone, some declarative + -- items may be forbiden. + + procedure Parse_Package_Declaration + (Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id); + -- Parse a package declaration + + procedure Parse_String_Type_Declaration + (String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id; + First_Attribute : Attribute_Node_Id); + -- type <name> is ( <literal_string> { , <literal_string> } ) ; + + procedure Parse_Variable_Declaration + (Variable : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse a variable assignment + -- <variable_Name> := <expression>; OR + -- <variable_Name> : <string_type_Name> := <string_expression>; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (Declarations : out Project_Node_Id; + Current_Project : Project_Node_Id; + Modifying : Project_Node_Id) + is + First_Declarative_Item : Project_Node_Id := Empty_Node; + + begin + Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration); + Set_Location_Of (Declarations, To => Token_Ptr); + Set_Modified_Project_Of (Declarations, To => Modifying); + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Zone => In_Project, + First_Attribute => Prj.Attr.Attribute_First, + Current_Project => Current_Project, + Current_Package => Empty_Node); + Set_First_Declarative_Item_Of + (Declarations, To => First_Declarative_Item); + end Parse; + + --------------------------------- + -- Parse_Attribute_Declaration -- + --------------------------------- + + procedure Parse_Attribute_Declaration + (Attribute : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Current_Attribute : Attribute_Node_Id := First_Attribute; + + begin + Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration); + Set_Location_Of (Attribute, To => Token_Ptr); + + -- Scan past "for" + + Scan; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Attribute, To => Token_Name); + Set_Location_Of (Attribute, To => Token_Ptr); + while Current_Attribute /= Empty_Attribute + and then + Attributes.Table (Current_Attribute).Name /= Token_Name + loop + Current_Attribute := Attributes.Table (Current_Attribute).Next; + end loop; + + if Current_Attribute = Empty_Attribute then + Error_Msg ("undefined attribute", Token_Ptr); + end if; + + Scan; + end if; + + if Token = Tok_Left_Paren then + if Current_Attribute /= Empty_Attribute + and then Attributes.Table (Current_Attribute).Kind_2 = Single + then + Error_Msg ("this attribute cannot be an associative array", + Location_Of (Attribute)); + end if; + + Scan; + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node)); + Scan; + end if; + + Expect (Tok_Right_Paren, ")"); + + if Token = Tok_Right_Paren then + Scan; + end if; + + else + if Current_Attribute /= Empty_Attribute + and then + Attributes.Table (Current_Attribute).Kind_2 = Associative_Array + then + Error_Msg ("this attribute need to be an associative array", + Location_Of (Attribute)); + end if; + end if; + + if Current_Attribute /= Empty_Attribute then + Set_Expression_Kind_Of + (Attribute, To => Attributes.Table (Current_Attribute).Kind_1); + end if; + + Expect (Tok_Use, "use"); + + if Token = Tok_Use then + Scan; + + declare + Expression_Location : constant Source_Ptr := Token_Ptr; + Expression : Project_Node_Id := Empty_Node; + + begin + Prj.Strt.Parse_Expression + (Expression => Expression, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Expression_Of (Attribute, To => Expression); + + if Current_Attribute /= Empty_Attribute + and then Expression /= Empty_Node + and then Attributes.Table (Current_Attribute).Kind_1 /= + Expression_Kind_Of (Expression) + then + Error_Msg + ("wrong expression kind for the attribute", + Expression_Location); + end if; + end; + end if; + + end Parse_Attribute_Declaration; + + ----------------------------- + -- Parse_Case_Construction -- + ----------------------------- + + procedure Parse_Case_Construction + (Case_Construction : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Current_Item : Project_Node_Id := Empty_Node; + Next_Item : Project_Node_Id := Empty_Node; + First_Case_Item : Boolean := True; + + Variable_Location : Source_Ptr := No_Location; + + String_Type : Project_Node_Id := Empty_Node; + + Case_Variable : Project_Node_Id := Empty_Node; + + First_Declarative_Item : Project_Node_Id := Empty_Node; + + First_Choice : Project_Node_Id := Empty_Node; + + begin + Case_Construction := + Default_Project_Node (Of_Kind => N_Case_Construction); + Set_Location_Of (Case_Construction, To => Token_Ptr); + + -- Scan past "case" + + Scan; + + -- Get the switch variable + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Variable_Location := Token_Ptr; + Prj.Strt.Parse_Variable_Reference + (Variable => Case_Variable, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Case_Variable_Reference_Of + (Case_Construction, To => Case_Variable); + + else + if Token /= Tok_Is then + Scan; + end if; + end if; + + if Case_Variable /= Empty_Node then + String_Type := String_Type_Of (Case_Variable); + + if String_Type = Empty_Node then + Error_Msg ("this variable is not typed", Variable_Location); + end if; + end if; + + Expect (Tok_Is, "is"); + + if Token = Tok_Is then + + -- Scan past "is" + + Scan; + end if; + + Prj.Strt.Start_New_Case_Construction (String_Type); + + When_Loop : + + while Token = Tok_When loop + + if First_Case_Item then + Current_Item := Default_Project_Node (Of_Kind => N_Case_Item); + Set_First_Case_Item_Of (Case_Construction, To => Current_Item); + First_Case_Item := False; + + else + Next_Item := Default_Project_Node (Of_Kind => N_Case_Item); + Set_Next_Case_Item (Current_Item, To => Next_Item); + Current_Item := Next_Item; + end if; + + Set_Location_Of (Current_Item, To => Token_Ptr); + + -- Scan past "when" + + Scan; + + if Token = Tok_Others then + + -- Scan past "others" + + Scan; + + Expect (Tok_Arrow, "=>"); + + -- Empty_Node in Field1 of a Case_Item indicates + -- the "when others =>" branch. + + Set_First_Choice_Of (Current_Item, To => Empty_Node); + + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package); + + -- "when others =>" must be the last branch, so save the + -- Case_Item and exit + + Set_First_Declarative_Item_Of + (Current_Item, To => First_Declarative_Item); + exit When_Loop; + + else + Prj.Strt.Parse_Choice_List (First_Choice => First_Choice); + Set_First_Choice_Of (Current_Item, To => First_Choice); + + Expect (Tok_Arrow, "=>"); + + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Zone => In_Case_Construction, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package); + + Set_First_Declarative_Item_Of + (Current_Item, To => First_Declarative_Item); + + end if; + end loop When_Loop; + + Prj.Strt.End_Case_Construction; + + Expect (Tok_End, "end case"); + + if Token = Tok_End then + + -- Scan past "end" + + Scan; + + Expect (Tok_Case, "case"); + + end if; + + -- Scan past "case" + + Scan; + + Expect (Tok_Semicolon, ";"); + + end Parse_Case_Construction; + + ----------------------------- + -- Parse_Declarative_Items -- + ----------------------------- + + procedure Parse_Declarative_Items + (Declarations : out Project_Node_Id; + In_Zone : Zone; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Current_Declarative_Item : Project_Node_Id := Empty_Node; + Next_Declarative_Item : Project_Node_Id := Empty_Node; + Current_Declaration : Project_Node_Id := Empty_Node; + Item_Location : Source_Ptr := No_Location; + + begin + Declarations := Empty_Node; + + loop + -- We are always positioned at the token that precedes + -- the first token of the declarative element. + -- Scan past it + + Scan; + + Item_Location := Token_Ptr; + + case Token is + when Tok_Identifier => + + if In_Zone = In_Case_Construction then + Error_Msg ("a variable cannot be declared here", + Token_Ptr); + end if; + + Parse_Variable_Declaration + (Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package); + + when Tok_For => + + Parse_Attribute_Declaration + (Attribute => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package); + + when Tok_Package => + + -- Package declaration + + if In_Zone /= In_Project then + Error_Msg ("a package cannot be declared here", Token_Ptr); + end if; + + Parse_Package_Declaration + (Package_Declaration => Current_Declaration, + Current_Project => Current_Project); + + when Tok_Type => + + -- Type String Declaration + + if In_Zone /= In_Project then + Error_Msg ("a string type cannot be declared here", + Token_Ptr); + end if; + + Parse_String_Type_Declaration + (String_Type => Current_Declaration, + Current_Project => Current_Project, + First_Attribute => First_Attribute); + + when Tok_Case => + + -- Case construction + + Parse_Case_Construction + (Case_Construction => Current_Declaration, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Current_Package); + + when others => + exit; + + -- We are leaving Parse_Declarative_Items positionned + -- at the first token after the list of declarative items. + -- It could be "end" (for a project, a package declaration or + -- a case construction) or "when" (for a case construction) + + end case; + + Expect (Tok_Semicolon, "; after declarative items"); + + if Current_Declarative_Item = Empty_Node then + Current_Declarative_Item := + Default_Project_Node (Of_Kind => N_Declarative_Item); + Declarations := Current_Declarative_Item; + + else + Next_Declarative_Item := + Default_Project_Node (Of_Kind => N_Declarative_Item); + Set_Next_Declarative_Item + (Current_Declarative_Item, To => Next_Declarative_Item); + Current_Declarative_Item := Next_Declarative_Item; + end if; + + Set_Current_Item_Node + (Current_Declarative_Item, To => Current_Declaration); + Set_Location_Of (Current_Declarative_Item, To => Item_Location); + + end loop; + + end Parse_Declarative_Items; + + ------------------------------- + -- Parse_Package_Declaration -- + ------------------------------- + + procedure Parse_Package_Declaration + (Package_Declaration : out Project_Node_Id; + Current_Project : Project_Node_Id) + is + First_Attribute : Attribute_Node_Id := Empty_Attribute; + Current_Package : Package_Node_Id := Empty_Package; + First_Declarative_Item : Project_Node_Id := Empty_Node; + + begin + Package_Declaration := + Default_Project_Node (Of_Kind => N_Package_Declaration); + Set_Location_Of (Package_Declaration, To => Token_Ptr); + + -- Scan past "package" + + Scan; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + + Set_Name_Of (Package_Declaration, To => Token_Name); + + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Token_Name = Package_Attributes.Table (Index).Name then + First_Attribute := + Package_Attributes.Table (Index).First_Attribute; + Current_Package := Index; + exit; + end if; + end loop; + + if Current_Package = Empty_Package then + Error_Msg ("not an allowed package name", Token_Ptr); + + else + Set_Package_Id_Of (Package_Declaration, To => Current_Package); + + declare + Current : Project_Node_Id := First_Package_Of (Current_Project); + + begin + while Current /= Empty_Node + and then Name_Of (Current) /= Token_Name + loop + Current := Next_Package_In_Project (Current); + end loop; + + if Current /= Empty_Node then + Error_Msg + ("package declared twice in the same project", Token_Ptr); + + else + -- Add the package to the project list + + Set_Next_Package_In_Project + (Package_Declaration, + To => First_Package_Of (Current_Project)); + Set_First_Package_Of + (Current_Project, To => Package_Declaration); + end if; + end; + end if; + + -- Scan past the package name + + Scan; + + end if; + + if Token = Tok_Renames then + -- Scan past "renames" + Scan; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + declare + Project_Name : Name_Id := Token_Name; + Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project); + The_Project : Project_Node_Id := Empty_Node; + + begin + while Clause /= Empty_Node loop + The_Project := Project_Node_Of (Clause); + exit when Name_Of (The_Project) = Project_Name; + Clause := Next_With_Clause_Of (Clause); + end loop; + + if Clause = Empty_Node then + Error_Msg ("not an imported project", Token_Ptr); + else + Set_Project_Of_Renamed_Package_Of + (Package_Declaration, To => The_Project); + end if; + end; + + Scan; + Expect (Tok_Dot, "."); + + if Token = Tok_Dot then + Scan; + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + if Name_Of (Package_Declaration) /= Token_Name then + Error_Msg ("not the same package name", Token_Ptr); + elsif + Project_Of_Renamed_Package_Of (Package_Declaration) + /= Empty_Node + then + declare + Current : Project_Node_Id := + First_Package_Of + (Project_Of_Renamed_Package_Of + (Package_Declaration)); + + begin + while Current /= Empty_Node + and then Name_Of (Current) /= Token_Name + loop + Current := Next_Package_In_Project (Current); + end loop; + + if Current = Empty_Node then + Error_Msg + ("not a package declared by the project", + Token_Ptr); + end if; + end; + end if; + + Scan; + end if; + end if; + end if; + + Expect (Tok_Semicolon, ";"); + + elsif Token = Tok_Is then + + Parse_Declarative_Items + (Declarations => First_Declarative_Item, + In_Zone => In_Package, + First_Attribute => First_Attribute, + Current_Project => Current_Project, + Current_Package => Package_Declaration); + + Set_First_Declarative_Item_Of + (Package_Declaration, To => First_Declarative_Item); + + Expect (Tok_End, "end"); + + if Token = Tok_End then + + -- Scan past "end" + + Scan; + end if; + + -- We should have the name of the package after "end" + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier + and then Name_Of (Package_Declaration) /= No_Name + and then Token_Name /= Name_Of (Package_Declaration) + then + Error_Msg_Name_1 := Name_Of (Package_Declaration); + Error_Msg ("expected {", Token_Ptr); + end if; + + if Token /= Tok_Semicolon then + + -- Scan past the package name + + Scan; + end if; + + Expect (Tok_Semicolon, ";"); + + else + Error_Msg ("expected ""is"" or ""renames""", Token_Ptr); + end if; + + end Parse_Package_Declaration; + + ----------------------------------- + -- Parse_String_Type_Declaration -- + ----------------------------------- + + procedure Parse_String_Type_Declaration + (String_Type : out Project_Node_Id; + Current_Project : Project_Node_Id; + First_Attribute : Attribute_Node_Id) + is + Current : Project_Node_Id := Empty_Node; + First_String : Project_Node_Id := Empty_Node; + + begin + String_Type := + Default_Project_Node (Of_Kind => N_String_Type_Declaration); + + Set_Location_Of (String_Type, To => Token_Ptr); + + -- Scan past "type" + + Scan; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (String_Type, To => Token_Name); + + Current := First_String_Type_Of (Current_Project); + while Current /= Empty_Node + and then + Name_Of (Current) /= Token_Name + loop + Current := Next_String_Type (Current); + end loop; + + if Current /= Empty_Node then + Error_Msg ("duplicate string type name", Token_Ptr); + else + Current := First_Variable_Of (Current_Project); + while Current /= Empty_Node + and then Name_Of (Current) /= Token_Name + loop + Current := Next_Variable (Current); + end loop; + + if Current /= Empty_Node then + Error_Msg ("already a variable name", Token_Ptr); + else + Set_Next_String_Type + (String_Type, To => First_String_Type_Of (Current_Project)); + Set_First_String_Type_Of (Current_Project, To => String_Type); + end if; + end if; + + -- Scan past the name + + Scan; + end if; + + Expect (Tok_Is, "is"); + + if Token = Tok_Is then + Scan; + end if; + + Expect (Tok_Left_Paren, "("); + + if Token = Tok_Left_Paren then + Scan; + end if; + + Prj.Strt.Parse_String_Type_List (First_String => First_String); + Set_First_Literal_String (String_Type, To => First_String); + + Expect (Tok_Right_Paren, ")"); + + if Token = Tok_Right_Paren then + Scan; + end if; + + end Parse_String_Type_Declaration; + + -------------------------------- + -- Parse_Variable_Declaration -- + -------------------------------- + + procedure Parse_Variable_Declaration + (Variable : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Expression_Location : Source_Ptr; + String_Type_Name : Name_Id := No_Name; + Project_String_Type_Name : Name_Id := No_Name; + Type_Location : Source_Ptr := No_Location; + Project_Location : Source_Ptr := No_Location; + Expression : Project_Node_Id := Empty_Node; + Variable_Name : constant Name_Id := Token_Name; + + begin + Variable := + Default_Project_Node (Of_Kind => N_Variable_Declaration); + Set_Name_Of (Variable, To => Variable_Name); + Set_Location_Of (Variable, To => Token_Ptr); + + -- Scan past the variable name + + Scan; + + if Token = Tok_Colon then + + -- Typed string variable declaration + + Scan; + Set_Kind_Of (Variable, N_Typed_Variable_Declaration); + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan; + + if Token = Tok_Dot then + Project_String_Type_Name := String_Type_Name; + Project_Location := Type_Location; + + -- Scan past the dot + + Scan; + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + String_Type_Name := Token_Name; + Type_Location := Token_Ptr; + Scan; + else + String_Type_Name := No_Name; + end if; + end if; + + if String_Type_Name /= No_Name then + declare + Current : Project_Node_Id := + First_String_Type_Of (Current_Project); + + begin + if Project_String_Type_Name /= No_Name then + declare + The_Project_Name_And_Node : constant + Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get + (Project_String_Type_Name); + + use Tree_Private_Part; + + begin + if The_Project_Name_And_Node = + Tree_Private_Part.No_Project_Name_And_Node + then + Error_Msg ("unknown project", Project_Location); + Current := Empty_Node; + else + Current := + First_String_Type_Of + (The_Project_Name_And_Node.Node); + end if; + end; + end if; + + while Current /= Empty_Node + and then Name_Of (Current) /= String_Type_Name + loop + Current := Next_String_Type (Current); + end loop; + + if Current = Empty_Node then + Error_Msg ("unknown string type", Type_Location); + else + Set_String_Type_Of + (Variable, To => Current); + end if; + end; + end if; + end if; + end if; + + Expect (Tok_Colon_Equal, ":="); + + if Token = Tok_Colon_Equal then + Scan; + end if; + + -- Get the single string or string list value + + Expression_Location := Token_Ptr; + + Prj.Strt.Parse_Expression + (Expression => Expression, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Expression_Of (Variable, To => Expression); + + if Expression /= Empty_Node then + Set_Expression_Kind_Of + (Variable, To => Expression_Kind_Of (Expression)); + end if; + + declare + The_Variable : Project_Node_Id := Empty_Node; + + begin + if Current_Package /= Empty_Node then + The_Variable := First_Variable_Of (Current_Package); + elsif Current_Project /= Empty_Node then + The_Variable := First_Variable_Of (Current_Project); + end if; + + while The_Variable /= Empty_Node + and then Name_Of (The_Variable) /= Variable_Name + loop + The_Variable := Next_Variable (The_Variable); + end loop; + + if The_Variable = Empty_Node then + if Current_Package /= Empty_Node then + Set_Next_Variable + (Variable, To => First_Variable_Of (Current_Package)); + Set_First_Variable_Of (Current_Package, To => Variable); + + elsif Current_Project /= Empty_Node then + Set_Next_Variable + (Variable, To => First_Variable_Of (Current_Project)); + Set_First_Variable_Of (Current_Project, To => Variable); + end if; + + else + if Expression_Kind_Of (Variable) /= Undefined then + if Expression_Kind_Of (The_Variable) = Undefined then + Set_Expression_Kind_Of + (The_Variable, To => Expression_Kind_Of (Variable)); + + else + if Expression_Kind_Of (The_Variable) /= + Expression_Kind_Of (Variable) + then + Error_Msg ("wrong expression kind for the variable", + Expression_Location); + end if; + end if; + end if; + end if; + end; + + end Parse_Variable_Declaration; + +end Prj.Dect; diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads new file mode 100644 index 00000000000..3072c573b62 --- /dev/null +++ b/gcc/ada/prj-dect.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . D E C T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- Parse a list of declarative items in a project file. + +with Prj.Tree; + +private package Prj.Dect is + + procedure Parse + (Declarations : out Prj.Tree.Project_Node_Id; + Current_Project : Prj.Tree.Project_Node_Id; + Modifying : Prj.Tree.Project_Node_Id); + -- Parse project declarative items. + +end Prj.Dect; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb new file mode 100644 index 00000000000..171a2d03c1a --- /dev/null +++ b/gcc/ada/prj-env.adb @@ -0,0 +1,1471 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E N V -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Util; +with Snames; use Snames; +with Stringt; use Stringt; +with Table; + +package body Prj.Env is + + type Naming_Id is new Nat; + No_Naming : constant Naming_Id := 0; + + Ada_Path_Buffer : String_Access := new String (1 .. 1_000); + -- A buffer where values for ADA_INCLUDE_PATH + -- and ADA_OBJECTS_PATH are stored. + + Ada_Path_Length : Natural := 0; + -- Index of the last valid character in Ada_Path_Buffer. + + package Namings is new Table.Table ( + Table_Component_Type => Naming_Data, + Table_Index_Type => Naming_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 100, + Table_Name => "Prj.Env.Namings"); + + Default_Naming : constant Naming_Id := Namings.First; + + Global_Configuration_Pragmas : Name_Id; + Local_Configuration_Pragmas : Name_Id; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Body_Path_Name_Of (Unit : Unit_Id) return String; + -- Returns the path name of the body of a unit. + -- Compute it first, if necessary. + + function Spec_Path_Name_Of (Unit : Unit_Id) return String; + -- Returns the path name of the spec of a unit. + -- Compute it first, if necessary. + + procedure Add_To_Path (Path : String); + -- Add Path to global variable Ada_Path_Buffer + -- Increment Ada_Path_Length + + ---------------------- + -- Ada_Include_Path -- + ---------------------- + + function Ada_Include_Path (Project : Project_Id) return String_Access is + + procedure Add (Project : Project_Id); + -- Add all the source directories of a project to the path, + -- only if this project has not been visited. + -- Call itself recursively for projects being modified, + -- and imported projects. + -- Add the project to the list Seen if this is the first time + -- we call Add for this project. + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id) is + begin + -- If Seen is empty, then the project cannot have been + -- visited. + + if not Projects.Table (Project).Seen then + Projects.Table (Project).Seen := True; + + declare + Data : Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + Current : String_List_Id := Data.Source_Dirs; + Source_Dir : String_Element; + + begin + -- Add to path all source directories of this project + + while Current /= Nil_String loop + if Ada_Path_Length > 0 then + Add_To_Path (Path => (1 => Path_Separator)); + end if; + + Source_Dir := String_Elements.Table (Current); + String_To_Name_Buffer (Source_Dir.Value); + + declare + New_Path : constant String := + Name_Buffer (1 .. Name_Len); + begin + Add_To_Path (New_Path); + end; + + Current := Source_Dir.Next; + end loop; + + -- Call Add to the project being modified, if any + + if Data.Modifies /= No_Project then + Add (Data.Modifies); + end if; + + -- Call Add for each imported project, if any + + while List /= Empty_Project_List loop + Add (Project_Lists.Table (List).Project); + List := Project_Lists.Table (List).Next; + end loop; + end; + end if; + + end Add; + + -- Start of processing for Ada_Include_Path + + begin + -- If it is the first time we call this function for + -- this project, compute the source path + + if Projects.Table (Project).Include_Path = null then + Ada_Path_Length := 0; + + for Index in 1 .. Projects.Last loop + Projects.Table (Index).Seen := False; + end loop; + + Add (Project); + Projects.Table (Project).Include_Path := + new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); + end if; + + return Projects.Table (Project).Include_Path; + end Ada_Include_Path; + + ---------------------- + -- Ada_Objects_Path -- + ---------------------- + + function Ada_Objects_Path + (Project : Project_Id; + Including_Libraries : Boolean := True) + return String_Access is + + procedure Add (Project : Project_Id); + -- Add all the object directory of a project to the path, + -- only if this project has not been visited. + -- Call itself recursively for projects being modified, + -- and imported projects. + -- Add the project to the list Seen if this is the first time + -- we call Add for this project. + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id) is + begin + + -- If this project has not been seen yet + + if not Projects.Table (Project).Seen then + Projects.Table (Project).Seen := True; + + declare + Data : Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + begin + -- Add to path the object directory of this project + -- except if we don't include library project and + -- this is a library project. + + if (Data.Library and then Including_Libraries) + or else + (Data.Object_Directory /= No_Name + and then + (not Including_Libraries or else not Data.Library)) + then + if Ada_Path_Length > 0 then + Add_To_Path (Path => (1 => Path_Separator)); + end if; + + -- For a library project, att the library directory + + if Data.Library then + declare + New_Path : constant String := + Get_Name_String (Data.Library_Dir); + begin + Add_To_Path (New_Path); + end; + else + + -- For a non library project, add the object directory + declare + New_Path : constant String := + Get_Name_String (Data.Object_Directory); + begin + Add_To_Path (New_Path); + end; + end if; + end if; + + -- Call Add to the project being modified, if any + + if Data.Modifies /= No_Project then + Add (Data.Modifies); + end if; + + -- Call Add for each imported project, if any + + while List /= Empty_Project_List loop + Add (Project_Lists.Table (List).Project); + List := Project_Lists.Table (List).Next; + end loop; + end; + + end if; + end Add; + + -- Start of processing for Ada_Objects_Path + + begin + -- If it is the first time we call this function for + -- this project, compute the objects path + + if Projects.Table (Project).Objects_Path = null then + Ada_Path_Length := 0; + + for Index in 1 .. Projects.Last loop + Projects.Table (Index).Seen := False; + end loop; + + Add (Project); + Projects.Table (Project).Objects_Path := + new String'(Ada_Path_Buffer (1 .. Ada_Path_Length)); + end if; + + return Projects.Table (Project).Objects_Path; + end Ada_Objects_Path; + + ----------------- + -- Add_To_Path -- + ----------------- + + procedure Add_To_Path (Path : String) is + begin + -- If Ada_Path_Buffer is too small, double it + + if Ada_Path_Length + Path'Length > Ada_Path_Buffer'Last then + declare + New_Ada_Path_Buffer : constant String_Access := + new String + (1 .. Ada_Path_Buffer'Last + + Ada_Path_Buffer'Last); + + begin + New_Ada_Path_Buffer (1 .. Ada_Path_Length) := + Ada_Path_Buffer (1 .. Ada_Path_Length); + Ada_Path_Buffer := New_Ada_Path_Buffer; + end; + end if; + + Ada_Path_Buffer + (Ada_Path_Length + 1 .. Ada_Path_Length + Path'Length) := Path; + Ada_Path_Length := Ada_Path_Length + Path'Length; + end Add_To_Path; + + ----------------------- + -- Body_Path_Name_Of -- + ----------------------- + + function Body_Path_Name_Of (Unit : Unit_Id) return String is + Data : Unit_Data := Units.Table (Unit); + + begin + -- If we don't know the path name of the body of this unit, + -- we compute it, and we store it. + + if Data.File_Names (Body_Part).Path = No_Name then + declare + Current_Source : String_List_Id := + Projects.Table (Data.File_Names (Body_Part).Project).Sources; + Path : GNAT.OS_Lib.String_Access; + + begin + -- By default, put the file name + + Data.File_Names (Body_Part).Path := + Data.File_Names (Body_Part).Name; + + -- For each source directory + + while Current_Source /= Nil_String loop + String_To_Name_Buffer + (String_Elements.Table (Current_Source).Value); + Path := + Locate_Regular_File + (Namet.Get_Name_String + (Data.File_Names (Body_Part).Name), + Name_Buffer (1 .. Name_Len)); + + -- If the file is in this directory, + -- then we store the path, and we are done. + + if Path /= null then + Name_Len := Path'Length; + Name_Buffer (1 .. Name_Len) := Path.all; + Data.File_Names (Body_Part).Path := Name_Enter; + exit; + + else + Current_Source := + String_Elements.Table (Current_Source).Next; + end if; + end loop; + + Units.Table (Unit) := Data; + end; + end if; + + -- Returned the value stored + + return Namet.Get_Name_String (Data.File_Names (Body_Part).Path); + end Body_Path_Name_Of; + + -------------------------------- + -- Create_Config_Pragmas_File -- + -------------------------------- + + procedure Create_Config_Pragmas_File + (For_Project : Project_Id; + Main_Project : Project_Id) + is + File_Name : Temp_File_Name; + File : File_Descriptor := Invalid_FD; + + The_Packages : Package_Id; + Gnatmake : Prj.Package_Id; + Compiler : Prj.Package_Id; + + Current_Unit : Unit_Id := Units.First; + + First_Project : Project_List := Empty_Project_List; + + Current_Project : Project_List; + Current_Naming : Naming_Id; + + Global_Attribute : Variable_Value := Nil_Variable_Value; + Local_Attribute : Variable_Value := Nil_Variable_Value; + + Global_Attribute_Present : Boolean := False; + Local_Attribute_Present : Boolean := False; + + procedure Check (Project : Project_Id); + + procedure Check_Temp_File; + -- Check that a temporary file has been opened. + -- If not, create one, and put its name in the project data, + -- with the indication that it is a temporary file. + + procedure Copy_File (Name : String_Id); + -- Copy a configuration pragmas file into the temp file. + + procedure Put + (Unit_Name : Name_Id; + File_Name : Name_Id; + Unit_Kind : Spec_Or_Body); + -- Put an SFN pragma in the temporary file. + + procedure Put (File : File_Descriptor; S : String); + + procedure Put_Line (File : File_Descriptor; S : String); + + ----------- + -- Check -- + ----------- + + procedure Check (Project : Project_Id) is + Data : constant Project_Data := Projects.Table (Project); + + begin + if Current_Verbosity = High then + Write_Str ("Checking project file """); + Write_Str (Namet.Get_Name_String (Data.Name)); + Write_Str ("""."); + Write_Eol; + end if; + + -- Is this project in the list of the visited project? + + Current_Project := First_Project; + while Current_Project /= Empty_Project_List + and then Project_Lists.Table (Current_Project).Project /= Project + loop + Current_Project := Project_Lists.Table (Current_Project).Next; + end loop; + + -- If it is not, put it in the list, and visit it + + if Current_Project = Empty_Project_List then + Project_Lists.Increment_Last; + Project_Lists.Table (Project_Lists.Last) := + (Project => Project, Next => First_Project); + First_Project := Project_Lists.Last; + + -- Is the naming scheme of this project one that we know? + + Current_Naming := Default_Naming; + while Current_Naming <= Namings.Last and then + not Same_Naming_Scheme + (Left => Namings.Table (Current_Naming), + Right => Data.Naming) loop + Current_Naming := Current_Naming + 1; + end loop; + + -- If we don't know it, add it + + if Current_Naming > Namings.Last then + Namings.Increment_Last; + Namings.Table (Namings.Last) := Data.Naming; + + -- We need a temporary file to be created + + Check_Temp_File; + + -- Put the SFN pragmas for the naming scheme + + -- Spec + + Put_Line + (File, "pragma Source_File_Name"); + Put_Line + (File, " (Spec_File_Name => ""*" & + Namet.Get_Name_String (Data.Naming.Specification_Append) & + ""","); + Put_Line + (File, " Casing => " & + Image (Data.Naming.Casing) & ","); + Put_Line + (File, " Dot_Replacement => """ & + Namet.Get_Name_String (Data.Naming.Dot_Replacement) & + """);"); + + -- and body + + Put_Line + (File, "pragma Source_File_Name"); + Put_Line + (File, " (Body_File_Name => ""*" & + Namet.Get_Name_String (Data.Naming.Body_Append) & + ""","); + Put_Line + (File, " Casing => " & + Image (Data.Naming.Casing) & ","); + Put_Line + (File, " Dot_Replacement => """ & + Namet.Get_Name_String (Data.Naming.Dot_Replacement) & + """);"); + + -- and maybe separate + + if Data.Naming.Body_Append /= Data.Naming.Separate_Append then + Put_Line + (File, "pragma Source_File_Name"); + Put_Line + (File, " (Subunit_File_Name => ""*" & + Namet.Get_Name_String (Data.Naming.Separate_Append) & + ""","); + Put_Line + (File, " Casing => " & + Image (Data.Naming.Casing) & + ","); + Put_Line + (File, " Dot_Replacement => """ & + Namet.Get_Name_String (Data.Naming.Dot_Replacement) & + """);"); + end if; + end if; + + if Data.Modifies /= No_Project then + Check (Data.Modifies); + end if; + + declare + Current : Project_List := Data.Imported_Projects; + + begin + while Current /= Empty_Project_List loop + Check (Project_Lists.Table (Current).Project); + Current := Project_Lists.Table (Current).Next; + end loop; + end; + end if; + end Check; + + --------------------- + -- Check_Temp_File -- + --------------------- + + procedure Check_Temp_File is + begin + if File = Invalid_FD then + GNAT.OS_Lib.Create_Temp_File (File, Name => File_Name); + if File = Invalid_FD then + Osint.Fail + ("unable to create temporary configuration pragmas file"); + elsif Opt.Verbose_Mode then + Write_Str ("Creating temp file """); + Write_Str (File_Name); + Write_Line (""""); + end if; + end if; + end Check_Temp_File; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File (Name : in String_Id) is + Input : File_Descriptor; + Buffer : String (1 .. 1_000); + Input_Length : Integer; + Output_Length : Integer; + + begin + Check_Temp_File; + String_To_Name_Buffer (Name); + + if Opt.Verbose_Mode then + Write_Str ("Copying config pragmas file """); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Line (""" into temp file"); + end if; + + declare + Name : constant String := + Name_Buffer (1 .. Name_Len) & ASCII.NUL; + begin + Input := Open_Read (Name'Address, Binary); + end; + + if Input = Invalid_FD then + Osint.Fail + ("cannot open configuration pragmas file " & + Name_Buffer (1 .. Name_Len)); + end if; + + loop + Input_Length := Read (Input, Buffer'Address, Buffer'Length); + Output_Length := Write (File, Buffer'Address, Input_Length); + + if Output_Length /= Input_Length then + Osint.Fail ("disk full"); + end if; + + exit when Input_Length < Buffer'Length; + end loop; + + Close (Input); + + end Copy_File; + + --------- + -- Put -- + --------- + + procedure Put + (Unit_Name : Name_Id; + File_Name : Name_Id; + Unit_Kind : Spec_Or_Body) + is + begin + -- A temporary file needs to be open + + Check_Temp_File; + + -- Put the pragma SFN for the unit kind (spec or body) + + Put (File, "pragma Source_File_Name ("); + Put (File, Namet.Get_Name_String (Unit_Name)); + + if Unit_Kind = Specification then + Put (File, ", Spec_File_Name => """); + else + Put (File, ", Body_File_Name => """); + end if; + + Put (File, Namet.Get_Name_String (File_Name)); + Put_Line (File, """);"); + end Put; + + procedure Put (File : File_Descriptor; S : String) is + Last : Natural; + + begin + Last := Write (File, S (S'First)'Address, S'Length); + + if Last /= S'Length then + Osint.Fail ("Disk full"); + end if; + + if Current_Verbosity = High then + Write_Str (S); + end if; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (File : File_Descriptor; S : String) is + S0 : String (1 .. S'Length + 1); + Last : Natural; + + begin + -- Add an ASCII.LF to the string. As this gnat.adc + -- is supposed to be used only by the compiler, we don't + -- care about the characters for the end of line. + -- The truth is we could have put a space, but it is + -- more convenient to be able to read gnat.adc during + -- development. And the development was done under UNIX. + -- Hence the ASCII.LF. + + S0 (1 .. S'Length) := S; + S0 (S0'Last) := ASCII.LF; + Last := Write (File, S0'Address, S0'Length); + + if Last /= S'Length + 1 then + Osint.Fail ("Disk full"); + end if; + + if Current_Verbosity = High then + Write_Line (S); + end if; + end Put_Line; + + -- Start of processing for Create_Config_Pragmas_File + + begin + + if not Projects.Table (For_Project).Config_Checked then + + -- Remove any memory of processed naming schemes, if any + + Namings.Set_Last (Default_Naming); + + -- Check the naming schemes + + Check (For_Project); + + -- Visit all the units and process those that need an SFN pragma + + while Current_Unit <= Units.Last loop + declare + Unit : constant Unit_Data := + Units.Table (Current_Unit); + + begin + if Unit.File_Names (Specification).Needs_Pragma then + Put (Unit.Name, + Unit.File_Names (Specification).Name, + Specification); + end if; + + if Unit.File_Names (Body_Part).Needs_Pragma then + Put (Unit.Name, + Unit.File_Names (Body_Part).Name, + Body_Part); + end if; + + Current_Unit := Current_Unit + 1; + end; + end loop; + + The_Packages := Projects.Table (Main_Project).Decl.Packages; + Gnatmake := + Prj.Util.Value_Of + (Name => Name_Gnatmake, + In_Packages => The_Packages); + + if Gnatmake /= No_Package then + Global_Attribute := Prj.Util.Value_Of + (Variable_Name => Global_Configuration_Pragmas, + In_Variables => Packages.Table (Gnatmake).Decl.Attributes); + Global_Attribute_Present := + Global_Attribute /= Nil_Variable_Value + and then String_Length (Global_Attribute.Value) > 0; + end if; + + The_Packages := Projects.Table (For_Project).Decl.Packages; + Compiler := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => The_Packages); + + if Compiler /= No_Package then + Local_Attribute := Prj.Util.Value_Of + (Variable_Name => Local_Configuration_Pragmas, + In_Variables => Packages.Table (Compiler).Decl.Attributes); + Local_Attribute_Present := + Local_Attribute /= Nil_Variable_Value + and then String_Length (Local_Attribute.Value) > 0; + end if; + + if Global_Attribute_Present then + + if File /= Invalid_FD + or else Local_Attribute_Present + then + Copy_File (Global_Attribute.Value); + else + String_To_Name_Buffer (Global_Attribute.Value); + Projects.Table (For_Project).Config_File_Name := Name_Find; + end if; + end if; + + if Local_Attribute_Present then + + if File /= Invalid_FD then + Copy_File (Local_Attribute.Value); + + else + String_To_Name_Buffer (Local_Attribute.Value); + Projects.Table (For_Project).Config_File_Name := Name_Find; + end if; + + end if; + + if File /= Invalid_FD then + GNAT.OS_Lib.Close (File); + + if Opt.Verbose_Mode then + Write_Str ("Closing configuration file """); + Write_Str (File_Name); + Write_Line (""""); + end if; + + Name_Len := File_Name'Length; + Name_Buffer (1 .. Name_Len) := File_Name; + Projects.Table (For_Project).Config_File_Name := Name_Find; + Projects.Table (For_Project).Config_File_Temp := True; + end if; + + Projects.Table (For_Project).Config_Checked := True; + + end if; + + end Create_Config_Pragmas_File; + + ------------------------------------ + -- File_Name_Of_Library_Unit_Body -- + ------------------------------------ + + function File_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id) + return String + is + Data : constant Project_Data := Projects.Table (Project); + Original_Name : String := Name; + + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Data.Naming.Specification_Append); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Data.Naming.Body_Append); + + Unit : Unit_Data; + + The_Original_Name : Name_Id; + The_Spec_Name : Name_Id; + The_Body_Name : Name_Id; + + begin + Canonical_Case_File_Name (Original_Name); + Name_Len := Original_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Name; + The_Original_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Spec_Name); + Name_Len := Extended_Spec_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; + The_Spec_Name := Name_Find; + + Canonical_Case_File_Name (Extended_Body_Name); + Name_Len := Extended_Body_Name'Length; + Name_Buffer (1 .. Name_Len) := Extended_Body_Name; + The_Body_Name := Name_Find; + + if Current_Verbosity = High then + Write_Str ("Looking for file name of """); + Write_Str (Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Spec Name = """); + Write_Str (Extended_Spec_Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Body Name = """); + Write_Str (Extended_Body_Name); + Write_Char ('"'); + Write_Eol; + end if; + + -- For every unit + + for Current in reverse Units.First .. Units.Last loop + Unit := Units.Table (Current); + + -- If it is a unit of the same project + + if Unit.File_Names (Body_Part).Project = Project then + declare + Current_Name : constant Name_Id := + Unit.File_Names (Body_Part).Name; + + begin + -- If there is a body + + if Current_Name /= No_Name then + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If it has the name of the original name, + -- return the original name + + if Unit.Name = The_Original_Name + or else Current_Name = The_Original_Name + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Get_Name_String (Current_Name); + + -- If it has the name of the extended body name, + -- return the extended body name + + elsif Current_Name = The_Body_Name then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Extended_Body_Name; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + -- If it is a unit of the same project + + if Units.Table (Current).File_Names (Specification).Project = + Project + then + declare + Current_Name : constant Name_Id := + Unit.File_Names (Specification).Name; + + begin + -- If there is a spec + + if Current_Name /= No_Name then + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Get_Name_String (Current_Name)); + Write_Char ('"'); + Write_Eol; + end if; + + -- If it has the same name as the original name, + -- return the original name + + if Unit.Name = The_Original_Name + or else Current_Name = The_Original_Name + then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Get_Name_String (Current_Name); + + -- If it has the same name as the extended spec name, + -- return the extended spec name + + elsif Current_Name = The_Spec_Name then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Extended_Spec_Name; + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end if; + end; + end if; + + end loop; + + -- We don't know this file name, return an empty string + + return ""; + end File_Name_Of_Library_Unit_Body; + + ------------------------- + -- For_All_Object_Dirs -- + ------------------------- + + procedure For_All_Object_Dirs (Project : Project_Id) is + Seen : Project_List := Empty_Project_List; + + procedure Add (Project : Project_Id); + -- Process a project. Remember the processes visited to avoid + -- processing a project twice. Recursively process an eventual + -- modified project, and all imported projects. + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id) is + Data : constant Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + begin + -- If the list of visited project is empty, then + -- for sure we never visited this project. + + if Seen = Empty_Project_List then + Project_Lists.Increment_Last; + Seen := Project_Lists.Last; + Project_Lists.Table (Seen) := + (Project => Project, Next => Empty_Project_List); + + else + -- Check if the project is in the list + + declare + Current : Project_List := Seen; + + begin + loop + -- If it is, then there is nothing else to do + + if Project_Lists.Table (Current).Project = Project then + return; + end if; + + exit when Project_Lists.Table (Current).Next = + Empty_Project_List; + Current := Project_Lists.Table (Current).Next; + end loop; + + -- This project has never been visited, add it + -- to the list. + + Project_Lists.Increment_Last; + Project_Lists.Table (Current).Next := Project_Lists.Last; + Project_Lists.Table (Project_Lists.Last) := + (Project => Project, Next => Empty_Project_List); + end; + end if; + + -- If there is an object directory, call Action + -- with its name + + if Data.Object_Directory /= No_Name then + Get_Name_String (Data.Object_Directory); + Action (Name_Buffer (1 .. Name_Len)); + end if; + + -- If we are modifying a project, visit it + + if Data.Modifies /= No_Project then + Add (Data.Modifies); + end if; + + -- And visit all imported projects + + while List /= Empty_Project_List loop + Add (Project_Lists.Table (List).Project); + List := Project_Lists.Table (List).Next; + end loop; + end Add; + + -- Start of processing for For_All_Object_Dirs + + begin + -- Visit this project, and its imported projects, + -- recursively + + Add (Project); + end For_All_Object_Dirs; + + ------------------------- + -- For_All_Source_Dirs -- + ------------------------- + + procedure For_All_Source_Dirs (Project : Project_Id) is + Seen : Project_List := Empty_Project_List; + + procedure Add (Project : Project_Id); + -- Process a project. Remember the processes visited to avoid + -- processing a project twice. Recursively process an eventual + -- modified project, and all imported projects. + + --------- + -- Add -- + --------- + + procedure Add (Project : Project_Id) is + Data : constant Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + begin + -- If the list of visited project is empty, then + -- for sure we never visited this project. + + if Seen = Empty_Project_List then + Project_Lists.Increment_Last; + Seen := Project_Lists.Last; + Project_Lists.Table (Seen) := + (Project => Project, Next => Empty_Project_List); + + else + -- Check if the project is in the list + + declare + Current : Project_List := Seen; + + begin + loop + -- If it is, then there is nothing else to do + + if Project_Lists.Table (Current).Project = Project then + return; + end if; + + exit when Project_Lists.Table (Current).Next = + Empty_Project_List; + Current := Project_Lists.Table (Current).Next; + end loop; + + -- This project has never been visited, add it + -- to the list. + + Project_Lists.Increment_Last; + Project_Lists.Table (Current).Next := Project_Lists.Last; + Project_Lists.Table (Project_Lists.Last) := + (Project => Project, Next => Empty_Project_List); + end; + end if; + + declare + Current : String_List_Id := Data.Source_Dirs; + The_String : String_Element; + + begin + -- Call action with the name of every source directorie + + while Current /= Nil_String loop + The_String := String_Elements.Table (Current); + String_To_Name_Buffer (The_String.Value); + Action (Name_Buffer (1 .. Name_Len)); + Current := The_String.Next; + end loop; + end; + + -- If we are modifying a project, visit it + + if Data.Modifies /= No_Project then + Add (Data.Modifies); + end if; + + -- And visit all imported projects + + while List /= Empty_Project_List loop + Add (Project_Lists.Table (List).Project); + List := Project_Lists.Table (List).Next; + end loop; + end Add; + + -- Start of processing for For_All_Source_Dirs + + begin + -- Visit this project, and its imported projects recursively + + Add (Project); + end For_All_Source_Dirs; + + ------------------- + -- Get_Reference -- + ------------------- + + procedure Get_Reference + (Source_File_Name : String; + Project : out Project_Id; + Path : out Name_Id) + is + begin + if Current_Verbosity > Default then + Write_Str ("Getting Reference_Of ("""); + Write_Str (Source_File_Name); + Write_Str (""") ... "); + end if; + + declare + Original_Name : String := Source_File_Name; + Unit : Unit_Data; + + begin + Canonical_Case_File_Name (Original_Name); + + for Id in Units.First .. Units.Last loop + Unit := Units.Table (Id); + + if (Unit.File_Names (Specification).Name /= No_Name + and then + Namet.Get_Name_String + (Unit.File_Names (Specification).Name) = Original_Name) + or else (Unit.File_Names (Specification).Path /= No_Name + and then + Namet.Get_Name_String + (Unit.File_Names (Specification).Path) = + Original_Name) + then + Project := Unit.File_Names (Specification).Project; + Path := Unit.File_Names (Specification).Path; + + if Current_Verbosity > Default then + Write_Str ("Done: Specification."); + Write_Eol; + end if; + + return; + + elsif (Unit.File_Names (Body_Part).Name /= No_Name + and then + Namet.Get_Name_String + (Unit.File_Names (Body_Part).Name) = Original_Name) + or else (Unit.File_Names (Body_Part).Path /= No_Name + and then Namet.Get_Name_String + (Unit.File_Names (Body_Part).Path) = + Original_Name) + then + Project := Unit.File_Names (Body_Part).Project; + Path := Unit.File_Names (Body_Part).Path; + + if Current_Verbosity > Default then + Write_Str ("Done: Body."); + Write_Eol; + end if; + + return; + end if; + + end loop; + end; + + Project := No_Project; + Path := No_Name; + + if Current_Verbosity > Default then + Write_Str ("Cannot be found."); + Write_Eol; + end if; + end Get_Reference; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Global : constant String := "global_configuration_pragmas"; + Local : constant String := "local_configuration_pragmas"; + begin + -- Put the standard GNAT naming scheme in the Namings table + + Namings.Increment_Last; + Namings.Table (Namings.Last) := Standard_Naming_Data; + Name_Len := Global'Length; + Name_Buffer (1 .. Name_Len) := Global; + Global_Configuration_Pragmas := Name_Find; + Name_Len := Local'Length; + Name_Buffer (1 .. Name_Len) := Local; + Local_Configuration_Pragmas := Name_Find; + end Initialize; + + ------------------------------------ + -- Path_Name_Of_Library_Unit_Body -- + ------------------------------------ + + function Path_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id) + return String + is + Data : constant Project_Data := Projects.Table (Project); + Original_Name : String := Name; + + Extended_Spec_Name : String := + Name & Namet.Get_Name_String + (Data.Naming.Specification_Append); + Extended_Body_Name : String := + Name & Namet.Get_Name_String + (Data.Naming.Body_Append); + + First : Unit_Id := Units.First; + Current : Unit_Id; + Unit : Unit_Data; + + begin + Canonical_Case_File_Name (Original_Name); + Canonical_Case_File_Name (Extended_Spec_Name); + Canonical_Case_File_Name (Extended_Spec_Name); + + if Current_Verbosity = High then + Write_Str ("Looking for path name of """); + Write_Str (Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Spec Name = """); + Write_Str (Extended_Spec_Name); + Write_Char ('"'); + Write_Eol; + Write_Str (" Extended Body Name = """); + Write_Str (Extended_Body_Name); + Write_Char ('"'); + Write_Eol; + end if; + + while First <= Units.Last + and then Units.Table (First).File_Names (Body_Part).Project /= Project + loop + First := First + 1; + end loop; + + Current := First; + while Current <= Units.Last loop + Unit := Units.Table (Current); + + if Unit.File_Names (Body_Part).Project = Project + and then Unit.File_Names (Body_Part).Name /= No_Name + then + declare + Current_Name : constant String := + Namet.Get_Name_String (Unit.File_Names (Body_Part).Name); + begin + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Current_Name); + Write_Char ('"'); + Write_Eol; + end if; + + if Current_Name = Original_Name then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Body_Path_Name_Of (Current); + + elsif Current_Name = Extended_Body_Name then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Body_Path_Name_Of (Current); + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end; + + elsif Unit.File_Names (Specification).Name /= No_Name then + declare + Current_Name : constant String := + Namet.Get_Name_String + (Unit.File_Names (Specification).Name); + + begin + if Current_Verbosity = High then + Write_Str (" Comparing with """); + Write_Str (Current_Name); + Write_Char ('"'); + Write_Eol; + end if; + + if Current_Name = Original_Name then + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Spec_Path_Name_Of (Current); + + elsif Current_Name = Extended_Spec_Name then + + if Current_Verbosity = High then + Write_Line (" OK"); + end if; + + return Spec_Path_Name_Of (Current); + + else + if Current_Verbosity = High then + Write_Line (" not good"); + end if; + end if; + end; + end if; + Current := Current + 1; + end loop; + + return ""; + end Path_Name_Of_Library_Unit_Body; + + ------------------- + -- Print_Sources -- + ------------------- + + procedure Print_Sources is + Unit : Unit_Data; + + begin + Write_Line ("List of Sources:"); + + for Id in Units.First .. Units.Last loop + Unit := Units.Table (Id); + Write_Str (" "); + Write_Line (Namet.Get_Name_String (Unit.Name)); + + if Unit.File_Names (Specification).Name /= No_Name then + if Unit.File_Names (Specification).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Projects.Table + (Unit.File_Names (Specification).Project).Path_Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" spec: "); + Write_Line + (Namet.Get_Name_String + (Unit.File_Names (Specification).Name)); + end if; + + if Unit.File_Names (Body_Part).Name /= No_Name then + if Unit.File_Names (Body_Part).Project = No_Project then + Write_Line (" No project"); + + else + Write_Str (" Project: "); + Get_Name_String + (Projects.Table + (Unit.File_Names (Body_Part).Project).Path_Name); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + Write_Str (" body: "); + Write_Line + (Namet.Get_Name_String + (Unit.File_Names (Body_Part).Name)); + end if; + + end loop; + + Write_Line ("end of List of Sources."); + end Print_Sources; + + ----------------------- + -- Spec_Path_Name_Of -- + ----------------------- + + function Spec_Path_Name_Of (Unit : Unit_Id) return String is + Data : Unit_Data := Units.Table (Unit); + + begin + if Data.File_Names (Specification).Path = No_Name then + declare + Current_Source : String_List_Id := + Projects.Table (Data.File_Names (Specification).Project).Sources; + Path : GNAT.OS_Lib.String_Access; + + begin + Data.File_Names (Specification).Path := + Data.File_Names (Specification).Name; + + while Current_Source /= Nil_String loop + String_To_Name_Buffer + (String_Elements.Table (Current_Source).Value); + Path := Locate_Regular_File + (Namet.Get_Name_String + (Data.File_Names (Specification).Name), + Name_Buffer (1 .. Name_Len)); + + if Path /= null then + Name_Len := Path'Length; + Name_Buffer (1 .. Name_Len) := Path.all; + Data.File_Names (Specification).Path := Name_Enter; + exit; + else + Current_Source := + String_Elements.Table (Current_Source).Next; + end if; + end loop; + + Units.Table (Unit) := Data; + end; + end if; + + return Namet.Get_Name_String (Data.File_Names (Specification).Path); + end Spec_Path_Name_Of; + +end Prj.Env; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads new file mode 100644 index 00000000000..272c559282a --- /dev/null +++ b/gcc/ada/prj-env.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E N V -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements services for Project-aware tools, related +-- to the environment (gnat.adc, ADA_INCLUDE_PATH, ADA_OBJECTS_PATH) + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Prj.Env is + + procedure Initialize; + -- Put Standard_Naming_Data into Namings table (called by Prj.Initialize) + + procedure Print_Sources; + -- Output the list of sources, after Project files have been scanned + + procedure Create_Config_Pragmas_File + (For_Project : Project_Id; + Main_Project : Project_Id); + -- If there needs to have SFN pragmas, either for non standard naming + -- schemes or for individual units, or if Global_Configuration_Pragmas + -- has been specified in package gnatmake of the main project, or if + -- Local_Configuration_Pragmas has been specified in package Compiler + -- of the main project, build (if needed) a temporary file that contains + -- all configuration pragmas, and specify the configuration pragmas file + -- in the project data. + + function Ada_Include_Path (Project : Project_Id) return String_Access; + -- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute + -- it and cache it. + + function Ada_Objects_Path + (Project : Project_Id; + Including_Libraries : Boolean := True) + return String_Access; + -- Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute + -- it and cache it. When Including_Libraries is False, do not include the + -- object directories of the library projects, and do not cache the result. + + function Path_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id) + return String; + -- Returns the Path of a library unit. + + function File_Name_Of_Library_Unit_Body + (Name : String; + Project : Project_Id) + return String; + -- Returns the file name of a library unit, in canonical case. Name may or + -- may not have an extension (corresponding to the naming scheme of the + -- project). If there is no body with this name, but there is a spec, the + -- name of the spec is returned. If neither a body or a spec can be found, + -- return an empty string. + + procedure Get_Reference + (Source_File_Name : String; + Project : out Project_Id; + Path : out Name_Id); + -- Returns the project of a source. + + generic + with procedure Action (Path : String); + procedure For_All_Source_Dirs (Project : Project_Id); + -- Iterate through all the source directories of a project, + -- including those of imported or modified projects. + + generic + with procedure Action (Path : String); + procedure For_All_Object_Dirs (Project : Project_Id); + -- Iterate through all the object directories of a project, + -- including those of imported or modified projects. + +end Prj.Env; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb new file mode 100644 index 00000000000..b6f6ab8bb14 --- /dev/null +++ b/gcc/ada/prj-ext.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E X T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.HTable; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Prj.Com; use Prj.Com; +with Stringt; use Stringt; +with Types; use Types; + +package body Prj.Ext is + + package Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => String_Id, + No_Element => No_String, + Key => Name_Id, + Hash => Hash, + Equal => "="); + + --------- + -- Add -- + --------- + + procedure Add + (External_Name : String; + Value : String) + is + The_Key : Name_Id; + The_Value : String_Id; + + begin + Start_String; + Store_String_Chars (Value); + The_Value := End_String; + Name_Len := External_Name'Length; + Name_Buffer (1 .. Name_Len) := External_Name; + The_Key := Name_Find; + Htable.Set (The_Key, The_Value); + end Add; + + ----------- + -- Check -- + ----------- + + function Check (Declaration : String) return Boolean is + begin + for Equal_Pos in Declaration'Range loop + + if Declaration (Equal_Pos) = '=' then + exit when Equal_Pos = Declaration'First; + exit when Equal_Pos = Declaration'Last; + Add + (External_Name => + Declaration (Declaration'First .. Equal_Pos - 1), + Value => + Declaration (Equal_Pos + 1 .. Declaration'Last)); + return True; + end if; + + end loop; + + return False; + end Check; + + -------------- + -- Value_Of -- + -------------- + + function Value_Of + (External_Name : Name_Id; + With_Default : String_Id := No_String) + return String_Id + is + The_Value : String_Id; + + begin + The_Value := Htable.Get (External_Name); + + if The_Value /= No_String then + return The_Value; + end if; + + -- Find if it is an environment. + -- If it is, put the value in the hash table. + + declare + Env_Value : constant String_Access := + Getenv (Get_Name_String (External_Name)); + + begin + if Env_Value /= null and then Env_Value'Length > 0 then + Start_String; + Store_String_Chars (Env_Value.all); + The_Value := End_String; + Htable.Set (External_Name, The_Value); + return The_Value; + + else + return With_Default; + end if; + end; + end Value_Of; + +end Prj.Ext; diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads new file mode 100644 index 00000000000..4c12b786bcf --- /dev/null +++ b/gcc/ada/prj-ext.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . E X T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2000 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Set, Get and cache External reference, to be used as External functions +-- in project files. + +with Types; use Types; + +package Prj.Ext is + + procedure Add + (External_Name : String; + Value : String); + -- Add an external reference (or modify an existing one). + + function Value_Of + (External_Name : Name_Id; + With_Default : String_Id := No_String) + return String_Id; + -- Get the value of an external reference, and cache it for future uses. + + function Check (Declaration : String) return Boolean; + -- Check that an external declaration <external>=<value> is correct. + -- If it is correct, the external reference is Added. + +end Prj.Ext; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb new file mode 100644 index 00000000000..66031878d2b --- /dev/null +++ b/gcc/ada/prj-nmsc.adb @@ -0,0 +1,2236 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . N M S C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.25 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; +with Errout; use Errout; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Util; use Prj.Util; +with Snames; use Snames; +with Stringt; use Stringt; +with Types; use Types; + +package body Prj.Nmsc is + + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + + Error_Report : Put_Line_Access := null; + + procedure Check_Naming_Scheme (Naming : Naming_Data); + -- Check that the package Naming is correct. + + procedure Check_Naming_Scheme + (Name : Name_Id; + Unit : out Name_Id); + -- Check that a name is a valid unit name. + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); + -- Output an error message. + -- If Error_Report is null, simply call Errout.Error_Msg. + -- Otherwise, disregard Flag_Location and use Error_Report. + + function Get_Name_String (S : String_Id) return String; + -- Get the string from a String_Id + + procedure Get_Unit + (File_Name : Name_Id; + Naming : Naming_Data; + Unit_Name : out Name_Id; + Unit_Kind : out Spec_Or_Body; + Needs_Pragma : out Boolean); + -- Find out, from a file name, the unit name, the unit kind + -- and if a specific SFN pragma is needed. + -- If the file name corresponds to no unit, then Unit_Name + -- will be No_Name. + + function Is_Illegal_Append (This : String) return Boolean; + -- Returns True if the string This cannot be used as + -- a Specification_Append, a Body_Append or a Separate_Append. + + procedure Record_Source + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Error_If_Invalid : Boolean; + Location : Source_Ptr; + Current_Source : in out String_List_Id); + -- Put a unit in the list of units of a project, if the file name + -- corresponds to a valid unit name. + -- If it does not correspond to a valid unit name, report an error + -- only if Error_If_Invalid is true. + + procedure Show_Source_Dirs (Project : Project_Id); + -- List all the source directories of a project. + + function Locate_Directory + (Name : Name_Id; + Parent : Name_Id) + return Name_Id; + -- Locate a directory. + -- Returns No_Name if directory does not exist. + + function Path_Name_Of + (File_Name : String_Id; + Directory : Name_Id) + return String; + -- Returns the path name of a (non project) file. + -- Returns an empty string if file cannot be found. + + function Path_Name_Of + (File_Name : String_Id; + Directory : String_Id) + return String; + -- Same as above except that Directory is a String_Id instead + -- of a Name_Id. + + ------------------------- + -- Check_Naming_Scheme -- + ------------------------- + + procedure Check_Naming_Scheme (Naming : Naming_Data) is + begin + -- Only check if we are not using the standard naming scheme + + if Naming /= Standard_Naming_Data then + declare + Dot_Replacement : constant String := + Get_Name_String + (Naming.Dot_Replacement); + Specification_Append : constant String := + Get_Name_String + (Naming.Specification_Append); + Body_Append : constant String := + Get_Name_String + (Naming.Body_Append); + Separate_Append : constant String := + Get_Name_String + (Naming.Separate_Append); + + begin + -- Dot_Replacement cannot + -- - be empty + -- - start or end with an alphanumeric + -- - be a single '_' + -- - start with an '_' followed by an alphanumeric + -- - contain a '.' except if it is "." + + if Dot_Replacement'Length = 0 + or else Is_Alphanumeric + (Dot_Replacement (Dot_Replacement'First)) + or else Is_Alphanumeric + (Dot_Replacement (Dot_Replacement'Last)) + or else (Dot_Replacement (Dot_Replacement'First) = '_' + and then + (Dot_Replacement'Length = 1 + or else + Is_Alphanumeric + (Dot_Replacement (Dot_Replacement'First + 1)))) + or else (Dot_Replacement'Length > 1 + and then + Index (Source => Dot_Replacement, + Pattern => ".") /= 0) + then + Error_Msg + ('"' & Dot_Replacement & + """ is illegal for Dot_Replacement.", + Naming.Dot_Repl_Loc); + end if; + + -- Appends cannot + -- - be empty + -- - start with an alphanumeric + -- - start with an '_' followed by an alphanumeric + + if Is_Illegal_Append (Specification_Append) then + Error_Msg + ('"' & Specification_Append & + """ is illegal for Specification_Append.", + Naming.Spec_Append_Loc); + end if; + + if Is_Illegal_Append (Body_Append) then + Error_Msg + ('"' & Body_Append & + """ is illegal for Body_Append.", + Naming.Body_Append_Loc); + end if; + + if Body_Append /= Separate_Append then + if Is_Illegal_Append (Separate_Append) then + Error_Msg + ('"' & Separate_Append & + """ is illegal for Separate_Append.", + Naming.Sep_Append_Loc); + end if; + end if; + + -- Specification_Append cannot have the same termination as + -- Body_Append or Separate_Append + + if Specification_Append'Length >= Body_Append'Length + and then + Body_Append (Body_Append'Last - + Specification_Append'Length + 1 .. + Body_Append'Last) = Specification_Append + then + Error_Msg + ("Body_Append (""" & + Body_Append & + """) cannot end with" & + " Specification_Append (""" & + Specification_Append & """).", + Naming.Body_Append_Loc); + end if; + + if Specification_Append'Length >= Separate_Append'Length + and then + Separate_Append + (Separate_Append'Last - Specification_Append'Length + 1 + .. + Separate_Append'Last) = Specification_Append + then + Error_Msg + ("Separate_Append (""" & + Separate_Append & + """) cannot end with" & + " Specification_Append (""" & + Specification_Append & """).", + Naming.Sep_Append_Loc); + end if; + end; + end if; + end Check_Naming_Scheme; + + procedure Check_Naming_Scheme + (Name : Name_Id; + Unit : out Name_Id) + is + The_Name : String := Get_Name_String (Name); + Need_Letter : Boolean := True; + Last_Underscore : Boolean := False; + OK : Boolean := The_Name'Length > 0; + + begin + for Index in The_Name'Range loop + if Need_Letter then + + -- We need a letter (at the beginning, and following a dot), + -- but we don't have one. + + if Is_Letter (The_Name (Index)) then + Need_Letter := False; + + else + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not a letter."); + end if; + + exit; + end if; + + elsif Last_Underscore + and then (The_Name (Index) = '_' or else The_Name (Index) = '.') + then + -- Two underscores are illegal, and a dot cannot follow + -- an underscore. + + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is illegal here."); + end if; + + exit; + + elsif The_Name (Index) = '.' then + + -- We need a letter after a dot + + Need_Letter := True; + + elsif The_Name (Index) = '_' then + Last_Underscore := True; + + else + -- We need an letter or a digit + + Last_Underscore := False; + + if not Is_Alphanumeric (The_Name (Index)) then + OK := False; + + if Current_Verbosity = High then + Write_Int (Types.Int (Index)); + Write_Str (": '"); + Write_Char (The_Name (Index)); + Write_Line ("' is not alphanumeric."); + end if; + + exit; + end if; + end if; + end loop; + + -- We cannot end with an underscore or a dot + + OK := OK and then not Need_Letter and then not Last_Underscore; + + if OK then + Unit := Name; + else + -- We signal a problem with No_Name + + Unit := No_Name; + end if; + end Check_Naming_Scheme; + + procedure Check_Naming_Scheme + (Project : Project_Id; + Report_Error : Put_Line_Access) + is + Last_Source_Dir : String_List_Id := Nil_String; + Data : Project_Data := Projects.Table (Project); + + procedure Check_Unit_Names (List : Array_Element_Id); + -- Check that a list of unit names contains only valid names. + + procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr); + -- Find one or several source directories, and add them + -- to the list of source directories of the project. + + procedure Find_Sources; + -- Find all the sources in all of the source directories + -- of a project. + + procedure Get_Path_Name_And_Record_Source + (File_Name : String; + Location : Source_Ptr; + Current_Source : in out String_List_Id); + -- Find the path name of a source in the source directories and + -- record the source, if found. + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr); + -- Get the sources of a project from a text file + + ---------------------- + -- Check_Unit_Names -- + ---------------------- + + procedure Check_Unit_Names (List : Array_Element_Id) is + Current : Array_Element_Id := List; + Element : Array_Element; + Unit_Name : Name_Id; + + begin + -- Loop through elements of the string list + + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + -- Check that it contains a valid unit name + + Check_Naming_Scheme (Element.Index, Unit_Name); + + if Unit_Name = No_Name then + Error_Msg_Name_1 := Element.Index; + Error_Msg + ("{ is not a valid unit name.", + Element.Value.Location); + + else + + if Current_Verbosity = High then + Write_Str (" Body_Part ("""); + Write_Str (Get_Name_String (Unit_Name)); + Write_Line (""")"); + end if; + + Element.Index := Unit_Name; + Array_Elements.Table (Current) := Element; + end if; + + Current := Element.Next; + end loop; + end Check_Unit_Names; + + ---------------------- + -- Find_Source_Dirs -- + ---------------------- + + procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr) is + + Directory : String (1 .. Integer (String_Length (From))); + Directory_Id : Name_Id; + Element : String_Element; + + procedure Recursive_Find_Dirs (Path : String_Id); + -- Find all the subdirectories (recursively) of Path + -- and add them to the list of source directories + -- of the project. + + ------------------------- + -- Recursive_Find_Dirs -- + ------------------------- + + procedure Recursive_Find_Dirs (Path : String_Id) is + Dir : Dir_Type; + Name : String (1 .. 250); + Last : Natural; + The_Path : String := Get_Name_String (Path) & Dir_Sep; + + The_Path_Last : Positive := The_Path'Last; + + begin + if The_Path'Length > 1 + and then + (The_Path (The_Path_Last - 1) = Dir_Sep + or else The_Path (The_Path_Last - 1) = '/') + then + The_Path_Last := The_Path_Last - 1; + end if; + + if Current_Verbosity = High then + Write_Str (" "); + Write_Line (The_Path (The_Path'First .. The_Path_Last)); + end if; + + String_Elements.Increment_Last; + Element := + (Value => Path, + Location => No_Location, + Next => Nil_String); + + -- Case of first source directory + + if Last_Source_Dir = Nil_String then + Data.Source_Dirs := String_Elements.Last; + + -- Here we already have source directories. + + else + -- Link the previous last to the new one + + String_Elements.Table (Last_Source_Dir).Next := + String_Elements.Last; + end if; + + -- And register this source directory as the new last + + Last_Source_Dir := String_Elements.Last; + String_Elements.Table (Last_Source_Dir) := Element; + + -- Now look for subdirectories + + Open (Dir, The_Path (The_Path'First .. The_Path_Last)); + + loop + Read (Dir, Name, Last); + exit when Last = 0; + + if Current_Verbosity = High then + Write_Str (" Checking "); + Write_Line (Name (1 .. Last)); + end if; + + if Name (1 .. Last) /= "." + and then Name (1 .. Last) /= ".." + then + -- Avoid . and .. + + declare + Path_Name : constant String := + The_Path (The_Path'First .. The_Path_Last) & + Name (1 .. Last); + + begin + if Is_Directory (Path_Name) then + + -- We have found a new subdirectory, + -- register it and find its own subdirectories. + + Start_String; + Store_String_Chars (Path_Name); + Recursive_Find_Dirs (End_String); + end if; + end; + end if; + end loop; + + Close (Dir); + + exception + when Directory_Error => + null; + end Recursive_Find_Dirs; + + -- Start of processing for Find_Source_Dirs + + begin + if Current_Verbosity = High then + Write_Str ("Find_Source_Dirs ("""); + end if; + + String_To_Name_Buffer (From); + Directory := Name_Buffer (1 .. Name_Len); + Directory_Id := Name_Find; + + if Current_Verbosity = High then + Write_Str (Directory); + Write_Line (""")"); + end if; + + -- First, check if we are looking for a directory tree, + -- indicated by "/**" at the end. + + if Directory'Length >= 3 + and then Directory (Directory'Last - 1 .. Directory'Last) = "**" + and then (Directory (Directory'Last - 2) = '/' + or else + Directory (Directory'Last - 2) = Dir_Sep) + then + Name_Len := Directory'Length - 3; + + if Name_Len = 0 then + -- This is the case of "/**": all directories + -- in the file system. + + Name_Len := 1; + Name_Buffer (1) := Directory (Directory'First); + + else + Name_Buffer (1 .. Name_Len) := + Directory (Directory'First .. Directory'Last - 3); + end if; + + if Current_Verbosity = High then + Write_Str ("Looking for all subdirectories of """); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Line (""""); + end if; + + declare + Base_Dir : constant Name_Id := Name_Find; + Root : constant Name_Id := + Locate_Directory (Base_Dir, Data.Directory); + + begin + if Root = No_Name then + Error_Msg_Name_1 := Base_Dir; + if Location = No_Location then + Error_Msg ("{ is not a valid directory.", Data.Location); + else + Error_Msg ("{ is not a valid directory.", Location); + end if; + + else + -- We have an existing directory, + -- we register it and all of its subdirectories. + + if Current_Verbosity = High then + Write_Line ("Looking for source directories:"); + end if; + + Start_String; + Store_String_Chars (Get_Name_String (Root)); + Recursive_Find_Dirs (End_String); + + if Current_Verbosity = High then + Write_Line ("End of looking for source directories."); + end if; + end if; + end; + + -- We have a single directory + + else + declare + Path_Name : constant Name_Id := + Locate_Directory (Directory_Id, Data.Directory); + + begin + if Path_Name = No_Name then + Error_Msg_Name_1 := Directory_Id; + if Location = No_Location then + Error_Msg ("{ is not a valid directory", Data.Location); + else + Error_Msg ("{ is not a valid directory", Location); + end if; + else + + -- As it is an existing directory, we add it to + -- the list of directories. + + String_Elements.Increment_Last; + Start_String; + Store_String_Chars (Get_Name_String (Path_Name)); + Element.Value := End_String; + + if Last_Source_Dir = Nil_String then + + -- This is the first source directory + + Data.Source_Dirs := String_Elements.Last; + + else + -- We already have source directories, + -- link the previous last to the new one. + + String_Elements.Table (Last_Source_Dir).Next := + String_Elements.Last; + end if; + + -- And register this source directory as the new last + + Last_Source_Dir := String_Elements.Last; + String_Elements.Table (Last_Source_Dir) := Element; + end if; + end; + end if; + end Find_Source_Dirs; + + ------------------ + -- Find_Sources -- + ------------------ + + procedure Find_Sources is + Source_Dir : String_List_Id := Data.Source_Dirs; + Element : String_Element; + Dir : Dir_Type; + Current_Source : String_List_Id := Nil_String; + + begin + if Current_Verbosity = High then + Write_Line ("Looking for sources:"); + end if; + + -- For each subdirectory + + while Source_Dir /= Nil_String loop + begin + Element := String_Elements.Table (Source_Dir); + if Element.Value /= No_String then + declare + Source_Directory : String + (1 .. Integer (String_Length (Element.Value))); + begin + String_To_Name_Buffer (Element.Value); + Source_Directory := Name_Buffer (1 .. Name_Len); + if Current_Verbosity = High then + Write_Str ("Source_Dir = "); + Write_Line (Source_Directory); + end if; + + -- We look to every entry in the source directory + + Open (Dir, Source_Directory); + + loop + Read (Dir, Name_Buffer, Name_Len); + + if Current_Verbosity = High then + Write_Str (" Checking "); + Write_Line (Name_Buffer (1 .. Name_Len)); + end if; + + exit when Name_Len = 0; + + declare + Path_Access : constant GNAT.OS_Lib.String_Access := + Locate_Regular_File + (Name_Buffer (1 .. Name_Len), + Source_Directory); + + File_Name : Name_Id; + Path_Name : Name_Id; + + begin + -- If it is a regular file + + if Path_Access /= null then + File_Name := Name_Find; + Name_Len := Path_Access'Length; + Name_Buffer (1 .. Name_Len) := Path_Access.all; + Path_Name := Name_Find; + + -- We attempt to register it as a source. + -- However, there is no error if the file + -- does not contain a valid source (as + -- indicated by Error_If_Invalid => False). + -- But there is an error if we have a + -- duplicate unit name. + + Record_Source + (File_Name => File_Name, + Path_Name => Path_Name, + Project => Project, + Data => Data, + Error_If_Invalid => False, + Location => No_Location, + Current_Source => Current_Source); + + else + if Current_Verbosity = High then + Write_Line + (" Not a regular file."); + end if; + end if; + end; + end loop; + + Close (Dir); + end; + end if; + + exception + when Directory_Error => + null; + end; + + Source_Dir := Element.Next; + end loop; + + if Current_Verbosity = High then + Write_Line ("end Looking for sources."); + end if; + + -- If we have looked for sources and found none, then + -- it is an error. If a project is not supposed to contain + -- any source, then we never call Find_Sources. + + if Current_Source = Nil_String then + Error_Msg ("there are no sources in this project", + Data.Location); + end if; + end Find_Sources; + + ------------------------------------- + -- Get_Path_Name_And_Record_Source -- + ------------------------------------- + + procedure Get_Path_Name_And_Record_Source + (File_Name : String; + Location : Source_Ptr; + Current_Source : in out String_List_Id) + is + Source_Dir : String_List_Id := Data.Source_Dirs; + Element : String_Element; + Path_Name : GNAT.OS_Lib.String_Access; + Found : Boolean := False; + File : Name_Id; + + begin + if Current_Verbosity = High then + Write_Str (" Checking """); + Write_Str (File_Name); + Write_Line ("""."); + end if; + + -- We look in all source directories for this file name + + while Source_Dir /= Nil_String loop + Element := String_Elements.Table (Source_Dir); + + if Current_Verbosity = High then + Write_Str (" """); + Write_Str (Get_Name_String (Element.Value)); + Write_Str (""": "); + end if; + + Path_Name := + Locate_Regular_File + (File_Name, + Get_Name_String (Element.Value)); + + if Path_Name /= null then + if Current_Verbosity = High then + Write_Line ("OK"); + end if; + + Name_Len := File_Name'Length; + Name_Buffer (1 .. Name_Len) := File_Name; + File := Name_Find; + Name_Len := Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Path_Name.all; + + -- We register the source. + -- We report an error if the file does not + -- correspond to a source. + + Record_Source + (File_Name => File, + Path_Name => Name_Find, + Project => Project, + Data => Data, + Error_If_Invalid => True, + Location => Location, + Current_Source => Current_Source); + Found := True; + exit; + + else + if Current_Verbosity = High then + Write_Line ("No"); + end if; + + Source_Dir := Element.Next; + end if; + end loop; + + if not Found then + Name_Len := File_Name'Length; + Name_Buffer (1 .. Name_Len) := File_Name; + Error_Msg_Name_1 := Name_Find; + Error_Msg + ("cannot find source {", Location); + end if; + end Get_Path_Name_And_Record_Source; + + --------------------------- + -- Get_Sources_From_File -- + --------------------------- + + procedure Get_Sources_From_File + (Path : String; + Location : Source_Ptr) + is + File : Prj.Util.Text_File; + Line : String (1 .. 250); + Last : Natural; + Current_Source : String_List_Id := Nil_String; + + Nmb_Errors : constant Nat := Errors_Detected; + + begin + if Current_Verbosity = High then + Write_Str ("Opening """); + Write_Str (Path); + Write_Line ("""."); + end if; + + -- We open the file + + Prj.Util.Open (File, Path); + + if not Prj.Util.Is_Valid (File) then + Error_Msg ("file does not exist", Location); + else + while not Prj.Util.End_Of_File (File) loop + Prj.Util.Get_Line (File, Line, Last); + + -- If the line is not empty and does not start with "--", + -- then it must contains a file name. + + if Last /= 0 + and then (Last = 1 or else Line (1 .. 2) /= "--") + then + Get_Path_Name_And_Record_Source + (File_Name => Line (1 .. Last), + Location => Location, + Current_Source => Current_Source); + exit when Nmb_Errors /= Errors_Detected; + end if; + end loop; + + Prj.Util.Close (File); + + end if; + + -- We should have found at least one source. + -- If not, report an error. + + if Current_Source = Nil_String then + Error_Msg ("this project has no source", Location); + end if; + end Get_Sources_From_File; + + -- Start of processing for Check_Naming_Scheme + + begin + + Error_Report := Report_Error; + + if Current_Verbosity = High then + Write_Line ("Starting to look for directories"); + end if; + + -- Let's check the object directory + + declare + Object_Dir : Variable_Value := + Util.Value_Of (Name_Object_Dir, Data.Decl.Attributes); + + begin + pragma Assert (Object_Dir.Kind = Single, + "Object_Dir is not a single string"); + + -- We set the object directory to its default + + Data.Object_Directory := Data.Directory; + + if not String_Equal (Object_Dir.Value, Empty_String) then + + String_To_Name_Buffer (Object_Dir.Value); + + if Name_Len = 0 then + Error_Msg ("Object_Dir cannot be empty", + Object_Dir.Location); + + else + -- We check that the specified object directory + -- does exist. + + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Dir_Id : constant Name_Id := Name_Find; + + begin + Data.Object_Directory := + Locate_Directory (Dir_Id, Data.Directory); + + if Data.Object_Directory = No_Name then + Error_Msg_Name_1 := Dir_Id; + Error_Msg + ("the object directory { cannot be found", + Data.Location); + end if; + end; + end if; + end if; + end; + + if Current_Verbosity = High then + if Data.Object_Directory = No_Name then + Write_Line ("No object directory"); + else + Write_Str ("Object directory: """); + Write_Str (Get_Name_String (Data.Object_Directory)); + Write_Line (""""); + end if; + end if; + + -- Let's check the source directories + + declare + Source_Dirs : Variable_Value := + Util.Value_Of (Name_Source_Dirs, Data.Decl.Attributes); + + begin + + if Current_Verbosity = High then + Write_Line ("Starting to look for source directories"); + end if; + + pragma Assert (Source_Dirs.Kind = List, + "Source_Dirs is not a list"); + + if Source_Dirs.Default then + + -- No Source_Dirs specified: the single source directory + -- is the one containing the project file + + String_Elements.Increment_Last; + Data.Source_Dirs := String_Elements.Last; + Start_String; + Store_String_Chars (Get_Name_String (Data.Directory)); + String_Elements.Table (Data.Source_Dirs) := + (Value => End_String, + Location => No_Location, + Next => Nil_String); + + if Current_Verbosity = High then + Write_Line ("(Undefined) Single object directory:"); + Write_Str (" """); + Write_Str (Get_Name_String (Data.Directory)); + Write_Line (""""); + end if; + + elsif Source_Dirs.Values = Nil_String then + + -- If Source_Dirs is an empty string list, this means + -- that this project contains no source. + + if Data.Object_Directory = Data.Directory then + Data.Object_Directory := No_Name; + end if; + + Data.Source_Dirs := Nil_String; + + else + declare + Source_Dir : String_List_Id := Source_Dirs.Values; + Element : String_Element; + + begin + -- We will find the source directories for each + -- element of the list + + while Source_Dir /= Nil_String loop + Element := String_Elements.Table (Source_Dir); + Find_Source_Dirs (Element.Value, Element.Location); + Source_Dir := Element.Next; + end loop; + end; + end if; + + if Current_Verbosity = High then + Write_Line ("Puting source directories in canonical cases"); + end if; + + declare + Current : String_List_Id := Data.Source_Dirs; + Element : String_Element; + + begin + while Current /= Nil_String loop + Element := String_Elements.Table (Current); + if Element.Value /= No_String then + String_To_Name_Buffer (Element.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Start_String; + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Element.Value := End_String; + String_Elements.Table (Current) := Element; + end if; + + Current := Element.Next; + end loop; + end; + end; + + -- Library Dir, Name, Version and Kind + + declare + Attributes : constant Prj.Variable_Id := Data.Decl.Attributes; + + Lib_Dir : Prj.Variable_Value := + Prj.Util.Value_Of (Snames.Name_Library_Dir, Attributes); + + Lib_Name : Prj.Variable_Value := + Prj.Util.Value_Of (Snames.Name_Library_Name, Attributes); + + Lib_Version : Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Version, Attributes); + + The_Lib_Kind : Prj.Variable_Value := + Prj.Util.Value_Of + (Snames.Name_Library_Kind, Attributes); + + begin + pragma Assert (Lib_Dir.Kind = Single); + + if Lib_Dir.Value = Empty_String then + + if Current_Verbosity = High then + Write_Line ("No library directory"); + end if; + + else + -- Find path name, check that it is a directory + + Stringt.String_To_Name_Buffer (Lib_Dir.Value); + + declare + Dir_Id : constant Name_Id := Name_Find; + + begin + Data.Library_Dir := + Locate_Directory (Dir_Id, Data.Directory); + + if Data.Library_Dir = No_Name then + Error_Msg ("not an existing directory", + Lib_Dir.Location); + + elsif Data.Library_Dir = Data.Object_Directory then + Error_Msg + ("library directory cannot be the same " & + "as object directory", + Lib_Dir.Location); + Data.Library_Dir := No_Name; + + else + if Current_Verbosity = High then + Write_Str ("Library directory ="""); + Write_Str (Get_Name_String (Data.Library_Dir)); + Write_Line (""""); + end if; + end if; + end; + end if; + + pragma Assert (Lib_Name.Kind = Single); + + if Lib_Name.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library name"); + end if; + + else + Stringt.String_To_Name_Buffer (Lib_Name.Value); + + if not Is_Letter (Name_Buffer (1)) then + Error_Msg ("must start with a letter", + Lib_Name.Location); + + else + Data.Library_Name := Name_Find; + + for Index in 2 .. Name_Len loop + if not Is_Alphanumeric (Name_Buffer (Index)) then + Data.Library_Name := No_Name; + Error_Msg ("only letters and digits are allowed", + Lib_Name.Location); + exit; + end if; + end loop; + + if Data.Library_Name /= No_Name + and then Current_Verbosity = High then + Write_Str ("Library name = """); + Write_Str (Get_Name_String (Data.Library_Name)); + Write_Line (""""); + end if; + end if; + end if; + + Data.Library := + Data.Library_Dir /= No_Name + and then + Data.Library_Name /= No_Name; + + if Data.Library then + if Current_Verbosity = High then + Write_Line ("This is a library project file"); + end if; + + pragma Assert (Lib_Version.Kind = Single); + + if Lib_Version.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library version specified"); + end if; + + else + Stringt.String_To_Name_Buffer (Lib_Version.Value); + Data.Lib_Internal_Name := Name_Find; + end if; + + pragma Assert (The_Lib_Kind.Kind = Single); + + if The_Lib_Kind.Value = Empty_String then + if Current_Verbosity = High then + Write_Line ("No library kind specified"); + end if; + + else + Stringt.String_To_Name_Buffer (The_Lib_Kind.Value); + + declare + Kind_Name : constant String := + Ada.Characters.Handling.To_Lower + (Name_Buffer (1 .. Name_Len)); + + OK : Boolean := True; + + begin + if Kind_Name = "static" then + Data.Library_Kind := Static; + + elsif Kind_Name = "dynamic" then + Data.Library_Kind := Dynamic; + + elsif Kind_Name = "relocatable" then + Data.Library_Kind := Relocatable; + + else + Error_Msg + ("illegal value for Library_Kind", + The_Lib_Kind.Location); + OK := False; + end if; + + if Current_Verbosity = High and then OK then + Write_Str ("Library kind = "); + Write_Line (Kind_Name); + end if; + end; + end if; + end if; + end; + + if Current_Verbosity = High then + Show_Source_Dirs (Project); + end if; + + declare + Naming_Id : constant Package_Id := + Util.Value_Of (Name_Naming, Data.Decl.Packages); + + Naming : Package_Element; + + begin + -- If there is a package Naming, we will put in Data.Naming + -- what is in this package Naming. + + if Naming_Id /= No_Package then + Naming := Packages.Table (Naming_Id); + + if Current_Verbosity = High then + Write_Line ("Checking ""Naming""."); + end if; + + declare + Bodies : constant Array_Element_Id := + Util.Value_Of (Name_Body_Part, Naming.Decl.Arrays); + + Specifications : constant Array_Element_Id := + Util.Value_Of + (Name_Specification, Naming.Decl.Arrays); + + begin + if Bodies /= No_Array_Element then + + -- We have elements in the array Body_Part + + if Current_Verbosity = High then + Write_Line ("Found Bodies."); + end if; + + Data.Naming.Bodies := Bodies; + Check_Unit_Names (Bodies); + + else + if Current_Verbosity = High then + Write_Line ("No Bodies."); + end if; + end if; + + if Specifications /= No_Array_Element then + + -- We have elements in the array Specification + + if Current_Verbosity = High then + Write_Line ("Found Specifications."); + end if; + + Data.Naming.Specifications := Specifications; + Check_Unit_Names (Specifications); + + else + if Current_Verbosity = High then + Write_Line ("No Specifications."); + end if; + end if; + end; + + -- We are now checking if variables Dot_Replacement, Casing, + -- Specification_Append, Body_Append and/or Separate_Append + -- exist. + -- For each variable, if it does not exist, we do nothing, + -- because we already have the default. + + -- Let's check Dot_Replacement + + declare + Dot_Replacement : constant Variable_Value := + Util.Value_Of + (Name_Dot_Replacement, + Naming.Decl.Attributes); + + begin + pragma Assert (Dot_Replacement.Kind = Single, + "Dot_Replacement is not a single string"); + + if not Dot_Replacement.Default then + + String_To_Name_Buffer (Dot_Replacement.Value); + + if Name_Len = 0 then + Error_Msg ("Dot_Replacement cannot be empty", + Dot_Replacement.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Dot_Replacement := Name_Find; + Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location; + end if; + + end if; + + end; + + if Current_Verbosity = High then + Write_Str (" Dot_Replacement = """); + Write_Str (Get_Name_String (Data.Naming.Dot_Replacement)); + Write_Char ('"'); + Write_Eol; + end if; + + -- Check Casing + + declare + Casing_String : constant Variable_Value := + Util.Value_Of (Name_Casing, Naming.Decl.Attributes); + + begin + pragma Assert (Casing_String.Kind = Single, + "Dot_Replacement is not a single string"); + + if not Casing_String.Default then + declare + Casing_Image : constant String := + Get_Name_String (Casing_String.Value); + + begin + declare + Casing : constant Casing_Type := + Value (Casing_Image); + + begin + Data.Naming.Casing := Casing; + end; + + exception + when Constraint_Error => + if Casing_Image'Length = 0 then + Error_Msg ("Casing cannot be an empty string", + Casing_String.Location); + + else + Name_Len := Casing_Image'Length; + Name_Buffer (1 .. Name_Len) := Casing_Image; + Error_Msg_Name_1 := Name_Find; + Error_Msg + ("{ is not a correct Casing", + Casing_String.Location); + end if; + end; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Casing = "); + Write_Str (Image (Data.Naming.Casing)); + Write_Char ('.'); + Write_Eol; + end if; + + -- Let's check Specification_Append + + declare + Specification_Append : constant Variable_Value := + Util.Value_Of + (Name_Specification_Append, + Naming.Decl.Attributes); + + begin + pragma Assert (Specification_Append.Kind = Single, + "Specification_Append is not a single string"); + + if not Specification_Append.Default then + String_To_Name_Buffer (Specification_Append.Value); + + if Name_Len = 0 then + Error_Msg ("Specification_Append cannot be empty", + Specification_Append.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Specification_Append := Name_Find; + Data.Naming.Spec_Append_Loc := + Specification_Append.Location; + end if; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Specification_Append = """); + Write_Str (Get_Name_String (Data.Naming.Specification_Append)); + Write_Line ("""."); + end if; + + -- Check Body_Append + + declare + Body_Append : constant Variable_Value := + Util.Value_Of + (Name_Body_Append, Naming.Decl.Attributes); + + begin + pragma Assert (Body_Append.Kind = Single, + "Body_Append is not a single string"); + + if not Body_Append.Default then + + String_To_Name_Buffer (Body_Append.Value); + + if Name_Len = 0 then + Error_Msg ("Body_Append cannot be empty", + Body_Append.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Body_Append := Name_Find; + Data.Naming.Body_Append_Loc := Body_Append.Location; + + -- As we have a new Body_Append, we set Separate_Append + -- to the same value. + + Data.Naming.Separate_Append := Data.Naming.Body_Append; + Data.Naming.Sep_Append_Loc := Data.Naming.Body_Append_Loc; + end if; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Body_Append = """); + Write_Str (Get_Name_String (Data.Naming.Body_Append)); + Write_Line ("""."); + end if; + + -- Check Separate_Append + + declare + Separate_Append : constant Variable_Value := + Util.Value_Of + (Name_Separate_Append, + Naming.Decl.Attributes); + + begin + pragma Assert (Separate_Append.Kind = Single, + "Separate_Append is not a single string"); + + if not Separate_Append.Default then + String_To_Name_Buffer (Separate_Append.Value); + + if Name_Len = 0 then + Error_Msg ("Separate_Append cannot be empty", + Separate_Append.Location); + + else + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Data.Naming.Separate_Append := Name_Find; + Data.Naming.Sep_Append_Loc := Separate_Append.Location; + end if; + end if; + end; + + if Current_Verbosity = High then + Write_Str (" Separate_Append = """); + Write_Str (Get_Name_String (Data.Naming.Separate_Append)); + Write_Line ("""."); + Write_Line ("end Naming."); + end if; + + -- Now, we check if Data.Naming is valid + + Check_Naming_Scheme (Data.Naming); + end if; + end; + + -- If we have source directories, then let's find the sources. + + if Data.Source_Dirs /= Nil_String then + declare + Sources : constant Variable_Value := + Util.Value_Of + (Name_Source_Files, + Data.Decl.Attributes); + + Source_List_File : constant Variable_Value := + Util.Value_Of + (Name_Source_List_File, + Data.Decl.Attributes); + + begin + pragma Assert + (Sources.Kind = List, + "Source_Files is not a list"); + pragma Assert + (Source_List_File.Kind = Single, + "Source_List_File is not a single string"); + + if not Sources.Default then + if not Source_List_File.Default then + Error_Msg + ("?both variables source_files and " & + "source_list_file are present", + Source_List_File.Location); + end if; + + -- Sources is a list of file names + + declare + Current_Source : String_List_Id := Nil_String; + Current : String_List_Id := Sources.Values; + Element : String_Element; + + begin + while Current /= Nil_String loop + Element := String_Elements.Table (Current); + String_To_Name_Buffer (Element.Value); + + declare + File_Name : constant String := + Name_Buffer (1 .. Name_Len); + + begin + Get_Path_Name_And_Record_Source + (File_Name => File_Name, + Location => Element.Location, + Current_Source => Current_Source); + Current := Element.Next; + end; + end loop; + end; + + -- No source_files specified. + -- We check Source_List_File has been specified. + + elsif not Source_List_File.Default then + + -- Source_List_File is the name of the file + -- that contains the source file names + + declare + Source_File_Path_Name : constant String := + Path_Name_Of + (Source_List_File.Value, + Data.Directory); + + begin + if Source_File_Path_Name'Length = 0 then + String_To_Name_Buffer (Source_List_File.Value); + Error_Msg_Name_1 := Name_Find; + Error_Msg + ("file with sources { does not exist", + Source_List_File.Location); + + else + Get_Sources_From_File + (Source_File_Path_Name, + Source_List_File.Location); + end if; + end; + + else + -- Neither Source_Files nor Source_List_File has been + -- specified. + -- Find all the files that satisfy + -- the naming scheme in all the source directories. + + Find_Sources; + end if; + end; + end if; + + Projects.Table (Project) := Data; + end Check_Naming_Scheme; + + --------------- + -- Error_Msg -- + --------------- + + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is + begin + if Error_Report = null then + Errout.Error_Msg (Msg, Flag_Location); + + else + declare + Error_Buffer : String (1 .. 5_000); + Error_Last : Natural := 0; + Msg_Name : Natural := 0; + First : Positive := Msg'First; + + procedure Add (C : Character); + -- Add a character to the buffer + + procedure Add (S : String); + -- Add a string to the buffer + + procedure Add (Id : Name_Id); + -- Add a name to the buffer + + --------- + -- Add -- + --------- + + procedure Add (C : Character) is + begin + Error_Last := Error_Last + 1; + Error_Buffer (Error_Last) := C; + end Add; + + procedure Add (S : String) is + begin + Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S; + Error_Last := Error_Last + S'Length; + end Add; + + procedure Add (Id : Name_Id) is + begin + Get_Name_String (Id); + Add (Name_Buffer (1 .. Name_Len)); + end Add; + + begin + if Msg (First) = '\' then + -- Continuation character, ignore. + First := First + 1; + + elsif Msg (First) = '?' then + -- Warning character. It is always the first one, + -- in this package. + First := First + 1; + Add ("Warning: "); + end if; + + for Index in First .. Msg'Last loop + if Msg (Index) = '{' or else Msg (Index) = '%' then + -- Include a name between double quotes. + Msg_Name := Msg_Name + 1; + Add ('"'); + + case Msg_Name is + when 1 => Add (Error_Msg_Name_1); + + when 2 => Add (Error_Msg_Name_2); + + when 3 => Add (Error_Msg_Name_3); + + when others => null; + end case; + + Add ('"'); + + else + Add (Msg (Index)); + end if; + + end loop; + + Error_Report (Error_Buffer (1 .. Error_Last)); + end; + end if; + end Error_Msg; + + --------------------- + -- Get_Name_String -- + --------------------- + + function Get_Name_String (S : String_Id) return String is + begin + if S = No_String then + return ""; + else + String_To_Name_Buffer (S); + return Name_Buffer (1 .. Name_Len); + end if; + end Get_Name_String; + + -------------- + -- Get_Unit -- + -------------- + + procedure Get_Unit + (File_Name : Name_Id; + Naming : Naming_Data; + Unit_Name : out Name_Id; + Unit_Kind : out Spec_Or_Body; + Needs_Pragma : out Boolean) + is + Canonical_Case_Name : Name_Id; + + begin + Needs_Pragma := False; + Get_Name_String (File_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Canonical_Case_Name := Name_Find; + + if Naming.Bodies /= No_Array_Element then + + -- There are some specified file names for some bodies + -- of this project. Find out if File_Name is one of these bodies. + + declare + Current : Array_Element_Id := Naming.Bodies; + Element : Array_Element; + + begin + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + if Element.Index /= No_Name then + String_To_Name_Buffer (Element.Value.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + if Canonical_Case_Name = Name_Find then + + -- File_Name corresponds to one body. + -- So, we know it is a body, and we know the unit name. + + Unit_Kind := Body_Part; + Unit_Name := Element.Index; + Needs_Pragma := True; + return; + end if; + end if; + + Current := Element.Next; + end loop; + end; + end if; + + if Naming.Specifications /= No_Array_Element then + + -- There are some specified file names for some bodiesspecifications + -- of this project. Find out if File_Name is one of these + -- specifications. + + declare + Current : Array_Element_Id := Naming.Specifications; + Element : Array_Element; + + begin + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + if Element.Index /= No_Name then + String_To_Name_Buffer (Element.Value.Value); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + if Canonical_Case_Name = Name_Find then + + -- File_Name corresponds to one specification. + -- So, we know it is a spec, and we know the unit name. + + Unit_Kind := Specification; + Unit_Name := Element.Index; + Needs_Pragma := True; + return; + end if; + + end if; + + Current := Element.Next; + end loop; + end; + end if; + + declare + File : String := Get_Name_String (Canonical_Case_Name); + First : Positive := File'First; + Last : Natural := File'Last; + + begin + -- Check if the end of the file name is Specification_Append + + Get_Name_String (Naming.Specification_Append); + + if File'Length > Name_Len + and then File (Last - Name_Len + 1 .. Last) = + Name_Buffer (1 .. Name_Len) + then + -- We have a spec + + Unit_Kind := Specification; + Last := Last - Name_Len; + + if Current_Verbosity = High then + Write_Str (" Specification: "); + Write_Line (File (First .. Last)); + end if; + + else + Get_Name_String (Naming.Body_Append); + + -- Check if the end of the file name is Body_Append + + if File'Length > Name_Len + and then File (Last - Name_Len + 1 .. Last) = + Name_Buffer (1 .. Name_Len) + then + -- We have a body + + Unit_Kind := Body_Part; + Last := Last - Name_Len; + + if Current_Verbosity = High then + Write_Str (" Body: "); + Write_Line (File (First .. Last)); + end if; + + elsif Naming.Separate_Append /= Naming.Body_Append then + Get_Name_String (Naming.Separate_Append); + + -- Check if the end of the file name is Separate_Append + + if File'Length > Name_Len + and then File (Last - Name_Len + 1 .. Last) = + Name_Buffer (1 .. Name_Len) + then + -- We have a separate (a body) + + Unit_Kind := Body_Part; + Last := Last - Name_Len; + + if Current_Verbosity = High then + Write_Str (" Separate: "); + Write_Line (File (First .. Last)); + end if; + + else + Last := 0; + end if; + + else + Last := 0; + end if; + end if; + + if Last = 0 then + + -- This is not a source file + + Unit_Name := No_Name; + Unit_Kind := Specification; + + if Current_Verbosity = High then + Write_Line (" Not a valid file name."); + end if; + + return; + end if; + + Get_Name_String (Naming.Dot_Replacement); + + if Name_Buffer (1 .. Name_Len) /= "." then + + -- If Dot_Replacement is not a single dot, + -- then there should not be any dot in the name. + + for Index in First .. Last loop + if File (Index) = '.' then + if Current_Verbosity = High then + Write_Line + (" Not a valid file name (some dot not replaced)."); + end if; + + Unit_Name := No_Name; + return; + + end if; + end loop; + + -- Replace the substring Dot_Replacement with dots + + declare + Index : Positive := First; + + begin + while Index <= Last - Name_Len + 1 loop + + if File (Index .. Index + Name_Len - 1) = + Name_Buffer (1 .. Name_Len) + then + File (Index) := '.'; + + if Name_Len > 1 and then Index < Last then + File (Index + 1 .. Last - Name_Len + 1) := + File (Index + Name_Len .. Last); + end if; + + Last := Last - Name_Len + 1; + end if; + + Index := Index + 1; + end loop; + end; + end if; + + -- Check if the casing is right + + declare + Src : String := File (First .. Last); + + begin + case Naming.Casing is + when All_Lower_Case => + Fixed.Translate + (Source => Src, + Mapping => Lower_Case_Map); + + when All_Upper_Case => + Fixed.Translate + (Source => Src, + Mapping => Upper_Case_Map); + + when Mixed_Case | Unknown => + null; + end case; + + if Src /= File (First .. Last) then + if Current_Verbosity = High then + Write_Line (" Not a valid file name (casing)."); + end if; + + Unit_Name := No_Name; + return; + end if; + + -- We put the name in lower case + + Fixed.Translate + (Source => Src, + Mapping => Lower_Case_Map); + + if Current_Verbosity = High then + Write_Str (" "); + Write_Line (Src); + end if; + + Name_Len := Src'Length; + Name_Buffer (1 .. Name_Len) := Src; + + -- Now, we check if this name is a valid unit name + + Check_Naming_Scheme (Name => Name_Find, Unit => Unit_Name); + end; + + end; + + end Get_Unit; + + ----------------------- + -- Is_Illegal_Append -- + ----------------------- + + function Is_Illegal_Append (This : String) return Boolean is + begin + return This'Length = 0 + or else Is_Alphanumeric (This (This'First)) + or else (This'Length >= 2 + and then This (This'First) = '_' + and then Is_Alphanumeric (This (This'First + 1))); + end Is_Illegal_Append; + + ---------------------- + -- Locate_Directory -- + ---------------------- + + function Locate_Directory + (Name : Name_Id; + Parent : Name_Id) + return Name_Id + is + The_Name : constant String := Get_Name_String (Name); + The_Parent : constant String := + Get_Name_String (Parent) & Dir_Sep; + + The_Parent_Last : Positive := The_Parent'Last; + + begin + if The_Parent'Length > 1 + and then (The_Parent (The_Parent_Last - 1) = Dir_Sep + or else The_Parent (The_Parent_Last - 1) = '/') + then + The_Parent_Last := The_Parent_Last - 1; + end if; + + if Current_Verbosity = High then + Write_Str ("Locate_Directory ("""); + Write_Str (The_Name); + Write_Str (""", """); + Write_Str (The_Parent); + Write_Line (""")"); + end if; + + if Is_Absolute_Path (The_Name) then + if Is_Directory (The_Name) then + return Name; + end if; + + else + declare + Full_Path : constant String := + The_Parent (The_Parent'First .. The_Parent_Last) & + The_Name; + + begin + if Is_Directory (Full_Path) then + Name_Len := Full_Path'Length; + Name_Buffer (1 .. Name_Len) := Full_Path; + return Name_Find; + end if; + end; + + end if; + + return No_Name; + end Locate_Directory; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of + (File_Name : String_Id; + Directory : String_Id) + return String + is + Result : String_Access; + + begin + String_To_Name_Buffer (File_Name); + + declare + The_File_Name : constant String := Name_Buffer (1 .. Name_Len); + + begin + String_To_Name_Buffer (Directory); + Result := Locate_Regular_File + (File_Name => The_File_Name, + Path => Name_Buffer (1 .. Name_Len)); + end; + + if Result = null then + return ""; + else + Canonical_Case_File_Name (Result.all); + return Result.all; + end if; + end Path_Name_Of; + + function Path_Name_Of + (File_Name : String_Id; + Directory : Name_Id) + return String + is + Result : String_Access; + The_Directory : constant String := Get_Name_String (Directory); + + begin + String_To_Name_Buffer (File_Name); + Result := Locate_Regular_File + (File_Name => Name_Buffer (1 .. Name_Len), + Path => The_Directory); + + if Result = null then + return ""; + else + Canonical_Case_File_Name (Result.all); + return Result.all; + end if; + end Path_Name_Of; + + ------------------- + -- Record_Source -- + ------------------- + + procedure Record_Source + (File_Name : Name_Id; + Path_Name : Name_Id; + Project : Project_Id; + Data : in out Project_Data; + Error_If_Invalid : Boolean; + Location : Source_Ptr; + Current_Source : in out String_List_Id) + is + Unit_Name : Name_Id; + Unit_Kind : Spec_Or_Body; + Needs_Pragma : Boolean; + The_Location : Source_Ptr := Location; + + begin + -- Find out the unit name, the unit kind and if it needs + -- a specific SFN pragma. + + Get_Unit + (File_Name => File_Name, + Naming => Data.Naming, + Unit_Name => Unit_Name, + Unit_Kind => Unit_Kind, + Needs_Pragma => Needs_Pragma); + + -- If it is not a source file, report an error only if + -- Error_If_Invalid is true. + + if Unit_Name = No_Name then + if Error_If_Invalid then + Error_Msg_Name_1 := File_Name; + Error_Msg + ("{ is not a valid source file name", + Location); + + else + if Current_Verbosity = High then + Write_Str (" """); + Write_Str (Get_Name_String (File_Name)); + Write_Line (""" is not a valid source file name (ignored)."); + end if; + end if; + + else + -- Put the file name in the list of sources of the project + + String_Elements.Increment_Last; + Get_Name_String (File_Name); + Start_String; + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + String_Elements.Table (String_Elements.Last) := + (Value => End_String, + Location => No_Location, + Next => Nil_String); + + if Current_Source = Nil_String then + Data.Sources := String_Elements.Last; + + else + String_Elements.Table (Current_Source).Next := + String_Elements.Last; + end if; + + Current_Source := String_Elements.Last; + + -- Put the unit in unit list + + declare + The_Unit : Unit_Id := Units_Htable.Get (Unit_Name); + The_Unit_Data : Unit_Data; + + begin + if Current_Verbosity = High then + Write_Str ("Putting "); + Write_Str (Get_Name_String (Unit_Name)); + Write_Line (" in the unit list."); + end if; + + -- The unit is already in the list, but may be it is + -- only the other unit kind (spec or body), or what is + -- in the unit list is a unit of a project we are modifying. + + if The_Unit /= Prj.Com.No_Unit then + The_Unit_Data := Units.Table (The_Unit); + + if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name + or else (Data.Modifies /= No_Project + and then + The_Unit_Data.File_Names (Unit_Kind).Project = + Data.Modifies) + then + The_Unit_Data.File_Names (Unit_Kind) := + (Name => File_Name, + Path => Path_Name, + Project => Project, + Needs_Pragma => Needs_Pragma); + Units.Table (The_Unit) := The_Unit_Data; + + else + -- It is an error to have two units with the same name + -- and the same kind (spec or body). + + if The_Location = No_Location then + The_Location := Projects.Table (Project).Location; + end if; + + Error_Msg_Name_1 := Unit_Name; + Error_Msg ("duplicate source {", The_Location); + + Error_Msg_Name_1 := + Projects.Table + (The_Unit_Data.File_Names (Unit_Kind).Project).Name; + Error_Msg_Name_2 := + The_Unit_Data.File_Names (Unit_Kind).Path; + Error_Msg ("\ project file {, {", The_Location); + + Error_Msg_Name_1 := Projects.Table (Project).Name; + Error_Msg_Name_2 := Path_Name; + Error_Msg ("\ project file {, {", The_Location); + + end if; + + -- It is a new unit, create a new record + + else + Units.Increment_Last; + The_Unit := Units.Last; + Units_Htable.Set (Unit_Name, The_Unit); + The_Unit_Data.Name := Unit_Name; + The_Unit_Data.File_Names (Unit_Kind) := + (Name => File_Name, + Path => Path_Name, + Project => Project, + Needs_Pragma => Needs_Pragma); + Units.Table (The_Unit) := The_Unit_Data; + end if; + end; + end if; + end Record_Source; + + ---------------------- + -- Show_Source_Dirs -- + ---------------------- + + procedure Show_Source_Dirs (Project : Project_Id) is + Current : String_List_Id := Projects.Table (Project).Source_Dirs; + Element : String_Element; + + begin + Write_Line ("Source_Dirs:"); + + while Current /= Nil_String loop + Element := String_Elements.Table (Current); + Write_Str (" "); + Write_Line (Get_Name_String (Element.Value)); + Current := Element.Next; + end loop; + + Write_Line ("end Source_Dirs."); + end Show_Source_Dirs; + +end Prj.Nmsc; diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads new file mode 100644 index 00000000000..5fcc00538da --- /dev/null +++ b/gcc/ada/prj-nmsc.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . N M S C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- Check the Naming Scheme of a project file, find the directories +-- and the source files. + +private package Prj.Nmsc is + + procedure Check_Naming_Scheme + (Project : Project_Id; + Report_Error : Put_Line_Access); + -- Check that the Naming Scheme of a project is legal. Find the + -- object directory, the source directories, and the source files. + -- Check the source files against the Naming Scheme. + -- If Report_Error is null , use the standard error reporting mechanism + -- (Errout). Otherwise, report errors using Report_Error. + +end Prj.Nmsc; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb new file mode 100644 index 00000000000..620d2e113a9 --- /dev/null +++ b/gcc/ada/prj-pars.adb @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.19 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; + +with Errout; use Errout; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Part; +with Prj.Proc; +with Prj.Tree; use Prj.Tree; + +package body Prj.Pars is + + ----------- + -- Parse -- + ----------- + + procedure Parse + (Project : out Project_Id; + Project_File_Name : String) + is + Project_Tree : Project_Node_Id := Empty_Node; + The_Project : Project_Id := No_Project; + + begin + -- Parse the main project file into a tree + + Prj.Part.Parse + (Project => Project_Tree, + Project_File_Name => Project_File_Name, + Always_Errout_Finalize => False); + + -- If there were no error, process the tree + + if Project_Tree /= Empty_Node then + Prj.Proc.Process + (Project => The_Project, + From_Project_Node => Project_Tree, + Report_Error => null); + Errout.Finalize; + end if; + + Project := The_Project; + + exception + when X : others => + + -- Internal error + + Write_Line (Exception_Information (X)); + Write_Str ("Exception "); + Write_Str (Exception_Name (X)); + Write_Line (" raised, while processing project file"); + Project := No_Project; + end Parse; + + ------------------- + -- Set_Verbosity -- + ------------------- + + procedure Set_Verbosity (To : in Verbosity) is + begin + Current_Verbosity := To; + end Set_Verbosity; + +end Prj.Pars; diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads new file mode 100644 index 00000000000..0adaf72f4c2 --- /dev/null +++ b/gcc/ada/prj-pars.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- Implements the parsing of project files. + +package Prj.Pars is + + procedure Set_Verbosity (To : Verbosity); + -- Set the verbosity when parsing the project files. + + procedure Parse + (Project : out Project_Id; + Project_File_Name : String); + -- Parse a project files and all its imported project files. + -- If parsing is successful, Project_Id is the project ID + -- of the main project file; otherwise, Project_Id is set + -- to No_Project. + +end Prj.Pars; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb new file mode 100644 index 00000000000..8100ad49e95 --- /dev/null +++ b/gcc/ada/prj-part.adb @@ -0,0 +1,871 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; +with Errout; use Errout; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Dect; +with Scans; use Scans; +with Scn; use Scn; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Sinput.P; use Sinput.P; +with Stringt; use Stringt; +with Table; +with Types; use Types; + +pragma Elaborate_All (GNAT.OS_Lib); + +package body Prj.Part is + + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + + Project_File_Extension : String := ".gpr"; + + Project_Path : String_Access; + -- The project path; initialized during package elaboration. + + Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; + Prj_Path : constant String_Access := Getenv (Ada_Project_Path); + + ------------------------------------ + -- Local Packages and Subprograms -- + ------------------------------------ + + package Project_Stack is new Table.Table + (Table_Component_Type => Name_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 10, + Table_Name => "Prj.Part.Project_Stack"); + -- This table is used to detect circular dependencies + -- for imported and modified projects. + + procedure Parse_Context_Clause + (Context_Clause : out Project_Node_Id; + Project_Directory : Name_Id); + -- Parse the context clause of a project + -- Does nothing if there is b\no context clause (if the current + -- token is not "with"). + + procedure Parse_Single_Project + (Project : out Project_Node_Id; + Path_Name : String; + Modified : Boolean); + -- Parse a project file. + -- Recursive procedure: it calls itself for imported and + -- modified projects. + + function Path_Name_Of + (File_Name : String; + Directory : String) + return String; + -- Returns the path name of a (non project) file. + -- Returns an empty string if file cannot be found. + + function Project_Path_Name_Of + (Project_File_Name : String; + Directory : String) + return String; + -- Returns the path name of a project file. + -- Returns an empty string if project file cannot be found. + + function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id; + -- Get the directory of the file with the specified path name. + -- This includes the directory separator as the last character. + -- Returns "./" if Path_Name contains no directory separator. + + function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id; + -- Returns the name of a file with the specified path name + -- with no directory information. + + function Project_Name_From (Path_Name : String) return Name_Id; + -- Returns the name of the project that corresponds to its path name. + -- Returns No_Name if the path name is invalid, because the corresponding + -- project name does not have the syntax of an ada identifier. + + ---------------------------- + -- Immediate_Directory_Of -- + ---------------------------- + + function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is + begin + Get_Name_String (Path_Name); + + for Index in reverse 1 .. Name_Len loop + if Name_Buffer (Index) = '/' + or else Name_Buffer (Index) = Dir_Sep + then + -- Remove from name all characters after the last + -- directory separator. + + Name_Len := Index; + return Name_Find; + end if; + end loop; + + -- There is no directory separator in name. Return "./" or ".\". + Name_Len := 2; + Name_Buffer (1) := '.'; + Name_Buffer (2) := Dir_Sep; + return Name_Find; + end Immediate_Directory_Of; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (Project : out Project_Node_Id; + Project_File_Name : String; + Always_Errout_Finalize : Boolean) + is + Current_Directory : constant String := Get_Current_Dir; + + begin + Project := Empty_Node; + + if Current_Verbosity >= Medium then + Write_Str ("ADA_PROJECT_PATH="""); + Write_Str (Project_Path.all); + Write_Line (""""); + end if; + + declare + Path_Name : constant String := + Project_Path_Name_Of (Project_File_Name, + Directory => Current_Directory); + + begin + -- Initialize the tables + + Tree_Private_Part.Project_Nodes.Set_Last (Empty_Node); + Tree_Private_Part.Projects_Htable.Reset; + + Errout.Initialize; + + -- And parse the main project file + + if Path_Name = "" then + Fail ("project file """ & Project_File_Name & """ not found"); + end if; + + Parse_Single_Project + (Project => Project, + Path_Name => Path_Name, + Modified => False); + + if Errout.Errors_Detected > 0 then + Project := Empty_Node; + end if; + + if Project = Empty_Node or else Always_Errout_Finalize then + Errout.Finalize; + end if; + end; + + exception + when X : others => + + -- Internal error + + Write_Line (Exception_Information (X)); + Write_Str ("Exception "); + Write_Str (Exception_Name (X)); + Write_Line (" raised, while processing project file"); + Project := Empty_Node; + end Parse; + + -------------------------- + -- Parse_Context_Clause -- + -------------------------- + + procedure Parse_Context_Clause + (Context_Clause : out Project_Node_Id; + Project_Directory : Name_Id) + is + Project_Directory_Path : constant String := + Get_Name_String (Project_Directory); + Current_With_Clause : Project_Node_Id := Empty_Node; + Next_With_Clause : Project_Node_Id := Empty_Node; + + begin + -- Assume no context clause + + Context_Clause := Empty_Node; + With_Loop : + + -- If Token is not "with", there is no context clause, + -- or we have exhausted the with clauses. + + while Token = Tok_With loop + Comma_Loop : + loop + -- Scan past "with" or "," + + Scan; + Expect (Tok_String_Literal, "literal string"); + + if Token /= Tok_String_Literal then + return; + end if; + + -- New with clause + + if Current_With_Clause = Empty_Node then + + -- First with clause of the context clause + + Current_With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause); + Context_Clause := Current_With_Clause; + + else + Next_With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause); + Set_Next_With_Clause_Of (Current_With_Clause, Next_With_Clause); + Current_With_Clause := Next_With_Clause; + end if; + + Set_String_Value_Of (Current_With_Clause, Strval (Token_Node)); + Set_Location_Of (Current_With_Clause, Token_Ptr); + String_To_Name_Buffer (String_Value_Of (Current_With_Clause)); + + declare + Original_Path : constant String := + Name_Buffer (1 .. Name_Len); + + Imported_Path_Name : constant String := + Project_Path_Name_Of + (Original_Path, + Project_Directory_Path); + + Withed_Project : Project_Node_Id := Empty_Node; + + begin + if Imported_Path_Name = "" then + + -- The project file cannot be found + + Name_Len := Original_Path'Length; + Name_Buffer (1 .. Name_Len) := Original_Path; + Error_Msg_Name_1 := Name_Find; + + Error_Msg ("unknown project file: {", Token_Ptr); + + else + -- Parse the imported project + + Parse_Single_Project + (Project => Withed_Project, + Path_Name => Imported_Path_Name, + Modified => False); + + if Withed_Project /= Empty_Node then + + -- If parsing was successful, record project name + -- and path name in with clause + + Set_Project_Node_Of (Current_With_Clause, Withed_Project); + Set_Name_Of (Current_With_Clause, + Name_Of (Withed_Project)); + Name_Len := Imported_Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Imported_Path_Name; + Set_Path_Name_Of (Current_With_Clause, Name_Find); + end if; + end if; + end; + + Scan; + if Token = Tok_Semicolon then + + -- End of (possibly multiple) with clause; + -- Scan past the semicolon. + + Scan; + exit Comma_Loop; + + elsif Token /= Tok_Comma then + Error_Msg ("expected comma or semi colon", Token_Ptr); + exit Comma_Loop; + end if; + end loop Comma_Loop; + end loop With_Loop; + + end Parse_Context_Clause; + + -------------------------- + -- Parse_Single_Project -- + -------------------------- + + procedure Parse_Single_Project + (Project : out Project_Node_Id; + Path_Name : String; + Modified : Boolean) + is + Canonical_Path_Name : Name_Id; + Project_Directory : Name_Id; + Project_Scan_State : Saved_Project_Scan_State; + Source_Index : Source_File_Index; + + Modified_Project : Project_Node_Id := Empty_Node; + + A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_First; + + Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); + + use Tree_Private_Part; + + begin + Name_Len := Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Path_Name; + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Canonical_Path_Name := Name_Find; + + -- Check for a circular dependency + + for Index in 1 .. Project_Stack.Last loop + if Canonical_Path_Name = Project_Stack.Table (Index) then + Error_Msg ("circular dependency detected", Token_Ptr); + Error_Msg_Name_1 := Canonical_Path_Name; + Error_Msg ("\ { is imported by", Token_Ptr); + + for Current in reverse 1 .. Project_Stack.Last loop + Error_Msg_Name_1 := Project_Stack.Table (Current); + + if Error_Msg_Name_1 /= Canonical_Path_Name then + Error_Msg + ("\ { which itself is imported by", Token_Ptr); + + else + Error_Msg ("\ {", Token_Ptr); + exit; + end if; + end loop; + + Project := Empty_Node; + return; + end if; + end loop; + + Project_Stack.Increment_Last; + Project_Stack.Table (Project_Stack.Last) := Canonical_Path_Name; + + -- Check if the project file has already been parsed. + + while + A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node + loop + if + Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name + then + if Modified then + + if A_Project_Name_And_Node.Modified then + Error_Msg + ("cannot modify several times the same project file", + Token_Ptr); + + else + Error_Msg + ("cannot modify an imported project file", + Token_Ptr); + end if; + + elsif A_Project_Name_And_Node.Modified then + Error_Msg + ("cannot imported a modified project file", + Token_Ptr); + end if; + + Project := A_Project_Name_And_Node.Node; + Project_Stack.Decrement_Last; + return; + end if; + + A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next; + end loop; + + -- We never encountered this project file + -- Save the scan state, load the project file and start to scan it. + + Save_Project_Scan_State (Project_Scan_State); + Source_Index := Load_Project_File (Path_Name); + + -- if we cannot find it, we stop + + if Source_Index = No_Source_File then + Project := Empty_Node; + Project_Stack.Decrement_Last; + return; + end if; + + Initialize_Scanner (Types.No_Unit, Source_Index); + + if Name_From_Path = No_Name then + + -- The project file name is not correct (no or bad extension, + -- or not following Ada identifier's syntax). + + Error_Msg_Name_1 := Canonical_Path_Name; + Error_Msg ("?{ is not a valid path name for a project file", + Token_Ptr); + end if; + + if Current_Verbosity >= Medium then + Write_Str ("Parsing """); + Write_Str (Path_Name); + Write_Char ('"'); + Write_Eol; + end if; + + Project_Directory := Immediate_Directory_Of (Canonical_Path_Name); + Project := Default_Project_Node (Of_Kind => N_Project); + Set_Directory_Of (Project, Project_Directory); + Set_Name_Of (Project, Simple_File_Name_Of (Canonical_Path_Name)); + Set_Path_Name_Of (Project, Canonical_Path_Name); + Set_Location_Of (Project, Token_Ptr); + + -- Is there any imported project? + + declare + First_With_Clause : Project_Node_Id := Empty_Node; + + begin + Parse_Context_Clause (Context_Clause => First_With_Clause, + Project_Directory => Project_Directory); + Set_First_With_Clause_Of (Project, First_With_Clause); + end; + + Expect (Tok_Project, "project"); + + -- Scan past "project" + + if Token = Tok_Project then + Set_Location_Of (Project, Token_Ptr); + Scan; + end if; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Project, Token_Name); + + Get_Name_String (Token_Name); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Expected_Name : constant Name_Id := Name_Find; + + begin + if Name_From_Path /= No_Name + and then Expected_Name /= Name_From_Path + then + -- The project name is not the one that was expected from + -- the file name. Report a warning. + + Error_Msg_Name_1 := Expected_Name; + Error_Msg ("?file name does not match unit name, " & + "should be `{" & Project_File_Extension & "`", + Token_Ptr); + end if; + end; + + declare + Project_Name : Name_Id := + Tree_Private_Part.Projects_Htable.Get_First.Name; + + begin + -- Check if we already have a project with this name + + while Project_Name /= No_Name + and then Project_Name /= Token_Name + loop + Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name; + end loop; + + if Project_Name /= No_Name then + Error_Msg ("duplicate project name", Token_Ptr); + + else + Tree_Private_Part.Projects_Htable.Set + (K => Token_Name, + E => (Name => Token_Name, + Node => Project, + Modified => Modified)); + end if; + end; + + -- Scan past the project name + + Scan; + + end if; + + if Token = Tok_Modifying then + + -- We are modifying another project + + -- Scan past "modifying" + + Scan; + + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Modified_Project_Path_Of (Project, Strval (Token_Node)); + String_To_Name_Buffer (Modified_Project_Path_Of (Project)); + + declare + Original_Path_Name : constant String := + Name_Buffer (1 .. Name_Len); + + Modified_Project_Path_Name : constant String := + Project_Path_Name_Of + (Original_Path_Name, + Get_Name_String + (Project_Directory)); + + begin + if Modified_Project_Path_Name = "" then + + -- We could not find the project file to modify + + Name_Len := Original_Path_Name'Length; + Name_Buffer (1 .. Name_Len) := Original_Path_Name; + Error_Msg_Name_1 := Name_Find; + + Error_Msg ("unknown project file: {", Token_Ptr); + + else + Parse_Single_Project + (Project => Modified_Project, + Path_Name => Modified_Project_Path_Name, + Modified => True); + end if; + end; + + -- Scan past the modified project path + + Scan; + end if; + end if; + + Expect (Tok_Is, "is"); + + declare + Project_Declaration : Project_Node_Id := Empty_Node; + + begin + -- No need to Scan past "is", Prj.Dect.Parse will do it. + + Prj.Dect.Parse + (Declarations => Project_Declaration, + Current_Project => Project, + Modifying => Modified_Project); + Set_Project_Declaration_Of (Project, Project_Declaration); + end; + + Expect (Tok_End, "end"); + + -- Scan past "end" + + if Token = Tok_End then + Scan; + end if; + + Expect (Tok_Identifier, "identifier"); + + if Token = Tok_Identifier then + + -- We check if this is the project name + + if To_Lower (Get_Name_String (Token_Name)) /= + Get_Name_String (Name_Of (Project)) + then + Error_Msg ("Expected """ & + Get_Name_String (Name_Of (Project)) & """", + Token_Ptr); + end if; + end if; + + if Token /= Tok_Semicolon then + Scan; + end if; + + Expect (Tok_Semicolon, ";"); + + -- Restore the scan state, in case we are not the main project + + Restore_Project_Scan_State (Project_Scan_State); + + Project_Stack.Decrement_Last; + end Parse_Single_Project; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of + (File_Name : String; + Directory : String) + return String + is + Result : String_Access; + + begin + Result := Locate_Regular_File (File_Name => File_Name, + Path => Directory); + + if Result = null then + return ""; + + else + Canonical_Case_File_Name (Result.all); + return Result.all; + end if; + end Path_Name_Of; + + ----------------------- + -- Project_Name_From -- + ----------------------- + + function Project_Name_From (Path_Name : String) return Name_Id is + Canonical : String (1 .. Path_Name'Length) := Path_Name; + First : Natural := Canonical'Last; + Last : Positive := First; + + begin + if First = 0 then + return No_Name; + end if; + + Canonical_Case_File_Name (Canonical); + + while First > 0 + and then + Canonical (First) /= '.' + loop + First := First - 1; + end loop; + + if Canonical (First) = '.' then + if Canonical (First .. Last) = Project_File_Extension + and then First /= 1 + then + First := First - 1; + Last := First; + + while First > 0 + and then Canonical (First) /= '/' + and then Canonical (First) /= Dir_Sep + loop + First := First - 1; + end loop; + + else + return No_Name; + end if; + + else + return No_Name; + end if; + + if Canonical (First) = '/' + or else Canonical (First) = Dir_Sep + then + First := First + 1; + end if; + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); + + if not Is_Letter (Name_Buffer (1)) then + return No_Name; + + else + for Index in 2 .. Name_Len - 1 loop + if Name_Buffer (Index) = '_' then + if Name_Buffer (Index + 1) = '_' then + return No_Name; + end if; + + elsif not Is_Alphanumeric (Name_Buffer (Index)) then + return No_Name; + end if; + + end loop; + + if not Is_Alphanumeric (Name_Buffer (Name_Len)) then + return No_Name; + + else + return Name_Find; + end if; + + end if; + end Project_Name_From; + + -------------------------- + -- Project_Path_Name_Of -- + -------------------------- + + function Project_Path_Name_Of + (Project_File_Name : String; + Directory : String) + return String + is + Result : String_Access; + + begin + -- First we try <file_name>.<extension> + + if Current_Verbosity = High then + Write_Str ("Project_Path_Name_Of ("""); + Write_Str (Project_File_Name); + Write_Str (""", """); + Write_Str (Directory); + Write_Line (""");"); + Write_Str (" Trying "); + Write_Str (Project_File_Name); + Write_Line (Project_File_Extension); + end if; + + Result := + Locate_Regular_File + (File_Name => Project_File_Name & Project_File_Extension, + Path => Project_Path.all); + + -- Then we try <file_name> + + if Result = null then + if Current_Verbosity = High then + Write_Str (" Trying "); + Write_Line (Project_File_Name); + end if; + + Result := + Locate_Regular_File + (File_Name => Project_File_Name, + Path => Project_Path.all); + + -- The we try <directory>/<file_name>.<extension> + + if Result = null then + if Current_Verbosity = High then + Write_Str (" Trying "); + Write_Str (Directory); + Write_Str (Project_File_Name); + Write_Line (Project_File_Extension); + end if; + + Result := + Locate_Regular_File + (File_Name => Directory & Project_File_Name & + Project_File_Extension, + Path => Project_Path.all); + + -- Then we try <directory>/<file_name> + + if Result = null then + if Current_Verbosity = High then + Write_Str (" Trying "); + Write_Str (Directory); + Write_Line (Project_File_Name); + end if; + + Result := + Locate_Regular_File + (File_Name => Directory & Project_File_Name, + Path => Project_Path.all); + end if; + end if; + end if; + + -- If we cannot find the project file, we return an empty string + + if Result = null then + return ""; + + else + declare + Final_Result : String + := GNAT.OS_Lib.Normalize_Pathname (Result.all); + begin + Free (Result); + Canonical_Case_File_Name (Final_Result); + return Final_Result; + end; + + end if; + + end Project_Path_Name_Of; + + ------------------------- + -- Simple_File_Name_Of -- + ------------------------- + + function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id is + begin + Get_Name_String (Path_Name); + + for Index in reverse 1 .. Name_Len loop + if Name_Buffer (Index) = '/' + or else Name_Buffer (Index) = Dir_Sep + then + exit when Index = Name_Len; + Name_Buffer (1 .. Name_Len - Index) := + Name_Buffer (Index + 1 .. Name_Len); + Name_Len := Name_Len - Index; + return Name_Find; + end if; + end loop; + + return No_Name; + + end Simple_File_Name_Of; + +begin + Canonical_Case_File_Name (Project_File_Extension); + + if Prj_Path.all = "" then + Project_Path := new String'("."); + + else + Project_Path := new String'("." & Path_Separator & Prj_Path.all); + end if; + +end Prj.Part; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads new file mode 100644 index 00000000000..d960b732b35 --- /dev/null +++ b/gcc/ada/prj-part.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- Implements the parsing of project files into a tree. + +with Prj.Tree; use Prj.Tree; + +package Prj.Part is + + procedure Parse + (Project : out Project_Node_Id; + Project_File_Name : String; + Always_Errout_Finalize : Boolean); + -- Parse a project file and all its imported project files + -- and create a tree. + -- Return the node for the project (or Empty_Node if parsing failed). + -- If Always_Errout_Finalize is True, Errout.Finalize is called + -- in all cases; otherwise, Errout.Finalize is only called if there are + -- errors (but not if there are only warnings). + +end Prj.Part; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb new file mode 100644 index 00000000000..4822596f964 --- /dev/null +++ b/gcc/ada/prj-proc.adb @@ -0,0 +1,1371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P R O C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Errout; use Errout; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Attr; use Prj.Attr; +with Prj.Com; use Prj.Com; +with Prj.Ext; use Prj.Ext; +with Prj.Nmsc; use Prj.Nmsc; +with Stringt; use Stringt; + +with GNAT.HTable; + +package body Prj.Proc is + + Error_Report : Put_Line_Access := null; + + package Processed_Projects is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Id, + No_Element => No_Project, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains all processed projects + + procedure Add (To_Exp : in out String_Id; Str : String_Id); + -- Concatenate two strings and returns another string if both + -- arguments are not null string. + + procedure Add_Attributes + (Decl : in out Declarations; + First : Attribute_Node_Id); + -- Add all attributes, starting with First, with their default + -- values to the package or project with declarations Decl. + + function Expression + (Project : Project_Id; + From_Project_Node : Project_Node_Id; + Pkg : Package_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind) + return Variable_Value; + -- From N_Expression project node From_Project_Node, compute the value + -- of an expression and return it as a Variable_Value. + + function Imported_Or_Modified_Project_From + (Project : Project_Id; + With_Name : Name_Id) + return Project_Id; + -- Find an imported or modified project of Project whose name is With_Name. + + function Package_From + (Project : Project_Id; + With_Name : Name_Id) + return Package_Id; + -- Find the package of Project whose name is With_Name. + + procedure Process_Declarative_Items + (Project : Project_Id; + From_Project_Node : Project_Node_Id; + Pkg : Package_Id; + Item : Project_Node_Id); + -- Process declarative items starting with From_Project_Node, and put them + -- in declarations Decl. This is a recursive procedure; it calls itself for + -- a package declaration or a case construction. + + procedure Recursive_Process + (Project : out Project_Id; + From_Project_Node : Project_Node_Id; + Modified_By : Project_Id); + -- Process project with node From_Project_Node in the tree. + -- Do nothing if From_Project_Node is Empty_Node. + -- If project has already been processed, simply return its project id. + -- Otherwise create a new project id, mark it as processed, call itself + -- recursively for all imported projects and a modified project, if any. + -- Then process the declarative items of the project. + + procedure Check (Project : in out Project_Id); + -- Set all projects to not checked, then call Recursive_Check for + -- the main project Project. + -- Project is set to No_Project if errors occurred. + + procedure Recursive_Check (Project : Project_Id); + -- If Project is marked as not checked, mark it as checked, + -- call Check_Naming_Scheme for the project, then call itself + -- for a possible modified project and all the imported projects + -- of Project. + + --------- + -- Add -- + --------- + + procedure Add (To_Exp : in out String_Id; Str : String_Id) is + begin + if To_Exp = Types.No_String or else String_Length (To_Exp) = 0 then + + -- To_Exp is nil or empty. The result is Str. + + To_Exp := Str; + + -- If Str is nil, then do not change To_Ext + + elsif Str /= No_String then + Start_String (To_Exp); + Store_String_Chars (Str); + To_Exp := End_String; + end if; + end Add; + + -------------------- + -- Add_Attributes -- + -------------------- + + procedure Add_Attributes + (Decl : in out Declarations; + First : Attribute_Node_Id) is + The_Attribute : Attribute_Node_Id := First; + Attribute_Data : Attribute_Record; + + begin + while The_Attribute /= Empty_Attribute loop + Attribute_Data := Attributes.Table (The_Attribute); + + if Attribute_Data.Kind_2 /= Associative_Array then + declare + New_Attribute : Variable_Value; + + begin + case Attribute_Data.Kind_1 is + + -- Undefined should not happen + + when Undefined => + pragma Assert + (False, "attribute with an undefined kind"); + raise Program_Error; + + -- Single attributes have a default value of empty string + + when Single => + New_Attribute := + (Kind => Single, + Location => No_Location, + Default => True, + Value => Empty_String); + + -- List attributes have a default value of nil list + + when List => + New_Attribute := + (Kind => List, + Location => No_Location, + Default => True, + Values => Nil_String); + + end case; + + Variable_Elements.Increment_Last; + Variable_Elements.Table (Variable_Elements.Last) := + (Next => Decl.Attributes, + Name => Attribute_Data.Name, + Value => New_Attribute); + Decl.Attributes := Variable_Elements.Last; + end; + end if; + + The_Attribute := Attributes.Table (The_Attribute).Next; + end loop; + + end Add_Attributes; + + ----------- + -- Check -- + ----------- + + procedure Check (Project : in out Project_Id) is + begin + -- Make sure that all projects are marked as not checked. + + for Index in 1 .. Projects.Last loop + Projects.Table (Index).Checked := False; + end loop; + + Recursive_Check (Project); + + if Errout.Errors_Detected > 0 then + Project := No_Project; + end if; + + end Check; + + ---------------- + -- Expression -- + ---------------- + + function Expression + (Project : Project_Id; + From_Project_Node : Project_Node_Id; + Pkg : Package_Id; + First_Term : Project_Node_Id; + Kind : Variable_Kind) + return Variable_Value + is + The_Term : Project_Node_Id := First_Term; + -- The term in the expression list + + The_Current_Term : Project_Node_Id := Empty_Node; + -- The current term node id + + Term_Kind : Variable_Kind; + -- The kind of the current term + + Result : Variable_Value (Kind => Kind); + -- The returned result + + Last : String_List_Id := Nil_String; + -- Reference to the last string elements in Result, when Kind is List. + + begin + Result.Location := Location_Of (From_Project_Node); + + -- Process each term of the expression, starting with First_Term + + while The_Term /= Empty_Node loop + + -- We get the term data and kind ... + + Term_Kind := Expression_Kind_Of (The_Term); + + The_Current_Term := Current_Term (The_Term); + + case Kind_Of (The_Current_Term) is + + when N_Literal_String => + + case Kind is + + when Undefined => + + -- Should never happen + + pragma Assert (False, "Undefined expression kind"); + raise Program_Error; + + when Single => + Add (Result.Value, String_Value_Of (The_Current_Term)); + + when List => + + String_Elements.Increment_Last; + + if Last = Nil_String then + + -- This can happen in an expression such as + -- () & "toto" + + Result.Values := String_Elements.Last; + + else + String_Elements.Table (Last).Next := + String_Elements.Last; + end if; + + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => String_Value_Of (The_Current_Term), + Location => Location_Of (The_Current_Term), + Next => Nil_String); + + end case; + + when N_Literal_String_List => + + declare + String_Node : Project_Node_Id := + First_Expression_In_List (The_Current_Term); + + Value : Variable_Value; + + begin + if String_Node /= Empty_Node then + + -- If String_Node is nil, it is an empty list, + -- there is nothing to do + + Value := Expression + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => Pkg, + First_Term => Tree.First_Term (String_Node), + Kind => Single); + String_Elements.Increment_Last; + + if Result.Values = Nil_String then + + -- This literal string list is the first term + -- in a string list expression + + Result.Values := String_Elements.Last; + + else + String_Elements.Table (Last).Next := + String_Elements.Last; + end if; + + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => Value.Value, + Location => Value.Location, + Next => Nil_String); + + loop + -- Add the other element of the literal string list + -- one after the other + + String_Node := + Next_Expression_In_List (String_Node); + + exit when String_Node = Empty_Node; + + Value := + Expression + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => Pkg, + First_Term => Tree.First_Term (String_Node), + Kind => Single); + + String_Elements.Increment_Last; + String_Elements.Table (Last).Next := + String_Elements.Last; + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => Value.Value, + Location => Value.Location, + Next => Nil_String); + end loop; + + end if; + + end; + + when N_Variable_Reference | N_Attribute_Reference => + + declare + The_Project : Project_Id := Project; + The_Package : Package_Id := Pkg; + The_Name : Name_Id := No_Name; + The_Variable_Id : Variable_Id := No_Variable; + The_Variable : Variable; + Term_Project : constant Project_Node_Id := + Project_Node_Of (The_Current_Term); + Term_Package : constant Project_Node_Id := + Package_Node_Of (The_Current_Term); + + begin + if Term_Project /= Empty_Node and then + Term_Project /= From_Project_Node + then + -- This variable or attribute comes from another project + + The_Name := Name_Of (Term_Project); + The_Project := Imported_Or_Modified_Project_From + (Project => Project, With_Name => The_Name); + end if; + + if Term_Package /= Empty_Node then + + -- This is an attribute of a package + + The_Name := Name_Of (Term_Package); + The_Package := Projects.Table (The_Project).Decl.Packages; + + while The_Package /= No_Package + and then Packages.Table (The_Package).Name /= The_Name + loop + The_Package := Packages.Table (The_Package).Next; + end loop; + + pragma Assert + (The_Package /= No_Package, + "package not found."); + + elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then + The_Package := No_Package; + end if; + + The_Name := Name_Of (The_Current_Term); + + if The_Package /= No_Package then + + -- First, if there is a package, look into the package + + if Kind_Of (The_Current_Term) = N_Variable_Reference then + The_Variable_Id := + Packages.Table (The_Package).Decl.Variables; + + else + The_Variable_Id := + Packages.Table (The_Package).Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then + Variable_Elements.Table (The_Variable_Id).Name /= + The_Name + loop + The_Variable_Id := + Variable_Elements.Table (The_Variable_Id).Next; + end loop; + + end if; + + if The_Variable_Id = No_Variable then + + -- If we have not found it, look into the project + + if Kind_Of (The_Current_Term) = N_Variable_Reference then + The_Variable_Id := + Projects.Table (The_Project).Decl.Variables; + + else + The_Variable_Id := + Projects.Table (The_Project).Decl.Attributes; + end if; + + while The_Variable_Id /= No_Variable + and then + Variable_Elements.Table (The_Variable_Id).Name /= + The_Name + loop + The_Variable_Id := + Variable_Elements.Table (The_Variable_Id).Next; + end loop; + + end if; + + pragma Assert (The_Variable_Id /= No_Variable, + "variable or attribute not found"); + + The_Variable := Variable_Elements.Table (The_Variable_Id); + + case Kind is + + when Undefined => + + -- Should never happen + + pragma Assert (False, "undefined expression kind"); + null; + + when Single => + + case The_Variable.Value.Kind is + + when Undefined => + null; + + when Single => + Add (Result.Value, The_Variable.Value.Value); + + when List => + + -- Should never happen + + pragma Assert + (False, + "list cannot appear in single " & + "string expression"); + null; + + end case; + + when List => + case The_Variable.Value.Kind is + + when Undefined => + null; + + when Single => + String_Elements.Increment_Last; + + if Last = Nil_String then + + -- This can happen in an expression such as + -- () & Var + + Result.Values := String_Elements.Last; + + else + String_Elements.Table (Last).Next := + String_Elements.Last; + end if; + + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => The_Variable.Value.Value, + Location => Location_Of (The_Current_Term), + Next => Nil_String); + + when List => + + declare + The_List : String_List_Id := + The_Variable.Value.Values; + + begin + while The_List /= Nil_String loop + String_Elements.Increment_Last; + + if Last = Nil_String then + Result.Values := String_Elements.Last; + + else + String_Elements.Table (Last).Next := + String_Elements.Last; + + end if; + + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => + String_Elements.Table + (The_List).Value, + Location => Location_Of + (The_Current_Term), + Next => Nil_String); + The_List := + String_Elements.Table (The_List).Next; + + end loop; + end; + end case; + end case; + end; + + when N_External_Value => + String_To_Name_Buffer + (String_Value_Of (External_Reference_Of (The_Current_Term))); + + declare + Name : constant Name_Id := Name_Find; + Default : String_Id := No_String; + Value : String_Id := No_String; + + Default_Node : constant Project_Node_Id := + External_Default_Of (The_Current_Term); + + begin + if Default_Node /= Empty_Node then + Default := String_Value_Of (Default_Node); + end if; + + Value := Prj.Ext.Value_Of (Name, Default); + + if Value = No_String then + if Error_Report = null then + Error_Msg + ("undefined external reference", + Location_Of (The_Current_Term)); + + else + Error_Report + ("""" & Get_Name_String (Name) & + """ is an undefined external reference"); + end if; + + Value := Empty_String; + + end if; + + case Kind is + + when Undefined => + null; + + when Single => + Add (Result.Value, Value); + + when List => + String_Elements.Increment_Last; + + if Last = Nil_String then + Result.Values := String_Elements.Last; + + else + String_Elements.Table (Last).Next := + String_Elements.Last; + end if; + + Last := String_Elements.Last; + String_Elements.Table (Last) := + (Value => Value, + Location => Location_Of (The_Current_Term), + Next => Nil_String); + + end case; + + end; + + when others => + + -- Should never happen + + pragma Assert + (False, + "illegal node kind in an expression"); + raise Program_Error; + + end case; + + The_Term := Next_Term (The_Term); + + end loop; + return Result; + end Expression; + + --------------------------------------- + -- Imported_Or_Modified_Project_From -- + --------------------------------------- + + function Imported_Or_Modified_Project_From + (Project : Project_Id; + With_Name : Name_Id) + return Project_Id + is + Data : constant Project_Data := Projects.Table (Project); + List : Project_List := Data.Imported_Projects; + + begin + -- First check if it is the name of a modified project + + if Data.Modifies /= No_Project + and then Projects.Table (Data.Modifies).Name = With_Name + then + return Data.Modifies; + + else + -- Then check the name of each imported project + + while List /= Empty_Project_List + and then + Projects.Table + (Project_Lists.Table (List).Project).Name /= With_Name + + loop + List := Project_Lists.Table (List).Next; + end loop; + + pragma Assert + (List /= Empty_Project_List, + "project not found"); + + return Project_Lists.Table (List).Project; + end if; + + end Imported_Or_Modified_Project_From; + + ------------------ + -- Package_From -- + ------------------ + + function Package_From + (Project : Project_Id; + With_Name : Name_Id) + return Package_Id + is + Data : constant Project_Data := Projects.Table (Project); + Result : Package_Id := Data.Decl.Packages; + + begin + -- Check the name of each existing package of Project + + while Result /= No_Package + and then + Packages.Table (Result).Name /= With_Name + loop + Result := Packages.Table (Result).Next; + end loop; + + if Result = No_Package then + -- Should never happen + Write_Line ("package """ & Get_Name_String (With_Name) & + """ not found"); + raise Program_Error; + + else + return Result; + end if; + end Package_From; + + ------------- + -- Process -- + ------------- + + procedure Process + (Project : out Project_Id; + From_Project_Node : Project_Node_Id; + Report_Error : Put_Line_Access) + is + begin + Error_Report := Report_Error; + + -- Make sure there is no projects in the data structure + + Projects.Set_Last (No_Project); + Processed_Projects.Reset; + + -- And process the main project and all of the projects it depends on, + -- recursively + + Recursive_Process + (Project => Project, + From_Project_Node => From_Project_Node, + Modified_By => No_Project); + + if Errout.Errors_Detected > 0 then + Project := No_Project; + end if; + + if Project /= No_Project then + Check (Project); + end if; + + end Process; + + ------------------------------- + -- Process_Declarative_Items -- + ------------------------------- + + procedure Process_Declarative_Items + (Project : Project_Id; + From_Project_Node : Project_Node_Id; + Pkg : Package_Id; + Item : Project_Node_Id) is + + Current_Declarative_Item : Project_Node_Id := Item; + + Current_Item : Project_Node_Id := Empty_Node; + + begin + -- For each declarative item + + while Current_Declarative_Item /= Empty_Node loop + + -- Get its data + + Current_Item := Current_Item_Node (Current_Declarative_Item); + + -- And set Current_Declarative_Item to the next declarative item + -- ready for the next iteration + + Current_Declarative_Item := Next_Declarative_Item + (Current_Declarative_Item); + + case Kind_Of (Current_Item) is + + when N_Package_Declaration => + Packages.Increment_Last; + + declare + New_Pkg : constant Package_Id := Packages.Last; + The_New_Package : Package_Element; + + Project_Of_Renamed_Package : constant Project_Node_Id := + Project_Of_Renamed_Package_Of + (Current_Item); + + begin + The_New_Package.Name := Name_Of (Current_Item); + + if Pkg /= No_Package then + The_New_Package.Next := + Packages.Table (Pkg).Decl.Packages; + Packages.Table (Pkg).Decl.Packages := New_Pkg; + else + The_New_Package.Next := + Projects.Table (Project).Decl.Packages; + Projects.Table (Project).Decl.Packages := New_Pkg; + end if; + + Packages.Table (New_Pkg) := The_New_Package; + + if Project_Of_Renamed_Package /= Empty_Node then + + -- Renamed package + + declare + Project_Name : constant Name_Id := + Name_Of + (Project_Of_Renamed_Package); + + Renamed_Project : constant Project_Id := + Imported_Or_Modified_Project_From + (Project, Project_Name); + + Renamed_Package : constant Package_Id := + Package_From + (Renamed_Project, + Name_Of (Current_Item)); + + begin + Packages.Table (New_Pkg).Decl := + Packages.Table (Renamed_Package).Decl; + end; + + else + -- Set the default values of the attributes + + Add_Attributes + (Packages.Table (New_Pkg).Decl, + Package_Attributes.Table + (Package_Id_Of (Current_Item)).First_Attribute); + + Process_Declarative_Items + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => New_Pkg, + Item => First_Declarative_Item_Of + (Current_Item)); + end if; + + end; + + when N_String_Type_Declaration => + + -- There is nothing to process + + null; + + when N_Attribute_Declaration | + N_Typed_Variable_Declaration | + N_Variable_Declaration => + + pragma Assert (Expression_Of (Current_Item) /= Empty_Node, + "no expression for an object declaration"); + + declare + New_Value : constant Variable_Value := + Expression + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => Pkg, + First_Term => + Tree.First_Term (Expression_Of + (Current_Item)), + Kind => + Expression_Kind_Of (Current_Item)); + + The_Variable : Variable_Id := No_Variable; + + Current_Item_Name : constant Name_Id := + Name_Of (Current_Item); + + begin + if Kind_Of (Current_Item) = N_Typed_Variable_Declaration then + + if String_Equal (New_Value.Value, Empty_String) then + Error_Msg_Name_1 := Name_Of (Current_Item); + + if Error_Report = null then + Error_Msg + ("no value defined for %", + Location_Of (Current_Item)); + + else + Error_Report + ("no value defined for " & + Get_Name_String (Error_Msg_Name_1)); + end if; + + else + declare + Current_String : Project_Node_Id := + First_Literal_String + (String_Type_Of + (Current_Item)); + + begin + while Current_String /= Empty_Node + and then not String_Equal + (String_Value_Of (Current_String), + New_Value.Value) + loop + Current_String := + Next_Literal_String (Current_String); + end loop; + + if Current_String = Empty_Node then + String_To_Name_Buffer (New_Value.Value); + Error_Msg_Name_1 := Name_Find; + Error_Msg_Name_2 := Name_Of (Current_Item); + + if Error_Report = null then + Error_Msg + ("value { is illegal for typed string %", + Location_Of (Current_Item)); + + else + Error_Report + ("value """ & + Get_Name_String (Error_Msg_Name_1) & + """ is illegal for typed string """ & + Get_Name_String (Error_Msg_Name_2) & + """"); + end if; + end if; + end; + end if; + end if; + + if Kind_Of (Current_Item) /= N_Attribute_Declaration + or else + Associative_Array_Index_Of (Current_Item) = No_String + then + -- Usual case + + -- Code below really needs more comments ??? + + if Kind_Of (Current_Item) = N_Attribute_Declaration then + if Pkg /= No_Package then + The_Variable := + Packages.Table (Pkg).Decl.Attributes; + + else + The_Variable := + Projects.Table (Project).Decl.Attributes; + end if; + + else + if Pkg /= No_Package then + The_Variable := + Packages.Table (Pkg).Decl.Variables; + + else + The_Variable := + Projects.Table (Project).Decl.Variables; + end if; + + end if; + + while + The_Variable /= No_Variable + and then + Variable_Elements.Table (The_Variable).Name /= + Current_Item_Name + loop + The_Variable := + Variable_Elements.Table (The_Variable).Next; + end loop; + + if The_Variable = No_Variable then + pragma Assert + (Kind_Of (Current_Item) /= N_Attribute_Declaration, + "illegal attribute declaration"); + + Variable_Elements.Increment_Last; + The_Variable := Variable_Elements.Last; + + if Pkg /= No_Package then + Variable_Elements.Table (The_Variable) := + (Next => + Packages.Table (Pkg).Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + Packages.Table (Pkg).Decl.Variables := The_Variable; + + else + Variable_Elements.Table (The_Variable) := + (Next => + Projects.Table (Project).Decl.Variables, + Name => Current_Item_Name, + Value => New_Value); + Projects.Table (Project).Decl.Variables := + The_Variable; + end if; + + else + Variable_Elements.Table (The_Variable).Value := + New_Value; + + end if; + + else + -- Associative array attribute + + String_To_Name_Buffer + (Associative_Array_Index_Of (Current_Item)); + + declare + The_Array : Array_Id; + + The_Array_Element : Array_Element_Id := + No_Array_Element; + + Index_Name : constant Name_Id := Name_Find; + + begin + + if Pkg /= No_Package then + The_Array := Packages.Table (Pkg).Decl.Arrays; + + else + The_Array := Projects.Table (Project).Decl.Arrays; + end if; + + while + The_Array /= No_Array + and then Arrays.Table (The_Array).Name /= + Current_Item_Name + loop + The_Array := Arrays.Table (The_Array).Next; + end loop; + + if The_Array = No_Array then + Arrays.Increment_Last; + The_Array := Arrays.Last; + + if Pkg /= No_Package then + Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => Packages.Table (Pkg).Decl.Arrays); + Packages.Table (Pkg).Decl.Arrays := The_Array; + + else + Arrays.Table (The_Array) := + (Name => Current_Item_Name, + Value => No_Array_Element, + Next => + Projects.Table (Project).Decl.Arrays); + Projects.Table (Project).Decl.Arrays := + The_Array; + end if; + + else + The_Array_Element := Arrays.Table (The_Array).Value; + end if; + + while The_Array_Element /= No_Array_Element + and then + Array_Elements.Table (The_Array_Element).Index /= + Index_Name + loop + The_Array_Element := + Array_Elements.Table (The_Array_Element).Next; + end loop; + + if The_Array_Element = No_Array_Element then + Array_Elements.Increment_Last; + The_Array_Element := Array_Elements.Last; + Array_Elements.Table (The_Array_Element) := + (Index => Index_Name, + Value => New_Value, + Next => Arrays.Table (The_Array).Value); + Arrays.Table (The_Array).Value := The_Array_Element; + + else + Array_Elements.Table (The_Array_Element).Value := + New_Value; + end if; + end; + end if; + end; + + when N_Case_Construction => + declare + The_Project : Project_Id := Project; + The_Package : Package_Id := Pkg; + The_Variable : Variable_Value := Nil_Variable_Value; + Case_Value : String_Id := No_String; + Case_Item : Project_Node_Id := Empty_Node; + Choice_String : Project_Node_Id := Empty_Node; + Decl_Item : Project_Node_Id := Empty_Node; + + begin + declare + Variable_Node : constant Project_Node_Id := + Case_Variable_Reference_Of + (Current_Item); + + Var_Id : Variable_Id := No_Variable; + Name : Name_Id := No_Name; + + begin + if Project_Node_Of (Variable_Node) /= Empty_Node then + Name := Name_Of (Project_Node_Of (Variable_Node)); + The_Project := + Imported_Or_Modified_Project_From (Project, Name); + end if; + + if Package_Node_Of (Variable_Node) /= Empty_Node then + Name := Name_Of (Package_Node_Of (Variable_Node)); + The_Package := Package_From (The_Project, Name); + end if; + + Name := Name_Of (Variable_Node); + + if The_Package /= No_Package then + Var_Id := Packages.Table (The_Package).Decl.Variables; + Name := Name_Of (Variable_Node); + while Var_Id /= No_Variable + and then + Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := Variable_Elements.Table (Var_Id).Next; + end loop; + end if; + + if Var_Id = No_Variable + and then Package_Node_Of (Variable_Node) = Empty_Node + then + Var_Id := Projects.Table (The_Project).Decl.Variables; + while Var_Id /= No_Variable + and then + Variable_Elements.Table (Var_Id).Name /= Name + loop + Var_Id := Variable_Elements.Table (Var_Id).Next; + end loop; + end if; + + if Var_Id = No_Variable then + + -- Should never happen + + Write_Line ("variable """ & + Get_Name_String (Name) & + """ not found"); + raise Program_Error; + end if; + + The_Variable := Variable_Elements.Table (Var_Id).Value; + + if The_Variable.Kind /= Single then + + -- Should never happen + + Write_Line ("variable""" & + Get_Name_String (Name) & + """ is not a single string variable"); + raise Program_Error; + end if; + + Case_Value := The_Variable.Value; + end; + + Case_Item := First_Case_Item_Of (Current_Item); + Case_Item_Loop : + while Case_Item /= Empty_Node loop + Choice_String := First_Choice_Of (Case_Item); + + if Choice_String = Empty_Node then + Decl_Item := First_Declarative_Item_Of (Case_Item); + exit Case_Item_Loop; + end if; + + Choice_Loop : + while Choice_String /= Empty_Node loop + if String_Equal (Case_Value, + String_Value_Of (Choice_String)) + then + Decl_Item := + First_Declarative_Item_Of (Case_Item); + exit Case_Item_Loop; + end if; + + Choice_String := + Next_Literal_String (Choice_String); + end loop Choice_Loop; + Case_Item := Next_Case_Item (Case_Item); + end loop Case_Item_Loop; + + if Decl_Item /= Empty_Node then + Process_Declarative_Items + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => Pkg, + Item => Decl_Item); + end if; + end; + + when others => + + -- Should never happen + + Write_Line ("Illegal declarative item: " & + Project_Node_Kind'Image (Kind_Of (Current_Item))); + raise Program_Error; + end case; + end loop; + end Process_Declarative_Items; + + --------------------- + -- Recursive_Check -- + --------------------- + + procedure Recursive_Check (Project : Project_Id) is + Data : Project_Data; + Imported_Project_List : Project_List := Empty_Project_List; + + begin + -- Do nothing if Project is No_Project, or Project has already + -- been marked as checked. + + if Project /= No_Project + and then not Projects.Table (Project).Checked + then + Data := Projects.Table (Project); + + -- Call itself for a possible modified project. + -- (if there is no modified project, then nothing happens). + + Recursive_Check (Data.Modifies); + + -- Call itself for all imported projects + + Imported_Project_List := Data.Imported_Projects; + while Imported_Project_List /= Empty_Project_List loop + Recursive_Check + (Project_Lists.Table (Imported_Project_List).Project); + Imported_Project_List := + Project_Lists.Table (Imported_Project_List).Next; + end loop; + + -- Mark project as checked + + Projects.Table (Project).Checked := True; + + if Opt.Verbose_Mode then + Write_Str ("Checking project file """); + Write_Str (Get_Name_String (Data.Name)); + Write_Line (""""); + end if; + + Prj.Nmsc.Check_Naming_Scheme (Project, Error_Report); + end if; + + end Recursive_Check; + + ----------------------- + -- Recursive_Process -- + ----------------------- + + procedure Recursive_Process + (Project : out Project_Id; + From_Project_Node : Project_Node_Id; + Modified_By : Project_Id) + is + With_Clause : Project_Node_Id; + + begin + if From_Project_Node = Empty_Node then + Project := No_Project; + + else + declare + Processed_Data : Project_Data := Empty_Project; + Imported : Project_List := Empty_Project_List; + Declaration_Node : Project_Node_Id := Empty_Node; + Name : constant Name_Id := + Name_Of (From_Project_Node); + + begin + Project := Processed_Projects.Get (Name); + + if Project /= No_Project then + return; + end if; + + Projects.Increment_Last; + Project := Projects.Last; + Processed_Projects.Set (Name, Project); + Processed_Data.Name := Name; + Processed_Data.Path_Name := Path_Name_Of (From_Project_Node); + Processed_Data.Location := Location_Of (From_Project_Node); + Processed_Data.Directory := Directory_Of (From_Project_Node); + Processed_Data.Modified_By := Modified_By; + Add_Attributes (Processed_Data.Decl, Attribute_First); + With_Clause := First_With_Clause_Of (From_Project_Node); + + while With_Clause /= Empty_Node loop + declare + New_Project : Project_Id; + New_Data : Project_Data; + + begin + Recursive_Process + (Project => New_Project, + From_Project_Node => Project_Node_Of (With_Clause), + Modified_By => No_Project); + New_Data := Projects.Table (New_Project); + + -- If we were the first project to import it, + -- set First_Referred_By to us. + + if New_Data.First_Referred_By = No_Project then + New_Data.First_Referred_By := Project; + Projects.Table (New_Project) := New_Data; + end if; + + -- Add this project to our list of imported projects + + Project_Lists.Increment_Last; + Project_Lists.Table (Project_Lists.Last) := + (Project => New_Project, Next => Empty_Project_List); + + -- Imported is the id of the last imported project. + -- If it is nil, then this imported project is our first. + + if Imported = Empty_Project_List then + Processed_Data.Imported_Projects := Project_Lists.Last; + + else + Project_Lists.Table (Imported).Next := Project_Lists.Last; + end if; + + Imported := Project_Lists.Last; + + With_Clause := Next_With_Clause_Of (With_Clause); + end; + end loop; + + Declaration_Node := Project_Declaration_Of (From_Project_Node); + + Recursive_Process + (Project => Processed_Data.Modifies, + From_Project_Node => Modified_Project_Of (Declaration_Node), + Modified_By => Project); + + Projects.Table (Project) := Processed_Data; + + Process_Declarative_Items + (Project => Project, + From_Project_Node => From_Project_Node, + Pkg => No_Package, + Item => First_Declarative_Item_Of + (Declaration_Node)); + + end; + end if; + end Recursive_Process; + +end Prj.Proc; diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads new file mode 100644 index 00000000000..63259a42699 --- /dev/null +++ b/gcc/ada/prj-proc.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P R O C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This package is used to convert a project file tree (see prj-tree.ads) to +-- project file data structures (see prj.ads), taking into account +-- the environment (external references). + +with Prj.Tree; use Prj.Tree; + +package Prj.Proc is + + procedure Process + (Project : out Project_Id; + From_Project_Node : Project_Node_Id; + Report_Error : Put_Line_Access); + -- Process a project file tree into project file data structures. + -- If Report_Error is null, use the standard error reporting mechanism + -- (Errout). Otherwise, report errors using Report_Error. + +end Prj.Proc; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb new file mode 100644 index 00000000000..790c632c2cf --- /dev/null +++ b/gcc/ada/prj-strt.adb @@ -0,0 +1,943 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . S T R T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Errout; use Errout; +with Prj.Attr; use Prj.Attr; +with Prj.Tree; use Prj.Tree; +with Scans; use Scans; +with Sinfo; use Sinfo; +with Stringt; use Stringt; +with Table; +with Types; use Types; + +package body Prj.Strt is + + Initial_Size : constant := 8; + + type Name_Location is record + Name : Name_Id := No_Name; + Location : Source_Ptr := No_Location; + end record; + -- Store the identifier and the location of a simple name + + type Name_Range is range 0 .. 3; + subtype Name_Index is Name_Range range 1 .. Name_Range'Last; + -- A Name may contain up to 3 simple names + + type Names is array (Name_Index) of Name_Location; + -- Used to store 1 to 3 simple_names. 2 simple names are for + -- <project>.<package>, <project>.<variable> or <package>.<variable>. + -- 3 simple names are for <project>.<package>.<variable>. + + type Choice_String is record + The_String : String_Id; + Already_Used : Boolean := False; + end record; + -- The string of a case label, and an indication that it has already + -- been used (to avoid duplicate case labels). + + Choices_Initial : constant := 10; + Choices_Increment : constant := 10; + + Choice_Node_Low_Bound : constant := 0; + Choice_Node_High_Bound : constant := 099_999_999; -- In practice, infinite + + type Choice_Node_Id is + range Choice_Node_Low_Bound .. Choice_Node_High_Bound; + + First_Choice_Node_Id : constant Choice_Node_Id := + Choice_Node_Low_Bound; + + Empty_Choice : constant Choice_Node_Id := + Choice_Node_Low_Bound; + + First_Choice_Id : constant Choice_Node_Id := First_Choice_Node_Id + 1; + + package Choices is + new Table.Table (Table_Component_Type => Choice_String, + Table_Index_Type => Choice_Node_Id, + Table_Low_Bound => First_Choice_Node_Id, + Table_Initial => Choices_Initial, + Table_Increment => Choices_Increment, + Table_Name => "Prj.Strt.Choices"); + -- Used to store the case labels and check that there is no duplicate. + + package Choice_Lasts is + new Table.Table (Table_Component_Type => Choice_Node_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 3, + Table_Increment => 3, + Table_Name => "Prj.Strt.Choice_Lasts"); + -- Used to store the indices of the choices in table Choices, + -- to distinguish nested case constructions. + + Choice_First : Choice_Node_Id := 0; + -- Index in table Choices of the first case label of the current + -- case construction. + -- 0 means no current case construction. + + procedure Add (This_String : String_Id); + -- Add a string to the case label list, indicating that it has not + -- yet been used. + + procedure External_Reference (External_Value : out Project_Node_Id); + -- Parse an external reference. Current token is "external". + + procedure Attribute_Reference + (Reference : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse an attribute reference. Current token is an apostrophe. + + procedure Terms + (Term : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Recursive procedure to parse one term or several terms concatenated + -- using "&". + + --------- + -- Add -- + --------- + + procedure Add (This_String : String_Id) is + begin + Choices.Increment_Last; + Choices.Table (Choices.Last) := + (The_String => This_String, + Already_Used => False); + end Add; + + ------------------------- + -- Attribute_Reference -- + ------------------------- + + procedure Attribute_Reference + (Reference : out Project_Node_Id; + First_Attribute : Attribute_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Current_Attribute : Attribute_Node_Id := First_Attribute; + + begin + Reference := Default_Project_Node (Of_Kind => N_Attribute_Reference); + Set_Location_Of (Reference, To => Token_Ptr); + Scan; -- past apostrophe + Expect (Tok_Identifier, "Identifier"); + + if Token = Tok_Identifier then + Set_Name_Of (Reference, To => Token_Name); + + while Current_Attribute /= Empty_Attribute + and then + Attributes.Table (Current_Attribute).Name /= Token_Name + loop + Current_Attribute := Attributes.Table (Current_Attribute).Next; + end loop; + + if Current_Attribute = Empty_Attribute then + Error_Msg ("unknown attribute", Token_Ptr); + Reference := Empty_Node; + + elsif + Attributes.Table (Current_Attribute).Kind_2 = Associative_Array + then + Error_Msg + ("associative array attribute cannot be referenced", + Token_Ptr); + Reference := Empty_Node; + + else + Set_Project_Node_Of (Reference, To => Current_Project); + Set_Package_Node_Of (Reference, To => Current_Package); + Set_Expression_Kind_Of + (Reference, To => Attributes.Table (Current_Attribute).Kind_1); + Scan; + end if; + end if; + end Attribute_Reference; + + --------------------------- + -- End_Case_Construction -- + --------------------------- + + procedure End_Case_Construction is + begin + if Choice_Lasts.Last = 1 then + Choice_Lasts.Set_Last (0); + Choices.Set_Last (First_Choice_Node_Id); + Choice_First := 0; + + elsif Choice_Lasts.Last = 2 then + Choice_Lasts.Set_Last (1); + Choices.Set_Last (Choice_Lasts.Table (1)); + Choice_First := 1; + + else + Choice_Lasts.Decrement_Last; + Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last)); + Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1; + end if; + end End_Case_Construction; + + ------------------------ + -- External_Reference -- + ------------------------ + + procedure External_Reference (External_Value : out Project_Node_Id) is + Field_Id : Project_Node_Id := Empty_Node; + + begin + External_Value := + Default_Project_Node (Of_Kind => N_External_Value, + And_Expr_Kind => Single); + Set_Location_Of (External_Value, To => Token_Ptr); + + -- The current token is External + + -- Get the left parenthesis + + Scan; + Expect (Tok_Left_Paren, "("); + + -- Scan past the left parenthesis + + if Token = Tok_Left_Paren then + Scan; + end if; + + -- Get the name of the external reference + + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Field_Id := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Set_String_Value_Of (Field_Id, To => Strval (Token_Node)); + Set_External_Reference_Of (External_Value, To => Field_Id); + + -- Scan past the first argument + + Scan; + + case Token is + + when Tok_Right_Paren => + + -- Scan past the right parenthesis + Scan; + + when Tok_Comma => + + -- Scan past the comma + + Scan; + + Expect (Tok_String_Literal, "literal string"); + + -- Get the default + + if Token = Tok_String_Literal then + Field_Id := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Set_String_Value_Of (Field_Id, To => Strval (Token_Node)); + Set_External_Default_Of (External_Value, To => Field_Id); + Scan; + Expect (Tok_Right_Paren, ")"); + end if; + + -- Scan past the right parenthesis + if Token = Tok_Right_Paren then + Scan; + end if; + + when others => + Error_Msg ("',' or ')' expected", Token_Ptr); + end case; + end if; + end External_Reference; + + ----------------------- + -- Parse_Choice_List -- + ----------------------- + + procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is + Current_Choice : Project_Node_Id := Empty_Node; + Next_Choice : Project_Node_Id := Empty_Node; + Choice_String : String_Id := No_String; + Found : Boolean := False; + + begin + First_Choice := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Current_Choice := First_Choice; + + loop + Expect (Tok_String_Literal, "literal string"); + exit when Token /= Tok_String_Literal; + Set_Location_Of (Current_Choice, To => Token_Ptr); + Choice_String := Strval (Token_Node); + Set_String_Value_Of (Current_Choice, To => Choice_String); + + Found := False; + for Choice in Choice_First .. Choices.Last loop + if String_Equal (Choices.Table (Choice).The_String, + Choice_String) + then + Found := True; + + if Choices.Table (Choice).Already_Used then + Error_Msg ("duplicate case label", Token_Ptr); + else + Choices.Table (Choice).Already_Used := True; + end if; + + exit; + end if; + end loop; + + if not Found then + Error_Msg ("illegal case label", Token_Ptr); + end if; + + Scan; + + if Token = Tok_Vertical_Bar then + Next_Choice := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Set_Next_Literal_String (Current_Choice, To => Next_Choice); + Current_Choice := Next_Choice; + Scan; + else + exit; + end if; + end loop; + end Parse_Choice_List; + + ---------------------- + -- Parse_Expression -- + ---------------------- + + procedure Parse_Expression + (Expression : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + First_Term : Project_Node_Id := Empty_Node; + Expression_Kind : Variable_Kind := Undefined; + + begin + Expression := Default_Project_Node (Of_Kind => N_Expression); + Set_Location_Of (Expression, To => Token_Ptr); + Terms (Term => First_Term, + Expr_Kind => Expression_Kind, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_First_Term (Expression, To => First_Term); + Set_Expression_Kind_Of (Expression, To => Expression_Kind); + end Parse_Expression; + + ---------------------------- + -- Parse_String_Type_List -- + ---------------------------- + + procedure Parse_String_Type_List (First_String : out Project_Node_Id) is + Last_String : Project_Node_Id := Empty_Node; + Next_String : Project_Node_Id := Empty_Node; + String_Value : String_Id := No_String; + + begin + First_String := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Last_String := First_String; + + loop + Expect (Tok_String_Literal, "literal string"); + exit when Token /= Tok_String_Literal; + String_Value := Strval (Token_Node); + Set_String_Value_Of (Last_String, To => String_Value); + Set_Location_Of (Last_String, To => Token_Ptr); + + declare + Current : Project_Node_Id := First_String; + + begin + while Current /= Last_String loop + if String_Equal (String_Value_Of (Current), String_Value) then + Error_Msg ("duplicate value in type", Token_Ptr); + exit; + end if; + + Current := Next_Literal_String (Current); + end loop; + end; + + Scan; + + if Token /= Tok_Comma then + exit; + + else + Next_String := + Default_Project_Node (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + Set_Next_Literal_String (Last_String, To => Next_String); + Last_String := Next_String; + Scan; + end if; + end loop; + end Parse_String_Type_List; + + ------------------------------ + -- Parse_Variable_Reference -- + ------------------------------ + + procedure Parse_Variable_Reference + (Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + The_Names : Names; + Last_Name : Name_Range := 0; + Current_Variable : Project_Node_Id := Empty_Node; + + The_Package : Project_Node_Id := Current_Package; + The_Project : Project_Node_Id := Current_Project; + + Specified_Project : Project_Node_Id := Empty_Node; + Specified_Package : Project_Node_Id := Empty_Node; + Look_For_Variable : Boolean := True; + First_Attribute : Attribute_Node_Id := Empty_Attribute; + Variable_Name : Name_Id; + + begin + for Index in The_Names'Range loop + Expect (Tok_Identifier, "identifier"); + + if Token /= Tok_Identifier then + Look_For_Variable := False; + exit; + end if; + + Last_Name := Last_Name + 1; + The_Names (Last_Name) := + (Name => Token_Name, + Location => Token_Ptr); + Scan; + exit when Token /= Tok_Dot; + Scan; + end loop; + + if Look_For_Variable then + if Token = Tok_Apostrophe then + + -- Attribute reference + + case Last_Name is + when 0 => + + -- Cannot happen + + null; + + when 1 => + for Index in Package_First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = + The_Names (1).Name + then + First_Attribute := + Package_Attributes.Table (Index).First_Attribute; + exit; + end if; + end loop; + + if First_Attribute /= Empty_Attribute then + The_Package := First_Package_Of (Current_Project); + while The_Package /= Empty_Node + and then Name_Of (The_Package) /= The_Names (1).Name + loop + The_Package := Next_Package_In_Project (The_Package); + end loop; + + if The_Package = Empty_Node then + Error_Msg ("package not yet defined", + The_Names (1).Location); + end if; + + else + First_Attribute := Attribute_First; + The_Package := Empty_Node; + + declare + The_Project_Name_And_Node : + constant Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get + (The_Names (1).Name); + + use Tree_Private_Part; + + begin + if The_Project_Name_And_Node = + Tree_Private_Part.No_Project_Name_And_Node + then + Error_Msg ("unknown project", + The_Names (1).Location); + else + The_Project := The_Project_Name_And_Node.Node; + end if; + end; + end if; + + when 2 => + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project); + + begin + while With_Clause /= Empty_Node loop + The_Project := Project_Node_Of (With_Clause); + exit when Name_Of (The_Project) = The_Names (1).Name; + With_Clause := Next_With_Clause_Of (With_Clause); + end loop; + + if With_Clause = Empty_Node then + Error_Msg ("unknown project", + The_Names (1).Location); + The_Project := Empty_Node; + The_Package := Empty_Node; + First_Attribute := Attribute_First; + + else + The_Package := First_Package_Of (The_Project); + while The_Package /= Empty_Node + and then Name_Of (The_Package) /= The_Names (2).Name + loop + The_Package := + Next_Package_In_Project (The_Package); + end loop; + + if The_Package = Empty_Node then + Error_Msg ("package not declared in project", + The_Names (2).Location); + First_Attribute := Attribute_First; + + else + First_Attribute := + Package_Attributes.Table + (Package_Id_Of (The_Package)).First_Attribute; + end if; + end if; + end; + + when 3 => + Error_Msg + ("too many single names for an attribute reference", + The_Names (1).Location); + Scan; + Variable := Empty_Node; + return; + end case; + + Attribute_Reference + (Variable, + Current_Project => The_Project, + Current_Package => The_Package, + First_Attribute => First_Attribute); + return; + end if; + end if; + + Variable := + Default_Project_Node (Of_Kind => N_Variable_Reference); + + if Look_For_Variable then + case Last_Name is + when 0 => + + -- Cannot happen + + null; + + when 1 => + Set_Name_Of (Variable, To => The_Names (1).Name); + + -- Header comment needed ??? + + when 2 => + Set_Name_Of (Variable, To => The_Names (2).Name); + The_Package := First_Package_Of (Current_Project); + + while The_Package /= Empty_Node + and then Name_Of (The_Package) /= The_Names (1).Name + loop + The_Package := Next_Package_In_Project (The_Package); + end loop; + + if The_Package /= Empty_Node then + Specified_Package := The_Package; + The_Project := Empty_Node; + + else + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project); + + begin + while With_Clause /= Empty_Node loop + The_Project := Project_Node_Of (With_Clause); + exit when Name_Of (The_Project) = The_Names (1).Name; + With_Clause := Next_With_Clause_Of (With_Clause); + end loop; + + if With_Clause = Empty_Node then + The_Project := + Modified_Project_Of + (Project_Declaration_Of (Current_Project)); + + if The_Project /= Empty_Node + and then + Name_Of (The_Project) /= The_Names (1).Name + then + The_Project := Empty_Node; + end if; + end if; + + if The_Project = Empty_Node then + Error_Msg ("unknown package or project", + The_Names (1).Location); + Look_For_Variable := False; + else + Specified_Project := The_Project; + end if; + end; + end if; + + -- Header comment needed ??? + + when 3 => + Set_Name_Of (Variable, To => The_Names (3).Name); + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Current_Project); + + begin + while With_Clause /= Empty_Node loop + The_Project := Project_Node_Of (With_Clause); + exit when Name_Of (The_Project) = The_Names (1).Name; + With_Clause := Next_With_Clause_Of (With_Clause); + end loop; + + if With_Clause = Empty_Node then + The_Project := + Modified_Project_Of + (Project_Declaration_Of (Current_Project)); + + if The_Project /= Empty_Node + and then Name_Of (The_Project) /= The_Names (1).Name + then + The_Project := Empty_Node; + end if; + end if; + + if The_Project = Empty_Node then + Error_Msg ("unknown package or project", + The_Names (1).Location); + Look_For_Variable := False; + + else + Specified_Project := The_Project; + The_Package := First_Package_Of (The_Project); + + while The_Package /= Empty_Node + and then Name_Of (The_Package) /= The_Names (2).Name + loop + The_Package := Next_Package_In_Project (The_Package); + end loop; + + if The_Package = Empty_Node then + Error_Msg ("unknown package", + The_Names (2).Location); + Look_For_Variable := False; + + else + Specified_Package := The_Package; + The_Project := Empty_Node; + end if; + end if; + end; + + end case; + end if; + + if Look_For_Variable then + Variable_Name := Name_Of (Variable); + Set_Project_Node_Of (Variable, To => Specified_Project); + Set_Package_Node_Of (Variable, To => Specified_Package); + + if The_Package /= Empty_Node then + Current_Variable := First_Variable_Of (The_Package); + + while Current_Variable /= Empty_Node + and then + Name_Of (Current_Variable) /= Variable_Name + loop + Current_Variable := Next_Variable (Current_Variable); + end loop; + end if; + + if Current_Variable = Empty_Node + and then The_Project /= Empty_Node + then + Current_Variable := First_Variable_Of (The_Project); + while Current_Variable /= Empty_Node + and then Name_Of (Current_Variable) /= Variable_Name + loop + Current_Variable := Next_Variable (Current_Variable); + end loop; + end if; + + if Current_Variable = Empty_Node then + Error_Msg ("unknown variable", The_Names (Last_Name).Location); + end if; + end if; + + if Current_Variable /= Empty_Node then + Set_Expression_Kind_Of + (Variable, To => Expression_Kind_Of (Current_Variable)); + + if Kind_Of (Current_Variable) = N_Typed_Variable_Declaration then + Set_String_Type_Of + (Variable, To => String_Type_Of (Current_Variable)); + end if; + end if; + end Parse_Variable_Reference; + + --------------------------------- + -- Start_New_Case_Construction -- + --------------------------------- + + procedure Start_New_Case_Construction (String_Type : Project_Node_Id) is + Current_String : Project_Node_Id; + + begin + if Choice_First = 0 then + Choice_First := 1; + Choices.Set_Last (First_Choice_Node_Id); + else + Choice_First := Choices.Last + 1; + end if; + + if String_Type /= Empty_Node then + Current_String := First_Literal_String (String_Type); + + while Current_String /= Empty_Node loop + Add (This_String => String_Value_Of (Current_String)); + Current_String := Next_Literal_String (Current_String); + end loop; + end if; + + Choice_Lasts.Increment_Last; + Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last; + + end Start_New_Case_Construction; + + ----------- + -- Terms -- + ----------- + + procedure Terms (Term : out Project_Node_Id; + Expr_Kind : in out Variable_Kind; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id) + is + Next_Term : Project_Node_Id := Empty_Node; + Term_Id : Project_Node_Id := Empty_Node; + Current_Expression : Project_Node_Id := Empty_Node; + Next_Expression : Project_Node_Id := Empty_Node; + Current_Location : Source_Ptr := No_Location; + Reference : Project_Node_Id := Empty_Node; + + begin + Term := Default_Project_Node (Of_Kind => N_Term); + Set_Location_Of (Term, To => Token_Ptr); + + case Token is + + when Tok_Left_Paren => + case Expr_Kind is + when Undefined => + Expr_Kind := List; + when List => + null; + when Single => + Expr_Kind := List; + Error_Msg + ("literal string list cannot appear in a string", + Token_Ptr); + end case; + + Term_Id := Default_Project_Node + (Of_Kind => N_Literal_String_List, + And_Expr_Kind => List); + Set_Current_Term (Term, To => Term_Id); + Set_Location_Of (Term, To => Token_Ptr); + + Scan; + if Token = Tok_Right_Paren then + Scan; + + else + loop + Current_Location := Token_Ptr; + Parse_Expression (Expression => Next_Expression, + Current_Project => Current_Project, + Current_Package => Current_Package); + + if Expression_Kind_Of (Next_Expression) = List then + Error_Msg ("single expression expected", + Current_Location); + end if; + + if Current_Expression = Empty_Node then + Set_First_Expression_In_List + (Term_Id, To => Next_Expression); + else + Set_Next_Expression_In_List + (Current_Expression, To => Next_Expression); + end if; + + Current_Expression := Next_Expression; + exit when Token /= Tok_Comma; + Scan; -- past the comma + end loop; + + Expect (Tok_Right_Paren, "("); + + if Token = Tok_Right_Paren then + Scan; + end if; + end if; + + when Tok_String_Literal => + if Expr_Kind = Undefined then + Expr_Kind := Single; + end if; + + Term_Id := Default_Project_Node (Of_Kind => N_Literal_String); + Set_Current_Term (Term, To => Term_Id); + Set_String_Value_Of (Term_Id, To => Strval (Token_Node)); + + Scan; + + when Tok_Identifier => + Current_Location := Token_Ptr; + Parse_Variable_Reference + (Variable => Reference, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Current_Term (Term, To => Reference); + + if Reference /= Empty_Node then + if Expr_Kind = Undefined then + Expr_Kind := Expression_Kind_Of (Reference); + + elsif Expr_Kind = Single + and then Expression_Kind_Of (Reference) = List + then + Expr_Kind := List; + Error_Msg + ("list variable cannot appear in single string expression", + Current_Location); + end if; + end if; + + when Tok_Project => + Current_Location := Token_Ptr; + Scan; + Expect (Tok_Apostrophe, "'"); + + if Token = Tok_Apostrophe then + Attribute_Reference + (Reference => Reference, + First_Attribute => Prj.Attr.Attribute_First, + Current_Project => Current_Project, + Current_Package => Empty_Node); + Set_Current_Term (Term, To => Reference); + end if; + + if Reference /= Empty_Node then + if Expr_Kind = Undefined then + Expr_Kind := Expression_Kind_Of (Reference); + + elsif Expr_Kind = Single + and then Expression_Kind_Of (Reference) = List + then + Error_Msg + ("lists cannot appear in single string expression", + Current_Location); + end if; + end if; + + when Tok_External => + if Expr_Kind = Undefined then + Expr_Kind := Single; + end if; + + External_Reference (External_Value => Reference); + Set_Current_Term (Term, To => Reference); + + when others => + Error_Msg ("cannot be part of an expression", Token_Ptr); + Term := Empty_Node; + return; + end case; + + if Token = Tok_Ampersand then + Scan; + + Terms (Term => Next_Term, + Expr_Kind => Expr_Kind, + Current_Project => Current_Project, + Current_Package => Current_Package); + Set_Next_Term (Term, To => Next_Term); + + end if; + + end Terms; + +end Prj.Strt; diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads new file mode 100644 index 00000000000..9bbdbeb8832 --- /dev/null +++ b/gcc/ada/prj-strt.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . S T R T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- This package implements parsing of string expressions in project files. + +with Prj.Tree; use Prj.Tree; + +private package Prj.Strt is + + procedure Parse_String_Type_List (First_String : out Project_Node_Id); + -- Get the list of literal strings that are allowed for a typed string. + -- On entry, the current token is the first literal string following + -- a left parenthesis in a string type declaration such as: + -- type Toto is ("string_1", "string_2", "string_3"); + -- On exit, the current token is the right parenthesis. + -- The parameter First_String is a node that contained the first + -- literal string of the string type, linked with the following + -- literal strings. + -- + -- Report an error if + -- - a literal string is not found at the beginning of the list + -- or after a comma + -- - two literal strings in the list are equal + + procedure Start_New_Case_Construction (String_Type : Project_Node_Id); + -- This procedure is called at the beginning of a case construction + -- The parameter String_Type is the node for the string type + -- of the case label variable. + -- The different literal strings of the string type are stored + -- into a table to be checked against the case labels of the + -- case construction. + + procedure End_Case_Construction; + -- This procedure is called at the end of a case construction + -- to remove the case labels and to restore the previous state. + -- In particular, in the case of nested case constructions, + -- the case labels of the enclosing case construction are restored. + + procedure Parse_Choice_List + (First_Choice : out Project_Node_Id); + -- Get the label for a choice list. + -- Report an error if + -- - a case label is not a literal string + -- - a case label is not in the typed string list + -- - the same case label is repeated in the same case construction + + procedure Parse_Expression + (Expression : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse a simple string expression or a string list expression. + -- Current_Project is the node of the project file being parsed. + -- Current_Package is the node of the package being parsed, + -- or Empty_Node when we are at the project level (not in a package). + -- On exit, Expression is the node of the expression that has + -- been parsed. + + procedure Parse_Variable_Reference + (Variable : out Project_Node_Id; + Current_Project : Project_Node_Id; + Current_Package : Project_Node_Id); + -- Parse a variable or attribute reference. + -- Used internally (in expressions) and for case variables (in Prj.Dect). + -- Current_Package is the node of the package being parsed, + -- or Empty_Node when we are at the project level (not in a package). + -- On exit, Variable is the node of the variable or attribute reference. + -- A variable reference is made of one to three simple names. + -- An attribute reference is made of one or two simple names, + -- followed by an apostroph, followed by the attribute simple name. + +end Prj.Strt; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb new file mode 100644 index 00000000000..322e4aae39f --- /dev/null +++ b/gcc/ada/prj-tree.adb @@ -0,0 +1,1478 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . T R E E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Stringt; use Stringt; + +package body Prj.Tree is + + use Tree_Private_Part; + + -------------------------------- + -- Associative_Array_Index_Of -- + -------------------------------- + + function Associative_Array_Index_Of + (Node : Project_Node_Id) + return String_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration)); + return Project_Nodes.Table (Node).Value; + end Associative_Array_Index_Of; + + -------------------------------- + -- Case_Variable_Reference_Of -- + -------------------------------- + + function Case_Variable_Reference_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Construction); + return Project_Nodes.Table (Node).Field1; + end Case_Variable_Reference_Of; + + ----------------------- + -- Current_Item_Node -- + ----------------------- + + function Current_Item_Node + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Declarative_Item); + return Project_Nodes.Table (Node).Field1; + end Current_Item_Node; + + ------------------ + -- Current_Term -- + ------------------ + + function Current_Term + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Term); + return Project_Nodes.Table (Node).Field1; + end Current_Term; + + -------------------------- + -- Default_Project_Node -- + -------------------------- + + function Default_Project_Node + (Of_Kind : Project_Node_Kind; + And_Expr_Kind : Variable_Kind := Undefined) + return Project_Node_Id + is + begin + Project_Nodes.Increment_Last; + Project_Nodes.Table (Project_Nodes.Last) := + (Kind => Of_Kind, + Location => No_Location, + Directory => No_Name, + Expr_Kind => And_Expr_Kind, + Variables => Empty_Node, + Packages => Empty_Node, + Pkg_Id => Empty_Package, + Name => No_Name, + Path_Name => No_Name, + Value => No_String, + Field1 => Empty_Node, + Field2 => Empty_Node, + Field3 => Empty_Node); + return Project_Nodes.Last; + end Default_Project_Node; + + ------------------ + -- Directory_Of -- + ------------------ + + function Directory_Of (Node : Project_Node_Id) return Name_Id is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Directory; + end Directory_Of; + + ------------------------ + -- Expression_Kind_Of -- + ------------------------ + + function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Literal_String + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Expression + or else + Project_Nodes.Table (Node).Kind = N_Term + or else + Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + + return Project_Nodes.Table (Node).Expr_Kind; + end Expression_Kind_Of; + + ------------------- + -- Expression_Of -- + ------------------- + + function Expression_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration)); + + return Project_Nodes.Table (Node).Field1; + end Expression_Of; + + --------------------------- + -- External_Reference_Of -- + --------------------------- + + function External_Reference_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_External_Value); + return Project_Nodes.Table (Node).Field1; + end External_Reference_Of; + + ------------------------- + -- External_Default_Of -- + ------------------------- + + function External_Default_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_External_Value); + return Project_Nodes.Table (Node).Field2; + end External_Default_Of; + + ------------------------ + -- First_Case_Item_Of -- + ------------------------ + + function First_Case_Item_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Construction); + return Project_Nodes.Table (Node).Field2; + end First_Case_Item_Of; + + --------------------- + -- First_Choice_Of -- + --------------------- + + function First_Choice_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Item); + return Project_Nodes.Table (Node).Field1; + end First_Choice_Of; + + ------------------------------- + -- First_Declarative_Item_Of -- + ------------------------------- + + function First_Declarative_Item_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Case_Item + or else + Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + if Project_Nodes.Table (Node).Kind = N_Project_Declaration then + return Project_Nodes.Table (Node).Field1; + else + return Project_Nodes.Table (Node).Field2; + end if; + end First_Declarative_Item_Of; + + ------------------------------ + -- First_Expression_In_List -- + ------------------------------ + + function First_Expression_In_List + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Literal_String_List); + return Project_Nodes.Table (Node).Field1; + end First_Expression_In_List; + + -------------------------- + -- First_Literal_String -- + -------------------------- + + function First_Literal_String + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); + return Project_Nodes.Table (Node).Field1; + end First_Literal_String; + + ---------------------- + -- First_Package_Of -- + ---------------------- + + function First_Package_Of + (Node : Project_Node_Id) + return Package_Declaration_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Packages; + end First_Package_Of; + + -------------------------- + -- First_String_Type_Of -- + -------------------------- + + function First_String_Type_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Field3; + end First_String_Type_Of; + + ---------------- + -- First_Term -- + ---------------- + + function First_Term + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Expression); + return Project_Nodes.Table (Node).Field1; + end First_Term; + + ----------------------- + -- First_Variable_Of -- + ----------------------- + + function First_Variable_Of + (Node : Project_Node_Id) + return Variable_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project + or else + Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + return Project_Nodes.Table (Node).Variables; + end First_Variable_Of; + + -------------------------- + -- First_With_Clause_Of -- + -------------------------- + + function First_With_Clause_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Field1; + end First_With_Clause_Of; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Project_Nodes.Set_Last (Empty_Node); + Projects_Htable.Reset; + end Initialize; + + ------------- + -- Kind_Of -- + ------------- + + function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind is + begin + pragma Assert (Node /= Empty_Node); + return Project_Nodes.Table (Node).Kind; + end Kind_Of; + + ----------------- + -- Location_Of -- + ----------------- + + function Location_Of (Node : Project_Node_Id) return Source_Ptr is + begin + pragma Assert (Node /= Empty_Node); + return Project_Nodes.Table (Node).Location; + end Location_Of; + + ------------------------- + -- Modified_Project_Of -- + ------------------------- + + function Modified_Project_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project_Declaration); + return Project_Nodes.Table (Node).Field2; + end Modified_Project_Of; + + ------------------------------ + -- Modified_Project_Path_Of -- + ------------------------------ + + function Modified_Project_Path_Of + (Node : Project_Node_Id) + return String_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Value; + end Modified_Project_Path_Of; + + ------------- + -- Name_Of -- + ------------- + + function Name_Of (Node : Project_Node_Id) return Name_Id is + begin + pragma Assert (Node /= Empty_Node); + return Project_Nodes.Table (Node).Name; + end Name_Of; + + -------------------- + -- Next_Case_Item -- + -------------------- + + function Next_Case_Item + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Item); + return Project_Nodes.Table (Node).Field3; + end Next_Case_Item; + + --------------------------- + -- Next_Declarative_Item -- + --------------------------- + + function Next_Declarative_Item + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Declarative_Item); + return Project_Nodes.Table (Node).Field2; + end Next_Declarative_Item; + + ----------------------------- + -- Next_Expression_In_List -- + ----------------------------- + + function Next_Expression_In_List + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Expression); + return Project_Nodes.Table (Node).Field2; + end Next_Expression_In_List; + + ------------------------- + -- Next_Literal_String -- + ------------------------- + + function Next_Literal_String + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Literal_String); + return Project_Nodes.Table (Node).Field1; + end Next_Literal_String; + + ----------------------------- + -- Next_Package_In_Project -- + ----------------------------- + + function Next_Package_In_Project + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return Project_Nodes.Table (Node).Field3; + end Next_Package_In_Project; + + ---------------------- + -- Next_String_Type -- + ---------------------- + + function Next_String_Type + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); + return Project_Nodes.Table (Node).Field2; + end Next_String_Type; + + --------------- + -- Next_Term -- + --------------- + + function Next_Term + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Term); + return Project_Nodes.Table (Node).Field2; + end Next_Term; + + ------------------- + -- Next_Variable -- + ------------------- + + function Next_Variable + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration)); + + return Project_Nodes.Table (Node).Field3; + end Next_Variable; + + ------------------------- + -- Next_With_Clause_Of -- + ------------------------- + + function Next_With_Clause_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_With_Clause); + return Project_Nodes.Table (Node).Field2; + end Next_With_Clause_Of; + + ------------------- + -- Package_Id_Of -- + ------------------- + + function Package_Id_Of (Node : Project_Node_Id) return Package_Node_Id is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return Project_Nodes.Table (Node).Pkg_Id; + end Package_Id_Of; + + --------------------- + -- Package_Node_Of -- + --------------------- + + function Package_Node_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return Project_Nodes.Table (Node).Field2; + end Package_Node_Of; + + ------------------ + -- Path_Name_Of -- + ------------------ + + function Path_Name_Of (Node : Project_Node_Id) return Name_Id is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project + or else + Project_Nodes.Table (Node).Kind = N_With_Clause)); + return Project_Nodes.Table (Node).Path_Name; + end Path_Name_Of; + + ---------------------------- + -- Project_Declaration_Of -- + ---------------------------- + + function Project_Declaration_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + return Project_Nodes.Table (Node).Field2; + end Project_Declaration_Of; + + --------------------- + -- Project_Node_Of -- + --------------------- + + function Project_Node_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_With_Clause + or else + Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + return Project_Nodes.Table (Node).Field1; + end Project_Node_Of; + + ----------------------------------- + -- Project_Of_Renamed_Package_Of -- + ----------------------------------- + + function Project_Of_Renamed_Package_Of + (Node : Project_Node_Id) + return Project_Node_Id + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + return Project_Nodes.Table (Node).Field1; + end Project_Of_Renamed_Package_Of; + + ------------------------------------ + -- Set_Associative_Array_Index_Of -- + ------------------------------------ + + procedure Set_Associative_Array_Index_Of + (Node : Project_Node_Id; + To : String_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); + Project_Nodes.Table (Node).Value := To; + end Set_Associative_Array_Index_Of; + + ------------------------------------ + -- Set_Case_Variable_Reference_Of -- + ------------------------------------ + + procedure Set_Case_Variable_Reference_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Construction); + Project_Nodes.Table (Node).Field1 := To; + end Set_Case_Variable_Reference_Of; + + --------------------------- + -- Set_Current_Item_Node -- + --------------------------- + + procedure Set_Current_Item_Node + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Declarative_Item); + Project_Nodes.Table (Node).Field1 := To; + end Set_Current_Item_Node; + + ---------------------- + -- Set_Current_Term -- + ---------------------- + + procedure Set_Current_Term + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Term); + Project_Nodes.Table (Node).Field1 := To; + end Set_Current_Term; + + ---------------------- + -- Set_Directory_Of -- + ---------------------- + + procedure Set_Directory_Of + (Node : Project_Node_Id; + To : Name_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Directory := To; + end Set_Directory_Of; + + ---------------------------- + -- Set_Expression_Kind_Of -- + ---------------------------- + + procedure Set_Expression_Kind_Of + (Node : Project_Node_Id; + To : Variable_Kind) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Literal_String + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Expression + or else + Project_Nodes.Table (Node).Kind = N_Term + or else + Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + Project_Nodes.Table (Node).Expr_Kind := To; + end Set_Expression_Kind_Of; + + ----------------------- + -- Set_Expression_Of -- + ----------------------- + + procedure Set_Expression_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration)); + Project_Nodes.Table (Node).Field1 := To; + end Set_Expression_Of; + + ------------------------------- + -- Set_External_Reference_Of -- + ------------------------------- + + procedure Set_External_Reference_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_External_Value); + Project_Nodes.Table (Node).Field1 := To; + end Set_External_Reference_Of; + + ----------------------------- + -- Set_External_Default_Of -- + ----------------------------- + + procedure Set_External_Default_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_External_Value); + Project_Nodes.Table (Node).Field2 := To; + end Set_External_Default_Of; + + ---------------------------- + -- Set_First_Case_Item_Of -- + ---------------------------- + + procedure Set_First_Case_Item_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Construction); + Project_Nodes.Table (Node).Field2 := To; + end Set_First_Case_Item_Of; + + ------------------------- + -- Set_First_Choice_Of -- + ------------------------- + + procedure Set_First_Choice_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Item); + Project_Nodes.Table (Node).Field1 := To; + end Set_First_Choice_Of; + + ------------------------ + -- Set_Next_Case_Item -- + ------------------------ + + procedure Set_Next_Case_Item + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Case_Item); + Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Case_Item; + + ----------------------------------- + -- Set_First_Declarative_Item_Of -- + ----------------------------------- + + procedure Set_First_Declarative_Item_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Case_Item + or else + Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + + if Project_Nodes.Table (Node).Kind = N_Project_Declaration then + Project_Nodes.Table (Node).Field1 := To; + else + Project_Nodes.Table (Node).Field2 := To; + end if; + end Set_First_Declarative_Item_Of; + + ---------------------------------- + -- Set_First_Expression_In_List -- + ---------------------------------- + + procedure Set_First_Expression_In_List + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Literal_String_List); + Project_Nodes.Table (Node).Field1 := To; + end Set_First_Expression_In_List; + + ------------------------------ + -- Set_First_Literal_String -- + ------------------------------ + + procedure Set_First_Literal_String + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); + Project_Nodes.Table (Node).Field1 := To; + end Set_First_Literal_String; + + -------------------------- + -- Set_First_Package_Of -- + -------------------------- + + procedure Set_First_Package_Of + (Node : Project_Node_Id; + To : Package_Declaration_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Packages := To; + end Set_First_Package_Of; + + ------------------------------ + -- Set_First_String_Type_Of -- + ------------------------------ + + procedure Set_First_String_Type_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Field3 := To; + end Set_First_String_Type_Of; + + -------------------- + -- Set_First_Term -- + -------------------- + + procedure Set_First_Term + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Expression); + Project_Nodes.Table (Node).Field1 := To; + end Set_First_Term; + + --------------------------- + -- Set_First_Variable_Of -- + --------------------------- + + procedure Set_First_Variable_Of + (Node : Project_Node_Id; + To : Variable_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project + or else + Project_Nodes.Table (Node).Kind = N_Package_Declaration)); + Project_Nodes.Table (Node).Variables := To; + end Set_First_Variable_Of; + + ------------------------------ + -- Set_First_With_Clause_Of -- + ------------------------------ + + procedure Set_First_With_Clause_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Field1 := To; + end Set_First_With_Clause_Of; + + ----------------- + -- Set_Kind_Of -- + ----------------- + + procedure Set_Kind_Of + (Node : Project_Node_Id; + To : Project_Node_Kind) + is + begin + pragma Assert (Node /= Empty_Node); + Project_Nodes.Table (Node).Kind := To; + end Set_Kind_Of; + + --------------------- + -- Set_Location_Of -- + --------------------- + + procedure Set_Location_Of + (Node : Project_Node_Id; + To : Source_Ptr) + is + begin + pragma Assert (Node /= Empty_Node); + Project_Nodes.Table (Node).Location := To; + end Set_Location_Of; + + ----------------------------- + -- Set_Modified_Project_Of -- + ----------------------------- + + procedure Set_Modified_Project_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project_Declaration); + Project_Nodes.Table (Node).Field2 := To; + end Set_Modified_Project_Of; + + ---------------------------------- + -- Set_Modified_Project_Path_Of -- + ---------------------------------- + + procedure Set_Modified_Project_Path_Of + (Node : Project_Node_Id; + To : String_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Value := To; + end Set_Modified_Project_Path_Of; + + ----------------- + -- Set_Name_Of -- + ----------------- + + procedure Set_Name_Of + (Node : Project_Node_Id; + To : Name_Id) + is + begin + pragma Assert (Node /= Empty_Node); + Project_Nodes.Table (Node).Name := To; + end Set_Name_Of; + + ------------------------------- + -- Set_Next_Declarative_Item -- + ------------------------------- + + procedure Set_Next_Declarative_Item + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Declarative_Item); + Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Declarative_Item; + + --------------------------------- + -- Set_Next_Expression_In_List -- + --------------------------------- + + procedure Set_Next_Expression_In_List + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Expression); + Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Expression_In_List; + + ----------------------------- + -- Set_Next_Literal_String -- + ----------------------------- + + procedure Set_Next_Literal_String + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Literal_String); + Project_Nodes.Table (Node).Field1 := To; + end Set_Next_Literal_String; + + --------------------------------- + -- Set_Next_Package_In_Project -- + --------------------------------- + + procedure Set_Next_Package_In_Project + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Package_In_Project; + + -------------------------- + -- Set_Next_String_Type -- + -------------------------- + + procedure Set_Next_String_Type + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); + Project_Nodes.Table (Node).Field2 := To; + end Set_Next_String_Type; + + ------------------- + -- Set_Next_Term -- + ------------------- + + procedure Set_Next_Term + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Term); + Project_Nodes.Table (Node).Field2 := To; + end Set_Next_Term; + + ----------------------- + -- Set_Next_Variable -- + ----------------------- + + procedure Set_Next_Variable + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration + or else + Project_Nodes.Table (Node).Kind = N_Variable_Declaration)); + Project_Nodes.Table (Node).Field3 := To; + end Set_Next_Variable; + + ----------------------------- + -- Set_Next_With_Clause_Of -- + ----------------------------- + + procedure Set_Next_With_Clause_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_With_Clause); + Project_Nodes.Table (Node).Field2 := To; + end Set_Next_With_Clause_Of; + + ----------------------- + -- Set_Package_Id_Of -- + ----------------------- + + procedure Set_Package_Id_Of + (Node : Project_Node_Id; + To : Package_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + Project_Nodes.Table (Node).Pkg_Id := To; + end Set_Package_Id_Of; + + ------------------------- + -- Set_Package_Node_Of -- + ------------------------- + + procedure Set_Package_Node_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + Project_Nodes.Table (Node).Field2 := To; + end Set_Package_Node_Of; + + ---------------------- + -- Set_Path_Name_Of -- + ---------------------- + + procedure Set_Path_Name_Of + (Node : Project_Node_Id; + To : Name_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Project + or else + Project_Nodes.Table (Node).Kind = N_With_Clause)); + Project_Nodes.Table (Node).Path_Name := To; + end Set_Path_Name_Of; + + -------------------------------- + -- Set_Project_Declaration_Of -- + -------------------------------- + + procedure Set_Project_Declaration_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Project); + Project_Nodes.Table (Node).Field2 := To; + end Set_Project_Declaration_Of; + + ------------------------- + -- Set_Project_Node_Of -- + ------------------------- + + procedure Set_Project_Node_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_With_Clause + or else + Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Attribute_Reference)); + Project_Nodes.Table (Node).Field1 := To; + end Set_Project_Node_Of; + + --------------------------------------- + -- Set_Project_Of_Renamed_Package_Of -- + --------------------------------------- + + procedure Set_Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + Project_Nodes.Table (Node).Kind = N_Package_Declaration); + Project_Nodes.Table (Node).Field1 := To; + end Set_Project_Of_Renamed_Package_Of; + + ------------------------ + -- Set_String_Type_Of -- + ------------------------ + + procedure Set_String_Type_Of + (Node : Project_Node_Id; + To : Project_Node_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration) + and then + Project_Nodes.Table (To).Kind = N_String_Type_Declaration); + + if Project_Nodes.Table (Node).Kind = N_Variable_Reference then + Project_Nodes.Table (Node).Field3 := To; + else + Project_Nodes.Table (Node).Field2 := To; + end if; + end Set_String_Type_Of; + + ------------------------- + -- Set_String_Value_Of -- + ------------------------- + + procedure Set_String_Value_Of + (Node : Project_Node_Id; + To : String_Id) + is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_With_Clause + or else + Project_Nodes.Table (Node).Kind = N_Literal_String)); + Project_Nodes.Table (Node).Value := To; + end Set_String_Value_Of; + + -------------------- + -- String_Type_Of -- + -------------------- + + function String_Type_Of (Node : Project_Node_Id) + return Project_Node_Id is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_Variable_Reference + or else + Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration)); + + if Project_Nodes.Table (Node).Kind = N_Variable_Reference then + return Project_Nodes.Table (Node).Field3; + else + return Project_Nodes.Table (Node).Field2; + end if; + end String_Type_Of; + + --------------------- + -- String_Value_Of -- + --------------------- + + function String_Value_Of (Node : Project_Node_Id) return String_Id is + begin + pragma Assert + (Node /= Empty_Node + and then + (Project_Nodes.Table (Node).Kind = N_With_Clause + or else + Project_Nodes.Table (Node).Kind = N_Literal_String)); + return Project_Nodes.Table (Node).Value; + end String_Value_Of; + + -------------------- + -- Value_Is_Valid -- + -------------------- + + function Value_Is_Valid + (For_Typed_Variable : Project_Node_Id; + Value : String_Id) + return Boolean + is + begin + pragma Assert + (For_Typed_Variable /= Empty_Node + and then + (Project_Nodes.Table (For_Typed_Variable).Kind = + N_Typed_Variable_Declaration)); + + declare + Current_String : Project_Node_Id := + First_Literal_String + (String_Type_Of (For_Typed_Variable)); + + begin + while Current_String /= Empty_Node + and then + not String_Equal (String_Value_Of (Current_String), Value) + loop + Current_String := + Next_Literal_String (Current_String); + end loop; + + return Current_String /= Empty_Node; + end; + + end Value_Is_Valid; + +end Prj.Tree; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads new file mode 100644 index 00000000000..d32fcb19808 --- /dev/null +++ b/gcc/ada/prj-tree.ads @@ -0,0 +1,742 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . T R E E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the structure of the Project File tree. + +with GNAT.HTable; + +with Prj.Attr; use Prj.Attr; +with Prj.Com; use Prj.Com; +with Types; use Types; +with Table; + +package Prj.Tree is + + Project_Nodes_Initial : constant := 1_000; + -- Initial number of nodes in table Tree_Private_Part.Project_Nodes + Project_Nodes_Increment : constant := 100; + + Project_Node_Low_Bound : constant := 0; + Project_Node_High_Bound : constant := 099_999_999; -- In practice, infinite + + type Project_Node_Id is range + Project_Node_Low_Bound .. Project_Node_High_Bound; + -- The index of table Tree_Private_Part.Project_Nodes + + Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound; + -- Designates no node in table Project_Nodes + First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound; + + subtype Variable_Node_Id is Project_Node_Id; + -- Used to designate a node whose expected kind is + -- N_Typed_Variable_Declaration, N_Variable_Declaration or + -- N_Variable_Reference. + subtype Package_Declaration_Id is Project_Node_Id; + -- Used to designate a node whose expected kind is + -- N_Project_Declaration. + + type Project_Node_Kind is + (N_Project, + N_With_Clause, + N_Project_Declaration, + N_Declarative_Item, + N_Package_Declaration, + N_String_Type_Declaration, + N_Literal_String, + N_Attribute_Declaration, + N_Typed_Variable_Declaration, + N_Variable_Declaration, + N_Expression, + N_Term, + N_Literal_String_List, + N_Variable_Reference, + N_External_Value, + N_Attribute_Reference, + N_Case_Construction, + N_Case_Item); + -- Each node in the tree is of a Project_Node_Kind + -- For the signification of the fields in each node of a + -- Project_Node_Kind, look at package Tree_Private_Part. + + procedure Initialize; + -- Initialize the Project File tree: empty the Project_Nodes table + -- and reset the Projects_Htable. + + function Default_Project_Node + (Of_Kind : Project_Node_Kind; + And_Expr_Kind : Variable_Kind := Undefined) + return Project_Node_Id; + -- Returns a Project_Node_Record with the specified Kind and + -- Expr_Kind; all the other components have default nil values. + + ---------------------- + -- Access Functions -- + ---------------------- + + -- The following query functions are part of the abstract interface + -- of the Project File tree + + function Name_Of (Node : Project_Node_Id) return Name_Id; + -- Valid for all non empty nodes. May return No_Name for nodes that have + -- no names. + + function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind; + -- Valid for all non empty nodes + + function Location_Of (Node : Project_Node_Id) return Source_Ptr; + -- Valid for all non empty nodes + + function Directory_Of (Node : Project_Node_Id) return Name_Id; + -- Only valid for N_Project nodes. + + function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind; + -- Only valid for N_Literal_String, N_Attribute_Declaration, + -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, + -- N_Term, N_Variable_Reference or N_Attribute_Reference nodes. + + function First_Variable_Of + (Node : Project_Node_Id) + return Variable_Node_Id; + -- Only valid for N_Project or N_Package_Declaration nodes + + function First_Package_Of + (Node : Project_Node_Id) + return Package_Declaration_Id; + -- Only valid for N_Project nodes + + function Package_Id_Of (Node : Project_Node_Id) return Package_Node_Id; + -- Only valid for N_Package_Declaration nodes + + function Path_Name_Of (Node : Project_Node_Id) return Name_Id; + -- Only valid for N_Project and N_With_Clause nodes. + + function String_Value_Of (Node : Project_Node_Id) return String_Id; + -- Only valid for N_With_Clause or N_Literal_String nodes. + + function First_With_Clause_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Project nodes + + function Project_Declaration_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Project nodes + + function First_String_Type_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Project nodes + + function Modified_Project_Path_Of + (Node : Project_Node_Id) + return String_Id; + -- Only valid for N_With_Clause nodes + + function Project_Node_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Project nodes + + function Next_With_Clause_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_With_Clause nodes + + function First_Declarative_Item_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_With_Clause nodes + + function Modified_Project_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_With_Clause nodes + + function Current_Item_Node + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Declarative_Item nodes + + function Next_Declarative_Item + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Declarative_Item node + + function Project_Of_Renamed_Package_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Package_Declaration nodes. + -- May return Empty_Node. + + function Next_Package_In_Project + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Package_Declaration nodes + + function First_Literal_String + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_String_Type_Declaration nodes + + function Next_String_Type + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_String_Type_Declaration nodes + + function Next_Literal_String + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Literal_String nodes + + function Expression_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration + -- or N_Variable_Declaration nodes + + function Value_Is_Valid + (For_Typed_Variable : Project_Node_Id; + Value : String_Id) + return Boolean; + -- Only valid for N_Typed_Variable_Declaration. Returns True if Value is + -- in the list of allowed strings for For_Typed_Variable. False otherwise. + + function Associative_Array_Index_Of + (Node : Project_Node_Id) + return String_Id; + -- Only valid for N_Attribute_Declaration. + -- Returns No_String for non associative array attributes. + + function Next_Variable + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration + -- nodes. + + function First_Term + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Expression nodes + + function Next_Expression_In_List + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Expression nodes + + function Current_Term + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Term nodes + + function Next_Term + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Term nodes + + function First_Expression_In_List + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Literal_String_List nodes + + function Package_Node_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. + -- May return Empty_Node. + + function String_Type_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration + -- nodes. + + function External_Reference_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_External_Value nodes + + function External_Default_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_External_Value nodes + + function Case_Variable_Reference_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Case_Construction nodes + + function First_Case_Item_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Case_Construction nodes + + function First_Choice_Of + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Case_Item nodes + + function Next_Case_Item + (Node : Project_Node_Id) + return Project_Node_Id; + -- Only valid for N_Case_Item nodes + + -------------------- + -- Set Procedures -- + -------------------- + + -- The following procedures are part of the abstract interface of + -- the Project File tree. + + -- Each Set_* procedure is valid only for the same Project_Node_Kind + -- nodes as the corresponding query function above. + + procedure Set_Name_Of + (Node : Project_Node_Id; + To : Name_Id); + + procedure Set_Kind_Of + (Node : Project_Node_Id; + To : Project_Node_Kind); + + procedure Set_Location_Of + (Node : Project_Node_Id; + To : Source_Ptr); + + procedure Set_Directory_Of + (Node : Project_Node_Id; + To : Name_Id); + + procedure Set_Expression_Kind_Of + (Node : Project_Node_Id; + To : Variable_Kind); + + procedure Set_First_Variable_Of + (Node : Project_Node_Id; + To : Variable_Node_Id); + + procedure Set_First_Package_Of + (Node : Project_Node_Id; + To : Package_Declaration_Id); + + procedure Set_Package_Id_Of + (Node : Project_Node_Id; + To : Package_Node_Id); + + procedure Set_Path_Name_Of + (Node : Project_Node_Id; + To : Name_Id); + + procedure Set_String_Value_Of + (Node : Project_Node_Id; + To : String_Id); + + procedure Set_First_With_Clause_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Project_Declaration_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_String_Type_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Modified_Project_Path_Of + (Node : Project_Node_Id; + To : String_Id); + + procedure Set_Project_Node_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_With_Clause_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Declarative_Item_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Modified_Project_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Current_Item_Node + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Declarative_Item + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Project_Of_Renamed_Package_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Package_In_Project + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Literal_String + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_String_Type + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Literal_String + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Expression_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Associative_Array_Index_Of + (Node : Project_Node_Id; + To : String_Id); + + procedure Set_Next_Variable + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Term + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Expression_In_List + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Current_Term + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Term + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Expression_In_List + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Package_Node_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_String_Type_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_External_Reference_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_External_Default_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Case_Variable_Reference_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Case_Item_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_First_Choice_Of + (Node : Project_Node_Id; + To : Project_Node_Id); + + procedure Set_Next_Case_Item + (Node : Project_Node_Id; + To : Project_Node_Id); + + ------------------------------- + -- Restricted Access Section -- + ------------------------------- + + package Tree_Private_Part is + + -- This is conceptually in the private part. + -- However, for efficiency, some packages are accessing it directly. + + type Project_Node_Record is record + + Kind : Project_Node_Kind; + + Location : Source_Ptr := No_Location; + + Directory : Name_Id := No_Name; + -- Only for N_Project + + Expr_Kind : Variable_Kind := Undefined; + -- See below for what Project_Node_Kind it is used + + Variables : Variable_Node_Id := Empty_Node; + -- First variable in a project or a package + + Packages : Package_Declaration_Id := Empty_Node; + -- First package declaration in a project + + Pkg_Id : Package_Node_Id := Empty_Package; + -- Only use in Package_Declaration + + Name : Name_Id := No_Name; + -- See below for what Project_Node_Kind it is used + + Path_Name : Name_Id := No_Name; + -- See below for what Project_Node_Kind it is used + + Value : String_Id := No_String; + -- See below for what Project_Node_Kind it is used + + Field1 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Field2 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + Field3 : Project_Node_Id := Empty_Node; + -- See below the meaning for each Project_Node_Kind + + end record; + + -- type Project_Node_Kind is + + -- (N_Project, + -- -- Name: project name + -- -- Path_Name: project path name + -- -- Expr_Kind: Undefined + -- -- Field1: first with clause + -- -- Field2: project declaration + -- -- Field3: first string type + -- -- Value: modified project path name (if any) + + -- N_With_Clause, + -- -- Name: imported project name + -- -- Path_Name: imported project path name + -- -- Expr_Kind: Undefined + -- -- Field1: project node + -- -- Field2: next with clause + -- -- Field3: not used + -- -- Value: literal string withed + + -- N_Project_Declaration, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: first declarative item + -- -- Field2: modified project + -- -- Field3: not used + -- -- Value: not used + + -- N_Declarative_Item, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: current item node + -- -- Field2: next declarative item + -- -- Field3: not used + -- -- Value: not used + + -- N_Package_Declaration, + -- -- Name: package name + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: project of renamed package (if any) + -- -- Field2: first declarative item + -- -- Field3: next package in project + -- -- Value: not used + + -- N_String_Type_Declaration, + -- -- Name: type name + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: first literal string + -- -- Field2: next string type + -- -- Field3: not used + -- -- Value: not used + + -- N_Literal_String, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: next literal string + -- -- Field2: not used + -- -- Field3: not used + -- -- Value: string value + + -- N_Attribute_Declaration, + -- -- Name: attribute name + -- -- Path_Name: not used + -- -- Expr_Kind: attribute kind + -- -- Field1: expression + -- -- Field2: not used + -- -- Field3: not used + -- -- Value: associative array index + -- -- (if an associative array element) + + -- N_Typed_Variable_Declaration, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: expression + -- -- Field2: type of variable (N_String_Type_Declaration) + -- -- Field3: next variable + -- -- Value: not used + + -- N_Variable_Declaration, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: variable kind + -- -- Field1: expression + -- -- Field2: not used + -- -- Field3 is used for next variable, instead of Field2, + -- -- so that it is the same field for + -- -- N_Variable_Declaration and + -- -- N_Typed_Variable_Declaration + -- -- Field3: next variable + -- -- Value: not used + + -- N_Expression, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: expression kind + -- -- Field1: first term + -- -- Field2: next expression in list + -- -- Field3: not used + -- -- Value: not used + + -- N_Term, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: term kind + -- -- Field1: current term + -- -- Field2: next term in the expression + -- -- Field3: not used + -- -- Value: not used + + -- N_Literal_String_List, + -- -- Designates a list of string expressions between brackets + -- -- separated by commas. The string expressions are not necessarily + -- -- literal strings. + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: List + -- -- Field1: first expression + -- -- Field2: not used + -- -- Field3: not used + -- -- Value: not used + + -- N_Variable_Reference, + -- -- Name: variable name + -- -- Path_Name: not used + -- -- Expr_Kind: variable kind + -- -- Field1: project (if specified) + -- -- Field2: package (if specified) + -- -- Field3: type of variable (N_String_Type_Declaration), if any + -- -- Value: not used + + -- N_External_Value, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Single + -- -- Field1: Name of the external reference (literal string) + -- -- Field2: Default (literal string) + -- -- Field3: not used + -- -- Value: not used + + -- N_Attribute_Reference, + -- -- Name: attribute name + -- -- Path_Name: not used + -- -- Expr_Kind: attribute kind + -- -- Field1: project + -- -- Field2: package (if attribute of a package) + -- -- Field3: not used + -- -- Value: not used + + -- N_Case_Construction, + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: Undefined + -- -- Field1: case variable reference + -- -- Field2: first case item + -- -- Field3: not used + -- -- Value: not used + + -- N_Case_Item); + -- -- Name: not used + -- -- Path_Name: not used + -- -- Expr_Kind: not used + -- -- Field1: first choice (literal string) + -- -- Field2: first declarative item + -- -- Field3: next case item + -- -- Value: not used + + package Project_Nodes is + new Table.Table (Table_Component_Type => Project_Node_Record, + Table_Index_Type => Project_Node_Id, + Table_Low_Bound => First_Node_Id, + Table_Initial => Project_Nodes_Initial, + Table_Increment => Project_Nodes_Increment, + Table_Name => "Project_Nodes"); + -- This table contains the syntactic tree of project data + -- from project files. + + type Project_Name_And_Node is record + Name : Name_Id; + -- Name of the project + Node : Project_Node_Id; + -- Node of the project in table Project_Nodes + Modified : Boolean; + -- True when the project is being modified by another project + end record; + + No_Project_Name_And_Node : constant Project_Name_And_Node := + (Name => No_Name, Node => Empty_Node, Modified => True); + + package Projects_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Name_And_Node, + No_Element => No_Project_Name_And_Node, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- This hash table contains a mapping of project names to project nodes. + -- Note that this hash table contains only the nodes whose Kind is + -- N_Project. It is used to find the node of a project from its + -- name, and to verify if a project has already been parsed, knowing + -- its name. + + end Tree_Private_Part; + +end Prj.Tree; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb new file mode 100644 index 00000000000..6a94a0cfc4c --- /dev/null +++ b/gcc/ada/prj-util.adb @@ -0,0 +1,415 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . U T I L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Namet; use Namet; +with Osint; +with Output; use Output; +with Stringt; use Stringt; + +package body Prj.Util is + + procedure Free is new Ada.Unchecked_Deallocation + (Text_File_Data, Text_File); + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out Text_File) is + begin + if File = null then + Osint.Fail ("Close attempted on an invalid Text_File"); + end if; + + Close (File.FD); + Free (File); + end Close; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : Text_File) return Boolean is + begin + if File = null then + Osint.Fail ("End_Of_File attempted on an invalid Text_File"); + end if; + + return File.End_Of_File_Reached; + end End_Of_File; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : Text_File; + Line : out String; + Last : out Natural) + is + C : Character; + + procedure Advance; + + ------------- + -- Advance -- + ------------- + + procedure Advance is + begin + if File.Cursor = File.Buffer_Len then + File.Buffer_Len := + Read + (FD => File.FD, + A => File.Buffer'Address, + N => File.Buffer'Length); + + if File.Buffer_Len = 0 then + File.End_Of_File_Reached := True; + return; + else + File.Cursor := 1; + end if; + + else + File.Cursor := File.Cursor + 1; + end if; + end Advance; + + -- Start of processing for Get_Line + + begin + if File = null then + Osint.Fail ("Get_Line attempted on an invalid Text_File"); + end if; + + Last := Line'First - 1; + + if not File.End_Of_File_Reached then + loop + C := File.Buffer (File.Cursor); + exit when C = ASCII.CR or else C = ASCII.LF; + Last := Last + 1; + Line (Last) := C; + Advance; + + if File.End_Of_File_Reached then + return; + end if; + + exit when Last = Line'Last; + end loop; + + if C = ASCII.CR or else C = ASCII.LF then + Advance; + + if File.End_Of_File_Reached then + return; + end if; + end if; + + if C = ASCII.CR + and then File.Buffer (File.Cursor) = ASCII.LF + then + Advance; + end if; + end if; + end Get_Line; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (File : Text_File) return Boolean is + begin + return File /= null; + end Is_Valid; + + ---------- + -- Open -- + ---------- + + procedure Open (File : out Text_File; Name : in String) is + FD : File_Descriptor; + File_Name : String (1 .. Name'Length + 1); + + begin + File_Name (1 .. Name'Length) := Name; + File_Name (File_Name'Last) := ASCII.NUL; + FD := Open_Read (Name => File_Name'Address, + Fmode => GNAT.OS_Lib.Text); + if FD = Invalid_FD then + File := null; + else + File := new Text_File_Data; + File.FD := FD; + File.Buffer_Len := + Read (FD => FD, + A => File.Buffer'Address, + N => File.Buffer'Length); + + if File.Buffer_Len = 0 then + File.End_Of_File_Reached := True; + else + File.Cursor := 1; + end if; + end if; + end Open; + + -------------- + -- Value_Of -- + -------------- + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id) + return Name_Id + is + Current : Array_Element_Id := In_Array; + Element : Array_Element; + + begin + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + if Index = Element.Index then + exit when Element.Value.Kind /= Single; + exit when String_Length (Element.Value.Value) = 0; + String_To_Name_Buffer (Element.Value.Value); + return Name_Find; + else + Current := Element.Next; + end if; + end loop; + + return No_Name; + end Value_Of; + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id) + return Variable_Value + is + Current : Array_Element_Id := In_Array; + Element : Array_Element; + + begin + while Current /= No_Array_Element loop + Element := Array_Elements.Table (Current); + + if Index = Element.Index then + return Element.Value; + else + Current := Element.Next; + end if; + end loop; + + return Nil_Variable_Value; + end Value_Of; + + function Value_Of + (Name : Name_Id; + Attribute_Or_Array_Name : Name_Id; + In_Package : Package_Id) + return Variable_Value + is + The_Array : Array_Element_Id; + The_Attribute : Variable_Value := Nil_Variable_Value; + + begin + if In_Package /= No_Package then + + -- First, look if there is an array element that fits + + The_Array := + Value_Of + (Name => Attribute_Or_Array_Name, + In_Arrays => Packages.Table (In_Package).Decl.Arrays); + The_Attribute := + Value_Of + (Index => Name, + In_Array => The_Array); + + -- If there is no array element, look for a variable + + if The_Attribute = Nil_Variable_Value then + The_Attribute := + Value_Of + (Variable_Name => Attribute_Or_Array_Name, + In_Variables => Packages.Table (In_Package).Decl.Attributes); + end if; + end if; + + return The_Attribute; + end Value_Of; + + function Value_Of + (Index : Name_Id; + In_Array : Name_Id; + In_Arrays : Array_Id) + return Name_Id + is + Current : Array_Id := In_Arrays; + The_Array : Array_Data; + + begin + while Current /= No_Array loop + The_Array := Arrays.Table (Current); + if The_Array.Name = In_Array then + return Value_Of (Index, In_Array => The_Array.Value); + else + Current := The_Array.Next; + end if; + end loop; + + return No_Name; + end Value_Of; + + function Value_Of + (Name : Name_Id; + In_Arrays : Array_Id) + return Array_Element_Id + is + Current : Array_Id := In_Arrays; + The_Array : Array_Data; + + begin + while Current /= No_Array loop + The_Array := Arrays.Table (Current); + if The_Array.Name = Name then + return The_Array.Value; + else + Current := The_Array.Next; + end if; + end loop; + + return No_Array_Element; + end Value_Of; + + function Value_Of + (Name : Name_Id; + In_Packages : Package_Id) + return Package_Id + is + Current : Package_Id := In_Packages; + The_Package : Package_Element; + + begin + while Current /= No_Package loop + The_Package := Packages.Table (Current); + exit when The_Package.Name /= No_Name and then + The_Package.Name = Name; + Current := The_Package.Next; + end loop; + + return Current; + end Value_Of; + + function Value_Of + (Variable_Name : Name_Id; + In_Variables : Variable_Id) + return Variable_Value + is + Current : Variable_Id := In_Variables; + The_Variable : Variable; + + begin + while Current /= No_Variable loop + The_Variable := Variable_Elements.Table (Current); + + if Variable_Name = The_Variable.Name then + return The_Variable.Value; + else + Current := The_Variable.Next; + end if; + end loop; + + return Nil_Variable_Value; + end Value_Of; + + --------------- + -- Write_Str -- + --------------- + + procedure Write_Str + (S : String; + Max_Length : Positive; + Separator : Character) + is + First : Positive := S'First; + Last : Natural := S'Last; + + begin + -- Nothing to do for empty strings + + if S'Length > 0 then + -- Start on a new line if current line is already longer than + -- Max_Length. + + if Positive (Column) >= Max_Length then + Write_Eol; + end if; + + -- If length of remainder is longer than Max_Length, we need to + -- cut the remainder in several lines. + + while Positive (Column) + S'Last - First > Max_Length loop + -- Try the maximum length possible + + Last := First + Max_Length - Positive (Column); + + -- Look for last Separator in the line + + while Last >= First and then S (Last) /= Separator loop + Last := Last - 1; + end loop; + + -- If we do not find a separator, we output the maximum length + -- possible. + if Last < First then + Last := First + Max_Length - Positive (Column); + end if; + + Write_Line (S (First .. Last)); + + -- Set the beginning of the new remainder + + First := Last + 1; + + end loop; + + -- What is left goes to the buffer, without EOL + + Write_Str (S (First .. S'Last)); + + end if; + end Write_Str; + +end Prj.Util; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads new file mode 100644 index 00000000000..baef0404f0e --- /dev/null +++ b/gcc/ada/prj-util.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . U T I L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ +-- +-- Utilities when using project files. + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Types; use Types; + +package Prj.Util is + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id) + return Name_Id; + -- Get a single string array component. + -- Returns No_Name if there is no component Index (case sensitive), + -- if In_Array is null, or if the component is a String list. + + function Value_Of + (Index : Name_Id; + In_Array : Array_Element_Id) + return Variable_Value; + -- Get a string array component (single String or String list). + -- Returns Nil_Variable_Value if there is no component Index + -- (case sensitive), or if In_Array is null. + + function Value_Of + (Name : Name_Id; + Attribute_Or_Array_Name : Name_Id; + In_Package : Package_Id) + return Variable_Value; + -- In a specific package, + -- - if there exists an array Variable_Or_Array_Name with an index + -- Name, returns the corresponding component, + -- - otherwise if there is a attribute Attribute_Or_Array_Name, + -- returns this attribute, + -- - otherwise, returns Nil_Variable_Value. + -- If In_Package is null, returns Nil_Variable_Value. + + function Value_Of + (Index : Name_Id; + In_Array : Name_Id; + In_Arrays : Array_Id) + return Name_Id; + -- Get a string array component in an array of an array list. + -- Returns No_Name if there is no component Index (case sensitive), + -- if In_Arrays is null, if In_Array is not found in In_Arrays, + -- or if the component is a String list. + + function Value_Of + (Name : Name_Id; + In_Arrays : Array_Id) + return Array_Element_Id; + -- Returns a specified array in an array list. + -- Returns No_Array_Element if In_Arrays is null or if Name is not the + -- name of an array in In_Arrays. + -- Assumption: Name is in lower case. + + function Value_Of + (Name : Name_Id; + In_Packages : Package_Id) + return Package_Id; + -- Returns a specified package in a package list. + -- Returns No_Package if In_Packages is null or if Name is not the + -- name of a package in Package_List. + -- Assumption: Name is in lower case. + + function Value_Of + (Variable_Name : Name_Id; + In_Variables : Variable_Id) + return Variable_Value; + -- Returns a specified variable in a variable list. + -- Returns null if In_Variables is null or if Variable_Name + -- is not the name of a variable in In_Variables. + -- Assumption: Variable_Name is in lower case. + + procedure Write_Str + (S : String; + Max_Length : Positive; + Separator : Character); + -- Output string S using Output.Write_Str. + -- If S is too long to fit in one line of Max_Length, cut it in + -- several lines, using Separator as the last character of each line, + -- if possible. + + type Text_File is limited private; + -- Represents a text file. + -- Default is invalid text file. + + function Is_Valid (File : Text_File) return Boolean; + -- Returns True if File designates an open text file that + -- has not yet been closed. + + procedure Open (File : out Text_File; Name : String); + -- Open a text file. If this procedure fails, File is invalid. + + function End_Of_File (File : Text_File) return Boolean; + -- Returns True if the end of the text file File has been + -- reached. Fails if File is invalid. + + procedure Get_Line + (File : Text_File; + Line : out String; + Last : out Natural); + -- Reads a line from an open text file. Fails if File is invalid. + + procedure Close (File : in out Text_File); + -- Close an open text file. File becomes invalid. + -- Fails if File is already invalid. + +private + + type Text_File_Data is record + FD : File_Descriptor := Invalid_FD; + Buffer : String (1 .. 1_000); + Buffer_Len : Natural; + Cursor : Natural := 0; + End_Of_File_Reached : Boolean := False; + end record; + + type Text_File is access Text_File_Data; + +end Prj.Util; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb new file mode 100644 index 00000000000..8e302117917 --- /dev/null +++ b/gcc/ada/prj.adb @@ -0,0 +1,286 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Errout; use Errout; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Namet; use Namet; +with Osint; use Osint; +with Prj.Attr; +with Prj.Com; +with Prj.Env; +with Scans; use Scans; +with Scn; +with Stringt; use Stringt; +with Sinfo.CN; +with Snames; use Snames; + +package body Prj is + + The_Empty_String : String_Id; + + subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; + + The_Casing_Images : array (Known_Casing) of String_Access := + (All_Lower_Case => new String'("lowercase"), + All_Upper_Case => new String'("UPPERCASE"), + Mixed_Case => new String'("MixedCase")); + + Initialized : Boolean := False; + + Standard_Dot_Replacement : constant Name_Id := + First_Name_Id + Character'Pos ('-'); + Standard_Specification_Append : Name_Id; + Standard_Body_Append : Name_Id; + + Std_Naming_Data : Naming_Data := + (Dot_Replacement => Standard_Dot_Replacement, + Dot_Repl_Loc => No_Location, + Casing => All_Lower_Case, + Specification_Append => No_Name, + Spec_Append_Loc => No_Location, + Body_Append => No_Name, + Body_Append_Loc => No_Location, + Separate_Append => No_Name, + Sep_Append_Loc => No_Location, + Specifications => No_Array_Element, + Bodies => No_Array_Element); + + Project_Empty : Project_Data := + (First_Referred_By => No_Project, + Name => No_Name, + Path_Name => No_Name, + Location => No_Location, + Directory => No_Name, + File_Name => No_Name, + Library => False, + Library_Dir => No_Name, + Library_Name => No_Name, + Library_Kind => Static, + Lib_Internal_Name => No_Name, + Lib_Elaboration => False, + Sources => Nil_String, + Source_Dirs => Nil_String, + Object_Directory => No_Name, + Modifies => No_Project, + Modified_By => No_Project, + Naming => Std_Naming_Data, + Decl => No_Declarations, + Imported_Projects => Empty_Project_List, + Include_Path => null, + Objects_Path => null, + Config_File_Name => No_Name, + Config_File_Temp => False, + Config_Checked => False, + Checked => False, + Seen => False, + Flag1 => False, + Flag2 => False); + + ------------------- + -- Empty_Project -- + ------------------- + + function Empty_Project return Project_Data is + begin + Initialize; + return Project_Empty; + end Empty_Project; + + ------------------ + -- Empty_String -- + ------------------ + + function Empty_String return String_Id is + begin + return The_Empty_String; + end Empty_String; + + ------------ + -- Expect -- + ------------ + + procedure Expect (The_Token : Token_Type; Token_Image : String) is + begin + if Token /= The_Token then + Error_Msg ("""" & Token_Image & """ expected", Token_Ptr); + end if; + end Expect; + + -------------------------------- + -- For_Every_Project_Imported -- + -------------------------------- + + procedure For_Every_Project_Imported + (By : Project_Id; + With_State : in out State) + is + + procedure Check (Project : Project_Id); + -- Check if a project has already been seen. + -- If not seen, mark it as seen, call Action, + -- and check all its imported projects. + + procedure Check (Project : Project_Id) is + List : Project_List; + + begin + if not Projects.Table (Project).Seen then + Projects.Table (Project).Seen := False; + Action (Project, With_State); + + List := Projects.Table (Project).Imported_Projects; + while List /= Empty_Project_List loop + Check (Project_Lists.Table (List).Project); + List := Project_Lists.Table (List).Next; + end loop; + end if; + end Check; + + begin + for Project in Projects.First .. Projects.Last loop + Projects.Table (Project).Seen := False; + end loop; + + Check (Project => By); + end For_Every_Project_Imported; + + ----------- + -- Image -- + ----------- + + function Image (Casing : Casing_Type) return String is + begin + return The_Casing_Images (Casing).all; + end Image; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if not Initialized then + Initialized := True; + Stringt.Initialize; + Start_String; + The_Empty_String := End_String; + Name_Len := 4; + Name_Buffer (1 .. 4) := ".ads"; + Canonical_Case_File_Name (Name_Buffer (1 .. 4)); + Standard_Specification_Append := Name_Find; + Name_Buffer (4) := 'b'; + Canonical_Case_File_Name (Name_Buffer (1 .. 4)); + Standard_Body_Append := Name_Find; + Std_Naming_Data.Specification_Append := Standard_Specification_Append; + Std_Naming_Data.Body_Append := Standard_Body_Append; + Std_Naming_Data.Separate_Append := Standard_Body_Append; + Project_Empty.Naming := Std_Naming_Data; + Prj.Env.Initialize; + Prj.Attr.Initialize; + Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); + Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying)); + Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); + end if; + end Initialize; + + ------------ + -- Reset -- + ------------ + + procedure Reset is + begin + Projects.Init; + Project_Lists.Init; + Packages.Init; + Arrays.Init; + Variable_Elements.Init; + String_Elements.Init; + Prj.Com.Units.Init; + Prj.Com.Units_Htable.Reset; + end Reset; + + ------------------------ + -- Same_Naming_Scheme -- + ------------------------ + + function Same_Naming_Scheme + (Left, Right : Naming_Data) + return Boolean + is + begin + return Left.Dot_Replacement = Right.Dot_Replacement + and then Left.Casing = Right.Casing + and then Left.Specification_Append = Right.Specification_Append + and then Left.Body_Append = Right.Body_Append + and then Left.Separate_Append = Right.Separate_Append; + end Same_Naming_Scheme; + + ---------- + -- Scan -- + ---------- + + procedure Scan is + begin + Scn.Scan; + + -- Change operator symbol to literal strings, since that's the way + -- we treat all strings in a project file. + + if Token = Tok_Operator_Symbol then + Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node); + Token := Tok_String_Literal; + end if; + end Scan; + + -------------------------- + -- Standard_Naming_Data -- + -------------------------- + + function Standard_Naming_Data return Naming_Data is + begin + Initialize; + return Std_Naming_Data; + end Standard_Naming_Data; + + ----------- + -- Value -- + ----------- + + function Value (Image : String) return Casing_Type is + begin + for Casing in The_Casing_Images'Range loop + if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then + return Casing; + end if; + end loop; + + raise Constraint_Error; + end Value; + +end Prj; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads new file mode 100644 index 00000000000..409a0717223 --- /dev/null +++ b/gcc/ada/prj.ads @@ -0,0 +1,416 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The following package declares the data types for GNAT project. +-- These data types may be used by GNAT Project-aware tools. + +-- Children of these package implements various services on these data types. +-- See in particular Prj.Pars and Prj.Env. + +with Casing; use Casing; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Scans; use Scans; +with Table; +with Types; use Types; + +package Prj is + + type Put_Line_Access is access procedure (Line : String); + -- Use to customize error reporting in Prj.Proc and Prj.Nmsc. + + type Verbosity is (Default, Medium, High); + -- Verbosity when parsing GNAT Project Files. + -- Default is default (very quiet, if no errors). + -- Medium is more verbose. + -- High is extremely verbose. + + type Lib_Kind is (Static, Dynamic, Relocatable); + + function Empty_String return String_Id; + + type String_List_Id is new Nat; + Nil_String : constant String_List_Id := 0; + type String_Element is record + Value : String_Id := No_String; + Location : Source_Ptr := No_Location; + Next : String_List_Id := Nil_String; + end record; + -- To hold values for string list variables and array elements. + + package String_Elements is new Table.Table + (Table_Component_Type => String_Element, + Table_Index_Type => String_List_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Prj.String_Elements"); + -- The table for string elements in string lists. + + type Variable_Kind is (Undefined, List, Single); + -- Different kinds of variables + + type Variable_Value (Kind : Variable_Kind := Undefined) is record + Location : Source_Ptr := No_Location; + Default : Boolean := False; + case Kind is + when Undefined => + null; + when List => + Values : String_List_Id := Nil_String; + when Single => + Value : String_Id := No_String; + end case; + end record; + -- Values for variables and array elements + + Nil_Variable_Value : constant Variable_Value := + (Kind => Undefined, + Location => No_Location, + Default => False); + -- Value of a non existing variable or array element. + + type Variable_Id is new Nat; + No_Variable : constant Variable_Id := 0; + type Variable is record + Next : Variable_Id := No_Variable; + Name : Name_Id; + Value : Variable_Value; + end record; + -- To hold the list of variables in a project file and in packages. + + package Variable_Elements is new Table.Table + (Table_Component_Type => Variable, + Table_Index_Type => Variable_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Prj.Variable_Elements"); + -- The table of variable in list of variables. + + type Array_Element_Id is new Nat; + No_Array_Element : constant Array_Element_Id := 0; + type Array_Element is record + Index : Name_Id; + Value : Variable_Value; + Next : Array_Element_Id := No_Array_Element; + end record; + -- Each Array_Element represents an array element. + -- Each Array_Element is linked (Next) to the next array element, + -- if any, in the array. + + package Array_Elements is new Table.Table + (Table_Component_Type => Array_Element, + Table_Index_Type => Array_Element_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Prj.Array_Elements"); + -- The table that contains all array elements + + type Array_Id is new Nat; + No_Array : constant Array_Id := 0; + type Array_Data is record + Name : Name_Id := No_Name; + Value : Array_Element_Id := No_Array_Element; + Next : Array_Id := No_Array; + end record; + -- Each Array_Data represents an array. + -- Value is the id of the first element. + -- Next is the id of the next array in the project file or package. + + package Arrays is new Table.Table + (Table_Component_Type => Array_Data, + Table_Index_Type => Array_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Prj.Arrays"); + -- The table that contains all arrays + + type Package_Id is new Nat; + No_Package : constant Package_Id := 0; + type Declarations is record + Variables : Variable_Id := No_Variable; + Attributes : Variable_Id := No_Variable; + Arrays : Array_Id := No_Array; + Packages : Package_Id := No_Package; + end record; + + No_Declarations : constant Declarations := + (Variables => No_Variable, + Attributes => No_Variable, + Arrays => No_Array, + Packages => No_Package); + -- Declarations. Used in project structures and packages. + + type Package_Element is record + Name : Name_Id := No_Name; + Decl : Declarations := No_Declarations; + Parent : Package_Id := No_Package; + Next : Package_Id := No_Package; + end record; + -- A package. Includes declarations that may include + -- other packages. + + package Packages is new Table.Table + (Table_Component_Type => Package_Element, + Table_Index_Type => Package_Id, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Prj.Packages"); + -- The table that contains all packages. + + function Image (Casing : Casing_Type) return String; + -- Similar to 'Image + + function Value (Image : String) return Casing_Type; + -- Similar to 'Value + -- This is to avoid s-valenu in the closure of the tools + -- Raises Constraint_Error if not a Casing_Type image. + + type Naming_Data is record + Dot_Replacement : Name_Id := No_Name; + -- The string to replace '.' in the source file name. + + Dot_Repl_Loc : Source_Ptr := No_Location; + -- The position in the project file source where + -- Dot_Replacement is defined. + + Casing : Casing_Type := All_Lower_Case; + -- The casing of the source file name. + + Specification_Append : Name_Id := No_Name; + -- The string to append to the unit name for the + -- source file name of a specification. + + Spec_Append_Loc : Source_Ptr := No_Location; + -- The position in the project file source where + -- Specification_Append is defined. + + Body_Append : Name_Id := No_Name; + -- The string to append to the unit name for the + -- source file name of a body. + + Body_Append_Loc : Source_Ptr := No_Location; + -- The position in the project file source where + -- Body_Append is defined. + + Separate_Append : Name_Id := No_Name; + -- The string to append to the unit name for the + -- source file name of a subunit. + + Sep_Append_Loc : Source_Ptr := No_Location; + -- The position in the project file source where + -- Separate_Append is defined. + + Specifications : Array_Element_Id := No_Array_Element; + -- An associative array mapping individual specifications + -- to source file names. + + Bodies : Array_Element_Id := No_Array_Element; + -- An associative array mapping individual bodies + -- to source file names. + + end record; + -- A naming scheme. + + function Standard_Naming_Data return Naming_Data; + pragma Inline (Standard_Naming_Data); + -- The standard GNAT naming scheme. + + function Same_Naming_Scheme + (Left, Right : Naming_Data) + return Boolean; + -- Returns True if Left and Right are the same naming scheme + -- not considering Specifications and Bodies. + + type Project_Id is new Nat; + No_Project : constant Project_Id := 0; + -- Id of a Project File + + type Project_List is new Nat; + Empty_Project_List : constant Project_List := 0; + -- A list of project files. + + type Project_Element is record + Project : Project_Id := No_Project; + Next : Project_List := Empty_Project_List; + end record; + -- Element in a list of project file. + -- Next is the id of the next project file in the list. + + package Project_Lists is new Table.Table + (Table_Component_Type => Project_Element, + Table_Index_Type => Project_List, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Prj.Project_Lists"); + -- The table that contains the lists of project files. + + type Project_Data is record + First_Referred_By : Project_Id := No_Project; + -- The project, if any, that was the first to be known + -- as importing or modifying this project. + + Name : Name_Id := No_Name; + -- The name of the project. + + Path_Name : Name_Id := No_Name; + -- The path name of the project file. + + Location : Source_Ptr := No_Location; + -- The location in the project file source of the + -- reserved word project. + + Directory : Name_Id := No_Name; + -- The directory where the project file resides. + + File_Name : Name_Id := No_Name; + -- The file name of the project file. + + Library : Boolean := False; + -- True if this is a library project + + Library_Dir : Name_Id := No_Name; + -- If a library project, directory where resides the library + + Library_Name : Name_Id := No_Name; + -- If a library project, name of the library + + Library_Kind : Lib_Kind := Static; + -- If a library project, kind of library + + Lib_Internal_Name : Name_Id := No_Name; + -- If a library project, internal name store inside the library + + Lib_Elaboration : Boolean := False; + -- If a library project, indicate if <lib>init and <lib>final + -- procedures need to be defined. + + Sources : String_List_Id := Nil_String; + -- The list of all the source file names. + + Source_Dirs : String_List_Id := Nil_String; + -- The list of all the source directories. + + Object_Directory : Name_Id := No_Name; + -- The object directory of this project file. + + Modifies : Project_Id := No_Project; + -- The reference of the project file, if any, that this + -- project file modifies. + + Modified_By : Project_Id := No_Project; + -- The reference of the project file, if any, that + -- modifies this project file. + + Naming : Naming_Data := Standard_Naming_Data; + -- The naming scheme of this project file. + + Decl : Declarations := No_Declarations; + -- The declarations (variables, attributes and packages) + -- of this project file. + + Imported_Projects : Project_List := Empty_Project_List; + -- The list of all directly imported projects, if any. + + Include_Path : String_Access := null; + -- The cached value of ADA_INCLUDE_PATH for this project file. + + Objects_Path : String_Access := null; + -- The cached value of ADA_OBJECTS_PATH for this project file. + + Config_File_Name : Name_Id := No_Name; + -- The name of the configuration pragmas file, if any. + + Config_File_Temp : Boolean := False; + -- An indication that the configuration pragmas file is + -- a temporary file that must be deleted at the end. + + Config_Checked : Boolean := False; + -- A flag to avoid checking repetively the configuration pragmas file. + + Checked : Boolean := False; + -- A flag to avoid checking repetively the naming scheme of + -- this project file. + + -- Various flags that are used in an ad hoc manner + + Seen : Boolean := False; + Flag1 : Boolean := False; + Flag2 : Boolean := False; + + end record; + -- Project File representation. + + function Empty_Project return Project_Data; + -- Return the representation of an empty project. + + package Projects is new Table.Table ( + Table_Component_Type => Project_Data, + Table_Index_Type => Project_Id, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Prj.Projects"); + -- The set of all project files. + + procedure Expect (The_Token : Token_Type; Token_Image : String); + -- Check that the current token is The_Token. If it is not, then + -- output an error message. + + procedure Initialize; + -- This procedure must be called before using any services from the Prj + -- hierarchy. Namet.Initialize must be called before Prj.Initialize. + + procedure Reset; + -- This procedure resets all the tables that are used when processing a + -- project file tree. Initialize must be called before the call to Reset. + + generic + type State is limited private; + with procedure Action + (Project : Project_Id; + With_State : in out State); + procedure For_Every_Project_Imported + (By : Project_Id; + With_State : in out State); + -- Call Action for each project imported directly or indirectly by project + -- By.-- Action is called according to the order of importation: if A + -- imports B, directly or indirectly, Action will be called for A before + -- it is called for B. With_State may be used by Action to choose a + -- behavior or to report some global result. + +private + + procedure Scan; + -- Calls Scn.Scan and change any Operator_Symbol to String_Literal + +end Prj; diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c new file mode 100644 index 00000000000..43d630795a8 --- /dev/null +++ b/gcc/ada/raise.c @@ -0,0 +1,86 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E * + * * + * C Implementation File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* Routines to support runtime exception handling */ + +#ifdef IN_RTS +#include "tconfig.h" +#include "tsystem.h" +#include <sys/stat.h> +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +/* We have not yet figured out how to import this directly */ + +void +_gnat_builtin_longjmp (ptr, flag) + void *ptr; + int flag ATTRIBUTE_UNUSED; +{ + __builtin_longjmp (ptr, 1); +} + +/* When an exception is raised for which no handler exists, the procedure + Ada.Exceptions.Unhandled_Exception is called, which performs the call to + adafinal to complete finalization, and then prints out the error messages + for the unhandled exception. The final step is to call this routine, which + performs any system dependent cleanup required. */ + +void +__gnat_unhandled_terminate () +{ + /* Special termination handling for VMS */ + +#ifdef VMS + { + long prvhnd; + + /* Remove the exception vector so it won't intercept any errors + in the call to exit, and go into and endless loop */ + + SYS$SETEXV (1, 0, 3, &prvhnd); + __gnat_os_exit (1); + } + +/* Termination handling for all other systems. */ + +#elif !defined (__RT__) + __gnat_os_exit (1); +#endif +} diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h new file mode 100644 index 00000000000..8db83f4a2b8 --- /dev/null +++ b/gcc/ada/raise.h @@ -0,0 +1,71 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +struct Exception_Data +{ + char Handled_By_Others; + char Lang; + int Name_Length; + char *Full_Name, Htable_Ptr; + int Import_Code; +}; + +typedef struct Exception_Data *Exception_Id; + +struct Exception_Occurrence +{ + int Max_Length; + Exception_Id Id; + int Msg_Length; + char Msg [0]; +}; + +typedef struct Exception_Occurrence *Exception_Occurrence_Access; + +extern void _gnat_builtin_longjmp PARAMS ((void *, int)); +extern void __gnat_unhandled_terminate PARAMS ((void)); +extern void *__gnat_malloc PARAMS ((__SIZE_TYPE__)); +extern void __gnat_free PARAMS ((void *)); +extern void *__gnat_realloc PARAMS ((void *, __SIZE_TYPE__)); +extern void __gnat_finalize PARAMS ((void)); +extern void set_gnat_exit_status PARAMS ((int)); +extern void __gnat_set_globals PARAMS ((int, int, int, int, int, int, + void (*) PARAMS ((void)), + int, int)); +extern void __gnat_initialize PARAMS ((void)); +extern void __gnat_init_float PARAMS ((void)); +extern void __gnat_install_handler PARAMS ((void)); + +extern int gnat_exit_status; + diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb new file mode 100644 index 00000000000..9e711527e5b --- /dev/null +++ b/gcc/ada/repinfo.adb @@ -0,0 +1,1024 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.36 $ +-- -- +-- Copyright (C) 1999-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; use Alloc; +with Atree; use Atree; +with Casing; use Casing; +with Debug; use Debug; +with Einfo; use Einfo; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Table; use Table; +with Uname; use Uname; +with Urealp; use Urealp; + +package body Repinfo is + + SSU : constant := 8; + -- Value for Storage_Unit, we do not want to get this from TTypes, since + -- this introduces problematic dependencies in ASIS, and in any case this + -- value is assumed to be 8 for the implementation of the DDA. + -- This is wrong for AAMP??? + + --------------------------------------- + -- Representation of gcc Expressions -- + --------------------------------------- + + -- This table is used only if Frontend_Layout_On_Target is False, + -- so that gigi lays out dynamic size/offset fields using encoded + -- gcc expressions. + + -- A table internal to this unit is used to hold the values of + -- back annotated expressions. This table is written out by -gnatt + -- and read back in for ASIS processing. + + -- Node values are stored as Uint values which are the negative of + -- the node index in this table. Constants appear as non-negative + -- Uint values. + + type Exp_Node is record + Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val; + Op3 : Node_Ref_Or_Val; + end record; + + package Rep_Table is new Table.Table ( + Table_Component_Type => Exp_Node, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_Table_Initial, + Table_Increment => Alloc.Rep_Table_Increment, + Table_Name => "BE_Rep_Table"); + + -------------------------------------------------------------- + -- Representation of Front-End Dynamic Size/Offset Entities -- + -------------------------------------------------------------- + + package Dynamic_SO_Entity_Table is new Table.Table ( + Table_Component_Type => Entity_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_Table_Initial, + Table_Increment => Alloc.Rep_Table_Increment, + Table_Name => "FE_Rep_Table"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + Unit_Casing : Casing_Type; + -- Indentifier casing for current unit + + procedure Spaces (N : Natural); + -- Output given number of spaces + + function Back_End_Layout return Boolean; + -- Test for layout mode, True = back end, False = front end. This + -- function is used rather than checking the configuration parameter + -- because we do not want Repinfo to depend on Targparm (for ASIS) + + procedure List_Entities (Ent : Entity_Id); + -- This procedure lists the entities associated with the entity E, + -- starting with the First_Entity and using the Next_Entity link. + -- If a nested package is found, entities within the package are + -- recursively processed. + + procedure List_Name (Ent : Entity_Id); + -- List name of entity Ent in appropriate case. The name is listed with + -- full qualification up to but not including the compilation unit name. + + procedure List_Array_Info (Ent : Entity_Id); + -- List representation info for array type Ent + + procedure List_Object_Info (Ent : Entity_Id); + -- List representation info for object Ent + + procedure List_Record_Info (Ent : Entity_Id); + -- List representation info for record type Ent + + procedure List_Type_Info (Ent : Entity_Id); + -- List type info for type Ent + + function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean; + -- Returns True if Val represents a variable value, and False if it + -- represents a value that is fixed at compile time. + + procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); + -- Given a representation value, write it out. No_Uint values or values + -- dependent on discriminants are written as two question marks. If the + -- flag Paren is set, then the output is surrounded in parentheses if + -- it is other than a simple value. + + --------------------- + -- Back_End_Layout -- + --------------------- + + function Back_End_Layout return Boolean is + begin + -- We have back end layout if the back end has made any entries in + -- the table of GCC expressions, otherwise we have front end layout. + + return Rep_Table.Last > 0; + end Back_End_Layout; + + ------------------------ + -- Create_Discrim_Ref -- + ------------------------ + + function Create_Discrim_Ref + (Discr : Entity_Id) + return Node_Ref + is + N : constant Uint := Discriminant_Number (Discr); + T : Nat; + + begin + Rep_Table.Increment_Last; + T := Rep_Table.Last; + Rep_Table.Table (T).Expr := Discrim_Val; + Rep_Table.Table (T).Op1 := N; + Rep_Table.Table (T).Op2 := No_Uint; + Rep_Table.Table (T).Op3 := No_Uint; + return UI_From_Int (-T); + end Create_Discrim_Ref; + + --------------------------- + -- Create_Dynamic_SO_Ref -- + --------------------------- + + function Create_Dynamic_SO_Ref + (E : Entity_Id) + return Dynamic_SO_Ref + is + T : Nat; + + begin + Dynamic_SO_Entity_Table.Increment_Last; + T := Dynamic_SO_Entity_Table.Last; + Dynamic_SO_Entity_Table.Table (T) := E; + return UI_From_Int (-T); + end Create_Dynamic_SO_Ref; + + ----------------- + -- Create_Node -- + ----------------- + + function Create_Node + (Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val := No_Uint; + Op3 : Node_Ref_Or_Val := No_Uint) + return Node_Ref + is + T : Nat; + + begin + Rep_Table.Increment_Last; + T := Rep_Table.Last; + Rep_Table.Table (T).Expr := Expr; + Rep_Table.Table (T).Op1 := Op1; + Rep_Table.Table (T).Op2 := Op2; + Rep_Table.Table (T).Op3 := Op3; + + return UI_From_Int (-T); + end Create_Node; + + --------------------------- + -- Get_Dynamic_SO_Entity -- + --------------------------- + + function Get_Dynamic_SO_Entity + (U : Dynamic_SO_Ref) + return Entity_Id + is + begin + return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U)); + end Get_Dynamic_SO_Entity; + + ----------------------- + -- Is_Dynamic_SO_Ref -- + ----------------------- + + function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is + begin + return U < Uint_0; + end Is_Dynamic_SO_Ref; + + ---------------------- + -- Is_Static_SO_Ref -- + ---------------------- + + function Is_Static_SO_Ref (U : SO_Ref) return Boolean is + begin + return U >= Uint_0; + end Is_Static_SO_Ref; + + --------- + -- lgx -- + --------- + + procedure lgx (U : Node_Ref_Or_Val) is + begin + List_GCC_Expression (U); + Write_Eol; + end lgx; + + ---------------------- + -- List_Array_Info -- + ---------------------- + + procedure List_Array_Info (Ent : Entity_Id) is + begin + List_Type_Info (Ent); + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Component_Size use "); + Write_Val (Component_Size (Ent)); + Write_Line (";"); + end List_Array_Info; + + ------------------- + -- List_Entities -- + ------------------- + + procedure List_Entities (Ent : Entity_Id) is + E : Entity_Id; + + begin + if Present (Ent) then + E := First_Entity (Ent); + while Present (E) loop + if Comes_From_Source (E) or else Debug_Flag_AA then + + if Is_Record_Type (E) then + List_Record_Info (E); + + elsif Is_Array_Type (E) then + List_Array_Info (E); + + elsif List_Representation_Info >= 2 then + + if Is_Type (E) then + List_Type_Info (E); + + elsif Ekind (E) = E_Variable + or else + Ekind (E) = E_Constant + or else + Ekind (E) = E_Loop_Parameter + or else + Is_Formal (E) + then + List_Object_Info (E); + end if; + end if; + + -- Recurse over nested package, but not if they are + -- package renamings (in particular renamings of the + -- enclosing package, as for some Java bindings and + -- for generic instances). + + if (Ekind (E) = E_Package + and then No (Renamed_Object (E))) + or else + Ekind (E) = E_Protected_Type + or else + Ekind (E) = E_Task_Type + or else + Ekind (E) = E_Subprogram_Body + or else + Ekind (E) = E_Package_Body + or else + Ekind (E) = E_Task_Body + or else + Ekind (E) = E_Protected_Body + then + List_Entities (E); + end if; + end if; + + E := Next_Entity (E); + end loop; + end if; + end List_Entities; + + ------------------------- + -- List_GCC_Expression -- + ------------------------- + + procedure List_GCC_Expression (U : Node_Ref_Or_Val) is + + procedure P (Val : Node_Ref_Or_Val); + -- Internal recursive procedure to print expression + + procedure P (Val : Node_Ref_Or_Val) is + begin + if Val >= 0 then + UI_Write (Val, Decimal); + + else + declare + Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); + + procedure Binop (S : String); + -- Output text for binary operator with S being operator name + + procedure Binop (S : String) is + begin + Write_Char ('('); + P (Node.Op1); + Write_Str (S); + P (Node.Op2); + Write_Char (')'); + end Binop; + + -- Start of processing for P + + begin + case Node.Expr is + when Cond_Expr => + Write_Str ("(if "); + P (Node.Op1); + Write_Str (" then "); + P (Node.Op2); + Write_Str (" else "); + P (Node.Op3); + Write_Str (" end)"); + + when Plus_Expr => + Binop (" + "); + + when Minus_Expr => + Binop (" - "); + + when Mult_Expr => + Binop (" * "); + + when Trunc_Div_Expr => + Binop (" /t "); + + when Ceil_Div_Expr => + Binop (" /c "); + + when Floor_Div_Expr => + Binop (" /f "); + + when Trunc_Mod_Expr => + Binop (" modt "); + + when Floor_Mod_Expr => + Binop (" modf "); + + when Ceil_Mod_Expr => + Binop (" modc "); + + when Exact_Div_Expr => + Binop (" /e "); + + when Negate_Expr => + Write_Char ('-'); + P (Node.Op1); + + when Min_Expr => + Binop (" min "); + + when Max_Expr => + Binop (" max "); + + when Abs_Expr => + Write_Str ("abs "); + P (Node.Op1); + + when Truth_Andif_Expr => + Binop (" and if "); + + when Truth_Orif_Expr => + Binop (" or if "); + + when Truth_And_Expr => + Binop (" and "); + + when Truth_Or_Expr => + Binop (" or "); + + when Truth_Xor_Expr => + Binop (" xor "); + + when Truth_Not_Expr => + Write_Str ("not "); + P (Node.Op1); + + when Lt_Expr => + Binop (" < "); + + when Le_Expr => + Binop (" <= "); + + when Gt_Expr => + Binop (" > "); + + when Ge_Expr => + Binop (" >= "); + + when Eq_Expr => + Binop (" == "); + + when Ne_Expr => + Binop (" != "); + + when Discrim_Val => + Write_Char ('#'); + UI_Write (Node.Op1); + + end case; + end; + end if; + end P; + + -- Start of processing for List_GCC_Expression + + begin + if U = No_Uint then + Write_Line ("??"); + else + P (U); + end if; + end List_GCC_Expression; + + --------------- + -- List_Name -- + --------------- + + procedure List_Name (Ent : Entity_Id) is + begin + if not Is_Compilation_Unit (Scope (Ent)) then + List_Name (Scope (Ent)); + Write_Char ('.'); + end if; + + Get_Unqualified_Decoded_Name_String (Chars (Ent)); + Set_Casing (Unit_Casing); + Write_Str (Name_Buffer (1 .. Name_Len)); + end List_Name; + + --------------------- + -- List_Object_Info -- + --------------------- + + procedure List_Object_Info (Ent : Entity_Id) is + begin + Write_Eol; + + if Known_Esize (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; + + if Known_Alignment (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); + end if; + end List_Object_Info; + + ---------------------- + -- List_Record_Info -- + ---------------------- + + procedure List_Record_Info (Ent : Entity_Id) is + Comp : Entity_Id; + Esiz : Uint; + Cfbit : Uint; + Sunit : Uint; + + Max_Name_Length : Natural; + Max_Suni_Length : Natural; + + begin + List_Type_Info (Ent); + + Write_Str ("for "); + List_Name (Ent); + Write_Line (" use record"); + + -- First loop finds out max line length and max starting position + -- length, for the purpose of lining things up nicely. + + Max_Name_Length := 0; + Max_Suni_Length := 0; + + Comp := First_Entity (Ent); + while Present (Comp) loop + if Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant + then + Get_Decoded_Name_String (Chars (Comp)); + Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len); + + Cfbit := Component_Bit_Offset (Comp); + + if Rep_Not_Constant (Cfbit) then + UI_Image_Length := 2; + + else + -- Complete annotation in case not done + + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + + Esiz := Esize (Comp); + Sunit := Cfbit / SSU; + UI_Image (Sunit); + end if; + + if Unknown_Normalized_First_Bit (Comp) then + Set_Normalized_First_Bit (Comp, Uint_0); + end if; + + Max_Suni_Length := + Natural'Max (Max_Suni_Length, UI_Image_Length); + end if; + + Comp := Next_Entity (Comp); + end loop; + + -- Second loop does actual output based on those values + + Comp := First_Entity (Ent); + while Present (Comp) loop + if Ekind (Comp) = E_Component + or else Ekind (Comp) = E_Discriminant + then + declare + Esiz : constant Uint := Esize (Comp); + Bofs : constant Uint := Component_Bit_Offset (Comp); + Npos : constant Uint := Normalized_Position (Comp); + Fbit : constant Uint := Normalized_First_Bit (Comp); + Lbit : Uint; + + begin + Write_Str (" "); + Get_Decoded_Name_String (Chars (Comp)); + Set_Casing (Unit_Casing); + Write_Str (Name_Buffer (1 .. Name_Len)); + + for J in 1 .. Max_Name_Length - Name_Len loop + Write_Char (' '); + end loop; + + Write_Str (" at "); + + if Known_Static_Normalized_Position (Comp) then + UI_Image (Npos); + Spaces (Max_Suni_Length - UI_Image_Length); + Write_Str (UI_Image_Buffer (1 .. UI_Image_Length)); + + elsif Known_Component_Bit_Offset (Comp) + and then List_Representation_Info = 3 + then + Spaces (Max_Suni_Length - 2); + Write_Val (Bofs, Paren => True); + Write_Str (" / 8"); + + elsif Known_Normalized_Position (Comp) + and then List_Representation_Info = 3 + then + Spaces (Max_Suni_Length - 2); + Write_Val (Npos); + + else + Write_Str ("??"); + end if; + + Write_Str (" range "); + UI_Write (Fbit); + Write_Str (" .. "); + + if not Is_Dynamic_SO_Ref (Esize (Comp)) then + Lbit := Fbit + Esiz - 1; + + if Lbit < 10 then + Write_Char (' '); + end if; + + UI_Write (Lbit); + + elsif List_Representation_Info < 3 then + Write_Str ("??"); + + else -- List_Representation >= 3 + + Write_Val (Esiz, Paren => True); + + -- If in front end layout mode, then dynamic size is + -- stored in storage units, so renormalize for output + + if not Back_End_Layout then + Write_Str (" * "); + Write_Int (SSU); + end if; + + -- Add appropriate first bit offset + + if Fbit = 0 then + Write_Str (" - 1"); + + elsif Fbit = 1 then + null; + + else + Write_Str (" + "); + Write_Int (UI_To_Int (Fbit) - 1); + end if; + end if; + + Write_Line (";"); + end; + end if; + + Comp := Next_Entity (Comp); + end loop; + + Write_Line ("end record;"); + end List_Record_Info; + + ------------------- + -- List_Rep_Info -- + ------------------- + + procedure List_Rep_Info is + Col : Nat; + + begin + for U in Main_Unit .. Last_Unit loop + if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then + Unit_Casing := Identifier_Casing (Source_Index (U)); + Write_Eol; + Write_Str ("Representation information for unit "); + Write_Unit_Name (Unit_Name (U)); + Col := Column; + Write_Eol; + + for J in 1 .. Col - 1 loop + Write_Char ('-'); + end loop; + + Write_Eol; + List_Entities (Cunit_Entity (U)); + end if; + end loop; + end List_Rep_Info; + + -------------------- + -- List_Type_Info -- + -------------------- + + procedure List_Type_Info (Ent : Entity_Id) is + begin + Write_Eol; + + -- If Esize and RM_Size are the same and known, list as Size. This + -- is a common case, which we may as well list in simple form. + + if Esize (Ent) = RM_Size (Ent) then + if Known_Esize (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; + + -- For now, temporary case, to be removed when gigi properly back + -- annotates RM_Size, if RM_Size is not set, then list Esize as + -- Size. This avoids odd Object_Size output till we fix things??? + + elsif Unknown_RM_Size (Ent) then + if Known_Esize (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; + + -- Otherwise list size values separately if they are set + + else + if Known_Esize (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Object_Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; + + -- Note on following check: The RM_Size of a discrete type can + -- legitimately be set to zero, so a special check is needed. + + if Known_RM_Size (Ent) or else Is_Discrete_Type (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Value_Size use "); + Write_Val (RM_Size (Ent)); + Write_Line (";"); + end if; + end if; + + if Known_Alignment (Ent) then + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); + end if; + end List_Type_Info; + + ---------------------- + -- Rep_Not_Constant -- + ---------------------- + + function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is + begin + if Val = No_Uint or else Val < 0 then + return True; + else + return False; + end if; + end Rep_Not_Constant; + + --------------- + -- Rep_Value -- + --------------- + + function Rep_Value + (Val : Node_Ref_Or_Val; + D : Discrim_List) + return Uint + is + function B (Val : Boolean) return Uint; + -- Returns Uint_0 for False, Uint_1 for True + + function T (Val : Node_Ref_Or_Val) return Boolean; + -- Returns True for 0, False for any non-zero (i.e. True) + + function V (Val : Node_Ref_Or_Val) return Uint; + -- Internal recursive routine to evaluate tree + + ------- + -- B -- + ------- + + function B (Val : Boolean) return Uint is + begin + if Val then + return Uint_1; + else + return Uint_0; + end if; + end B; + + ------- + -- T -- + ------- + + function T (Val : Node_Ref_Or_Val) return Boolean is + begin + if V (Val) = 0 then + return False; + else + return True; + end if; + end T; + + ------- + -- V -- + ------- + + function V (Val : Node_Ref_Or_Val) return Uint is + L, R, Q : Uint; + + begin + if Val >= 0 then + return Val; + + else + declare + Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); + + begin + case Node.Expr is + when Cond_Expr => + if T (Node.Op1) then + return V (Node.Op2); + else + return V (Node.Op3); + end if; + + when Plus_Expr => + return V (Node.Op1) + V (Node.Op2); + + when Minus_Expr => + return V (Node.Op1) - V (Node.Op2); + + when Mult_Expr => + return V (Node.Op1) * V (Node.Op2); + + when Trunc_Div_Expr => + return V (Node.Op1) / V (Node.Op2); + + when Ceil_Div_Expr => + return + UR_Ceiling + (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); + + when Floor_Div_Expr => + return + UR_Floor + (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); + + when Trunc_Mod_Expr => + return V (Node.Op1) rem V (Node.Op2); + + when Floor_Mod_Expr => + return V (Node.Op1) mod V (Node.Op2); + + when Ceil_Mod_Expr => + L := V (Node.Op1); + R := V (Node.Op2); + Q := UR_Ceiling (L / UR_From_Uint (R)); + return L - R * Q; + + when Exact_Div_Expr => + return V (Node.Op1) / V (Node.Op2); + + when Negate_Expr => + return -V (Node.Op1); + + when Min_Expr => + return UI_Min (V (Node.Op1), V (Node.Op2)); + + when Max_Expr => + return UI_Max (V (Node.Op1), V (Node.Op2)); + + when Abs_Expr => + return UI_Abs (V (Node.Op1)); + + when Truth_Andif_Expr => + return B (T (Node.Op1) and then T (Node.Op2)); + + when Truth_Orif_Expr => + return B (T (Node.Op1) or else T (Node.Op2)); + + when Truth_And_Expr => + return B (T (Node.Op1) and T (Node.Op2)); + + when Truth_Or_Expr => + return B (T (Node.Op1) or T (Node.Op2)); + + when Truth_Xor_Expr => + return B (T (Node.Op1) xor T (Node.Op2)); + + when Truth_Not_Expr => + return B (not T (Node.Op1)); + + when Lt_Expr => + return B (V (Node.Op1) < V (Node.Op2)); + + when Le_Expr => + return B (V (Node.Op1) <= V (Node.Op2)); + + when Gt_Expr => + return B (V (Node.Op1) > V (Node.Op2)); + + when Ge_Expr => + return B (V (Node.Op1) >= V (Node.Op2)); + + when Eq_Expr => + return B (V (Node.Op1) = V (Node.Op2)); + + when Ne_Expr => + return B (V (Node.Op1) /= V (Node.Op2)); + + when Discrim_Val => + declare + Sub : constant Int := UI_To_Int (Node.Op1); + + begin + pragma Assert (Sub in D'Range); + return D (Sub); + end; + + end case; + end; + end if; + end V; + + -- Start of processing for Rep_Value + + begin + if Val = No_Uint then + return No_Uint; + + else + return V (Val); + end if; + end Rep_Value; + + ------------ + -- Spaces -- + ------------ + + procedure Spaces (N : Natural) is + begin + for J in 1 .. N loop + Write_Char (' '); + end loop; + end Spaces; + + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + begin + Rep_Table.Tree_Read; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + begin + Rep_Table.Tree_Write; + end Tree_Write; + + --------------- + -- Write_Val -- + --------------- + + procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is + begin + if Rep_Not_Constant (Val) then + if List_Representation_Info < 3 then + Write_Str ("??"); + else + if Back_End_Layout then + Write_Char (' '); + List_GCC_Expression (Val); + Write_Char (' '); + else + Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); + end if; + end if; + + else + UI_Write (Val); + end if; + end Write_Val; + +end Repinfo; diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads new file mode 100644 index 00000000000..0b41ba0864b --- /dev/null +++ b/gcc/ada/repinfo.ads @@ -0,0 +1,320 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.20 $ +-- -- +-- Copyright (C) 1999-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines to handle back annotation of the +-- tree to fill in representation information, and also the routine used +-- by -gnatR to print this information. This unit is used both in the +-- compiler and in ASIS (it is used in ASIS as part of the implementation +-- of the data decomposition annex. + +with Types; use Types; +with Uintp; use Uintp; + +package Repinfo is + + -------------------------------- + -- Representation Information -- + -------------------------------- + + -- The representation information of interest here is size and + -- component information for arrays and records. For primitive + -- types, the front end computes the Esize and RM_Size fields of + -- the corresponding entities as constant non-negative integers, + -- and the Uint values are stored directly in these fields. + + -- For composite types, there are three cases: + + -- 1. In some cases the front end knows the values statically, + -- for example in the ase where representation clauses or + -- pragmas specify the values. + + -- 2. If Backend_Layout is True, then the backend is responsible + -- for layout of all types and objects not laid out by the + -- front end. This includes all dynamic values, and also + -- static values (e.g. record sizes) when not set by the + -- front end. + + -- 3. If Backend_Layout is False, then the front end lays out + -- all data, according to target dependent size and alignment + -- information, creating dynamic inlinable functions where + -- needed in the case of sizes not known till runtime. + + ----------------------------- + -- Back-Annotation by Gigi -- + ----------------------------- + + -- The following interface is used by gigi if Backend_Layout is True. + + -- As part of the processing in gigi, the types are laid out and + -- appropriate values computed for the sizes and component positions + -- and sizes of records and arrays. + + -- The back-annotation circuit in gigi is responsible for updating the + -- relevant fields in the tree to reflect these computations, as follows: + + -- For E_Array_Type entities, the Component_Size field + + -- For all record and array types and subtypes, the Esize field, + -- which contains the Size (more accurately the Object_SIze) value + -- for the type or subtype. + + -- For E_Component and E_Distriminant entities, the Esize (size + -- of component) and Component_Bit_Offset fields. Note that gigi + -- does not (yet ???) back annotate Normalized_Position/First_Bit. + + -- There are three cases to consider: + + -- 1. The value is constant. In this case, the back annotation works + -- by simply storing the non-negative universal integer value in + -- the appropriate field corresponding to this constant size. + + -- 2. The value depends on variables other than discriminants of the + -- current record. In this case, the value is not known, even if + -- the complete data of the record is available, and gigi marks + -- this situation by storing the special value No_Uint. + + -- 3. The value depends on the discriminant values for the current + -- record. In this case, gigi back annotates the field with a + -- representation of the expression for computing the value in + -- terms of the discriminants. A negative Uint value is used to + -- represent the value of such an expression, as explained in + -- the following section. + + -- GCC expressions are represented with a Uint value that is negative. + -- See the body of this package for details on the representation used. + + -- One other case in which gigi back annotates GCC expressions is in + -- the Present_Expr field of an N_Variant node. This expression which + -- will always depend on discriminants, and hence always be represented + -- as a negative Uint value, provides an expression which, when evaluated + -- with a given set of discriminant values, indicates whether the variant + -- is present for that set of values (result is True, i.e. non-zero) or + -- not present (result is False, i.e. zero). + + subtype Node_Ref is Uint; + -- Subtype used for negative Uint values used to represent nodes + + subtype Node_Ref_Or_Val is Uint; + -- Subtype used for values that can either be a Node_Ref (negative) + -- or a value (non-negative) + + type TCode is range 0 .. 27; + -- Type used on Ada side to represent DEFTREECODE values defined in + -- tree.def. Only a subset of these tree codes can actually appear. + -- The names are the names from tree.def in Ada casing. + + -- name code description operands + + Cond_Expr : constant TCode := 1; -- conditional 3 + Plus_Expr : constant TCode := 2; -- addition 2 + Minus_Expr : constant TCode := 3; -- subtraction 2 + Mult_Expr : constant TCode := 4; -- multiplication 2 + Trunc_Div_Expr : constant TCode := 5; -- truncating division 2 + Ceil_Div_Expr : constant TCode := 6; -- division rounding up 2 + Floor_Div_Expr : constant TCode := 7; -- division rounding down 2 + Trunc_Mod_Expr : constant TCode := 8; -- mod for trunc_div 2 + Ceil_Mod_Expr : constant TCode := 9; -- mod for ceil_div 2 + Floor_Mod_Expr : constant TCode := 10; -- mod for floor_div 2 + Exact_Div_Expr : constant TCode := 11; -- exact div 2 + Negate_Expr : constant TCode := 12; -- negation 1 + Min_Expr : constant TCode := 13; -- minimum 2 + Max_Expr : constant TCode := 14; -- maximum 2 + Abs_Expr : constant TCode := 15; -- absolute value 1 + Truth_Andif_Expr : constant TCode := 16; -- Boolean and then 2 + Truth_Orif_Expr : constant TCode := 17; -- Boolean or else 2 + Truth_And_Expr : constant TCode := 18; -- Boolean and 2 + Truth_Or_Expr : constant TCode := 19; -- Boolean or 2 + Truth_Xor_Expr : constant TCode := 20; -- Boolean xor 2 + Truth_Not_Expr : constant TCode := 21; -- Boolean not 1 + Lt_Expr : constant TCode := 22; -- comparision < 2 + Le_Expr : constant TCode := 23; -- comparision <= 2 + Gt_Expr : constant TCode := 24; -- comparision > 2 + Ge_Expr : constant TCode := 25; -- comparision >= 2 + Eq_Expr : constant TCode := 26; -- comparision = 2 + Ne_Expr : constant TCode := 27; -- comparision /= 2 + + -- The following entry is used to represent a discriminant value in + -- the tree. It has a special tree code that does not correspond + -- directly to a gcc node. The single operand is the number of the + -- discriminant in the record (1 = first discriminant). + + Discrim_Val : constant TCode := 0; -- discriminant value 1 + + ------------------------ + -- The gigi Interface -- + ------------------------ + + -- The following declarations are for use by gigi for back annotation + + function Create_Node + (Expr : TCode; + Op1 : Node_Ref_Or_Val; + Op2 : Node_Ref_Or_Val := No_Uint; + Op3 : Node_Ref_Or_Val := No_Uint) + return Node_Ref; + -- Creates a node with using the tree code defined by Expr and from + -- 1-3 operands as required (unused operands set as shown to No_Uint) + -- Note that this call can be used to create a discriminant reference + -- by using (Expr => Discrim_Val, Op1 => discriminant_number). + + function Create_Discrim_Ref + (Discr : Entity_Id) + return Node_Ref; + -- Creates a refrerence to the discriminant whose entity is Discr. + + -------------------------------------------------------- + -- Front-End Interface for Dynamic Size/Offset Values -- + -------------------------------------------------------- + + -- If Backend_Layout is False, then the front-end deals with all + -- dynamic size and offset fields. There are two cases: + + -- 1. The value can be computed at the time of type freezing, and + -- is stored in a run-time constant. In this case, the field + -- contains a reference to this entity. In the case of sizes + -- the value stored is the size in storage units, since dynamic + -- sizes are always a multiple of storage units. + + -- 2. The size/offset depends on the value of discriminants at + -- run-time. In this case, the front end builds a function to + -- compute the value. This function has a single parameter + -- which is the discriminated record object in question. Any + -- references to discriminant values are simply references to + -- the appropriate discriminant in this single argument, and + -- to compute the required size/offset value at run time, the + -- code generator simply constructs a call to the function + -- with the appropriate argument. The size/offset field in + -- this case contains a reference to the function entity. + -- Note that as for case 1, if such a function is used to + -- return a size, then the size in storage units is returned, + -- not the size in bits. + + -- The interface here allows these created entities to be referenced + -- using negative Unit values, so that they can be stored in the + -- appropriate size and offset fields in the tree. + + -- In the case of components, if the location of the component is static, + -- then all four fields (Component_Bit_Offset, Normalized_Position, Esize, + -- and Normalized_First_Bit) are set to appropraite values. In the case of + -- a non-static component location, Component_Bit_Offset is not used and + -- is left set to Unknown. Normalized_Position and Normalized_First_Bit + -- are set appropriately. + + subtype SO_Ref is Uint; + -- Type used to represent a Uint value that represents a static or + -- dynamic size/offset value (non-negative if static, negative if + -- the size value is dynamic). + + subtype Dynamic_SO_Ref is Uint; + -- Type used to represent a negative Uint value used to store + -- a dynamic size/offset value. + + function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean; + pragma Inline (Is_Dynamic_SO_Ref); + -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value + -- represents a dynamic Size/Offset value (i.e. it is negative). + + function Is_Static_SO_Ref (U : SO_Ref) return Boolean; + pragma Inline (Is_Static_SO_Ref); + -- Given a SO_Ref (Uint) value, returns True iff the SO_Ref value + -- represents a static Size/Offset value (i.e. it is non-negative). + + function Create_Dynamic_SO_Ref + (E : Entity_Id) + return Dynamic_SO_Ref; + -- Given the Entity_Id for a constant (case 1), the Node_Id for an + -- expression (case 2), or the Entity_Id for a function (case 3), + -- this function returns a (negative) Uint value that can be used + -- to retrieve the entity or expression for later use. + + function Get_Dynamic_SO_Entity + (U : Dynamic_SO_Ref) + return Entity_Id; + -- Retrieve the Node_Id or Entity_Id stored by a previous call to + -- Create_Dynamic_SO_Ref. The approach is that the front end makes + -- the necessary Create_Dynamic_SO_Ref calls to associate the node + -- and entity id values and the back end makes Get_Dynamic_SO_Ref + -- calls to retrive them. + + -------------------- + -- ASIS_Interface -- + -------------------- + + type Discrim_List is array (Pos range <>) of Uint; + -- Type used to represent list of discriminant values + + function Rep_Value + (Val : Node_Ref_Or_Val; + D : Discrim_List) + return Uint; + -- Given the contents of a First_Bit_Position or Esize field containing + -- a node reference (i.e. a negative Uint value) and D, the list of + -- discriminant values, returns the interpreted value of this field. + -- For convenience, Rep_Value will take a non-negative Uint value + -- as an argument value, and return it unmodified. A No_Uint value is + -- also returned unmodified. + + procedure Tree_Read; + -- Read in the value of the Rep_Table + + ------------------------ + -- Compiler Interface -- + ------------------------ + + procedure List_Rep_Info; + -- Procedure to list representation information + + procedure Tree_Write; + -- Write out the value of the Rep_Table + + -------------------------- + -- Debugging Procedures -- + -------------------------- + + procedure List_GCC_Expression (U : Node_Ref_Or_Val); + -- Prints out given expression in symbolic form. Constants are listed + -- in decimal numeric form, Discriminants are listed with a # followed + -- by the discriminant number, and operators are output in appropriate + -- symbolic form No_Uint displays as two question marks. The output is + -- on a single line but has no line return after it. This procedure is + -- useful only if operating in backend layout mode. + + procedure lgx (U : Node_Ref_Or_Val); + -- In backend layout mode, this is like List_GCC_Expression, but + -- includes a line return at the end. If operating in front end + -- layout mode, then the name of the entity for the size (either + -- a function of a variable) is listed followed by a line return. + +end Repinfo; diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h new file mode 100644 index 00000000000..305c818685c --- /dev/null +++ b/gcc/ada/repinfo.h @@ -0,0 +1,79 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R E P I N F O * + * * + * C Header File * + * * + * $Revision: 1.1 $ + * * + * Copyright (C) 1999-2001 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, 59 Temple Place - Suite 330, Boston, * + * MA 02111-1307, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). * + * * + ****************************************************************************/ + +/* This file corresponds to the Ada file repinfo.ads. */ + +typedef Uint Node_Ref; +typedef Uint Node_Ref_Or_Val; +typedef char TCode; + +/* These are the values of TCcode that correspond to tree codes in tree.def, + except for the first, which is how we encode discriminants. */ + +#define Discrim_Val 0 +#define Cond_Expr 1 +#define Plus_Expr 2 +#define Minus_Expr 3 +#define Mult_Expr 4 +#define Trunc_Div_Expr 5 +#define Ceil_Div_Expr 6 +#define Floor_Div_Expr 7 +#define Trunc_Mod_Expr 8 +#define Ceil_Mod_Expr 9 +#define Floor_Mod_Expr 10 +#define Exact_Div_Expr 11 +#define Negate_Expr 12 +#define Min_Expr 13 +#define Max_Expr 14 +#define Abs_Expr 15 +#define Truth_Andif_Expr 16 +#define Truth_Orif_Expr 17 +#define Truth_And_Expr 18 +#define Truth_Or_Expr 19 +#define Truth_Xor_Expr 20 +#define Truth_Not_Expr 21 +#define Lt_Expr 22 +#define Le_Expr 23 +#define Gt_Expr 24 +#define Ge_Expr 25 +#define Eq_Expr 26 +#define Ne_Expr 27 + +/* Creates a node using the tree code defined by Expr and from 1-3 + operands as required (unused operands set as shown to No_Uint) Note + that this call can be used to create a discriminant reference by + using (Expr => Discrim_Val, Op1 => discriminant_number). */ +#define Create_Node repinfo__create_node +extern Node_Ref Create_Node PARAMS((TCode, Node_Ref_Or_Val, + Node_Ref_Or_Val, Node_Ref_Or_Val)); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb new file mode 100644 index 00000000000..a284cd42e82 --- /dev/null +++ b/gcc/ada/restrict.adb @@ -0,0 +1,458 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E S T R I C T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.37 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Errout; use Errout; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Opt; use Opt; +with Stand; use Stand; +with Uname; use Uname; + +package body Restrict is + + function Suppress_Restriction_Message (N : Node_Id) return Boolean; + -- N is the node for a possible restriction violation message, but + -- the message is to be suppressed if this is an internal file and + -- this file is not the main unit. + + ------------------- + -- Abort_Allowed -- + ------------------- + + function Abort_Allowed return Boolean is + begin + return + Restrictions (No_Abort_Statements) = False + or else + Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0; + end Abort_Allowed; + + ------------------------------------ + -- Check_Elaboration_Code_Allowed -- + ------------------------------------ + + procedure Check_Elaboration_Code_Allowed (N : Node_Id) is + begin + -- Avoid calling Namet.Unlock/Lock except when there is an error. + -- Even in the error case it is a bit dubious, either gigi needs + -- the table locked or it does not! ??? + + if Restrictions (No_Elaboration_Code) + and then not Suppress_Restriction_Message (N) + then + Namet.Unlock; + Check_Restriction (No_Elaboration_Code, N); + Namet.Lock; + end if; + end Check_Elaboration_Code_Allowed; + + --------------------------- + -- Check_Restricted_Unit -- + --------------------------- + + procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is + begin + if Suppress_Restriction_Message (N) then + return; + + elsif Is_Spec_Name (U) then + declare + Fnam : constant File_Name_Type := + Get_File_Name (U, Subunit => False); + R_Id : Restriction_Id; + + begin + if not Is_Predefined_File_Name (Fnam) then + return; + + -- Ada child unit spec, needs checking against list + + else + -- Pad name to 8 characters with blanks + + Get_Name_String (Fnam); + Name_Len := Name_Len - 4; + + while Name_Len < 8 loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; + + for J in Unit_Array'Range loop + if Name_Len = 8 + and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm + then + R_Id := Unit_Array (J).Res_Id; + Violations (R_Id) := True; + + if Restrictions (R_Id) then + declare + S : constant String := Restriction_Id'Image (R_Id); + + begin + Error_Msg_Unit_1 := U; + + Error_Msg_N + ("dependence on $ not allowed,", N); + + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (All_Lower_Case); + Error_Msg_Name_1 := Name_Enter; + Error_Msg_Sloc := Restrictions_Loc (R_Id); + + Error_Msg_N + ("\violates pragma Restriction (%) #", N); + return; + end; + end if; + end if; + end loop; + end if; + end; + end if; + end Check_Restricted_Unit; + + ----------------------- + -- Check_Restriction -- + ----------------------- + + -- Case of simple identifier (no parameter) + + procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is + begin + Violations (R) := True; + + if Restrictions (R) + and then not Suppress_Restriction_Message (N) + then + declare + S : constant String := Restriction_Id'Image (R); + + begin + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (All_Lower_Case); + Error_Msg_Name_1 := Name_Enter; + Error_Msg_Sloc := Restrictions_Loc (R); + Error_Msg_N ("violation of restriction %#", N); + end; + end if; + end Check_Restriction; + + -- Case where a parameter is present (but no count) + + procedure Check_Restriction + (R : Restriction_Parameter_Id; + N : Node_Id) + is + begin + if Restriction_Parameters (R) = Uint_0 + and then not Suppress_Restriction_Message (N) + then + declare + Loc : constant Source_Ptr := Sloc (N); + S : constant String := + Restriction_Parameter_Id'Image (R); + + begin + Error_Msg_NE + ("& will be raised at run time?!", N, Standard_Storage_Error); + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (All_Lower_Case); + Error_Msg_Name_1 := Name_Enter; + Error_Msg_Sloc := Restriction_Parameters_Loc (R); + Error_Msg_N ("violation of restriction %?#!", N); + + Insert_Action (N, + Make_Raise_Storage_Error (Loc)); + end; + end if; + end Check_Restriction; + + -- Case where a parameter is present, with a count + + procedure Check_Restriction + (R : Restriction_Parameter_Id; + V : Uint; + N : Node_Id) + is + begin + if Restriction_Parameters (R) /= No_Uint + and then V > Restriction_Parameters (R) + and then not Suppress_Restriction_Message (N) + then + declare + S : constant String := Restriction_Parameter_Id'Image (R); + + begin + Name_Buffer (1 .. S'Last) := S; + Name_Len := S'Length; + Set_Casing (All_Lower_Case); + Error_Msg_Name_1 := Name_Enter; + Error_Msg_Sloc := Restriction_Parameters_Loc (R); + Error_Msg_N ("maximum value exceeded for restriction %#", N); + end; + end if; + end Check_Restriction; + + ------------------------------------------- + -- Compilation_Unit_Restrictions_Restore -- + ------------------------------------------- + + procedure Compilation_Unit_Restrictions_Restore + (R : Save_Compilation_Unit_Restrictions) + is + begin + for J in Compilation_Unit_Restrictions loop + Restrictions (J) := R (J); + end loop; + end Compilation_Unit_Restrictions_Restore; + + ---------------------------------------- + -- Compilation_Unit_Restrictions_Save -- + ---------------------------------------- + + function Compilation_Unit_Restrictions_Save + return Save_Compilation_Unit_Restrictions + is + R : Save_Compilation_Unit_Restrictions; + + begin + for J in Compilation_Unit_Restrictions loop + R (J) := Restrictions (J); + Restrictions (J) := False; + end loop; + + return R; + end Compilation_Unit_Restrictions_Save; + + ---------------------------------- + -- Disallow_In_No_Run_Time_Mode -- + ---------------------------------- + + procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is + begin + if No_Run_Time then + Error_Msg_N + ("this construct not allowed in No_Run_Time mode", Enode); + end if; + end Disallow_In_No_Run_Time_Mode; + + ------------------------ + -- Get_Restriction_Id -- + ------------------------ + + function Get_Restriction_Id + (N : Name_Id) + return Restriction_Id + is + J : Restriction_Id; + + begin + Get_Name_String (N); + Set_Casing (All_Upper_Case); + + J := Restriction_Id'First; + while J /= Not_A_Restriction_Id loop + declare + S : constant String := Restriction_Id'Image (J); + + begin + exit when S = Name_Buffer (1 .. Name_Len); + end; + + J := Restriction_Id'Succ (J); + end loop; + + return J; + end Get_Restriction_Id; + + ---------------------------------- + -- Get_Restriction_Parameter_Id -- + ---------------------------------- + + function Get_Restriction_Parameter_Id + (N : Name_Id) + return Restriction_Parameter_Id + is + J : Restriction_Parameter_Id; + + begin + Get_Name_String (N); + Set_Casing (All_Upper_Case); + + J := Restriction_Parameter_Id'First; + while J /= Not_A_Restriction_Parameter_Id loop + declare + S : constant String := Restriction_Parameter_Id'Image (J); + + begin + exit when S = Name_Buffer (1 .. Name_Len); + end; + + J := Restriction_Parameter_Id'Succ (J); + end loop; + + return J; + end Get_Restriction_Parameter_Id; + + ------------------------------- + -- No_Exception_Handlers_Set -- + ------------------------------- + + function No_Exception_Handlers_Set return Boolean is + begin + return Restrictions (No_Exception_Handlers); + end No_Exception_Handlers_Set; + + ------------------------ + -- Restricted_Profile -- + ------------------------ + + -- This implementation must be coordinated with Set_Restricted_Profile + + function Restricted_Profile return Boolean is + begin + return Restrictions (No_Abort_Statements) + and then Restrictions (No_Asynchronous_Control) + and then Restrictions (No_Entry_Queue) + and then Restrictions (No_Task_Hierarchy) + and then Restrictions (No_Task_Allocators) + and then Restrictions (No_Dynamic_Priorities) + and then Restrictions (No_Terminate_Alternatives) + and then Restrictions (No_Dynamic_Interrupts) + and then Restrictions (No_Protected_Type_Allocators) + and then Restrictions (No_Local_Protected_Objects) + and then Restrictions (No_Requeue) + and then Restrictions (No_Task_Attributes) + and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0 + and then Restriction_Parameters (Max_Task_Entries) = 0 + and then Restriction_Parameters (Max_Protected_Entries) <= 1 + and then Restriction_Parameters (Max_Select_Alternatives) = 0; + end Restricted_Profile; + + -------------------------- + -- Set_No_Run_Time_Mode -- + -------------------------- + + procedure Set_No_Run_Time_Mode is + begin + No_Run_Time := True; + Restrictions (No_Exception_Handlers) := True; + end Set_No_Run_Time_Mode; + + ------------------- + -- Set_Ravenscar -- + ------------------- + + procedure Set_Ravenscar is + begin + Set_Restricted_Profile; + Restrictions (Boolean_Entry_Barriers) := True; + Restrictions (No_Select_Statements) := True; + Restrictions (No_Calendar) := True; + Restrictions (Static_Storage_Size) := True; + Restrictions (No_Entry_Queue) := True; + Restrictions (No_Relative_Delay) := True; + Restrictions (No_Task_Termination) := True; + Restrictions (No_Implicit_Heap_Allocations) := True; + end Set_Ravenscar; + + ---------------------------- + -- Set_Restricted_Profile -- + ---------------------------- + + -- This must be coordinated with Restricted_Profile + + procedure Set_Restricted_Profile is + begin + Restrictions (No_Abort_Statements) := True; + Restrictions (No_Asynchronous_Control) := True; + Restrictions (No_Entry_Queue) := True; + Restrictions (No_Task_Hierarchy) := True; + Restrictions (No_Task_Allocators) := True; + Restrictions (No_Dynamic_Priorities) := True; + Restrictions (No_Terminate_Alternatives) := True; + Restrictions (No_Dynamic_Interrupts) := True; + Restrictions (No_Protected_Type_Allocators) := True; + Restrictions (No_Local_Protected_Objects) := True; + Restrictions (No_Requeue) := True; + Restrictions (No_Task_Attributes) := True; + + Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0; + Restriction_Parameters (Max_Task_Entries) := Uint_0; + Restriction_Parameters (Max_Select_Alternatives) := Uint_0; + + if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then + Restriction_Parameters (Max_Protected_Entries) := Uint_1; + end if; + end Set_Restricted_Profile; + + ---------------------------------- + -- Suppress_Restriction_Message -- + ---------------------------------- + + function Suppress_Restriction_Message (N : Node_Id) return Boolean is + begin + -- If main unit is library unit, then we will output message + + if In_Extended_Main_Source_Unit (N) then + return False; + + -- If loaded by rtsfind, then suppress message + + elsif Sloc (N) <= No_Location then + return True; + + -- Otherwise suppress message if internal file + + else + return + Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); + end if; + end Suppress_Restriction_Message; + + --------------------- + -- Tasking_Allowed -- + --------------------- + + function Tasking_Allowed return Boolean is + begin + return + Restriction_Parameters (Max_Tasks) /= 0; + end Tasking_Allowed; + +end Restrict; diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads new file mode 100644 index 00000000000..426149efaaf --- /dev/null +++ b/gcc/ada/restrict.ads @@ -0,0 +1,253 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E S T R I C T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package deals with the implementation of the Restrictions pragma + +with Rident; +with Types; use Types; +with Uintp; use Uintp; + +package Restrict is + + type Restriction_Id is new Rident.Restriction_Id; + -- The type Restriction_Id defines the set of restriction identifiers, + -- which take no parameter (i.e. they are either present or not present). + -- The actual definition is in the separate package Rident, so that it + -- can easily be accessed by the binder without dragging in lots of stuff. + + subtype Partition_Restrictions is + Restriction_Id range + Restriction_Id (Rident.Partition_Restrictions'First) .. + Restriction_Id (Rident.Partition_Restrictions'Last); + -- Range of restriction identifiers that are checked by the binder + + subtype Compilation_Unit_Restrictions is + Restriction_Id range + Restriction_Id (Rident.Compilation_Unit_Restrictions'First) .. + Restriction_Id (Rident.Compilation_Unit_Restrictions'Last); + -- Range of restriction identifiers not checked by binder + + type Restriction_Parameter_Id is new Rident.Restriction_Parameter_Id; + -- The type Restriction_Parameter_Id records cases where a parameter is + -- present in the corresponding pragma. These cases are not checked for + -- consistency by the binder. The actual definition is in the separate + -- package Rident for consistency. + + type Restrictions_Flags is array (Restriction_Id) of Boolean; + -- Type used for arrays indexed by Restriction_Id. + + Restrictions : Restrictions_Flags := (others => False); + -- Corresponding entry is False if restriction is not active, and + -- True if the restriction is active, i.e. if a pragma Restrictions + -- has been seen anywhere. Note that we are happy to pick up any + -- restrictions pragmas in with'ed units, since we are required to + -- be consistent at link time, and we might as well find the error + -- at compile time. Clients must NOT use this array for checking to + -- see if a restriction is violated, instead it is required that the + -- Check_Restrictions subprograms be used for this purpose. The only + -- legitimate direct use of this array is when the code is modified + -- as a result of the restriction in some way. + + Restrictions_Loc : array (Restriction_Id) of Source_Ptr; + -- Locations of Restrictions pragmas for error message purposes. + -- Valid only if corresponding entry in Restrictions is set. + + Main_Restrictions : Restrictions_Flags := (others => False); + -- This variable saves the cumulative restrictions in effect compiling + -- any unit that is part of the extended main unit (i.e. the compiled + -- unit, its spec if any, and its subunits if any). The reason we keep + -- track of this is for the information that goes to the binder about + -- restrictions that are set. The binder will identify a unit that has + -- a restrictions pragma for error message purposes, and we do not want + -- to pick up a restrictions pragma in a with'ed unit for this purpose. + + Violations : Restrictions_Flags := (others => False); + -- Corresponding entry is False if the restriction has not been + -- violated in the current main unit, and True if it has been violated. + + Restriction_Parameters : + array (Restriction_Parameter_Id) of Uint := (others => No_Uint); + -- This array indicates the setting of restriction parameter identifier + -- values. All values are initially set to No_Uint indicating that the + -- parameter is not set, and are set to the appropriate non-negative + -- value if a Restrictions pragma specifies the corresponding + -- restriction parameter identifier with an appropriate value. + + Restriction_Parameters_Loc : + array (Restriction_Parameter_Id) of Source_Ptr; + -- Locations of Restrictions pragmas for error message purposes. + -- Valid only if corresponding entry in Restriction_Parameters is + -- set to a value other than No_Uint. + + type Unit_Entry is record + Res_Id : Restriction_Id; + Filenm : String (1 .. 8); + end record; + + type Unit_Array_Type is array (Positive range <>) of Unit_Entry; + + Unit_Array : constant Unit_Array_Type := ( + (No_Asynchronous_Control, "a-astaco"), + (No_Calendar, "a-calend"), + (No_Calendar, "calendar"), + (No_Delay, "a-calend"), + (No_Delay, "calendar"), + (No_Dynamic_Priorities, "a-dynpri"), + (No_IO, "a-direio"), + (No_IO, "directio"), + (No_IO, "a-sequio"), + (No_IO, "sequenio"), + (No_IO, "a-ststio"), + (No_IO, "a-textio"), + (No_IO, "text_io "), + (No_IO, "a-witeio"), + (No_Task_Attributes, "a-tasatt"), + (No_Streams, "a-stream"), + (No_Unchecked_Conversion, "a-unccon"), + (No_Unchecked_Conversion, "unchconv"), + (No_Unchecked_Deallocation, "a-uncdea"), + (No_Unchecked_Deallocation, "unchdeal")); + -- This array defines the mapping between restriction identifiers and + -- predefined language files containing units for which the identifier + -- forbids semantic dependence. + + type Save_Compilation_Unit_Restrictions is private; + -- Type used for saving and restoring compilation unit restrictions. + -- See Compilation_Unit_Restrictions_[Save|Restore] subprograms. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id); + -- Checks if loading of unit U is prohibited by the setting of some + -- restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO). + -- If a restriction exists post error message at the given node. + + procedure Check_Restriction (R : Restriction_Id; N : Node_Id); + -- Checks that the given restriction is not set, and if it is set, an + -- appropriate message is posted on the given node. Also records the + -- violation in the violations array. Note that it is mandatory to + -- always use this routine to check if a restriction is violated. Such + -- checks must never be done directly by the caller, since otherwise + -- they are not properly recorded in the violations array. + + procedure Check_Restriction + (R : Restriction_Parameter_Id; + N : Node_Id); + -- Checks that the given restriction parameter identifier is not set to + -- zero. If it is set to zero, then the node N is replaced by a node + -- that raises Storage_Error, and a warning is issued. + + procedure Check_Restriction + (R : Restriction_Parameter_Id; + V : Uint; + N : Node_Id); + -- Checks that the count in V does not exceed the maximum value of the + -- restriction parameter value corresponding to the given restriction + -- parameter identifier (if it has been set). If the count in V exceeds + -- the maximum, then post an error message on node N. + + procedure Check_Elaboration_Code_Allowed (N : Node_Id); + -- Tests to see if elaboration code is allowed by the current restrictions + -- settings. This function is called by Gigi when it needs to define + -- an elaboration routine. If elaboration code is not allowed, an error + -- message is posted on the node given as argument. + + function No_Exception_Handlers_Set return Boolean; + -- Test to see if current restrictions settings specify that no exception + -- handlers are present. This function is called by Gigi when it needs to + -- expand an AT END clean up identifier with no exception handler. + + function Compilation_Unit_Restrictions_Save + return Save_Compilation_Unit_Restrictions; + -- This function saves the compilation unit restriction settings, and + -- resets them to False. This is used e.g. when compiling a with'ed + -- unit to avoid incorrectly propagating restrictions. Note that it + -- would not be wrong to also save and reset the partition restrictions, + -- since the binder would catch inconsistencies, but actually it is a + -- good thing to acquire restrictions from with'ed units if they are + -- required to be partition wide, because it allows the restriction + -- violation message to be given at compile time instead of link time. + + procedure Compilation_Unit_Restrictions_Restore + (R : Save_Compilation_Unit_Restrictions); + -- This is the corresponding restore procedure to restore restrictions + -- previously saved by Compilation_Unit_Restrictions_Save. + + procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id); + -- If in No_Run_Time mode, then the construct represented by Enode is + -- not permitted, and will be appropriately flagged. + + procedure Set_No_Run_Time_Mode; + -- Set the no run time mode, and associated restriction pragmas. + + function Get_Restriction_Id + (N : Name_Id) + return Restriction_Id; + -- Given an identifier name, determines if it is a valid restriction + -- identifier, and if so returns the corresponding Restriction_Id + -- value, otherwise returns Not_A_Restriction_Id. + + function Get_Restriction_Parameter_Id + (N : Name_Id) + return Restriction_Parameter_Id; + -- Given an identifier name, determines if it is a valid restriction + -- parameter identifier, and if so returns the corresponding + -- Restriction_Parameter_Id value, otherwise returns + -- Not_A_Restriction_Parameter_Id. + + function Abort_Allowed return Boolean; + pragma Inline (Abort_Allowed); + -- Tests to see if abort is allowed by the current restrictions settings. + -- For abort to be allowed, either No_Abort_Statements must be False, + -- or Max_Asynchronous_Select_Nesting must be non-zero. + + function Restricted_Profile return Boolean; + -- Tests to see if tasking operations follow the GNAT restricted run time + -- profile. + + procedure Set_Ravenscar; + -- Sets the set of rerstrictions fro Ravenscar + + procedure Set_Restricted_Profile; + -- Sets the set of restrictions for pragma Restricted_Run_Time + + function Tasking_Allowed return Boolean; + pragma Inline (Tasking_Allowed); + -- Tests to see if tasking operations are allowed by the current + -- restrictions settings. For tasking to be allowed Max_Tasks must + -- be non-zero. + +private + type Save_Compilation_Unit_Restrictions is + array (Compilation_Unit_Restrictions) of Boolean; + -- Type used for saving and restoring compilation unit restrictions. + -- See Compilation_Unit_Restrictions_[Save|Restore] subprograms. + +end Restrict; diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads new file mode 100644 index 00000000000..3eb65408433 --- /dev/null +++ b/gcc/ada/rident.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R I D E N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the set of restriction identifiers. It is in a +-- separate package from Restrict so that it can be easily used by the +-- binder without dragging in a lot of stuff. + +package Rident is + + -- The following enumeration type defines the set of restriction + -- identifiers not taking a parameter that are implemented in GNAT. + -- To add a new restriction identifier, add an entry with the name + -- to be used in the pragma, and add appropriate calls to the + -- Check_Restriction routine. + + type Restriction_Id is ( + + -- The following cases are checked for consistency in the binder + + Boolean_Entry_Barriers, -- GNAT (Ravenscar) + No_Abort_Statements, -- (RM D.7(5), H.4(3)) + No_Access_Subprograms, -- (RM H.4(17)) + No_Allocators, -- (RM H.4(7)) + No_Asynchronous_Control, -- (RM D.9(10)) + No_Calendar, -- GNAT + No_Delay, -- (RM H.4(21)) + No_Dispatch, -- (RM H.4(19)) + No_Dynamic_Interrupts, -- GNAT + No_Dynamic_Priorities, -- (RM D.9(9)) + No_Enumeration_Maps, -- GNAT + No_Entry_Calls_In_Elaboration_Code, -- GNAT + No_Entry_Queue, -- GNAT + No_Exception_Handlers, -- GNAT + No_Exceptions, -- (RM H.4(12)) + No_Fixed_Point, -- (RM H.4(15)) + No_Floating_Point, -- (RM H.4(14)) + No_IO, -- (RM H.4(20)) + No_Implicit_Conditionals, -- GNAT + No_Implicit_Dynamic_Code, -- GNAT + No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Loops, -- GNAT + No_Local_Allocators, -- (RM H.4(8)) + No_Local_Protected_Objects, -- GNAT + No_Nested_Finalization, -- (RM D.7(4)) + No_Protected_Type_Allocators, -- GNAT + No_Protected_Types, -- (RM H.4(5)) + No_Recursion, -- (RM H.4(22)) + No_Reentrancy, -- (RM H.4(23)) + No_Relative_Delay, -- GNAT + No_Requeue, -- GNAT + No_Select_Statements, -- GNAT (Ravenscar) + No_Standard_Storage_Pools, -- GNAT + No_Streams, -- GNAT + No_Task_Allocators, -- (RM D.7(7)) + No_Task_Attributes, -- GNAT + No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) + No_Task_Termination, -- GNAT + No_Terminate_Alternatives, -- (RM D.7(6)) + No_Unchecked_Access, -- (RM H.4(18)) + No_Unchecked_Conversion, -- (RM H.4(16)) + No_Unchecked_Deallocation, -- (RM H.4(9)) + No_Wide_Characters, -- GNAT + Static_Priorities, -- GNAT + Static_Storage_Size, -- GNAT + + -- The following cases do not require partition-wide checks + + Immediate_Reclamation, -- (RM H.4(10)) + No_Implementation_Attributes, -- GNAT + No_Implementation_Pragmas, -- GNAT + No_Implementation_Restrictions, -- GNAT + No_Elaboration_Code, -- GNAT + + Not_A_Restriction_Id); + + -- The following range of Restriction identifiers is checked for + -- consistency across a partition. The generated ali file is marked + -- for each entry to show one of three possibilities: + -- + -- Corresponding restriction is set (so unit does not violate it) + -- Corresponding restriction is not violated + -- Corresponding restriction is violated + + subtype Partition_Restrictions is + Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size; + + -- The following set of Restriction identifiers is not checked for + -- consistency across a partition, and the generated ali files does + -- not carry any indications with respect to such restrictions. + + subtype Compilation_Unit_Restrictions is + Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code; + + -- The following enumeration type defines the set of restriction + -- parameter identifiers taking a parameter that are implemented in + -- GNAT. To add a new restriction parameter identifier, add an entry + -- with the name to be used in the pragma, and add appropriate + -- calls to Check_Restriction. + + -- Note: the GNAT implementation currently only accomodates restriction + -- parameter identifiers whose expression value is a non-negative + -- integer. This is true for all language defined parameters. + + type Restriction_Parameter_Id is ( + Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) + Max_Entry_Queue_Depth, -- GNAT + Max_Protected_Entries, -- (RM D.7(14)) + Max_Select_Alternatives, -- (RM D.7(12)) + Max_Storage_At_Blocking, -- (RM D.7(17)) + Max_Task_Entries, -- (RM D.7(13), H.4(3)) + Max_Tasks, -- (RM D.7(19), H.4(3)) + Not_A_Restriction_Parameter_Id); + +end Rident; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb new file mode 100644 index 00000000000..1299e1e2a13 --- /dev/null +++ b/gcc/ada/rtsfind.adb @@ -0,0 +1,913 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R T S F I N D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.96 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Casing; use Casing; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Lib.Load; use Lib.Load; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Opt; use Opt; +with Restrict; use Restrict; +with Sem; use Sem; +with Sem_Ch7; use Sem_Ch7; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Snames; use Snames; +with Tbuild; use Tbuild; +with Uname; use Uname; + +package body Rtsfind is + + ---------------- + -- Unit table -- + ---------------- + + -- The unit table has one entry for each unit included in the definition + -- of the type RTU_Id in the spec. The table entries are initialized in + -- Initialize to set the Entity field to Empty, indicating that the + -- corresponding unit has not yet been loaded. The fields are set when + -- a unit is loaded to contain the defining entity for the unit, the + -- unit name, and the unit number. + + type RT_Unit_Table_Record is record + Entity : Entity_Id; + Uname : Unit_Name_Type; + Unum : Unit_Number_Type; + Withed : Boolean; + end record; + + RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; + + -------------------------- + -- Runtime Entity Table -- + -------------------------- + + -- There is one entry in the runtime entity table for each entity that is + -- included in the definition of the RE_Id type in the spec. The entries + -- are set by Initialize_Rtsfind to contain Empty, indicating that the + -- entity has not yet been located. Once the entity is located for the + -- first time, its ID is stored in this array, so that subsequent calls + -- for the same entity can be satisfied immediately. + + RE_Table : array (RE_Id) of Entity_Id; + + -------------------------- + -- Generation of WITH's -- + -------------------------- + + -- When a unit is implicitly loaded as a result of a call to RTE, it + -- is necessary to create an implicit with to ensure that the object + -- is correctly loaded by the binder. Such with statements are only + -- required when the request is from the extended main unit (if a + -- client needs a with, that will be taken care of when the client + -- is compiled. + + -- We always attach the with to the main unit. This is not perfectly + -- accurate in terms of elaboration requirements, but it is close + -- enough, since the units that are accessed using rtsfind do not + -- have delicate elaboration requirements. + + -- The flag Withed in the unit table record is initially set to False. + -- It is set True if a with has been generated for the main unit for + -- the corresponding unit. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := ""); + -- Internal procedure called if we can't find the entity or unit. + -- The parameter is a detailed error message that is to be given. + -- S is a reason for failing to compile the file. U_Id is the unit + -- id, and Ent_Name, if non-null, is the associated entity name. + + function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; + -- Retrieves the Unit Name given a unit id represented by its + -- enumaration value in RTU_Id. + + procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False); + -- Load the unit whose Id is given if not already loaded. The unit is + -- loaded, analyzed, and added to the with list, and the entry in + -- RT_Unit_Table is updated to reflect the load. The second parameter + -- indicates the initial setting for the Is_Potentially_Use_Visible + -- flag of the entity for the loaded unit (if it is indeed loaded). + -- A value of False means nothing special need be done. A value of + -- True indicates that this flag must be set to True. It is needed + -- only in the Text_IO_Kludge procedure, which may materialize an + -- entity of Text_IO (or Wide_Text_IO) that was previously unknown. + + function RE_Chars (E : RE_Id) return Name_Id; + -- Given a RE_Id value returns the Chars of the corresponding entity. + + ------------------- + -- Get_Unit_Name -- + ------------------- + + function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is + Uname_Chars : constant String := RTU_Id'Image (U_Id); + + begin + Name_Len := Uname_Chars'Length; + Name_Buffer (1 .. Name_Len) := Uname_Chars; + Set_Casing (All_Lower_Case); + + if U_Id in Ada_Child then + Name_Buffer (4) := '.'; + + if U_Id in Ada_Calendar_Child then + Name_Buffer (13) := '.'; + + elsif U_Id in Ada_Finalization_Child then + Name_Buffer (17) := '.'; + + elsif U_Id in Ada_Real_Time_Child then + Name_Buffer (14) := '.'; + + elsif U_Id in Ada_Streams_Child then + Name_Buffer (12) := '.'; + + elsif U_Id in Ada_Text_IO_Child then + Name_Buffer (12) := '.'; + + elsif U_Id in Ada_Wide_Text_IO_Child then + Name_Buffer (17) := '.'; + end if; + + elsif U_Id in Interfaces_Child then + Name_Buffer (11) := '.'; + + elsif U_Id in System_Child then + Name_Buffer (7) := '.'; + + if U_Id in System_Tasking_Child then + Name_Buffer (15) := '.'; + end if; + + if U_Id in System_Tasking_Restricted_Child then + Name_Buffer (26) := '.'; + end if; + + if U_Id in System_Tasking_Protected_Objects_Child then + Name_Buffer (33) := '.'; + end if; + + if U_Id in System_Tasking_Async_Delays_Child then + Name_Buffer (28) := '.'; + end if; + end if; + + -- Add %s at end for spec + + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := 's'; + Name_Len := Name_Len + 2; + + return Name_Find; + end Get_Unit_Name; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- Initialize the unit table + + for J in RTU_Id loop + RT_Unit_Table (J).Entity := Empty; + end loop; + + for J in RE_Id loop + RE_Table (J) := Empty; + end loop; + end Initialize; + + ------------ + -- Is_RTE -- + ------------ + + function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is + E_Unit_Name : Unit_Name_Type; + Ent_Unit_Name : Unit_Name_Type; + + S : Entity_Id; + E1 : Entity_Id; + E2 : Entity_Id; + + begin + if No (Ent) then + return False; + + -- If E has already a corresponding entity, check it directly, + -- going to full views if they exist to deal with the incomplete + -- and private type cases properly. + + elsif Present (RE_Table (E)) then + E1 := Ent; + + if Is_Type (E1) and then Present (Full_View (E1)) then + E1 := Full_View (E1); + end if; + + E2 := RE_Table (E); + + if Is_Type (E2) and then Present (Full_View (E2)) then + E2 := Full_View (E2); + end if; + + return E1 = E2; + end if; + + -- If the unit containing E is not loaded, we already know that + -- the entity we have cannot have come from this unit. + + E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); + + if not Is_Loaded (E_Unit_Name) then + return False; + end if; + + -- Here the unit containing the entity is loaded. We have not made + -- an explicit call to RTE to get the entity in question, but we may + -- have obtained a reference to it indirectly from some other entity + -- in the same unit, or some other unit that references it. + + -- Get the defining unit of the entity + + S := Scope (Ent); + + if Ekind (S) /= E_Package then + return False; + end if; + + Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S)); + + -- If the defining unit of the entity we are testing is not the + -- unit containing E, then they cannot possibly match. + + if Ent_Unit_Name /= E_Unit_Name then + return False; + end if; + + -- If the units match, then compare the names (remember that no + -- overloading is permitted in entities fetched using Rtsfind). + + if RE_Chars (E) = Chars (Ent) then + RE_Table (E) := Ent; + + -- If front-end inlining is enabled, we may be within a body that + -- contains inlined functions, which has not been retrieved through + -- rtsfind, and therefore is not yet recorded in the RT_Unit_Table. + -- Add the unit information now, it must be fully available. + + declare + U : RT_Unit_Table_Record + renames RT_Unit_Table (RE_Unit_Table (E)); + begin + if No (U.Entity) then + U.Entity := S; + U.Uname := E_Unit_Name; + U.Unum := Get_Source_Unit (S); + end if; + end; + + return True; + else + return False; + end if; + end Is_RTE; + + ---------------------------- + -- Is_Text_IO_Kludge_Unit -- + ---------------------------- + + function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is + Prf : Node_Id; + Sel : Node_Id; + + begin + if Nkind (Nam) /= N_Expanded_Name then + return False; + end if; + + Prf := Prefix (Nam); + Sel := Selector_Name (Nam); + + if Nkind (Sel) /= N_Expanded_Name + or else Nkind (Prf) /= N_Identifier + or else Chars (Prf) /= Name_Ada + then + return False; + end if; + + Prf := Prefix (Sel); + Sel := Selector_Name (Sel); + + return + Nkind (Prf) = N_Identifier + and then + (Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO) + and then + Nkind (Sel) = N_Identifier + and then + Chars (Sel) in Text_IO_Package_Name; + + end Is_Text_IO_Kludge_Unit; + + --------------- + -- Load_Fail -- + --------------- + + procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is + begin + Set_Standard_Error; + + Write_Str ("fatal error: run-time library configuration error"); + Write_Eol; + + if Ent_Name /= "" then + Write_Str ("cannot locate """); + + -- Copy name skipping initial RE_ or RO_XX characters + + if Ent_Name (1 .. 2) = "RE" then + for J in 4 .. Ent_Name'Length loop + Name_Buffer (J - 3) := Ent_Name (J); + end loop; + else + for J in 7 .. Ent_Name'Length loop + Name_Buffer (J - 6) := Ent_Name (J); + end loop; + end if; + + Name_Len := Ent_Name'Length - 3; + Set_Casing (Mixed_Case); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Str (""" in file """); + + else + Write_Str ("cannot load file """); + end if; + + Write_Name + (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); + Write_Str (""" ("); + Write_Str (S); + Write_Char (')'); + Write_Eol; + Set_Standard_Output; + raise Unrecoverable_Error; + end Load_Fail; + + -------------- + -- Load_RTU -- + -------------- + + procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is + Loaded : Boolean; + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + Priv_Par : Elist_Id := New_Elmt_List; + Lib_Unit : Node_Id; + + procedure Save_Private_Visibility; + -- If the current unit is the body of child unit or the spec of a + -- private child unit, the private declarations of the parent (s) + -- are visible. If the unit to be loaded is another public sibling, + -- its compilation will affect the visibility of the common ancestors. + -- Indicate those that must be restored. + + procedure Restore_Private_Visibility; + -- Restore the visibility of ancestors after compiling RTU. + + -------------------------------- + -- Restore_Private_Visibility -- + -------------------------------- + + procedure Restore_Private_Visibility is + E_Par : Elmt_Id; + + begin + E_Par := First_Elmt (Priv_Par); + + while Present (E_Par) loop + if not In_Private_Part (Node (E_Par)) then + Install_Private_Declarations (Node (E_Par)); + end if; + + Next_Elmt (E_Par); + end loop; + end Restore_Private_Visibility; + + ----------------------------- + -- Save_Private_Visibility -- + ----------------------------- + + procedure Save_Private_Visibility is + Par : Entity_Id; + + begin + Par := Scope (Current_Scope); + + while Present (Par) + and then Par /= Standard_Standard + loop + if Ekind (Par) = E_Package + and then Is_Compilation_Unit (Par) + and then In_Private_Part (Par) + then + Append_Elmt (Par, Priv_Par); + end if; + + Par := Scope (Par); + end loop; + end Save_Private_Visibility; + + -- Start of processing for Load_RTU + + begin + -- Nothing to do if unit is already loaded + + if Present (U.Entity) then + return; + end if; + + -- Otherwise we need to load the unit, First build unit name + -- from the enumeration literal name in type RTU_Id. + + U.Uname := Get_Unit_Name (U_Id); + U.Withed := False; + Loaded := Is_Loaded (U.Uname); + + -- Now do the load call, note that setting Error_Node to Empty is + -- a signal to Load_Unit that we will regard a failure to find the + -- file as a fatal error, and that it should not output any kind + -- of diagnostics, since we will take care of it here. + + U.Unum := + Load_Unit + (Load_Name => U.Uname, + Required => False, + Subunit => False, + Error_Node => Empty); + + if U.Unum = No_Unit then + Load_Fail ("unit not found", U_Id); + + elsif Fatal_Error (U.Unum) then + Load_Fail ("parser errors", U_Id); + end if; + + -- Make sure that the unit is analyzed + + declare + Was_Analyzed : Boolean := Analyzed (Cunit (Current_Sem_Unit)); + + begin + -- Pretend that the current unit is analysed, in case it is + -- System or some such. This allows us to put some declarations, + -- such as exceptions and packed arrays of Boolean, into System + -- even though expanding them requires System... + + -- This is a bit odd but works fine. If the RTS unit does not depend + -- in any way on the current unit, then it never gets back into the + -- current unit's tree, and the change we make to the current unit + -- tree is never noticed by anyone (it is undone in a moment). That + -- is the normal situation. + + -- If the RTS Unit *does* depend on the current unit, for instance, + -- when you are compiling System, then you had better have finished + -- Analyzing the part of System that is depended on before you try + -- to load the RTS Unit. This means having the System ordered in an + -- appropriate manner. + + Set_Analyzed (Cunit (Current_Sem_Unit), True); + + if not Analyzed (Cunit (U.Unum)) then + + Save_Private_Visibility; + Semantics (Cunit (U.Unum)); + Restore_Private_Visibility; + + if Fatal_Error (U.Unum) then + Load_Fail ("semantic errors", U_Id); + end if; + end if; + + -- Undo the pretence + + Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed); + end; + + Lib_Unit := Unit (Cunit (U.Unum)); + U.Entity := Defining_Entity (Lib_Unit); + + if Use_Setting then + Set_Is_Potentially_Use_Visible (U.Entity, True); + end if; + end Load_RTU; + + -------------- + -- RE_Chars -- + -------------- + + function RE_Chars (E : RE_Id) return Name_Id is + RE_Name_Chars : constant String := RE_Id'Image (E); + + begin + -- Copy name skipping initial RE_ or RO_XX characters + + if RE_Name_Chars (1 .. 2) = "RE" then + for J in 4 .. RE_Name_Chars'Last loop + Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J)); + end loop; + + Name_Len := RE_Name_Chars'Length - 3; + + else + for J in 7 .. RE_Name_Chars'Last loop + Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J)); + end loop; + + Name_Len := RE_Name_Chars'Length - 6; + end if; + + return Name_Find; + end RE_Chars; + + --------- + -- RTE -- + --------- + + function RTE (E : RE_Id) return Entity_Id is + U_Id : constant RTU_Id := RE_Unit_Table (E); + U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); + + Ent : Entity_Id; + Lib_Unit : Node_Id; + Pkg_Ent : Entity_Id; + Ename : Name_Id; + Enode : Node_Id; + + procedure Check_RPC; + -- Reject programs that make use of distribution features not supported + -- on the current target. On such targets (VMS, Vxworks, others?) we + -- only provide a minimal body for System.Rpc that only supplies an + -- implementation of partition_id. + + function Find_Local_Entity (E : RE_Id) return Entity_Id; + -- This function is used when entity E is in this compilation's main + -- unit. It gets the value from the already compiled declaration. + + function Make_Unit_Name (N : Node_Id) return Node_Id; + -- If the unit is a child unit, build fully qualified name for use + -- in with_clause. + + --------------- + -- Check_RPC -- + --------------- + + procedure Check_RPC is + Body_Name : Unit_Name_Type; + Unum : Unit_Number_Type; + + begin + -- Bypass this check if debug flag -gnatdR set + + if Debug_Flag_RR then + return; + end if; + + -- Otherwise we need the check if we are going after one of + -- the critical entities in System.RPC in stubs mode. + + if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body + or else + Distribution_Stub_Mode = Generate_Caller_Stub_Body) + and then (E = RE_Do_Rpc + or else E = RE_Do_Apc + or else E = RE_Params_Stream_Type + or else E = RE_RPC_Receiver) + then + -- Load body of System.Rpc, and abort if this is the body that is + -- provided by GNAT, for which these features are not supported + -- on current target. We identify the gnat body by the presence + -- of a local entity called Gnat in the first declaration. + + Lib_Unit := Unit (Cunit (U.Unum)); + Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit)); + Unum := + Load_Unit + (Load_Name => Body_Name, + Required => False, + Subunit => False, + Error_Node => Empty, + Renamings => True); + + if Unum /= No_Unit then + declare + Decls : List_Id := Declarations (Unit (Cunit (Unum))); + + begin + if Present (Decls) + and then Nkind (First (Decls)) = N_Object_Declaration + and then + Chars (Defining_Identifier (First (Decls))) = Name_Gnat + then + Set_Standard_Error; + Write_Str ("distribution feature not supported"); + Write_Eol; + raise Unrecoverable_Error; + end if; + end; + end if; + end if; + end Check_RPC; + + ------------------------ + -- Find_System_Entity -- + ------------------------ + + function Find_Local_Entity (E : RE_Id) return Entity_Id is + RE_Str : String renames RE_Id'Image (E); + Ent : Entity_Id; + + Save_Nam : constant String := Name_Buffer (1 .. Name_Len); + -- Save name buffer and length over call + + begin + Name_Len := Natural'Max (0, RE_Str'Length - 3); + Name_Buffer (1 .. Name_Len) := + RE_Str (RE_Str'First + 3 .. RE_Str'Last); + + Ent := Entity_Id (Get_Name_Table_Info (Name_Find)); + + Name_Len := Save_Nam'Length; + Name_Buffer (1 .. Name_Len) := Save_Nam; + + return Ent; + end Find_Local_Entity; + + -------------------- + -- Make_Unit_Name -- + -------------------- + + function Make_Unit_Name (N : Node_Id) return Node_Id is + Nam : Node_Id; + Scop : Entity_Id; + + begin + Nam := New_Reference_To (U.Entity, Standard_Location); + Scop := Scope (U.Entity); + + if Nkind (N) = N_Defining_Program_Unit_Name then + while Scop /= Standard_Standard loop + Nam := + Make_Expanded_Name (Standard_Location, + Chars => Chars (U.Entity), + Prefix => New_Reference_To (Scop, Standard_Location), + Selector_Name => Nam); + Set_Entity (Nam, U.Entity); + + Scop := Scope (Scop); + end loop; + end if; + + return Nam; + end Make_Unit_Name; + + -- Start of processing for RTE + + begin + -- Doing a rtsfind in system.ads is special, as we cannot do this + -- when compiling System itself. So if we are compiling system then + -- we should already have acquired and processed the declaration + -- of the entity. The test is to see if this compilation's main unit + -- is System. If so, return the value from the already compiled + -- declaration and otherwise do a regular find. + + -- Not pleasant, but these kinds of annoying recursion when + -- writing an Ada compiler in Ada have to be broken somewhere! + + if Present (Main_Unit_Entity) + and then Chars (Main_Unit_Entity) = Name_System + and then Analyzed (Main_Unit_Entity) + and then not Is_Child_Unit (Main_Unit_Entity) + then + return Find_Local_Entity (E); + end if; + + Enode := Current_Error_Node; + + -- Load unit if unit not previously loaded + + if No (RE_Table (E)) then + Load_RTU (U_Id); + Lib_Unit := Unit (Cunit (U.Unum)); + + -- In the subprogram case, we are all done, the entity we want + -- is the entity for the subprogram itself. Note that we do not + -- bother to check that it is the entity that was requested. + -- the only way that could fail to be the case is if runtime is + -- hopelessly misconfigured, and it isn't worth testing for this. + + if Nkind (Lib_Unit) = N_Subprogram_Declaration then + RE_Table (E) := U.Entity; + + -- Otherwise we must have the package case, and here we have to + -- search the package entity chain for the entity we want. The + -- entity we want must be present in this chain, or we have a + -- misconfigured runtime. + + else + pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); + Ename := RE_Chars (E); + + Pkg_Ent := First_Entity (U.Entity); + + while Present (Pkg_Ent) loop + if Ename = Chars (Pkg_Ent) then + RE_Table (E) := Pkg_Ent; + Check_RPC; + goto Found; + end if; + + Next_Entity (Pkg_Ent); + end loop; + + -- If we didn't find the unit we want, something is wrong! + + Load_Fail ("entity not in package", U_Id, RE_Id'Image (E)); + raise Program_Error; + end if; + end if; + + -- See if we have to generate a with for this entity. We generate + -- a with if the current unit is part of the extended main code + -- unit, and if we have not already added the with. The with is + -- added to the appropriate unit (the current one). + + <<Found>> + if (not U.Withed) + and then + In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit)) + then + U.Withed := True; + + declare + Withn : Node_Id; + Lib_Unit : Node_Id; + + begin + Lib_Unit := Unit (Cunit (U.Unum)); + Withn := + Make_With_Clause (Standard_Location, + Name => + Make_Unit_Name + (Defining_Unit_Name (Specification (Lib_Unit)))); + Set_Library_Unit (Withn, Cunit (U.Unum)); + Set_Corresponding_Spec (Withn, U.Entity); + Set_First_Name (Withn, True); + Set_Implicit_With (Withn, True); + + Mark_Rewrite_Insertion (Withn); + Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); + end; + end if; + + -- We can now obtain the entity. Check that the No_Run_Time condition + -- is not violated. Note that we do not signal the error if we detect + -- it in a runtime unit. This can only arise if the user explicitly + -- with'ed the runtime unit (or another runtime unit that uses it + -- transitively), or if some acceptable (e.g. inlined) entity is + -- fetched from a unit, some of whose other routines or entities + -- violate the conditions. In the latter case, it does not matter, + -- since we won't be using those entities. + + Ent := RE_Table (E); + + if Is_Subprogram (Ent) + and then not Is_Inlined (Ent) + and then Sloc (Enode) /= Standard_Location + and then not + Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Enode))) + then + Disallow_In_No_Run_Time_Mode (Enode); + end if; + + return Ent; + end RTE; + + -------------------- + -- Text_IO_Kludge -- + -------------------- + + procedure Text_IO_Kludge (Nam : Node_Id) is + Chrs : Name_Id; + + type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id; + + Name_Map : Name_Map_Type := Name_Map_Type'( + Name_Decimal_IO => Ada_Text_IO_Decimal_IO, + Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO, + Name_Fixed_IO => Ada_Text_IO_Fixed_IO, + Name_Float_IO => Ada_Text_IO_Float_IO, + Name_Integer_IO => Ada_Text_IO_Integer_IO, + Name_Modular_IO => Ada_Text_IO_Modular_IO); + + Wide_Name_Map : Name_Map_Type := Name_Map_Type'( + Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO, + Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO, + Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO, + Name_Float_IO => Ada_Wide_Text_IO_Float_IO, + Name_Integer_IO => Ada_Wide_Text_IO_Integer_IO, + Name_Modular_IO => Ada_Wide_Text_IO_Modular_IO); + + begin + -- Nothing to do if name is not identifier or a selected component + -- whose selector_name is not an identifier. + + if Nkind (Nam) = N_Identifier then + Chrs := Chars (Nam); + + elsif Nkind (Nam) = N_Selected_Component + and then Nkind (Selector_Name (Nam)) = N_Identifier + then + Chrs := Chars (Selector_Name (Nam)); + + else + return; + end if; + + -- Nothing to do if name is not one of the Text_IO subpackages + -- Otherwise look through loaded units, and if we find Text_IO + -- or Wide_Text_IO already loaded, then load the proper child. + + if Chrs in Text_IO_Package_Name then + for U in Main_Unit .. Last_Unit loop + Get_Name_String (Unit_File_Name (U)); + + if Name_Len = 12 then + + -- Here is where we do the loads if we find one of the + -- units Ada.Text_IO or Ada.Wide_Text_IO. An interesting + -- detail is that these units may already be used (i.e. + -- their In_Use flags may be set). Normally when the In_Use + -- flag is set, the Is_Potentially_Use_Visible flag of all + -- entities in the package is set, but the new entity we + -- are mysteriously adding was not there to have its flag + -- set at the time. So that's why we pass the extra parameter + -- to RTU_Find, to make sure the flag does get set now. + -- Given that those generic packages are in fact child units, + -- we must indicate that they are visible. + + if Name_Buffer (1 .. 12) = "a-textio.ads" then + Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U))); + Set_Is_Visible_Child_Unit + (RT_Unit_Table (Name_Map (Chrs)).Entity); + + elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then + Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U))); + Set_Is_Visible_Child_Unit + (RT_Unit_Table (Wide_Name_Map (Chrs)).Entity); + end if; + end if; + end loop; + end if; + end Text_IO_Kludge; + +end Rtsfind; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads new file mode 100644 index 00000000000..11304f625a8 --- /dev/null +++ b/gcc/ada/rtsfind.ads @@ -0,0 +1,2324 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R T S F I N D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.216 $ +-- -- +-- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Rtsfind is + +-- This package contains the routine that is used to obtain runtime library +-- entities, loading in the required runtime library packages on demand. It +-- is also used for such purposes as finding System.Address when System has +-- not been explicitly With'ed. + + ------------------------ + -- Runtime Unit Table -- + ------------------------ + + -- The following type includes an enumeration entry for each runtime + -- unit. The enumeration literal represents the fully qualified + -- name of the unit, as follows: + + -- Names of the form Ada_xxx are first level children of Ada, whose + -- name is Ada.xxx. For example, the name Ada_Tags refers to package + -- Ada.Tags. + + -- Names of the form Ada_Calendar_xxx are second level children + -- of Ada.Calendar. This is part of a temporary implementation of + -- delays; eventually, packages implementing delays will be found + -- relative to the package that declares the time type. + + -- Names of the form Interfaces_xxx are first level children of + -- Interfaces_CPP refers to package Interfaces.CPP + + -- Names of the form System_xxx are first level children of System, whose + -- name is System.xxx. For example, the name System_Str_Concat refers to + -- package System.Str_Concat. + + -- Names of the form System_Tasking_xxx are second level children of the + -- package System.Tasking. For example, System_Tasking_Stages refers to + -- refers to the package System.Tasking.Stages. + + -- Other names stand for themselves (e.g. System for package System) + + -- This list can contain both subprogram and package unit names. For + -- packages, the accessible entities in the package are separately + -- listed in the package entity table. The units must be either library + -- level package declarations, or library level subprogram declarations. + -- Generic units, library level instantiations and subprogram bodies + -- acting as specs may not be referenced (all these cases could be added + -- at the expense of additional complexity in the body of Rtsfind, but + -- it doesn't seem worth while, since the implementation controls the + -- set of units that are referenced, and this restrictions is easily met. + + -- IMPORTANT NOTE: the specs of packages and procedures with'ed using + -- this mechanism may not contain use clauses. This is because these + -- subprograms are compiled in the current visibility environment, and + -- it would be too much trouble to establish a clean environment for the + -- compilation. The presence of extraneous visible stuff has no effect + -- on the compilation except in the presence of use clauses (which might + -- result in unexpected ambiguities). + + type RTU_Id is ( + -- Runtime packages, for list of accessible entities in each + -- package see declarations in the runtime entity table below. + + RTU_Null, + -- Used as a null entry. Will cause an error if referenced. + + -- Children of Ada + + Ada_Calendar, + Ada_Exceptions, + Ada_Finalization, + Ada_Interrupts, + Ada_Real_Time, + Ada_Streams, + Ada_Tags, + Ada_Task_Identification, + + -- Children of Ada.Calendar + + Ada_Calendar_Delays, + + -- Children of Ada.Finalization + + Ada_Finalization_List_Controller, + + -- Children of Ada.Real_Time + + Ada_Real_Time_Delays, + + -- Children of Ada.Streams + + Ada_Streams_Stream_IO, + + -- Children of Ada.Text_IO (for Text_IO_Kludge) + + Ada_Text_IO_Decimal_IO, + Ada_Text_IO_Enumeration_IO, + Ada_Text_IO_Fixed_IO, + Ada_Text_IO_Float_IO, + Ada_Text_IO_Integer_IO, + Ada_Text_IO_Modular_IO, + + -- Children of Ada.Wide_Text_IO (for Text_IO_Kludge) + + Ada_Wide_Text_IO_Decimal_IO, + Ada_Wide_Text_IO_Enumeration_IO, + Ada_Wide_Text_IO_Fixed_IO, + Ada_Wide_Text_IO_Float_IO, + Ada_Wide_Text_IO_Integer_IO, + Ada_Wide_Text_IO_Modular_IO, + + -- Interfaces + + Interfaces, + + -- Children of Interfaces + + Interfaces_CPP, + Interfaces_Packed_Decimal, + + -- Package System + + System, + + -- Children of System + + System_Arith_64, + System_AST_Handling, + System_Assertions, + System_Aux_DEC, + System_Bit_Ops, + System_Checked_Pools, + System_Exception_Table, + System_Exceptions, + System_Delay_Operations, + System_Exn_Flt, + System_Exn_Int, + System_Exn_LFlt, + System_Exn_LInt, + System_Exn_LLF, + System_Exn_LLI, + System_Exn_SFlt, + System_Exn_SInt, + System_Exn_SSI, + System_Exp_Flt, + System_Exp_Int, + System_Exp_LFlt, + System_Exp_LInt, + System_Exp_LLF, + System_Exp_LLI, + System_Exp_LLU, + System_Exp_Mod, + System_Exp_SFlt, + System_Exp_SInt, + System_Exp_SSI, + System_Exp_Uns, + System_Fat_Flt, + System_Fat_LFlt, + System_Fat_LLF, + System_Fat_SFlt, + System_Finalization_Implementation, + System_Finalization_Root, + System_Fore, + System_Img_Bool, + System_Img_Char, + System_Img_Dec, + System_Img_Enum, + System_Img_Int, + System_Img_LLD, + System_Img_LLI, + System_Img_LLU, + System_Img_Name, + System_Img_Real, + System_Img_Uns, + System_Img_WChar, + System_Interrupts, + System_Machine_Code, + System_Mantissa, + System_Pack_03, + System_Pack_05, + System_Pack_06, + System_Pack_07, + System_Pack_09, + System_Pack_10, + System_Pack_11, + System_Pack_12, + System_Pack_13, + System_Pack_14, + System_Pack_15, + System_Pack_17, + System_Pack_18, + System_Pack_19, + System_Pack_20, + System_Pack_21, + System_Pack_22, + System_Pack_23, + System_Pack_24, + System_Pack_25, + System_Pack_26, + System_Pack_27, + System_Pack_28, + System_Pack_29, + System_Pack_30, + System_Pack_31, + System_Pack_33, + System_Pack_34, + System_Pack_35, + System_Pack_36, + System_Pack_37, + System_Pack_38, + System_Pack_39, + System_Pack_40, + System_Pack_41, + System_Pack_42, + System_Pack_43, + System_Pack_44, + System_Pack_45, + System_Pack_46, + System_Pack_47, + System_Pack_48, + System_Pack_49, + System_Pack_50, + System_Pack_51, + System_Pack_52, + System_Pack_53, + System_Pack_54, + System_Pack_55, + System_Pack_56, + System_Pack_57, + System_Pack_58, + System_Pack_59, + System_Pack_60, + System_Pack_61, + System_Pack_62, + System_Pack_63, + System_Parameters, + System_Partition_Interface, + System_Pool_Global, + System_Pool_Empty, + System_Pool_Local, + System_Pool_Size, + System_RPC, + System_Scalar_Values, + System_Secondary_Stack, + System_Shared_Storage, + System_Soft_Links, + System_Standard_Library, + System_Storage_Elements, + System_Storage_Pools, + System_Stream_Attributes, + System_String_Ops, + System_String_Ops_Concat_3, + System_String_Ops_Concat_4, + System_String_Ops_Concat_5, + System_Task_Info, + System_Tasking, + System_Unsigned_Types, + System_Val_Bool, + System_Val_Char, + System_Val_Dec, + System_Val_Enum, + System_Val_Int, + System_Val_LLD, + System_Val_LLI, + System_Val_LLU, + System_Val_Name, + System_Val_Real, + System_Val_Uns, + System_Val_WChar, + System_Vax_Float_Operations, + System_Version_Control, + System_VMS_Exception_Table, + System_WCh_StW, + System_WCh_WtS, + System_Wid_Bool, + System_Wid_Char, + System_Wid_Enum, + System_Wid_LLI, + System_Wid_LLU, + System_Wid_Name, + System_Wid_WChar, + System_WWd_Char, + System_WWd_Enum, + System_WWd_Wchar, + + -- Children of System.Tasking + + System_Tasking_Async_Delays, + System_Tasking_Async_Delays_Enqueue_Calendar, + System_Tasking_Async_Delays_Enqueue_RT, + System_Tasking_Protected_Objects, + System_Tasking_Protected_Objects_Entries, + System_Tasking_Protected_Objects_Operations, + System_Tasking_Protected_Objects_Single_Entry, + System_Tasking_Restricted_Stages, + System_Tasking_Rendezvous, + System_Tasking_Stages); + + subtype Ada_Child is RTU_Id + range Ada_Calendar .. Ada_Wide_Text_IO_Modular_IO; + -- Range of values for children or grand-children of Ada + + subtype Ada_Calendar_Child is Ada_Child + range Ada_Calendar_Delays .. Ada_Calendar_Delays; + -- Range of values for children of Ada.Calendar + + subtype Ada_Finalization_Child is Ada_Child range + Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller; + -- Range of values for children of Ada.Finalization + + subtype Ada_Real_Time_Child is Ada_Child + range Ada_Real_Time_Delays .. Ada_Real_Time_Delays; + -- Range of values for children of Ada.Real_Time + + subtype Ada_Streams_Child is Ada_Child + range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO; + + subtype Ada_Text_IO_Child is Ada_Child + range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; + -- Range of values for children of Ada.Text_IO + + subtype Ada_Wide_Text_IO_Child is Ada_Child + range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO; + -- Range of values for children of Ada.Text_IO + + subtype Interfaces_Child is RTU_Id + range Interfaces_CPP .. Interfaces_Packed_Decimal; + -- Range of values for children of Interfaces + + subtype System_Child is RTU_Id + range System_Arith_64 .. System_Tasking_Stages; + -- Range of values for children or grandchildren of System + + subtype System_Tasking_Child is System_Child + range System_Tasking_Async_Delays .. System_Tasking_Stages; + -- Range of values for children of System.Tasking + + subtype System_Tasking_Protected_Objects_Child is System_Tasking_Child + range System_Tasking_Protected_Objects_Entries .. + System_Tasking_Protected_Objects_Single_Entry; + -- Range of values for children of System.Tasking.Protected_Objects + + subtype System_Tasking_Restricted_Child is System_Tasking_Child + range System_Tasking_Restricted_Stages .. + System_Tasking_Restricted_Stages; + -- Range of values for children of System.Tasking.Restricted + + subtype System_Tasking_Async_Delays_Child is System_Tasking_Child + range System_Tasking_Async_Delays_Enqueue_Calendar .. + System_Tasking_Async_Delays_Enqueue_RT; + -- Range of values for children of System.Tasking.Async_Delays + + -------------------------- + -- Runtime Entity Table -- + -------------------------- + + -- This is the enumeration type used to define the argument passed to + -- the RTE function. The name must exactly match the name of the entity + -- involved, and in the case of a package entity, this name must uniquely + -- imply the package containing the entity. + + -- As far as possible, we avoid duplicate names in runtime packages, so + -- that the name RE_nnn uniquely identifies the entity nnn. In some cases, + -- it is impossible to avoid such duplication because the names come from + -- RM defined packages. In such cases, the name is of the form RO_XX_nnn + -- where XX is two letters used to differentiate the multiple occurrences + -- of the name xx, and nnn is the entity name. + + -- Note that not all entities in the units contained in the run-time unit + -- table are included in the following table, only those that actually + -- have to be referenced from generated code. + + -- Note on RE_Null. This value is used as a null entry where an RE_Id + -- value is required syntactically, but no real entry is required or + -- needed. Use of this value will cause a fatal error in an RTE call. + + type RE_Id is ( + + RE_Null, + + RE_Code_Loc, -- Ada.Exceptions + RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only) + RE_Exception_Id, -- Ada.Exceptions + RE_Exception_Information, -- Ada.Exceptions + RE_Exception_Message, -- Ada.Exceptions + RE_Exception_Name_Simple, -- Ada.Exceptions + RE_Exception_Occurrence, -- Ada.Exceptions + RE_Null_Id, -- Ada.Exceptions + RE_Null_Occurrence, -- Ada.Exceptions + RE_Poll, -- Ada.Exceptions + RE_Raise_Exception, -- Ada.Exceptions + RE_Raise_Exception_Always, -- Ada.Exceptions + RE_Reraise_Occurrence, -- Ada.Exceptions + RE_Reraise_Occurrence_Always, -- Ada.Exceptions + RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions + RE_Save_Occurrence, -- Ada.Exceptions + + RE_Simple_List_Controller, -- Ada.Finalization.List_Controller + RE_List_Controller, -- Ada.Finalization.List_Controller + + RE_Interrupt_Id, -- Ada.Interrupts + + RE_Root_Stream_Type, -- Ada.Streams + RE_Stream_Element, -- Ada.Streams + RE_Stream_Element_Offset, -- Ada.Streams + RE_Stream_Element_Array, -- Ada.Streams + + RE_Stream_Access, -- Ada.Streams.Stream_IO + + RE_CW_Membership, -- Ada.Tags + RE_DT_Entry_Size, -- Ada.Tags + RE_DT_Prologue_Size, -- Ada.Tags + RE_External_Tag, -- Ada.Tags + RE_Get_Expanded_Name, -- Ada.Tags + RE_Get_External_Tag, -- Ada.Tags + RE_Get_Prim_Op_Address, -- Ada.Tags + RE_Get_RC_Offset, -- Ada.Tags + RE_Get_Remotely_Callable, -- Ada.Tags + RE_Get_TSD, -- Ada.Tags + RE_Inherit_DT, -- Ada.Tags + RE_Inherit_TSD, -- Ada.Tags + RE_Internal_Tag, -- Ada.Tags + RE_Register_Tag, -- Ada.Tags + RE_Set_Expanded_Name, -- Ada.Tags + RE_Set_External_Tag, -- Ada.Tags + RE_Set_Prim_Op_Address, -- Ada.Tags + RE_Set_RC_Offset, -- Ada.Tags + RE_Set_Remotely_Callable, -- Ada.Tags + RE_Set_TSD, -- Ada.Tags + RE_Tag_Error, -- Ada.Tags + RE_TSD_Entry_Size, -- Ada.Tags + RE_TSD_Prologue_Size, -- Ada.Tags + RE_Tag, -- Ada.Tags + RE_Address_Array, -- Ada.Tags + + RE_Current_Task, -- Ada.Task_Identification + RO_AT_Task_ID, -- Ada.Task_Identification + + RO_CA_Time, -- Ada.Calendar + + RO_CA_Delay_For, -- Ada.Calendar.Delays + RO_CA_Delay_Until, -- Ada.Calendar.Delays + RO_CA_To_Duration, -- Ada.Calendar.Delays + + RO_RT_Time, -- Ada.Real_Time + + RO_RT_Delay_Until, -- Ada.Real_Time.Delays + RO_RT_To_Duration, -- Ada.Real_Time.Delays + + RE_Integer_64, -- Interfaces + RE_Unsigned_8, -- Interfaces + RE_Unsigned_16, -- Interfaces + RE_Unsigned_32, -- Interfaces + RE_Unsigned_64, -- Interfaces + + RE_Vtable_Ptr, -- Interfaces.CPP + RE_Displaced_This, -- Interfaces.CPP + RE_CPP_CW_Membership, -- Interfaces.CPP + RE_CPP_DT_Entry_Size, -- Interfaces.CPP + RE_CPP_DT_Prologue_Size, -- Interfaces.CPP + RE_CPP_Get_Expanded_Name, -- Interfaces.CPP + RE_CPP_Get_External_Tag, -- Interfaces.CPP + RE_CPP_Get_Prim_Op_Address, -- Interfaces.CPP + RE_CPP_Get_RC_Offset, -- Interfaces.CPP + RE_CPP_Get_Remotely_Callable, -- Interfaces.CPP + RE_CPP_Get_TSD, -- Interfaces.CPP + RE_CPP_Inherit_DT, -- Interfaces.CPP + RE_CPP_Inherit_TSD, -- Interfaces.CPP + RE_CPP_Register_Tag, -- Interfaces.CPP + RE_CPP_Set_Expanded_Name, -- Interfaces.CPP + RE_CPP_Set_External_Tag, -- Interfaces.CPP + RE_CPP_Set_Prim_Op_Address, -- Interfaces.CPP + RE_CPP_Set_RC_Offset, -- Interfaces.CPP + RE_CPP_Set_Remotely_Callable, -- Interfaces.CPP + RE_CPP_Set_TSD, -- Interfaces.CPP + RE_CPP_TSD_Entry_Size, -- Interfaces.CPP + RE_CPP_TSD_Prologue_Size, -- Interfaces.CPP + + RE_Packed_Size, -- Interfaces.Packed_Decimal + RE_Packed_To_Int32, -- Interfaces.Packed_Decimal + RE_Packed_To_Int64, -- Interfaces.Packed_Decimal + RE_Int32_To_Packed, -- Interfaces.Packed_Decimal + RE_Int64_To_Packed, -- Interfaces.Packed_Decimal + + RE_Address, -- System + RE_Any_Priority, -- System + RE_Bit_Order, -- System + RE_Default_Priority, -- System + RE_High_Order_First, -- System + RE_Interrupt_Priority, -- System + RE_Lib_Stop, -- System + RE_Low_Order_First, -- System + RE_Max_Interrupt_Priority, -- System + RE_Max_Priority, -- System + RE_Null_Address, -- System + RE_Priority, -- System + + RE_Add_With_Ovflo_Check, -- System.Arith_64 + RE_Double_Divide, -- System.Arith_64 + RE_Multiply_With_Ovflo_Check, -- System.Arith_64 + RE_Scaled_Divide, -- System.Arith_64 + RE_Subtract_With_Ovflo_Check, -- System.Arith_64 + + RE_Create_AST_Handler, -- System.AST_Handling + + RE_Raise_Assert_Failure, -- System.Assertions + + RE_AST_Handler, -- System.Aux_DEC + RE_Import_Value, -- System.Aux_DEC + RE_No_AST_Handler, -- System.Aux_DEC + RE_Type_Class, -- System.Aux_DEC + RE_Type_Class_Enumeration, -- System.Aux_DEC + RE_Type_Class_Integer, -- System.Aux_DEC + RE_Type_Class_Fixed_Point, -- System.Aux_DEC + RE_Type_Class_Floating_Point, -- System.Aux_DEC + RE_Type_Class_Array, -- System.Aux_DEC + RE_Type_Class_Record, -- System.Aux_DEC + RE_Type_Class_Access, -- System.Aux_DEC + RE_Type_Class_Task, -- System.Aux_DEC + RE_Type_Class_Address, -- System.Aux_DEC + + RE_Bit_And, -- System.Bit_Ops + RE_Bit_Eq, -- System.Bit_Ops + RE_Bit_Not, -- System.Bit_Ops + RE_Bit_Or, -- System.Bit_Ops + RE_Bit_Xor, -- System.Bit_Ops + + RE_Checked_Pool, -- System.Checked_Pools + + RE_Register_Exception, -- System.Exception_Table + + RE_All_Others_Id, -- System.Exceptions + RE_Handler_Record, -- System.Exceptions + RE_Handler_Record_Ptr, -- System.Exceptions + RE_Others_Id, -- System.Exceptions + RE_Subprogram_Descriptor, -- System.Exceptions + RE_Subprogram_Descriptor_0, -- System.Exceptions + RE_Subprogram_Descriptor_1, -- System.Exceptions + RE_Subprogram_Descriptor_2, -- System.Exceptions + RE_Subprogram_Descriptor_3, -- System.Exceptions + RE_Subprogram_Descriptor_List, -- System.Exceptions + RE_Subprogram_Descriptor_Ptr, -- System.Exceptions + RE_Subprogram_Descriptors_Record, -- System.Exceptions + RE_Subprogram_Descriptors_Ptr, -- System.Exceptions + + RE_Exn_Float, -- System.Exn_Flt + + RE_Exn_Integer, -- System.Exn_Int + + RE_Exn_Long_Float, -- System.Exn_LFlt + + RE_Exn_Long_Integer, -- System.Exn_LInt + + RE_Exn_Long_Long_Float, -- System.Exn_LLF + + RE_Exn_Long_Long_Integer, -- System.Exn_LLI + + RE_Exn_Short_Float, -- System.Exn_SFlt + + RE_Exn_Short_Integer, -- System.Exn_SInt + + RE_Exn_Short_Short_Integer, -- System.Exn_SSI + + RE_Exp_Float, -- System.Exp_Flt + + RE_Exp_Integer, -- System.Exp_Int + + RE_Exp_Long_Float, -- System.Exp_LFlt + + RE_Exp_Long_Integer, -- System.Exp_LInt + + RE_Exp_Long_Long_Float, -- System.Exp_LLF + + RE_Exp_Long_Long_Integer, -- System.Exp_LLI + + RE_Exp_Long_Long_Unsigned, -- System.Exp_LLU + + RE_Exp_Modular, -- System.Exp_Mod + + RE_Exp_Short_Float, -- System.Exp_SFlt + + RE_Exp_Short_Integer, -- System.Exp_SInt + + RE_Exp_Short_Short_Integer, -- System.Exp_SSI + + RE_Exp_Unsigned, -- System.Exp_Uns + + RE_Fat_Float, -- System.Fat_Flt + + RE_Fat_Long_Float, -- System.Fat_LFlt + + RE_Fat_Long_Long_Float, -- System.Fat_LLF + + RE_Fat_Short_Float, -- System.Fat_SFlt + + RE_Attach_To_Final_List, -- System.Finalization_Implementation + RE_Finalize_List, -- System.Finalization_Implementation + RE_Finalize_One, -- System.Finalization_Implementation + RE_Global_Final_List, -- System.Finalization_Implementation + RE_Record_Controller, -- System.Finalization_Implementation + RE_Limited_Record_Controller, -- System.Finalization_Implementation + RE_Deep_Tag_Initialize, -- System.Finalization_Implementation + RE_Deep_Tag_Adjust, -- System.Finalization_Implementation + RE_Deep_Tag_Finalize, -- System.Finalization_Implementation + RE_Deep_Tag_Attach, -- System.Finalization_Implementation + RE_Deep_Rec_Initialize, -- System.Finalization_Implementation + RE_Deep_Rec_Adjust, -- System.Finalization_Implementation + RE_Deep_Rec_Finalize, -- System.Finalization_Implementation + + RE_Root_Controlled, -- System.Finalization_Root + RE_Finalizable, -- System.Finalization_Root + RE_Finalizable_Ptr, -- System.Finalization_Root + + RE_Fore, -- System.Fore + + RE_Image_Boolean, -- System.Img_Bool + + RE_Image_Character, -- System.Img_Char + + RE_Image_Decimal, -- System.Img_Dec + + RE_Image_Enumeration_8, -- System.Img_Enum + RE_Image_Enumeration_16, -- System.Img_Enum + RE_Image_Enumeration_32, -- System.Img_Enum + + RE_Image_Integer, -- System.Img_Int + + RE_Image_Long_Long_Decimal, -- System.Img_LLD + + RE_Image_Long_Long_Integer, -- System.Img_LLI + + RE_Image_Long_Long_Unsigned, -- System.Img_LLU + + RE_Image_Ordinary_Fixed_Point, -- System.Img_Real + RE_Image_Floating_Point, -- System.Img_Real + + RE_Image_Unsigned, -- System.Img_Uns + + RE_Image_Wide_Character, -- System.Img_WChar + + RE_Bind_Interrupt_To_Entry, -- System.Interrupts + RE_Default_Interrupt_Priority, -- System.Interrupts + RE_Dynamic_Interrupt_Protection, -- System.Interrupts + RE_Install_Handlers, -- System.Interrupts + RE_Register_Interrupt_Handler, -- System.Interrupts + RE_Static_Interrupt_Protection, -- System.Interrupts + + RE_Asm_Insn, -- System.Machine_Code + RE_Asm_Input_Operand, -- System.Machine_Code + RE_Asm_Output_Operand, -- System.Machine_Code + + RE_Mantissa_Value, -- System_Mantissa + + RE_Bits_03, -- System.Pack_03 + RE_Get_03, -- System.Pack_03 + RE_Set_03, -- System.Pack_03 + + RE_Bits_05, -- System.Pack_05 + RE_Get_05, -- System.Pack_05 + RE_Set_05, -- System.Pack_05 + + RE_Bits_06, -- System.Pack_06 + RE_Get_06, -- System.Pack_06 + RE_GetU_06, -- System.Pack_06 + RE_Set_06, -- System.Pack_06 + RE_SetU_06, -- System.Pack_06 + + RE_Bits_07, -- System.Pack_07 + RE_Get_07, -- System.Pack_07 + RE_Set_07, -- System.Pack_07 + + RE_Bits_09, -- System.Pack_09 + RE_Get_09, -- System.Pack_09 + RE_Set_09, -- System.Pack_09 + + RE_Bits_10, -- System.Pack_10 + RE_Get_10, -- System.Pack_10 + RE_GetU_10, -- System.Pack_10 + RE_Set_10, -- System.Pack_10 + RE_SetU_10, -- System.Pack_10 + + RE_Bits_11, -- System.Pack_11 + RE_Get_11, -- System.Pack_11 + RE_Set_11, -- System.Pack_11 + + RE_Bits_12, -- System.Pack_12 + RE_Get_12, -- System.Pack_12 + RE_GetU_12, -- System.Pack_12 + RE_Set_12, -- System.Pack_12 + RE_SetU_12, -- System.Pack_12 + + RE_Bits_13, -- System.Pack_13 + RE_Get_13, -- System.Pack_13 + RE_Set_13, -- System.Pack_13 + + RE_Bits_14, -- System.Pack_14 + RE_Get_14, -- System.Pack_14 + RE_GetU_14, -- System.Pack_14 + RE_Set_14, -- System.Pack_14 + RE_SetU_14, -- System.Pack_14 + + RE_Bits_15, -- System.Pack_15 + RE_Get_15, -- System.Pack_15 + RE_Set_15, -- System.Pack_15 + + RE_Bits_17, -- System.Pack_17 + RE_Get_17, -- System.Pack_17 + RE_Set_17, -- System.Pack_17 + + RE_Bits_18, -- System.Pack_18 + RE_Get_18, -- System.Pack_18 + RE_GetU_18, -- System.Pack_18 + RE_Set_18, -- System.Pack_18 + RE_SetU_18, -- System.Pack_18 + + RE_Bits_19, -- System.Pack_19 + RE_Get_19, -- System.Pack_19 + RE_Set_19, -- System.Pack_19 + + RE_Bits_20, -- System.Pack_20 + RE_Get_20, -- System.Pack_20 + RE_GetU_20, -- System.Pack_20 + RE_Set_20, -- System.Pack_20 + RE_SetU_20, -- System.Pack_20 + + RE_Bits_21, -- System.Pack_21 + RE_Get_21, -- System.Pack_21 + RE_Set_21, -- System.Pack_21 + + RE_Bits_22, -- System.Pack_22 + RE_Get_22, -- System.Pack_22 + RE_GetU_22, -- System.Pack_22 + RE_Set_22, -- System.Pack_22 + RE_SetU_22, -- System.Pack_22 + + RE_Bits_23, -- System.Pack_23 + RE_Get_23, -- System.Pack_23 + RE_Set_23, -- System.Pack_23 + + RE_Bits_24, -- System.Pack_24 + RE_Get_24, -- System.Pack_24 + RE_GetU_24, -- System.Pack_24 + RE_Set_24, -- System.Pack_24 + RE_SetU_24, -- System.Pack_24 + + RE_Bits_25, -- System.Pack_25 + RE_Get_25, -- System.Pack_25 + RE_Set_25, -- System.Pack_25 + + RE_Bits_26, -- System.Pack_26 + RE_Get_26, -- System.Pack_26 + RE_GetU_26, -- System.Pack_26 + RE_Set_26, -- System.Pack_26 + RE_SetU_26, -- System.Pack_26 + + RE_Bits_27, -- System.Pack_27 + RE_Get_27, -- System.Pack_27 + RE_Set_27, -- System.Pack_27 + + RE_Bits_28, -- System.Pack_28 + RE_Get_28, -- System.Pack_28 + RE_GetU_28, -- System.Pack_28 + RE_Set_28, -- System.Pack_28 + RE_SetU_28, -- System.Pack_28 + + RE_Bits_29, -- System.Pack_29 + RE_Get_29, -- System.Pack_29 + RE_Set_29, -- System.Pack_29 + + RE_Bits_30, -- System.Pack_30 + RE_Get_30, -- System.Pack_30 + RE_GetU_30, -- System.Pack_30 + RE_Set_30, -- System.Pack_30 + RE_SetU_30, -- System.Pack_30 + + RE_Bits_31, -- System.Pack_31 + RE_Get_31, -- System.Pack_31 + RE_Set_31, -- System.Pack_31 + + RE_Bits_33, -- System.Pack_33 + RE_Get_33, -- System.Pack_33 + RE_Set_33, -- System.Pack_33 + + RE_Bits_34, -- System.Pack_34 + RE_Get_34, -- System.Pack_34 + RE_GetU_34, -- System.Pack_34 + RE_Set_34, -- System.Pack_34 + RE_SetU_34, -- System.Pack_34 + + RE_Bits_35, -- System.Pack_35 + RE_Get_35, -- System.Pack_35 + RE_Set_35, -- System.Pack_35 + + RE_Bits_36, -- System.Pack_36 + RE_Get_36, -- System.Pack_36 + RE_GetU_36, -- System.Pack_36 + RE_Set_36, -- System.Pack_36 + RE_SetU_36, -- System.Pack_36 + + RE_Bits_37, -- System.Pack_37 + RE_Get_37, -- System.Pack_37 + RE_Set_37, -- System.Pack_37 + + RE_Bits_38, -- System.Pack_38 + RE_Get_38, -- System.Pack_38 + RE_GetU_38, -- System.Pack_38 + RE_Set_38, -- System.Pack_38 + RE_SetU_38, -- System.Pack_38 + + RE_Bits_39, -- System.Pack_39 + RE_Get_39, -- System.Pack_39 + RE_Set_39, -- System.Pack_39 + + RE_Bits_40, -- System.Pack_40 + RE_Get_40, -- System.Pack_40 + RE_GetU_40, -- System.Pack_40 + RE_Set_40, -- System.Pack_40 + RE_SetU_40, -- System.Pack_40 + + RE_Bits_41, -- System.Pack_41 + RE_Get_41, -- System.Pack_41 + RE_Set_41, -- System.Pack_41 + + RE_Bits_42, -- System.Pack_42 + RE_Get_42, -- System.Pack_42 + RE_GetU_42, -- System.Pack_42 + RE_Set_42, -- System.Pack_42 + RE_SetU_42, -- System.Pack_42 + + RE_Bits_43, -- System.Pack_43 + RE_Get_43, -- System.Pack_43 + RE_Set_43, -- System.Pack_43 + + RE_Bits_44, -- System.Pack_44 + RE_Get_44, -- System.Pack_44 + RE_GetU_44, -- System.Pack_44 + RE_Set_44, -- System.Pack_44 + RE_SetU_44, -- System.Pack_44 + + RE_Bits_45, -- System.Pack_45 + RE_Get_45, -- System.Pack_45 + RE_Set_45, -- System.Pack_45 + + RE_Bits_46, -- System.Pack_46 + RE_Get_46, -- System.Pack_46 + RE_GetU_46, -- System.Pack_46 + RE_Set_46, -- System.Pack_46 + RE_SetU_46, -- System.Pack_46 + + RE_Bits_47, -- System.Pack_47 + RE_Get_47, -- System.Pack_47 + RE_Set_47, -- System.Pack_47 + + RE_Bits_48, -- System.Pack_48 + RE_Get_48, -- System.Pack_48 + RE_GetU_48, -- System.Pack_48 + RE_Set_48, -- System.Pack_48 + RE_SetU_48, -- System.Pack_48 + + RE_Bits_49, -- System.Pack_49 + RE_Get_49, -- System.Pack_49 + RE_Set_49, -- System.Pack_49 + + RE_Bits_50, -- System.Pack_50 + RE_Get_50, -- System.Pack_50 + RE_GetU_50, -- System.Pack_50 + RE_Set_50, -- System.Pack_50 + RE_SetU_50, -- System.Pack_50 + + RE_Bits_51, -- System.Pack_51 + RE_Get_51, -- System.Pack_51 + RE_Set_51, -- System.Pack_51 + + RE_Bits_52, -- System.Pack_52 + RE_Get_52, -- System.Pack_52 + RE_GetU_52, -- System.Pack_52 + RE_Set_52, -- System.Pack_52 + RE_SetU_52, -- System.Pack_52 + + RE_Bits_53, -- System.Pack_53 + RE_Get_53, -- System.Pack_53 + RE_Set_53, -- System.Pack_53 + + RE_Bits_54, -- System.Pack_54 + RE_Get_54, -- System.Pack_54 + RE_GetU_54, -- System.Pack_54 + RE_Set_54, -- System.Pack_54 + RE_SetU_54, -- System.Pack_54 + + RE_Bits_55, -- System.Pack_55 + RE_Get_55, -- System.Pack_55 + RE_Set_55, -- System.Pack_55 + + RE_Bits_56, -- System.Pack_56 + RE_Get_56, -- System.Pack_56 + RE_GetU_56, -- System.Pack_56 + RE_Set_56, -- System.Pack_56 + RE_SetU_56, -- System.Pack_56 + + RE_Bits_57, -- System.Pack_57 + RE_Get_57, -- System.Pack_57 + RE_Set_57, -- System.Pack_57 + + RE_Bits_58, -- System.Pack_58 + RE_Get_58, -- System.Pack_58 + RE_GetU_58, -- System.Pack_58 + RE_Set_58, -- System.Pack_58 + RE_SetU_58, -- System.Pack_58 + + RE_Bits_59, -- System.Pack_59 + RE_Get_59, -- System.Pack_59 + RE_Set_59, -- System.Pack_59 + + RE_Bits_60, -- System.Pack_60 + RE_Get_60, -- System.Pack_60 + RE_GetU_60, -- System.Pack_60 + RE_Set_60, -- System.Pack_60 + RE_SetU_60, -- System.Pack_60 + + RE_Bits_61, -- System.Pack_61 + RE_Get_61, -- System.Pack_61 + RE_Set_61, -- System.Pack_61 + + RE_Bits_62, -- System.Pack_62 + RE_Get_62, -- System.Pack_62 + RE_GetU_62, -- System.Pack_62 + RE_Set_62, -- System.Pack_62 + RE_SetU_62, -- System.Pack_62 + + RE_Bits_63, -- System.Pack_63 + RE_Get_63, -- System.Pack_63 + RE_Set_63, -- System.Pack_63 + + RE_Adjust_Storage_Size, -- System_Parameters + RE_Default_Stack_Size, -- System.Parameters + RE_Garbage_Collected, -- System.Parameters + RE_Size_Type, -- System.Parameters + RE_Unspecified_Size, -- System.Parameters + + RE_Get_Active_Partition_Id, -- System.Partition_Interface + RE_Get_Passive_Partition_Id, -- System.Partition_Interface + RE_Get_Local_Partition_Id, -- System.Partition_Interface + RE_Get_RCI_Package_Receiver, -- System.Partition_Interface + RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface + RE_RACW_Stub_Type, -- System.Partition_Interface + RE_RACW_Stub_Type_Access, -- System.Partition_Interface + RE_Raise_Program_Error_For_E_4_18, -- System.Partition_Interface + RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface + RE_Register_Passive_Package, -- System.Partition_Interface + RE_Register_Receiving_Stub, -- System.Partition_Interface + RE_RCI_Info, -- System.Partition_Interface + RE_Subprogram_Id, -- System.Partition_Interface + + RE_Global_Pool_Object, -- System.Pool_Global + + RE_Unbounded_Reclaim_Pool, -- System.Pool_Local + + RE_Stack_Bounded_Pool, -- System.Pool_Size + + RE_Do_Apc, -- System.RPC + RE_Do_Rpc, -- System.RPC + RE_Params_Stream_Type, -- System.RPC + RE_Partition_ID, -- System.RPC + RE_RPC_Receiver, -- System.RPC + + RE_IS_Is1, -- System.Scalar_Values + RE_IS_Is2, -- System.Scalar_Values + RE_IS_Is4, -- System.Scalar_Values + RE_IS_Is8, -- System.Scalar_Values + RE_IS_Iu1, -- System.Scalar_Values + RE_IS_Iu2, -- System.Scalar_Values + RE_IS_Iu4, -- System.Scalar_Values + RE_IS_Iu8, -- System.Scalar_Values + RE_IS_Isf, -- System.Scalar_Values + RE_IS_Ifl, -- System.Scalar_Values + RE_IS_Ilf, -- System.Scalar_Values + RE_IS_Ill, -- System.Scalar_Values + + RE_Mark_Id, -- System.Secondary_Stack + RE_SS_Allocate, -- System.Secondary_Stack + RE_SS_Pool, -- System.Secondary_Stack + RE_SS_Mark, -- System.Secondary_Stack + RE_SS_Release, -- System.Secondary_Stack + + RE_Shared_Var_Close, -- System.Shared_Storage + RE_Shared_Var_Lock, -- System.Shared_Storage + RE_Shared_Var_ROpen, -- System.Shared_Storage + RE_Shared_Var_Unlock, -- System.Shared_Storage + RE_Shared_Var_WOpen, -- System.Shared_Storage + + RE_Abort_Undefer_Direct, -- System.Standard_Library + RE_Exception_Data, -- System.Standard_Library + RE_Exception_Data_Ptr, -- System.Standard_Library + + RE_Integer_Address, -- System.Storage_Elements + RE_Storage_Offset, -- System.Storage_Elements + RE_Storage_Array, -- System.Storage_Elements + RE_To_Address, -- System.Storage_Elements + + RE_Root_Storage_Pool, -- System.Storage_Pools + + RE_Thin_Pointer, -- System.Stream_Attributes + RE_Fat_Pointer, -- System.Stream_Attributes + + RE_I_AD, -- System.Stream_Attributes + RE_I_AS, -- System.Stream_Attributes + RE_I_B, -- System.Stream_Attributes + RE_I_C, -- System.Stream_Attributes + RE_I_F, -- System.Stream_Attributes + RE_I_I, -- System.Stream_Attributes + RE_I_LF, -- System.Stream_Attributes + RE_I_LI, -- System.Stream_Attributes + RE_I_LLF, -- System.Stream_Attributes + RE_I_LLI, -- System.Stream_Attributes + RE_I_LLU, -- System.Stream_Attributes + RE_I_LU, -- System.Stream_Attributes + RE_I_SF, -- System.Stream_Attributes + RE_I_SI, -- System.Stream_Attributes + RE_I_SSI, -- System.Stream_Attributes + RE_I_SSU, -- System.Stream_Attributes + RE_I_SU, -- System.Stream_Attributes + RE_I_U, -- System.Stream_Attributes + RE_I_WC, -- System.Stream_Attributes + + RE_W_AD, -- System.Stream_Attributes + RE_W_AS, -- System.Stream_Attributes + RE_W_B, -- System.Stream_Attributes + RE_W_C, -- System.Stream_Attributes + RE_W_F, -- System.Stream_Attributes + RE_W_I, -- System.Stream_Attributes + RE_W_LF, -- System.Stream_Attributes + RE_W_LI, -- System.Stream_Attributes + RE_W_LLF, -- System.Stream_Attributes + RE_W_LLI, -- System.Stream_Attributes + RE_W_LLU, -- System.Stream_Attributes + RE_W_LU, -- System.Stream_Attributes + RE_W_SF, -- System.Stream_Attributes + RE_W_SI, -- System.Stream_Attributes + RE_W_SSI, -- System.Stream_Attributes + RE_W_SSU, -- System.Stream_Attributes + RE_W_SU, -- System.Stream_Attributes + RE_W_U, -- System.Stream_Attributes + RE_W_WC, -- System.Stream_Attributes + + RE_Str_Concat, -- System.String_Ops + RE_Str_Concat_CC, -- System.String_Ops + RE_Str_Concat_CS, -- System.String_Ops + RE_Str_Concat_SC, -- System.String_Ops + RE_Str_Equal, -- System.String_Ops + RE_Str_Normalize, -- System.String_Ops + RE_Wide_Str_Normalize, -- System.String_Ops + + RE_Str_Concat_3, -- System.String_Ops_Concat_3 + + RE_Str_Concat_4, -- System.String_Ops_Concat_4 + + RE_Str_Concat_5, -- System.String_Ops_Concat_5 + + RE_Free_Task_Image, -- System.Task_Info + RE_Task_Info_Type, -- System.Task_Info + RE_Task_Image_Type, -- System_Task_Info + RE_Unspecified_Task_Info, -- System.Task_Info + + RE_Library_Task_Level, -- System.Tasking + + RE_Task_Procedure_Access, -- System.Tasking + + RO_ST_Task_ID, -- System.Tasking + + RE_Call_Modes, -- System.Tasking + RE_Simple_Call, -- System.Tasking + RE_Conditional_Call, -- System.Tasking + RE_Asynchronous_Call, -- System.Tasking + RE_Timed_Call, -- System.Tasking + + RE_Task_List, -- System.Tasking + + RE_Accept_Alternative, -- System.Tasking + RE_Accept_List, -- System.Tasking + RE_Accept_List_Access, -- System.Tasking + RE_Max_Select, -- System.Tasking + RE_Max_Task_Entry, -- System.Tasking + RE_No_Rendezvous, -- System.Tasking + RE_Null_Task_Entry, -- System.Tasking + RE_Positive_Select_Index, -- System.Tasking + RE_Select_Index, -- System.Tasking + RE_Select_Modes, -- System.Tasking + RE_Else_Mode, -- System.Tasking + RE_Simple_Mode, -- System.Tasking + RE_Terminate_Mode, -- System.Tasking + RE_Delay_Mode, -- System.Tasking + RE_Task_Entry_Index, -- System.Tasking + RE_Self, -- System.Tasking + + RE_Master_Id, -- System.Tasking + RE_Unspecified_Priority, -- System.Tasking + + RE_Activation_Chain, -- System.Tasking + + RE_Abort_Defer, -- System.Soft_Links + RE_Abort_Undefer, -- System.Soft_Links + RE_Complete_Master, -- System.Soft_Links + RE_Current_Master, -- System.Soft_Links + RE_Enter_Master, -- System.Soft_Links + RE_Get_Current_Excep, -- System.Soft_Links + RE_Get_GNAT_Exception, -- System.Soft_Links + RE_Update_Exception, -- System.Soft_Links + + RE_Bits_1, -- System.Unsigned_Types + RE_Bits_2, -- System.Unsigned_Types + RE_Bits_4, -- System.Unsigned_Types + RE_Float_Unsigned, -- System.Unsigned_Types + RE_Long_Long_Unsigned, -- System.Unsigned_Types + RE_Packed_Byte, -- System.Unsigned_Types + RE_Packed_Bytes1, -- System.Unsigned_Types + RE_Packed_Bytes2, -- System.Unsigned_Types + RE_Packed_Bytes4, -- System.Unsigned_Types + RE_Unsigned, -- System.Unsigned_Types + + RE_Value_Boolean, -- System.Val_Bool + + RE_Value_Character, -- System.Val_Char + + RE_Value_Decimal, -- System.Val_Dec + + RE_Value_Enumeration_8, -- System.Val_Enum + RE_Value_Enumeration_16, -- System.Val_Enum + RE_Value_Enumeration_32, -- System.Val_Enum + + RE_Value_Integer, -- System.Val_Int + + RE_Value_Long_Long_Decimal, -- System.Val_LLD + + RE_Value_Long_Long_Integer, -- System.Val_LLI + + RE_Value_Long_Long_Unsigned, -- System.Val_LLU + + RE_Value_Real, -- System.Val_Real + + RE_Value_Unsigned, -- System.Val_Uns + + RE_Value_Wide_Character, -- System.Val_WChar + + RE_D, -- System.Vax_Float_Operations + RE_F, -- System.Vax_Float_Operations + RE_G, -- System.Vax_Float_Operations + RE_Q, -- System.Vax_Float_Operations + RE_S, -- System.Vax_Float_Operations + RE_T, -- System.Vax_Float_Operations + + RE_D_To_G, -- System.Vax_Float_Operations + RE_F_To_G, -- System.Vax_Float_Operations + RE_F_To_Q, -- System.Vax_Float_Operations + RE_F_To_S, -- System.Vax_Float_Operations + RE_G_To_D, -- System.Vax_Float_Operations + RE_G_To_F, -- System.Vax_Float_Operations + RE_G_To_Q, -- System.Vax_Float_Operations + RE_G_To_T, -- System.Vax_Float_Operations + RE_Q_To_F, -- System.Vax_Float_Operations + RE_Q_To_G, -- System.Vax_Float_Operations + RE_S_To_F, -- System.Vax_Float_Operations + RE_T_To_D, -- System.Vax_Float_Operations + RE_T_To_G, -- System.Vax_Float_Operations + + RE_Abs_F, -- System.Vax_Float_Operations + RE_Abs_G, -- System.Vax_Float_Operations + RE_Add_F, -- System.Vax_Float_Operations + RE_Add_G, -- System.Vax_Float_Operations + RE_Div_F, -- System.Vax_Float_Operations + RE_Div_G, -- System.Vax_Float_Operations + RE_Mul_F, -- System.Vax_Float_Operations + RE_Mul_G, -- System.Vax_Float_Operations + RE_Neg_F, -- System.Vax_Float_Operations + RE_Neg_G, -- System.Vax_Float_Operations + RE_Sub_F, -- System.Vax_Float_Operations + RE_Sub_G, -- System.Vax_Float_Operations + + RE_Eq_F, -- System.Vax_Float_Operations + RE_Eq_G, -- System.Vax_Float_Operations + RE_Le_F, -- System.Vax_Float_Operations + RE_Le_G, -- System.Vax_Float_Operations + RE_Lt_F, -- System.Vax_Float_Operations + RE_Lt_G, -- System.Vax_Float_Operations + + RE_Version_String, -- System.Version_Control + RE_Get_Version_String, -- System.Version_Control + + RE_Register_VMS_Exception, -- System.VMS_Exception_Table + + RE_String_To_Wide_String, -- System.WCh_StW + + RE_Wide_String_To_String, -- System.WCh_WtS + + RE_Wide_Width_Character, -- System.WWd_Char + + RE_Wide_Width_Enumeration_8, -- System.WWd_Enum + RE_Wide_Width_Enumeration_16, -- System.WWd_Enum + RE_Wide_Width_Enumeration_32, -- System.WWd_Enum + + RE_Wide_Width_Wide_Character, -- System.WWd_Wchar + + RE_Width_Boolean, -- System.Wid_Bool + + RE_Width_Character, -- System.Wid_Char + + RE_Width_Enumeration_8, -- System.Wid_Enum + RE_Width_Enumeration_16, -- System.Wid_Enum + RE_Width_Enumeration_32, -- System.Wid_Enum + + RE_Width_Long_Long_Integer, -- System.Wid_LLI + + RE_Width_Long_Long_Unsigned, -- System.Wid_LLU + + RE_Width_Wide_Character, -- System.Wid_WChar + + RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries + RE_Protection_Entries, -- Tasking.Protected_Objects.Entries + RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries + RE_Lock_Entries, -- Tasking.Protected_Objects.Entries + RE_Lock_Read_Only_Entries, -- Tasking.Protected_Objects.Entries + RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries + RE_Communication_Block, -- Protected_Objects.Operations + RE_Protected_Entry_Call, -- Protected_Objects.Operations + RE_Service_Entries, -- Protected_Objects.Operations + RE_Cancel_Protected_Entry_Call, -- Protected_Objects.Operations + RE_Enqueued, -- Protected_Objects.Operations + RE_Cancelled, -- Protected_Objects.Operations + RE_Complete_Entry_Body, -- Protected_Objects.Operations + RE_Exceptional_Complete_Entry_Body, -- Protected_Objects.Operations + RE_Requeue_Protected_Entry, -- Protected_Objects.Operations + RE_Requeue_Task_To_Protected_Entry, -- Protected_Objects.Operations + RE_Protected_Count, -- Protected_Objects.Operations + RE_Protected_Entry_Caller, -- Protected_Objects.Operations + RE_Timed_Protected_Entry_Call, -- Protected_Objects.Operations + + RE_Protection_Entry, -- Protected_Objects.Single_Entry + RE_Initialize_Protection_Entry, -- Protected_Objects.Single_Entry + RE_Lock_Entry, -- Protected_Objects.Single_Entry + RE_Lock_Read_Only_Entry, -- Protected_Objects.Single_Entry + RE_Unlock_Entry, -- Protected_Objects.Single_Entry + RE_Protected_Single_Entry_Call, -- Protected_Objects.Single_Entry + RE_Service_Entry, -- Protected_Objects.Single_Entry + RE_Complete_Single_Entry_Body, -- Protected_Objects.Single_Entry + RE_Exceptional_Complete_Single_Entry_Body, + RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry + RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry + RE_Timed_Protected_Single_Entry_Call, + + RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects + RE_Entry_Body, -- System.Tasking.Protected_Objects + RE_Protection, -- System.Tasking.Protected_Objects + RE_Initialize_Protection, -- System.Tasking.Protected_Objects + RE_Finalize_Protection, -- System.Tasking.Protected_Objects + RE_Lock, -- System.Tasking.Protected_Objects + RE_Lock_Read_Only, -- System.Tasking.Protected_Objects + RE_Unlock, -- System.Tasking.Protected_Objects + + RE_Delay_Block, -- System.Tasking.Async_Delays + RE_Timed_Out, -- System.Tasking.Async_Delays + RE_Cancel_Async_Delay, -- System.Tasking.Async_Delays + RE_Enqueue_Duration, -- System.Tasking.Async_Delays + RE_Enqueue_Calendar, -- System.Tasking.Async_Delays + RE_Enqueue_RT, -- System.Tasking.Async_Delays + + RE_Accept_Call, -- System.Tasking.Rendezvous + RE_Accept_Trivial, -- System.Tasking.Rendezvous + RE_Callable, -- System.Tasking.Rendezvous + RE_Call_Simple, -- System.Tasking.Rendezvous + RE_Requeue_Task_Entry, -- System.Tasking.Rendezvous + RE_Requeue_Protected_To_Task_Entry, -- System.Tasking.Rendezvous + RE_Cancel_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Complete_Rendezvous, -- System.Tasking.Rendezvous + RE_Task_Count, -- System.Tasking.Rendezvous + RE_Exceptional_Complete_Rendezvous, -- System.Tasking.Rendezvous + RE_Selective_Wait, -- System.Tasking.Rendezvous + RE_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Task_Entry_Caller, -- System.Tasking.Rendezvous + RE_Timed_Task_Entry_Call, -- System.Tasking.Rendezvous + RE_Timed_Selective_Wait, -- System.Tasking.Rendezvous + + RE_Activate_Restricted_Tasks, -- System.Tasking.Restricted.Stages + RE_Complete_Restricted_Activation, -- System.Tasking.Restricted.Stages + RE_Create_Restricted_Task, -- System.Tasking.Restricted.Stages + RE_Complete_Restricted_Task, -- System.Tasking.Restricted.Stages + RE_Restricted_Terminated, -- System.Tasking.Restricted.Stages + + RE_Abort_Tasks, -- System.Tasking.Stages + RE_Activate_Tasks, -- System.Tasking.Stages + RE_Complete_Activation, -- System.Tasking.Stages + RE_Create_Task, -- System.Tasking.Stages + RE_Complete_Task, -- System.Tasking.Stages + RE_Free_Task, -- System.Tasking.Stages + RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages + RE_Terminated); -- System.Tasking.Stages + + -- The following declarations build a table that is indexed by the + -- RTE function to determine the unit containing the given entity. + -- This table is sorted in order of package names. + + RE_Unit_Table : array (RE_Id) of RTU_Id := ( + + RE_Null => RTU_Null, + + RE_Code_Loc => Ada_Exceptions, + RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT + RE_Exception_Id => Ada_Exceptions, + RE_Exception_Information => Ada_Exceptions, + RE_Exception_Message => Ada_Exceptions, + RE_Exception_Name_Simple => Ada_Exceptions, + RE_Exception_Occurrence => Ada_Exceptions, + RE_Null_Id => Ada_Exceptions, + RE_Null_Occurrence => Ada_Exceptions, + RE_Poll => Ada_Exceptions, + RE_Raise_Exception => Ada_Exceptions, + RE_Raise_Exception_Always => Ada_Exceptions, + RE_Reraise_Occurrence => Ada_Exceptions, + RE_Reraise_Occurrence_Always => Ada_Exceptions, + RE_Reraise_Occurrence_No_Defer => Ada_Exceptions, + RE_Save_Occurrence => Ada_Exceptions, + + RE_Simple_List_Controller => Ada_Finalization_List_Controller, + RE_List_Controller => Ada_Finalization_List_Controller, + + RE_Interrupt_Id => Ada_Interrupts, + + RE_Root_Stream_Type => Ada_Streams, + RE_Stream_Element => Ada_Streams, + RE_Stream_Element_Offset => Ada_Streams, + RE_Stream_Element_Array => Ada_Streams, + + RE_Stream_Access => Ada_Streams_Stream_IO, + + RE_CW_Membership => Ada_Tags, + RE_DT_Entry_Size => Ada_Tags, + RE_DT_Prologue_Size => Ada_Tags, + RE_External_Tag => Ada_Tags, + RE_Get_Expanded_Name => Ada_Tags, + RE_Get_External_Tag => Ada_Tags, + RE_Get_Prim_Op_Address => Ada_Tags, + RE_Get_RC_Offset => Ada_Tags, + RE_Get_Remotely_Callable => Ada_Tags, + RE_Get_TSD => Ada_Tags, + RE_Inherit_DT => Ada_Tags, + RE_Inherit_TSD => Ada_Tags, + RE_Internal_Tag => Ada_Tags, + RE_Register_Tag => Ada_Tags, + RE_Set_Expanded_Name => Ada_Tags, + RE_Set_External_Tag => Ada_Tags, + RE_Set_Prim_Op_Address => Ada_Tags, + RE_Set_RC_Offset => Ada_Tags, + RE_Set_Remotely_Callable => Ada_Tags, + RE_Set_TSD => Ada_Tags, + RE_Tag_Error => Ada_Tags, + RE_TSD_Entry_Size => Ada_Tags, + RE_TSD_Prologue_Size => Ada_Tags, + RE_Tag => Ada_Tags, + RE_Address_Array => Ada_Tags, + + RE_Current_Task => Ada_Task_Identification, + RO_AT_Task_ID => Ada_Task_Identification, + + RO_CA_Time => Ada_Calendar, + RO_CA_Delay_For => Ada_Calendar_Delays, + RO_CA_Delay_Until => Ada_Calendar_Delays, + RO_CA_To_Duration => Ada_Calendar_Delays, + + RO_RT_Time => Ada_Real_Time, + RO_RT_Delay_Until => Ada_Real_Time_Delays, + RO_RT_To_Duration => Ada_Real_Time_Delays, + + RE_Integer_64 => Interfaces, + RE_Unsigned_8 => Interfaces, + RE_Unsigned_16 => Interfaces, + RE_Unsigned_32 => Interfaces, + RE_Unsigned_64 => Interfaces, + + RE_Vtable_Ptr => Interfaces_CPP, + RE_Displaced_This => Interfaces_CPP, + RE_CPP_CW_Membership => Interfaces_CPP, + RE_CPP_DT_Entry_Size => Interfaces_CPP, + RE_CPP_DT_Prologue_Size => Interfaces_CPP, + RE_CPP_Get_Expanded_Name => Interfaces_CPP, + RE_CPP_Get_External_Tag => Interfaces_CPP, + RE_CPP_Get_Prim_Op_Address => Interfaces_CPP, + RE_CPP_Get_RC_Offset => Interfaces_CPP, + RE_CPP_Get_Remotely_Callable => Interfaces_CPP, + RE_CPP_Get_TSD => Interfaces_CPP, + RE_CPP_Inherit_DT => Interfaces_CPP, + RE_CPP_Inherit_TSD => Interfaces_CPP, + RE_CPP_Register_Tag => Interfaces_CPP, + RE_CPP_Set_Expanded_Name => Interfaces_CPP, + RE_CPP_Set_External_Tag => Interfaces_CPP, + RE_CPP_Set_Prim_Op_Address => Interfaces_CPP, + RE_CPP_Set_RC_Offset => Interfaces_CPP, + RE_CPP_Set_Remotely_Callable => Interfaces_CPP, + RE_CPP_Set_TSD => Interfaces_CPP, + RE_CPP_TSD_Entry_Size => Interfaces_CPP, + RE_CPP_TSD_Prologue_Size => Interfaces_CPP, + + RE_Packed_Size => Interfaces_Packed_Decimal, + RE_Packed_To_Int32 => Interfaces_Packed_Decimal, + RE_Packed_To_Int64 => Interfaces_Packed_Decimal, + RE_Int32_To_Packed => Interfaces_Packed_Decimal, + RE_Int64_To_Packed => Interfaces_Packed_Decimal, + + RE_Address => System, + RE_Any_Priority => System, + RE_Bit_Order => System, + RE_Default_Priority => System, + RE_High_Order_First => System, + RE_Interrupt_Priority => System, + RE_Lib_Stop => System, + RE_Low_Order_First => System, + RE_Max_Interrupt_Priority => System, + RE_Max_Priority => System, + RE_Null_Address => System, + RE_Priority => System, + + RE_Add_With_Ovflo_Check => System_Arith_64, + RE_Double_Divide => System_Arith_64, + RE_Multiply_With_Ovflo_Check => System_Arith_64, + RE_Scaled_Divide => System_Arith_64, + RE_Subtract_With_Ovflo_Check => System_Arith_64, + + RE_Create_AST_Handler => System_AST_Handling, + + RE_Raise_Assert_Failure => System_Assertions, + + RE_AST_Handler => System_Aux_DEC, + RE_Import_Value => System_Aux_DEC, + RE_No_AST_Handler => System_Aux_DEC, + RE_Type_Class => System_Aux_DEC, + RE_Type_Class_Enumeration => System_Aux_DEC, + RE_Type_Class_Integer => System_Aux_DEC, + RE_Type_Class_Fixed_Point => System_Aux_DEC, + RE_Type_Class_Floating_Point => System_Aux_DEC, + RE_Type_Class_Array => System_Aux_DEC, + RE_Type_Class_Record => System_Aux_DEC, + RE_Type_Class_Access => System_Aux_DEC, + RE_Type_Class_Task => System_Aux_DEC, + RE_Type_Class_Address => System_Aux_DEC, + + RE_Bit_And => System_Bit_Ops, + RE_Bit_Eq => System_Bit_Ops, + RE_Bit_Not => System_Bit_Ops, + RE_Bit_Or => System_Bit_Ops, + RE_Bit_Xor => System_Bit_Ops, + + RE_Checked_Pool => System_Checked_Pools, + + RE_Register_Exception => System_Exception_Table, + + RE_All_Others_Id => System_Exceptions, + RE_Handler_Record => System_Exceptions, + RE_Handler_Record_Ptr => System_Exceptions, + RE_Others_Id => System_Exceptions, + RE_Subprogram_Descriptor => System_Exceptions, + RE_Subprogram_Descriptor_0 => System_Exceptions, + RE_Subprogram_Descriptor_1 => System_Exceptions, + RE_Subprogram_Descriptor_2 => System_Exceptions, + RE_Subprogram_Descriptor_3 => System_Exceptions, + RE_Subprogram_Descriptor_List => System_Exceptions, + RE_Subprogram_Descriptor_Ptr => System_Exceptions, + RE_Subprogram_Descriptors_Record => System_Exceptions, + RE_Subprogram_Descriptors_Ptr => System_Exceptions, + + RE_Exn_Float => System_Exn_Flt, + + RE_Exn_Integer => System_Exn_Int, + + RE_Exn_Long_Float => System_Exn_LFlt, + + RE_Exn_Long_Integer => System_Exn_LInt, + + RE_Exn_Long_Long_Float => System_Exn_LLF, + + RE_Exn_Long_Long_Integer => System_Exn_LLI, + + RE_Exn_Short_Float => System_Exn_SFlt, + + RE_Exn_Short_Integer => System_Exn_SInt, + + RE_Exn_Short_Short_Integer => System_Exn_SSI, + + RE_Exp_Float => System_Exp_Flt, + + RE_Exp_Integer => System_Exp_Int, + + RE_Exp_Long_Float => System_Exp_LFlt, + + RE_Exp_Long_Integer => System_Exp_LInt, + + RE_Exp_Long_Long_Float => System_Exp_LLF, + + RE_Exp_Long_Long_Integer => System_Exp_LLI, + + RE_Exp_Long_Long_Unsigned => System_Exp_LLU, + + RE_Exp_Modular => System_Exp_Mod, + + RE_Exp_Short_Float => System_Exp_SFlt, + + RE_Exp_Short_Integer => System_Exp_SInt, + + RE_Exp_Short_Short_Integer => System_Exp_SSI, + + RE_Exp_Unsigned => System_Exp_Uns, + + RE_Fat_Float => System_Fat_Flt, + + RE_Fat_Long_Float => System_Fat_LFlt, + + RE_Fat_Long_Long_Float => System_Fat_LLF, + + RE_Fat_Short_Float => System_Fat_SFlt, + + RE_Attach_To_Final_List => System_Finalization_Implementation, + RE_Finalize_List => System_Finalization_Implementation, + RE_Finalize_One => System_Finalization_Implementation, + RE_Global_Final_List => System_Finalization_Implementation, + RE_Record_Controller => System_Finalization_Implementation, + RE_Limited_Record_Controller => System_Finalization_Implementation, + RE_Deep_Tag_Initialize => System_Finalization_Implementation, + RE_Deep_Tag_Adjust => System_Finalization_Implementation, + RE_Deep_Tag_Finalize => System_Finalization_Implementation, + RE_Deep_Tag_Attach => System_Finalization_Implementation, + RE_Deep_Rec_Initialize => System_Finalization_Implementation, + RE_Deep_Rec_Adjust => System_Finalization_Implementation, + RE_Deep_Rec_Finalize => System_Finalization_Implementation, + + RE_Root_Controlled => System_Finalization_Root, + RE_Finalizable => System_Finalization_Root, + RE_Finalizable_Ptr => System_Finalization_Root, + + RE_Fore => System_Fore, + + RE_Image_Boolean => System_Img_Bool, + + RE_Image_Character => System_Img_Char, + + RE_Image_Decimal => System_Img_Dec, + + RE_Image_Enumeration_8 => System_Img_Enum, + RE_Image_Enumeration_16 => System_Img_Enum, + RE_Image_Enumeration_32 => System_Img_Enum, + + RE_Image_Integer => System_Img_Int, + + RE_Image_Long_Long_Decimal => System_Img_LLD, + + RE_Image_Long_Long_Integer => System_Img_LLI, + + RE_Image_Long_Long_Unsigned => System_Img_LLU, + + RE_Image_Ordinary_Fixed_Point => System_Img_Real, + RE_Image_Floating_Point => System_Img_Real, + + RE_Image_Unsigned => System_Img_Uns, + + RE_Image_Wide_Character => System_Img_WChar, + + RE_Bind_Interrupt_To_Entry => System_Interrupts, + RE_Default_Interrupt_Priority => System_Interrupts, + RE_Dynamic_Interrupt_Protection => System_Interrupts, + RE_Install_Handlers => System_Interrupts, + RE_Register_Interrupt_Handler => System_Interrupts, + RE_Static_Interrupt_Protection => System_Interrupts, + + RE_Asm_Insn => System_Machine_Code, + RE_Asm_Input_Operand => System_Machine_Code, + RE_Asm_Output_Operand => System_Machine_Code, + + RE_Mantissa_Value => System_Mantissa, + + RE_Bits_03 => System_Pack_03, + RE_Get_03 => System_Pack_03, + RE_Set_03 => System_Pack_03, + + RE_Bits_05 => System_Pack_05, + RE_Get_05 => System_Pack_05, + RE_Set_05 => System_Pack_05, + + RE_Bits_06 => System_Pack_06, + RE_Get_06 => System_Pack_06, + RE_GetU_06 => System_Pack_06, + RE_Set_06 => System_Pack_06, + RE_SetU_06 => System_Pack_06, + + RE_Bits_07 => System_Pack_07, + RE_Get_07 => System_Pack_07, + RE_Set_07 => System_Pack_07, + + RE_Bits_09 => System_Pack_09, + RE_Get_09 => System_Pack_09, + RE_Set_09 => System_Pack_09, + + RE_Bits_10 => System_Pack_10, + RE_Get_10 => System_Pack_10, + RE_GetU_10 => System_Pack_10, + RE_Set_10 => System_Pack_10, + RE_SetU_10 => System_Pack_10, + + RE_Bits_11 => System_Pack_11, + RE_Get_11 => System_Pack_11, + RE_Set_11 => System_Pack_11, + + RE_Bits_12 => System_Pack_12, + RE_Get_12 => System_Pack_12, + RE_GetU_12 => System_Pack_12, + RE_Set_12 => System_Pack_12, + RE_SetU_12 => System_Pack_12, + + RE_Bits_13 => System_Pack_13, + RE_Get_13 => System_Pack_13, + RE_Set_13 => System_Pack_13, + + RE_Bits_14 => System_Pack_14, + RE_Get_14 => System_Pack_14, + RE_GetU_14 => System_Pack_14, + RE_Set_14 => System_Pack_14, + RE_SetU_14 => System_Pack_14, + + RE_Bits_15 => System_Pack_15, + RE_Get_15 => System_Pack_15, + RE_Set_15 => System_Pack_15, + + RE_Bits_17 => System_Pack_17, + RE_Get_17 => System_Pack_17, + RE_Set_17 => System_Pack_17, + + RE_Bits_18 => System_Pack_18, + RE_Get_18 => System_Pack_18, + RE_GetU_18 => System_Pack_18, + RE_Set_18 => System_Pack_18, + RE_SetU_18 => System_Pack_18, + + RE_Bits_19 => System_Pack_19, + RE_Get_19 => System_Pack_19, + RE_Set_19 => System_Pack_19, + + RE_Bits_20 => System_Pack_20, + RE_Get_20 => System_Pack_20, + RE_GetU_20 => System_Pack_20, + RE_Set_20 => System_Pack_20, + RE_SetU_20 => System_Pack_20, + + RE_Bits_21 => System_Pack_21, + RE_Get_21 => System_Pack_21, + RE_Set_21 => System_Pack_21, + + RE_Bits_22 => System_Pack_22, + RE_Get_22 => System_Pack_22, + RE_GetU_22 => System_Pack_22, + RE_Set_22 => System_Pack_22, + RE_SetU_22 => System_Pack_22, + + RE_Bits_23 => System_Pack_23, + RE_Get_23 => System_Pack_23, + RE_Set_23 => System_Pack_23, + + RE_Bits_24 => System_Pack_24, + RE_Get_24 => System_Pack_24, + RE_GetU_24 => System_Pack_24, + RE_Set_24 => System_Pack_24, + RE_SetU_24 => System_Pack_24, + + RE_Bits_25 => System_Pack_25, + RE_Get_25 => System_Pack_25, + RE_Set_25 => System_Pack_25, + + RE_Bits_26 => System_Pack_26, + RE_Get_26 => System_Pack_26, + RE_GetU_26 => System_Pack_26, + RE_Set_26 => System_Pack_26, + RE_SetU_26 => System_Pack_26, + + RE_Bits_27 => System_Pack_27, + RE_Get_27 => System_Pack_27, + RE_Set_27 => System_Pack_27, + + RE_Bits_28 => System_Pack_28, + RE_Get_28 => System_Pack_28, + RE_GetU_28 => System_Pack_28, + RE_Set_28 => System_Pack_28, + RE_SetU_28 => System_Pack_28, + + RE_Bits_29 => System_Pack_29, + RE_Get_29 => System_Pack_29, + RE_Set_29 => System_Pack_29, + + RE_Bits_30 => System_Pack_30, + RE_Get_30 => System_Pack_30, + RE_GetU_30 => System_Pack_30, + RE_Set_30 => System_Pack_30, + RE_SetU_30 => System_Pack_30, + + RE_Bits_31 => System_Pack_31, + RE_Get_31 => System_Pack_31, + RE_Set_31 => System_Pack_31, + + RE_Bits_33 => System_Pack_33, + RE_Get_33 => System_Pack_33, + RE_Set_33 => System_Pack_33, + + RE_Bits_34 => System_Pack_34, + RE_Get_34 => System_Pack_34, + RE_GetU_34 => System_Pack_34, + RE_Set_34 => System_Pack_34, + RE_SetU_34 => System_Pack_34, + + RE_Bits_35 => System_Pack_35, + RE_Get_35 => System_Pack_35, + RE_Set_35 => System_Pack_35, + + RE_Bits_36 => System_Pack_36, + RE_Get_36 => System_Pack_36, + RE_GetU_36 => System_Pack_36, + RE_Set_36 => System_Pack_36, + RE_SetU_36 => System_Pack_36, + + RE_Bits_37 => System_Pack_37, + RE_Get_37 => System_Pack_37, + RE_Set_37 => System_Pack_37, + + RE_Bits_38 => System_Pack_38, + RE_Get_38 => System_Pack_38, + RE_GetU_38 => System_Pack_38, + RE_Set_38 => System_Pack_38, + RE_SetU_38 => System_Pack_38, + + RE_Bits_39 => System_Pack_39, + RE_Get_39 => System_Pack_39, + RE_Set_39 => System_Pack_39, + + RE_Bits_40 => System_Pack_40, + RE_Get_40 => System_Pack_40, + RE_GetU_40 => System_Pack_40, + RE_Set_40 => System_Pack_40, + RE_SetU_40 => System_Pack_40, + + RE_Bits_41 => System_Pack_41, + RE_Get_41 => System_Pack_41, + RE_Set_41 => System_Pack_41, + + RE_Bits_42 => System_Pack_42, + RE_Get_42 => System_Pack_42, + RE_GetU_42 => System_Pack_42, + RE_Set_42 => System_Pack_42, + RE_SetU_42 => System_Pack_42, + + RE_Bits_43 => System_Pack_43, + RE_Get_43 => System_Pack_43, + RE_Set_43 => System_Pack_43, + + RE_Bits_44 => System_Pack_44, + RE_Get_44 => System_Pack_44, + RE_GetU_44 => System_Pack_44, + RE_Set_44 => System_Pack_44, + RE_SetU_44 => System_Pack_44, + + RE_Bits_45 => System_Pack_45, + RE_Get_45 => System_Pack_45, + RE_Set_45 => System_Pack_45, + + RE_Bits_46 => System_Pack_46, + RE_Get_46 => System_Pack_46, + RE_GetU_46 => System_Pack_46, + RE_Set_46 => System_Pack_46, + RE_SetU_46 => System_Pack_46, + + RE_Bits_47 => System_Pack_47, + RE_Get_47 => System_Pack_47, + RE_Set_47 => System_Pack_47, + + RE_Bits_48 => System_Pack_48, + RE_Get_48 => System_Pack_48, + RE_GetU_48 => System_Pack_48, + RE_Set_48 => System_Pack_48, + RE_SetU_48 => System_Pack_48, + + RE_Bits_49 => System_Pack_49, + RE_Get_49 => System_Pack_49, + RE_Set_49 => System_Pack_49, + + RE_Bits_50 => System_Pack_50, + RE_Get_50 => System_Pack_50, + RE_GetU_50 => System_Pack_50, + RE_Set_50 => System_Pack_50, + RE_SetU_50 => System_Pack_50, + + RE_Bits_51 => System_Pack_51, + RE_Get_51 => System_Pack_51, + RE_Set_51 => System_Pack_51, + + RE_Bits_52 => System_Pack_52, + RE_Get_52 => System_Pack_52, + RE_GetU_52 => System_Pack_52, + RE_Set_52 => System_Pack_52, + RE_SetU_52 => System_Pack_52, + + RE_Bits_53 => System_Pack_53, + RE_Get_53 => System_Pack_53, + RE_Set_53 => System_Pack_53, + + RE_Bits_54 => System_Pack_54, + RE_Get_54 => System_Pack_54, + RE_GetU_54 => System_Pack_54, + RE_Set_54 => System_Pack_54, + RE_SetU_54 => System_Pack_54, + + RE_Bits_55 => System_Pack_55, + RE_Get_55 => System_Pack_55, + RE_Set_55 => System_Pack_55, + + RE_Bits_56 => System_Pack_56, + RE_Get_56 => System_Pack_56, + RE_GetU_56 => System_Pack_56, + RE_Set_56 => System_Pack_56, + RE_SetU_56 => System_Pack_56, + + RE_Bits_57 => System_Pack_57, + RE_Get_57 => System_Pack_57, + RE_Set_57 => System_Pack_57, + + RE_Bits_58 => System_Pack_58, + RE_Get_58 => System_Pack_58, + RE_GetU_58 => System_Pack_58, + RE_Set_58 => System_Pack_58, + RE_SetU_58 => System_Pack_58, + + RE_Bits_59 => System_Pack_59, + RE_Get_59 => System_Pack_59, + RE_Set_59 => System_Pack_59, + + RE_Bits_60 => System_Pack_60, + RE_Get_60 => System_Pack_60, + RE_GetU_60 => System_Pack_60, + RE_Set_60 => System_Pack_60, + RE_SetU_60 => System_Pack_60, + + RE_Bits_61 => System_Pack_61, + RE_Get_61 => System_Pack_61, + RE_Set_61 => System_Pack_61, + + RE_Bits_62 => System_Pack_62, + RE_Get_62 => System_Pack_62, + RE_GetU_62 => System_Pack_62, + RE_Set_62 => System_Pack_62, + RE_SetU_62 => System_Pack_62, + + RE_Bits_63 => System_Pack_63, + RE_Get_63 => System_Pack_63, + RE_Set_63 => System_Pack_63, + + RE_Adjust_Storage_Size => System_Parameters, + RE_Default_Stack_Size => System_Parameters, + RE_Garbage_Collected => System_Parameters, + RE_Size_Type => System_Parameters, + RE_Unspecified_Size => System_Parameters, + + RE_Get_Active_Partition_Id => System_Partition_Interface, + RE_Get_Passive_Partition_Id => System_Partition_Interface, + RE_Get_Local_Partition_Id => System_Partition_Interface, + RE_Get_RCI_Package_Receiver => System_Partition_Interface, + RE_Get_Unique_Remote_Pointer => System_Partition_Interface, + RE_RACW_Stub_Type => System_Partition_Interface, + RE_RACW_Stub_Type_Access => System_Partition_Interface, + RE_Raise_Program_Error_For_E_4_18 => System_Partition_Interface, + RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface, + RE_Register_Passive_Package => System_Partition_Interface, + RE_Register_Receiving_Stub => System_Partition_Interface, + RE_RCI_Info => System_Partition_Interface, + RE_Subprogram_Id => System_Partition_Interface, + + RE_Global_Pool_Object => System_Pool_Global, + + RE_Unbounded_Reclaim_Pool => System_Pool_Local, + + RE_Stack_Bounded_Pool => System_Pool_Size, + + RE_Do_Apc => System_RPC, + RE_Do_Rpc => System_RPC, + RE_Params_Stream_Type => System_RPC, + RE_Partition_ID => System_RPC, + RE_RPC_Receiver => System_RPC, + + RE_IS_Is1 => System_Scalar_Values, + RE_IS_Is2 => System_Scalar_Values, + RE_IS_Is4 => System_Scalar_Values, + RE_IS_Is8 => System_Scalar_Values, + RE_IS_Iu1 => System_Scalar_Values, + RE_IS_Iu2 => System_Scalar_Values, + RE_IS_Iu4 => System_Scalar_Values, + RE_IS_Iu8 => System_Scalar_Values, + RE_IS_Isf => System_Scalar_Values, + RE_IS_Ifl => System_Scalar_Values, + RE_IS_Ilf => System_Scalar_Values, + RE_IS_Ill => System_Scalar_Values, + + RE_Mark_Id => System_Secondary_Stack, + RE_SS_Allocate => System_Secondary_Stack, + RE_SS_Mark => System_Secondary_Stack, + RE_SS_Pool => System_Secondary_Stack, + RE_SS_Release => System_Secondary_Stack, + + RE_Shared_Var_Close => System_Shared_Storage, + RE_Shared_Var_Lock => System_Shared_Storage, + RE_Shared_Var_ROpen => System_Shared_Storage, + RE_Shared_Var_Unlock => System_Shared_Storage, + RE_Shared_Var_WOpen => System_Shared_Storage, + + RE_Abort_Undefer_Direct => System_Standard_Library, + RE_Exception_Data => System_Standard_Library, + RE_Exception_Data_Ptr => System_Standard_Library, + + RE_Integer_Address => System_Storage_Elements, + RE_Storage_Offset => System_Storage_Elements, + RE_Storage_Array => System_Storage_Elements, + RE_To_Address => System_Storage_Elements, + + RE_Root_Storage_Pool => System_Storage_Pools, + + RE_Thin_Pointer => System_Stream_Attributes, + RE_Fat_Pointer => System_Stream_Attributes, + + RE_I_AD => System_Stream_Attributes, + RE_I_AS => System_Stream_Attributes, + RE_I_B => System_Stream_Attributes, + RE_I_C => System_Stream_Attributes, + RE_I_F => System_Stream_Attributes, + RE_I_I => System_Stream_Attributes, + RE_I_LF => System_Stream_Attributes, + RE_I_LI => System_Stream_Attributes, + RE_I_LLF => System_Stream_Attributes, + RE_I_LLI => System_Stream_Attributes, + RE_I_LLU => System_Stream_Attributes, + RE_I_LU => System_Stream_Attributes, + RE_I_SF => System_Stream_Attributes, + RE_I_SI => System_Stream_Attributes, + RE_I_SSI => System_Stream_Attributes, + RE_I_SSU => System_Stream_Attributes, + RE_I_SU => System_Stream_Attributes, + RE_I_U => System_Stream_Attributes, + RE_I_WC => System_Stream_Attributes, + + RE_W_AD => System_Stream_Attributes, + RE_W_AS => System_Stream_Attributes, + RE_W_B => System_Stream_Attributes, + RE_W_C => System_Stream_Attributes, + RE_W_F => System_Stream_Attributes, + RE_W_I => System_Stream_Attributes, + RE_W_LF => System_Stream_Attributes, + RE_W_LI => System_Stream_Attributes, + RE_W_LLF => System_Stream_Attributes, + RE_W_LLI => System_Stream_Attributes, + RE_W_LLU => System_Stream_Attributes, + RE_W_LU => System_Stream_Attributes, + RE_W_SF => System_Stream_Attributes, + RE_W_SI => System_Stream_Attributes, + RE_W_SSI => System_Stream_Attributes, + RE_W_SSU => System_Stream_Attributes, + RE_W_SU => System_Stream_Attributes, + RE_W_U => System_Stream_Attributes, + RE_W_WC => System_Stream_Attributes, + + RE_Str_Concat => System_String_Ops, + RE_Str_Equal => System_String_Ops, + RE_Str_Normalize => System_String_Ops, + RE_Wide_Str_Normalize => System_String_Ops, + RE_Str_Concat_CC => System_String_Ops, + RE_Str_Concat_CS => System_String_Ops, + RE_Str_Concat_SC => System_String_Ops, + + RE_Str_Concat_3 => System_String_Ops_Concat_3, + + RE_Str_Concat_4 => System_String_Ops_Concat_4, + + RE_Str_Concat_5 => System_String_Ops_Concat_5, + + RE_Free_Task_Image => System_Task_Info, + RE_Task_Info_Type => System_Task_Info, + RE_Task_Image_Type => System_Task_Info, + RE_Unspecified_Task_Info => System_Task_Info, + + RE_Library_Task_Level => System_Tasking, + + RE_Task_Procedure_Access => System_Tasking, + + RO_ST_Task_ID => System_Tasking, + + RE_Call_Modes => System_Tasking, + RE_Simple_Call => System_Tasking, + RE_Conditional_Call => System_Tasking, + RE_Asynchronous_Call => System_Tasking, + RE_Timed_Call => System_Tasking, + + RE_Task_List => System_Tasking, + + RE_Accept_Alternative => System_Tasking, + RE_Accept_List => System_Tasking, + RE_Accept_List_Access => System_Tasking, + RE_Max_Select => System_Tasking, + RE_Max_Task_Entry => System_Tasking, + RE_No_Rendezvous => System_Tasking, + RE_Null_Task_Entry => System_Tasking, + RE_Positive_Select_Index => System_Tasking, + RE_Select_Index => System_Tasking, + RE_Select_Modes => System_Tasking, + RE_Else_Mode => System_Tasking, + RE_Simple_Mode => System_Tasking, + RE_Terminate_Mode => System_Tasking, + RE_Delay_Mode => System_Tasking, + RE_Task_Entry_Index => System_Tasking, + RE_Self => System_Tasking, + + RE_Master_Id => System_Tasking, + RE_Unspecified_Priority => System_Tasking, + + RE_Activation_Chain => System_Tasking, + + RE_Abort_Defer => System_Soft_Links, + RE_Abort_Undefer => System_Soft_Links, + RE_Complete_Master => System_Soft_Links, + RE_Current_Master => System_Soft_Links, + RE_Enter_Master => System_Soft_Links, + RE_Get_Current_Excep => System_Soft_Links, + RE_Get_GNAT_Exception => System_Soft_Links, + RE_Update_Exception => System_Soft_Links, + + RE_Bits_1 => System_Unsigned_Types, + RE_Bits_2 => System_Unsigned_Types, + RE_Bits_4 => System_Unsigned_Types, + RE_Float_Unsigned => System_Unsigned_Types, + RE_Long_Long_Unsigned => System_Unsigned_Types, + RE_Packed_Byte => System_Unsigned_Types, + RE_Packed_Bytes1 => System_Unsigned_Types, + RE_Packed_Bytes2 => System_Unsigned_Types, + RE_Packed_Bytes4 => System_Unsigned_Types, + RE_Unsigned => System_Unsigned_Types, + + RE_Value_Boolean => System_Val_Bool, + + RE_Value_Character => System_Val_Char, + + RE_Value_Decimal => System_Val_Dec, + + RE_Value_Enumeration_8 => System_Val_Enum, + RE_Value_Enumeration_16 => System_Val_Enum, + RE_Value_Enumeration_32 => System_Val_Enum, + + RE_Value_Integer => System_Val_Int, + + RE_Value_Long_Long_Decimal => System_Val_LLD, + + RE_Value_Long_Long_Integer => System_Val_LLI, + + RE_Value_Long_Long_Unsigned => System_Val_LLU, + + RE_Value_Real => System_Val_Real, + + RE_Value_Unsigned => System_Val_Uns, + + RE_Value_Wide_Character => System_Val_WChar, + + RE_D => System_Vax_Float_Operations, + RE_F => System_Vax_Float_Operations, + RE_G => System_Vax_Float_Operations, + RE_Q => System_Vax_Float_Operations, + RE_S => System_Vax_Float_Operations, + RE_T => System_Vax_Float_Operations, + + RE_D_To_G => System_Vax_Float_Operations, + RE_F_To_G => System_Vax_Float_Operations, + RE_F_To_Q => System_Vax_Float_Operations, + RE_F_To_S => System_Vax_Float_Operations, + RE_G_To_D => System_Vax_Float_Operations, + RE_G_To_F => System_Vax_Float_Operations, + RE_G_To_Q => System_Vax_Float_Operations, + RE_G_To_T => System_Vax_Float_Operations, + RE_Q_To_F => System_Vax_Float_Operations, + RE_Q_To_G => System_Vax_Float_Operations, + RE_S_To_F => System_Vax_Float_Operations, + RE_T_To_D => System_Vax_Float_Operations, + RE_T_To_G => System_Vax_Float_Operations, + + RE_Abs_F => System_Vax_Float_Operations, + RE_Abs_G => System_Vax_Float_Operations, + RE_Add_F => System_Vax_Float_Operations, + RE_Add_G => System_Vax_Float_Operations, + RE_Div_F => System_Vax_Float_Operations, + RE_Div_G => System_Vax_Float_Operations, + RE_Mul_F => System_Vax_Float_Operations, + RE_Mul_G => System_Vax_Float_Operations, + RE_Neg_F => System_Vax_Float_Operations, + RE_Neg_G => System_Vax_Float_Operations, + RE_Sub_F => System_Vax_Float_Operations, + RE_Sub_G => System_Vax_Float_Operations, + + RE_Eq_F => System_Vax_Float_Operations, + RE_Eq_G => System_Vax_Float_Operations, + RE_Le_F => System_Vax_Float_Operations, + RE_Le_G => System_Vax_Float_Operations, + RE_Lt_F => System_Vax_Float_Operations, + RE_Lt_G => System_Vax_Float_Operations, + + RE_Version_String => System_Version_Control, + RE_Get_Version_String => System_Version_Control, + + RE_Register_VMS_Exception => System_VMS_Exception_Table, + + RE_String_To_Wide_String => System_WCh_StW, + + RE_Wide_String_To_String => System_WCh_WtS, + + RE_Wide_Width_Character => System_WWd_Char, + + RE_Wide_Width_Enumeration_8 => System_WWd_Enum, + RE_Wide_Width_Enumeration_16 => System_WWd_Enum, + RE_Wide_Width_Enumeration_32 => System_WWd_Enum, + + RE_Wide_Width_Wide_Character => System_WWd_Wchar, + + RE_Width_Boolean => System_Wid_Bool, + + RE_Width_Character => System_Wid_Char, + + RE_Width_Enumeration_8 => System_Wid_Enum, + RE_Width_Enumeration_16 => System_Wid_Enum, + RE_Width_Enumeration_32 => System_Wid_Enum, + + RE_Width_Long_Long_Integer => System_Wid_LLI, + + RE_Width_Long_Long_Unsigned => System_Wid_LLU, + + RE_Width_Wide_Character => System_Wid_WChar, + + RE_Protected_Entry_Body_Array => + System_Tasking_Protected_Objects_Entries, + RE_Protection_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Initialize_Protection_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Lock_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Lock_Read_Only_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Unlock_Entries => + System_Tasking_Protected_Objects_Entries, + RE_Communication_Block => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + RE_Service_Entries => + System_Tasking_Protected_Objects_Operations, + RE_Cancel_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + RE_Enqueued => + System_Tasking_Protected_Objects_Operations, + RE_Cancelled => + System_Tasking_Protected_Objects_Operations, + RE_Complete_Entry_Body => + System_Tasking_Protected_Objects_Operations, + RE_Exceptional_Complete_Entry_Body => + System_Tasking_Protected_Objects_Operations, + RE_Requeue_Protected_Entry => + System_Tasking_Protected_Objects_Operations, + RE_Requeue_Task_To_Protected_Entry => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Count => + System_Tasking_Protected_Objects_Operations, + RE_Protected_Entry_Caller => + System_Tasking_Protected_Objects_Operations, + RE_Timed_Protected_Entry_Call => + System_Tasking_Protected_Objects_Operations, + + RE_Protection_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Initialize_Protection_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Lock_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Lock_Read_Only_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Unlock_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Single_Entry_Call => + System_Tasking_Protected_Objects_Single_Entry, + RE_Service_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Complete_Single_Entry_Body => + System_Tasking_Protected_Objects_Single_Entry, + RE_Exceptional_Complete_Single_Entry_Body => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Count_Entry => + System_Tasking_Protected_Objects_Single_Entry, + RE_Protected_Single_Entry_Caller => + System_Tasking_Protected_Objects_Single_Entry, + RE_Timed_Protected_Single_Entry_Call => + System_Tasking_Protected_Objects_Single_Entry, + + RE_Protected_Entry_Index => System_Tasking_Protected_Objects, + RE_Entry_Body => System_Tasking_Protected_Objects, + RE_Protection => System_Tasking_Protected_Objects, + RE_Initialize_Protection => System_Tasking_Protected_Objects, + RE_Finalize_Protection => System_Tasking_Protected_Objects, + RE_Lock => System_Tasking_Protected_Objects, + RE_Lock_Read_Only => System_Tasking_Protected_Objects, + RE_Unlock => System_Tasking_Protected_Objects, + + RE_Delay_Block => System_Tasking_Async_Delays, + RE_Timed_Out => System_Tasking_Async_Delays, + RE_Cancel_Async_Delay => System_Tasking_Async_Delays, + RE_Enqueue_Duration => System_Tasking_Async_Delays, + + RE_Enqueue_Calendar => + System_Tasking_Async_Delays_Enqueue_Calendar, + RE_Enqueue_RT => + System_Tasking_Async_Delays_Enqueue_RT, + + RE_Accept_Call => System_Tasking_Rendezvous, + RE_Accept_Trivial => System_Tasking_Rendezvous, + RE_Callable => System_Tasking_Rendezvous, + RE_Call_Simple => System_Tasking_Rendezvous, + RE_Cancel_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Requeue_Task_Entry => System_Tasking_Rendezvous, + RE_Requeue_Protected_To_Task_Entry => System_Tasking_Rendezvous, + RE_Complete_Rendezvous => System_Tasking_Rendezvous, + RE_Task_Count => System_Tasking_Rendezvous, + RE_Exceptional_Complete_Rendezvous => System_Tasking_Rendezvous, + RE_Selective_Wait => System_Tasking_Rendezvous, + RE_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Task_Entry_Caller => System_Tasking_Rendezvous, + RE_Timed_Task_Entry_Call => System_Tasking_Rendezvous, + RE_Timed_Selective_Wait => System_Tasking_Rendezvous, + + RE_Activate_Restricted_Tasks => System_Tasking_Restricted_Stages, + RE_Complete_Restricted_Activation => System_Tasking_Restricted_Stages, + RE_Create_Restricted_Task => System_Tasking_Restricted_Stages, + RE_Complete_Restricted_Task => System_Tasking_Restricted_Stages, + RE_Restricted_Terminated => System_Tasking_Restricted_Stages, + + RE_Abort_Tasks => System_Tasking_Stages, + RE_Activate_Tasks => System_Tasking_Stages, + RE_Complete_Activation => System_Tasking_Stages, + RE_Create_Task => System_Tasking_Stages, + RE_Complete_Task => System_Tasking_Stages, + RE_Free_Task => System_Tasking_Stages, + RE_Expunge_Unactivated_Tasks => System_Tasking_Stages, + RE_Terminated => System_Tasking_Stages); + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Procedure to initialize data structures used by RTE. Called at the + -- start of processing a new main source file. Must be called after + -- Initialize_Snames (since names it enters into name table must come + -- after names entered by Snames). + + function RTE (E : RE_Id) return Entity_Id; + -- Given the entity defined in the above tables, as identified by the + -- corresponding value in the RE_Id enumeration type, returns the Id + -- of the corresponding entity, first loading in (parsing, analyzing and + -- expanding) its spec if the unit has not already been loaded. If the + -- unit cannot be found, or if it does not contain the specified entity, + -- then an appropriate error message is output ("run-time configuration + -- error") and an Unrecoverable_Error exception is raised. + + function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean; + -- This function determines if the given entity corresponds to the entity + -- referenced by RE_Id. It is similar in effect to (Ent = RTE (E)) except + -- that the latter would unconditionally load the unit containing E. For + -- this call, if the unit is not loaded, then a result of False is returned + -- immediately, since obviously Ent cannot be the entity in question if the + -- corresponding unit has not been loaded. + + procedure Text_IO_Kludge (Nam : Node_Id); + -- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has + -- generic subpackages (e.g. Integer_IO). They really should be child + -- packages, and in GNAT, they *are* child packages. To maintain the + -- required compatibility, this routine is called for package renamings + -- and generic instantiations, with the simple name of the referenced + -- package. If Text_IO has been with'ed and if the simple name of Nam + -- matches one of the subpackages of Text_IO, then this subpackage is + -- with'ed automatically. The important result of this approach is that + -- Text_IO does not drag in all the code for the subpackages unless they + -- are used. Our test is a little crude, and could drag in stuff when it + -- is not necessary, but that doesn't matter. Wide_Text_IO is handled in + -- a similar manner. + + function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean; + -- Returns True if the given Nam is an Expanded Name, whose Prefix is + -- Ada, and whose selector is either Text_IO.xxx or Wide_Text_IO.xxx + -- where xxx is one of the subpackages of Text_IO that is specially + -- handled as described above for Text_IO_Kludge. + +end Rtsfind; |