--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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
+}
--- /dev/null
+/****************************************************************************
+ * *
+ * 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;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+/****************************************************************************
+ * *
+ * 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));
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / linaro-gcc.git / commitdiff