New Language: Ada

From-SVN: r45956

gcc/ada/par-ch11.adb

@@ -0,0 +1,246 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 1                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.22 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Sinfo.CN; use Sinfo.CN;
+
+separate (Par)
+package body Ch11 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Exception_Handler  return Node_Id;
+   function P_Exception_Choice   return Node_Id;
+
+   ---------------------------------
+   -- 11.1  Exception Declaration --
+   ---------------------------------
+
+   --  Parsed by P_Identifier_Declaration (3.3.1)
+
+   ------------------------------------------
+   -- 11.2  Handled Sequence Of Statements --
+   ------------------------------------------
+
+   --  HANDLED_SEQUENCE_OF_STATEMENTS ::=
+   --      SEQUENCE_OF_STATEMENTS
+   --    [exception
+   --      EXCEPTION_HANDLER
+   --      {EXCEPTION_HANDLER}]
+
+   --  Error_Recovery : Cannot raise Error_Resync
+
+   function P_Handled_Sequence_Of_Statements return Node_Id is
+      Handled_Stmt_Seq_Node : Node_Id;
+
+   begin
+      Handled_Stmt_Seq_Node :=
+        New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr);
+      Set_Statements
+        (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq));
+
+      if Token = Tok_Exception then
+         Scan; -- past EXCEPTION
+         Set_Exception_Handlers
+           (Handled_Stmt_Seq_Node, Parse_Exception_Handlers);
+      end if;
+
+      return Handled_Stmt_Seq_Node;
+   end P_Handled_Sequence_Of_Statements;
+
+   -----------------------------
+   -- 11.2  Exception Handler --
+   -----------------------------
+
+   --  EXCEPTION_HANDLER ::=
+   --    when [CHOICE_PARAMETER_SPECIFICATION :]
+   --      EXCEPTION_CHOICE {| EXCEPTION_CHOICE} =>
+   --        SEQUENCE_OF_STATEMENTS
+
+   --  CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Exception_Handler return Node_Id is
+      Scan_State        : Saved_Scan_State;
+      Handler_Node      : Node_Id;
+      Choice_Param_Node : Node_Id;
+
+   begin
+      Handler_Node := New_Node (N_Exception_Handler, Token_Ptr);
+      T_When;
+
+      --  Test for possible choice parameter present
+
+      if Token = Tok_Identifier then
+         Choice_Param_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at identifier
+         Scan; -- past identifier
+
+         if Token = Tok_Colon then
+            if Ada_83 then
+               Error_Msg_SP ("(Ada 83) choice parameter not allowed!");
+            end if;
+
+            Scan; -- past :
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         elsif Token = Tok_Others then
+            Error_Msg_AP ("missing "":""");
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         else
+            Restore_Scan_State (Scan_State); -- to identifier
+         end if;
+      end if;
+
+      --  Loop through exception choices
+
+      Set_Exception_Choices (Handler_Node, New_List);
+
+      loop
+         Append (P_Exception_Choice, Exception_Choices (Handler_Node));
+         exit when Token /= Tok_Vertical_Bar;
+         Scan; -- past vertical bar
+      end loop;
+
+      TF_Arrow;
+      Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
+      return Handler_Node;
+   end P_Exception_Handler;
+
+   ------------------------------------------
+   -- 11.2  Choice Parameter Specification --
+   ------------------------------------------
+
+   --  Parsed by P_Exception_Handler (11.2)
+
+   ----------------------------
+   -- 11.2  Exception Choice --
+   ----------------------------
+
+   --  EXCEPTION_CHOICE ::= exception_NAME | others
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs, then the
+   --  scan pointer is advanced to the next arrow or vertical bar or semicolon.
+
+   function P_Exception_Choice return Node_Id is
+   begin
+
+      if Token = Tok_Others then
+         Scan; -- past OTHERS
+         return New_Node (N_Others_Choice, Prev_Token_Ptr);
+
+      else
+         return P_Name; -- exception name
+      end if;
+
+   exception
+      when Error_Resync =>
+         Resync_Choice;
+         return Error;
+   end P_Exception_Choice;
+
+   ---------------------------
+   -- 11.3  Raise Statement --
+   ---------------------------
+
+   --  RAISE_STATEMENT ::= raise [exception_NAME];
+
+   --  The caller has verified that the initial token is RAISE
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Raise_Statement return Node_Id is
+      Raise_Node : Node_Id;
+
+   begin
+      Raise_Node := New_Node (N_Raise_Statement, Token_Ptr);
+      Scan; -- past RAISE
+
+      if Token /= Tok_Semicolon then
+         Set_Name (Raise_Node, P_Name);
+      end if;
+
+      TF_Semicolon;
+      return Raise_Node;
+   end P_Raise_Statement;
+
+   ------------------------------
+   -- Parse_Exception_Handlers --
+   ------------------------------
+
+   --  This routine scans out a list of exception handlers appearing in a
+   --  construct as:
+
+   --    exception
+   --      EXCEPTION_HANDLER {EXCEPTION_HANDLER}
+
+   --  The caller has scanned out the EXCEPTION keyword
+
+   --  Control returns after scanning the last exception handler, presumably
+   --  at the keyword END, but this is not checked in this routine.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function Parse_Exception_Handlers return List_Id is
+      Handler       : Node_Id;
+      Handlers_List : List_Id;
+      Pragmas_List  : List_Id;
+
+   begin
+      Handlers_List := New_List;
+      P_Pragmas_Opt (Handlers_List);
+
+      if Token = Tok_End then
+         Error_Msg_SC ("must have at least one exception handler!");
+
+      else
+         loop
+            Handler := P_Exception_Handler;
+            Pragmas_List := No_List;
+            Append (Handler, Handlers_List);
+
+            --  Note: no need to check for pragmas here. Although the
+            --  syntax officially allows them in this position, they
+            --  will have been swallowed up as part of the statement
+            --  sequence of the handler we just scanned out.
+
+            exit when Token /= Tok_When;
+         end loop;
+      end if;
+
+      return Handlers_List;
+   end Parse_Exception_Handlers;
+
+end Ch11;

gcc/ada/par-ch12.adb

@@ -0,0 +1,882 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 2                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.46 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch12 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Formal_Derived_Type_Definition           return Node_Id;
+   function P_Formal_Discrete_Type_Definition          return Node_Id;
+   function P_Formal_Fixed_Point_Definition            return Node_Id;
+   function P_Formal_Floating_Point_Definition         return Node_Id;
+   function P_Formal_Modular_Type_Definition           return Node_Id;
+   function P_Formal_Package_Declaration               return Node_Id;
+   function P_Formal_Private_Type_Definition           return Node_Id;
+   function P_Formal_Signed_Integer_Type_Definition    return Node_Id;
+   function P_Formal_Subprogram_Declaration            return Node_Id;
+   function P_Formal_Type_Declaration                  return Node_Id;
+   function P_Formal_Type_Definition                   return Node_Id;
+   function P_Generic_Association                      return Node_Id;
+
+   procedure P_Formal_Object_Declarations (Decls : List_Id);
+   --  Scans one or more formal object declarations and appends them to
+   --  Decls. Scans more than one declaration only in the case where the
+   --  source has a declaration with multiple defining identifiers.
+
+   --------------------------------
+   -- 12.1  Generic (also 8.5.5) --
+   --------------------------------
+
+   --  This routine parses either one of the forms of a generic declaration
+   --  or a generic renaming declaration.
+
+   --  GENERIC_DECLARATION ::=
+   --    GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION
+
+   --  GENERIC_SUBPROGRAM_DECLARATION ::=
+   --    GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION;
+
+   --  GENERIC_PACKAGE_DECLARATION ::=
+   --    GENERIC_FORMAL_PART PACKAGE_SPECIFICATION;
+
+   --  GENERIC_FORMAL_PART ::=
+   --    generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE}
+
+   --  GENERIC_RENAMING_DECLARATION ::=
+   --    generic package DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_package_NAME
+   --  | generic procedure DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_procedure_NAME
+   --  | generic function DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_function_NAME
+
+   --  GENERIC_FORMAL_PARAMETER_DECLARATION ::=
+   --    FORMAL_OBJECT_DECLARATION
+   --  | FORMAL_TYPE_DECLARATION
+   --  | FORMAL_SUBPROGRAM_DECLARATION
+   --  | FORMAL_PACKAGE_DECLARATION
+
+   --  The caller has checked that the initial token is GENERIC
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Generic return Node_Id is
+      Gen_Sloc   : constant Source_Ptr := Token_Ptr;
+      Gen_Decl   : Node_Id;
+      Decl_Node  : Node_Id;
+      Decls      : List_Id;
+      Def_Unit   : Node_Id;
+      Ren_Token  : Token_Type;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Scan; -- past GENERIC
+
+      if Token = Tok_Private then
+         Error_Msg_SC ("PRIVATE goes before GENERIC, not after");
+         Scan; -- past junk PRIVATE token
+      end if;
+
+      Save_Scan_State (Scan_State); -- at token past GENERIC
+
+      --  Check for generic renaming declaration case
+
+      if Token = Tok_Package
+        or else Token = Tok_Function
+        or else Token = Tok_Procedure
+      then
+         Ren_Token := Token;
+         Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE
+
+         if Token = Tok_Identifier then
+            Def_Unit := P_Defining_Program_Unit_Name;
+
+            Check_Misspelling_Of (Tok_Renames);
+
+            if Token = Tok_Renames then
+               if Ren_Token = Tok_Package then
+                  Decl_Node := New_Node
+                    (N_Generic_Package_Renaming_Declaration, Gen_Sloc);
+
+               elsif Ren_Token = Tok_Procedure then
+                  Decl_Node := New_Node
+                    (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc);
+
+               else -- Ren_Token = Tok_Function then
+                  Decl_Node := New_Node
+                    (N_Generic_Function_Renaming_Declaration, Gen_Sloc);
+               end if;
+
+               Scan; -- past RENAMES
+               Set_Defining_Unit_Name (Decl_Node, Def_Unit);
+               Set_Name (Decl_Node, P_Name);
+               TF_Semicolon;
+               return Decl_Node;
+            end if;
+         end if;
+      end if;
+
+      --  Fall through if this is *not* a generic renaming declaration
+
+      Restore_Scan_State (Scan_State);
+      Decls := New_List;
+
+      --  Loop through generic parameter declarations and use clauses
+
+      Decl_Loop : loop
+         P_Pragmas_Opt (Decls);
+         Ignore (Tok_Private);
+
+         if Token = Tok_Use then
+            Append (P_Use_Clause, Decls);
+         else
+            --  Parse a generic parameter declaration
+
+            if Token = Tok_Identifier then
+               P_Formal_Object_Declarations (Decls);
+
+            elsif Token = Tok_Type then
+               Append (P_Formal_Type_Declaration, Decls);
+
+            elsif Token = Tok_With then
+               Scan; -- past WITH
+
+               if Token = Tok_Package then
+                  Append (P_Formal_Package_Declaration, Decls);
+
+               elsif Token = Tok_Procedure or Token = Tok_Function then
+                  Append (P_Formal_Subprogram_Declaration, Decls);
+
+               else
+                  Error_Msg_BC
+                    ("FUNCTION, PROCEDURE or PACKAGE expected here");
+                  Resync_Past_Semicolon;
+               end if;
+
+            elsif Token = Tok_Subtype then
+               Error_Msg_SC ("subtype declaration not allowed " &
+                                "as generic parameter declaration!");
+               Resync_Past_Semicolon;
+
+            else
+               exit Decl_Loop;
+            end if;
+         end if;
+
+      end loop Decl_Loop;
+
+      --  Generic formal part is scanned, scan out subprogram or package spec
+
+      if Token = Tok_Package then
+         Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc);
+         Set_Specification (Gen_Decl, P_Package (Pf_Spcn));
+      else
+         Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
+         Set_Specification (Gen_Decl, P_Subprogram_Specification);
+         TF_Semicolon;
+      end if;
+
+      Set_Generic_Formal_Declarations (Gen_Decl, Decls);
+      return Gen_Decl;
+   end P_Generic;
+
+   -------------------------------
+   -- 12.1  Generic Declaration --
+   -------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ------------------------------------------
+   -- 12.1  Generic Subprogram Declaration --
+   ------------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ---------------------------------------
+   -- 12.1  Generic Package Declaration --
+   ---------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   -------------------------------
+   -- 12.1  Generic Formal Part --
+   -------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   -------------------------------------------------
+   -- 12.1   Generic Formal Parameter Declaration --
+   -------------------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ---------------------------------
+   -- 12.3  Generic Instantiation --
+   ---------------------------------
+
+   --  Generic package instantiation parsed by P_Package (7.1)
+   --  Generic procedure instantiation parsed by P_Subprogram (6.1)
+   --  Generic function instantiation parsed by P_Subprogram (6.1)
+
+   -------------------------------
+   -- 12.3  Generic Actual Part --
+   -------------------------------
+
+   --  GENERIC_ACTUAL_PART ::=
+   --    (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION})
+
+   --  Returns a list of generic associations, or Empty if none are present
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Generic_Actual_Part_Opt return List_Id is
+      Association_List : List_Id;
+
+   begin
+      --  Figure out if a generic actual part operation is present. Clearly
+      --  there is no generic actual part if the current token is semicolon
+
+      if Token = Tok_Semicolon then
+         return No_List;
+
+      --  If we don't have a left paren, then we have an error, and the job
+      --  is to figure out whether a left paren or semicolon was intended.
+      --  We assume a missing left paren (and hence a generic actual part
+      --  present) if the current token is not on a new line, or if it is
+      --  indented from the subprogram token. Otherwise assume missing
+      --  semicolon (which will be diagnosed by caller) and no generic part
+
+      elsif Token /= Tok_Left_Paren
+        and then Token_Is_At_Start_Of_Line
+        and then Start_Column <= Scope.Table (Scope.Last).Ecol
+      then
+         return No_List;
+
+      --  Otherwise we have a generic actual part (either a left paren is
+      --  present, or we have decided that there must be a missing left paren)
+
+      else
+         Association_List := New_List;
+         T_Left_Paren;
+
+         loop
+            Append (P_Generic_Association, Association_List);
+            exit when not Comma_Present;
+         end loop;
+
+         T_Right_Paren;
+         return Association_List;
+      end if;
+
+   end P_Generic_Actual_Part_Opt;
+
+   -------------------------------
+   -- 12.3  Generic Association --
+   -------------------------------
+
+   --  GENERIC_ASSOCIATION ::=
+   --    [generic_formal_parameter_SELECTOR_NAME =>]
+   --      EXPLICIT_GENERIC_ACTUAL_PARAMETER
+
+   --  EXPLICIT_GENERIC_ACTUAL_PARAMETER ::=
+   --    EXPRESSION      | variable_NAME   | subprogram_NAME
+   --  | entry_NAME      | SUBTYPE_MARK    | package_instance_NAME
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Generic_Association return Node_Id is
+      Scan_State         : Saved_Scan_State;
+      Param_Name_Node    : Node_Id;
+      Generic_Assoc_Node : Node_Id;
+
+   begin
+      Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr);
+
+      if Token in Token_Class_Desig then
+         Param_Name_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at designator
+         Scan; -- past simple name or operator symbol
+
+         if Token = Tok_Arrow then
+            Scan; -- past arrow
+            Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node);
+         else
+            Restore_Scan_State (Scan_State); -- to designator
+         end if;
+      end if;
+
+      Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, P_Expression);
+      return Generic_Assoc_Node;
+   end P_Generic_Association;
+
+   ---------------------------------------------
+   -- 12.3  Explicit Generic Actual Parameter --
+   ---------------------------------------------
+
+   --  Parsed by P_Generic_Association (12.3)
+
+   --------------------------------------
+   -- 12.4  Formal Object Declarations --
+   --------------------------------------
+
+   --  FORMAL_OBJECT_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST :
+   --      MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+
+   --  The caller has checked that the initial token is an identifier
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure P_Formal_Object_Declarations (Decls : List_Id) is
+      Decl_Node  : Node_Id;
+      Scan_State : Saved_Scan_State;
+      Num_Idents : Nat;
+      Ident      : Nat;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  This array holds the list of defining identifiers. The upper bound
+      --  of 4096 is intended to be essentially infinite, and we do not even
+      --  bother to check for it being exceeded.
+
+   begin
+      Idents (1) := P_Defining_Identifier;
+      Num_Idents := 1;
+
+      while Comma_Present loop
+         Num_Idents := Num_Idents + 1;
+         Idents (Num_Idents) := P_Defining_Identifier;
+      end loop;
+
+      T_Colon;
+
+      --  If there are multiple identifiers, we repeatedly scan the
+      --  type and initialization expression information by resetting
+      --  the scan pointer (so that we get completely separate trees
+      --  for each occurrence).
+
+      if Num_Idents > 1 then
+         Save_Scan_State (Scan_State);
+      end if;
+
+      --  Loop through defining identifiers in list
+
+      Ident := 1;
+      Ident_Loop : loop
+         Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr);
+         Set_Defining_Identifier (Decl_Node, Idents (Ident));
+         P_Mode (Decl_Node);
+         Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync);
+         No_Constraint;
+         Set_Expression (Decl_Node, Init_Expr_Opt);
+
+         if Ident > 1 then
+            Set_Prev_Ids (Decl_Node, True);
+         end if;
+
+         if Ident < Num_Idents then
+            Set_More_Ids (Decl_Node, True);
+         end if;
+
+         Append (Decl_Node, Decls);
+
+         exit Ident_Loop when Ident = Num_Idents;
+         Ident := Ident + 1;
+         Restore_Scan_State (Scan_State);
+      end loop Ident_Loop;
+
+      TF_Semicolon;
+   end P_Formal_Object_Declarations;
+
+   -----------------------------------
+   -- 12.5  Formal Type Declaration --
+   -----------------------------------
+
+   --  FORMAL_TYPE_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+   --      is FORMAL_TYPE_DEFINITION;
+
+   --  The caller has checked that the initial token is TYPE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Type_Declaration return Node_Id is
+      Decl_Node  : Node_Id;
+
+   begin
+      Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr);
+      Scan; -- past TYPE
+      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
+
+      if P_Unknown_Discriminant_Part_Opt then
+         Set_Unknown_Discriminants_Present (Decl_Node, True);
+      else
+         Set_Discriminant_Specifications
+           (Decl_Node, P_Known_Discriminant_Part_Opt);
+      end if;
+
+      T_Is;
+
+      Set_Formal_Type_Definition (Decl_Node, P_Formal_Type_Definition);
+      TF_Semicolon;
+      return Decl_Node;
+   end P_Formal_Type_Declaration;
+
+   ----------------------------------
+   -- 12.5  Formal Type Definition --
+   ----------------------------------
+
+   --  FORMAL_TYPE_DEFINITION ::=
+   --    FORMAL_PRIVATE_TYPE_DEFINITION
+   --  | FORMAL_DERIVED_TYPE_DEFINITION
+   --  | FORMAL_DISCRETE_TYPE_DEFINITION
+   --  | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION
+   --  | FORMAL_MODULAR_TYPE_DEFINITION
+   --  | FORMAL_FLOATING_POINT_DEFINITION
+   --  | FORMAL_ORDINARY_FIXED_POINT_DEFINITION
+   --  | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
+   --  | FORMAL_ARRAY_TYPE_DEFINITION
+   --  | FORMAL_ACCESS_TYPE_DEFINITION
+
+   --  FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
+
+   --  FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+
+   function P_Formal_Type_Definition return Node_Id is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token_Name = Name_Abstract then
+         Check_95_Keyword (Tok_Abstract, Tok_Tagged);
+      end if;
+
+      if Token_Name = Name_Tagged then
+         Check_95_Keyword (Tok_Tagged, Tok_Private);
+         Check_95_Keyword (Tok_Tagged, Tok_Limited);
+      end if;
+
+      case Token is
+
+         --  Mostly we can tell what we have from the initial token. The one
+         --  exception is ABSTRACT, where we have to scan ahead to see if we
+         --  have a formal derived type or a formal private type definition.
+
+         when Tok_Abstract =>
+            Save_Scan_State (Scan_State);
+            Scan; -- past ABSTRACT
+
+            if Token = Tok_New then
+               Restore_Scan_State (Scan_State); -- to ABSTRACT
+               return P_Formal_Derived_Type_Definition;
+
+            else
+               Restore_Scan_State (Scan_State); -- to ABSTRACT
+               return P_Formal_Private_Type_Definition;
+            end if;
+
+         when Tok_Private | Tok_Limited | Tok_Tagged =>
+            return P_Formal_Private_Type_Definition;
+
+         when Tok_New =>
+            return P_Formal_Derived_Type_Definition;
+
+         when Tok_Left_Paren =>
+            return P_Formal_Discrete_Type_Definition;
+
+         when Tok_Range =>
+            return P_Formal_Signed_Integer_Type_Definition;
+
+         when Tok_Mod =>
+            return P_Formal_Modular_Type_Definition;
+
+         when Tok_Digits =>
+            return P_Formal_Floating_Point_Definition;
+
+         when Tok_Delta =>
+            return P_Formal_Fixed_Point_Definition;
+
+         when Tok_Array =>
+            return P_Array_Type_Definition;
+
+         when Tok_Access =>
+            return P_Access_Type_Definition;
+
+         when Tok_Record =>
+            Error_Msg_SC ("record not allowed in generic type definition!");
+            Discard_Junk_Node (P_Record_Definition);
+            return Error;
+
+         when others =>
+            Error_Msg_BC ("expecting generic type definition here");
+            Resync_Past_Semicolon;
+            return Error;
+
+      end case;
+   end P_Formal_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.1  Formal Private Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_PRIVATE_TYPE_DEFINITION ::=
+   --    [[abstract] tagged] [limited] private
+
+   --  The caller has checked the initial token is PRIVATE, ABSTRACT,
+   --   TAGGED or LIMITED
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Private_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr);
+
+      if Token = Tok_Abstract then
+         Scan; -- past ABSTRACT
+
+         if Token_Name = Name_Tagged then
+            Check_95_Keyword (Tok_Tagged, Tok_Private);
+            Check_95_Keyword (Tok_Tagged, Tok_Limited);
+         end if;
+
+         if Token /= Tok_Tagged then
+            Error_Msg_SP ("ABSTRACT must be followed by TAGGED");
+         else
+            Set_Abstract_Present (Def_Node, True);
+         end if;
+      end if;
+
+      if Token = Tok_Tagged then
+         Set_Tagged_Present (Def_Node, True);
+         Scan; -- past TAGGED
+      end if;
+
+      if Token = Tok_Limited then
+         Set_Limited_Present (Def_Node, True);
+         Scan; -- past LIMITED
+      end if;
+
+      Set_Sloc (Def_Node, Token_Ptr);
+      T_Private;
+      return Def_Node;
+   end P_Formal_Private_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.1  Formal Derived Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_DERIVED_TYPE_DEFINITION ::=
+   --    [abstract] new SUBTYPE_MARK [with private]
+
+   --  The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Derived_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr);
+
+      if Token = Tok_Abstract then
+         Set_Abstract_Present (Def_Node);
+         Scan; -- past ABSTRACT
+      end if;
+
+      Scan; -- past NEW;
+      Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+      No_Constraint;
+
+      if Token = Tok_With then
+         Scan; -- past WITH
+         Set_Private_Present (Def_Node, True);
+         T_Private;
+      end if;
+
+      return Def_Node;
+   end P_Formal_Derived_Type_Definition;
+
+   ---------------------------------------------
+   -- 12.5.2  Formal Discrete Type Definition --
+   ---------------------------------------------
+
+   --  FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>)
+
+   --  The caller has checked the initial token is left paren
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Discrete_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr);
+      Scan; -- past left paren
+      T_Box;
+      T_Right_Paren;
+      return Def_Node;
+   end P_Formal_Discrete_Type_Definition;
+
+   ---------------------------------------------------
+   -- 12.5.2  Formal Signed Integer Type Definition --
+   ---------------------------------------------------
+
+   --  FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <>
+
+   --  The caller has checked the initial token is RANGE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Signed_Integer_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr);
+      Scan; -- past RANGE
+      T_Box;
+      return Def_Node;
+   end P_Formal_Signed_Integer_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.2  Formal Modular Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_MODULAR_TYPE_DEFINITION ::= mod <>
+
+   --  The caller has checked the initial token is MOD
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Modular_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Modular_Type_Definition, Token_Ptr);
+      Scan; -- past MOD
+      T_Box;
+      return Def_Node;
+   end P_Formal_Modular_Type_Definition;
+
+   ----------------------------------------------
+   -- 12.5.2  Formal Floating Point Definition --
+   ----------------------------------------------
+
+   --  FORMAL_FLOATING_POINT_DEFINITION ::= digits <>
+
+   --  The caller has checked the initial token is DIGITS
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Floating_Point_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Floating_Point_Definition, Token_Ptr);
+      Scan; -- past DIGITS
+      T_Box;
+      return Def_Node;
+   end P_Formal_Floating_Point_Definition;
+
+   -------------------------------------------
+   -- 12.5.2  Formal Fixed Point Definition --
+   -------------------------------------------
+
+   --  This routine parses either a formal ordinary fixed point definition
+   --  or a formal decimal fixed point definition:
+
+   --  FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <>
+
+   --  FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <>
+
+   --  The caller has checked the initial token is DELTA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Fixed_Point_Definition return Node_Id is
+      Def_Node   : Node_Id;
+      Delta_Sloc : Source_Ptr;
+
+   begin
+      Delta_Sloc := Token_Ptr;
+      Scan; -- past DELTA
+      T_Box;
+
+      if Token = Tok_Digits then
+         Def_Node :=
+           New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc);
+         Scan; -- past DIGITS
+         T_Box;
+      else
+         Def_Node :=
+           New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc);
+      end if;
+
+      return Def_Node;
+   end P_Formal_Fixed_Point_Definition;
+
+   ----------------------------------------------------
+   -- 12.5.2  Formal Ordinary Fixed Point Definition --
+   ----------------------------------------------------
+
+   --  Parsed by P_Formal_Fixed_Point_Definition (12.5.2)
+
+   ---------------------------------------------------
+   -- 12.5.2  Formal Decimal Fixed Point Definition --
+   ---------------------------------------------------
+
+   --  Parsed by P_Formal_Fixed_Point_Definition (12.5.2)
+
+   ------------------------------------------
+   -- 12.5.3  Formal Array Type Definition --
+   ------------------------------------------
+
+   --  Parsed by P_Formal_Type_Definition (12.5)
+
+   -------------------------------------------
+   -- 12.5.4  Formal Access Type Definition --
+   -------------------------------------------
+
+   --  Parsed by P_Formal_Type_Definition (12.5)
+
+   -----------------------------------------
+   -- 12.6  Formal Subprogram Declaration --
+   -----------------------------------------
+
+   --  FORMAL_SUBPROGRAM_DECLARATION ::=
+   --    with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT];
+
+   --  SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
+
+   --  DEFAULT_NAME ::= NAME
+
+   --  The caller has checked that the initial tokens are WITH FUNCTION or
+   --  WITH PROCEDURE, and the initial WITH has been scanned out.
+
+   --  Note: we separate this into two procedures because the name is allowed
+   --  to be an operator symbol for a function, but not for a procedure.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Subprogram_Declaration return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Subprogram_Declaration, Prev_Token_Ptr);
+      Set_Specification (Def_Node, P_Subprogram_Specification);
+
+      if Token = Tok_Is then
+         T_Is; -- past IS, skip extra IS or ";"
+
+         if Token = Tok_Box then
+            Set_Box_Present (Def_Node, True);
+            Scan; -- past <>
+
+         else
+            Set_Default_Name (Def_Node, P_Name);
+         end if;
+
+      end if;
+
+      T_Semicolon;
+      return Def_Node;
+   end P_Formal_Subprogram_Declaration;
+
+   ------------------------------
+   -- 12.6  Subprogram Default --
+   ------------------------------
+
+   --  Parsed by P_Formal_Procedure_Declaration (12.6)
+
+   ------------------------
+   -- 12.6  Default Name --
+   ------------------------
+
+   --  Parsed by P_Formal_Procedure_Declaration (12.6)
+
+   --------------------------------------
+   -- 12.7  Formal Package Declaration --
+   --------------------------------------
+
+   --  FORMAL_PACKAGE_DECLARATION ::=
+   --    with package DEFINING_IDENTIFIER
+   --      is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART;
+
+   --  FORMAL_PACKAGE_ACTUAL_PART ::=
+   --    (<>) | [GENERIC_ACTUAL_PART]
+
+   --  The caller has checked that the initial tokens are WITH PACKAGE,
+   --  and the initial WITH has been scanned out (so Token = Tok_Package).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Package_Declaration return Node_Id is
+      Def_Node : Node_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr);
+      Scan; -- past PACKAGE
+      Set_Defining_Identifier (Def_Node, P_Defining_Identifier);
+      T_Is;
+      T_New;
+      Set_Name (Def_Node, P_Qualified_Simple_Name);
+
+      if Token = Tok_Left_Paren then
+         Save_Scan_State (Scan_State); -- at the left paren
+         Scan; -- past the left paren
+
+         if Token = Tok_Box then
+            Set_Box_Present (Def_Node, True);
+            Scan; -- past box
+            T_Right_Paren;
+
+         else
+            Restore_Scan_State (Scan_State); -- to the left paren
+            Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt);
+         end if;
+      end if;
+
+      T_Semicolon;
+      return Def_Node;
+   end P_Formal_Package_Declaration;
+
+   --------------------------------------
+   -- 12.7  Formal Package Actual Part --
+   --------------------------------------
+
+   --  Parsed by P_Formal_Package_Declaration (12.7)
+
+end Ch12;

gcc/ada/par-ch13.adb

@@ -0,0 +1,441 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 3                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.34 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch13 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Component_Clause return Node_Id;
+   function P_Mod_Clause return Node_Id;
+
+   --------------------------------------------
+   -- 13.1  Representation Clause (also I.7) --
+   --------------------------------------------
+
+   --  REPRESENTATION_CLAUSE ::=
+   --    ATTRIBUTE_DEFINITION_CLAUSE
+   --  | ENUMERATION_REPRESENTATION_CLAUSE
+   --  | RECORD_REPRESENTATION_CLAUSE
+   --  | AT_CLAUSE
+
+   --  ATTRIBUTE_DEFINITION_CLAUSE ::=
+   --    for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION;
+   --  | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  ENUMERATION_REPRESENTATION_CLAUSE ::=
+   --    for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE;
+
+   --  ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE
+
+   --  RECORD_REPRESENTATION_CLAUSE ::=
+   --    for first_subtype_LOCAL_NAME use
+   --      record [MOD_CLAUSE]
+   --        {COMPONENT_CLAUSE}
+   --      end record;
+
+   --  Note: for now we allow only a direct name as the local name in the
+   --  above constructs. This probably needs changing later on ???
+
+   --  The caller has checked that the initial token is FOR
+
+   --  Error recovery: cannot raise Error_Resync, if an error occurs,
+   --  the scan is repositioned past the next semicolon.
+
+   function P_Representation_Clause return Node_Id is
+      For_Loc         : Source_Ptr;
+      Name_Node       : Node_Id;
+      Prefix_Node     : Node_Id;
+      Attr_Name       : Name_Id;
+      Identifier_Node : Node_Id;
+      Rep_Clause_Node : Node_Id;
+      Expr_Node       : Node_Id;
+      Record_Items    : List_Id;
+
+   begin
+      For_Loc := Token_Ptr;
+      Scan; -- past FOR
+
+      --  Note that the name in a representation clause is always a simple
+      --  name, even in the attribute case, see AI-300 which made this so!
+
+      Identifier_Node := P_Identifier;
+
+      --  Check case of qualified name to give good error message
+
+      if Token = Tok_Dot then
+         Error_Msg_SC
+            ("representation clause requires simple name!");
+
+         loop
+            exit when Token /= Tok_Dot;
+            Scan; -- past dot
+            Discard_Junk_Node (P_Identifier);
+         end loop;
+      end if;
+
+      --  Attribute Definition Clause
+
+      if Token = Tok_Apostrophe then
+
+         --  Allow local names of the form a'b'.... This enables
+         --  us to parse class-wide streams attributes correctly.
+
+         Name_Node := Identifier_Node;
+         while Token = Tok_Apostrophe loop
+
+            Scan; -- past apostrophe
+
+            Identifier_Node := Token_Node;
+            Attr_Name := No_Name;
+
+            if Token = Tok_Identifier then
+               Attr_Name := Token_Name;
+
+               if not Is_Attribute_Name (Attr_Name) then
+                  Signal_Bad_Attribute;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (False);
+               end if;
+
+            --  Here for case of attribute designator is not an identifier
+
+            else
+               if Token = Tok_Delta then
+                  Attr_Name := Name_Delta;
+
+               elsif Token = Tok_Digits then
+                  Attr_Name := Name_Digits;
+
+               elsif Token = Tok_Access then
+                  Attr_Name := Name_Access;
+
+               else
+                  Error_Msg_AP ("attribute designator expected");
+                  raise Error_Resync;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (True);
+               end if;
+            end if;
+
+            --  We come here with an OK attribute scanned, and the
+            --  corresponding Attribute identifier node stored in Ident_Node.
+
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Attribute_Name (Name_Node, Attr_Name);
+            Scan;
+         end loop;
+
+         Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc);
+         Set_Name (Rep_Clause_Node, Prefix_Node);
+         Set_Chars (Rep_Clause_Node, Attr_Name);
+         T_Use;
+
+         Expr_Node := P_Expression_No_Right_Paren;
+         Check_Simple_Expression_In_Ada_83 (Expr_Node);
+         Set_Expression (Rep_Clause_Node, Expr_Node);
+
+      else
+         TF_Use;
+         Rep_Clause_Node := Empty;
+
+         --  AT follows USE (At Clause)
+
+         if Token = Tok_At then
+            Scan; -- past AT
+            Rep_Clause_Node := New_Node (N_At_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+            Expr_Node := P_Expression_No_Right_Paren;
+            Check_Simple_Expression_In_Ada_83 (Expr_Node);
+            Set_Expression (Rep_Clause_Node, Expr_Node);
+
+         --  RECORD follows USE (Record Representation Clause)
+
+         elsif Token = Tok_Record then
+            Record_Items := P_Pragmas_Opt;
+            Rep_Clause_Node :=
+              New_Node (N_Record_Representation_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+
+            Push_Scope_Stack;
+            Scope.Table (Scope.Last).Etyp := E_Record;
+            Scope.Table (Scope.Last).Ecol := Start_Column;
+            Scope.Table (Scope.Last).Sloc := Token_Ptr;
+            Scan; -- past RECORD
+            Record_Items := P_Pragmas_Opt;
+
+            --  Possible Mod Clause
+
+            if Token = Tok_At then
+               Set_Mod_Clause (Rep_Clause_Node, P_Mod_Clause);
+               Set_Pragmas_Before (Mod_Clause (Rep_Clause_Node), Record_Items);
+               Record_Items := P_Pragmas_Opt;
+            end if;
+
+            if No (Record_Items) then
+               Record_Items := New_List;
+            end if;
+
+            Set_Component_Clauses (Rep_Clause_Node, Record_Items);
+
+            --  Loop through component clauses
+
+            loop
+               if Token not in Token_Class_Name then
+                  exit when Check_End;
+               end if;
+
+               Append (P_Component_Clause, Record_Items);
+               P_Pragmas_Opt (Record_Items);
+            end loop;
+
+         --  Left paren follows USE (Enumeration Representation Clause)
+
+         elsif Token = Tok_Left_Paren then
+            Rep_Clause_Node :=
+              New_Node (N_Enumeration_Representation_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+            Set_Array_Aggregate (Rep_Clause_Node, P_Aggregate);
+
+         --  Some other token follows FOR (invalid representation clause)
+
+         else
+            Error_Msg_SC ("invalid representation clause");
+            raise Error_Resync;
+         end if;
+      end if;
+
+      TF_Semicolon;
+      return Rep_Clause_Node;
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         return Error;
+
+   end P_Representation_Clause;
+
+   ----------------------
+   -- 13.1  Local Name --
+   ----------------------
+
+   --  Local name is always parsed by its parent. In the case of its use in
+   --  pragmas, the check for a local name is handled in Par.Prag and allows
+   --  all the possible forms of local name. For the uses in chapter 13, we
+   --  currently only allow a direct name, but this should probably change???
+
+   ---------------------------
+   -- 13.1  At Clause (I.7) --
+   ---------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------------
+   -- 13.3  Attribute Definition Clause --
+   ---------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------------------
+   -- 13.4  Enumeration Representation Clause --
+   ---------------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------
+   -- 13.4  Enumeration Aggregate --
+   ---------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ------------------------------------------
+   -- 13.5.1  Record Representation Clause --
+   ------------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ------------------------------
+   -- 13.5.1  Mod Clause (I.8) --
+   ------------------------------
+
+   --  MOD_CLAUSE ::= at mod static_EXPRESSION;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  The caller has checked that the initial Token is AT
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  Note: the caller is responsible for setting the Pragmas_Before field
+
+   function P_Mod_Clause return Node_Id is
+      Mod_Node  : Node_Id;
+      Expr_Node : Node_Id;
+
+   begin
+      Mod_Node := New_Node (N_Mod_Clause, Token_Ptr);
+      Scan; -- past AT
+      T_Mod;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Expression (Mod_Node, Expr_Node);
+      TF_Semicolon;
+      return Mod_Node;
+   end P_Mod_Clause;
+
+   ------------------------------
+   -- 13.5.1  Component Clause --
+   ------------------------------
+
+   --  COMPONENT_CLAUSE ::=
+   --    COMPONENT_CLAUSE_COMPONENT_NAME at POSITION
+   --      range FIRST_BIT .. LAST_BIT;
+
+   --  COMPONENT_CLAUSE_COMPONENT_NAME ::=
+   --    component_DIRECT_NAME
+   --  | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+   --  | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+
+   --  POSITION ::= static_EXPRESSION
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  FIRST_BIT ::= static_SIMPLE_EXPRESSION
+   --  LAST_BIT ::= static_SIMPLE_EXPRESSION
+
+   --  Note: the AARM V2.0 grammar has an error at this point, it uses
+   --  EXPRESSION instead of SIMPLE_EXPRESSION for FIRST_BIT and LAST_BIT
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Component_Clause return Node_Id is
+      Component_Node : Node_Id;
+      Comp_Name      : Node_Id;
+      Expr_Node      : Node_Id;
+
+   begin
+      Component_Node := New_Node (N_Component_Clause, Token_Ptr);
+      Comp_Name := P_Name;
+
+      if Nkind (Comp_Name) = N_Identifier
+        or else Nkind (Comp_Name) = N_Attribute_Reference
+      then
+         Set_Component_Name (Component_Node, Comp_Name);
+      else
+         Error_Msg_N
+           ("component name must be direct name or attribute", Comp_Name);
+         Set_Component_Name (Component_Node, Error);
+      end if;
+
+      Set_Sloc (Component_Node, Token_Ptr);
+      T_At;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Position (Component_Node, Expr_Node);
+      T_Range;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_First_Bit (Component_Node, Expr_Node);
+      T_Dot_Dot;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Last_Bit (Component_Node, Expr_Node);
+      TF_Semicolon;
+      return Component_Node;
+   end P_Component_Clause;
+
+   ----------------------
+   -- 13.5.1  Position --
+   ----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   -----------------------
+   -- 13.5.1  First Bit --
+   -----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   ----------------------
+   -- 13.5.1  Last Bit --
+   ----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   --------------------------
+   -- 13.8  Code Statement --
+   --------------------------
+
+   --  CODE_STATEMENT ::= QUALIFIED_EXPRESSION
+
+   --  On entry the caller has scanned the SUBTYPE_MARK (passed in as the
+   --  single argument, and the scan points to the apostrophe.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id is
+      Node1 : Node_Id;
+
+   begin
+      Scan; -- past apostrophe
+
+      --  If left paren, then we have a possible code statement
+
+      if Token = Tok_Left_Paren then
+         Node1 := New_Node (N_Code_Statement, Sloc (Subtype_Mark));
+         Set_Expression (Node1, P_Qualified_Expression (Subtype_Mark));
+         TF_Semicolon;
+         return Node1;
+
+      --  Otherwise we have an illegal range attribute. Note that P_Name
+      --  ensures that Token = Tok_Range is the only possibility left here.
+
+      else -- Token = Tok_Range
+         Error_Msg_SC ("RANGE attribute illegal here!");
+         raise Error_Resync;
+      end if;
+
+   end P_Code_Statement;
+
+end Ch13;

gcc/ada/par-ch2.adb

@@ -0,0 +1,405 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 2                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.35 $                             --
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch2 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Pragma_Argument_Association return Node_Id;
+
+   ---------------------
+   -- 2.3  Identifier --
+   ---------------------
+
+   --  IDENTIFIER ::= LETTER {[UNDERLINE] LETTER_OR_DIGIT}
+
+   --  LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT
+
+   --  An IDENTIFIER shall not be a reserved word
+
+   --  Error recovery: can raise Error_Resync (cannot return Error)
+
+   function P_Identifier return Node_Id is
+      Ident_Node : Node_Id;
+
+   begin
+      --  All set if we do indeed have an identifier
+
+      if Token = Tok_Identifier then
+         Ident_Node := Token_Node;
+         Scan; -- past Identifier
+         return Ident_Node;
+
+      --  If we have a reserved identifier, manufacture an identifier with
+      --  a corresponding name after posting an appropriate error message
+
+      elsif Is_Reserved_Identifier then
+         Scan_Reserved_Identifier (Force_Msg => False);
+         Ident_Node := Token_Node;
+         Scan; -- past the node
+         return Ident_Node;
+
+      --  Otherwise we have junk that cannot be interpreted as an identifier
+
+      else
+         T_Identifier; -- to give message
+         raise Error_Resync;
+      end if;
+   end P_Identifier;
+
+   --------------------------
+   -- 2.3  Letter Or Digit --
+   --------------------------
+
+   --  Parsed by P_Identifier (2.3)
+
+   --------------------------
+   -- 2.4  Numeric Literal --
+   --------------------------
+
+   --  NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL
+
+   --  Numeric literal is returned by the scanner as either
+   --  Tok_Integer_Literal or Tok_Real_Literal
+
+   ----------------------------
+   -- 2.4.1  Decimal Literal --
+   ----------------------------
+
+   --  DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT]
+
+   --  Handled by scanner as part of numeric lIteral handing (see 2.4)
+
+   --------------------
+   -- 2.4.1  Numeral --
+   --------------------
+
+   --  NUMERAL ::= DIGIT {[UNDERLINE] DIGIT}
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ---------------------
+   -- 2.4.1  Exponent --
+   ---------------------
+
+   --  EXPONENT ::= E [+] NUMERAL | E - NUMERAL
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   --------------------------
+   -- 2.4.2  Based Literal --
+   --------------------------
+
+   --  BASED_LITERAL ::=
+   --   BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT]
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   -----------------
+   -- 2.4.2  Base --
+   -----------------
+
+   --  BASE ::= NUMERAL
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   --------------------------
+   -- 2.4.2  Based Numeral --
+   --------------------------
+
+   --  BASED_NUMERAL ::=
+   --    EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT}
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ---------------------------
+   -- 2.4.2  Extended Digit --
+   ---------------------------
+
+   --  EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ----------------------------
+   -- 2.5  Character Literal --
+   ----------------------------
+
+   --  CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
+
+   --  Handled by the scanner and returned as Tok_Character_Literal
+
+   -------------------------
+   -- 2.6  String Literal --
+   -------------------------
+
+   --  STRING LITERAL ::= "{STRING_ELEMENT}"
+
+   --  Handled by the scanner and returned as Tok_Character_Literal
+   --  or if the string looks like an operator as Tok_Operator_Symbol.
+
+   -------------------------
+   -- 2.6  String Element --
+   -------------------------
+
+   --  STRING_ELEMENT ::= "" | non-quotation_mark_GRAPHIC_CHARACTER
+
+   --  A STRING_ELEMENT is either a pair of quotation marks ("),
+   --  or a single GRAPHIC_CHARACTER other than a quotation mark.
+
+   --  Handled by scanner as part of string literal handling (see 2.4)
+
+   ------------------
+   -- 2.7  Comment --
+   ------------------
+
+   --  A COMMENT starts with two adjacent hyphens and extends up to the
+   --  end of the line. A COMMENT may appear on any line of a program.
+
+   --  Handled by the scanner which simply skips past encountered comments
+
+   -----------------
+   -- 2.8  Pragma --
+   -----------------
+
+   --  PRAGMA ::= pragma IDENTIFIER
+   --    [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})];
+
+   --  The caller has checked that the initial token is PRAGMA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  One special piece of processing is needed in this routine. As described
+   --  in the section on "Handling semicolon used in place of IS" in module
+   --  Parse, the parser detects the case of missing subprogram bodies to
+   --  allow recovery from this syntactic error. Pragma INTERFACE (and, for
+   --  Ada 95, pragma IMPORT) can appear in place of the body. The parser must
+   --  recognize the use of these two pragmas in this context, otherwise it
+   --  will think there are missing bodies, and try to change ; to IS, when
+   --  in fact the bodies ARE present, supplied by these pragmas.
+
+   function P_Pragma return Node_Id is
+
+      Interface_Check_Required : Boolean := False;
+      --  Set True if check of pragma INTERFACE is required
+
+      Import_Check_Required : Boolean := False;
+      --  Set True if check of pragma IMPORT is required
+
+      Arg_Count : Int := 0;
+      --  Number of argument associations processed
+
+      Pragma_Node   : Node_Id;
+      Pragma_Name   : Name_Id;
+      Semicolon_Loc : Source_Ptr;
+      Ident_Node    : Node_Id;
+      Assoc_Node    : Node_Id;
+
+   begin
+      Pragma_Node := New_Node (N_Pragma, Token_Ptr);
+      Scan; -- past PRAGMA
+      Pragma_Name := Token_Name;
+
+      if Style_Check then
+         Style.Check_Pragma_Name;
+      end if;
+
+      Ident_Node := P_Identifier;
+      Set_Chars (Pragma_Node, Pragma_Name);
+      Delete_Node (Ident_Node);
+
+      --  See if special INTERFACE/IMPORT check is required
+
+      if SIS_Entry_Active then
+         Interface_Check_Required := (Pragma_Name = Name_Interface);
+         Import_Check_Required    := (Pragma_Name = Name_Import);
+      else
+         Interface_Check_Required := False;
+         Import_Check_Required    := False;
+      end if;
+
+      --  Scan arguments. We assume that arguments are present if there is
+      --  a left paren, or if a semicolon is missing and there is another
+      --  token on the same line as the pragma name.
+
+      if Token = Tok_Left_Paren
+        or else (Token /= Tok_Semicolon
+                   and then not Token_Is_At_Start_Of_Line)
+      then
+         Set_Pragma_Argument_Associations (Pragma_Node, New_List);
+         T_Left_Paren;
+
+         loop
+            Arg_Count := Arg_Count + 1;
+            Assoc_Node := P_Pragma_Argument_Association;
+
+            if Arg_Count = 2
+              and then (Interface_Check_Required or else Import_Check_Required)
+            then
+               --  Here is where we cancel the SIS active status if this pragma
+               --  supplies a body for the currently active subprogram spec.
+
+               if Nkind (Expression (Assoc_Node)) in N_Direct_Name
+                 and then Chars (Expression (Assoc_Node)) = Chars (SIS_Labl)
+               then
+                  SIS_Entry_Active := False;
+               end if;
+            end if;
+
+            Append (Assoc_Node, Pragma_Argument_Associations (Pragma_Node));
+            exit when Token /= Tok_Comma;
+            Scan; -- past comma
+         end loop;
+
+         T_Right_Paren;
+      end if;
+
+      Semicolon_Loc := Token_Ptr;
+
+      if Token /= Tok_Semicolon then
+         T_Semicolon;
+         Resync_Past_Semicolon;
+      else
+         Scan; -- past semicolon
+      end if;
+
+      if Is_Pragma_Name (Chars (Pragma_Node)) then
+         return Par.Prag (Pragma_Node, Semicolon_Loc);
+
+      else
+         --  Unrecognized pragma, warning generated in Sem_Prag
+
+         return Pragma_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         return Error;
+
+   end P_Pragma;
+
+   --  This routine is called if a pragma is encountered in an inappropriate
+   --  position, the pragma is scanned out and control returns to continue.
+
+   --  The caller has checked that the initial token is pragma
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure P_Pragmas_Misplaced is
+   begin
+      while Token = Tok_Pragma loop
+         Error_Msg_SC ("pragma not allowed here");
+         Discard_Junk_Node (P_Pragma);
+      end loop;
+   end P_Pragmas_Misplaced;
+
+   --  This function is called to scan out an optional sequence of pragmas.
+   --  If no pragmas are found, then No_List is returned.
+
+   --  Error recovery: Cannot raise Error_Resync
+
+   function P_Pragmas_Opt return List_Id is
+      L : List_Id;
+
+   begin
+      if Token = Tok_Pragma then
+         L := New_List;
+         P_Pragmas_Opt (L);
+         return L;
+
+      else
+         return No_List;
+      end if;
+   end P_Pragmas_Opt;
+
+   --  This procedure is called to scan out an optional sequence of pragmas.
+   --  Any pragmas found are appended to the list provided as an argument.
+
+   --  Error recovery: Cannot raise Error_Resync
+
+   procedure P_Pragmas_Opt (List : List_Id) is
+      P : Node_Id;
+
+   begin
+      while Token = Tok_Pragma loop
+         P := P_Pragma;
+
+         if Chars (P) = Name_Assert or else Chars (P) = Name_Debug then
+            Error_Msg_Name_1 := Chars (P);
+            Error_Msg_N
+              ("pragma% must be in declaration/statement context", P);
+         else
+            Append (P, List);
+         end if;
+      end loop;
+   end P_Pragmas_Opt;
+
+   --------------------------------------
+   -- 2.8  Pragma_Argument Association --
+   --------------------------------------
+
+   --  PRAGMA_ARGUMENT_ASSOCIATION ::=
+   --    [pragma_argument_IDENTIFIER =>] NAME
+   --  | [pragma_argument_IDENTIFIER =>] EXPRESSION
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Pragma_Argument_Association return Node_Id is
+      Scan_State      : Saved_Scan_State;
+      Pragma_Arg_Node : Node_Id;
+      Identifier_Node : Node_Id;
+
+   begin
+      Pragma_Arg_Node := New_Node (N_Pragma_Argument_Association, Token_Ptr);
+      Set_Chars (Pragma_Arg_Node, No_Name);
+
+      if Token = Tok_Identifier then
+         Identifier_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at Identifier
+         Scan; -- past Identifier
+
+         if Token = Tok_Arrow then
+            Scan; -- past arrow
+            Set_Chars (Pragma_Arg_Node, Chars (Identifier_Node));
+            Delete_Node (Identifier_Node);
+         else
+            Restore_Scan_State (Scan_State); -- to Identifier
+         end if;
+      end if;
+
+      Set_Expression (Pragma_Arg_Node, P_Expression);
+      return Pragma_Arg_Node;
+
+   end P_Pragma_Argument_Association;
+
+end Ch2;

gcc/ada/par-ch7.adb

@@ -0,0 +1,282 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 7                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.29 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch7 is
+
+   ---------------------------------------------
+   -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
+   ---------------------------------------------
+
+   --  This routine scans out a package declaration, package body, or a
+   --  renaming declaration or generic instantiation starting with PACKAGE
+
+   --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
+
+   --  PACKAGE_SPECIFICATION ::=
+   --    package DEFINING_PROGRAM_UNIT_NAME is
+   --      {BASIC_DECLARATIVE_ITEM}
+   --    [private
+   --      {BASIC_DECLARATIVE_ITEM}]
+   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+   --  PACKAGE_BODY ::=
+   --    package body DEFINING_PROGRAM_UNIT_NAME is
+   --      DECLARATIVE_PART
+   --    [begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS]
+   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+   --  PACKAGE_RENAMING_DECLARATION ::=
+   --    package DEFINING_IDENTIFIER renames package_NAME;
+
+   --  PACKAGE_BODY_STUB ::=
+   --    package body DEFINING_IDENTIFIER is separate;
+
+   --  The value in Pf_Flags indicates which of these possible declarations
+   --  is acceptable to the caller:
+
+   --    Pf_Flags.Spcn                 Set if specification OK
+   --    Pf_Flags.Decl                 Set if declaration OK
+   --    Pf_Flags.Gins                 Set if generic instantiation OK
+   --    Pf_Flags.Pbod                 Set if proper body OK
+   --    Pf_Flags.Rnam                 Set if renaming declaration OK
+   --    Pf_Flags.Stub                 Set if body stub OK
+
+   --  If an inappropriate form is encountered, it is scanned out but an
+   --  error message indicating that it is appearing in an inappropriate
+   --  context is issued. The only possible settings for Pf_Flags are those
+   --  defined as constants in package Par.
+
+   --  Note: in all contexts where a package specification is required, there
+   --  is a terminating semicolon. This semicolon is scanned out in the case
+   --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
+   --  of the package specification (it's just too much trouble, and really
+   --  quite unnecessary, to deal with scanning out an END where the semicolon
+   --  after the END is not considered to be part of the END.
+
+   --  The caller has checked that the initial token is PACKAGE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
+      Package_Node       : Node_Id;
+      Specification_Node : Node_Id;
+      Name_Node          : Node_Id;
+      Package_Sloc       : Source_Ptr;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Lreq := False;
+
+      Package_Sloc := Token_Ptr;
+      Scan; -- past PACKAGE
+
+      if Token = Tok_Type then
+         Error_Msg_SC ("TYPE not allowed here");
+         Scan; -- past TYPE
+      end if;
+
+      --  Case of package body. Note that we demand a package body if that
+      --  is the only possibility (even if the BODY keyword is not present)
+
+      if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
+         if not Pf_Flags.Pbod then
+            Error_Msg_SC ("package body cannot appear here!");
+         end if;
+
+         T_Body;
+         Name_Node := P_Defining_Program_Unit_Name;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+         TF_Is;
+
+         if Separate_Present then
+            if not Pf_Flags.Stub then
+               Error_Msg_SC ("body stub cannot appear here!");
+            end if;
+
+            Scan; -- past SEPARATE
+            TF_Semicolon;
+            Pop_Scope_Stack;
+
+            Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
+            Set_Defining_Identifier (Package_Node, Name_Node);
+
+         else
+            Package_Node := New_Node (N_Package_Body, Package_Sloc);
+            Set_Defining_Unit_Name (Package_Node, Name_Node);
+            Parse_Decls_Begin_End (Package_Node);
+         end if;
+
+         return Package_Node;
+
+      --  Cases other than Package_Body
+
+      else
+         Name_Node := P_Defining_Program_Unit_Name;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+
+         --  Case of renaming declaration
+
+         Check_Misspelling_Of (Tok_Renames);
+
+         if Token = Tok_Renames then
+            if not Pf_Flags.Rnam then
+               Error_Msg_SC ("renaming declaration cannot appear here!");
+            end if;
+
+            Scan; -- past RENAMES;
+
+            Package_Node :=
+              New_Node (N_Package_Renaming_Declaration, Package_Sloc);
+            Set_Defining_Unit_Name (Package_Node, Name_Node);
+            Set_Name (Package_Node, P_Qualified_Simple_Name);
+
+            No_Constraint;
+            TF_Semicolon;
+            Pop_Scope_Stack;
+            return Package_Node;
+
+         else
+            TF_Is;
+
+            --  Case of generic instantiation
+
+            if Token = Tok_New then
+               if not Pf_Flags.Gins then
+                  Error_Msg_SC
+                     ("generic instantiation cannot appear here!");
+               end if;
+
+               Scan; -- past NEW
+
+               Package_Node :=
+                  New_Node (N_Package_Instantiation, Package_Sloc);
+               Set_Defining_Unit_Name (Package_Node, Name_Node);
+               Set_Name (Package_Node, P_Qualified_Simple_Name);
+               Set_Generic_Associations
+                 (Package_Node, P_Generic_Actual_Part_Opt);
+               TF_Semicolon;
+               Pop_Scope_Stack;
+
+            --  Case of package declaration or package specification
+
+            else
+               Specification_Node :=
+                 New_Node (N_Package_Specification, Package_Sloc);
+
+               Set_Defining_Unit_Name (Specification_Node, Name_Node);
+               Set_Visible_Declarations
+                 (Specification_Node, P_Basic_Declarative_Items);
+
+               if Token = Tok_Private then
+                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+
+                  if Style.RM_Column_Check then
+                     if Token_Is_At_Start_Of_Line
+                       and then Start_Column /= Error_Msg_Col
+                     then
+                        Error_Msg_SC
+                          ("(style) PRIVATE in wrong column, should be@");
+                     end if;
+                  end if;
+
+                  Scan; -- past PRIVATE
+                  Set_Private_Declarations
+                    (Specification_Node, P_Basic_Declarative_Items);
+
+                  --  Deal gracefully with multiple PRIVATE parts
+
+                  while Token = Tok_Private loop
+                     Error_Msg_SC
+                       ("only one private part allowed per package");
+                     Scan; -- past PRIVATE
+                     Append_List (P_Basic_Declarative_Items,
+                       Private_Declarations (Specification_Node));
+                  end loop;
+               end if;
+
+               if Pf_Flags = Pf_Spcn then
+                  Package_Node := Specification_Node;
+               else
+                  Package_Node :=
+                    New_Node (N_Package_Declaration, Package_Sloc);
+                  Set_Specification (Package_Node, Specification_Node);
+               end if;
+
+               if Token = Tok_Begin then
+                  Error_Msg_SC ("begin block not allowed in package spec");
+                  Scan; -- past BEGIN
+                  Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
+               end if;
+
+               End_Statements (Specification_Node);
+            end if;
+
+            return Package_Node;
+         end if;
+      end if;
+   end P_Package;
+
+   ------------------------------
+   -- 7.1  Package Declaration --
+   ------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   --------------------------------
+   -- 7.1  Package Specification --
+   --------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   -----------------------
+   -- 7.1  Package Body --
+   -----------------------
+
+   --  Parsed by P_Package (7.1)
+
+   -----------------------------------
+   -- 7.3  Private Type Declaration --
+   -----------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   ----------------------------------------
+   -- 7.3  Private Extension Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+end Ch7;

gcc/ada/par-ch8.adb

@@ -0,0 +1,175 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 8                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch8 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function P_Use_Package_Clause                           return Node_Id;
+   function P_Use_Type_Clause                              return Node_Id;
+
+   ---------------------
+   -- 8.4  Use Clause --
+   ---------------------
+
+   --  USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
+
+   --  The caller has checked that the initial token is USE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Clause return Node_Id is
+   begin
+      Scan; -- past USE
+
+      if Token = Tok_Type then
+         return P_Use_Type_Clause;
+
+      else
+         return P_Use_Package_Clause;
+      end if;
+   end P_Use_Clause;
+
+   -----------------------------
+   -- 8.4  Use Package Clause --
+   -----------------------------
+
+   --  USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
+
+   --  The caller has scanned out the USE keyword
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Package_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr);
+      Set_Names (Use_Node, New_List);
+
+      if Token = Tok_Package then
+         Error_Msg_SC ("PACKAGE should not appear here");
+         Scan; -- past PACKAGE
+      end if;
+
+      loop
+         Append (P_Qualified_Simple_Name, Names (Use_Node));
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Package_Clause;
+
+   --------------------------
+   -- 8.4  Use Type Clause --
+   --------------------------
+
+   --  USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK};
+
+   --  The caller has checked that the initial token is USE, scanned it out
+   --  and that the current token is TYPE.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Type_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr);
+      Set_Subtype_Marks (Use_Node, New_List);
+
+      if Ada_83 then
+         Error_Msg_SC ("(Ada 83) use type not allowed!");
+      end if;
+
+      Scan; -- past TYPE
+
+      loop
+         Append (P_Subtype_Mark, Subtype_Marks (Use_Node));
+         No_Constraint;
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Type_Clause;
+
+   -------------------------------
+   -- 8.5  Renaming Declaration --
+   -------------------------------
+
+   --  Object renaming declarations and exception renaming declarations
+   --  are parsed by P_Identifier_Declaration (3.3.1)
+
+   --  Subprogram renaming declarations are parsed by P_Subprogram (6.1)
+
+   --  Package renaming declarations are parsed by P_Package (7.1)
+
+   --  Generic renaming declarations are parsed by P_Generic (12.1)
+
+   ----------------------------------------
+   -- 8.5.1  Object Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   ----------------------------------------
+   -- 8.5.2  Exception Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   -----------------------------------------
+   -- 8.5.3  Package Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   --------------------------------------------
+   -- 8.5.4  Subprogram Renaming Declaration --
+   --------------------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -----------------------------------------
+   -- 8.5.2  Generic Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+end Ch8;

gcc/ada/par-labl.adb

@@ -0,0 +1,202 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L A B L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.18 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1998, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+procedure Labl is
+   Enclosing_Body_Or_Block : Node_Id;
+   --  Innermost enclosing body or block statement
+
+   Label_Decl_Node : Node_Id;
+   --  Implicit label declaration node
+
+   Defining_Ident_Node : Node_Id;
+   --  Defining identifier node for implicit label declaration
+
+   Next_Label_Elmt : Elmt_Id;
+   --  Next element on label element list
+
+   Label_Node : Node_Id;
+   --  Next label node to process
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
+   --  Find the innermost body or block that encloses N.
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id;
+   --  Find the innermost body that encloses N.
+
+   procedure Check_Distinct_Labels;
+   --  Checks the rule in RM-5.1(11), which requires distinct identifiers
+   --  for all the labels in a given body.
+
+   ---------------------------
+   -- Check_Distinct_Labels --
+   ---------------------------
+
+   procedure Check_Distinct_Labels is
+      Label_Id : constant Node_Id := Identifier (Label_Node);
+
+      Enclosing_Body : constant Node_Id :=
+                         Find_Enclosing_Body (Enclosing_Body_Or_Block);
+      --  Innermost enclosing body
+
+      Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
+      --  Next element on label element list
+
+      Other_Label : Node_Id;
+      --  Next label node to process
+
+   begin
+      --  Loop through all the labels, and if we find some other label
+      --  (i.e. not Label_Node) that has the same identifier,
+      --  and whose innermost enclosing body is the same,
+      --  then we have an error.
+
+      --  Note that in the worst case, this is quadratic in the number
+      --  of labels.  However, labels are not all that common, and this
+      --  is only called for explicit labels.
+      --  ???Nonetheless, the efficiency could be improved. For example,
+      --  call Labl for each body, rather than once per compilation.
+
+      while Present (Next_Other_Label_Elmt) loop
+         Other_Label := Node (Next_Other_Label_Elmt);
+
+         exit when Label_Node = Other_Label;
+
+         if Chars (Label_Id) = Chars (Identifier (Other_Label))
+           and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
+         then
+            Error_Msg_Sloc := Sloc (Other_Label);
+            Error_Msg_N ("& conflicts with label#", Label_Id);
+            exit;
+         end if;
+
+         Next_Elmt (Next_Other_Label_Elmt);
+      end loop;
+   end Check_Distinct_Labels;
+
+   -------------------------
+   -- Find_Enclosing_Body --
+   -------------------------
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id is
+      Result : Node_Id := N;
+
+   begin
+      --  This is the same as Find_Enclosing_Body_Or_Block, except
+      --  that we skip block statements and accept statements, instead
+      --  of stopping at them.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body;
+
+   ----------------------------------
+   -- Find_Enclosing_Body_Or_Block --
+   ----------------------------------
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
+      Result : Node_Id := Parent (N);
+
+   begin
+      --  Climb up the parent chain until we find a body or block.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Accept_Statement
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+        and then Nkind (Result) /= N_Block_Statement
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body_Or_Block;
+
+--  Start of processing for Par.Labl
+
+begin
+   Next_Label_Elmt := First_Elmt (Label_List);
+
+   while Present (Next_Label_Elmt) loop
+      Label_Node := Node (Next_Label_Elmt);
+
+      if not Comes_From_Source (Label_Node) then
+         goto Next_Label;
+      end if;
+
+      --  Find the innermost enclosing body or block, which is where
+      --  we need to implicitly declare this label
+
+      Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
+
+      --  If we didn't find a parent, then the label in question never got
+      --  hooked into a reasonable declarative part. This happens only in
+      --  error situations, and we simply ignore the entry (we aren't going
+      --  to get into the semantics in any case given the error).
+
+      if Present (Enclosing_Body_Or_Block) then
+         Check_Distinct_Labels;
+
+         --  Now create the implicit label declaration node and its
+         --  corresponding defining identifier. Note that the defining
+         --  occurrence of a label is the implicit label declaration that
+         --  we are creating. The label itself is an applied occurrence.
+
+         Label_Decl_Node :=
+           New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
+         Defining_Ident_Node :=
+           New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
+         Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
+         Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
+         Set_Label_Construct (Label_Decl_Node, Label_Node);
+
+         --  Now attach the implicit label declaration to the appropriate
+         --  declarative region, creating a declaration list if none exists
+
+         if not Present (Declarations (Enclosing_Body_Or_Block)) then
+            Set_Declarations (Enclosing_Body_Or_Block, New_List);
+         end if;
+
+         Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
+      end if;
+
+      <<Next_Label>>
+         Next_Elmt (Next_Label_Elmt);
+   end loop;
+
+end Labl;

gcc/ada/par-load.adb

@@ -0,0 +1,410 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L O A D                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.60 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The Par.Load procedure loads all units that are definitely required before
+--  it makes any sense at all to proceed with semantic analysis, including
+--  with'ed units, corresponding specs for bodies, parents of child specs,
+--  and parents of subunits. All these units are loaded and pointers installed
+--  in the tree as described in the spec of package Lib.
+
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib.Load; use Lib.Load;
+with Uname;    use Uname;
+with Namet;    use Namet;
+with Casing;   use Casing;
+with Opt;      use Opt;
+with Osint;    use Osint;
+with Sinput.L; use Sinput.L;
+with Stylesw;  use Stylesw;
+with Validsw;  use Validsw;
+
+separate (Par)
+procedure Load is
+
+   File_Name : File_Name_Type;
+   --  Name of file for current unit, derived from unit name
+
+   Cur_Unum : Unit_Number_Type := Current_Source_Unit;
+   --  Unit number of unit that we just finished parsing. Note that we need
+   --  to capture this, because Source_Unit will change as we parse new
+   --  source files in the multiple main source file case.
+
+   Curunit : constant Node_Id := Cunit (Cur_Unum);
+   --  Compilation unit node for current compilation unit
+
+   Loc : Source_Ptr := Sloc (Curunit);
+   --  Source location for compilation unit node
+
+   Save_Style_Check  : Boolean;
+   Save_Style_Checks : Style_Check_Options;
+   --  Save style check so it can be restored later
+
+   Save_Validity_Check  : Boolean;
+   Save_Validity_Checks : Validity_Check_Options;
+   --  Save validity check so it can be restored later
+
+   With_Cunit : Node_Id;
+   --  Compilation unit node for withed unit
+
+   Context_Node : Node_Id;
+   --  Next node in context items list
+
+   With_Node : Node_Id;
+   --  N_With_Clause node
+
+   Spec_Name : Unit_Name_Type;
+   --  Unit name of required spec
+
+   Body_Name : Unit_Name_Type;
+   --  Unit name of corresponding body
+
+   Unum : Unit_Number_Type;
+   --  Unit number of loaded unit
+
+   function Same_File_Name_Except_For_Case
+     (Expected_File_Name : File_Name_Type;
+      Actual_File_Name   : File_Name_Type)
+      return               Boolean;
+   --  Given an actual file name and an expected file name (the latter being
+   --  derived from the unit name), determine if they are the same except for
+   --  possibly different casing of letters.
+
+   function Same_File_Name_Except_For_Case
+     (Expected_File_Name : File_Name_Type;
+      Actual_File_Name   : File_Name_Type)
+      return               Boolean
+   is
+   begin
+      Get_Name_String (Actual_File_Name);
+      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+      declare
+         Lower_Case_Actual_File_Name : String (1 .. Name_Len);
+
+      begin
+         Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
+         Get_Name_String (Expected_File_Name);
+         Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+         return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
+      end;
+
+   end Same_File_Name_Except_For_Case;
+
+--  Start of processing for Load
+
+begin
+   --  Don't do any loads if we already had a fatal error
+
+   if Fatal_Error (Cur_Unum) then
+      return;
+   end if;
+
+   Save_Style_Check_Options (Save_Style_Checks);
+   Save_Style_Check := Opt.Style_Check;
+
+   Save_Validity_Check_Options (Save_Validity_Checks);
+   Save_Validity_Check := Opt.Validity_Checks_On;
+
+   --  If main unit, set Main_Unit_Entity (this will get overwritten if
+   --  the main unit has a separate spec, that happens later on in Load)
+
+   if Cur_Unum = Main_Unit then
+      Main_Unit_Entity := Cunit_Entity (Main_Unit);
+   end if;
+
+   --  If we have no unit name, things are seriously messed up by previous
+   --  errors, and we should not try to continue compilation.
+
+   if Unit_Name (Cur_Unum) = No_Name then
+      raise Unrecoverable_Error;
+   end if;
+
+   --  Next step, make sure that the unit name matches the file name
+   --  and issue a warning message if not. We only output this for the
+   --  main unit, since for other units it is more serious and is
+   --  caught in a separate test below.
+
+   File_Name :=
+     Get_File_Name
+       (Unit_Name (Cur_Unum),
+        Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit);
+
+   if Cur_Unum = Main_Unit
+     and then File_Name /= Unit_File_Name (Cur_Unum)
+     and then (File_Names_Case_Sensitive
+                or not Same_File_Name_Except_For_Case
+                         (File_Name, Unit_File_Name (Cur_Unum)))
+   then
+      Error_Msg_Name_1 := File_Name;
+      Error_Msg
+        ("?file name does not match unit name, should be{", Sloc (Curunit));
+   end if;
+
+   --  For units other than the main unit, the expected unit name is set and
+   --  must be the same as the actual unit name, or we are in big trouble, and
+   --  abandon the compilation since there are situations where this really
+   --  gets us into bad trouble (e.g. some subunit situations).
+
+   if Cur_Unum /= Main_Unit
+     and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
+   then
+      Loc := Error_Location (Cur_Unum);
+      Error_Msg_Name_1 := Unit_File_Name (Cur_Unum);
+      Get_Name_String (Error_Msg_Name_1);
+
+      --  Check for predefined file case
+
+      if Name_Len > 1
+        and then Name_Buffer (2) = '-'
+        and then (Name_Buffer (1) = 'a'
+                    or else
+                  Name_Buffer (1) = 's'
+                    or else
+                  Name_Buffer (1) = 'i'
+                    or else
+                  Name_Buffer (1) = 'g')
+      then
+         --  In the predefined file case, we know the user did not construct
+         --  their own package, but we got the wrong one. This means that the
+         --  name supplied by the user crunched to something we recognized,
+         --  but then the file did not contain the unit expected. Most likely
+         --  this is due to a misspelling, e.g.
+
+         --    with Ada.Calender;
+
+         --  This crunches to a-calend, which indeed contains the unit
+         --  Ada.Calendar, and we can diagnose the misspelling. This is
+         --  a simple heuristic, but it catches many common cases of
+         --  misspelling of predefined unit names without needing a full
+         --  list of them.
+
+         Error_Msg_Name_1 := Expected_Unit (Cur_Unum);
+         Error_Msg ("% is not a predefined library unit!", Loc);
+         Error_Msg_Name_1 := Unit_Name (Cur_Unum);
+         Error_Msg ("possible misspelling of %!", Loc);
+
+      --  Non-predefined file name case
+
+      else
+         Error_Msg ("file { does not contain expected unit!", Loc);
+         Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
+         Error_Msg ("expected unit $!", Loc);
+         Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
+         Error_Msg ("found unit $!", Loc);
+      end if;
+
+      raise Unrecoverable_Error;
+   end if;
+
+   --  If current unit is a body, load its corresponding spec
+
+   if Nkind (Unit (Curunit)) = N_Package_Body
+     or else Nkind (Unit (Curunit)) = N_Subprogram_Body
+   then
+      Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
+      Unum :=
+        Load_Unit
+          (Load_Name  => Spec_Name,
+           Required   => False,
+           Subunit    => False,
+           Error_Node => Curunit,
+           Corr_Body  => Cur_Unum);
+
+      --  If we successfully load the unit, then set the spec pointer. Once
+      --  again note that if the loaded unit has a fatal error, Load will
+      --  have set our Fatal_Error flag to propagate this condition.
+
+      if Unum /= No_Unit then
+         Set_Library_Unit (Curunit, Cunit (Unum));
+
+         --  If this is a separate spec for the main unit, then we reset
+         --  Main_Unit_Entity to point to the entity for this separate spec
+
+         if Cur_Unum = Main_Unit then
+            Main_Unit_Entity := Cunit_Entity (Unum);
+         end if;
+
+      --  If we don't find the spec, then if we have a subprogram body, we
+      --  are still OK, we just have a case of a body acting as its own spec
+
+      elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
+         Set_Acts_As_Spec (Curunit, True);
+         Set_Library_Unit (Curunit, Curunit);
+
+      --  Otherwise we do have an error, repeat the load request for the spec
+      --  with Required set True to generate an appropriate error message.
+
+      else
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => True,
+              Subunit    => False,
+              Error_Node => Curunit);
+         return;
+      end if;
+
+   --  If current unit is a child unit spec, load its parent
+
+   elsif Nkind (Unit (Curunit)) = N_Package_Declaration
+     or else Nkind (Unit (Curunit)) =  N_Subprogram_Declaration
+     or else Nkind (Unit (Curunit)) in N_Generic_Declaration
+     or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
+     or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
+   then
+      --  Turn style and validity checks off for parent unit
+
+      if not GNAT_Mode then
+         Reset_Style_Check_Options;
+         Reset_Validity_Check_Options;
+      end if;
+
+      Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
+
+      if Spec_Name /= No_Name then
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => True,
+              Subunit    => False,
+              Error_Node => Curunit);
+
+         if Unum /= No_Unit then
+            Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
+         end if;
+      end if;
+
+   --  If current unit is a subunit, then load its parent body
+
+   elsif Nkind (Unit (Curunit)) = N_Subunit then
+      Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
+      Unum :=
+        Load_Unit
+          (Load_Name  => Body_Name,
+           Required   => True,
+           Subunit    => True,
+           Error_Node => Name (Unit (Curunit)));
+
+      if Unum /= No_Unit then
+         Set_Library_Unit (Curunit, Cunit (Unum));
+      end if;
+
+   end if;
+
+   --  Now we load with'ed units, with style/validity checks turned off
+
+   if not GNAT_Mode then
+      Reset_Style_Check_Options;
+      Reset_Validity_Check_Options;
+   end if;
+
+   --  Loop through context items
+
+   Context_Node := First (Context_Items (Curunit));
+   while Present (Context_Node) loop
+
+      if Nkind (Context_Node) = N_With_Clause then
+         With_Node := Context_Node;
+         Spec_Name := Get_Unit_Name (With_Node);
+
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => False,
+              Subunit    => False,
+              Error_Node => With_Node,
+              Renamings  => True);
+
+         --  If we find the unit, then set spec pointer in the N_With_Clause
+         --  to point to the compilation unit for the spec. Remember that
+         --  the Load routine itself sets our Fatal_Error flag if the loaded
+         --  unit gets a fatal error, so we don't need to worry about that.
+
+         if Unum /= No_Unit then
+            Set_Library_Unit (With_Node, Cunit (Unum));
+
+         --  If the spec isn't found, then try finding the corresponding
+         --  body, since it is possible that we have a subprogram body
+         --  that is acting as a spec (since no spec is present).
+
+         else
+            Body_Name := Get_Body_Name (Spec_Name);
+            Unum :=
+              Load_Unit
+                (Load_Name  => Body_Name,
+                 Required   => False,
+                 Subunit    => False,
+                 Error_Node => With_Node,
+                 Renamings  => True);
+
+            --  If we got a subprogram body, then mark that we are using
+            --  the body as a spec in the file table, and set the spec
+            --  pointer in the N_With_Clause to point to the body entity.
+
+            if Unum /= No_Unit
+              and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
+            then
+               With_Cunit := Cunit (Unum);
+               Set_Library_Unit (With_Node, With_Cunit);
+               Set_Acts_As_Spec (With_Cunit, True);
+               Set_Library_Unit (With_Cunit, With_Cunit);
+
+            --  If we couldn't find the body, or if it wasn't a body spec
+            --  then we are in trouble. We make one more call to Load to
+            --  require the spec. We know it will fail of course, the
+            --  purpose is to generate the required error message (we prefer
+            --  that this message refer to the missing spec, not the body)
+
+            else
+               Unum :=
+                 Load_Unit
+                   (Load_Name  => Spec_Name,
+                    Required   => True,
+                    Subunit    => False,
+                    Error_Node => With_Node,
+                    Renamings  => True);
+
+               --  Here we create a dummy package unit for the missing unit
+
+               Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name);
+               Set_Library_Unit (With_Node, Cunit (Unum));
+            end if;
+         end if;
+      end if;
+
+      Next (Context_Node);
+   end loop;
+
+   --  Restore style/validity check mode for main unit
+
+   Set_Style_Check_Options (Save_Style_Checks);
+   Opt.Style_Check := Save_Style_Check;
+   Set_Validity_Check_Options (Save_Validity_Checks);
+   Opt.Validity_Checks_On := Save_Validity_Check;
+end Load;

gcc/ada/par-prag.adb

@@ -0,0 +1,950 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . P R A G                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.149 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Generally the parser checks the basic syntax of pragmas, but does not
+--  do specialized syntax checks for individual pragmas, these are deferred
+--  to semantic analysis time (see unit Sem_Prag). There are some pragmas
+--  which require recognition and either partial or complete processing
+--  during parsing, and this unit performs this required processing.
+
+with Fname.UF; use Fname.UF;
+with Osint;    use Osint;
+with Stringt;  use Stringt;
+with Stylesw;  use Stylesw;
+with Uintp;    use Uintp;
+with Uname;    use Uname;
+
+separate (Par)
+
+function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
+   Pragma_Name : constant Name_Id    := Chars (Pragma_Node);
+   Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
+   Arg_Count   : Nat;
+   Arg_Node    : Node_Id;
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Arg1 return Node_Id;
+   function Arg2 return Node_Id;
+   function Arg3 return Node_Id;
+   function Arg4 return Node_Id;
+   --  Obtain specified Pragma_Argument_Association. It is allowable to call
+   --  the routine for the argument one past the last present argument, but
+   --  that is the only case in which a non-present argument can be referenced.
+
+   procedure Check_Arg_Count (Required : Int);
+   --  Check argument count for pragma = Required.
+   --  If not give error and raise Error_Resync.
+
+   procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
+   --  Check the expression of the specified argument to make sure that it
+   --  is a string literal. If not give error and raise Error_Resync.
+
+   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id);
+   --  Check the expression of the specified argument to make sure that it
+   --  is an identifier which is either ON or OFF, and if not, then issue
+   --  an error message and raise Error_Resync.
+
+   procedure Check_No_Identifier (Arg : Node_Id);
+   --  Checks that the given argument does not have an identifier. If an
+   --  identifier is present, then an error message is issued, and
+   --  Error_Resync is raised.
+
+   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
+   --  Checks if the given argument has an identifier, and if so, requires
+   --  it to match the given identifier name. If there is a non-matching
+   --  identifier, then an error message is given and Error_Resync raised.
+
+   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id);
+   --  Same as Check_Optional_Identifier, except that the name is required
+   --  to be present and to match the given Id value.
+
+   ----------
+   -- Arg1 --
+   ----------
+
+   function Arg1 return Node_Id is
+   begin
+      return First (Pragma_Argument_Associations (Pragma_Node));
+   end Arg1;
+
+   ----------
+   -- Arg2 --
+   ----------
+
+   function Arg2 return Node_Id is
+   begin
+      return Next (Arg1);
+   end Arg2;
+
+   ----------
+   -- Arg3 --
+   ----------
+
+   function Arg3 return Node_Id is
+   begin
+      return Next (Arg2);
+   end Arg3;
+
+   ----------
+   -- Arg4 --
+   ----------
+
+   function Arg4 return Node_Id is
+   begin
+      return Next (Arg3);
+   end Arg4;
+
+   ---------------------
+   -- Check_Arg_Count --
+   ---------------------
+
+   procedure Check_Arg_Count (Required : Int) is
+   begin
+      if Arg_Count /= Required then
+         Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Count;
+
+   ----------------------------
+   -- Check_Arg_Is_On_Or_Off --
+   ----------------------------
+
+   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is
+      Argx : constant Node_Id := Expression (Arg);
+
+   begin
+      if Nkind (Expression (Arg)) /= N_Identifier
+        or else (Chars (Argx) /= Name_On
+                   and then
+                 Chars (Argx) /= Name_Off)
+      then
+         Error_Msg_Name_2 := Name_On;
+         Error_Msg_Name_3 := Name_Off;
+
+         Error_Msg
+           ("argument for pragma% must be% or%", Sloc (Argx));
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Is_On_Or_Off;
+
+   ---------------------------------
+   -- Check_Arg_Is_String_Literal --
+   ---------------------------------
+
+   procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
+   begin
+      if Nkind (Expression (Arg)) /= N_String_Literal then
+         Error_Msg
+           ("argument for pragma% must be string literal",
+             Sloc (Expression (Arg)));
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Is_String_Literal;
+
+   -------------------------
+   -- Check_No_Identifier --
+   -------------------------
+
+   procedure Check_No_Identifier (Arg : Node_Id) is
+   begin
+      if Chars (Arg) /= No_Name then
+         Error_Msg_N ("pragma% does not permit named arguments", Arg);
+         raise Error_Resync;
+      end if;
+   end Check_No_Identifier;
+
+   -------------------------------
+   -- Check_Optional_Identifier --
+   -------------------------------
+
+   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
+   begin
+      if Present (Arg) and then Chars (Arg) /= No_Name then
+         if Chars (Arg) /= Id then
+            Error_Msg_Name_2 := Id;
+            Error_Msg_N ("pragma% argument expects identifier%", Arg);
+         end if;
+      end if;
+   end Check_Optional_Identifier;
+
+   -------------------------------
+   -- Check_Required_Identifier --
+   -------------------------------
+
+   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is
+   begin
+      if Chars (Arg) /= Id then
+         Error_Msg_Name_2 := Id;
+         Error_Msg_N ("pragma% argument must have identifier%", Arg);
+      end if;
+   end Check_Required_Identifier;
+
+   ----------
+   -- Prag --
+   ----------
+
+begin
+   Error_Msg_Name_1 := Pragma_Name;
+
+   --  Count number of arguments. This loop also checks if any of the arguments
+   --  are Error, indicating a syntax error as they were parsed. If so, we
+   --  simply return, because we get into trouble with cascaded errors if we
+   --  try to perform our error checks on junk arguments.
+
+   Arg_Count := 0;
+
+   if Present (Pragma_Argument_Associations (Pragma_Node)) then
+      Arg_Node := Arg1;
+
+      while Arg_Node /= Empty loop
+         Arg_Count := Arg_Count + 1;
+
+         if Expression (Arg_Node) = Error then
+            return Error;
+         end if;
+
+         Next (Arg_Node);
+      end loop;
+   end if;
+
+   --  Remaining processing is pragma dependent
+
+   case Get_Pragma_Id (Pragma_Name) is
+
+      ------------
+      -- Ada_83 --
+      ------------
+
+      --  This pragma must be processed at parse time, since we want to set
+      --  the Ada 83 and Ada 95 switches properly at parse time to recognize
+      --  Ada 83 syntax or Ada 95 syntax as appropriate.
+
+      when Pragma_Ada_83 =>
+         Ada_83 := True;
+         Ada_95 := False;
+
+      ------------
+      -- Ada_95 --
+      ------------
+
+      --  This pragma must be processed at parse time, since we want to set
+      --  the Ada 83 and Ada_95 switches properly at parse time to recognize
+      --  Ada 83 syntax or Ada 95 syntax as appropriate.
+
+      when Pragma_Ada_95 =>
+         Ada_83 := False;
+         Ada_95 := True;
+
+      -----------
+      -- Debug --
+      -----------
+
+      --  pragma Debug (PROCEDURE_CALL_STATEMENT);
+
+      --  This has to be processed by the parser because of the very peculiar
+      --  form of the second parameter, which is syntactically from a formal
+      --  point of view a function call (since it must be an expression), but
+      --  semantically we treat it as a procedure call (which has exactly the
+      --  same syntactic form, so that's why we can get away with this!)
+
+      when Pragma_Debug =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+
+         declare
+            Expr : constant Node_Id := New_Copy (Expression (Arg1));
+
+         begin
+            if Nkind (Expr) /= N_Indexed_Component
+              and then Nkind (Expr) /= N_Function_Call
+              and then Nkind (Expr) /= N_Identifier
+              and then Nkind (Expr) /= N_Selected_Component
+            then
+               Error_Msg
+                 ("argument of pragma% is not procedure call", Sloc (Expr));
+               raise Error_Resync;
+            else
+               Set_Debug_Statement
+                 (Pragma_Node, P_Statement_Name (Expr));
+            end if;
+         end;
+
+      -------------------------------
+      -- Extensions_Allowed (GNAT) --
+      -------------------------------
+
+      --  pragma Extensions_Allowed (Off | On)
+
+      --  The processing for pragma Extensions_Allowed must be done at
+      --  parse time, since extensions mode may affect what is accepted.
+
+      when Pragma_Extensions_Allowed =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+         Check_Arg_Is_On_Or_Off (Arg1);
+         Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+      ----------------
+      -- List (2.8) --
+      ----------------
+
+      --  pragma List (Off | On)
+
+      --  The processing for pragma List must be done at parse time,
+      --  since a listing can be generated in parse only mode.
+
+      when Pragma_List =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+         Check_Arg_Is_On_Or_Off (Arg1);
+
+         --  We unconditionally make a List_On entry for the pragma, so that
+         --  in the List (Off) case, the pragma will print even in a region
+         --  of code with listing turned off (this is required!)
+
+         List_Pragmas.Increment_Last;
+         List_Pragmas.Table (List_Pragmas.Last) :=
+           (Ptyp => List_On, Ploc => Sloc (Pragma_Node));
+
+         --  Now generate the list off entry for pragma List (Off)
+
+         if Chars (Expression (Arg1)) = Name_Off then
+            List_Pragmas.Increment_Last;
+            List_Pragmas.Table (List_Pragmas.Last) :=
+              (Ptyp => List_Off, Ploc => Semi);
+         end if;
+
+      ----------------
+      -- Page (2.8) --
+      ----------------
+
+      --  pragma Page;
+
+      --  Processing for this pragma must be done at parse time, since a
+      --  listing can be generated in parse only mode with semantics off.
+
+      when Pragma_Page =>
+         Check_Arg_Count (0);
+         List_Pragmas.Increment_Last;
+         List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
+
+      -----------------------------
+      -- Source_File_Name (GNAT) --
+      -----------------------------
+
+      --  There are five forms of this pragma:
+
+      --  pragma Source_File_Name (
+      --    [UNIT_NAME      =>] unit_NAME,
+      --     BODY_FILE_NAME =>  STRING_LITERAL);
+
+      --  pragma Source_File_Name (
+      --    [UNIT_NAME      =>] unit_NAME,
+      --     SPEC_FILE_NAME =>  STRING_LITERAL);
+
+      --  pragma Source_File_Name (
+      --     BODY_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT => STRING_LITERAL]
+      --  [, CASING          => CASING_SPEC]);
+
+      --  pragma Source_File_Name (
+      --     SPEC_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT => STRING_LITERAL]
+      --  [, CASING          => CASING_SPEC]);
+
+      --  pragma Source_File_Name (
+      --     SUBUNIT_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT    => STRING_LITERAL]
+      --  [, CASING             => CASING_SPEC]);
+
+      --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
+
+      --  Note: we process this during parsing, since we need to have the
+      --  source file names set well before the semantic analysis starts,
+      --  since we load the spec and with'ed packages before analysis.
+
+      when Pragma_Source_File_Name => Source_File_Name : declare
+         Unam  : Unit_Name_Type;
+         Expr1 : Node_Id;
+         Pat   : String_Ptr;
+         Typ   : Character;
+         Dot   : String_Ptr;
+         Cas   : Casing_Type;
+         Nast  : Nat;
+
+         function Get_Fname (Arg : Node_Id) return Name_Id;
+         --  Process file name from unit name form of pragma
+
+         function Get_String_Argument (Arg : Node_Id) return String_Ptr;
+         --  Process string literal value from argument
+
+         procedure Process_Casing (Arg : Node_Id);
+         --  Process Casing argument of pattern form of pragma
+
+         procedure Process_Dot_Replacement (Arg : Node_Id);
+         --  Process Dot_Replacement argument of patterm form of pragma
+
+         ---------------
+         -- Get_Fname --
+         ---------------
+
+         function Get_Fname (Arg : Node_Id) return Name_Id is
+         begin
+            String_To_Name_Buffer (Strval (Expression (Arg)));
+
+            for J in 1 .. Name_Len loop
+               if Is_Directory_Separator (Name_Buffer (J)) then
+                  Error_Msg
+                    ("directory separator character not allowed",
+                     Sloc (Expression (Arg)) + Source_Ptr (J));
+               end if;
+            end loop;
+
+            return Name_Find;
+         end Get_Fname;
+
+         -------------------------
+         -- Get_String_Argument --
+         -------------------------
+
+         function Get_String_Argument (Arg : Node_Id) return String_Ptr is
+            Str : String_Id;
+
+         begin
+            if Nkind (Expression (Arg)) /= N_String_Literal
+              and then
+               Nkind (Expression (Arg)) /= N_Operator_Symbol
+            then
+               Error_Msg_N
+                 ("argument for pragma% must be string literal", Arg);
+               raise Error_Resync;
+            end if;
+
+            Str := Strval (Expression (Arg));
+
+            --  Check string has no wide chars
+
+            for J in 1 .. String_Length (Str) loop
+               if Get_String_Char (Str, J) > 255 then
+                  Error_Msg
+                    ("wide character not allowed in pattern for pragma%",
+                     Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
+               end if;
+            end loop;
+
+            --  Acquire string
+
+            String_To_Name_Buffer (Str);
+            return new String'(Name_Buffer (1 .. Name_Len));
+         end Get_String_Argument;
+
+         --------------------
+         -- Process_Casing --
+         --------------------
+
+         procedure Process_Casing (Arg : Node_Id) is
+            Expr : constant Node_Id := Expression (Arg);
+
+         begin
+            Check_Required_Identifier (Arg, Name_Casing);
+
+            if Nkind (Expr) = N_Identifier then
+               if Chars (Expr) = Name_Lowercase then
+                  Cas := All_Lower_Case;
+                  return;
+               elsif Chars (Expr) = Name_Uppercase then
+                  Cas := All_Upper_Case;
+                  return;
+               elsif Chars (Expr) = Name_Mixedcase then
+                  Cas := Mixed_Case;
+                  return;
+               end if;
+            end if;
+
+            Error_Msg_N
+              ("Casing argument for pragma% must be " &
+               "one of Mixedcase, Lowercase, Uppercase",
+               Arg);
+         end Process_Casing;
+
+         -----------------------------
+         -- Process_Dot_Replacement --
+         -----------------------------
+
+         procedure Process_Dot_Replacement (Arg : Node_Id) is
+         begin
+            Check_Required_Identifier (Arg, Name_Dot_Replacement);
+            Dot := Get_String_Argument (Arg);
+         end Process_Dot_Replacement;
+
+      --  Start of processing for Source_File_Name pragma
+
+      begin
+         --  We permit from 1 to 3 arguments
+
+         if Arg_Count not in 1 .. 3 then
+            Check_Arg_Count (1);
+         end if;
+
+         Expr1 := Expression (Arg1);
+
+         --  If first argument is identifier or selected component, then
+         --  we have the specific file case of the Source_File_Name pragma,
+         --  and the first argument is a unit name.
+
+         if Nkind (Expr1) = N_Identifier
+           or else
+             (Nkind (Expr1) = N_Selected_Component
+               and then
+              Nkind (Selector_Name (Expr1)) = N_Identifier)
+         then
+            Check_Arg_Count (2);
+
+            Check_Optional_Identifier (Arg1, Name_Unit_Name);
+            Unam := Get_Unit_Name (Expr1);
+
+            Check_Arg_Is_String_Literal (Arg2);
+
+            if Chars (Arg2) = Name_Spec_File_Name then
+               Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2));
+
+            elsif Chars (Arg2) = Name_Body_File_Name then
+               Set_File_Name (Unam, Get_Fname (Arg2));
+
+            else
+               Error_Msg_N ("pragma% argument has incorrect identifier", Arg2);
+               return Pragma_Node;
+            end if;
+
+         --  If the first argument is not an identifier, then we must have
+         --  the pattern form of the pragma, and the first argument must be
+         --  the pattern string with an appropriate name.
+
+         else
+            if Chars (Arg1) = Name_Spec_File_Name then
+               Typ := 's';
+
+            elsif Chars (Arg1) = Name_Body_File_Name then
+               Typ := 'b';
+
+            elsif Chars (Arg1) = Name_Subunit_File_Name then
+               Typ := 'u';
+
+            elsif Chars (Arg1) = Name_Unit_Name then
+               Error_Msg_N
+                 ("Unit_Name parameter for pragma% must be an identifier",
+                  Arg1);
+               raise Error_Resync;
+
+            else
+               Error_Msg_N ("pragma% argument has incorrect identifier", Arg1);
+               raise Error_Resync;
+            end if;
+
+            Pat := Get_String_Argument (Arg1);
+
+            --  Check pattern has exactly one asterisk
+
+            Nast := 0;
+            for J in Pat'Range loop
+               if Pat (J) = '*' then
+                  Nast := Nast + 1;
+               end if;
+            end loop;
+
+            if Nast /= 1 then
+               Error_Msg_N
+                 ("file name pattern must have exactly one * character",
+                  Arg2);
+               return Pragma_Node;
+            end if;
+
+            --  Set defaults for Casing and Dot_Separator parameters
+
+            Cas := All_Lower_Case;
+
+            Dot := new String'(".");
+
+            --  Process second and third arguments if present
+
+            if Arg_Count > 1 then
+               if Chars (Arg2) = Name_Casing then
+                  Process_Casing (Arg2);
+
+                  if Arg_Count = 3 then
+                     Process_Dot_Replacement (Arg3);
+                  end if;
+
+               else
+                  Process_Dot_Replacement (Arg2);
+
+                  if Arg_Count = 3 then
+                     Process_Casing (Arg3);
+                  end if;
+               end if;
+            end if;
+
+            Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
+         end if;
+      end Source_File_Name;
+
+      -----------------------------
+      -- Source_Reference (GNAT) --
+      -----------------------------
+
+      --  pragma Source_Reference
+      --    (INTEGER_LITERAL [, STRING_LITERAL] );
+
+      --  Processing for this pragma must be done at parse time, since error
+      --  messages needing the proper line numbers can be generated in parse
+      --  only mode with semantic checking turned off, and indeed we usually
+      --  turn off semantic checking anyway if any parse errors are found.
+
+      when Pragma_Source_Reference => Source_Reference : declare
+         Fname : Name_Id;
+
+      begin
+         if Arg_Count /= 1 then
+            Check_Arg_Count (2);
+            Check_No_Identifier (Arg2);
+         end if;
+
+         --  Check that this is first line of file. We skip this test if
+         --  we are in syntax check only mode, since we may be dealing with
+         --  multiple compilation units.
+
+         if Get_Physical_Line_Number (Pragma_Sloc) /= 1
+           and then Num_SRef_Pragmas (Current_Source_File) = 0
+           and then Operating_Mode /= Check_Syntax
+         then
+            Error_Msg
+              ("first % pragma must be first line of file", Pragma_Sloc);
+            raise Error_Resync;
+         end if;
+
+         Check_No_Identifier (Arg1);
+
+         if Arg_Count = 1 then
+            if Num_SRef_Pragmas (Current_Source_File) = 0 then
+               Error_Msg
+                 ("file name required for first % pragma in file",
+                  Pragma_Sloc);
+               raise Error_Resync;
+
+            else
+               Fname := No_Name;
+            end if;
+
+         --  File name present
+
+         else
+            Check_Arg_Is_String_Literal (Arg2);
+            String_To_Name_Buffer (Strval (Expression (Arg2)));
+            Fname := Name_Find;
+
+            if Num_SRef_Pragmas (Current_Source_File) > 0 then
+               if Fname /= Full_Ref_Name (Current_Source_File) then
+                  Error_Msg
+                    ("file name must be same in all % pragmas", Pragma_Sloc);
+                  raise Error_Resync;
+               end if;
+            end if;
+         end if;
+
+         if Nkind (Expression (Arg1)) /= N_Integer_Literal then
+            Error_Msg
+              ("argument for pragma% must be integer literal",
+                Sloc (Expression (Arg1)));
+            raise Error_Resync;
+
+         --  OK, this source reference pragma is effective, however, we
+         --  ignore it if it is not in the first unit in the multiple unit
+         --  case. This is because the only purpose in this case is to
+         --  provide source pragmas for subsequent use by gnatchop.
+
+         else
+            if Num_Library_Units = 1 then
+               Register_Source_Ref_Pragma
+                 (Fname,
+                  Strip_Directory (Fname),
+                  UI_To_Int (Intval (Expression (Arg1))),
+                  Get_Physical_Line_Number (Pragma_Sloc) + 1);
+            end if;
+         end if;
+      end Source_Reference;
+
+      -------------------------
+      -- Style_Checks (GNAT) --
+      -------------------------
+
+      --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
+
+      --  This is processed by the parser since some of the style
+      --  checks take place during source scanning and parsing.
+
+      when Pragma_Style_Checks => Style_Checks : declare
+         A  : Node_Id;
+         S  : String_Id;
+         C  : Char_Code;
+         OK : Boolean := True;
+
+      begin
+         --  Two argument case is only for semantics
+
+         if Arg_Count = 2 then
+            null;
+
+         else
+            Check_Arg_Count (1);
+            Check_No_Identifier (Arg1);
+            A := Expression (Arg1);
+
+            if Nkind (A) = N_String_Literal then
+               S   := Strval (A);
+
+               declare
+                  Slen    : Natural := Natural (String_Length (S));
+                  Options : String (1 .. Slen);
+                  J       : Natural;
+                  Ptr     : Natural;
+
+               begin
+                  J := 1;
+                  loop
+                     C := Get_String_Char (S, Int (J));
+
+                     if not In_Character_Range (C) then
+                        OK := False;
+                        Ptr := J;
+                        exit;
+
+                     else
+                        Options (J) := Get_Character (C);
+                     end if;
+
+                     if J = Slen then
+                        Set_Style_Check_Options (Options, OK, Ptr);
+                        exit;
+
+                     else
+                        J := J + 1;
+                     end if;
+                  end loop;
+
+                  if not OK then
+                     Error_Msg
+                       ("invalid style check option",
+                        Sloc (Expression (Arg1)) + Source_Ptr (Ptr));
+                     raise Error_Resync;
+                  end if;
+               end;
+
+            elsif Nkind (A) /= N_Identifier then
+               OK := False;
+
+            elsif Chars (A) = Name_All_Checks then
+               Stylesw.Set_Default_Style_Check_Options;
+
+            elsif Chars (A) = Name_On then
+               Style_Check := True;
+
+            elsif Chars (A) = Name_Off then
+               Style_Check := False;
+
+            else
+               OK := False;
+            end if;
+
+            if not OK then
+               Error_Msg ("incorrect argument for pragma%", Sloc (A));
+               raise Error_Resync;
+            end if;
+         end if;
+      end Style_Checks;
+
+      ---------------------
+      -- Warnings (GNAT) --
+      ---------------------
+
+      --  pragma Warnings (On | Off, [LOCAL_NAME])
+
+      --  The one argument case is processed by the parser, since it may
+      --  control parser warnings as well as semantic warnings, and in any
+      --  case we want to be absolutely sure that the range in the warnings
+      --  table is set well before any semantic analysis is performed.
+
+      when Pragma_Warnings =>
+         if Arg_Count = 1 then
+            Check_No_Identifier (Arg1);
+            Check_Arg_Is_On_Or_Off (Arg1);
+
+            if Chars (Expression (Arg1)) = Name_On then
+               Set_Warnings_Mode_On (Pragma_Sloc);
+            else
+               Set_Warnings_Mode_Off (Pragma_Sloc);
+            end if;
+         end if;
+
+      -----------------------
+      -- All Other Pragmas --
+      -----------------------
+
+      --  For all other pragmas, checking and processing is handled
+      --  entirely in Sem_Prag, and no further checking is done by Par.
+
+      when Pragma_Abort_Defer              |
+           Pragma_AST_Entry                |
+           Pragma_All_Calls_Remote         |
+           Pragma_Annotate                 |
+           Pragma_Assert                   |
+           Pragma_Asynchronous             |
+           Pragma_Atomic                   |
+           Pragma_Atomic_Components        |
+           Pragma_Attach_Handler           |
+           Pragma_CPP_Class                |
+           Pragma_CPP_Constructor          |
+           Pragma_CPP_Virtual              |
+           Pragma_CPP_Vtable               |
+           Pragma_C_Pass_By_Copy           |
+           Pragma_Comment                  |
+           Pragma_Common_Object            |
+           Pragma_Complex_Representation   |
+           Pragma_Component_Alignment      |
+           Pragma_Controlled               |
+           Pragma_Convention               |
+           Pragma_Discard_Names            |
+           Pragma_Eliminate                |
+           Pragma_Elaborate                |
+           Pragma_Elaborate_All            |
+           Pragma_Elaborate_Body           |
+           Pragma_Elaboration_Checks       |
+           Pragma_Export                   |
+           Pragma_Export_Exception         |
+           Pragma_Export_Function          |
+           Pragma_Export_Object            |
+           Pragma_Export_Procedure         |
+           Pragma_Export_Valued_Procedure  |
+           Pragma_Extend_System            |
+           Pragma_External_Name_Casing     |
+           Pragma_Finalize_Storage_Only    |
+           Pragma_Float_Representation     |
+           Pragma_Ident                    |
+           Pragma_Import                   |
+           Pragma_Import_Exception         |
+           Pragma_Import_Function          |
+           Pragma_Import_Object            |
+           Pragma_Import_Procedure         |
+           Pragma_Import_Valued_Procedure  |
+           Pragma_Initialize_Scalars       |
+           Pragma_Inline                   |
+           Pragma_Inline_Always            |
+           Pragma_Inline_Generic           |
+           Pragma_Inspection_Point         |
+           Pragma_Interface                |
+           Pragma_Interface_Name           |
+           Pragma_Interrupt_Handler        |
+           Pragma_Interrupt_Priority       |
+           Pragma_Java_Constructor         |
+           Pragma_Java_Interface           |
+           Pragma_License                  |
+           Pragma_Link_With                |
+           Pragma_Linker_Alias             |
+           Pragma_Linker_Options           |
+           Pragma_Linker_Section           |
+           Pragma_Locking_Policy           |
+           Pragma_Long_Float               |
+           Pragma_Machine_Attribute        |
+           Pragma_Main                     |
+           Pragma_Main_Storage             |
+           Pragma_Memory_Size              |
+           Pragma_No_Return                |
+           Pragma_No_Run_Time              |
+           Pragma_Normalize_Scalars        |
+           Pragma_Optimize                 |
+           Pragma_Pack                     |
+           Pragma_Passive                  |
+           Pragma_Polling                  |
+           Pragma_Preelaborate             |
+           Pragma_Priority                 |
+           Pragma_Propagate_Exceptions     |
+           Pragma_Psect_Object             |
+           Pragma_Pure                     |
+           Pragma_Pure_Function            |
+           Pragma_Queuing_Policy           |
+           Pragma_Remote_Call_Interface    |
+           Pragma_Remote_Types             |
+           Pragma_Restrictions             |
+           Pragma_Restricted_Run_Time      |
+           Pragma_Ravenscar                |
+           Pragma_Reviewable               |
+           Pragma_Share_Generic            |
+           Pragma_Shared                   |
+           Pragma_Shared_Passive           |
+           Pragma_Storage_Size             |
+           Pragma_Storage_Unit             |
+           Pragma_Stream_Convert           |
+           Pragma_Subtitle                 |
+           Pragma_Suppress                 |
+           Pragma_Suppress_All             |
+           Pragma_Suppress_Debug_Info      |
+           Pragma_Suppress_Initialization  |
+           Pragma_System_Name              |
+           Pragma_Task_Dispatching_Policy  |
+           Pragma_Task_Info                |
+           Pragma_Task_Name                |
+           Pragma_Task_Storage             |
+           Pragma_Time_Slice               |
+           Pragma_Title                    |
+           Pragma_Unchecked_Union          |
+           Pragma_Unimplemented_Unit       |
+           Pragma_Unreserve_All_Interrupts |
+           Pragma_Unsuppress               |
+           Pragma_Use_VADS_Size            |
+           Pragma_Volatile                 |
+           Pragma_Volatile_Components      |
+           Pragma_Weak_External            |
+           Pragma_Validity_Checks          =>
+         null;
+
+   end case;
+
+   return Pragma_Node;
+
+   --------------------
+   -- Error Handling --
+   --------------------
+
+exception
+   when Error_Resync =>
+      return Error;
+
+end Prag;

gcc/ada/par-sync.adb

@@ -0,0 +1,312 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . S Y N C                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+package body Sync is
+
+   procedure Resync_Init;
+   --  This routine is called on initiating a resynchronization action
+
+   procedure Resync_Resume;
+   --  This routine is called on completing a resynchronization action
+
+   -------------------
+   -- Resync_Choice --
+   -------------------
+
+   procedure Resync_Choice is
+   begin
+      Resync_Init;
+
+      --  Loop till we get a token that terminates a choice. Note that EOF is
+      --  one such token, so we are sure to get out of this loop eventually!
+
+      while Token not in Token_Class_Cterm loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Choice;
+
+   ------------------
+   -- Resync_Cunit --
+   ------------------
+
+   procedure Resync_Cunit is
+   begin
+      Resync_Init;
+
+      while Token not in Token_Class_Cunit
+        and then Token /= Tok_EOF
+      loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Cunit;
+
+   -----------------------
+   -- Resync_Expression --
+   -----------------------
+
+   procedure Resync_Expression is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         --  Terminating tokens are those in class Eterm and also RANGE,
+         --  DIGITS or DELTA if not preceded by an apostrophe (if they are
+         --  preceded by an apostrophe, then they are attributes). In addiion,
+         --  at the outer parentheses level only, we also consider a comma,
+         --  right parenthesis or vertical bar to terminate an expression.
+
+         if Token in Token_Class_Eterm
+
+           or else (Token in Token_Class_Atkwd
+                     and then Prev_Token /= Tok_Apostrophe)
+
+           or else (Paren_Count = 0
+                     and then
+                       (Token = Tok_Comma
+                         or else Token = Tok_Right_Paren
+                         or else Token = Tok_Vertical_Bar))
+         then
+            --  A special check: if we stop on the ELSE of OR ELSE or the
+            --  THEN of AND THEN, keep going, because this is not really an
+            --  expression terminator after all. Also, keep going past WITH
+            --  since this can be part of an extension aggregate
+
+            if (Token = Tok_Else and then Prev_Token = Tok_Or)
+               or else (Token = Tok_Then and then Prev_Token = Tok_And)
+               or else Token = Tok_With
+            then
+               null;
+            else
+               exit;
+            end if;
+         end if;
+
+         if Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            Paren_Count := Paren_Count - 1;
+
+         end if;
+
+         Scan; -- past token to be skipped
+      end loop;
+
+      Resync_Resume;
+   end Resync_Expression;
+
+   -----------------
+   -- Resync_Init --
+   -----------------
+
+   procedure Resync_Init is
+   begin
+      --  The following check makes sure we do not get stuck in an infinite
+      --  loop resynchonizing and getting nowhere. If we are called to do a
+      --  resynchronize and we are exactly at the same point that we left off
+      --  on the last resynchronize call, then we force at least one token to
+      --  be skipped so that we make progress!
+
+      if Token_Ptr = Last_Resync_Point then
+         Scan; -- to skip at least one token
+      end if;
+
+      --  Output extra error message if debug R flag is set
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resynchronizing!");
+      end if;
+   end Resync_Init;
+
+   ---------------------------
+   -- Resync_Past_Semicolon --
+   ---------------------------
+
+   procedure Resync_Past_Semicolon is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if we are at a semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif Token in Token_Class_After_SM
+            and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon;
+
+   ----------------------------------------------
+   -- Resync_Past_Semicolon_Or_To_Loop_Or_Then --
+   ----------------------------------------------
+
+   procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past the semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif (Token in Token_Class_After_SM
+                  and then (Token /= Tok_Private
+                              or else Prev_Token /= Tok_With))
+         then
+            exit;
+
+         --  Done if we are at THEN or LOOP
+
+         elsif Token = Tok_Then or else Token = Tok_Loop then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon_Or_To_Loop_Or_Then;
+
+   -------------------
+   -- Resync_Resume --
+   -------------------
+
+   procedure Resync_Resume is
+   begin
+      --  Save resync point (see special test in Resync_Init)
+
+      Last_Resync_Point := Token_Ptr;
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resuming here!");
+      end if;
+   end Resync_Resume;
+
+   --------------------
+   -- Resync_To_When --
+   --------------------
+
+   procedure Resync_To_When is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon, WHEN or IS
+
+         if Token = Tok_Semicolon
+           or else Token = Tok_When
+           or else Token = Tok_Is
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_To_When;
+
+   ---------------------------
+   -- Resync_Semicolon_List --
+   ---------------------------
+
+   procedure Resync_Semicolon_List is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         if Token = Tok_EOF
+           or else Token = Tok_Semicolon
+           or else Token = Tok_Is
+           or else Token in Token_Class_After_SM
+         then
+            exit;
+
+         elsif Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            if Paren_Count = 0 then
+               exit;
+            else
+               Paren_Count := Paren_Count - 1;
+            end if;
+         end if;
+
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Semicolon_List;
+
+end Sync;

gcc/ada/par-tchk.adb

@@ -0,0 +1,812 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . T C H K                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.37 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Token scan routines.
+
+--  Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync
+
+separate (Par)
+package body Tchk is
+
+   type Position is (SC, BC, AP);
+   --  Specify position of error message (see Error_Msg_SC/BC/AP)
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Token (T : Token_Type; P : Position);
+   pragma Inline (Check_Token);
+   --  Called by T_xx routines to check for reserved keyword token. P is the
+   --  position of the error message if the token is missing (see Wrong_Token)
+
+   procedure Wrong_Token (T : Token_Type; P : Position);
+   --  Called when scanning a reserved keyword when the keyword is not
+   --  present. T is the token type for the keyword, and P indicates the
+   --  position to be used to place a message relative to the current
+   --  token if the keyword is not located nearby.
+
+   -----------------
+   -- Check_Token --
+   -----------------
+
+   procedure Check_Token (T : Token_Type; P : Position) is
+   begin
+      if Token = T then
+         Scan;
+         return;
+      else
+         Wrong_Token (T, P);
+      end if;
+   end Check_Token;
+
+   -------------
+   -- T_Abort --
+   -------------
+
+   procedure T_Abort is
+   begin
+      Check_Token (Tok_Abort, SC);
+   end T_Abort;
+
+   -------------
+   -- T_Arrow --
+   -------------
+
+   procedure T_Arrow is
+   begin
+      if Token = Tok_Arrow then
+         Scan;
+
+      --  A little recovery helper, accept then in place of =>
+
+      elsif Token = Tok_Then then
+         Error_Msg_BC ("missing ""=>""");
+         Scan; -- past THEN used in place of =>
+
+      elsif Token = Tok_Colon_Equal then
+         Error_Msg_SC (""":="" should be ""=>""");
+         Scan; -- past := used in place of =>
+
+      else
+         Error_Msg_AP ("missing ""=>""");
+      end if;
+   end T_Arrow;
+
+   ----------
+   -- T_At --
+   ----------
+
+   procedure T_At is
+   begin
+      Check_Token (Tok_At, SC);
+   end T_At;
+
+   ------------
+   -- T_Body --
+   ------------
+
+   procedure T_Body is
+   begin
+      Check_Token (Tok_Body, BC);
+   end T_Body;
+
+   -----------
+   -- T_Box --
+   -----------
+
+   procedure T_Box is
+   begin
+      if Token = Tok_Box then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""<>""");
+      end if;
+   end T_Box;
+
+   -------------
+   -- T_Colon --
+   -------------
+
+   procedure T_Colon is
+   begin
+      if Token = Tok_Colon then
+         Scan;
+      else
+         Error_Msg_AP ("missing "":""");
+      end if;
+   end T_Colon;
+
+   -------------------
+   -- T_Colon_Equal --
+   -------------------
+
+   procedure T_Colon_Equal is
+   begin
+      if Token = Tok_Colon_Equal then
+         Scan;
+
+      elsif Token = Tok_Equal then
+         Error_Msg_SC ("""="" should be "":=""");
+         Scan;
+
+      elsif Token = Tok_Colon then
+         Error_Msg_SC (""":"" should be "":=""");
+         Scan;
+
+      elsif Token = Tok_Is then
+         Error_Msg_SC ("IS should be "":=""");
+         Scan;
+
+      else
+         Error_Msg_AP ("missing "":=""");
+      end if;
+   end T_Colon_Equal;
+
+   -------------
+   -- T_Comma --
+   -------------
+
+   procedure T_Comma is
+   begin
+      if Token = Tok_Comma then
+         Scan;
+
+      else
+         if Token = Tok_Pragma then
+            P_Pragmas_Misplaced;
+         end if;
+
+         if Token = Tok_Comma then
+            Scan;
+         else
+            Error_Msg_AP ("missing "",""");
+         end if;
+      end if;
+
+      if Token = Tok_Pragma then
+         P_Pragmas_Misplaced;
+      end if;
+   end T_Comma;
+
+   ---------------
+   -- T_Dot_Dot --
+   ---------------
+
+   procedure T_Dot_Dot is
+   begin
+      if Token = Tok_Dot_Dot then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""..""");
+      end if;
+   end T_Dot_Dot;
+
+   -----------
+   -- T_For --
+   -----------
+
+   procedure T_For is
+   begin
+      Check_Token (Tok_For, AP);
+   end T_For;
+
+   -----------------------
+   -- T_Greater_Greater --
+   -----------------------
+
+   procedure T_Greater_Greater is
+   begin
+      if Token = Tok_Greater_Greater then
+         Scan;
+      else
+         Error_Msg_AP ("missing "">>""");
+      end if;
+   end T_Greater_Greater;
+
+   ------------------
+   -- T_Identifier --
+   ------------------
+
+   procedure T_Identifier is
+   begin
+      if Token = Tok_Identifier then
+         Scan;
+      elsif Token in Token_Class_Literal then
+         Error_Msg_SC ("identifier expected");
+         Scan;
+      else
+         Error_Msg_AP ("identifier expected");
+      end if;
+   end T_Identifier;
+
+   ----------
+   -- T_In --
+   ----------
+
+   procedure T_In is
+   begin
+      Check_Token (Tok_In, AP);
+   end T_In;
+
+   ----------
+   -- T_Is --
+   ----------
+
+   procedure T_Is is
+   begin
+      if Token = Tok_Is then
+         Scan;
+
+         Ignore (Tok_Semicolon);
+
+      --  Allow OF, => or = to substitute for IS with complaint
+
+      elsif Token = Tok_Arrow
+        or else Token = Tok_Of
+        or else Token = Tok_Equal
+      then
+         Error_Msg_SC ("missing IS");
+         Scan; -- token used in place of IS
+      else
+         Wrong_Token (Tok_Is, AP);
+      end if;
+
+      while Token = Tok_Is loop
+         Error_Msg_SC ("extra IS ignored");
+         Scan;
+      end loop;
+   end T_Is;
+
+   ------------------
+   -- T_Left_Paren --
+   ------------------
+
+   procedure T_Left_Paren is
+   begin
+      if Token = Tok_Left_Paren then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""(""");
+      end if;
+   end T_Left_Paren;
+
+   ------------
+   -- T_Loop --
+   ------------
+
+   procedure T_Loop is
+   begin
+      if Token = Tok_Do then
+         Error_Msg_SC ("LOOP expected");
+         Scan;
+      else
+         Check_Token (Tok_Loop, AP);
+      end if;
+   end T_Loop;
+
+   -----------
+   -- T_Mod --
+   -----------
+
+   procedure T_Mod is
+   begin
+      Check_Token (Tok_Mod, AP);
+   end T_Mod;
+
+   -----------
+   -- T_New --
+   -----------
+
+   procedure T_New is
+   begin
+      Check_Token (Tok_New, AP);
+   end T_New;
+
+   ----------
+   -- T_Of --
+   ----------
+
+   procedure T_Of is
+   begin
+      Check_Token (Tok_Of, AP);
+   end T_Of;
+
+   ----------
+   -- T_Or --
+   ----------
+
+   procedure T_Or is
+   begin
+      Check_Token (Tok_Or, AP);
+   end T_Or;
+
+   ---------------
+   -- T_Private --
+   ---------------
+
+   procedure T_Private is
+   begin
+      Check_Token (Tok_Private, SC);
+   end T_Private;
+
+   -------------
+   -- T_Range --
+   -------------
+
+   procedure T_Range is
+   begin
+      Check_Token (Tok_Range, AP);
+   end T_Range;
+
+   --------------
+   -- T_Record --
+   --------------
+
+   procedure T_Record is
+   begin
+      Check_Token (Tok_Record, AP);
+   end T_Record;
+
+   -------------------
+   -- T_Right_Paren --
+   -------------------
+
+   procedure T_Right_Paren is
+   begin
+      if Token = Tok_Right_Paren then
+         Scan;
+      else
+         Error_Msg_AP ("missing "")""");
+      end if;
+   end T_Right_Paren;
+
+   -----------------
+   -- T_Semicolon --
+   -----------------
+
+   procedure T_Semicolon is
+   begin
+
+      if Token = Tok_Semicolon then
+         Scan;
+
+         if Token = Tok_Semicolon then
+            Error_Msg_SC ("extra "";"" ignored");
+            Scan;
+         end if;
+
+      elsif Token = Tok_Colon then
+         Error_Msg_SC (""":"" should be "";""");
+         Scan;
+
+      elsif Token = Tok_Comma then
+         Error_Msg_SC (""","" should be "";""");
+         Scan;
+
+      elsif Token = Tok_Dot then
+         Error_Msg_SC ("""."" should be "";""");
+         Scan;
+
+      --  An interesting little kludge here. If the previous token is a
+      --  semicolon, then there is no way that we can legitimately need
+      --  another semicolon. This could only arise in an error situation
+      --  where an error has already been signalled. By simply ignoring
+      --  the request for a semicolon in this case, we avoid some spurious
+      --  missing semicolon messages.
+
+      elsif Prev_Token = Tok_Semicolon then
+         return;
+
+      --  If the current token is | then this is a reasonable
+      --  place to suggest the possibility of a "C" confusion :-)
+
+      elsif Token = Tok_Vertical_Bar then
+         Error_Msg_SC ("unexpected occurrence of ""|"", did you mean OR'?");
+         Resync_Past_Semicolon;
+
+      --  Otherwise we really do have a missing semicolon
+
+      else
+         Error_Msg_AP ("missing "";""");
+         return;
+      end if;
+
+   end T_Semicolon;
+
+   ------------
+   -- T_Then --
+   ------------
+
+   procedure T_Then is
+   begin
+      Check_Token (Tok_Then, AP);
+   end T_Then;
+
+   ------------
+   -- T_Type --
+   ------------
+
+   procedure T_Type is
+   begin
+      Check_Token (Tok_Type, BC);
+   end T_Type;
+
+   -----------
+   -- T_Use --
+   -----------
+
+   procedure T_Use is
+   begin
+      Check_Token (Tok_Use, SC);
+   end T_Use;
+
+   ------------
+   -- T_When --
+   ------------
+
+   procedure T_When is
+   begin
+      Check_Token (Tok_When, SC);
+   end T_When;
+
+   ------------
+   -- T_With --
+   ------------
+
+   procedure T_With is
+   begin
+      Check_Token (Tok_With, BC);
+   end T_With;
+
+   --------------
+   -- TF_Arrow --
+   --------------
+
+   procedure TF_Arrow is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Arrow then
+         Scan; -- skip arrow and we are done
+
+      elsif Token = Tok_Colon_Equal then
+         T_Arrow; -- Let T_Arrow give the message
+
+      else
+         T_Arrow; -- give missing arrow message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Arrow then
+               Scan; -- past arrow
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Arrow;
+
+   -----------
+   -- TF_Is --
+   -----------
+
+   procedure TF_Is is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Is then
+         T_Is; -- past IS and we are done
+
+      --  Allow OF or => or = in place of IS (with error message)
+
+      elsif Token = Tok_Of
+        or else Token = Tok_Arrow
+        or else Token = Tok_Equal
+      then
+         T_Is; -- give missing IS message and skip bad token
+
+      else
+         T_Is; -- give missing IS message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Is
+              or else Token = Tok_Of
+              or else Token = Tok_Arrow
+            then
+               Scan; -- past IS or OF or =>
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Is;
+
+   -------------
+   -- TF_Loop --
+   -------------
+
+   procedure TF_Loop is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Loop then
+         Scan; -- past LOOP and we are done
+
+      --  Allow DO or THEN in place of LOOP
+
+      elsif Token = Tok_Then or else Token = Tok_Do then
+         T_Loop; -- give missing LOOP message
+
+      else
+         T_Loop; -- give missing LOOP message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Loop or else Token = Tok_Then then
+               Scan; -- past loop or then (message already generated)
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Loop;
+
+   --------------
+   -- TF_Return--
+   --------------
+
+   procedure TF_Return is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Return then
+         Scan; -- skip RETURN and we are done
+
+      else
+         Error_Msg_SC ("missing RETURN");
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Return then
+               Scan; -- past RETURN
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Return;
+
+   ------------------
+   -- TF_Semicolon --
+   ------------------
+
+   procedure TF_Semicolon is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Semicolon then
+         T_Semicolon;
+         return;
+
+      --  An interesting little kludge here. If the previous token is a
+      --  semicolon, then there is no way that we can legitimately need
+      --  another semicolon. This could only arise in an error situation
+      --  where an error has already been signalled. By simply ignoring
+      --  the request for a semicolon in this case, we avoid some spurious
+      --  missing semicolon messages.
+
+      elsif Prev_Token = Tok_Semicolon then
+         return;
+
+      else
+         if Token = Tok_Pragma then
+            P_Pragmas_Misplaced;
+
+            if Token = Tok_Semicolon then
+               T_Semicolon;
+               return;
+            end if;
+         end if;
+
+         T_Semicolon; -- give missing semicolon message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search
+
+            if Token = Tok_Semicolon then
+               T_Semicolon;
+               return;
+
+            elsif Token in Token_Class_After_SM then
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Semicolon;
+
+   -------------
+   -- TF_Then --
+   -------------
+
+   procedure TF_Then is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Then then
+         Scan; -- past THEN and we are done
+
+      else
+         T_Then; -- give missing THEN message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Then then
+               Scan; -- past THEN
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Then;
+
+   ------------
+   -- TF_Use --
+   ------------
+
+   procedure TF_Use is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Use then
+         Scan; -- past USE and we are done
+
+      else
+         T_Use; -- give USE expected message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Use then
+               Scan; -- past use
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Use;
+
+   -----------------
+   -- Wrong_Token --
+   -----------------
+
+   procedure Wrong_Token (T : Token_Type; P : Position) is
+      Missing : constant String := "missing ";
+      Image : constant String := Token_Type'Image (T);
+      Tok_Name : constant String := Image (5 .. Image'Length);
+      M : String (1 .. Missing'Length + Tok_Name'Length);
+
+   begin
+      --  Set M to Missing & Tok_Name.
+
+      M (1 .. Missing'Length) := Missing;
+      M (Missing'Length + 1 .. M'Last) := Tok_Name;
+
+      if Token = Tok_Semicolon then
+         Scan;
+
+         if Token = T then
+            Error_Msg_SP ("extra "";"" ignored");
+            Scan;
+         else
+            Error_Msg_SP (M);
+         end if;
+
+      elsif Token = Tok_Comma then
+         Scan;
+
+         if Token = T then
+            Error_Msg_SP ("extra "","" ignored");
+            Scan;
+
+         else
+            Error_Msg_SP (M);
+         end if;
+
+      else
+         case P is
+            when SC => Error_Msg_SC (M);
+            when BC => Error_Msg_BC (M);
+            when AP => Error_Msg_AP (M);
+         end case;
+      end if;
+   end Wrong_Token;
+
+end Tchk;

gcc/ada/par-util.adb

@@ -0,0 +1,638 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . U T I L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.64 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Uintp; use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+separate (Par)
+package body Util is
+
+   ---------------------
+   -- Bad_Spelling_Of --
+   ---------------------
+
+   function Bad_Spelling_Of (T : Token_Type) return Boolean is
+      Tname : constant String := Token_Type'Image (T);
+      --  Characters of token name
+
+      S : String (1 .. Tname'Last - 4);
+      --  Characters of token name folded to lower case, omitting TOK_ at start
+
+      M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
+      M2 : String (1 .. 44) := "illegal abbreviation of keyword ************";
+      --  Buffers used to construct error message
+
+      P1 : constant := 30;
+      P2 : constant := 32;
+      --  Starting subscripts in M1, M2 for keyword name
+
+      SL : constant Natural := S'Length;
+      --  Length of expected token name excluding TOK_ at start
+
+   begin
+      if Token /= Tok_Identifier then
+         return False;
+      end if;
+
+      for J in S'Range loop
+         S (J) := Fold_Lower (Tname (Integer (J) + 4));
+      end loop;
+
+      Get_Name_String (Token_Name);
+
+      --  A special check for case of PROGRAM used for PROCEDURE
+
+      if T = Tok_Procedure
+        and then Name_Len = 7
+        and then Name_Buffer (1 .. 7) = "program"
+      then
+         Error_Msg_SC ("PROCEDURE expected");
+         Token := T;
+         return True;
+
+      --  A special check for an illegal abbrevation
+
+      elsif Name_Len < S'Length
+        and then Name_Len >= 4
+        and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
+      then
+         for J in 1 .. S'Last loop
+            M2 (P2 + J - 1) := Fold_Upper (S (J));
+         end loop;
+
+         Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
+         Token := T;
+         return True;
+      end if;
+
+      --  Now we go into the full circuit to check for a misspelling
+
+      --  Never consider something a misspelling if either the actual or
+      --  expected string is less than 3 characters (before this check we
+      --  used to consider i to be a misspelled if in some cases!)
+
+      if SL < 3 or else Name_Len < 3 then
+         return False;
+
+      --  Special case: prefix matches, i.e. the leading characters of the
+      --  token that we have exactly match the required keyword. If there
+      --  are at least two characters left over, assume that we have a case
+      --  of two keywords joined together which should not be joined.
+
+      elsif Name_Len > SL + 1
+        and then S = Name_Buffer (1 .. SL)
+      then
+         Scan_Ptr := Token_Ptr + S'Length;
+         Error_Msg_S ("missing space");
+         Token := T;
+         return True;
+      end if;
+
+      if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+
+         for J in 1 .. S'Last loop
+            M1 (P1 + J - 1) := Fold_Upper (S (J));
+         end loop;
+
+         Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last));
+         Token := T;
+         return True;
+
+      else
+         return False;
+      end if;
+
+   end Bad_Spelling_Of;
+
+   ----------------------
+   -- Check_95_Keyword --
+   ----------------------
+
+   --  On entry, the caller has checked that current token is an identifier
+   --  whose name matches the name of the 95 keyword New_Tok.
+
+   procedure Check_95_Keyword (Token_95, Next : Token_Type) is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Save_Scan_State (Scan_State); -- at identifier/keyword
+      Scan; -- past identifier/keyword
+
+      if Token = Next then
+         Restore_Scan_State (Scan_State); -- to identifier
+         Error_Msg_Name_1 := Token_Name;
+         Error_Msg_SC ("(Ada 83) keyword* cannot be used!");
+         Token := Token_95;
+      else
+         Restore_Scan_State (Scan_State); -- to identifier
+      end if;
+   end Check_95_Keyword;
+
+   ----------------------
+   -- Check_Bad_Layout --
+   ----------------------
+
+   procedure Check_Bad_Layout is
+   begin
+      if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
+        and then Start_Column <= Scope.Table (Scope.Last).Ecol
+      then
+         Error_Msg_BC ("(style) incorrect layout");
+      end if;
+   end Check_Bad_Layout;
+
+   --------------------------
+   -- Check_Misspelling_Of --
+   --------------------------
+
+   procedure Check_Misspelling_Of (T : Token_Type) is
+   begin
+      if Bad_Spelling_Of (T) then
+         null;
+      end if;
+   end Check_Misspelling_Of;
+
+   -----------------------------
+   -- Check_Simple_Expression --
+   -----------------------------
+
+   procedure Check_Simple_Expression (E : Node_Id) is
+   begin
+      if Expr_Form = EF_Non_Simple then
+         Error_Msg_N ("this expression must be parenthesized", E);
+      end if;
+   end Check_Simple_Expression;
+
+   ---------------------------------------
+   -- Check_Simple_Expression_In_Ada_83 --
+   ---------------------------------------
+
+   procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
+   begin
+      if Expr_Form = EF_Non_Simple then
+         if Ada_83 then
+            Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
+         end if;
+      end if;
+   end Check_Simple_Expression_In_Ada_83;
+
+   ------------------------
+   -- Check_Subtype_Mark --
+   ------------------------
+
+   function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is
+   begin
+      if Nkind (Mark) = N_Identifier
+        or else Nkind (Mark) = N_Selected_Component
+        or else (Nkind (Mark) = N_Attribute_Reference
+                  and then Is_Type_Attribute_Name (Attribute_Name (Mark)))
+        or else Mark = Error
+      then
+         return Mark;
+      else
+         Error_Msg ("subtype mark expected", Sloc (Mark));
+         return Error;
+      end if;
+   end Check_Subtype_Mark;
+
+   -------------------
+   -- Comma_Present --
+   -------------------
+
+   function Comma_Present return Boolean is
+      Scan_State  : Saved_Scan_State;
+      Paren_Count : Nat;
+
+   begin
+      --  First check, if a comma is present, then a comma is present!
+
+      if Token = Tok_Comma then
+         T_Comma;
+         return True;
+
+      --  If we have a right paren, then that is taken as ending the list
+      --  i.e. no comma is present.
+
+      elsif Token = Tok_Right_Paren then
+         return False;
+
+      --  If pragmas, then get rid of them and make a recursive call
+      --  to process what follows these pragmas.
+
+      elsif Token = Tok_Pragma then
+         P_Pragmas_Misplaced;
+         return Comma_Present;
+
+      --  At this stage we have an error, and the goal is to decide on whether
+      --  or not we should diagnose an error and report a (non-existent)
+      --  comma as being present, or simply to report no comma is present
+
+      --  If we are a semicolon, then the question is whether we have a missing
+      --  right paren, or whether the semicolon should have been a comma. To
+      --  guess the right answer, we scan ahead keeping track of the paren
+      --  level, looking for a clue that helps us make the right decision.
+
+      --  This approach is highly accurate in the single error case, and does
+      --  not make bad mistakes in the multiple error case (indeed we can't
+      --  really make a very bad decision at this point in any case).
+
+      elsif Token = Tok_Semicolon then
+         Save_Scan_State (Scan_State);
+         Scan; -- past semicolon
+
+         --  Check for being followed by identifier => which almost certainly
+         --  means we are still in a parameter list and the comma should have
+         --  been a semicolon (such a sequence could not follow a semicolon)
+
+         if Token = Tok_Identifier then
+            Scan;
+
+            if Token = Tok_Arrow then
+               goto Assume_Comma;
+            end if;
+         end if;
+
+         --  If that test didn't work, loop ahead looking for a comma or
+         --  semicolon at the same parenthesis level. Always remember that
+         --  we can't go badly wrong in an error situation like this!
+
+         Paren_Count := 0;
+
+         --  Here is the look ahead loop, Paren_Count tells us whether the
+         --  token we are looking at is at the same paren level as the
+         --  suspicious semicolon that we are trying to figure out.
+
+         loop
+
+            --  If we hit another semicolon or an end of file, and we have
+            --  not seen a right paren or another comma on the way, then
+            --  probably the semicolon did end the list. Indeed that is
+            --  certainly the only single error correction possible here.
+
+            if Token = Tok_Semicolon or else Token = Tok_EOF then
+               Restore_Scan_State (Scan_State);
+               return False;
+
+            --  A comma at the same paren level as the semicolon is a strong
+            --  indicator that the semicolon should have been a comma, indeed
+            --  again this is the only possible single error correction.
+
+            elsif Token = Tok_Comma then
+               exit when Paren_Count = 0;
+
+            --  A left paren just bumps the paren count
+
+            elsif Token = Tok_Left_Paren then
+               Paren_Count := Paren_Count + 1;
+
+            --  A right paren that is at the same paren level as the semicolon
+            --  also means that the only possible single error correction is
+            --  to assume that the semicolon should have been a comma. If we
+            --  are not at the same paren level, then adjust the paren level.
+
+            elsif Token = Tok_Right_Paren then
+               exit when Paren_Count = 0;
+               Paren_Count := Paren_Count - 1;
+            end if;
+
+            --  Keep going, we haven't made a decision yet
+
+            Scan;
+         end loop;
+
+         --  If we fall through the loop, it means that we found a terminating
+         --  right paren or another comma. In either case it is reasonable to
+         --  assume that the semicolon was really intended to be a comma. Also
+         --  come here for the identifier arrow case.
+
+         <<Assume_Comma>>
+            Restore_Scan_State (Scan_State);
+            Error_Msg_SC (""";"" illegal here, replaced by "",""");
+            Scan; -- past the semicolon
+            return True;
+
+      --  If we are not at semicolon or a right paren, then we base the
+      --  decision on whether or not the next token can be part of an
+      --  expression. If not, then decide that no comma is present (the
+      --  caller will eventually generate a missing right parent message)
+
+      elsif Token in Token_Class_Eterm then
+         return False;
+
+      --  Otherwise we assume a comma is present, even if none is present,
+      --  since the next token must be part of an expression, so if we were
+      --  at the end of the list, then there is more than one error present.
+
+      else
+         T_Comma; -- to give error
+         return True;
+      end if;
+   end Comma_Present;
+
+   -----------------------
+   -- Discard_Junk_List --
+   -----------------------
+
+   procedure Discard_Junk_List (L : List_Id) is
+   begin
+      null;
+   end Discard_Junk_List;
+
+   -----------------------
+   -- Discard_Junk_Node --
+   -----------------------
+
+   procedure Discard_Junk_Node (N : Node_Id) is
+   begin
+      null;
+   end Discard_Junk_Node;
+
+   ------------
+   -- Ignore --
+   ------------
+
+   procedure Ignore (T : Token_Type) is
+   begin
+      if Token = T then
+         if T = Tok_Comma then
+            Error_Msg_SC ("unexpected "","" ignored");
+
+         elsif T = Tok_Left_Paren then
+            Error_Msg_SC ("unexpected ""("" ignored");
+
+         elsif T = Tok_Right_Paren then
+            Error_Msg_SC ("unexpected "")"" ignored");
+
+         elsif T = Tok_Semicolon then
+            Error_Msg_SC ("unexpected "";"" ignored");
+
+         else
+            declare
+               Tname : constant String := Token_Type'Image (Token);
+               Msg   : String := "unexpected keyword ????????????????????????";
+
+            begin
+               --  Loop to copy characters of keyword name (ignoring Tok_)
+
+               for J in 5 .. Tname'Last loop
+                  Msg (J + 14) := Fold_Upper (Tname (J));
+               end loop;
+
+               Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored";
+               Error_Msg_SC (Msg (1 .. Tname'Last + 22));
+            end;
+         end if;
+
+         Scan; -- Scan past ignored token
+      end if;
+   end Ignore;
+
+   ----------------------------
+   -- Is_Reserved_Identifier --
+   ----------------------------
+
+   function Is_Reserved_Identifier return Boolean is
+   begin
+      if not Is_Reserved_Keyword (Token) then
+         return False;
+
+      else
+         declare
+            Ident_Casing : constant Casing_Type :=
+                             Identifier_Casing (Current_Source_File);
+
+            Key_Casing   : constant Casing_Type :=
+                             Keyword_Casing (Current_Source_File);
+
+         begin
+            --  If the casing of identifiers and keywords is different in
+            --  this source file, and the casing of this token matches the
+            --  keyword casing, then we return False, since it is pretty
+            --  clearly intended to be a keyword.
+
+            if Ident_Casing /= Unknown
+              and then Key_Casing /= Unknown
+              and then Ident_Casing /= Key_Casing
+              and then Determine_Token_Casing = Key_Casing
+            then
+               return False;
+
+            --  Otherwise assume that an identifier was intended
+
+            else
+               return True;
+            end if;
+         end;
+      end if;
+   end Is_Reserved_Identifier;
+
+   ----------------------
+   -- Merge_Identifier --
+   ----------------------
+
+   procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is
+   begin
+      if Token /= Tok_Identifier then
+         return;
+      end if;
+
+      declare
+         S : Saved_Scan_State;
+         T : Token_Type;
+
+      begin
+         Save_Scan_State (S);
+         Scan;
+         T := Token;
+         Restore_Scan_State (S);
+
+         if T /= Nxt then
+            return;
+         end if;
+      end;
+
+      --  Check exactly one space between identifiers
+
+      if Source (Token_Ptr - 1) /= ' '
+        or else Int (Token_Ptr) /=
+                  Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1
+      then
+         return;
+      end if;
+
+      --  Do the merge
+
+      Get_Name_String (Chars (Token_Node));
+
+      declare
+         Buf : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+
+      begin
+         Get_Name_String (Chars (Prev));
+         Add_Char_To_Name_Buffer ('_');
+         Add_Str_To_Name_Buffer (Buf);
+         Set_Chars (Prev, Name_Find);
+      end;
+
+      Error_Msg_Node_1 := Prev;
+      Error_Msg_SC
+        ("unexpected identifier, possibly & was meant here");
+      Scan;
+   end Merge_Identifier;
+
+   -------------------
+   -- No_Constraint --
+   -------------------
+
+   procedure No_Constraint is
+   begin
+      if Token in Token_Class_Consk then
+         Error_Msg_SC ("constraint not allowed here");
+         Discard_Junk_Node (P_Constraint_Opt);
+      end if;
+   end No_Constraint;
+
+   --------------------
+   -- No_Right_Paren --
+   --------------------
+
+   function No_Right_Paren (Expr : Node_Id) return Node_Id is
+   begin
+      if Token = Tok_Right_Paren then
+         Error_Msg_SC ("unexpected right parenthesis");
+         Resync_Expression;
+         return Error;
+      else
+         return Expr;
+      end if;
+   end No_Right_Paren;
+
+   ---------------------
+   -- Pop_Scope_Stack --
+   ---------------------
+
+   procedure Pop_Scope_Stack is
+   begin
+      pragma Assert (Scope.Last > 0);
+      Scope.Decrement_Last;
+
+      if Debug_Flag_P then
+         Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
+         Error_Msg_SC ("decrement scope stack ptr, new value = ^!");
+      end if;
+   end Pop_Scope_Stack;
+
+   ----------------------
+   -- Push_Scope_Stack --
+   ----------------------
+
+   procedure Push_Scope_Stack is
+   begin
+      Scope.Increment_Last;
+      Scope.Table (Scope.Last).Junk := False;
+      Scope.Table (Scope.Last).Node := Empty;
+
+      if Debug_Flag_P then
+         Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
+         Error_Msg_SC ("increment scope stack ptr, new value = ^!");
+      end if;
+   end Push_Scope_Stack;
+
+   ----------------------
+   -- Separate_Present --
+   ----------------------
+
+   function Separate_Present return Boolean is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Separate then
+         return True;
+
+      elsif Token /= Tok_Identifier then
+         return False;
+
+      else
+         Save_Scan_State (Scan_State);
+         Scan; -- past identifier
+
+         if Token = Tok_Semicolon then
+            Restore_Scan_State (Scan_State);
+            return Bad_Spelling_Of (Tok_Separate);
+
+         else
+            Restore_Scan_State (Scan_State);
+            return False;
+         end if;
+      end if;
+   end Separate_Present;
+
+   --------------------------
+   -- Signal_Bad_Attribute --
+   --------------------------
+
+   procedure Signal_Bad_Attribute is
+   begin
+      Error_Msg_N ("unrecognized attribute&", Token_Node);
+
+      --  Check for possible misspelling
+
+      Get_Name_String (Token_Name);
+
+      declare
+         AN : constant String := Name_Buffer (1 .. Name_Len);
+
+      begin
+         Error_Msg_Name_1 := First_Attribute_Name;
+         while Error_Msg_Name_1 <= Last_Attribute_Name loop
+            Get_Name_String (Error_Msg_Name_1);
+
+            if Is_Bad_Spelling_Of
+                 (AN, Name_Buffer (1 .. Name_Len))
+            then
+               Error_Msg_N
+                 ("\possible misspelling of %", Token_Node);
+               exit;
+            end if;
+
+            Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
+         end loop;
+      end;
+   end Signal_Bad_Attribute;
+
+   -------------------------------
+   -- Token_Is_At_Start_Of_Line --
+   -------------------------------
+
+   function Token_Is_At_Start_Of_Line return Boolean is
+   begin
+      return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF);
+   end Token_Is_At_Start_Of_Line;
+
+end Util;

gcc/ada/par.ads

@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P A R                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $                             --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The Par function and its subunits contains all the parsing routines
+--  for the top down recursive descent parser that constructs the parse tree
+
+with Types; use Types;
+
+function Par (Configuration_Pragmas : Boolean) return List_Id;
+--  Top level parsing routine. There are two cases:
+--
+--  If Configuration_Pragmas is False, Par parses a compilation unit in the
+--  current source file and sets the Cunit, Cunit_Entity and Unit_Name fields
+--  of the units table entry for Current_Source_Unit. On return the parse tree
+--  is complete, and decorated with any required implicit label declarations.
+--  The value returned in this case is always No_List.
+--
+--  If Configuration_Pragmas is True, Par parses a list of configuration
+--  pragmas from the current source file, and returns the list of pragmas.

gcc/ada/prj-attr.adb

@@ -0,0 +1,211 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Namet;     use Namet;
+with Output;    use Output;
+
+package body Prj.Attr is
+
+   --  Names end with '#'
+   --  Package names are preceded by 'P'
+   --  Attribute names are preceded by two capital letters:
+   --    'S' for Single or 'L' for list, then
+   --    'V' for single variable, 'A' for associative array, or 'B' for both.
+   --  End is indicated by two consecutive '#'.
+
+   Initialisation_Data : constant String :=
+
+   --  project attributes
+
+     "SVobject_dir#" &
+     "LVsource_dirs#" &
+     "LVsource_files#" &
+     "SVsource_list_file#" &
+     "SVlibrary_dir#" &
+     "SVlibrary_name#" &
+     "SVlibrary_kind#" &
+     "SVlibrary_elaboration#" &
+     "SVlibrary_version#" &
+     "LVmain#" &
+
+   --  package Naming
+
+     "Pnaming#" &
+     "SVspecification_append#" &
+     "SVbody_append#" &
+     "SVseparate_append#" &
+     "SVcasing#" &
+     "SVdot_replacement#" &
+     "SAspecification#" &
+     "SAbody_part#" &
+
+   --  package Compiler
+
+     "Pcompiler#" &
+     "LBswitches#" &
+     "SVlocal_configuration_pragmas#" &
+
+   --  package gnatmake
+
+     "Pgnatmake#" &
+     "LBswitches#" &
+     "SVglobal_configuration_pragmas#" &
+
+   --  package gnatls
+
+     "Pgnatls#" &
+     "LVswitches#" &
+
+   --  package gnatbind
+
+     "Pgnatbind#" &
+     "LBswitches#" &
+
+   --  package gnatlink
+
+     "Pgnatlink#" &
+     "LBswitches#" &
+
+     "#";
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+      Start             : Positive           := Initialisation_Data'First;
+      Finish            : Positive           := Start;
+      Current_Package   : Package_Node_Id    := Empty_Package;
+      Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
+      Is_An_Attribute   : Boolean            := False;
+      Kind_1            : Variable_Kind      := Undefined;
+      Kind_2            : Attribute_Kind     := Single;
+      Package_Name      : Name_Id            := No_Name;
+      Attribute_Name    : Name_Id            := No_Name;
+      First_Attribute   : Attribute_Node_Id  := Attribute_First;
+   begin
+
+      --  Make sure the two tables are empty
+
+      Attributes.Set_Last (Attributes.First);
+      Package_Attributes.Set_Last (Package_Attributes.First);
+
+      while Initialisation_Data (Start) /= '#' loop
+         Is_An_Attribute := True;
+         case Initialisation_Data (Start) is
+            when 'P' =>
+               --  New allowed package
+               Start := Start + 1;
+               Finish := Start;
+               while Initialisation_Data (Finish) /= '#' loop
+                  Finish := Finish + 1;
+               end loop;
+               Name_Len := Finish - Start;
+               Name_Buffer (1 .. Name_Len) :=
+                 To_Lower (Initialisation_Data (Start .. Finish - 1));
+               Package_Name := Name_Find;
+               for Index in Package_First .. Package_Attributes.Last loop
+                  if Package_Name = Package_Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate package name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+
+               Is_An_Attribute := False;
+               Current_Attribute := Empty_Attribute;
+               Package_Attributes.Increment_Last;
+               Current_Package := Package_Attributes.Last;
+               Package_Attributes.Table (Current_Package).Name :=
+                 Package_Name;
+               Start := Finish + 1;
+            when 'S' =>
+               Kind_1 := Single;
+            when 'L' =>
+               Kind_1 := List;
+            when others =>
+               raise Program_Error;
+         end case;
+
+         if Is_An_Attribute then
+            --  New attribute
+            Start := Start + 1;
+            case Initialisation_Data (Start) is
+               when 'V' =>
+                  Kind_2 := Single;
+               when 'A' =>
+                  Kind_2 := Associative_Array;
+               when 'B' =>
+                  Kind_2 := Both;
+               when others =>
+                  raise Program_Error;
+            end case;
+            Start := Start + 1;
+            Finish := Start;
+            while Initialisation_Data (Finish) /= '#' loop
+               Finish := Finish + 1;
+            end loop;
+            Name_Len := Finish - Start;
+            Name_Buffer (1 .. Name_Len) :=
+              To_Lower (Initialisation_Data (Start .. Finish - 1));
+            Attribute_Name := Name_Find;
+            Attributes.Increment_Last;
+            if Current_Attribute = Empty_Attribute then
+               First_Attribute := Attributes.Last;
+               if Current_Package /= Empty_Package then
+                  Package_Attributes.Table (Current_Package).First_Attribute
+                    := Attributes.Last;
+               end if;
+            else
+               --  Check that there are no duplicate attributes
+               for Index in First_Attribute .. Attributes.Last - 1 loop
+                  if Attribute_Name =
+                    Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate attribute name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+               Attributes.Table (Current_Attribute).Next :=
+                 Attributes.Last;
+            end if;
+            Current_Attribute := Attributes.Last;
+            Attributes.Table (Current_Attribute) :=
+              (Name    => Attribute_Name,
+               Kind_1  => Kind_1,
+               Kind_2  => Kind_2,
+               Next    => Empty_Attribute);
+            Start := Finish + 1;
+         end if;
+      end loop;
+   end Initialize;
+
+end Prj.Attr;

gcc/ada/prj-attr.ads

@@ -0,0 +1,108 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package defines allowed packages and attributes in GNAT project
+--  files.
+
+with Types; use Types;
+with Table;
+
+package Prj.Attr is
+
+   --  Define the allowed attributes
+
+   Attributes_Initial   : constant := 50;
+   Attributes_Increment : constant := 50;
+
+   Attribute_Node_Low_Bound  : constant := 0;
+   Attribute_Node_High_Bound : constant := 099_999_999;
+
+   type Attribute_Node_Id is
+     range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
+
+   First_Attribute_Node_Id : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   Empty_Attribute : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   type Attribute_Kind is (Single, Associative_Array, Both);
+
+   type Attribute_Record is record
+      Name     : Name_Id;
+      Kind_1   : Variable_Kind;
+      Kind_2   : Attribute_Kind;
+      Next     : Attribute_Node_Id;
+   end record;
+
+   package Attributes is
+      new Table.Table (Table_Component_Type => Attribute_Record,
+                       Table_Index_Type     => Attribute_Node_Id,
+                       Table_Low_Bound      => First_Attribute_Node_Id,
+                       Table_Initial        => Attributes_Initial,
+                       Table_Increment      => Attributes_Increment,
+                       Table_Name           => "Prj.Attr.Attributes");
+
+   Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id + 1;
+
+   --  Define the allowed packages
+
+   Packages_Initial   : constant := 10;
+   Packages_Increment : constant := 10;
+
+   Package_Node_Low_Bound  : constant := 0;
+   Package_Node_High_Bound : constant := 099_999_999;
+
+   type Package_Node_Id is
+     range Package_Node_Low_Bound .. Package_Node_High_Bound;
+
+   First_Package_Node_Id : constant Package_Node_Id
+     := Package_Node_Low_Bound;
+
+   Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound;
+
+   type Package_Record is record
+      Name            : Name_Id;
+      First_Attribute : Attribute_Node_Id;
+   end record;
+
+   package Package_Attributes is
+      new Table.Table (Table_Component_Type => Package_Record,
+                       Table_Index_Type     => Package_Node_Id,
+                       Table_Low_Bound      => First_Package_Node_Id,
+                       Table_Initial        => Packages_Initial,
+                       Table_Increment      => Packages_Increment,
+                       Table_Name           => "Prj.Attr.Packages");
+
+   Package_First : constant Package_Node_Id := Package_Node_Low_Bound + 1;
+
+   procedure Initialize;
+   --  Initialize the two tables above (Attributes and Package_Attributes).
+   --  This procedure should be called by Prj.Initialize.
+
+end Prj.Attr;

gcc/ada/prj-com.adb

@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Namet;   use Namet;
+with Stringt; use Stringt;
+
+package body Prj.Com is
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (Name : Name_Id) return Header_Num is
+   begin
+      return Hash (Get_Name_String (Name));
+   end Hash;
+
+   function Hash (Name : String_Id) return Header_Num is
+   begin
+      String_To_Name_Buffer (Name);
+      return Hash (Name_Buffer (1 .. Name_Len));
+   end Hash;
+
+end Prj.Com;

gcc/ada/prj-com.ads

@@ -0,0 +1,92 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The following package declares data types for GNAT project.
+--  These data types are used in the bodies of the Prj hierarchy.
+
+with GNAT.HTable;
+with Table;
+with Types; use Types;
+
+package Prj.Com is
+
+   --  At one point, this package was private.
+   --  It cannot be private, because it is used outside of
+   --  the Prj hierarchy.
+
+   Tool_Name : Name_Id := No_Name;
+
+   Current_Verbosity : Verbosity := Default;
+
+   type Spec_Or_Body is
+     (Specification, Body_Part);
+
+   type File_Name_Data is record
+      Name         : Name_Id := No_Name;
+      Path         : Name_Id := No_Name;
+      Project      : Project_Id := No_Project;
+      Needs_Pragma : Boolean := False;
+   end record;
+   --  File and Path name of a spec or body.
+
+   type File_Names_Data is array (Spec_Or_Body) of File_Name_Data;
+
+   type Unit_Id is new Nat;
+   No_Unit : constant Unit_Id := 0;
+   type Unit_Data is record
+      Name       : Name_Id    := No_Name;
+      File_Names : File_Names_Data;
+   end record;
+   --  File and Path names of a unit, with a reference to its
+   --  GNAT Project File.
+
+   package Units is new Table.Table
+     (Table_Component_Type => Unit_Data,
+      Table_Index_Type     => Unit_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Com.Units");
+
+   type Header_Num is range 0 .. 2047;
+
+   function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
+
+   function Hash (Name : Name_Id) return Header_Num;
+
+   function Hash (Name : String_Id) return Header_Num;
+
+   package Units_Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Unit_Id,
+      No_Element => No_Unit,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+end Prj.Com;

gcc/ada/prj-dect.adb

@@ -0,0 +1,942 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . D E C T                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Errout;     use Errout;
+with Prj.Strt;
+with Prj.Tree;   use Prj.Tree;
+with Scans;      use Scans;
+with Sinfo;      use Sinfo;
+with Types;      use Types;
+with Prj.Attr;   use Prj.Attr;
+
+package body Prj.Dect is
+
+   type Zone is (In_Project, In_Package, In_Case_Construction);
+
+   procedure Parse_Attribute_Declaration
+     (Attribute         : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse an attribute declaration.
+
+   procedure Parse_Case_Construction
+     (Case_Construction : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse a case construction
+
+   procedure Parse_Declarative_Items
+     (Declarations      : out Project_Node_Id;
+      In_Zone           : Zone;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse declarative items. Depending on In_Zone, some declarative
+   --  items may be forbiden.
+
+   procedure Parse_Package_Declaration
+     (Package_Declaration : out Project_Node_Id;
+      Current_Project     : Project_Node_Id);
+   --  Parse a package declaration
+
+   procedure Parse_String_Type_Declaration
+     (String_Type       : out Project_Node_Id;
+      Current_Project   : Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id);
+   --  type <name> is ( <literal_string> { , <literal_string> } ) ;
+
+   procedure Parse_Variable_Declaration
+     (Variable          : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse a variable assignment
+   --  <variable_Name> := <expression>; OR
+   --  <variable_Name> : <string_type_Name> := <string_expression>;
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Declarations    : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Modifying       : Project_Node_Id)
+   is
+      First_Declarative_Item : Project_Node_Id := Empty_Node;
+
+   begin
+      Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
+      Set_Location_Of (Declarations, To => Token_Ptr);
+      Set_Modified_Project_Of (Declarations, To => Modifying);
+      Parse_Declarative_Items
+        (Declarations    => First_Declarative_Item,
+         In_Zone         => In_Project,
+         First_Attribute => Prj.Attr.Attribute_First,
+         Current_Project => Current_Project,
+         Current_Package => Empty_Node);
+      Set_First_Declarative_Item_Of
+        (Declarations, To => First_Declarative_Item);
+   end Parse;
+
+   ---------------------------------
+   -- Parse_Attribute_Declaration --
+   ---------------------------------
+
+   procedure Parse_Attribute_Declaration
+     (Attribute       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Attribute : Attribute_Node_Id := First_Attribute;
+
+   begin
+      Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
+      Set_Location_Of (Attribute, To => Token_Ptr);
+
+      --  Scan past "for"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Attribute, To => Token_Name);
+         Set_Location_Of (Attribute, To => Token_Ptr);
+         while Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Name /= Token_Name
+         loop
+            Current_Attribute := Attributes.Table (Current_Attribute).Next;
+         end loop;
+
+         if Current_Attribute = Empty_Attribute then
+            Error_Msg ("undefined attribute", Token_Ptr);
+         end if;
+
+         Scan;
+      end if;
+
+      if Token = Tok_Left_Paren then
+         if Current_Attribute /= Empty_Attribute
+           and then Attributes.Table (Current_Attribute).Kind_2 = Single
+         then
+            Error_Msg ("this attribute cannot be an associative array",
+                       Location_Of (Attribute));
+         end if;
+
+         Scan;
+         Expect (Tok_String_Literal, "literal string");
+
+         if Token = Tok_String_Literal then
+            Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
+            Scan;
+         end if;
+
+         Expect (Tok_Right_Paren, ")");
+
+         if Token = Tok_Right_Paren then
+            Scan;
+         end if;
+
+      else
+         if Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Kind_2 = Associative_Array
+         then
+            Error_Msg ("this attribute need to be an associative array",
+                       Location_Of (Attribute));
+         end if;
+      end if;
+
+      if Current_Attribute /= Empty_Attribute then
+         Set_Expression_Kind_Of
+           (Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
+      end if;
+
+      Expect (Tok_Use, "use");
+
+      if Token = Tok_Use then
+         Scan;
+
+         declare
+            Expression_Location : constant Source_Ptr := Token_Ptr;
+            Expression          : Project_Node_Id     := Empty_Node;
+
+         begin
+            Prj.Strt.Parse_Expression
+              (Expression      => Expression,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+            Set_Expression_Of (Attribute, To => Expression);
+
+            if Current_Attribute /= Empty_Attribute
+              and then Expression /= Empty_Node
+              and then Attributes.Table (Current_Attribute).Kind_1 /=
+                                          Expression_Kind_Of (Expression)
+            then
+               Error_Msg
+                 ("wrong expression kind for the attribute",
+                  Expression_Location);
+            end if;
+         end;
+      end if;
+
+   end Parse_Attribute_Declaration;
+
+   -----------------------------
+   -- Parse_Case_Construction --
+   -----------------------------
+
+   procedure Parse_Case_Construction
+     (Case_Construction : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id)
+   is
+      Current_Item      : Project_Node_Id := Empty_Node;
+      Next_Item         : Project_Node_Id := Empty_Node;
+      First_Case_Item   : Boolean := True;
+
+      Variable_Location : Source_Ptr := No_Location;
+
+      String_Type       : Project_Node_Id := Empty_Node;
+
+      Case_Variable     : Project_Node_Id := Empty_Node;
+
+      First_Declarative_Item : Project_Node_Id := Empty_Node;
+
+      First_Choice      : Project_Node_Id := Empty_Node;
+
+   begin
+      Case_Construction  :=
+        Default_Project_Node (Of_Kind => N_Case_Construction);
+      Set_Location_Of (Case_Construction, To => Token_Ptr);
+
+      --  Scan past "case"
+
+      Scan;
+
+      --  Get the switch variable
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Variable_Location := Token_Ptr;
+         Prj.Strt.Parse_Variable_Reference
+           (Variable        => Case_Variable,
+            Current_Project => Current_Project,
+            Current_Package => Current_Package);
+         Set_Case_Variable_Reference_Of
+           (Case_Construction, To => Case_Variable);
+
+      else
+         if Token /= Tok_Is then
+            Scan;
+         end if;
+      end if;
+
+      if Case_Variable /= Empty_Node then
+         String_Type := String_Type_Of (Case_Variable);
+
+         if String_Type = Empty_Node then
+            Error_Msg ("this variable is not typed", Variable_Location);
+         end if;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      if Token = Tok_Is then
+
+         --  Scan past "is"
+
+         Scan;
+      end if;
+
+      Prj.Strt.Start_New_Case_Construction (String_Type);
+
+      When_Loop :
+
+      while Token = Tok_When loop
+
+         if First_Case_Item then
+            Current_Item := Default_Project_Node (Of_Kind => N_Case_Item);
+            Set_First_Case_Item_Of (Case_Construction, To => Current_Item);
+            First_Case_Item := False;
+
+         else
+            Next_Item := Default_Project_Node (Of_Kind => N_Case_Item);
+            Set_Next_Case_Item (Current_Item, To => Next_Item);
+            Current_Item := Next_Item;
+         end if;
+
+         Set_Location_Of (Current_Item, To => Token_Ptr);
+
+         --  Scan past "when"
+
+         Scan;
+
+         if Token = Tok_Others then
+
+            --  Scan past "others"
+
+            Scan;
+
+            Expect (Tok_Arrow, "=>");
+
+            --  Empty_Node in Field1 of a Case_Item indicates
+            --  the "when others =>" branch.
+
+            Set_First_Choice_Of (Current_Item, To => Empty_Node);
+
+            Parse_Declarative_Items
+              (Declarations    => First_Declarative_Item,
+               In_Zone         => In_Case_Construction,
+               First_Attribute => First_Attribute,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+
+            --  "when others =>" must be the last branch, so save the
+            --  Case_Item and exit
+
+            Set_First_Declarative_Item_Of
+              (Current_Item, To => First_Declarative_Item);
+            exit When_Loop;
+
+         else
+            Prj.Strt.Parse_Choice_List (First_Choice => First_Choice);
+            Set_First_Choice_Of (Current_Item, To => First_Choice);
+
+            Expect (Tok_Arrow, "=>");
+
+            Parse_Declarative_Items
+              (Declarations    => First_Declarative_Item,
+               In_Zone         => In_Case_Construction,
+               First_Attribute => First_Attribute,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+
+            Set_First_Declarative_Item_Of
+              (Current_Item, To => First_Declarative_Item);
+
+         end if;
+      end loop When_Loop;
+
+      Prj.Strt.End_Case_Construction;
+
+      Expect (Tok_End, "end case");
+
+      if Token = Tok_End then
+
+         --  Scan past "end"
+
+         Scan;
+
+         Expect (Tok_Case, "case");
+
+      end if;
+
+      --  Scan past "case"
+
+      Scan;
+
+      Expect (Tok_Semicolon, ";");
+
+   end Parse_Case_Construction;
+
+   -----------------------------
+   -- Parse_Declarative_Items --
+   -----------------------------
+
+   procedure Parse_Declarative_Items
+     (Declarations    : out Project_Node_Id;
+      In_Zone         : Zone;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Declarative_Item : Project_Node_Id := Empty_Node;
+      Next_Declarative_Item    : Project_Node_Id := Empty_Node;
+      Current_Declaration      : Project_Node_Id := Empty_Node;
+      Item_Location            : Source_Ptr      := No_Location;
+
+   begin
+      Declarations := Empty_Node;
+
+      loop
+         --  We are always positioned at the token that precedes
+         --  the first token of the declarative element.
+         --  Scan past it
+
+         Scan;
+
+         Item_Location := Token_Ptr;
+
+         case Token is
+            when Tok_Identifier =>
+
+               if In_Zone = In_Case_Construction then
+                  Error_Msg ("a variable cannot be declared here",
+                             Token_Ptr);
+               end if;
+
+               Parse_Variable_Declaration
+                 (Current_Declaration,
+                  First_Attribute => First_Attribute,
+                  Current_Project => Current_Project,
+                  Current_Package => Current_Package);
+
+            when Tok_For =>
+
+               Parse_Attribute_Declaration
+                 (Attribute       => Current_Declaration,
+                  First_Attribute => First_Attribute,
+                  Current_Project => Current_Project,
+                  Current_Package => Current_Package);
+
+            when Tok_Package =>
+
+               --  Package declaration
+
+               if In_Zone /= In_Project then
+                  Error_Msg ("a package cannot be declared here", Token_Ptr);
+               end if;
+
+               Parse_Package_Declaration
+                 (Package_Declaration => Current_Declaration,
+                  Current_Project     => Current_Project);
+
+            when Tok_Type =>
+
+               --  Type String Declaration
+
+               if In_Zone /= In_Project then
+                  Error_Msg ("a string type cannot be declared here",
+                             Token_Ptr);
+               end if;
+
+               Parse_String_Type_Declaration
+                 (String_Type     => Current_Declaration,
+                  Current_Project => Current_Project,
+                  First_Attribute => First_Attribute);
+
+            when Tok_Case =>
+
+               --  Case construction
+
+               Parse_Case_Construction
+                 (Case_Construction => Current_Declaration,
+                  First_Attribute   => First_Attribute,
+                  Current_Project   => Current_Project,
+                  Current_Package   => Current_Package);
+
+            when others =>
+               exit;
+
+               --  We are leaving Parse_Declarative_Items positionned
+               --  at the first token after the list of declarative items.
+               --  It could be "end" (for a project, a package declaration or
+               --  a case construction) or "when" (for a case construction)
+
+         end case;
+
+         Expect (Tok_Semicolon, "; after declarative items");
+
+         if Current_Declarative_Item = Empty_Node then
+            Current_Declarative_Item :=
+              Default_Project_Node (Of_Kind => N_Declarative_Item);
+            Declarations  := Current_Declarative_Item;
+
+         else
+            Next_Declarative_Item :=
+              Default_Project_Node (Of_Kind => N_Declarative_Item);
+            Set_Next_Declarative_Item
+              (Current_Declarative_Item, To => Next_Declarative_Item);
+            Current_Declarative_Item := Next_Declarative_Item;
+         end if;
+
+         Set_Current_Item_Node
+           (Current_Declarative_Item, To => Current_Declaration);
+         Set_Location_Of (Current_Declarative_Item, To => Item_Location);
+
+      end loop;
+
+   end Parse_Declarative_Items;
+
+   -------------------------------
+   -- Parse_Package_Declaration --
+   -------------------------------
+
+   procedure Parse_Package_Declaration
+     (Package_Declaration : out Project_Node_Id;
+      Current_Project     : Project_Node_Id)
+   is
+      First_Attribute        : Attribute_Node_Id := Empty_Attribute;
+      Current_Package        : Package_Node_Id   := Empty_Package;
+      First_Declarative_Item : Project_Node_Id   := Empty_Node;
+
+   begin
+      Package_Declaration :=
+        Default_Project_Node (Of_Kind => N_Package_Declaration);
+      Set_Location_Of (Package_Declaration, To => Token_Ptr);
+
+      --  Scan past "package"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+
+         Set_Name_Of (Package_Declaration, To => Token_Name);
+
+         for Index in Package_Attributes.First .. Package_Attributes.Last loop
+            if Token_Name = Package_Attributes.Table (Index).Name then
+               First_Attribute :=
+                 Package_Attributes.Table (Index).First_Attribute;
+               Current_Package := Index;
+               exit;
+            end if;
+         end loop;
+
+         if Current_Package  = Empty_Package then
+            Error_Msg ("not an allowed package name", Token_Ptr);
+
+         else
+            Set_Package_Id_Of (Package_Declaration, To => Current_Package);
+
+            declare
+               Current : Project_Node_Id := First_Package_Of (Current_Project);
+
+            begin
+               while Current /= Empty_Node
+                 and then Name_Of (Current) /= Token_Name
+               loop
+                  Current := Next_Package_In_Project (Current);
+               end loop;
+
+               if Current /= Empty_Node then
+                  Error_Msg
+                    ("package declared twice in the same project", Token_Ptr);
+
+               else
+                  --  Add the package to the project list
+
+                  Set_Next_Package_In_Project
+                    (Package_Declaration,
+                     To => First_Package_Of (Current_Project));
+                  Set_First_Package_Of
+                    (Current_Project, To => Package_Declaration);
+               end if;
+            end;
+         end if;
+
+         --  Scan past the package name
+
+         Scan;
+
+      end if;
+
+      if Token = Tok_Renames then
+         --  Scan past "renames"
+         Scan;
+
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier then
+            declare
+               Project_Name : Name_Id := Token_Name;
+               Clause       : Project_Node_Id :=
+                                First_With_Clause_Of (Current_Project);
+               The_Project  : Project_Node_Id := Empty_Node;
+
+            begin
+               while Clause /= Empty_Node loop
+                  The_Project := Project_Node_Of (Clause);
+                  exit when Name_Of (The_Project) = Project_Name;
+                  Clause := Next_With_Clause_Of (Clause);
+               end loop;
+
+               if Clause = Empty_Node then
+                  Error_Msg ("not an imported project", Token_Ptr);
+               else
+                  Set_Project_Of_Renamed_Package_Of
+                    (Package_Declaration, To => The_Project);
+               end if;
+            end;
+
+            Scan;
+            Expect (Tok_Dot, ".");
+
+            if Token = Tok_Dot then
+               Scan;
+               Expect (Tok_Identifier, "identifier");
+
+               if Token = Tok_Identifier then
+                  if Name_Of (Package_Declaration) /= Token_Name then
+                     Error_Msg ("not the same package name", Token_Ptr);
+                  elsif
+                    Project_Of_Renamed_Package_Of (Package_Declaration)
+                                                              /= Empty_Node
+                  then
+                     declare
+                        Current : Project_Node_Id :=
+                                    First_Package_Of
+                                      (Project_Of_Renamed_Package_Of
+                                         (Package_Declaration));
+
+                     begin
+                        while Current /= Empty_Node
+                          and then Name_Of (Current) /= Token_Name
+                        loop
+                           Current := Next_Package_In_Project (Current);
+                        end loop;
+
+                        if Current = Empty_Node then
+                           Error_Msg
+                             ("not a package declared by the project",
+                              Token_Ptr);
+                        end if;
+                     end;
+                  end if;
+
+                  Scan;
+               end if;
+            end if;
+         end if;
+
+         Expect (Tok_Semicolon, ";");
+
+      elsif Token = Tok_Is then
+
+         Parse_Declarative_Items
+           (Declarations    => First_Declarative_Item,
+            In_Zone         => In_Package,
+            First_Attribute => First_Attribute,
+            Current_Project => Current_Project,
+            Current_Package => Package_Declaration);
+
+         Set_First_Declarative_Item_Of
+           (Package_Declaration, To => First_Declarative_Item);
+
+         Expect (Tok_End, "end");
+
+         if Token = Tok_End then
+
+            --  Scan past "end"
+
+            Scan;
+         end if;
+
+         --  We should have the name of the package after "end"
+
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier
+           and then Name_Of (Package_Declaration) /= No_Name
+           and then Token_Name /= Name_Of (Package_Declaration)
+         then
+            Error_Msg_Name_1 := Name_Of (Package_Declaration);
+            Error_Msg ("expected {", Token_Ptr);
+         end if;
+
+         if Token /= Tok_Semicolon then
+
+            --  Scan past the package name
+
+            Scan;
+         end if;
+
+         Expect (Tok_Semicolon, ";");
+
+      else
+         Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
+      end if;
+
+   end Parse_Package_Declaration;
+
+   -----------------------------------
+   -- Parse_String_Type_Declaration --
+   -----------------------------------
+
+   procedure Parse_String_Type_Declaration
+     (String_Type     : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      First_Attribute : Attribute_Node_Id)
+   is
+      Current      : Project_Node_Id := Empty_Node;
+      First_String : Project_Node_Id := Empty_Node;
+
+   begin
+      String_Type :=
+        Default_Project_Node (Of_Kind => N_String_Type_Declaration);
+
+      Set_Location_Of (String_Type, To => Token_Ptr);
+
+      --  Scan past "type"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (String_Type, To => Token_Name);
+
+         Current := First_String_Type_Of (Current_Project);
+         while Current /= Empty_Node
+           and then
+           Name_Of (Current) /= Token_Name
+         loop
+            Current := Next_String_Type (Current);
+         end loop;
+
+         if Current /= Empty_Node then
+            Error_Msg ("duplicate string type name", Token_Ptr);
+         else
+            Current := First_Variable_Of (Current_Project);
+            while Current /= Empty_Node
+              and then Name_Of (Current) /= Token_Name
+            loop
+               Current := Next_Variable (Current);
+            end loop;
+
+            if Current /= Empty_Node then
+               Error_Msg ("already a variable name", Token_Ptr);
+            else
+               Set_Next_String_Type
+                 (String_Type, To => First_String_Type_Of (Current_Project));
+               Set_First_String_Type_Of (Current_Project, To => String_Type);
+            end if;
+         end if;
+
+         --  Scan past the name
+
+         Scan;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      if Token = Tok_Is then
+         Scan;
+      end if;
+
+      Expect (Tok_Left_Paren, "(");
+
+      if Token = Tok_Left_Paren then
+         Scan;
+      end if;
+
+      Prj.Strt.Parse_String_Type_List (First_String => First_String);
+      Set_First_Literal_String (String_Type, To => First_String);
+
+      Expect (Tok_Right_Paren, ")");
+
+      if Token = Tok_Right_Paren then
+         Scan;
+      end if;
+
+   end Parse_String_Type_Declaration;
+
+   --------------------------------
+   -- Parse_Variable_Declaration --
+   --------------------------------
+
+   procedure Parse_Variable_Declaration
+     (Variable        : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Expression_Location      : Source_Ptr;
+      String_Type_Name         : Name_Id := No_Name;
+      Project_String_Type_Name : Name_Id := No_Name;
+      Type_Location            : Source_Ptr := No_Location;
+      Project_Location         : Source_Ptr := No_Location;
+      Expression               : Project_Node_Id := Empty_Node;
+      Variable_Name            : constant Name_Id := Token_Name;
+
+   begin
+      Variable :=
+        Default_Project_Node (Of_Kind => N_Variable_Declaration);
+      Set_Name_Of (Variable, To => Variable_Name);
+      Set_Location_Of (Variable, To => Token_Ptr);
+
+      --  Scan past the variable name
+
+      Scan;
+
+      if Token = Tok_Colon then
+
+         --  Typed string variable declaration
+
+         Scan;
+         Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier then
+            String_Type_Name := Token_Name;
+            Type_Location := Token_Ptr;
+            Scan;
+
+            if Token = Tok_Dot then
+               Project_String_Type_Name := String_Type_Name;
+               Project_Location := Type_Location;
+
+               --  Scan past the dot
+
+               Scan;
+               Expect (Tok_Identifier, "identifier");
+
+               if Token = Tok_Identifier then
+                  String_Type_Name := Token_Name;
+                  Type_Location := Token_Ptr;
+                  Scan;
+               else
+                  String_Type_Name := No_Name;
+               end if;
+            end if;
+
+            if String_Type_Name /= No_Name then
+               declare
+                  Current : Project_Node_Id :=
+                              First_String_Type_Of (Current_Project);
+
+               begin
+                  if Project_String_Type_Name /= No_Name then
+                     declare
+                        The_Project_Name_And_Node : constant
+                          Tree_Private_Part.Project_Name_And_Node :=
+                          Tree_Private_Part.Projects_Htable.Get
+                                                    (Project_String_Type_Name);
+
+                        use Tree_Private_Part;
+
+                     begin
+                        if The_Project_Name_And_Node =
+                          Tree_Private_Part.No_Project_Name_And_Node
+                        then
+                           Error_Msg ("unknown project", Project_Location);
+                           Current := Empty_Node;
+                        else
+                           Current :=
+                             First_String_Type_Of
+                                         (The_Project_Name_And_Node.Node);
+                        end if;
+                     end;
+                  end if;
+
+                  while Current /= Empty_Node
+                    and then Name_Of (Current) /= String_Type_Name
+                  loop
+                     Current := Next_String_Type (Current);
+                  end loop;
+
+                  if Current = Empty_Node then
+                     Error_Msg ("unknown string type", Type_Location);
+                  else
+                     Set_String_Type_Of
+                       (Variable, To => Current);
+                  end if;
+               end;
+            end if;
+         end if;
+      end if;
+
+      Expect (Tok_Colon_Equal, ":=");
+
+      if Token = Tok_Colon_Equal then
+         Scan;
+      end if;
+
+      --  Get the single string or string list value
+
+      Expression_Location := Token_Ptr;
+
+      Prj.Strt.Parse_Expression
+        (Expression      => Expression,
+         Current_Project => Current_Project,
+         Current_Package => Current_Package);
+      Set_Expression_Of (Variable, To => Expression);
+
+      if Expression /= Empty_Node then
+         Set_Expression_Kind_Of
+           (Variable, To => Expression_Kind_Of (Expression));
+      end if;
+
+      declare
+         The_Variable : Project_Node_Id := Empty_Node;
+
+      begin
+         if Current_Package /= Empty_Node then
+            The_Variable :=  First_Variable_Of (Current_Package);
+         elsif Current_Project /= Empty_Node then
+            The_Variable :=  First_Variable_Of (Current_Project);
+         end if;
+
+         while The_Variable /= Empty_Node
+           and then Name_Of (The_Variable) /= Variable_Name
+         loop
+            The_Variable := Next_Variable (The_Variable);
+         end loop;
+
+         if The_Variable = Empty_Node then
+            if Current_Package /= Empty_Node then
+               Set_Next_Variable
+                 (Variable, To => First_Variable_Of (Current_Package));
+               Set_First_Variable_Of (Current_Package, To => Variable);
+
+            elsif Current_Project /= Empty_Node then
+               Set_Next_Variable
+                 (Variable, To => First_Variable_Of (Current_Project));
+               Set_First_Variable_Of (Current_Project, To => Variable);
+            end if;
+
+         else
+            if Expression_Kind_Of (Variable) /= Undefined then
+               if Expression_Kind_Of (The_Variable) = Undefined then
+                  Set_Expression_Kind_Of
+                    (The_Variable, To => Expression_Kind_Of (Variable));
+
+               else
+                  if Expression_Kind_Of (The_Variable) /=
+                                                 Expression_Kind_Of (Variable)
+                  then
+                     Error_Msg ("wrong expression kind for the variable",
+                                Expression_Location);
+                  end if;
+               end if;
+            end if;
+         end if;
+      end;
+
+   end Parse_Variable_Declaration;
+
+end Prj.Dect;

gcc/ada/prj-dect.ads

@@ -0,0 +1,41 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . D E C T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Parse a list of declarative items in a project file.
+
+with Prj.Tree;
+
+private package Prj.Dect is
+
+   procedure Parse
+     (Declarations    : out Prj.Tree.Project_Node_Id;
+      Current_Project : Prj.Tree.Project_Node_Id;
+      Modifying       : Prj.Tree.Project_Node_Id);
+   --  Parse project declarative items.
+
+end Prj.Dect;

gcc/ada/prj-env.ads

@@ -0,0 +1,99 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E N V                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package implements services for Project-aware tools, related
+--  to the environment (gnat.adc, ADA_INCLUDE_PATH, ADA_OBJECTS_PATH)
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Prj.Env is
+
+   procedure Initialize;
+   --  Put Standard_Naming_Data into Namings table (called by Prj.Initialize)
+
+   procedure Print_Sources;
+   --  Output the list of sources, after Project files have been scanned
+
+   procedure Create_Config_Pragmas_File
+     (For_Project  : Project_Id;
+      Main_Project : Project_Id);
+   --  If there needs to have SFN pragmas, either for non standard naming
+   --  schemes or for individual units, or if Global_Configuration_Pragmas
+   --  has been specified in package gnatmake of the main project, or if
+   --  Local_Configuration_Pragmas has been specified in package Compiler
+   --  of the main project, build (if needed) a temporary file that contains
+   --  all configuration pragmas, and specify the configuration pragmas file
+   --  in the project data.
+
+   function Ada_Include_Path (Project : Project_Id) return String_Access;
+   --  Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute
+   --  it and cache it.
+
+   function Ada_Objects_Path
+     (Project             : Project_Id;
+      Including_Libraries : Boolean := True)
+      return                String_Access;
+   --  Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
+   --  it and cache it. When Including_Libraries is False, do not include the
+   --  object directories of the library projects, and do not cache the result.
+
+   function Path_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the Path of a library unit.
+
+   function File_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the file name of a library unit, in canonical case. Name may or
+   --  may not have an extension (corresponding to the naming scheme of the
+   --  project). If there is no body with this name, but there is a spec, the
+   --  name of the spec is returned. If neither a body or a spec can be found,
+   --  return an empty string.
+
+   procedure Get_Reference
+     (Source_File_Name : String;
+      Project          : out Project_Id;
+      Path             : out Name_Id);
+   --  Returns the project of a source.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Source_Dirs (Project : Project_Id);
+   --  Iterate through all the source directories of a project,
+   --  including those of imported or modified projects.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Object_Dirs (Project : Project_Id);
+   --  Iterate through all the object directories of a project,
+   --  including those of imported or modified projects.
+
+end Prj.Env;

gcc/ada/prj-ext.adb

@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with GNAT.HTable;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Prj.Com;     use Prj.Com;
+with Stringt;     use Stringt;
+with Types;       use Types;
+
+package body Prj.Ext is
+
+   package Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => String_Id,
+      No_Element => No_String,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add
+     (External_Name : String;
+      Value         : String)
+   is
+      The_Key   : Name_Id;
+      The_Value : String_Id;
+
+   begin
+      Start_String;
+      Store_String_Chars (Value);
+      The_Value := End_String;
+      Name_Len := External_Name'Length;
+      Name_Buffer (1 .. Name_Len) := External_Name;
+      The_Key := Name_Find;
+      Htable.Set (The_Key, The_Value);
+   end Add;
+
+   -----------
+   -- Check --
+   -----------
+
+   function Check (Declaration : String) return Boolean is
+   begin
+      for Equal_Pos in Declaration'Range loop
+
+         if Declaration (Equal_Pos) = '=' then
+            exit when Equal_Pos = Declaration'First;
+            exit when Equal_Pos = Declaration'Last;
+            Add
+              (External_Name =>
+                 Declaration (Declaration'First .. Equal_Pos - 1),
+               Value =>
+                 Declaration (Equal_Pos + 1 .. Declaration'Last));
+            return True;
+         end if;
+
+      end loop;
+
+      return False;
+   end Check;
+
+   --------------
+   -- Value_Of --
+   --------------
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id
+   is
+      The_Value : String_Id;
+
+   begin
+      The_Value := Htable.Get (External_Name);
+
+      if The_Value /= No_String then
+         return The_Value;
+      end if;
+
+      --  Find if it is an environment.
+      --  If it is, put the value in the hash table.
+
+      declare
+         Env_Value : constant String_Access :=
+           Getenv (Get_Name_String (External_Name));
+
+      begin
+         if Env_Value /= null and then Env_Value'Length > 0 then
+            Start_String;
+            Store_String_Chars (Env_Value.all);
+            The_Value := End_String;
+            Htable.Set (External_Name, The_Value);
+            return The_Value;
+
+         else
+            return With_Default;
+         end if;
+      end;
+   end Value_Of;
+
+end Prj.Ext;

gcc/ada/prj-ext.ads

@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Set, Get and cache External reference, to be used as External functions
+--  in project files.
+
+with Types; use Types;
+
+package Prj.Ext is
+
+   procedure Add
+     (External_Name : String;
+      Value         : String);
+   --  Add an external reference (or modify an existing one).
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id;
+   --  Get the value of an external reference, and cache it for future uses.
+
+   function Check (Declaration : String) return Boolean;
+   --  Check that an external declaration <external>=<value> is correct.
+   --  If it is correct, the external reference is Added.
+
+end Prj.Ext;

gcc/ada/prj-nmsc.ads

@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . N M S C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000-2001 Free Software Foundation, Inc.       --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Check the Naming Scheme of a project file, find the directories
+--  and the source files.
+
+private package Prj.Nmsc is
+
+   procedure Check_Naming_Scheme
+     (Project      : Project_Id;
+      Report_Error : Put_Line_Access);
+   --  Check that the Naming Scheme of a project is legal. Find the
+   --  object directory, the source directories, and the source files.
+   --  Check the source files against the Naming Scheme.
+   --  If Report_Error is null , use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Nmsc;

gcc/ada/prj-pars.adb

@@ -0,0 +1,92 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . P A R S                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with Errout;   use Errout;
+with Output;   use Output;
+with Prj.Com;  use Prj.Com;
+with Prj.Part;
+with Prj.Proc;
+with Prj.Tree; use Prj.Tree;
+
+package body Prj.Pars is
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String)
+   is
+      Project_Tree      : Project_Node_Id := Empty_Node;
+      The_Project       : Project_Id      := No_Project;
+
+   begin
+      --  Parse the main project file into a tree
+
+      Prj.Part.Parse
+        (Project                => Project_Tree,
+         Project_File_Name      => Project_File_Name,
+         Always_Errout_Finalize => False);
+
+      --  If there were no error, process the tree
+
+      if Project_Tree /= Empty_Node then
+         Prj.Proc.Process
+           (Project           => The_Project,
+            From_Project_Node => Project_Tree,
+            Report_Error      => null);
+         Errout.Finalize;
+      end if;
+
+      Project := The_Project;
+
+   exception
+      when X : others =>
+
+         --  Internal error
+
+         Write_Line (Exception_Information (X));
+         Write_Str  ("Exception ");
+         Write_Str  (Exception_Name (X));
+         Write_Line (" raised, while processing project file");
+         Project := No_Project;
+   end Parse;
+
+   -------------------
+   -- Set_Verbosity --
+   -------------------
+
+   procedure Set_Verbosity (To : in Verbosity) is
+   begin
+      Current_Verbosity := To;
+   end Set_Verbosity;
+
+end Prj.Pars;

gcc/ada/prj-pars.ads

@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R S                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files.
+
+package Prj.Pars is
+
+   procedure Set_Verbosity (To : Verbosity);
+   --  Set the verbosity when parsing the project files.
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String);
+   --  Parse a project files and all its imported project files.
+   --  If parsing is successful, Project_Id is the project ID
+   --  of the main project file; otherwise, Project_Id is set
+   --  to No_Project.
+
+end Prj.Pars;

gcc/ada/prj-part.adb

@@ -0,0 +1,871 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . P A R T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling;    use Ada.Characters.Handling;
+with Ada.Exceptions;             use Ada.Exceptions;
+with Errout;                     use Errout;
+with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
+with GNAT.OS_Lib;                use GNAT.OS_Lib;
+with Namet;                      use Namet;
+with Osint;                      use Osint;
+with Output;                     use Output;
+with Prj.Com;                    use Prj.Com;
+with Prj.Dect;
+with Scans;                      use Scans;
+with Scn;                        use Scn;
+with Sinfo;                      use Sinfo;
+with Sinput;                     use Sinput;
+with Sinput.P;                   use Sinput.P;
+with Stringt;                    use Stringt;
+with Table;
+with Types;                      use Types;
+
+pragma Elaborate_All (GNAT.OS_Lib);
+
+package body Prj.Part is
+
+   Dir_Sep  : Character renames GNAT.OS_Lib.Directory_Separator;
+
+   Project_File_Extension : String := ".gpr";
+
+   Project_Path : String_Access;
+   --  The project path; initialized during package elaboration.
+
+   Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
+   Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
+
+   ------------------------------------
+   -- Local Packages and Subprograms --
+   ------------------------------------
+
+   package Project_Stack is new Table.Table
+     (Table_Component_Type => Name_Id,
+      Table_Index_Type     => Nat,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 10,
+      Table_Increment      => 10,
+      Table_Name           => "Prj.Part.Project_Stack");
+   --  This table is used to detect circular dependencies
+   --  for imported and modified projects.
+
+   procedure Parse_Context_Clause
+     (Context_Clause    : out Project_Node_Id;
+      Project_Directory : Name_Id);
+   --  Parse the context clause of a project
+   --  Does nothing if there is b\no context clause (if the current
+   --  token is not "with").
+
+   procedure Parse_Single_Project
+     (Project         : out Project_Node_Id;
+      Path_Name       : String;
+      Modified        : Boolean);
+   --  Parse a project file.
+   --  Recursive procedure: it calls itself for imported and
+   --  modified projects.
+
+   function Path_Name_Of
+     (File_Name : String;
+      Directory : String)
+      return      String;
+   --  Returns the path name of a (non project) file.
+   --  Returns an empty string if file cannot be found.
+
+   function Project_Path_Name_Of
+     (Project_File_Name : String;
+      Directory         : String)
+      return              String;
+   --  Returns the path name of a project file.
+   --  Returns an empty string if project file cannot be found.
+
+   function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
+   --  Get the directory of the file with the specified path name.
+   --  This includes the directory separator as the last character.
+   --  Returns "./" if Path_Name contains no directory separator.
+
+   function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id;
+   --  Returns the name of a file with the specified path name
+   --  with no directory information.
+
+   function Project_Name_From (Path_Name : String) return Name_Id;
+   --  Returns the name of the project that corresponds to its path name.
+   --  Returns No_Name if the path name is invalid, because the corresponding
+   --  project name does not have the syntax of an ada identifier.
+
+   ----------------------------
+   -- Immediate_Directory_Of --
+   ----------------------------
+
+   function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is
+   begin
+      Get_Name_String (Path_Name);
+
+      for Index in reverse 1 .. Name_Len loop
+         if Name_Buffer (Index) = '/'
+           or else Name_Buffer (Index) = Dir_Sep
+         then
+            --  Remove from name all characters after the last
+            --  directory separator.
+
+            Name_Len := Index;
+            return Name_Find;
+         end if;
+      end loop;
+
+      --  There is no directory separator in name. Return "./" or ".\".
+      Name_Len := 2;
+      Name_Buffer (1) := '.';
+      Name_Buffer (2) := Dir_Sep;
+      return Name_Find;
+   end Immediate_Directory_Of;
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Project                : out Project_Node_Id;
+      Project_File_Name      : String;
+      Always_Errout_Finalize : Boolean)
+   is
+      Current_Directory : constant String := Get_Current_Dir;
+
+   begin
+      Project := Empty_Node;
+
+      if Current_Verbosity >= Medium then
+         Write_Str ("ADA_PROJECT_PATH=""");
+         Write_Str (Project_Path.all);
+         Write_Line ("""");
+      end if;
+
+      declare
+         Path_Name : constant String :=
+           Project_Path_Name_Of (Project_File_Name,
+                                 Directory   => Current_Directory);
+
+      begin
+         --  Initialize the tables
+
+         Tree_Private_Part.Project_Nodes.Set_Last (Empty_Node);
+         Tree_Private_Part.Projects_Htable.Reset;
+
+         Errout.Initialize;
+
+         --  And parse the main project file
+
+         if Path_Name = "" then
+            Fail ("project file """ & Project_File_Name & """ not found");
+         end if;
+
+         Parse_Single_Project
+           (Project         => Project,
+            Path_Name       => Path_Name,
+            Modified        => False);
+
+         if Errout.Errors_Detected > 0 then
+            Project := Empty_Node;
+         end if;
+
+         if Project = Empty_Node or else Always_Errout_Finalize then
+            Errout.Finalize;
+         end if;
+      end;
+
+   exception
+      when X : others =>
+
+         --  Internal error
+
+         Write_Line (Exception_Information (X));
+         Write_Str  ("Exception ");
+         Write_Str  (Exception_Name (X));
+         Write_Line (" raised, while processing project file");
+         Project := Empty_Node;
+   end Parse;
+
+   --------------------------
+   -- Parse_Context_Clause --
+   --------------------------
+
+   procedure Parse_Context_Clause
+     (Context_Clause    : out Project_Node_Id;
+      Project_Directory : Name_Id)
+   is
+      Project_Directory_Path : constant String :=
+                                 Get_Name_String (Project_Directory);
+      Current_With_Clause    : Project_Node_Id := Empty_Node;
+      Next_With_Clause       : Project_Node_Id := Empty_Node;
+
+   begin
+      --  Assume no context clause
+
+      Context_Clause := Empty_Node;
+      With_Loop :
+
+      --  If Token is not "with", there is no context clause,
+      --  or we have exhausted the with clauses.
+
+      while Token = Tok_With loop
+         Comma_Loop :
+         loop
+            --  Scan past "with" or ","
+
+            Scan;
+            Expect (Tok_String_Literal, "literal string");
+
+            if Token /= Tok_String_Literal then
+               return;
+            end if;
+
+            --  New with clause
+
+            if Current_With_Clause = Empty_Node then
+
+               --  First with clause of the context clause
+
+               Current_With_Clause := Default_Project_Node
+                 (Of_Kind => N_With_Clause);
+               Context_Clause := Current_With_Clause;
+
+            else
+               Next_With_Clause := Default_Project_Node
+                 (Of_Kind => N_With_Clause);
+               Set_Next_With_Clause_Of (Current_With_Clause, Next_With_Clause);
+               Current_With_Clause := Next_With_Clause;
+            end if;
+
+            Set_String_Value_Of (Current_With_Clause, Strval (Token_Node));
+            Set_Location_Of     (Current_With_Clause, Token_Ptr);
+            String_To_Name_Buffer (String_Value_Of (Current_With_Clause));
+
+            declare
+               Original_Path : constant String :=
+                                 Name_Buffer (1 .. Name_Len);
+
+               Imported_Path_Name : constant String :=
+                                      Project_Path_Name_Of
+                                        (Original_Path,
+                                         Project_Directory_Path);
+
+               Withed_Project : Project_Node_Id := Empty_Node;
+
+            begin
+               if Imported_Path_Name = "" then
+
+                  --  The project file cannot be found
+
+                  Name_Len := Original_Path'Length;
+                  Name_Buffer (1 .. Name_Len) := Original_Path;
+                  Error_Msg_Name_1 := Name_Find;
+
+                  Error_Msg ("unknown project file: {", Token_Ptr);
+
+               else
+                  --  Parse the imported project
+
+                  Parse_Single_Project
+                    (Project   => Withed_Project,
+                     Path_Name => Imported_Path_Name,
+                     Modified  => False);
+
+                  if Withed_Project /= Empty_Node then
+
+                     --  If parsing was successful, record project name
+                     --  and path name in with clause
+
+                     Set_Project_Node_Of (Current_With_Clause, Withed_Project);
+                     Set_Name_Of (Current_With_Clause,
+                                  Name_Of (Withed_Project));
+                     Name_Len := Imported_Path_Name'Length;
+                     Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
+                     Set_Path_Name_Of (Current_With_Clause, Name_Find);
+                  end if;
+               end if;
+            end;
+
+            Scan;
+            if Token = Tok_Semicolon then
+
+               --  End of (possibly multiple) with clause;
+               --  Scan past the semicolon.
+
+               Scan;
+               exit Comma_Loop;
+
+            elsif Token /= Tok_Comma then
+               Error_Msg ("expected comma or semi colon", Token_Ptr);
+               exit Comma_Loop;
+            end if;
+         end loop Comma_Loop;
+      end loop With_Loop;
+
+   end Parse_Context_Clause;
+
+   --------------------------
+   -- Parse_Single_Project --
+   --------------------------
+
+   procedure Parse_Single_Project
+     (Project         : out Project_Node_Id;
+      Path_Name       : String;
+      Modified        : Boolean)
+   is
+      Canonical_Path_Name : Name_Id;
+      Project_Directory   : Name_Id;
+      Project_Scan_State  : Saved_Project_Scan_State;
+      Source_Index        : Source_File_Index;
+
+      Modified_Project    : Project_Node_Id := Empty_Node;
+
+      A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
+        Tree_Private_Part.Projects_Htable.Get_First;
+
+      Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
+
+      use Tree_Private_Part;
+
+   begin
+      Name_Len := Path_Name'Length;
+      Name_Buffer (1 .. Name_Len) := Path_Name;
+      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+      Canonical_Path_Name := Name_Find;
+
+      --  Check for a circular dependency
+
+      for Index in 1 .. Project_Stack.Last loop
+         if Canonical_Path_Name = Project_Stack.Table (Index) then
+            Error_Msg ("circular dependency detected", Token_Ptr);
+            Error_Msg_Name_1 := Canonical_Path_Name;
+            Error_Msg ("\  { is imported by", Token_Ptr);
+
+            for Current in reverse 1 .. Project_Stack.Last loop
+               Error_Msg_Name_1 := Project_Stack.Table (Current);
+
+               if Error_Msg_Name_1 /= Canonical_Path_Name then
+                  Error_Msg
+                    ("\  { which itself is imported by", Token_Ptr);
+
+               else
+                  Error_Msg ("\  {", Token_Ptr);
+                  exit;
+               end if;
+            end loop;
+
+            Project := Empty_Node;
+            return;
+         end if;
+      end loop;
+
+      Project_Stack.Increment_Last;
+      Project_Stack.Table (Project_Stack.Last) := Canonical_Path_Name;
+
+      --  Check if the project file has already been parsed.
+
+      while
+        A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
+      loop
+         if
+           Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
+         then
+            if Modified then
+
+               if A_Project_Name_And_Node.Modified then
+                  Error_Msg
+                    ("cannot modify several times the same project file",
+                     Token_Ptr);
+
+               else
+                  Error_Msg
+                    ("cannot modify an imported project file",
+                     Token_Ptr);
+               end if;
+
+            elsif A_Project_Name_And_Node.Modified then
+               Error_Msg
+                 ("cannot imported a modified project file",
+                  Token_Ptr);
+            end if;
+
+            Project := A_Project_Name_And_Node.Node;
+            Project_Stack.Decrement_Last;
+            return;
+         end if;
+
+         A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
+      end loop;
+
+      --  We never encountered this project file
+      --  Save the scan state, load the project file and start to scan it.
+
+      Save_Project_Scan_State (Project_Scan_State);
+      Source_Index := Load_Project_File (Path_Name);
+
+      --  if we cannot find it, we stop
+
+      if Source_Index = No_Source_File then
+         Project := Empty_Node;
+         Project_Stack.Decrement_Last;
+         return;
+      end if;
+
+      Initialize_Scanner (Types.No_Unit, Source_Index);
+
+      if Name_From_Path = No_Name then
+
+         --  The project file name is not correct (no or bad extension,
+         --  or not following Ada identifier's syntax).
+
+         Error_Msg_Name_1 := Canonical_Path_Name;
+         Error_Msg ("?{ is not a valid path name for a project file",
+                    Token_Ptr);
+      end if;
+
+      if Current_Verbosity >= Medium then
+         Write_Str  ("Parsing """);
+         Write_Str  (Path_Name);
+         Write_Char ('"');
+         Write_Eol;
+      end if;
+
+      Project_Directory := Immediate_Directory_Of (Canonical_Path_Name);
+      Project := Default_Project_Node (Of_Kind => N_Project);
+      Set_Directory_Of (Project, Project_Directory);
+      Set_Name_Of (Project, Simple_File_Name_Of (Canonical_Path_Name));
+      Set_Path_Name_Of (Project, Canonical_Path_Name);
+      Set_Location_Of (Project, Token_Ptr);
+
+      --  Is there any imported project?
+
+      declare
+         First_With_Clause : Project_Node_Id := Empty_Node;
+
+      begin
+         Parse_Context_Clause (Context_Clause    => First_With_Clause,
+                               Project_Directory => Project_Directory);
+         Set_First_With_Clause_Of (Project, First_With_Clause);
+      end;
+
+      Expect (Tok_Project, "project");
+
+      --  Scan past "project"
+
+      if Token = Tok_Project then
+         Set_Location_Of (Project, Token_Ptr);
+         Scan;
+      end if;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Project, Token_Name);
+
+         Get_Name_String (Token_Name);
+         Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+         declare
+            Expected_Name : constant Name_Id := Name_Find;
+
+         begin
+            if Name_From_Path /= No_Name
+              and then Expected_Name /= Name_From_Path
+            then
+               --  The project name is not the one that was expected from
+               --  the file name. Report a warning.
+
+               Error_Msg_Name_1 := Expected_Name;
+               Error_Msg ("?file name does not match unit name, " &
+                          "should be `{" & Project_File_Extension & "`",
+                          Token_Ptr);
+            end if;
+         end;
+
+         declare
+            Project_Name : Name_Id :=
+                             Tree_Private_Part.Projects_Htable.Get_First.Name;
+
+         begin
+            --  Check if we already have a project with this name
+
+            while Project_Name /= No_Name
+              and then Project_Name /= Token_Name
+            loop
+               Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
+            end loop;
+
+            if Project_Name /= No_Name then
+               Error_Msg ("duplicate project name", Token_Ptr);
+
+            else
+               Tree_Private_Part.Projects_Htable.Set
+                 (K => Token_Name,
+                  E => (Name     => Token_Name,
+                        Node     => Project,
+                        Modified => Modified));
+            end if;
+         end;
+
+         --  Scan past the project name
+
+         Scan;
+
+      end if;
+
+      if Token = Tok_Modifying then
+
+         --  We are modifying another project
+
+         --  Scan past "modifying"
+
+         Scan;
+
+         Expect (Tok_String_Literal, "literal string");
+
+         if Token = Tok_String_Literal then
+            Set_Modified_Project_Path_Of (Project, Strval (Token_Node));
+            String_To_Name_Buffer (Modified_Project_Path_Of (Project));
+
+            declare
+               Original_Path_Name : constant String :=
+                                      Name_Buffer (1 .. Name_Len);
+
+               Modified_Project_Path_Name : constant String :=
+                                              Project_Path_Name_Of
+                                                (Original_Path_Name,
+                                                   Get_Name_String
+                                                     (Project_Directory));
+
+            begin
+               if Modified_Project_Path_Name = "" then
+
+                  --  We could not find the project file to modify
+
+                  Name_Len := Original_Path_Name'Length;
+                  Name_Buffer (1 .. Name_Len) := Original_Path_Name;
+                  Error_Msg_Name_1 := Name_Find;
+
+                  Error_Msg ("unknown project file: {", Token_Ptr);
+
+               else
+                  Parse_Single_Project
+                    (Project   => Modified_Project,
+                     Path_Name => Modified_Project_Path_Name,
+                     Modified  => True);
+               end if;
+            end;
+
+            --  Scan past the modified project path
+
+            Scan;
+         end if;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      declare
+         Project_Declaration : Project_Node_Id := Empty_Node;
+
+      begin
+         --  No need to Scan past "is", Prj.Dect.Parse will do it.
+
+         Prj.Dect.Parse
+           (Declarations    => Project_Declaration,
+            Current_Project => Project,
+            Modifying       => Modified_Project);
+         Set_Project_Declaration_Of (Project, Project_Declaration);
+      end;
+
+      Expect (Tok_End, "end");
+
+      --  Scan past "end"
+
+      if Token = Tok_End then
+         Scan;
+      end if;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+
+         --  We check if this is the project name
+
+         if To_Lower (Get_Name_String (Token_Name)) /=
+            Get_Name_String (Name_Of (Project))
+         then
+            Error_Msg ("Expected """ &
+                       Get_Name_String (Name_Of (Project)) & """",
+                       Token_Ptr);
+         end if;
+      end if;
+
+      if Token /= Tok_Semicolon then
+         Scan;
+      end if;
+
+      Expect (Tok_Semicolon, ";");
+
+      --  Restore the scan state, in case we are not the main project
+
+      Restore_Project_Scan_State (Project_Scan_State);
+
+      Project_Stack.Decrement_Last;
+   end Parse_Single_Project;
+
+   ------------------
+   -- Path_Name_Of --
+   ------------------
+
+   function Path_Name_Of
+     (File_Name : String;
+      Directory : String)
+      return      String
+   is
+      Result : String_Access;
+
+   begin
+      Result := Locate_Regular_File (File_Name => File_Name,
+                                     Path      => Directory);
+
+      if Result = null then
+         return "";
+
+      else
+         Canonical_Case_File_Name (Result.all);
+         return Result.all;
+      end if;
+   end Path_Name_Of;
+
+   -----------------------
+   -- Project_Name_From --
+   -----------------------
+
+   function Project_Name_From (Path_Name : String) return Name_Id is
+      Canonical : String (1 .. Path_Name'Length) := Path_Name;
+      First : Natural  := Canonical'Last;
+      Last  : Positive := First;
+
+   begin
+      if First = 0 then
+         return No_Name;
+      end if;
+
+      Canonical_Case_File_Name (Canonical);
+
+      while First > 0
+        and then
+        Canonical (First) /= '.'
+      loop
+         First := First - 1;
+      end loop;
+
+      if Canonical (First) = '.' then
+         if Canonical (First .. Last) = Project_File_Extension
+           and then First /= 1
+         then
+            First := First - 1;
+            Last := First;
+
+            while First > 0
+              and then Canonical (First) /= '/'
+              and then Canonical (First) /= Dir_Sep
+            loop
+               First := First - 1;
+            end loop;
+
+         else
+            return No_Name;
+         end if;
+
+      else
+         return No_Name;
+      end if;
+
+      if Canonical (First) = '/'
+        or else Canonical (First) = Dir_Sep
+      then
+         First := First + 1;
+      end if;
+
+      Name_Len := Last - First + 1;
+      Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
+
+      if not Is_Letter (Name_Buffer (1)) then
+         return No_Name;
+
+      else
+         for Index in 2 .. Name_Len - 1 loop
+            if Name_Buffer (Index) = '_' then
+               if Name_Buffer (Index + 1) = '_' then
+                  return No_Name;
+               end if;
+
+            elsif not Is_Alphanumeric (Name_Buffer (Index)) then
+               return No_Name;
+            end if;
+
+         end loop;
+
+         if not Is_Alphanumeric (Name_Buffer (Name_Len)) then
+            return No_Name;
+
+         else
+            return Name_Find;
+         end if;
+
+      end if;
+   end Project_Name_From;
+
+   --------------------------
+   -- Project_Path_Name_Of --
+   --------------------------
+
+   function Project_Path_Name_Of
+     (Project_File_Name : String;
+      Directory         : String)
+      return              String
+   is
+      Result : String_Access;
+
+   begin
+      --  First we try <file_name>.<extension>
+
+      if Current_Verbosity = High then
+         Write_Str  ("Project_Path_Name_Of (""");
+         Write_Str  (Project_File_Name);
+         Write_Str  (""", """);
+         Write_Str  (Directory);
+         Write_Line (""");");
+         Write_Str  ("   Trying ");
+         Write_Str (Project_File_Name);
+         Write_Line (Project_File_Extension);
+      end if;
+
+      Result :=
+        Locate_Regular_File
+          (File_Name => Project_File_Name & Project_File_Extension,
+           Path      => Project_Path.all);
+
+      --  Then we try <file_name>
+
+      if Result = null then
+         if Current_Verbosity = High then
+            Write_Str  ("   Trying ");
+            Write_Line  (Project_File_Name);
+         end if;
+
+         Result :=
+           Locate_Regular_File
+           (File_Name => Project_File_Name,
+            Path      => Project_Path.all);
+
+         --  The we try <directory>/<file_name>.<extension>
+
+         if Result = null then
+            if Current_Verbosity = High then
+               Write_Str  ("   Trying ");
+               Write_Str  (Directory);
+               Write_Str (Project_File_Name);
+               Write_Line (Project_File_Extension);
+            end if;
+
+            Result :=
+              Locate_Regular_File
+              (File_Name => Directory & Project_File_Name &
+                            Project_File_Extension,
+               Path      => Project_Path.all);
+
+            --  Then we try <directory>/<file_name>
+
+            if Result = null then
+               if Current_Verbosity = High then
+                  Write_Str  ("   Trying ");
+                  Write_Str  (Directory);
+                  Write_Line  (Project_File_Name);
+               end if;
+
+               Result :=
+                 Locate_Regular_File
+                 (File_Name => Directory & Project_File_Name,
+                  Path      => Project_Path.all);
+            end if;
+         end if;
+      end if;
+
+      --  If we cannot find the project file, we return an empty string
+
+      if Result = null then
+         return "";
+
+      else
+         declare
+            Final_Result : String
+              := GNAT.OS_Lib.Normalize_Pathname (Result.all);
+         begin
+            Free (Result);
+            Canonical_Case_File_Name (Final_Result);
+            return Final_Result;
+         end;
+
+      end if;
+
+   end Project_Path_Name_Of;
+
+   -------------------------
+   -- Simple_File_Name_Of --
+   -------------------------
+
+   function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id is
+   begin
+      Get_Name_String (Path_Name);
+
+      for Index in reverse 1 .. Name_Len loop
+         if Name_Buffer (Index) = '/'
+           or else Name_Buffer (Index) = Dir_Sep
+         then
+            exit when Index = Name_Len;
+            Name_Buffer (1 .. Name_Len - Index) :=
+              Name_Buffer (Index + 1 .. Name_Len);
+            Name_Len := Name_Len - Index;
+            return Name_Find;
+         end if;
+      end loop;
+
+      return No_Name;
+
+   end Simple_File_Name_Of;
+
+begin
+   Canonical_Case_File_Name (Project_File_Extension);
+
+   if Prj_Path.all = "" then
+      Project_Path := new String'(".");
+
+   else
+      Project_Path := new String'("." & Path_Separator & Prj_Path.all);
+   end if;
+
+end Prj.Part;

gcc/ada/prj-part.ads

@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files into a tree.
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Part is
+
+   procedure Parse
+     (Project                : out Project_Node_Id;
+      Project_File_Name      : String;
+      Always_Errout_Finalize : Boolean);
+   --  Parse a project file and all its imported project files
+   --  and create a tree.
+   --  Return the node for the project (or Empty_Node if parsing failed).
+   --  If Always_Errout_Finalize is True, Errout.Finalize is called
+   --  in all cases; otherwise, Errout.Finalize is only called if there are
+   --  errors (but not if there are only warnings).
+
+end Prj.Part;

gcc/ada/prj-proc.ads

@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P R O C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package is used to convert a project file tree (see prj-tree.ads) to
+--  project file data structures (see prj.ads), taking into account
+--  the environment (external references).
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Proc is
+
+   procedure Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Report_Error      : Put_Line_Access);
+   --  Process a project file tree into project file data structures.
+   --  If Report_Error is null, use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Proc;

gcc/ada/prj-strt.adb

@@ -0,0 +1,943 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . S T R T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Errout;    use Errout;
+with Prj.Attr;  use Prj.Attr;
+with Prj.Tree;  use Prj.Tree;
+with Scans;     use Scans;
+with Sinfo;     use Sinfo;
+with Stringt;   use Stringt;
+with Table;
+with Types;     use Types;
+
+package body Prj.Strt is
+
+   Initial_Size : constant := 8;
+
+   type Name_Location is record
+      Name     : Name_Id := No_Name;
+      Location : Source_Ptr := No_Location;
+   end record;
+   --  Store the identifier and the location of a simple name
+
+   type Name_Range is range 0 .. 3;
+   subtype Name_Index is Name_Range range 1 .. Name_Range'Last;
+   --  A Name may contain up to 3 simple names
+
+   type Names is array (Name_Index) of Name_Location;
+   --  Used to store 1 to 3 simple_names. 2 simple names are for
+   --  <project>.<package>, <project>.<variable> or <package>.<variable>.
+   --  3 simple names are for <project>.<package>.<variable>.
+
+   type Choice_String is record
+      The_String : String_Id;
+      Already_Used : Boolean := False;
+   end record;
+   --  The string of a case label, and an indication that it has already
+   --  been used (to avoid duplicate case labels).
+
+   Choices_Initial   : constant := 10;
+   Choices_Increment : constant := 10;
+
+   Choice_Node_Low_Bound  : constant := 0;
+   Choice_Node_High_Bound : constant := 099_999_999; --  In practice, infinite
+
+   type Choice_Node_Id is
+     range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
+
+   First_Choice_Node_Id : constant Choice_Node_Id :=
+     Choice_Node_Low_Bound;
+
+   Empty_Choice : constant Choice_Node_Id :=
+     Choice_Node_Low_Bound;
+
+   First_Choice_Id : constant Choice_Node_Id := First_Choice_Node_Id + 1;
+
+   package Choices is
+      new Table.Table (Table_Component_Type => Choice_String,
+                       Table_Index_Type     => Choice_Node_Id,
+                       Table_Low_Bound      => First_Choice_Node_Id,
+                       Table_Initial        => Choices_Initial,
+                       Table_Increment      => Choices_Increment,
+                       Table_Name           => "Prj.Strt.Choices");
+   --  Used to store the case labels and check that there is no duplicate.
+
+   package Choice_Lasts is
+      new Table.Table (Table_Component_Type => Choice_Node_Id,
+                       Table_Index_Type     => Nat,
+                       Table_Low_Bound      => 1,
+                       Table_Initial        => 3,
+                       Table_Increment      => 3,
+                       Table_Name           => "Prj.Strt.Choice_Lasts");
+   --  Used to store the indices of the choices in table Choices,
+   --  to distinguish nested case constructions.
+
+   Choice_First : Choice_Node_Id := 0;
+   --  Index in table Choices of the first case label of the current
+   --  case construction.
+   --  0 means no current case construction.
+
+   procedure Add (This_String : String_Id);
+   --  Add a string to the case label list, indicating that it has not
+   --  yet been used.
+
+   procedure External_Reference (External_Value : out Project_Node_Id);
+   --  Parse an external reference. Current token is "external".
+
+   procedure Attribute_Reference
+     (Reference       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse an attribute reference. Current token is an apostrophe.
+
+   procedure Terms
+     (Term            : out Project_Node_Id;
+      Expr_Kind       : in out Variable_Kind;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Recursive procedure to parse one term or several terms concatenated
+   --  using "&".
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add (This_String : String_Id) is
+   begin
+      Choices.Increment_Last;
+      Choices.Table (Choices.Last) :=
+        (The_String   => This_String,
+         Already_Used => False);
+   end Add;
+
+   -------------------------
+   -- Attribute_Reference --
+   -------------------------
+
+   procedure Attribute_Reference
+     (Reference       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Attribute : Attribute_Node_Id := First_Attribute;
+
+   begin
+      Reference :=  Default_Project_Node (Of_Kind => N_Attribute_Reference);
+      Set_Location_Of (Reference, To => Token_Ptr);
+      Scan; -- past apostrophe
+      Expect (Tok_Identifier, "Identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Reference, To => Token_Name);
+
+         while Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Name /= Token_Name
+         loop
+            Current_Attribute := Attributes.Table (Current_Attribute).Next;
+         end loop;
+
+         if Current_Attribute = Empty_Attribute then
+            Error_Msg ("unknown attribute", Token_Ptr);
+            Reference := Empty_Node;
+
+         elsif
+           Attributes.Table (Current_Attribute).Kind_2 = Associative_Array
+         then
+            Error_Msg
+              ("associative array attribute cannot be referenced",
+               Token_Ptr);
+            Reference := Empty_Node;
+
+         else
+            Set_Project_Node_Of (Reference, To => Current_Project);
+            Set_Package_Node_Of (Reference, To => Current_Package);
+            Set_Expression_Kind_Of
+              (Reference, To => Attributes.Table (Current_Attribute).Kind_1);
+            Scan;
+         end if;
+      end if;
+   end Attribute_Reference;
+
+   ---------------------------
+   -- End_Case_Construction --
+   ---------------------------
+
+   procedure End_Case_Construction is
+   begin
+      if Choice_Lasts.Last = 1 then
+         Choice_Lasts.Set_Last (0);
+         Choices.Set_Last (First_Choice_Node_Id);
+         Choice_First := 0;
+
+      elsif Choice_Lasts.Last = 2 then
+         Choice_Lasts.Set_Last (1);
+         Choices.Set_Last (Choice_Lasts.Table (1));
+         Choice_First := 1;
+
+      else
+         Choice_Lasts.Decrement_Last;
+         Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
+         Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
+      end if;
+   end End_Case_Construction;
+
+   ------------------------
+   -- External_Reference --
+   ------------------------
+
+   procedure External_Reference (External_Value : out Project_Node_Id) is
+      Field_Id : Project_Node_Id := Empty_Node;
+
+   begin
+      External_Value :=
+        Default_Project_Node (Of_Kind       => N_External_Value,
+                              And_Expr_Kind => Single);
+      Set_Location_Of (External_Value, To => Token_Ptr);
+
+      --  The current token is External
+
+      --  Get the left parenthesis
+
+      Scan;
+      Expect (Tok_Left_Paren, "(");
+
+      --  Scan past the left parenthesis
+
+      if Token = Tok_Left_Paren then
+         Scan;
+      end if;
+
+      --  Get the name of the external reference
+
+      Expect (Tok_String_Literal, "literal string");
+
+      if Token = Tok_String_Literal then
+         Field_Id :=
+           Default_Project_Node (Of_Kind       => N_Literal_String,
+                                 And_Expr_Kind => Single);
+         Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+         Set_External_Reference_Of (External_Value, To => Field_Id);
+
+         --  Scan past the first argument
+
+         Scan;
+
+         case Token is
+
+            when Tok_Right_Paren =>
+
+               --  Scan past the right parenthesis
+               Scan;
+
+            when Tok_Comma =>
+
+               --  Scan past the comma
+
+               Scan;
+
+               Expect (Tok_String_Literal, "literal string");
+
+               --  Get the default
+
+               if Token = Tok_String_Literal then
+                  Field_Id :=
+                    Default_Project_Node (Of_Kind       => N_Literal_String,
+                                          And_Expr_Kind => Single);
+                  Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+                  Set_External_Default_Of (External_Value, To => Field_Id);
+                  Scan;
+                  Expect (Tok_Right_Paren, ")");
+               end if;
+
+               --  Scan past the right parenthesis
+               if Token = Tok_Right_Paren then
+                  Scan;
+               end if;
+
+            when others =>
+               Error_Msg ("',' or ')' expected", Token_Ptr);
+         end case;
+      end if;
+   end External_Reference;
+
+   -----------------------
+   -- Parse_Choice_List --
+   -----------------------
+
+   procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is
+      Current_Choice : Project_Node_Id := Empty_Node;
+      Next_Choice    : Project_Node_Id := Empty_Node;
+      Choice_String  : String_Id       := No_String;
+      Found          : Boolean         := False;
+
+   begin
+      First_Choice :=
+        Default_Project_Node (Of_Kind       => N_Literal_String,
+                              And_Expr_Kind => Single);
+      Current_Choice := First_Choice;
+
+      loop
+         Expect (Tok_String_Literal, "literal string");
+         exit when Token /= Tok_String_Literal;
+         Set_Location_Of (Current_Choice, To => Token_Ptr);
+         Choice_String := Strval (Token_Node);
+         Set_String_Value_Of (Current_Choice, To => Choice_String);
+
+         Found := False;
+         for Choice in Choice_First .. Choices.Last loop
+            if String_Equal (Choices.Table (Choice).The_String,
+                             Choice_String)
+            then
+               Found := True;
+
+               if Choices.Table (Choice).Already_Used then
+                  Error_Msg ("duplicate case label", Token_Ptr);
+               else
+                  Choices.Table (Choice).Already_Used := True;
+               end if;
+
+               exit;
+            end if;
+         end loop;
+
+         if not Found then
+            Error_Msg ("illegal case label", Token_Ptr);
+         end if;
+
+         Scan;
+
+         if Token = Tok_Vertical_Bar then
+            Next_Choice :=
+              Default_Project_Node (Of_Kind       => N_Literal_String,
+                                    And_Expr_Kind => Single);
+            Set_Next_Literal_String (Current_Choice, To => Next_Choice);
+            Current_Choice := Next_Choice;
+            Scan;
+         else
+            exit;
+         end if;
+      end loop;
+   end Parse_Choice_List;
+
+   ----------------------
+   -- Parse_Expression --
+   ----------------------
+
+   procedure Parse_Expression
+     (Expression      : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      First_Term      : Project_Node_Id := Empty_Node;
+      Expression_Kind : Variable_Kind := Undefined;
+
+   begin
+      Expression := Default_Project_Node (Of_Kind => N_Expression);
+      Set_Location_Of (Expression, To => Token_Ptr);
+      Terms (Term            => First_Term,
+             Expr_Kind       => Expression_Kind,
+             Current_Project => Current_Project,
+             Current_Package => Current_Package);
+      Set_First_Term (Expression, To => First_Term);
+      Set_Expression_Kind_Of (Expression, To => Expression_Kind);
+   end Parse_Expression;
+
+   ----------------------------
+   -- Parse_String_Type_List --
+   ----------------------------
+
+   procedure Parse_String_Type_List (First_String : out Project_Node_Id) is
+      Last_String  : Project_Node_Id := Empty_Node;
+      Next_String  : Project_Node_Id := Empty_Node;
+      String_Value : String_Id := No_String;
+
+   begin
+      First_String :=
+        Default_Project_Node (Of_Kind       => N_Literal_String,
+                              And_Expr_Kind => Single);
+      Last_String := First_String;
+
+      loop
+         Expect (Tok_String_Literal, "literal string");
+         exit when Token /= Tok_String_Literal;
+         String_Value := Strval (Token_Node);
+         Set_String_Value_Of (Last_String, To => String_Value);
+         Set_Location_Of (Last_String, To => Token_Ptr);
+
+         declare
+            Current : Project_Node_Id := First_String;
+
+         begin
+            while Current /= Last_String loop
+               if String_Equal (String_Value_Of (Current), String_Value) then
+                  Error_Msg ("duplicate value in type", Token_Ptr);
+                  exit;
+               end if;
+
+               Current := Next_Literal_String (Current);
+            end loop;
+         end;
+
+         Scan;
+
+         if Token /= Tok_Comma then
+            exit;
+
+         else
+            Next_String :=
+              Default_Project_Node (Of_Kind       => N_Literal_String,
+                                    And_Expr_Kind => Single);
+            Set_Next_Literal_String (Last_String, To => Next_String);
+            Last_String := Next_String;
+            Scan;
+         end if;
+      end loop;
+   end Parse_String_Type_List;
+
+   ------------------------------
+   -- Parse_Variable_Reference --
+   ------------------------------
+
+   procedure Parse_Variable_Reference
+     (Variable        : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      The_Names        : Names;
+      Last_Name        : Name_Range := 0;
+      Current_Variable : Project_Node_Id := Empty_Node;
+
+      The_Package : Project_Node_Id := Current_Package;
+      The_Project : Project_Node_Id := Current_Project;
+
+      Specified_Project : Project_Node_Id   := Empty_Node;
+      Specified_Package : Project_Node_Id   := Empty_Node;
+      Look_For_Variable : Boolean           := True;
+      First_Attribute   : Attribute_Node_Id := Empty_Attribute;
+      Variable_Name     : Name_Id;
+
+   begin
+      for Index in The_Names'Range loop
+         Expect (Tok_Identifier, "identifier");
+
+         if Token /= Tok_Identifier then
+            Look_For_Variable := False;
+            exit;
+         end if;
+
+         Last_Name := Last_Name + 1;
+         The_Names (Last_Name) :=
+           (Name     => Token_Name,
+            Location => Token_Ptr);
+         Scan;
+         exit when Token /= Tok_Dot;
+         Scan;
+      end loop;
+
+      if Look_For_Variable then
+         if Token = Tok_Apostrophe then
+
+            --  Attribute reference
+
+            case Last_Name is
+               when 0 =>
+
+                  --  Cannot happen
+
+                  null;
+
+               when 1 =>
+                  for Index in Package_First .. Package_Attributes.Last loop
+                     if Package_Attributes.Table (Index).Name =
+                                                      The_Names (1).Name
+                     then
+                        First_Attribute :=
+                          Package_Attributes.Table (Index).First_Attribute;
+                        exit;
+                     end if;
+                  end loop;
+
+                  if First_Attribute /= Empty_Attribute then
+                     The_Package := First_Package_Of (Current_Project);
+                     while The_Package /= Empty_Node
+                       and then Name_Of (The_Package) /= The_Names (1).Name
+                     loop
+                        The_Package := Next_Package_In_Project (The_Package);
+                     end loop;
+
+                     if The_Package = Empty_Node then
+                        Error_Msg ("package not yet defined",
+                                   The_Names (1).Location);
+                     end if;
+
+                  else
+                     First_Attribute := Attribute_First;
+                     The_Package     := Empty_Node;
+
+                     declare
+                        The_Project_Name_And_Node :
+                          constant Tree_Private_Part.Project_Name_And_Node :=
+                            Tree_Private_Part.Projects_Htable.Get
+                                                          (The_Names (1).Name);
+
+                        use Tree_Private_Part;
+
+                     begin
+                        if The_Project_Name_And_Node =
+                                   Tree_Private_Part.No_Project_Name_And_Node
+                        then
+                           Error_Msg ("unknown project",
+                                      The_Names (1).Location);
+                        else
+                           The_Project := The_Project_Name_And_Node.Node;
+                        end if;
+                     end;
+                  end if;
+
+               when 2 =>
+                  declare
+                     With_Clause : Project_Node_Id :=
+                                     First_With_Clause_Of (Current_Project);
+
+                  begin
+                     while With_Clause /= Empty_Node loop
+                        The_Project := Project_Node_Of (With_Clause);
+                        exit when Name_Of (The_Project) = The_Names (1).Name;
+                        With_Clause := Next_With_Clause_Of (With_Clause);
+                     end loop;
+
+                     if With_Clause = Empty_Node then
+                        Error_Msg ("unknown project",
+                                   The_Names (1).Location);
+                        The_Project := Empty_Node;
+                        The_Package := Empty_Node;
+                        First_Attribute := Attribute_First;
+
+                     else
+                        The_Package := First_Package_Of (The_Project);
+                        while The_Package /= Empty_Node
+                          and then Name_Of (The_Package) /= The_Names (2).Name
+                        loop
+                           The_Package :=
+                             Next_Package_In_Project (The_Package);
+                        end loop;
+
+                        if The_Package = Empty_Node then
+                           Error_Msg ("package not declared in project",
+                                      The_Names (2).Location);
+                           First_Attribute := Attribute_First;
+
+                        else
+                           First_Attribute :=
+                             Package_Attributes.Table
+                             (Package_Id_Of (The_Package)).First_Attribute;
+                        end if;
+                     end if;
+                  end;
+
+               when 3 =>
+                  Error_Msg
+                    ("too many single names for an attribute reference",
+                     The_Names (1).Location);
+                  Scan;
+                  Variable := Empty_Node;
+                  return;
+            end case;
+
+            Attribute_Reference
+              (Variable,
+               Current_Project => The_Project,
+               Current_Package => The_Package,
+               First_Attribute => First_Attribute);
+            return;
+         end if;
+      end if;
+
+      Variable :=
+        Default_Project_Node (Of_Kind => N_Variable_Reference);
+
+      if Look_For_Variable then
+         case Last_Name is
+            when 0 =>
+
+               --  Cannot happen
+
+               null;
+
+            when 1 =>
+               Set_Name_Of (Variable, To => The_Names (1).Name);
+
+            --  Header comment needed ???
+
+            when 2 =>
+               Set_Name_Of (Variable, To => The_Names (2).Name);
+               The_Package := First_Package_Of (Current_Project);
+
+               while The_Package /= Empty_Node
+                 and then Name_Of (The_Package) /= The_Names (1).Name
+               loop
+                  The_Package := Next_Package_In_Project (The_Package);
+               end loop;
+
+               if The_Package /= Empty_Node then
+                  Specified_Package := The_Package;
+                  The_Project := Empty_Node;
+
+               else
+                  declare
+                     With_Clause : Project_Node_Id :=
+                                     First_With_Clause_Of (Current_Project);
+
+                  begin
+                     while With_Clause /= Empty_Node loop
+                        The_Project := Project_Node_Of (With_Clause);
+                        exit when Name_Of (The_Project) = The_Names (1).Name;
+                        With_Clause := Next_With_Clause_Of (With_Clause);
+                     end loop;
+
+                     if With_Clause = Empty_Node then
+                        The_Project :=
+                          Modified_Project_Of
+                                 (Project_Declaration_Of (Current_Project));
+
+                        if The_Project /= Empty_Node
+                          and then
+                            Name_Of (The_Project) /= The_Names (1).Name
+                        then
+                           The_Project := Empty_Node;
+                        end if;
+                     end if;
+
+                     if The_Project = Empty_Node then
+                        Error_Msg ("unknown package or project",
+                                   The_Names (1).Location);
+                        Look_For_Variable := False;
+                     else
+                        Specified_Project := The_Project;
+                     end if;
+                  end;
+               end if;
+
+            --  Header comment needed ???
+
+            when 3 =>
+               Set_Name_Of (Variable, To => The_Names (3).Name);
+
+               declare
+                  With_Clause : Project_Node_Id :=
+                                  First_With_Clause_Of (Current_Project);
+
+               begin
+                  while With_Clause /= Empty_Node loop
+                     The_Project := Project_Node_Of (With_Clause);
+                     exit when Name_Of (The_Project) = The_Names (1).Name;
+                     With_Clause := Next_With_Clause_Of (With_Clause);
+                  end loop;
+
+                  if With_Clause = Empty_Node then
+                     The_Project :=
+                       Modified_Project_Of
+                          (Project_Declaration_Of (Current_Project));
+
+                     if The_Project /= Empty_Node
+                       and then Name_Of (The_Project) /= The_Names (1).Name
+                     then
+                        The_Project := Empty_Node;
+                     end if;
+                  end if;
+
+                  if The_Project = Empty_Node then
+                     Error_Msg ("unknown package or project",
+                                The_Names (1).Location);
+                     Look_For_Variable := False;
+
+                  else
+                     Specified_Project := The_Project;
+                     The_Package := First_Package_Of (The_Project);
+
+                     while The_Package /= Empty_Node
+                       and then Name_Of (The_Package) /= The_Names (2).Name
+                     loop
+                        The_Package := Next_Package_In_Project (The_Package);
+                     end loop;
+
+                     if The_Package = Empty_Node then
+                        Error_Msg ("unknown package",
+                                   The_Names (2).Location);
+                        Look_For_Variable := False;
+
+                     else
+                        Specified_Package := The_Package;
+                        The_Project := Empty_Node;
+                     end if;
+                  end if;
+               end;
+
+         end case;
+      end if;
+
+      if Look_For_Variable then
+         Variable_Name := Name_Of (Variable);
+         Set_Project_Node_Of (Variable, To => Specified_Project);
+         Set_Package_Node_Of (Variable, To => Specified_Package);
+
+         if The_Package /= Empty_Node then
+            Current_Variable := First_Variable_Of (The_Package);
+
+            while Current_Variable /= Empty_Node
+              and then
+              Name_Of (Current_Variable) /= Variable_Name
+            loop
+               Current_Variable := Next_Variable (Current_Variable);
+            end loop;
+         end if;
+
+         if Current_Variable = Empty_Node
+           and then The_Project /= Empty_Node
+         then
+            Current_Variable := First_Variable_Of (The_Project);
+            while Current_Variable /= Empty_Node
+              and then Name_Of (Current_Variable) /= Variable_Name
+            loop
+               Current_Variable := Next_Variable (Current_Variable);
+            end loop;
+         end if;
+
+         if Current_Variable = Empty_Node then
+            Error_Msg ("unknown variable", The_Names (Last_Name).Location);
+         end if;
+      end if;
+
+      if Current_Variable /= Empty_Node then
+         Set_Expression_Kind_Of
+           (Variable, To => Expression_Kind_Of (Current_Variable));
+
+         if Kind_Of (Current_Variable) = N_Typed_Variable_Declaration then
+            Set_String_Type_Of
+              (Variable, To => String_Type_Of (Current_Variable));
+         end if;
+      end if;
+   end Parse_Variable_Reference;
+
+   ---------------------------------
+   -- Start_New_Case_Construction --
+   ---------------------------------
+
+   procedure Start_New_Case_Construction (String_Type  : Project_Node_Id) is
+      Current_String : Project_Node_Id;
+
+   begin
+      if Choice_First = 0 then
+         Choice_First := 1;
+         Choices.Set_Last (First_Choice_Node_Id);
+      else
+         Choice_First := Choices.Last + 1;
+      end if;
+
+      if String_Type /= Empty_Node then
+         Current_String := First_Literal_String (String_Type);
+
+         while Current_String /= Empty_Node loop
+            Add (This_String => String_Value_Of (Current_String));
+            Current_String := Next_Literal_String (Current_String);
+         end loop;
+      end if;
+
+      Choice_Lasts.Increment_Last;
+      Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
+
+   end Start_New_Case_Construction;
+
+   -----------
+   -- Terms --
+   -----------
+
+   procedure Terms (Term            : out Project_Node_Id;
+                    Expr_Kind       : in out Variable_Kind;
+                    Current_Project : Project_Node_Id;
+                    Current_Package : Project_Node_Id)
+   is
+      Next_Term          : Project_Node_Id := Empty_Node;
+      Term_Id            : Project_Node_Id := Empty_Node;
+      Current_Expression : Project_Node_Id := Empty_Node;
+      Next_Expression    : Project_Node_Id := Empty_Node;
+      Current_Location   : Source_Ptr      := No_Location;
+      Reference          : Project_Node_Id := Empty_Node;
+
+   begin
+      Term := Default_Project_Node (Of_Kind => N_Term);
+      Set_Location_Of (Term, To => Token_Ptr);
+
+      case Token is
+
+         when Tok_Left_Paren =>
+            case Expr_Kind is
+               when Undefined =>
+                  Expr_Kind := List;
+               when List =>
+                  null;
+               when Single =>
+                  Expr_Kind := List;
+                  Error_Msg
+                    ("literal string list cannot appear in a string",
+                     Token_Ptr);
+            end case;
+
+            Term_Id := Default_Project_Node
+              (Of_Kind => N_Literal_String_List,
+               And_Expr_Kind => List);
+            Set_Current_Term (Term, To => Term_Id);
+            Set_Location_Of (Term, To => Token_Ptr);
+
+            Scan;
+            if Token = Tok_Right_Paren then
+               Scan;
+
+            else
+               loop
+                  Current_Location := Token_Ptr;
+                  Parse_Expression (Expression      => Next_Expression,
+                                    Current_Project => Current_Project,
+                                    Current_Package => Current_Package);
+
+                  if Expression_Kind_Of (Next_Expression) = List then
+                     Error_Msg ("single expression expected",
+                                Current_Location);
+                  end if;
+
+                  if Current_Expression = Empty_Node then
+                     Set_First_Expression_In_List
+                       (Term_Id, To => Next_Expression);
+                  else
+                     Set_Next_Expression_In_List
+                       (Current_Expression, To => Next_Expression);
+                  end if;
+
+                  Current_Expression := Next_Expression;
+                  exit when Token /= Tok_Comma;
+                  Scan; -- past the comma
+               end loop;
+
+               Expect (Tok_Right_Paren, "(");
+
+               if Token = Tok_Right_Paren then
+                  Scan;
+               end if;
+            end if;
+
+         when Tok_String_Literal =>
+            if Expr_Kind = Undefined then
+               Expr_Kind := Single;
+            end if;
+
+            Term_Id := Default_Project_Node (Of_Kind => N_Literal_String);
+            Set_Current_Term (Term, To => Term_Id);
+            Set_String_Value_Of (Term_Id, To => Strval (Token_Node));
+
+            Scan;
+
+         when Tok_Identifier =>
+            Current_Location := Token_Ptr;
+            Parse_Variable_Reference
+              (Variable        => Reference,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+            Set_Current_Term (Term, To => Reference);
+
+            if Reference /= Empty_Node then
+               if Expr_Kind = Undefined then
+                  Expr_Kind := Expression_Kind_Of (Reference);
+
+               elsif Expr_Kind = Single
+                 and then Expression_Kind_Of (Reference) = List
+               then
+                  Expr_Kind := List;
+                  Error_Msg
+                    ("list variable cannot appear in single string expression",
+                     Current_Location);
+               end if;
+            end if;
+
+         when Tok_Project =>
+            Current_Location := Token_Ptr;
+            Scan;
+            Expect (Tok_Apostrophe, "'");
+
+            if Token = Tok_Apostrophe then
+               Attribute_Reference
+                 (Reference       => Reference,
+                  First_Attribute => Prj.Attr.Attribute_First,
+                  Current_Project => Current_Project,
+                  Current_Package => Empty_Node);
+               Set_Current_Term (Term, To => Reference);
+            end if;
+
+            if Reference /= Empty_Node then
+               if Expr_Kind = Undefined then
+                  Expr_Kind := Expression_Kind_Of (Reference);
+
+               elsif Expr_Kind = Single
+                 and then Expression_Kind_Of (Reference) = List
+               then
+                  Error_Msg
+                    ("lists cannot appear in single string expression",
+                     Current_Location);
+               end if;
+            end if;
+
+         when Tok_External =>
+            if Expr_Kind = Undefined then
+               Expr_Kind := Single;
+            end if;
+
+            External_Reference (External_Value => Reference);
+            Set_Current_Term (Term, To => Reference);
+
+         when others =>
+            Error_Msg ("cannot be part of an expression", Token_Ptr);
+            Term := Empty_Node;
+            return;
+      end case;
+
+      if Token = Tok_Ampersand then
+         Scan;
+
+         Terms (Term            => Next_Term,
+                Expr_Kind       => Expr_Kind,
+                Current_Project => Current_Project,
+                Current_Package => Current_Package);
+         Set_Next_Term (Term, To => Next_Term);
+
+      end if;
+
+   end Terms;
+
+end Prj.Strt;

gcc/ada/prj-strt.ads

@@ -0,0 +1,96 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . S T R T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package implements parsing of string expressions in project files.
+
+with Prj.Tree;  use Prj.Tree;
+
+private package Prj.Strt is
+
+   procedure Parse_String_Type_List (First_String : out Project_Node_Id);
+   --  Get the list of literal strings that are allowed for a typed string.
+   --  On entry, the current token is the first literal string following
+   --  a left parenthesis in a string type declaration such as:
+   --    type Toto is ("string_1", "string_2", "string_3");
+   --  On exit, the current token is the right parenthesis.
+   --  The parameter First_String is a node that contained the first
+   --  literal string of the string type, linked with the following
+   --  literal strings.
+   --
+   --  Report an error if
+   --    - a literal string is not found at the beginning of the list
+   --      or after a comma
+   --    - two literal strings in the list are equal
+
+   procedure Start_New_Case_Construction (String_Type : Project_Node_Id);
+   --  This procedure is called at the beginning of a case construction
+   --  The parameter String_Type is the node for the string type
+   --  of the case label variable.
+   --  The different literal strings of the string type are stored
+   --  into a table to be checked against the case labels of the
+   --  case construction.
+
+   procedure End_Case_Construction;
+   --  This procedure is called at the end of a case construction
+   --  to remove the case labels and to restore the previous state.
+   --  In particular, in the case of nested case constructions,
+   --  the case labels of the enclosing case construction are restored.
+
+   procedure Parse_Choice_List
+     (First_Choice : out Project_Node_Id);
+   --  Get the label for a choice list.
+   --  Report an error if
+   --    - a case label is not a literal string
+   --    - a case label is not in the typed string list
+   --    - the same case label is repeated in the same case construction
+
+   procedure Parse_Expression
+     (Expression      : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a simple string expression or a string list expression.
+   --  Current_Project is the node of the project file being parsed.
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Expression is the node of the expression that has
+   --  been parsed.
+
+   procedure Parse_Variable_Reference
+     (Variable        : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a variable or attribute reference.
+   --  Used internally (in expressions) and for case variables (in Prj.Dect).
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Variable is the node of the variable or attribute reference.
+   --  A variable reference is made of one to three simple names.
+   --  An attribute reference is made of one or two simple names,
+   --  followed by an apostroph, followed by the attribute simple name.
+
+end Prj.Strt;

gcc/ada/prj-tree.ads

@@ -0,0 +1,742 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . T R E E                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.9 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package defines the structure of the Project File tree.
+
+with GNAT.HTable;
+
+with Prj.Attr; use Prj.Attr;
+with Prj.Com;  use Prj.Com;
+with Types;    use Types;
+with Table;
+
+package Prj.Tree is
+
+   Project_Nodes_Initial   : constant := 1_000;
+   --  Initial number of nodes in table Tree_Private_Part.Project_Nodes
+   Project_Nodes_Increment : constant := 100;
+
+   Project_Node_Low_Bound  : constant := 0;
+   Project_Node_High_Bound : constant := 099_999_999; -- In practice, infinite
+
+   type Project_Node_Id is range
+     Project_Node_Low_Bound .. Project_Node_High_Bound;
+   --  The index of table Tree_Private_Part.Project_Nodes
+
+   Empty_Node    : constant Project_Node_Id := Project_Node_Low_Bound;
+   --  Designates no node in table Project_Nodes
+   First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound;
+
+   subtype Variable_Node_Id       is Project_Node_Id;
+   --  Used to designate a node whose expected kind is
+   --  N_Typed_Variable_Declaration, N_Variable_Declaration or
+   --  N_Variable_Reference.
+   subtype Package_Declaration_Id is Project_Node_Id;
+   --  Used to designate a node whose expected kind is
+   --  N_Project_Declaration.
+
+   type Project_Node_Kind is
+     (N_Project,
+      N_With_Clause,
+      N_Project_Declaration,
+      N_Declarative_Item,
+      N_Package_Declaration,
+      N_String_Type_Declaration,
+      N_Literal_String,
+      N_Attribute_Declaration,
+      N_Typed_Variable_Declaration,
+      N_Variable_Declaration,
+      N_Expression,
+      N_Term,
+      N_Literal_String_List,
+      N_Variable_Reference,
+      N_External_Value,
+      N_Attribute_Reference,
+      N_Case_Construction,
+      N_Case_Item);
+   --  Each node in the tree is of a Project_Node_Kind
+   --  For the signification of the fields in each node of a
+   --  Project_Node_Kind, look at package Tree_Private_Part.
+
+   procedure Initialize;
+   --  Initialize the Project File tree: empty the Project_Nodes table
+   --  and reset the Projects_Htable.
+
+   function Default_Project_Node
+     (Of_Kind       : Project_Node_Kind;
+      And_Expr_Kind : Variable_Kind := Undefined)
+     return Project_Node_Id;
+   --  Returns a Project_Node_Record with the specified Kind and
+   --  Expr_Kind; all the other components have default nil values.
+
+   ----------------------
+   -- Access Functions --
+   ----------------------
+
+   --  The following query functions are part of the abstract interface
+   --  of the Project File tree
+
+   function Name_Of (Node : Project_Node_Id) return Name_Id;
+   --  Valid for all non empty nodes. May return No_Name for nodes that have
+   --  no names.
+
+   function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind;
+   --  Valid for all non empty nodes
+
+   function Location_Of (Node : Project_Node_Id) return Source_Ptr;
+   --  Valid for all non empty nodes
+
+   function Directory_Of (Node : Project_Node_Id) return Name_Id;
+   --  Only valid for N_Project nodes.
+
+   function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind;
+   --  Only valid for N_Literal_String, N_Attribute_Declaration,
+   --  N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
+   --  N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+
+   function First_Variable_Of
+     (Node  : Project_Node_Id)
+      return Variable_Node_Id;
+   --  Only valid for N_Project or N_Package_Declaration nodes
+
+   function First_Package_Of
+     (Node  : Project_Node_Id)
+      return  Package_Declaration_Id;
+   --  Only valid for N_Project nodes
+
+   function Package_Id_Of (Node  : Project_Node_Id) return Package_Node_Id;
+   --  Only valid for N_Package_Declaration nodes
+
+   function Path_Name_Of (Node  : Project_Node_Id) return Name_Id;
+   --  Only valid for N_Project and N_With_Clause nodes.
+
+   function String_Value_Of (Node  : Project_Node_Id) return String_Id;
+   --  Only valid for N_With_Clause or N_Literal_String nodes.
+
+   function First_With_Clause_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Project_Declaration_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function First_String_Type_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Modified_Project_Path_Of
+     (Node  : Project_Node_Id)
+      return  String_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Project_Node_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Next_With_Clause_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function First_Declarative_Item_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Modified_Project_Of
+     (Node  : Project_Node_Id)
+      return Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Current_Item_Node
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Declarative_Item nodes
+
+   function Next_Declarative_Item
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Declarative_Item node
+
+   function Project_Of_Renamed_Package_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Package_Declaration nodes.
+   --  May return Empty_Node.
+
+   function Next_Package_In_Project
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Package_Declaration nodes
+
+   function First_Literal_String
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_String_Type_Declaration nodes
+
+   function Next_String_Type
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_String_Type_Declaration nodes
+
+   function Next_Literal_String
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Literal_String nodes
+
+   function Expression_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
+   --  or N_Variable_Declaration nodes
+
+   function Value_Is_Valid
+     (For_Typed_Variable : Project_Node_Id;
+      Value              : String_Id)
+      return               Boolean;
+   --  Only valid for N_Typed_Variable_Declaration. Returns True if Value is
+   --  in the list of allowed strings for For_Typed_Variable. False otherwise.
+
+   function Associative_Array_Index_Of
+     (Node  : Project_Node_Id)
+      return  String_Id;
+   --  Only valid for N_Attribute_Declaration.
+   --  Returns No_String for non associative array attributes.
+
+   function Next_Variable
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
+   --  nodes.
+
+   function First_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Expression nodes
+
+   function Next_Expression_In_List
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Expression nodes
+
+   function Current_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Term nodes
+
+   function Next_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Term nodes
+
+   function First_Expression_In_List
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Literal_String_List nodes
+
+   function Package_Node_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
+   --  May return Empty_Node.
+
+   function String_Type_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
+   --  nodes.
+
+   function External_Reference_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_External_Value nodes
+
+   function External_Default_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_External_Value nodes
+
+   function Case_Variable_Reference_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Construction nodes
+
+   function First_Case_Item_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Construction nodes
+
+   function First_Choice_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Item nodes
+
+   function Next_Case_Item
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Item nodes
+
+   --------------------
+   -- Set Procedures --
+   --------------------
+
+   --  The following procedures are part of the abstract interface of
+   --  the Project File tree.
+
+   --  Each Set_* procedure is valid only for the same Project_Node_Kind
+   --  nodes as the corresponding query function above.
+
+   procedure Set_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Kind);
+
+   procedure Set_Location_Of
+     (Node : Project_Node_Id;
+      To   : Source_Ptr);
+
+   procedure Set_Directory_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_Expression_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Kind);
+
+   procedure Set_First_Variable_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Node_Id);
+
+   procedure Set_First_Package_Of
+     (Node : Project_Node_Id;
+      To   : Package_Declaration_Id);
+
+   procedure Set_Package_Id_Of
+     (Node : Project_Node_Id;
+      To   : Package_Node_Id);
+
+   procedure Set_Path_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_String_Value_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_First_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Project_Declaration_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Modified_Project_Path_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_Project_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Declarative_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Modified_Project_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Current_Item_Node
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Declarative_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Project_Of_Renamed_Package_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Package_In_Project
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_String_Type
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Expression_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Associative_Array_Index_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_Next_Variable
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Current_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Package_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_External_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_External_Default_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Case_Variable_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Case_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Choice_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Case_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   -------------------------------
+   -- Restricted Access Section --
+   -------------------------------
+
+   package Tree_Private_Part is
+
+      --  This is conceptually in the private part.
+      --  However, for efficiency, some packages are accessing it directly.
+
+      type Project_Node_Record is record
+
+         Kind        : Project_Node_Kind;
+
+         Location    : Source_Ptr    := No_Location;
+
+         Directory   : Name_Id       := No_Name;
+         --  Only for N_Project
+
+         Expr_Kind   : Variable_Kind := Undefined;
+         --  See below for what Project_Node_Kind it is used
+
+         Variables   : Variable_Node_Id := Empty_Node;
+         --  First variable in a project or a package
+
+         Packages    : Package_Declaration_Id := Empty_Node;
+         --  First package declaration in a project
+
+         Pkg_Id      : Package_Node_Id := Empty_Package;
+         --  Only use in Package_Declaration
+
+         Name        : Name_Id         := No_Name;
+         --  See below for what Project_Node_Kind it is used
+
+         Path_Name   : Name_Id         := No_Name;
+         --  See below for what Project_Node_Kind it is used
+
+         Value       : String_Id       := No_String;
+         --  See below for what Project_Node_Kind it is used
+
+         Field1      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+         Field2      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+         Field3      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+      end record;
+
+      --  type Project_Node_Kind is
+
+      --   (N_Project,
+      --    --  Name:      project name
+      --    --  Path_Name: project path name
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first with clause
+      --    --  Field2:    project declaration
+      --    --  Field3:    first string type
+      --    --  Value:     modified project path name (if any)
+
+      --    N_With_Clause,
+      --    --  Name:      imported project name
+      --    --  Path_Name: imported project path name
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    project node
+      --    --  Field2:    next with clause
+      --    --  Field3:    not used
+      --    --  Value:     literal string withed
+
+      --    N_Project_Declaration,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first declarative item
+      --    --  Field2:    modified project
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Declarative_Item,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    current item node
+      --    --  Field2:    next declarative item
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Package_Declaration,
+      --    --  Name:      package name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    project of renamed package (if any)
+      --    --  Field2:    first declarative item
+      --    --  Field3:    next package in project
+      --    --  Value:     not used
+
+      --    N_String_Type_Declaration,
+      --    --  Name:      type name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first literal string
+      --    --  Field2:    next string type
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Literal_String,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    next literal string
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     string value
+
+      --    N_Attribute_Declaration,
+      --    --  Name:      attribute name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: attribute kind
+      --    --  Field1:    expression
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     associative array index
+      --    --             (if an associative array element)
+
+      --    N_Typed_Variable_Declaration,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    expression
+      --    --  Field2:    type of variable (N_String_Type_Declaration)
+      --    --  Field3:    next variable
+      --    --  Value:     not used
+
+      --    N_Variable_Declaration,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: variable kind
+      --    --  Field1:    expression
+      --    --  Field2:    not used
+      --    --             Field3 is used for next variable, instead of Field2,
+      --    --             so that it is the same field for
+      --    --             N_Variable_Declaration and
+      --    --             N_Typed_Variable_Declaration
+      --    --  Field3:    next variable
+      --    --  Value:     not used
+
+      --    N_Expression,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: expression kind
+      --    --  Field1:    first term
+      --    --  Field2:    next expression in list
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Term,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: term kind
+      --    --  Field1:    current term
+      --    --  Field2:    next term in the expression
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Literal_String_List,
+      --    --  Designates a list of string expressions between brackets
+      --    --  separated by commas. The string expressions are not necessarily
+      --    --  literal strings.
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: List
+      --    --  Field1:    first expression
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Variable_Reference,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: variable kind
+      --    --  Field1:    project (if specified)
+      --    --  Field2:    package (if specified)
+      --    --  Field3:    type of variable (N_String_Type_Declaration), if any
+      --    --  Value:     not used
+
+      --    N_External_Value,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    Name of the external reference (literal string)
+      --    --  Field2:    Default (literal string)
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Attribute_Reference,
+      --    --  Name:      attribute name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: attribute kind
+      --    --  Field1:    project
+      --    --  Field2:    package (if attribute of a package)
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Case_Construction,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    case variable reference
+      --    --  Field2:    first case item
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Case_Item);
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: not used
+      --    --  Field1:    first choice (literal string)
+      --    --  Field2:    first declarative item
+      --    --  Field3:    next case item
+      --    --  Value:     not used
+
+      package Project_Nodes is
+         new Table.Table (Table_Component_Type => Project_Node_Record,
+                          Table_Index_Type     => Project_Node_Id,
+                          Table_Low_Bound      => First_Node_Id,
+                          Table_Initial        => Project_Nodes_Initial,
+                          Table_Increment      => Project_Nodes_Increment,
+                          Table_Name           => "Project_Nodes");
+      --  This table contains the syntactic tree of project data
+      --  from project files.
+
+      type Project_Name_And_Node is record
+         Name     : Name_Id;
+         --  Name of the project
+         Node     : Project_Node_Id;
+         --  Node of the project in table Project_Nodes
+         Modified : Boolean;
+         --  True when the project is being modified by another project
+      end record;
+
+      No_Project_Name_And_Node : constant Project_Name_And_Node :=
+        (Name => No_Name, Node => Empty_Node, Modified => True);
+
+      package Projects_Htable is new GNAT.HTable.Simple_HTable
+        (Header_Num => Header_Num,
+         Element    => Project_Name_And_Node,
+         No_Element => No_Project_Name_And_Node,
+         Key        => Name_Id,
+         Hash       => Hash,
+         Equal      => "=");
+      --  This hash table contains a mapping of project names to project nodes.
+      --  Note that this hash table contains only the nodes whose Kind is
+      --  N_Project. It is used to find the node of a project from its
+      --  name, and to verify if a project has already been parsed, knowing
+      --  its name.
+
+   end Tree_Private_Part;
+
+end Prj.Tree;

gcc/ada/prj-util.adb

@@ -0,0 +1,415 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . U T I L                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Namet;    use Namet;
+with Osint;
+with Output;   use Output;
+with Stringt;  use Stringt;
+
+package body Prj.Util is
+
+   procedure Free is new Ada.Unchecked_Deallocation
+     (Text_File_Data, Text_File);
+
+   -----------
+   -- Close --
+   -----------
+
+   procedure Close (File : in out Text_File) is
+   begin
+      if File = null then
+         Osint.Fail ("Close attempted on an invalid Text_File");
+      end if;
+
+      Close (File.FD);
+      Free (File);
+   end Close;
+
+   -----------------
+   -- End_Of_File --
+   -----------------
+
+   function End_Of_File (File : Text_File) return Boolean is
+   begin
+      if File = null then
+         Osint.Fail ("End_Of_File attempted on an invalid Text_File");
+      end if;
+
+      return File.End_Of_File_Reached;
+   end End_Of_File;
+
+   --------------
+   -- Get_Line --
+   --------------
+
+   procedure Get_Line
+     (File : Text_File;
+      Line : out String;
+      Last : out Natural)
+   is
+      C : Character;
+
+      procedure Advance;
+
+      -------------
+      -- Advance --
+      -------------
+
+      procedure Advance is
+      begin
+         if File.Cursor = File.Buffer_Len then
+            File.Buffer_Len :=
+              Read
+               (FD => File.FD,
+                A  => File.Buffer'Address,
+                N  => File.Buffer'Length);
+
+            if File.Buffer_Len = 0 then
+               File.End_Of_File_Reached := True;
+               return;
+            else
+               File.Cursor := 1;
+            end if;
+
+         else
+            File.Cursor := File.Cursor + 1;
+         end if;
+      end Advance;
+
+   --  Start of processing for Get_Line
+
+   begin
+      if File = null then
+         Osint.Fail ("Get_Line attempted on an invalid Text_File");
+      end if;
+
+      Last := Line'First - 1;
+
+      if not File.End_Of_File_Reached then
+         loop
+            C := File.Buffer (File.Cursor);
+            exit when C = ASCII.CR or else C = ASCII.LF;
+            Last := Last + 1;
+            Line (Last) := C;
+            Advance;
+
+            if File.End_Of_File_Reached then
+               return;
+            end if;
+
+            exit when Last = Line'Last;
+         end loop;
+
+         if C = ASCII.CR or else C = ASCII.LF then
+            Advance;
+
+            if File.End_Of_File_Reached then
+               return;
+            end if;
+         end if;
+
+         if C = ASCII.CR
+           and then File.Buffer (File.Cursor) = ASCII.LF
+         then
+            Advance;
+         end if;
+      end if;
+   end Get_Line;
+
+   --------------
+   -- Is_Valid --
+   --------------
+
+   function Is_Valid (File : Text_File) return Boolean is
+   begin
+      return File /= null;
+   end Is_Valid;
+
+   ----------
+   -- Open --
+   ----------
+
+   procedure Open (File : out Text_File; Name : in String) is
+      FD        : File_Descriptor;
+      File_Name : String (1 .. Name'Length + 1);
+
+   begin
+      File_Name (1 .. Name'Length) := Name;
+      File_Name (File_Name'Last) := ASCII.NUL;
+      FD := Open_Read (Name => File_Name'Address,
+                            Fmode => GNAT.OS_Lib.Text);
+      if FD = Invalid_FD then
+         File := null;
+      else
+         File := new Text_File_Data;
+         File.FD := FD;
+         File.Buffer_Len :=
+           Read (FD => FD,
+                 A  => File.Buffer'Address,
+                 N  => File.Buffer'Length);
+
+         if File.Buffer_Len = 0 then
+            File.End_Of_File_Reached := True;
+         else
+            File.Cursor := 1;
+         end if;
+      end if;
+   end Open;
+
+   --------------
+   -- Value_Of --
+   --------------
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Name_Id
+   is
+      Current : Array_Element_Id := In_Array;
+      Element : Array_Element;
+
+   begin
+      while Current /= No_Array_Element loop
+         Element := Array_Elements.Table (Current);
+
+         if Index = Element.Index then
+            exit when Element.Value.Kind /= Single;
+            exit when String_Length (Element.Value.Value) = 0;
+            String_To_Name_Buffer (Element.Value.Value);
+            return Name_Find;
+         else
+            Current := Element.Next;
+         end if;
+      end loop;
+
+      return No_Name;
+   end Value_Of;
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Variable_Value
+   is
+      Current : Array_Element_Id := In_Array;
+      Element : Array_Element;
+
+   begin
+      while Current /= No_Array_Element loop
+         Element := Array_Elements.Table (Current);
+
+         if Index = Element.Index then
+            return Element.Value;
+         else
+            Current := Element.Next;
+         end if;
+      end loop;
+
+      return Nil_Variable_Value;
+   end Value_Of;
+
+   function Value_Of
+     (Name                    : Name_Id;
+      Attribute_Or_Array_Name : Name_Id;
+      In_Package              : Package_Id)
+      return                   Variable_Value
+   is
+      The_Array     : Array_Element_Id;
+      The_Attribute : Variable_Value := Nil_Variable_Value;
+
+   begin
+      if In_Package /= No_Package then
+
+         --  First, look if there is an array element that fits
+
+         The_Array :=
+           Value_Of
+             (Name      => Attribute_Or_Array_Name,
+              In_Arrays => Packages.Table (In_Package).Decl.Arrays);
+         The_Attribute :=
+           Value_Of
+             (Index    => Name,
+              In_Array => The_Array);
+
+         --  If there is no array element, look for a variable
+
+         if The_Attribute = Nil_Variable_Value then
+            The_Attribute :=
+              Value_Of
+                (Variable_Name => Attribute_Or_Array_Name,
+                 In_Variables  => Packages.Table (In_Package).Decl.Attributes);
+         end if;
+      end if;
+
+      return The_Attribute;
+   end Value_Of;
+
+   function Value_Of
+     (Index     : Name_Id;
+      In_Array  : Name_Id;
+      In_Arrays : Array_Id)
+      return      Name_Id
+   is
+      Current : Array_Id := In_Arrays;
+      The_Array : Array_Data;
+
+   begin
+      while Current /= No_Array loop
+         The_Array := Arrays.Table (Current);
+         if The_Array.Name = In_Array then
+            return Value_Of (Index, In_Array => The_Array.Value);
+         else
+            Current := The_Array.Next;
+         end if;
+      end loop;
+
+      return No_Name;
+   end Value_Of;
+
+   function Value_Of
+     (Name      : Name_Id;
+      In_Arrays : Array_Id)
+      return      Array_Element_Id
+   is
+      Current : Array_Id := In_Arrays;
+      The_Array : Array_Data;
+
+   begin
+      while Current /= No_Array loop
+         The_Array := Arrays.Table (Current);
+         if The_Array.Name = Name then
+            return The_Array.Value;
+         else
+            Current := The_Array.Next;
+         end if;
+      end loop;
+
+      return No_Array_Element;
+   end Value_Of;
+
+   function Value_Of
+     (Name        : Name_Id;
+      In_Packages : Package_Id)
+      return        Package_Id
+   is
+      Current : Package_Id := In_Packages;
+      The_Package : Package_Element;
+
+   begin
+      while Current /= No_Package loop
+         The_Package := Packages.Table (Current);
+         exit when The_Package.Name /= No_Name and then
+           The_Package.Name = Name;
+         Current := The_Package.Next;
+      end loop;
+
+      return Current;
+   end Value_Of;
+
+   function Value_Of
+     (Variable_Name : Name_Id;
+      In_Variables  : Variable_Id)
+      return          Variable_Value
+   is
+      Current : Variable_Id := In_Variables;
+      The_Variable : Variable;
+
+   begin
+      while Current /= No_Variable loop
+         The_Variable := Variable_Elements.Table (Current);
+
+         if Variable_Name = The_Variable.Name then
+            return The_Variable.Value;
+         else
+            Current := The_Variable.Next;
+         end if;
+      end loop;
+
+      return Nil_Variable_Value;
+   end Value_Of;
+
+   ---------------
+   -- Write_Str --
+   ---------------
+
+   procedure Write_Str
+     (S          : String;
+      Max_Length : Positive;
+      Separator  : Character)
+   is
+      First : Positive := S'First;
+      Last  : Natural  := S'Last;
+
+   begin
+      --  Nothing to do for empty strings
+
+      if S'Length > 0 then
+         --  Start on a new line if current line is already longer than
+         --  Max_Length.
+
+         if Positive (Column) >= Max_Length then
+            Write_Eol;
+         end if;
+
+         --  If length of remainder is longer than Max_Length, we need to
+         --  cut the remainder in several lines.
+
+         while Positive (Column) + S'Last - First > Max_Length loop
+            --  Try the maximum length possible
+
+            Last := First + Max_Length - Positive (Column);
+
+            --  Look for last Separator in the line
+
+            while Last >= First and then S (Last) /= Separator loop
+               Last := Last - 1;
+            end loop;
+
+            --  If we do not find a separator, we output the maximum length
+            --  possible.
+            if Last < First then
+               Last := First + Max_Length - Positive (Column);
+            end if;
+
+            Write_Line (S (First .. Last));
+
+            --  Set the beginning of the new remainder
+
+            First := Last + 1;
+
+         end loop;
+
+         --  What is left goes to the buffer, without EOL
+
+         Write_Str (S (First .. S'Last));
+
+      end if;
+   end Write_Str;
+
+end Prj.Util;

gcc/ada/prj-util.ads

@@ -0,0 +1,148 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . U T I L                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.6 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Utilities when using project files.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Types;       use Types;
+
+package Prj.Util is
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Name_Id;
+   --  Get a single string array component.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Array is null, or if the component is a String list.
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Variable_Value;
+   --  Get a string array component (single String or String list).
+   --  Returns Nil_Variable_Value if there is no component Index
+   --  (case sensitive), or if In_Array is null.
+
+   function Value_Of
+     (Name                    : Name_Id;
+      Attribute_Or_Array_Name : Name_Id;
+      In_Package              : Package_Id)
+      return                   Variable_Value;
+   --  In a specific package,
+   --   - if there exists an array Variable_Or_Array_Name with an index
+   --     Name, returns the corresponding component,
+   --   - otherwise if there is a attribute Attribute_Or_Array_Name,
+   --     returns this attribute,
+   --   - otherwise, returns Nil_Variable_Value.
+   --  If In_Package is null, returns Nil_Variable_Value.
+
+   function Value_Of
+     (Index     : Name_Id;
+      In_Array  : Name_Id;
+      In_Arrays : Array_Id)
+      return      Name_Id;
+   --  Get a string array component in an array of an array list.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Arrays is null, if In_Array is not found in In_Arrays,
+   --  or if the component is a String list.
+
+   function Value_Of
+     (Name      : Name_Id;
+      In_Arrays : Array_Id)
+      return      Array_Element_Id;
+   --  Returns a specified array in an array list.
+   --  Returns No_Array_Element if In_Arrays is null or if Name is not the
+   --  name of an array in In_Arrays.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Name        : Name_Id;
+      In_Packages : Package_Id)
+      return        Package_Id;
+   --  Returns a specified package in a package list.
+   --  Returns No_Package if In_Packages is null or if Name is not the
+   --  name of a package in Package_List.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Variable_Name : Name_Id;
+      In_Variables  : Variable_Id)
+      return          Variable_Value;
+   --  Returns a specified variable in a variable list.
+   --  Returns null if In_Variables is null or if Variable_Name
+   --  is not the name of a variable in In_Variables.
+   --  Assumption: Variable_Name is in lower case.
+
+   procedure Write_Str
+     (S          : String;
+      Max_Length : Positive;
+      Separator  : Character);
+   --  Output string S using Output.Write_Str.
+   --  If S is too long to fit in one line of Max_Length, cut it in
+   --  several lines, using Separator as the last character of each line,
+   --  if possible.
+
+   type Text_File is limited private;
+   --  Represents a text file.
+   --  Default is invalid text file.
+
+   function Is_Valid (File : Text_File) return Boolean;
+   --  Returns True if File designates an open text file that
+   --  has not yet been closed.
+
+   procedure Open (File : out Text_File; Name : String);
+   --  Open a text file. If this procedure fails, File is invalid.
+
+   function End_Of_File (File : Text_File) return Boolean;
+   --  Returns True if the end of the text file File has been
+   --  reached. Fails if File is invalid.
+
+   procedure Get_Line
+     (File : Text_File;
+      Line : out String;
+      Last : out Natural);
+   --  Reads a line from an open text file. Fails if File is invalid.
+
+   procedure Close (File : in out Text_File);
+   --  Close an open text file. File becomes invalid.
+   --  Fails if File is already invalid.
+
+private
+
+   type Text_File_Data is record
+      FD                  : File_Descriptor := Invalid_FD;
+      Buffer              : String (1 .. 1_000);
+      Buffer_Len          : Natural;
+      Cursor              : Natural := 0;
+      End_Of_File_Reached : Boolean := False;
+   end record;
+
+   type Text_File is access Text_File_Data;
+
+end Prj.Util;

gcc/ada/prj.adb

@@ -0,0 +1,286 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P R J                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Errout;      use Errout;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Osint;       use Osint;
+with Prj.Attr;
+with Prj.Com;
+with Prj.Env;
+with Scans;       use Scans;
+with Scn;
+with Stringt;     use Stringt;
+with Sinfo.CN;
+with Snames;      use Snames;
+
+package body Prj is
+
+   The_Empty_String : String_Id;
+
+   subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
+
+   The_Casing_Images : array (Known_Casing) of String_Access :=
+     (All_Lower_Case => new String'("lowercase"),
+      All_Upper_Case => new String'("UPPERCASE"),
+      Mixed_Case     => new String'("MixedCase"));
+
+   Initialized : Boolean := False;
+
+   Standard_Dot_Replacement      : constant Name_Id :=
+     First_Name_Id + Character'Pos ('-');
+   Standard_Specification_Append : Name_Id;
+   Standard_Body_Append          : Name_Id;
+
+   Std_Naming_Data : Naming_Data :=
+     (Dot_Replacement      => Standard_Dot_Replacement,
+      Dot_Repl_Loc         => No_Location,
+      Casing               => All_Lower_Case,
+      Specification_Append => No_Name,
+      Spec_Append_Loc      => No_Location,
+      Body_Append          => No_Name,
+      Body_Append_Loc      => No_Location,
+      Separate_Append      => No_Name,
+      Sep_Append_Loc       => No_Location,
+      Specifications       => No_Array_Element,
+      Bodies               => No_Array_Element);
+
+   Project_Empty : Project_Data :=
+     (First_Referred_By  => No_Project,
+      Name               => No_Name,
+      Path_Name          => No_Name,
+      Location           => No_Location,
+      Directory          => No_Name,
+      File_Name          => No_Name,
+      Library            => False,
+      Library_Dir        => No_Name,
+      Library_Name       => No_Name,
+      Library_Kind       => Static,
+      Lib_Internal_Name  => No_Name,
+      Lib_Elaboration    => False,
+      Sources            => Nil_String,
+      Source_Dirs        => Nil_String,
+      Object_Directory   => No_Name,
+      Modifies           => No_Project,
+      Modified_By        => No_Project,
+      Naming             => Std_Naming_Data,
+      Decl               => No_Declarations,
+      Imported_Projects  => Empty_Project_List,
+      Include_Path       => null,
+      Objects_Path       => null,
+      Config_File_Name   => No_Name,
+      Config_File_Temp   => False,
+      Config_Checked     => False,
+      Checked            => False,
+      Seen               => False,
+      Flag1              => False,
+      Flag2              => False);
+
+   -------------------
+   -- Empty_Project --
+   -------------------
+
+   function Empty_Project return Project_Data is
+   begin
+      Initialize;
+      return Project_Empty;
+   end Empty_Project;
+
+   ------------------
+   -- Empty_String --
+   ------------------
+
+   function Empty_String return String_Id is
+   begin
+      return The_Empty_String;
+   end Empty_String;
+
+   ------------
+   -- Expect --
+   ------------
+
+   procedure Expect (The_Token : Token_Type; Token_Image : String) is
+   begin
+      if Token /= The_Token then
+         Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
+      end if;
+   end Expect;
+
+   --------------------------------
+   -- For_Every_Project_Imported --
+   --------------------------------
+
+   procedure For_Every_Project_Imported
+     (By         : Project_Id;
+      With_State : in out State)
+   is
+
+      procedure Check (Project : Project_Id);
+      --  Check if a project has already been seen.
+      --  If not seen, mark it as seen, call Action,
+      --  and check all its imported projects.
+
+      procedure Check (Project : Project_Id) is
+         List : Project_List;
+
+      begin
+         if not Projects.Table (Project).Seen then
+            Projects.Table (Project).Seen := False;
+            Action (Project, With_State);
+
+            List := Projects.Table (Project).Imported_Projects;
+            while List /= Empty_Project_List loop
+               Check (Project_Lists.Table (List).Project);
+               List := Project_Lists.Table (List).Next;
+            end loop;
+         end if;
+      end Check;
+
+   begin
+      for Project in Projects.First .. Projects.Last loop
+         Projects.Table (Project).Seen := False;
+      end loop;
+
+      Check (Project => By);
+   end For_Every_Project_Imported;
+
+   -----------
+   -- Image --
+   -----------
+
+   function Image (Casing : Casing_Type) return String is
+   begin
+      return The_Casing_Images (Casing).all;
+   end Image;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      if not Initialized then
+         Initialized := True;
+         Stringt.Initialize;
+         Start_String;
+         The_Empty_String := End_String;
+         Name_Len := 4;
+         Name_Buffer (1 .. 4) := ".ads";
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Specification_Append := Name_Find;
+         Name_Buffer (4) := 'b';
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Body_Append := Name_Find;
+         Std_Naming_Data.Specification_Append := Standard_Specification_Append;
+         Std_Naming_Data.Body_Append          := Standard_Body_Append;
+         Std_Naming_Data.Separate_Append      := Standard_Body_Append;
+         Project_Empty.Naming                 := Std_Naming_Data;
+         Prj.Env.Initialize;
+         Prj.Attr.Initialize;
+         Set_Name_Table_Byte (Name_Project,   Token_Type'Pos (Tok_Project));
+         Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
+         Set_Name_Table_Byte (Name_External,  Token_Type'Pos (Tok_External));
+      end if;
+   end Initialize;
+
+   ------------
+   --  Reset --
+   ------------
+
+   procedure Reset is
+   begin
+      Projects.Init;
+      Project_Lists.Init;
+      Packages.Init;
+      Arrays.Init;
+      Variable_Elements.Init;
+      String_Elements.Init;
+      Prj.Com.Units.Init;
+      Prj.Com.Units_Htable.Reset;
+   end Reset;
+
+   ------------------------
+   -- Same_Naming_Scheme --
+   ------------------------
+
+   function Same_Naming_Scheme
+     (Left, Right : Naming_Data)
+      return        Boolean
+   is
+   begin
+      return Left.Dot_Replacement = Right.Dot_Replacement
+        and then Left.Casing = Right.Casing
+        and then Left.Specification_Append = Right.Specification_Append
+        and then Left.Body_Append = Right.Body_Append
+        and then Left.Separate_Append = Right.Separate_Append;
+   end Same_Naming_Scheme;
+
+   ----------
+   -- Scan --
+   ----------
+
+   procedure Scan is
+   begin
+      Scn.Scan;
+
+      --  Change operator symbol to literal strings, since that's the way
+      --  we treat all strings in a project file.
+
+      if Token = Tok_Operator_Symbol then
+         Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
+         Token := Tok_String_Literal;
+      end if;
+   end Scan;
+
+   --------------------------
+   -- Standard_Naming_Data --
+   --------------------------
+
+   function Standard_Naming_Data return Naming_Data is
+   begin
+      Initialize;
+      return Std_Naming_Data;
+   end Standard_Naming_Data;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value (Image : String) return Casing_Type is
+   begin
+      for Casing in The_Casing_Images'Range loop
+         if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
+            return Casing;
+         end if;
+      end loop;
+
+      raise Constraint_Error;
+   end Value;
+
+end Prj;

gcc/ada/prj.ads

@@ -0,0 +1,416 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P R J                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.18 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The following package declares the data types for GNAT project.
+--  These data types may be used by GNAT Project-aware tools.
+
+--  Children of these package implements various services on these data types.
+--  See in particular Prj.Pars and Prj.Env.
+
+with Casing;      use Casing;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Scans;       use Scans;
+with Table;
+with Types;       use Types;
+
+package Prj is
+
+   type Put_Line_Access is access procedure (Line : String);
+   --  Use to customize error reporting in Prj.Proc and Prj.Nmsc.
+
+   type Verbosity is (Default, Medium, High);
+   --  Verbosity when parsing GNAT Project Files.
+   --  Default is default (very quiet, if no errors).
+   --  Medium is more verbose.
+   --  High is extremely verbose.
+
+   type Lib_Kind is (Static, Dynamic, Relocatable);
+
+   function Empty_String return String_Id;
+
+   type String_List_Id is new Nat;
+   Nil_String : constant String_List_Id := 0;
+   type String_Element is record
+      Value    : String_Id      := No_String;
+      Location : Source_Ptr     := No_Location;
+      Next     : String_List_Id := Nil_String;
+   end record;
+   --  To hold values for string list variables and array elements.
+
+   package String_Elements is new Table.Table
+     (Table_Component_Type => String_Element,
+      Table_Index_Type     => String_List_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.String_Elements");
+   --  The table for string elements in string lists.
+
+   type Variable_Kind is (Undefined, List, Single);
+   --  Different kinds of variables
+
+   type Variable_Value (Kind : Variable_Kind := Undefined) is record
+      Location : Source_Ptr := No_Location;
+      Default  : Boolean    := False;
+      case Kind is
+         when Undefined =>
+            null;
+         when List =>
+            Values : String_List_Id := Nil_String;
+         when Single =>
+            Value : String_Id := No_String;
+      end case;
+   end record;
+   --  Values for variables and array elements
+
+   Nil_Variable_Value : constant Variable_Value :=
+     (Kind     => Undefined,
+      Location => No_Location,
+      Default  => False);
+   --  Value of a non existing variable or array element.
+
+   type Variable_Id is new Nat;
+   No_Variable : constant Variable_Id := 0;
+   type Variable is record
+      Next     : Variable_Id := No_Variable;
+      Name     : Name_Id;
+      Value    : Variable_Value;
+   end record;
+   --  To hold the list of variables in a project file and in packages.
+
+   package Variable_Elements is new Table.Table
+     (Table_Component_Type => Variable,
+      Table_Index_Type     => Variable_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Variable_Elements");
+   --  The table of variable in list of variables.
+
+   type Array_Element_Id is new Nat;
+   No_Array_Element : constant Array_Element_Id := 0;
+   type Array_Element is record
+      Index    : Name_Id;
+      Value    : Variable_Value;
+      Next     : Array_Element_Id := No_Array_Element;
+   end record;
+   --  Each Array_Element represents an array element.
+   --  Each Array_Element is linked (Next) to the next array element,
+   --  if any, in the array.
+
+   package Array_Elements is new Table.Table
+     (Table_Component_Type => Array_Element,
+      Table_Index_Type     => Array_Element_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Array_Elements");
+   --  The table that contains all array elements
+
+   type Array_Id is new Nat;
+   No_Array : constant Array_Id := 0;
+   type Array_Data is record
+      Name  : Name_Id          := No_Name;
+      Value : Array_Element_Id := No_Array_Element;
+      Next  : Array_Id         := No_Array;
+   end record;
+   --  Each Array_Data represents an array.
+   --  Value is the id of the first element.
+   --  Next is the id of the next array in the project file or package.
+
+   package Arrays is new Table.Table
+     (Table_Component_Type => Array_Data,
+      Table_Index_Type     => Array_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Arrays");
+   --  The table that contains all arrays
+
+   type Package_Id is new Nat;
+   No_Package : constant Package_Id := 0;
+   type Declarations is record
+      Variables  : Variable_Id := No_Variable;
+      Attributes : Variable_Id := No_Variable;
+      Arrays     : Array_Id    := No_Array;
+      Packages   : Package_Id  := No_Package;
+   end record;
+
+   No_Declarations : constant Declarations :=
+     (Variables  => No_Variable,
+      Attributes => No_Variable,
+      Arrays     => No_Array,
+      Packages   => No_Package);
+   --  Declarations. Used in project structures and packages.
+
+   type Package_Element is record
+      Name   : Name_Id      := No_Name;
+      Decl   : Declarations := No_Declarations;
+      Parent : Package_Id   := No_Package;
+      Next   : Package_Id   := No_Package;
+   end record;
+   --  A package. Includes declarations that may include
+   --  other packages.
+
+   package Packages is new Table.Table
+     (Table_Component_Type => Package_Element,
+      Table_Index_Type     => Package_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Packages");
+   --  The table that contains all packages.
+
+   function Image (Casing : Casing_Type) return String;
+   --  Similar to 'Image
+
+   function Value (Image : String) return Casing_Type;
+   --  Similar to 'Value
+   --  This is to avoid s-valenu in the closure of the tools
+   --  Raises Constraint_Error if not a Casing_Type image.
+
+   type Naming_Data is record
+      Dot_Replacement      : Name_Id          := No_Name;
+      --  The string to replace '.' in the source file name.
+
+      Dot_Repl_Loc         : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Dot_Replacement is defined.
+
+      Casing               : Casing_Type      := All_Lower_Case;
+      --  The casing of the source file name.
+
+      Specification_Append : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a specification.
+
+      Spec_Append_Loc      : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Specification_Append is defined.
+
+      Body_Append          : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a body.
+
+      Body_Append_Loc      : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Body_Append is defined.
+
+      Separate_Append      : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a subunit.
+
+      Sep_Append_Loc       : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Separate_Append is defined.
+
+      Specifications       : Array_Element_Id := No_Array_Element;
+      --  An associative array mapping individual specifications
+      --  to source file names.
+
+      Bodies               : Array_Element_Id := No_Array_Element;
+      --  An associative array mapping individual bodies
+      --  to source file names.
+
+   end record;
+   --  A naming scheme.
+
+   function Standard_Naming_Data return Naming_Data;
+   pragma Inline (Standard_Naming_Data);
+   --  The standard GNAT naming scheme.
+
+   function Same_Naming_Scheme
+     (Left, Right : Naming_Data)
+      return        Boolean;
+   --  Returns True if Left and Right are the same naming scheme
+   --  not considering Specifications and Bodies.
+
+   type Project_Id is new Nat;
+   No_Project : constant Project_Id := 0;
+   --  Id of a Project File
+
+   type Project_List is new Nat;
+   Empty_Project_List : constant Project_List := 0;
+   --  A list of project files.
+
+   type Project_Element is record
+      Project : Project_Id   := No_Project;
+      Next    : Project_List := Empty_Project_List;
+   end record;
+   --  Element in a list of project file.
+   --  Next is the id of the next project file in the list.
+
+   package Project_Lists is new Table.Table
+     (Table_Component_Type => Project_Element,
+      Table_Index_Type     => Project_List,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Project_Lists");
+   --  The table that contains the lists of project files.
+
+   type Project_Data is record
+      First_Referred_By  : Project_Id     := No_Project;
+      --  The project, if any, that was the first to be known
+      --  as importing or modifying this project.
+
+      Name               : Name_Id        := No_Name;
+      --  The name of the project.
+
+      Path_Name          : Name_Id        := No_Name;
+      --  The path name of the project file.
+
+      Location           : Source_Ptr     := No_Location;
+      --  The location in the project file source of the
+      --  reserved word project.
+
+      Directory          : Name_Id        := No_Name;
+      --  The directory where the project file resides.
+
+      File_Name          : Name_Id        := No_Name;
+      --  The file name of the project file.
+
+      Library            : Boolean        := False;
+      --  True if this is a library project
+
+      Library_Dir        : Name_Id        := No_Name;
+      --  If a library project, directory where resides the library
+
+      Library_Name       : Name_Id        := No_Name;
+      --  If a library project, name of the library
+
+      Library_Kind       : Lib_Kind       := Static;
+      --  If a library project, kind of library
+
+      Lib_Internal_Name  : Name_Id        := No_Name;
+      --  If a library project, internal name store inside the library
+
+      Lib_Elaboration    : Boolean        := False;
+      --  If a library project, indicate if <lib>init and <lib>final
+      --  procedures need to be defined.
+
+      Sources            : String_List_Id := Nil_String;
+      --  The list of all the source file names.
+
+      Source_Dirs        : String_List_Id := Nil_String;
+      --  The list of all the source directories.
+
+      Object_Directory   : Name_Id        := No_Name;
+      --  The object directory of this project file.
+
+      Modifies           : Project_Id     := No_Project;
+      --  The reference of the project file, if any, that this
+      --  project file modifies.
+
+      Modified_By        : Project_Id     := No_Project;
+      --  The reference of the project file, if any, that
+      --  modifies this project file.
+
+      Naming             : Naming_Data    := Standard_Naming_Data;
+      --  The naming scheme of this project file.
+
+      Decl               : Declarations   := No_Declarations;
+      --  The declarations (variables, attributes and packages)
+      --  of this project file.
+
+      Imported_Projects  : Project_List   := Empty_Project_List;
+      --  The list of all directly imported projects, if any.
+
+      Include_Path       : String_Access  := null;
+      --  The cached value of ADA_INCLUDE_PATH for this project file.
+
+      Objects_Path       : String_Access  := null;
+      --  The cached value of ADA_OBJECTS_PATH for this project file.
+
+      Config_File_Name   : Name_Id        := No_Name;
+      --  The name of the configuration pragmas file, if any.
+
+      Config_File_Temp   : Boolean        := False;
+      --  An indication that the configuration pragmas file is
+      --  a temporary file that must be deleted at the end.
+
+      Config_Checked     : Boolean        := False;
+      --  A flag to avoid checking repetively the configuration pragmas file.
+
+      Checked            : Boolean        := False;
+      --  A flag to avoid checking repetively the naming scheme of
+      --  this project file.
+
+      --  Various flags that are used in an ad hoc manner
+
+      Seen               : Boolean        := False;
+      Flag1              : Boolean        := False;
+      Flag2              : Boolean        := False;
+
+   end record;
+   --  Project File representation.
+
+   function Empty_Project return Project_Data;
+   --  Return the representation of an empty project.
+
+   package Projects is new Table.Table (
+     Table_Component_Type => Project_Data,
+     Table_Index_Type     => Project_Id,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 100,
+     Table_Increment      => 100,
+     Table_Name           => "Prj.Projects");
+   --  The set of all project files.
+
+   procedure Expect (The_Token : Token_Type; Token_Image : String);
+   --  Check that the current token is The_Token. If it is not, then
+   --  output an error message.
+
+   procedure Initialize;
+   --  This procedure must be called before using any services from the Prj
+   --  hierarchy. Namet.Initialize must be called before Prj.Initialize.
+
+   procedure Reset;
+   --  This procedure resets all the tables that are used when processing a
+   --  project file tree. Initialize must be called before the call to Reset.
+
+   generic
+      type State is limited private;
+      with procedure Action
+        (Project    : Project_Id;
+         With_State : in out State);
+   procedure For_Every_Project_Imported
+     (By         : Project_Id;
+      With_State : in out State);
+   --  Call Action for each project imported directly or indirectly by project
+   --  By.--  Action is called according to the order of importation: if A
+   --  imports B, directly or indirectly, Action will be called for A before
+   --  it is called for B. With_State may be used by Action to choose a
+   --  behavior or to report some global result.
+
+private
+
+   procedure Scan;
+   --  Calls Scn.Scan and change any Operator_Symbol to String_Literal
+
+end Prj;

gcc/ada/raise.c

@@ -0,0 +1,86 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *             Copyright (C) 1992-2001, Free Software Foundation, Inc.      *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* Routines to support runtime exception handling */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+#include "raise.h"
+
+/*  We have not yet figured out how to import this directly */
+
+void
+_gnat_builtin_longjmp (ptr, flag)
+     void *ptr;
+     int flag ATTRIBUTE_UNUSED;
+{
+   __builtin_longjmp (ptr, 1);
+}
+
+/* When an exception is raised for which no handler exists, the procedure
+   Ada.Exceptions.Unhandled_Exception is called, which performs the call to
+   adafinal to complete finalization, and then prints out the error messages
+   for the unhandled exception. The final step is to call this routine, which
+   performs any system dependent cleanup required.  */
+
+void
+__gnat_unhandled_terminate ()
+{
+  /* Special termination handling for VMS */
+
+#ifdef VMS
+    {
+      long prvhnd;
+
+      /* Remove the exception vector so it won't intercept any errors
+	 in the call to exit, and go into and endless loop */
+
+      SYS$SETEXV (1, 0, 3, &prvhnd);
+      __gnat_os_exit (1);
+    }
+
+/* Termination handling for all other systems. */
+
+#elif !defined (__RT__)
+    __gnat_os_exit (1);
+#endif
+}

gcc/ada/raise.h

@@ -0,0 +1,71 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1992-2001, Free Software Foundation, Inc.         *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+struct Exception_Data
+{ 
+  char  Handled_By_Others;
+  char Lang;
+  int Name_Length;
+  char *Full_Name, Htable_Ptr;
+  int Import_Code;
+};
+
+typedef struct Exception_Data *Exception_Id;
+
+struct Exception_Occurrence
+{
+  int Max_Length;
+  Exception_Id Id;
+  int Msg_Length;
+  char Msg [0];
+};
+
+typedef struct Exception_Occurrence *Exception_Occurrence_Access;
+
+extern void _gnat_builtin_longjmp	PARAMS ((void *, int));
+extern void __gnat_unhandled_terminate	PARAMS ((void));
+extern void *__gnat_malloc		PARAMS ((__SIZE_TYPE__));
+extern void __gnat_free			PARAMS ((void *));
+extern void *__gnat_realloc		PARAMS ((void *, __SIZE_TYPE__));
+extern void __gnat_finalize		PARAMS ((void));
+extern void set_gnat_exit_status	PARAMS ((int));
+extern void __gnat_set_globals		PARAMS ((int, int, int, int, int, int,
+						 void (*) PARAMS ((void)),
+						 int, int));
+extern void __gnat_initialize		PARAMS ((void));
+extern void __gnat_init_float		PARAMS ((void));
+extern void __gnat_install_handler	PARAMS ((void));
+
+extern int gnat_exit_status;
+

gcc/ada/repinfo.ads

@@ -0,0 +1,320 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R E P I N F O                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.20 $
+--                                                                          --
+--          Copyright (C) 1999-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the routines to handle back annotation of the
+--  tree to fill in representation information, and also the routine used
+--  by -gnatR to print this information. This unit is used both in the
+--  compiler and in ASIS (it is used in ASIS as part of the implementation
+--  of the data decomposition annex.
+
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Repinfo is
+
+   --------------------------------
+   -- Representation Information --
+   --------------------------------
+
+   --  The representation information of interest here is size and
+   --  component information for arrays and records. For primitive
+   --  types, the front end computes the Esize and RM_Size fields of
+   --  the corresponding entities as constant non-negative integers,
+   --  and the Uint values are stored directly in these fields.
+
+   --  For composite types, there are three cases:
+
+   --    1. In some cases the front end knows the values statically,
+   --       for example in the ase where representation clauses or
+   --       pragmas specify the values.
+
+   --    2. If Backend_Layout is True, then the backend is responsible
+   --       for layout of all types and objects not laid out by the
+   --       front end. This includes all dynamic values, and also
+   --       static values (e.g. record sizes) when not set by the
+   --       front end.
+
+   --    3. If Backend_Layout is False, then the front end lays out
+   --       all data, according to target dependent size and alignment
+   --       information, creating dynamic inlinable functions where
+   --       needed in the case of sizes not known till runtime.
+
+   -----------------------------
+   -- Back-Annotation by Gigi --
+   -----------------------------
+
+   --  The following interface is used by gigi if Backend_Layout is True.
+
+   --  As part of the processing in gigi, the types are laid out and
+   --  appropriate values computed for the sizes and component positions
+   --  and sizes of records and arrays.
+
+   --  The back-annotation circuit in gigi is responsible for updating the
+   --  relevant fields in the tree to reflect these computations, as follows:
+
+   --    For E_Array_Type entities, the Component_Size field
+
+   --    For all record and array types and subtypes, the Esize field,
+   --    which contains the Size (more accurately the Object_SIze) value
+   --    for the type or subtype.
+
+   --    For E_Component and E_Distriminant entities, the Esize (size
+   --    of component) and Component_Bit_Offset fields. Note that gigi
+   --    does not (yet ???) back annotate Normalized_Position/First_Bit.
+
+   --  There are three cases to consider:
+
+   --    1. The value is constant. In this case, the back annotation works
+   --       by simply storing the non-negative universal integer value in
+   --       the appropriate field corresponding to this constant size.
+
+   --    2. The value depends on variables other than discriminants of the
+   --       current record. In this case, the value is not known, even if
+   --       the complete data of the record is available, and gigi marks
+   --       this situation by storing the special value No_Uint.
+
+   --    3. The value depends on the discriminant values for the current
+   --       record. In this case, gigi back annotates the field with a
+   --       representation of the expression for computing the value in
+   --       terms of the discriminants. A negative Uint value is used to
+   --       represent the value of such an expression, as explained in
+   --       the following section.
+
+   --  GCC expressions are represented with a Uint value that is negative.
+   --  See the body of this package for details on the representation used.
+
+   --  One other case in which gigi back annotates GCC expressions is in
+   --  the Present_Expr field of an N_Variant node. This expression which
+   --  will always depend on discriminants, and hence always be represented
+   --  as a negative Uint value, provides an expression which, when evaluated
+   --  with a given set of discriminant values, indicates whether the variant
+   --  is present for that set of values (result is True, i.e. non-zero) or
+   --  not present (result is False, i.e. zero).
+
+   subtype Node_Ref is Uint;
+   --  Subtype used for negative Uint values used to represent nodes
+
+   subtype Node_Ref_Or_Val is Uint;
+   --  Subtype used for values that can either be a Node_Ref (negative)
+   --  or a value (non-negative)
+
+   type TCode is range 0 .. 27;
+   --  Type used on Ada side to represent DEFTREECODE values defined in
+   --  tree.def. Only a subset of these tree codes can actually appear.
+   --  The names are the names from tree.def in Ada casing.
+
+   --  name                             code   description           operands
+
+   Cond_Expr        : constant TCode :=  1; -- conditional              3
+   Plus_Expr        : constant TCode :=  2; -- addition                 2
+   Minus_Expr       : constant TCode :=  3; -- subtraction              2
+   Mult_Expr        : constant TCode :=  4; -- multiplication           2
+   Trunc_Div_Expr   : constant TCode :=  5; -- truncating division      2
+   Ceil_Div_Expr    : constant TCode :=  6; -- division rounding up     2
+   Floor_Div_Expr   : constant TCode :=  7; -- division rounding down   2
+   Trunc_Mod_Expr   : constant TCode :=  8; -- mod for trunc_div        2
+   Ceil_Mod_Expr    : constant TCode :=  9; -- mod for ceil_div         2
+   Floor_Mod_Expr   : constant TCode := 10; -- mod for floor_div        2
+   Exact_Div_Expr   : constant TCode := 11; -- exact div                2
+   Negate_Expr      : constant TCode := 12; -- negation                 1
+   Min_Expr         : constant TCode := 13; -- minimum                  2
+   Max_Expr         : constant TCode := 14; -- maximum                  2
+   Abs_Expr         : constant TCode := 15; -- absolute value           1
+   Truth_Andif_Expr : constant TCode := 16; -- Boolean and then         2
+   Truth_Orif_Expr  : constant TCode := 17; -- Boolean or else          2
+   Truth_And_Expr   : constant TCode := 18; -- Boolean and              2
+   Truth_Or_Expr    : constant TCode := 19; -- Boolean or               2
+   Truth_Xor_Expr   : constant TCode := 20; -- Boolean xor              2
+   Truth_Not_Expr   : constant TCode := 21; -- Boolean not              1
+   Lt_Expr          : constant TCode := 22; -- comparision <            2
+   Le_Expr          : constant TCode := 23; -- comparision <=           2
+   Gt_Expr          : constant TCode := 24; -- comparision >            2
+   Ge_Expr          : constant TCode := 25; -- comparision >=           2
+   Eq_Expr          : constant TCode := 26; -- comparision =            2
+   Ne_Expr          : constant TCode := 27; -- comparision /=           2
+
+   --  The following entry is used to represent a discriminant value in
+   --  the tree. It has a special tree code that does not correspond
+   --  directly to a gcc node. The single operand is the number of the
+   --  discriminant in the record (1 = first discriminant).
+
+   Discrim_Val : constant TCode := 0;  -- discriminant value       1
+
+   ------------------------
+   -- The gigi Interface --
+   ------------------------
+
+   --  The following declarations are for use by gigi for back annotation
+
+   function Create_Node
+     (Expr  : TCode;
+      Op1   : Node_Ref_Or_Val;
+      Op2   : Node_Ref_Or_Val := No_Uint;
+      Op3   : Node_Ref_Or_Val := No_Uint)
+      return  Node_Ref;
+   --  Creates a node with using the tree code defined by Expr and from
+   --  1-3 operands as required (unused operands set as shown to No_Uint)
+   --  Note that this call can be used to create a discriminant reference
+   --  by using (Expr => Discrim_Val, Op1 => discriminant_number).
+
+   function Create_Discrim_Ref
+     (Discr : Entity_Id)
+      return  Node_Ref;
+   --  Creates a refrerence to the discriminant whose entity is Discr.
+
+   --------------------------------------------------------
+   -- Front-End Interface for Dynamic Size/Offset Values --
+   --------------------------------------------------------
+
+   --  If Backend_Layout is False, then the front-end deals with all
+   --  dynamic size and offset fields. There are two cases:
+
+   --    1. The value can be computed at the time of type freezing, and
+   --       is stored in a run-time constant. In this case, the field
+   --       contains a reference to this entity. In the case of sizes
+   --       the value stored is the size in storage units, since dynamic
+   --       sizes are always a multiple of storage units.
+
+   --    2. The size/offset depends on the value of discriminants at
+   --       run-time. In this case, the front end builds a function to
+   --       compute the value. This function has a single parameter
+   --       which is the discriminated record object in question. Any
+   --       references to discriminant values are simply references to
+   --       the appropriate discriminant in this single argument, and
+   --       to compute the required size/offset value at run time, the
+   --       code generator simply constructs a call to the function
+   --       with the appropriate argument. The size/offset field in
+   --       this case contains a reference to the function entity.
+   --       Note that as for case 1, if such a function is used to
+   --       return a size, then the size in storage units is returned,
+   --       not the size in bits.
+
+   --  The interface here allows these created entities to be referenced
+   --  using negative Unit values, so that they can be stored in the
+   --  appropriate size and offset fields in the tree.
+
+   --  In the case of components, if the location of the component is static,
+   --  then all four fields (Component_Bit_Offset, Normalized_Position, Esize,
+   --  and Normalized_First_Bit) are set to appropraite values. In the case of
+   --  a non-static component location, Component_Bit_Offset is not used and
+   --  is left set to Unknown. Normalized_Position and Normalized_First_Bit
+   --  are set appropriately.
+
+   subtype SO_Ref is Uint;
+   --  Type used to represent a Uint value that represents a static or
+   --  dynamic size/offset value (non-negative if static, negative if
+   --  the size value is dynamic).
+
+   subtype Dynamic_SO_Ref is Uint;
+   --  Type used to represent a negative Uint value used to store
+   --  a dynamic size/offset value.
+
+   function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean;
+   pragma Inline (Is_Dynamic_SO_Ref);
+   --  Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
+   --  represents a dynamic Size/Offset value (i.e. it is negative).
+
+   function Is_Static_SO_Ref (U : SO_Ref) return Boolean;
+   pragma Inline (Is_Static_SO_Ref);
+   --  Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
+   --  represents a static Size/Offset value (i.e. it is non-negative).
+
+   function Create_Dynamic_SO_Ref
+     (E    : Entity_Id)
+      return Dynamic_SO_Ref;
+   --  Given the Entity_Id for a constant (case 1), the Node_Id for an
+   --  expression (case 2), or the Entity_Id for a function (case 3),
+   --  this function returns a (negative) Uint value that can be used
+   --  to retrieve the entity or expression for later use.
+
+   function Get_Dynamic_SO_Entity
+     (U    : Dynamic_SO_Ref)
+      return Entity_Id;
+   --  Retrieve the Node_Id or Entity_Id stored by a previous call to
+   --  Create_Dynamic_SO_Ref. The approach is that the front end makes
+   --  the necessary Create_Dynamic_SO_Ref calls to associate the node
+   --  and entity id values and the back end makes Get_Dynamic_SO_Ref
+   --  calls to retrive them.
+
+   --------------------
+   -- ASIS_Interface --
+   --------------------
+
+   type Discrim_List is array (Pos range <>) of Uint;
+   --  Type used to represent list of discriminant values
+
+   function Rep_Value
+     (Val  : Node_Ref_Or_Val;
+      D    : Discrim_List)
+      return Uint;
+   --  Given the contents of a First_Bit_Position or Esize field containing
+   --  a node reference (i.e. a negative Uint value) and D, the list of
+   --  discriminant values, returns the interpreted value of this field.
+   --  For convenience, Rep_Value will take a non-negative Uint value
+   --  as an argument value, and return it unmodified. A No_Uint value is
+   --  also returned unmodified.
+
+   procedure Tree_Read;
+   --  Read in the value of the Rep_Table
+
+   ------------------------
+   -- Compiler Interface --
+   ------------------------
+
+   procedure List_Rep_Info;
+   --  Procedure to list representation information
+
+   procedure Tree_Write;
+   --  Write out the value of the Rep_Table
+
+   --------------------------
+   -- Debugging Procedures --
+   --------------------------
+
+   procedure List_GCC_Expression (U : Node_Ref_Or_Val);
+   --  Prints out given expression in symbolic form. Constants are listed
+   --  in decimal numeric form, Discriminants are listed with a # followed
+   --  by the discriminant number, and operators are output in appropriate
+   --  symbolic form No_Uint displays as two question marks. The output is
+   --  on a single line but has no line return after it. This procedure is
+   --  useful only if operating in backend layout mode.
+
+   procedure lgx (U : Node_Ref_Or_Val);
+   --  In backend layout mode, this is like List_GCC_Expression, but
+   --  includes a line return at the end. If operating in front end
+   --  layout mode, then the name of the entity for the size (either
+   --  a function of a variable) is listed followed by a line return.
+
+end Repinfo;

gcc/ada/repinfo.h

@@ -0,0 +1,79 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                              R E P I N F O                               *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                             $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1999-2001 Free Software Foundation, Inc.          *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file corresponds to the Ada file repinfo.ads.  */
+
+typedef Uint Node_Ref;
+typedef Uint Node_Ref_Or_Val;
+typedef char TCode;
+
+/* These are the values of TCcode that correspond to tree codes in tree.def,
+   except for the first, which is how we encode discriminants.  */
+
+#define Discrim_Val       0
+#define Cond_Expr         1
+#define Plus_Expr         2
+#define Minus_Expr        3
+#define Mult_Expr         4
+#define Trunc_Div_Expr    5
+#define Ceil_Div_Expr     6
+#define Floor_Div_Expr    7
+#define Trunc_Mod_Expr    8
+#define Ceil_Mod_Expr     9
+#define Floor_Mod_Expr   10
+#define Exact_Div_Expr   11
+#define Negate_Expr      12
+#define Min_Expr         13
+#define Max_Expr         14
+#define Abs_Expr         15
+#define Truth_Andif_Expr 16
+#define Truth_Orif_Expr  17
+#define Truth_And_Expr   18
+#define Truth_Or_Expr    19
+#define Truth_Xor_Expr   20
+#define Truth_Not_Expr   21
+#define Lt_Expr          22
+#define Le_Expr          23
+#define Gt_Expr          24
+#define Ge_Expr          25
+#define Eq_Expr          26
+#define Ne_Expr          27
+
+/* Creates a node using the tree code defined by Expr and from 1-3
+   operands as required (unused operands set as shown to No_Uint) Note
+   that this call can be used to create a discriminant reference by
+   using (Expr => Discrim_Val, Op1 => discriminant_number).  */
+#define Create_Node repinfo__create_node
+extern Node_Ref Create_Node	PARAMS((TCode, Node_Ref_Or_Val,
+					Node_Ref_Or_Val, Node_Ref_Or_Val));

gcc/ada/restrict.adb

@@ -0,0 +1,458 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             R E S T R I C T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.37 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Stand;    use Stand;
+with Uname;    use Uname;
+
+package body Restrict is
+
+   function Suppress_Restriction_Message (N : Node_Id) return Boolean;
+   --  N is the node for a possible restriction violation message, but
+   --  the message is to be suppressed if this is an internal file and
+   --  this file is not the main unit.
+
+   -------------------
+   -- Abort_Allowed --
+   -------------------
+
+   function Abort_Allowed return Boolean is
+   begin
+      return
+        Restrictions (No_Abort_Statements) = False
+          or else
+        Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
+   end Abort_Allowed;
+
+   ------------------------------------
+   -- Check_Elaboration_Code_Allowed --
+   ------------------------------------
+
+   procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
+   begin
+      --  Avoid calling Namet.Unlock/Lock except when there is an error.
+      --  Even in the error case it is a bit dubious, either gigi needs
+      --  the table locked or it does not! ???
+
+      if Restrictions (No_Elaboration_Code)
+        and then not Suppress_Restriction_Message (N)
+      then
+         Namet.Unlock;
+         Check_Restriction (No_Elaboration_Code, N);
+         Namet.Lock;
+      end if;
+   end Check_Elaboration_Code_Allowed;
+
+   ---------------------------
+   -- Check_Restricted_Unit --
+   ---------------------------
+
+   procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
+   begin
+      if Suppress_Restriction_Message (N) then
+         return;
+
+      elsif Is_Spec_Name (U) then
+         declare
+            Fnam : constant File_Name_Type :=
+                     Get_File_Name (U, Subunit => False);
+            R_Id : Restriction_Id;
+
+         begin
+            if not Is_Predefined_File_Name (Fnam) then
+               return;
+
+            --  Ada child unit spec, needs checking against list
+
+            else
+               --  Pad name to 8 characters with blanks
+
+               Get_Name_String (Fnam);
+               Name_Len := Name_Len - 4;
+
+               while Name_Len < 8 loop
+                  Name_Len := Name_Len + 1;
+                  Name_Buffer (Name_Len) := ' ';
+               end loop;
+
+               for J in Unit_Array'Range loop
+                  if Name_Len = 8
+                    and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
+                  then
+                     R_Id := Unit_Array (J).Res_Id;
+                     Violations (R_Id) := True;
+
+                     if Restrictions (R_Id) then
+                        declare
+                           S : constant String := Restriction_Id'Image (R_Id);
+
+                        begin
+                           Error_Msg_Unit_1 := U;
+
+                           Error_Msg_N
+                             ("dependence on $ not allowed,", N);
+
+                           Name_Buffer (1 .. S'Last) := S;
+                           Name_Len := S'Length;
+                           Set_Casing (All_Lower_Case);
+                           Error_Msg_Name_1 := Name_Enter;
+                           Error_Msg_Sloc := Restrictions_Loc (R_Id);
+
+                           Error_Msg_N
+                             ("\violates pragma Restriction (%) #", N);
+                           return;
+                        end;
+                     end if;
+                  end if;
+               end loop;
+            end if;
+         end;
+      end if;
+   end Check_Restricted_Unit;
+
+   -----------------------
+   -- Check_Restriction --
+   -----------------------
+
+   --  Case of simple identifier (no parameter)
+
+   procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
+   begin
+      Violations (R) := True;
+
+      if Restrictions (R)
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            S : constant String := Restriction_Id'Image (R);
+
+         begin
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restrictions_Loc (R);
+            Error_Msg_N ("violation of restriction %#", N);
+         end;
+      end if;
+   end Check_Restriction;
+
+   --  Case where a parameter is present (but no count)
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      N : Node_Id)
+   is
+   begin
+      if Restriction_Parameters (R) = Uint_0
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            S   : constant String :=
+                    Restriction_Parameter_Id'Image (R);
+
+         begin
+            Error_Msg_NE
+              ("& will be raised at run time?!", N, Standard_Storage_Error);
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restriction_Parameters_Loc (R);
+            Error_Msg_N ("violation of restriction %?#!", N);
+
+            Insert_Action (N,
+              Make_Raise_Storage_Error (Loc));
+         end;
+      end if;
+   end Check_Restriction;
+
+   --  Case where a parameter is present, with a count
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      V : Uint;
+      N : Node_Id)
+   is
+   begin
+      if Restriction_Parameters (R) /= No_Uint
+        and then V > Restriction_Parameters (R)
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            S : constant String := Restriction_Parameter_Id'Image (R);
+
+         begin
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restriction_Parameters_Loc (R);
+            Error_Msg_N ("maximum value exceeded for restriction %#", N);
+         end;
+      end if;
+   end Check_Restriction;
+
+   -------------------------------------------
+   -- Compilation_Unit_Restrictions_Restore --
+   -------------------------------------------
+
+   procedure Compilation_Unit_Restrictions_Restore
+     (R : Save_Compilation_Unit_Restrictions)
+   is
+   begin
+      for J in Compilation_Unit_Restrictions loop
+         Restrictions (J) := R (J);
+      end loop;
+   end Compilation_Unit_Restrictions_Restore;
+
+   ----------------------------------------
+   -- Compilation_Unit_Restrictions_Save --
+   ----------------------------------------
+
+   function Compilation_Unit_Restrictions_Save
+     return Save_Compilation_Unit_Restrictions
+   is
+      R : Save_Compilation_Unit_Restrictions;
+
+   begin
+      for J in Compilation_Unit_Restrictions loop
+         R (J) := Restrictions (J);
+         Restrictions (J) := False;
+      end loop;
+
+      return R;
+   end Compilation_Unit_Restrictions_Save;
+
+   ----------------------------------
+   -- Disallow_In_No_Run_Time_Mode --
+   ----------------------------------
+
+   procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
+   begin
+      if No_Run_Time then
+         Error_Msg_N
+           ("this construct not allowed in No_Run_Time mode", Enode);
+      end if;
+   end Disallow_In_No_Run_Time_Mode;
+
+   ------------------------
+   -- Get_Restriction_Id --
+   ------------------------
+
+   function Get_Restriction_Id
+     (N    : Name_Id)
+      return Restriction_Id
+   is
+      J : Restriction_Id;
+
+   begin
+      Get_Name_String (N);
+      Set_Casing (All_Upper_Case);
+
+      J := Restriction_Id'First;
+      while J /= Not_A_Restriction_Id loop
+         declare
+            S : constant String := Restriction_Id'Image (J);
+
+         begin
+            exit when S = Name_Buffer (1 .. Name_Len);
+         end;
+
+         J := Restriction_Id'Succ (J);
+      end loop;
+
+      return J;
+   end Get_Restriction_Id;
+
+   ----------------------------------
+   -- Get_Restriction_Parameter_Id --
+   ----------------------------------
+
+   function Get_Restriction_Parameter_Id
+     (N    : Name_Id)
+      return Restriction_Parameter_Id
+   is
+      J : Restriction_Parameter_Id;
+
+   begin
+      Get_Name_String (N);
+      Set_Casing (All_Upper_Case);
+
+      J := Restriction_Parameter_Id'First;
+      while J /= Not_A_Restriction_Parameter_Id loop
+         declare
+            S : constant String := Restriction_Parameter_Id'Image (J);
+
+         begin
+            exit when S = Name_Buffer (1 .. Name_Len);
+         end;
+
+         J := Restriction_Parameter_Id'Succ (J);
+      end loop;
+
+      return J;
+   end Get_Restriction_Parameter_Id;
+
+   -------------------------------
+   -- No_Exception_Handlers_Set --
+   -------------------------------
+
+   function No_Exception_Handlers_Set return Boolean is
+   begin
+      return Restrictions (No_Exception_Handlers);
+   end No_Exception_Handlers_Set;
+
+   ------------------------
+   -- Restricted_Profile --
+   ------------------------
+
+   --  This implementation must be coordinated with Set_Restricted_Profile
+
+   function Restricted_Profile return Boolean is
+   begin
+      return     Restrictions (No_Abort_Statements)
+        and then Restrictions (No_Asynchronous_Control)
+        and then Restrictions (No_Entry_Queue)
+        and then Restrictions (No_Task_Hierarchy)
+        and then Restrictions (No_Task_Allocators)
+        and then Restrictions (No_Dynamic_Priorities)
+        and then Restrictions (No_Terminate_Alternatives)
+        and then Restrictions (No_Dynamic_Interrupts)
+        and then Restrictions (No_Protected_Type_Allocators)
+        and then Restrictions (No_Local_Protected_Objects)
+        and then Restrictions (No_Requeue)
+        and then Restrictions (No_Task_Attributes)
+        and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) =  0
+        and then Restriction_Parameters (Max_Task_Entries)                =  0
+        and then Restriction_Parameters (Max_Protected_Entries)           <= 1
+        and then Restriction_Parameters (Max_Select_Alternatives)         =  0;
+   end Restricted_Profile;
+
+   --------------------------
+   -- Set_No_Run_Time_Mode --
+   --------------------------
+
+   procedure Set_No_Run_Time_Mode is
+   begin
+      No_Run_Time := True;
+      Restrictions (No_Exception_Handlers) := True;
+   end Set_No_Run_Time_Mode;
+
+   -------------------
+   -- Set_Ravenscar --
+   -------------------
+
+   procedure Set_Ravenscar is
+   begin
+      Set_Restricted_Profile;
+      Restrictions (Boolean_Entry_Barriers)       := True;
+      Restrictions (No_Select_Statements)         := True;
+      Restrictions (No_Calendar)                  := True;
+      Restrictions (Static_Storage_Size)          := True;
+      Restrictions (No_Entry_Queue)               := True;
+      Restrictions (No_Relative_Delay)            := True;
+      Restrictions (No_Task_Termination)          := True;
+      Restrictions (No_Implicit_Heap_Allocations) := True;
+   end Set_Ravenscar;
+
+   ----------------------------
+   -- Set_Restricted_Profile --
+   ----------------------------
+
+   --  This must be coordinated with Restricted_Profile
+
+   procedure Set_Restricted_Profile is
+   begin
+      Restrictions (No_Abort_Statements)          := True;
+      Restrictions (No_Asynchronous_Control)      := True;
+      Restrictions (No_Entry_Queue)               := True;
+      Restrictions (No_Task_Hierarchy)            := True;
+      Restrictions (No_Task_Allocators)           := True;
+      Restrictions (No_Dynamic_Priorities)        := True;
+      Restrictions (No_Terminate_Alternatives)    := True;
+      Restrictions (No_Dynamic_Interrupts)        := True;
+      Restrictions (No_Protected_Type_Allocators) := True;
+      Restrictions (No_Local_Protected_Objects)   := True;
+      Restrictions (No_Requeue)                   := True;
+      Restrictions (No_Task_Attributes)           := True;
+
+      Restriction_Parameters (Max_Asynchronous_Select_Nesting) :=  Uint_0;
+      Restriction_Parameters (Max_Task_Entries)                :=  Uint_0;
+      Restriction_Parameters (Max_Select_Alternatives)         :=  Uint_0;
+
+      if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
+         Restriction_Parameters (Max_Protected_Entries) := Uint_1;
+      end if;
+   end Set_Restricted_Profile;
+
+   ----------------------------------
+   -- Suppress_Restriction_Message --
+   ----------------------------------
+
+   function Suppress_Restriction_Message (N : Node_Id) return Boolean is
+   begin
+      --  If main unit is library unit, then we will output message
+
+      if In_Extended_Main_Source_Unit (N) then
+         return False;
+
+      --  If loaded by rtsfind, then suppress message
+
+      elsif Sloc (N) <= No_Location then
+         return True;
+
+      --  Otherwise suppress message if internal file
+
+      else
+         return
+           Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
+      end if;
+   end Suppress_Restriction_Message;
+
+   ---------------------
+   -- Tasking_Allowed --
+   ---------------------
+
+   function Tasking_Allowed return Boolean is
+   begin
+      return
+        Restriction_Parameters (Max_Tasks) /= 0;
+   end Tasking_Allowed;
+
+end Restrict;

gcc/ada/restrict.ads

@@ -0,0 +1,253 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             R E S T R I C T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.27 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package deals with the implementation of the Restrictions pragma
+
+with Rident;
+with Types;  use Types;
+with Uintp;  use Uintp;
+
+package Restrict is
+
+   type Restriction_Id is new Rident.Restriction_Id;
+   --  The type Restriction_Id defines the set of restriction identifiers,
+   --  which take no parameter (i.e. they are either present or not present).
+   --  The actual definition is in the separate package Rident, so that it
+   --  can easily be accessed by the binder without dragging in lots of stuff.
+
+   subtype Partition_Restrictions is
+     Restriction_Id range
+       Restriction_Id (Rident.Partition_Restrictions'First) ..
+       Restriction_Id (Rident.Partition_Restrictions'Last);
+   --  Range of restriction identifiers that are checked by the binder
+
+   subtype Compilation_Unit_Restrictions is
+     Restriction_Id range
+       Restriction_Id (Rident.Compilation_Unit_Restrictions'First) ..
+       Restriction_Id (Rident.Compilation_Unit_Restrictions'Last);
+   --  Range of restriction identifiers not checked by binder
+
+   type Restriction_Parameter_Id is new Rident.Restriction_Parameter_Id;
+   --  The type Restriction_Parameter_Id records cases where a parameter is
+   --  present in the corresponding pragma. These cases are not checked for
+   --  consistency by the binder. The actual definition is in the separate
+   --  package Rident for consistency.
+
+   type Restrictions_Flags is array (Restriction_Id) of Boolean;
+   --  Type used for arrays indexed by Restriction_Id.
+
+   Restrictions : Restrictions_Flags := (others => False);
+   --  Corresponding entry is False if restriction is not active, and
+   --  True if the restriction is active, i.e. if a pragma Restrictions
+   --  has been seen anywhere. Note that we are happy to pick up any
+   --  restrictions pragmas in with'ed units, since we are required to
+   --  be consistent at link time, and we might as well find the error
+   --  at compile time. Clients must NOT use this array for checking to
+   --  see if a restriction is violated, instead it is required that the
+   --  Check_Restrictions subprograms be used for this purpose. The only
+   --  legitimate direct use of this array is when the code is modified
+   --  as a result of the restriction in some way.
+
+   Restrictions_Loc : array (Restriction_Id) of Source_Ptr;
+   --  Locations of Restrictions pragmas for error message purposes.
+   --  Valid only if corresponding entry in Restrictions is set.
+
+   Main_Restrictions : Restrictions_Flags := (others => False);
+   --  This variable saves the cumulative restrictions in effect compiling
+   --  any unit that is part of the extended main unit (i.e. the compiled
+   --  unit, its spec if any, and its subunits if any). The reason we keep
+   --  track of this is for the information that goes to the binder about
+   --  restrictions that are set. The binder will identify a unit that has
+   --  a restrictions pragma for error message purposes, and we do not want
+   --  to pick up a restrictions pragma in a with'ed unit for this purpose.
+
+   Violations : Restrictions_Flags := (others => False);
+   --  Corresponding entry is False if the restriction has not been
+   --  violated in the current main unit, and True if it has been violated.
+
+   Restriction_Parameters :
+     array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
+   --  This array indicates the setting of restriction parameter identifier
+   --  values. All values are initially set to No_Uint indicating that the
+   --  parameter is not set, and are set to the appropriate non-negative
+   --  value if a Restrictions pragma specifies the corresponding
+   --  restriction parameter identifier with an appropriate value.
+
+   Restriction_Parameters_Loc :
+     array (Restriction_Parameter_Id) of Source_Ptr;
+   --  Locations of Restrictions pragmas for error message purposes.
+   --  Valid only if corresponding entry in Restriction_Parameters is
+   --  set to a value other than No_Uint.
+
+   type Unit_Entry is record
+      Res_Id : Restriction_Id;
+      Filenm : String (1 .. 8);
+   end record;
+
+   type Unit_Array_Type is array (Positive range <>) of Unit_Entry;
+
+   Unit_Array : constant Unit_Array_Type := (
+     (No_Asynchronous_Control,    "a-astaco"),
+     (No_Calendar,                "a-calend"),
+     (No_Calendar,                "calendar"),
+     (No_Delay,                   "a-calend"),
+     (No_Delay,                   "calendar"),
+     (No_Dynamic_Priorities,      "a-dynpri"),
+     (No_IO,                      "a-direio"),
+     (No_IO,                      "directio"),
+     (No_IO,                      "a-sequio"),
+     (No_IO,                      "sequenio"),
+     (No_IO,                      "a-ststio"),
+     (No_IO,                      "a-textio"),
+     (No_IO,                      "text_io "),
+     (No_IO,                      "a-witeio"),
+     (No_Task_Attributes,         "a-tasatt"),
+     (No_Streams,                 "a-stream"),
+     (No_Unchecked_Conversion,    "a-unccon"),
+     (No_Unchecked_Conversion,    "unchconv"),
+     (No_Unchecked_Deallocation,  "a-uncdea"),
+     (No_Unchecked_Deallocation,  "unchdeal"));
+   --  This array defines the mapping between restriction identifiers and
+   --  predefined language files containing units for which the identifier
+   --  forbids semantic dependence.
+
+   type Save_Compilation_Unit_Restrictions is private;
+   --  Type used for saving and restoring compilation unit restrictions.
+   --  See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id);
+   --  Checks if loading of unit U is prohibited by the setting of some
+   --  restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO).
+   --  If a restriction exists post error message at the given node.
+
+   procedure Check_Restriction (R : Restriction_Id; N : Node_Id);
+   --  Checks that the given restriction is not set, and if it is set, an
+   --  appropriate message is posted on the given node. Also records the
+   --  violation in the violations array. Note that it is mandatory to
+   --  always use this routine to check if a restriction is violated. Such
+   --  checks must never be done directly by the caller, since otherwise
+   --  they are not properly recorded in the violations array.
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      N : Node_Id);
+   --  Checks that the given restriction parameter identifier is not set to
+   --  zero. If it is set to zero, then the node N is replaced by a node
+   --  that raises Storage_Error, and a warning is issued.
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      V : Uint;
+      N : Node_Id);
+   --  Checks that the count in V does not exceed the maximum value of the
+   --  restriction parameter value corresponding to the given restriction
+   --  parameter identifier (if it has been set). If the count in V exceeds
+   --  the maximum, then post an error message on node N.
+
+   procedure Check_Elaboration_Code_Allowed (N : Node_Id);
+   --  Tests to see if elaboration code is allowed by the current restrictions
+   --  settings. This function is called by Gigi when it needs to define
+   --  an elaboration routine. If elaboration code is not allowed, an error
+   --  message is posted on the node given as argument.
+
+   function No_Exception_Handlers_Set return Boolean;
+   --  Test to see if current restrictions settings specify that no exception
+   --  handlers are present. This function is called by Gigi when it needs to
+   --  expand an AT END clean up identifier with no exception handler.
+
+   function Compilation_Unit_Restrictions_Save
+     return Save_Compilation_Unit_Restrictions;
+   --  This function saves the compilation unit restriction settings, and
+   --  resets them to False. This is used e.g. when compiling a with'ed
+   --  unit to avoid incorrectly propagating restrictions. Note that it
+   --  would not be wrong to also save and reset the partition restrictions,
+   --  since the binder would catch inconsistencies, but actually it is a
+   --  good thing to acquire restrictions from with'ed units if they are
+   --  required to be partition wide, because it allows the restriction
+   --  violation message to be given at compile time instead of link time.
+
+   procedure Compilation_Unit_Restrictions_Restore
+     (R : Save_Compilation_Unit_Restrictions);
+   --  This is the corresponding restore procedure to restore restrictions
+   --  previously saved by Compilation_Unit_Restrictions_Save.
+
+   procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id);
+   --  If in No_Run_Time mode, then the construct represented by Enode is
+   --  not permitted, and will be appropriately flagged.
+
+   procedure Set_No_Run_Time_Mode;
+   --  Set the no run time mode, and associated restriction pragmas.
+
+   function Get_Restriction_Id
+     (N    : Name_Id)
+      return Restriction_Id;
+   --  Given an identifier name, determines if it is a valid restriction
+   --  identifier, and if so returns the corresponding Restriction_Id
+   --  value, otherwise returns Not_A_Restriction_Id.
+
+   function Get_Restriction_Parameter_Id
+     (N    : Name_Id)
+      return Restriction_Parameter_Id;
+   --  Given an identifier name, determines if it is a valid restriction
+   --  parameter identifier, and if so returns the corresponding
+   --  Restriction_Parameter_Id value, otherwise returns
+   --  Not_A_Restriction_Parameter_Id.
+
+   function Abort_Allowed return Boolean;
+   pragma Inline (Abort_Allowed);
+   --  Tests to see if abort is allowed by the current restrictions settings.
+   --  For abort to be allowed, either No_Abort_Statements must be False,
+   --  or Max_Asynchronous_Select_Nesting must be non-zero.
+
+   function Restricted_Profile return Boolean;
+   --  Tests to see if tasking operations follow the GNAT restricted run time
+   --  profile.
+
+   procedure Set_Ravenscar;
+   --  Sets the set of rerstrictions fro Ravenscar
+
+   procedure Set_Restricted_Profile;
+   --  Sets the set of restrictions for pragma Restricted_Run_Time
+
+   function Tasking_Allowed return Boolean;
+   pragma Inline (Tasking_Allowed);
+   --  Tests to see if tasking operations are allowed by the current
+   --  restrictions settings. For tasking to be allowed Max_Tasks must
+   --  be non-zero.
+
+private
+   type Save_Compilation_Unit_Restrictions is
+     array (Compilation_Unit_Restrictions) of Boolean;
+   --  Type used for saving and restoring compilation unit restrictions.
+   --  See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
+
+end Restrict;

gcc/ada/rident.ads

@@ -0,0 +1,139 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               R I D E N T                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package defines the set of restriction identifiers. It is in a
+--  separate package from Restrict so that it can be easily used by the
+--  binder without dragging in a lot of stuff.
+
+package Rident is
+
+   --  The following enumeration type defines the set of restriction
+   --  identifiers not taking a parameter that are implemented in GNAT.
+   --  To add a new restriction identifier, add an entry with the name
+   --  to be used in the pragma, and add appropriate calls to the
+   --  Check_Restriction routine.
+
+   type Restriction_Id is (
+
+      --  The following cases are checked for consistency in the binder
+
+      Boolean_Entry_Barriers,                  -- GNAT (Ravenscar)
+      No_Abort_Statements,                     -- (RM D.7(5), H.4(3))
+      No_Access_Subprograms,                   -- (RM H.4(17))
+      No_Allocators,                           -- (RM H.4(7))
+      No_Asynchronous_Control,                 -- (RM D.9(10))
+      No_Calendar,                             -- GNAT
+      No_Delay,                                -- (RM H.4(21))
+      No_Dispatch,                             -- (RM H.4(19))
+      No_Dynamic_Interrupts,                   -- GNAT
+      No_Dynamic_Priorities,                   -- (RM D.9(9))
+      No_Enumeration_Maps,                     -- GNAT
+      No_Entry_Calls_In_Elaboration_Code,      -- GNAT
+      No_Entry_Queue,                          -- GNAT
+      No_Exception_Handlers,                   -- GNAT
+      No_Exceptions,                           -- (RM H.4(12))
+      No_Fixed_Point,                          -- (RM H.4(15))
+      No_Floating_Point,                       -- (RM H.4(14))
+      No_IO,                                   -- (RM H.4(20))
+      No_Implicit_Conditionals,                -- GNAT
+      No_Implicit_Dynamic_Code,                -- GNAT
+      No_Implicit_Heap_Allocations,            -- (RM D.8(8), H.4(3))
+      No_Implicit_Loops,                       -- GNAT
+      No_Local_Allocators,                     -- (RM H.4(8))
+      No_Local_Protected_Objects,              -- GNAT
+      No_Nested_Finalization,                  -- (RM D.7(4))
+      No_Protected_Type_Allocators,            -- GNAT
+      No_Protected_Types,                      -- (RM H.4(5))
+      No_Recursion,                            -- (RM H.4(22))
+      No_Reentrancy,                           -- (RM H.4(23))
+      No_Relative_Delay,                       -- GNAT
+      No_Requeue,                              -- GNAT
+      No_Select_Statements,                    -- GNAT (Ravenscar)
+      No_Standard_Storage_Pools,               -- GNAT
+      No_Streams,                              -- GNAT
+      No_Task_Allocators,                      -- (RM D.7(7))
+      No_Task_Attributes,                      -- GNAT
+      No_Task_Hierarchy,                       -- (RM D.7(3), H.4(3))
+      No_Task_Termination,                     -- GNAT
+      No_Terminate_Alternatives,               -- (RM D.7(6))
+      No_Unchecked_Access,                     -- (RM H.4(18))
+      No_Unchecked_Conversion,                 -- (RM H.4(16))
+      No_Unchecked_Deallocation,               -- (RM H.4(9))
+      No_Wide_Characters,                      -- GNAT
+      Static_Priorities,                       -- GNAT
+      Static_Storage_Size,                     -- GNAT
+
+      --  The following cases do not require partition-wide checks
+
+      Immediate_Reclamation,                   -- (RM H.4(10))
+      No_Implementation_Attributes,            -- GNAT
+      No_Implementation_Pragmas,               -- GNAT
+      No_Implementation_Restrictions,          -- GNAT
+      No_Elaboration_Code,                     -- GNAT
+
+      Not_A_Restriction_Id);
+
+   --  The following range of Restriction identifiers is checked for
+   --  consistency across a partition. The generated ali file is marked
+   --  for each entry to show one of three possibilities:
+   --
+   --    Corresponding restriction is set (so unit does not violate it)
+   --    Corresponding restriction is not violated
+   --    Corresponding restriction is violated
+
+   subtype Partition_Restrictions is
+     Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size;
+
+   --  The following set of Restriction identifiers is not checked for
+   --  consistency across a partition, and the generated ali files does
+   --  not carry any indications with respect to such restrictions.
+
+   subtype Compilation_Unit_Restrictions is
+     Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code;
+
+   --  The following enumeration type defines the set of restriction
+   --  parameter identifiers taking a parameter that are implemented in
+   --  GNAT. To add a new restriction parameter identifier, add an entry
+   --  with the name to be used in the pragma, and add appropriate
+   --  calls to Check_Restriction.
+
+   --  Note: the GNAT implementation currently only accomodates restriction
+   --  parameter identifiers whose expression value is a non-negative
+   --  integer. This is true for all language defined parameters.
+
+   type Restriction_Parameter_Id is (
+     Max_Asynchronous_Select_Nesting,         -- (RM D.7(18), H.4(3))
+     Max_Entry_Queue_Depth,                   -- GNAT
+     Max_Protected_Entries,                   -- (RM D.7(14))
+     Max_Select_Alternatives,                 -- (RM D.7(12))
+     Max_Storage_At_Blocking,                 -- (RM D.7(17))
+     Max_Task_Entries,                        -- (RM D.7(13), H.4(3))
+     Max_Tasks,                               -- (RM D.7(19), H.4(3))
+     Not_A_Restriction_Parameter_Id);
+
+end Rident;

gcc/ada/rtsfind.adb

@@ -0,0 +1,913 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R T S F I N D                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.96 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Csets;    use Csets;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Output;   use Output;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Sem;      use Sem;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+with Snames;   use Snames;
+with Tbuild;   use Tbuild;
+with Uname;    use Uname;
+
+package body Rtsfind is
+
+   ----------------
+   -- Unit table --
+   ----------------
+
+   --  The unit table has one entry for each unit included in the definition
+   --  of the type RTU_Id in the spec. The table entries are initialized in
+   --  Initialize to set the Entity field to Empty, indicating that the
+   --  corresponding unit has not yet been loaded. The fields are set when
+   --  a unit is loaded to contain the defining entity for the unit, the
+   --  unit name, and the unit number.
+
+   type RT_Unit_Table_Record is record
+      Entity : Entity_Id;
+      Uname  : Unit_Name_Type;
+      Unum   : Unit_Number_Type;
+      Withed : Boolean;
+   end record;
+
+   RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
+
+   --------------------------
+   -- Runtime Entity Table --
+   --------------------------
+
+   --  There is one entry in the runtime entity table for each entity that is
+   --  included in the definition of the RE_Id type in the spec. The entries
+   --  are set by Initialize_Rtsfind to contain Empty, indicating that the
+   --  entity has not yet been located. Once the entity is located for the
+   --  first time, its ID is stored in this array, so that subsequent calls
+   --  for the same entity can be satisfied immediately.
+
+   RE_Table : array (RE_Id) of Entity_Id;
+
+   --------------------------
+   -- Generation of WITH's --
+   --------------------------
+
+   --  When a unit is implicitly loaded as a result of a call to RTE, it
+   --  is necessary to create an implicit with to ensure that the object
+   --  is correctly loaded by the binder. Such with statements are only
+   --  required when the request is from the extended main unit (if a
+   --  client needs a with, that will be taken care of when the client
+   --  is compiled.
+
+   --  We always attach the with to the main unit. This is not perfectly
+   --  accurate in terms of elaboration requirements, but it is close
+   --  enough, since the units that are accessed using rtsfind do not
+   --  have delicate elaboration requirements.
+
+   --  The flag Withed in the unit table record is initially set to False.
+   --  It is set True if a with has been generated for the main unit for
+   --  the corresponding unit.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "");
+   --  Internal procedure called if we can't find the entity or unit.
+   --  The parameter is a detailed error message that is to be given.
+   --  S is a reason for failing to compile the file. U_Id is the unit
+   --  id, and Ent_Name, if non-null, is the associated entity name.
+
+   function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
+   --  Retrieves the Unit Name given a unit id represented by its
+   --  enumaration value in RTU_Id.
+
+   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False);
+   --  Load the unit whose Id is given if not already loaded. The unit is
+   --  loaded, analyzed, and added to the with list, and the entry in
+   --  RT_Unit_Table is updated to reflect the load. The second parameter
+   --  indicates the initial setting for the Is_Potentially_Use_Visible
+   --  flag of the entity for the loaded unit (if it is indeed loaded).
+   --  A value of False means nothing special need be done. A value of
+   --  True indicates that this flag must be set to True. It is needed
+   --  only in the Text_IO_Kludge procedure, which may materialize an
+   --  entity of Text_IO (or Wide_Text_IO) that was previously unknown.
+
+   function RE_Chars (E : RE_Id) return Name_Id;
+   --  Given a RE_Id value returns the Chars of the corresponding entity.
+
+   -------------------
+   -- Get_Unit_Name --
+   -------------------
+
+   function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is
+      Uname_Chars : constant String := RTU_Id'Image (U_Id);
+
+   begin
+      Name_Len := Uname_Chars'Length;
+      Name_Buffer (1 .. Name_Len) := Uname_Chars;
+      Set_Casing (All_Lower_Case);
+
+      if U_Id in Ada_Child then
+         Name_Buffer (4) := '.';
+
+         if U_Id in Ada_Calendar_Child then
+            Name_Buffer (13) := '.';
+
+         elsif U_Id in Ada_Finalization_Child then
+            Name_Buffer (17) := '.';
+
+         elsif U_Id in Ada_Real_Time_Child then
+            Name_Buffer (14) := '.';
+
+         elsif U_Id in Ada_Streams_Child then
+            Name_Buffer (12) := '.';
+
+         elsif U_Id in Ada_Text_IO_Child then
+            Name_Buffer (12) := '.';
+
+         elsif U_Id in Ada_Wide_Text_IO_Child then
+            Name_Buffer (17) := '.';
+         end if;
+
+      elsif U_Id in Interfaces_Child then
+         Name_Buffer (11) := '.';
+
+      elsif U_Id in System_Child then
+         Name_Buffer (7) := '.';
+
+         if U_Id in System_Tasking_Child then
+            Name_Buffer (15) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Restricted_Child then
+            Name_Buffer (26) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Protected_Objects_Child then
+            Name_Buffer (33) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Async_Delays_Child then
+            Name_Buffer (28) := '.';
+         end if;
+      end if;
+
+      --  Add %s at end for spec
+
+      Name_Buffer (Name_Len + 1) := '%';
+      Name_Buffer (Name_Len + 2) := 's';
+      Name_Len := Name_Len + 2;
+
+      return Name_Find;
+   end Get_Unit_Name;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      --  Initialize the unit table
+
+      for J in RTU_Id loop
+         RT_Unit_Table (J).Entity := Empty;
+      end loop;
+
+      for J in RE_Id loop
+         RE_Table (J) := Empty;
+      end loop;
+   end Initialize;
+
+   ------------
+   -- Is_RTE --
+   ------------
+
+   function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is
+      E_Unit_Name   : Unit_Name_Type;
+      Ent_Unit_Name : Unit_Name_Type;
+
+      S  : Entity_Id;
+      E1 : Entity_Id;
+      E2 : Entity_Id;
+
+   begin
+      if No (Ent) then
+         return False;
+
+      --  If E has already a corresponding entity, check it directly,
+      --  going to full views if they exist to deal with the incomplete
+      --  and private type cases properly.
+
+      elsif Present (RE_Table (E)) then
+         E1 := Ent;
+
+         if Is_Type (E1) and then Present (Full_View (E1)) then
+            E1 := Full_View (E1);
+         end if;
+
+         E2 := RE_Table (E);
+
+         if Is_Type (E2) and then Present (Full_View (E2)) then
+            E2 := Full_View (E2);
+         end if;
+
+         return E1 = E2;
+      end if;
+
+      --  If the unit containing E is not loaded, we already know that
+      --  the entity we have cannot have come from this unit.
+
+      E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E));
+
+      if not Is_Loaded (E_Unit_Name) then
+         return False;
+      end if;
+
+      --  Here the unit containing the entity is loaded. We have not made
+      --  an explicit call to RTE to get the entity in question, but we may
+      --  have obtained a reference to it indirectly from some other entity
+      --  in the same unit, or some other unit that references it.
+
+      --  Get the defining unit of the entity
+
+      S := Scope (Ent);
+
+      if Ekind (S) /= E_Package then
+         return False;
+      end if;
+
+      Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S));
+
+      --  If the defining unit of the entity we are testing is not the
+      --  unit containing E, then they cannot possibly match.
+
+      if Ent_Unit_Name /= E_Unit_Name then
+         return False;
+      end if;
+
+      --  If the units match, then compare the names (remember that no
+      --  overloading is permitted in entities fetched using Rtsfind).
+
+      if RE_Chars (E) = Chars (Ent) then
+         RE_Table (E) := Ent;
+
+         --  If front-end inlining is enabled, we may be within a body that
+         --  contains inlined functions, which has not been retrieved through
+         --  rtsfind, and therefore is not yet recorded in the RT_Unit_Table.
+         --  Add the unit information now, it must be fully available.
+
+         declare
+            U : RT_Unit_Table_Record
+                  renames  RT_Unit_Table (RE_Unit_Table (E));
+         begin
+            if No (U.Entity) then
+               U.Entity := S;
+               U.Uname  := E_Unit_Name;
+               U.Unum   := Get_Source_Unit (S);
+            end if;
+         end;
+
+         return True;
+      else
+         return False;
+      end if;
+   end Is_RTE;
+
+   ----------------------------
+   -- Is_Text_IO_Kludge_Unit --
+   ----------------------------
+
+   function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is
+      Prf : Node_Id;
+      Sel : Node_Id;
+
+   begin
+      if Nkind (Nam) /= N_Expanded_Name then
+         return False;
+      end if;
+
+      Prf := Prefix (Nam);
+      Sel := Selector_Name (Nam);
+
+      if Nkind (Sel) /= N_Expanded_Name
+        or else Nkind (Prf) /= N_Identifier
+        or else Chars (Prf) /= Name_Ada
+      then
+         return False;
+      end if;
+
+      Prf := Prefix (Sel);
+      Sel := Selector_Name (Sel);
+
+      return
+        Nkind (Prf) = N_Identifier
+          and then
+        (Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO)
+          and then
+        Nkind (Sel) = N_Identifier
+          and then
+        Chars (Sel) in Text_IO_Package_Name;
+
+   end Is_Text_IO_Kludge_Unit;
+
+   ---------------
+   -- Load_Fail --
+   ---------------
+
+   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is
+   begin
+      Set_Standard_Error;
+
+      Write_Str ("fatal error: run-time library configuration error");
+      Write_Eol;
+
+      if Ent_Name /= "" then
+         Write_Str ("cannot locate """);
+
+         --  Copy name skipping initial RE_ or RO_XX characters
+
+         if Ent_Name (1 .. 2) = "RE" then
+            for J in 4 .. Ent_Name'Length loop
+               Name_Buffer (J - 3) := Ent_Name (J);
+            end loop;
+         else
+            for J in 7 .. Ent_Name'Length loop
+               Name_Buffer (J - 6) := Ent_Name (J);
+            end loop;
+         end if;
+
+         Name_Len := Ent_Name'Length - 3;
+         Set_Casing (Mixed_Case);
+         Write_Str (Name_Buffer (1 .. Name_Len));
+         Write_Str (""" in file """);
+
+      else
+         Write_Str ("cannot load file """);
+      end if;
+
+      Write_Name
+        (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
+      Write_Str (""" (");
+      Write_Str (S);
+      Write_Char (')');
+      Write_Eol;
+      Set_Standard_Output;
+      raise Unrecoverable_Error;
+   end Load_Fail;
+
+   --------------
+   -- Load_RTU --
+   --------------
+
+   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is
+      Loaded   : Boolean;
+      U        : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+      Priv_Par : Elist_Id := New_Elmt_List;
+      Lib_Unit : Node_Id;
+
+      procedure Save_Private_Visibility;
+      --  If the current unit is the body of child unit or the spec of a
+      --  private child unit, the private declarations of the parent (s)
+      --  are visible. If the unit to be loaded is another public sibling,
+      --  its compilation will affect the visibility of the common ancestors.
+      --  Indicate those that must be restored.
+
+      procedure Restore_Private_Visibility;
+      --  Restore the visibility of ancestors after compiling RTU.
+
+      --------------------------------
+      -- Restore_Private_Visibility --
+      --------------------------------
+
+      procedure Restore_Private_Visibility is
+         E_Par : Elmt_Id;
+
+      begin
+         E_Par := First_Elmt (Priv_Par);
+
+         while Present (E_Par) loop
+            if not In_Private_Part (Node (E_Par)) then
+               Install_Private_Declarations (Node (E_Par));
+            end if;
+
+            Next_Elmt (E_Par);
+         end loop;
+      end Restore_Private_Visibility;
+
+      -----------------------------
+      -- Save_Private_Visibility --
+      -----------------------------
+
+      procedure Save_Private_Visibility is
+         Par : Entity_Id;
+
+      begin
+         Par := Scope (Current_Scope);
+
+         while Present (Par)
+           and then Par /= Standard_Standard
+         loop
+            if Ekind (Par) = E_Package
+              and then Is_Compilation_Unit (Par)
+              and then In_Private_Part (Par)
+            then
+               Append_Elmt (Par, Priv_Par);
+            end if;
+
+            Par := Scope (Par);
+         end loop;
+      end Save_Private_Visibility;
+
+   --  Start of processing for Load_RTU
+
+   begin
+      --  Nothing to do if unit is already loaded
+
+      if Present (U.Entity) then
+         return;
+      end if;
+
+      --  Otherwise we need to load the unit, First build unit name
+      --  from the enumeration literal name in type RTU_Id.
+
+      U.Uname  := Get_Unit_Name (U_Id);
+      U.Withed := False;
+      Loaded   := Is_Loaded (U.Uname);
+
+      --  Now do the load call, note that setting Error_Node to Empty is
+      --  a signal to Load_Unit that we will regard a failure to find the
+      --  file as a fatal error, and that it should not output any kind
+      --  of diagnostics, since we will take care of it here.
+
+      U.Unum :=
+        Load_Unit
+          (Load_Name  => U.Uname,
+           Required   => False,
+           Subunit    => False,
+           Error_Node => Empty);
+
+      if U.Unum = No_Unit then
+         Load_Fail ("unit not found", U_Id);
+
+      elsif Fatal_Error (U.Unum) then
+         Load_Fail ("parser errors", U_Id);
+      end if;
+
+      --  Make sure that the unit is analyzed
+
+      declare
+         Was_Analyzed : Boolean := Analyzed (Cunit (Current_Sem_Unit));
+
+      begin
+         --  Pretend that the current unit is analysed, in case it is
+         --  System or some such. This allows us to put some declarations,
+         --  such as exceptions and packed arrays of Boolean, into System
+         --  even though expanding them requires System...
+
+         --  This is a bit odd but works fine. If the RTS unit does not depend
+         --  in any way on the current unit, then it never gets back into the
+         --  current unit's tree, and the change we make to the current unit
+         --  tree is never noticed by anyone (it is undone in a moment). That
+         --  is the normal situation.
+
+         --  If the RTS Unit *does* depend on the current unit, for instance,
+         --  when you are compiling System, then you had better have finished
+         --  Analyzing the part of System that is depended on before you try
+         --  to load the RTS Unit. This means having the System ordered in an
+         --  appropriate manner.
+
+         Set_Analyzed (Cunit (Current_Sem_Unit), True);
+
+         if not Analyzed (Cunit (U.Unum)) then
+
+            Save_Private_Visibility;
+            Semantics (Cunit (U.Unum));
+            Restore_Private_Visibility;
+
+            if Fatal_Error (U.Unum) then
+               Load_Fail ("semantic errors", U_Id);
+            end if;
+         end if;
+
+         --  Undo the pretence
+
+         Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed);
+      end;
+
+      Lib_Unit := Unit (Cunit (U.Unum));
+      U.Entity := Defining_Entity (Lib_Unit);
+
+      if Use_Setting then
+         Set_Is_Potentially_Use_Visible (U.Entity, True);
+      end if;
+   end Load_RTU;
+
+   --------------
+   -- RE_Chars --
+   --------------
+
+   function RE_Chars (E : RE_Id) return Name_Id is
+      RE_Name_Chars : constant String := RE_Id'Image (E);
+
+   begin
+      --  Copy name skipping initial RE_ or RO_XX characters
+
+      if RE_Name_Chars (1 .. 2) = "RE" then
+         for J in 4 .. RE_Name_Chars'Last loop
+            Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J));
+         end loop;
+
+         Name_Len := RE_Name_Chars'Length - 3;
+
+      else
+         for J in 7 .. RE_Name_Chars'Last loop
+            Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J));
+         end loop;
+
+         Name_Len := RE_Name_Chars'Length - 6;
+      end if;
+
+      return Name_Find;
+   end RE_Chars;
+
+   ---------
+   -- RTE --
+   ---------
+
+   function RTE (E : RE_Id) return Entity_Id is
+      U_Id : constant RTU_Id := RE_Unit_Table (E);
+      U    : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+
+      Ent      : Entity_Id;
+      Lib_Unit : Node_Id;
+      Pkg_Ent  : Entity_Id;
+      Ename    : Name_Id;
+      Enode    : Node_Id;
+
+      procedure Check_RPC;
+      --  Reject programs that make use of distribution features not supported
+      --  on the current target. On such targets (VMS, Vxworks, others?) we
+      --  only provide a minimal body for System.Rpc that only supplies an
+      --  implementation of partition_id.
+
+      function Find_Local_Entity (E : RE_Id) return Entity_Id;
+      --  This function is used when entity E is in this compilation's main
+      --  unit. It gets the value from the already compiled declaration.
+
+      function Make_Unit_Name (N : Node_Id) return Node_Id;
+      --  If the unit is a child unit, build fully qualified name for use
+      --  in with_clause.
+
+      ---------------
+      -- Check_RPC --
+      ---------------
+
+      procedure Check_RPC is
+         Body_Name    : Unit_Name_Type;
+         Unum         : Unit_Number_Type;
+
+      begin
+         --  Bypass this check if debug flag -gnatdR set
+
+         if Debug_Flag_RR then
+            return;
+         end if;
+
+         --  Otherwise we need the check if we are going after one of
+         --  the critical entities in System.RPC in stubs mode.
+
+         if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
+                      or else
+                        Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+           and then (E = RE_Do_Rpc
+                       or else E = RE_Do_Apc
+                       or else E = RE_Params_Stream_Type
+                       or else E = RE_RPC_Receiver)
+         then
+            --  Load body of System.Rpc, and abort if this is the body that is
+            --  provided by GNAT, for which these features are not supported
+            --  on current target. We identify the gnat body by the presence
+            --  of a local entity called Gnat in the first declaration.
+
+            Lib_Unit := Unit (Cunit (U.Unum));
+            Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit));
+            Unum :=
+              Load_Unit
+                (Load_Name  => Body_Name,
+                 Required   => False,
+                 Subunit    => False,
+                 Error_Node => Empty,
+                 Renamings  => True);
+
+            if Unum /= No_Unit then
+               declare
+                  Decls : List_Id := Declarations (Unit (Cunit (Unum)));
+
+               begin
+                  if Present (Decls)
+                    and then Nkind (First (Decls)) = N_Object_Declaration
+                    and then
+                      Chars (Defining_Identifier (First (Decls))) = Name_Gnat
+                  then
+                     Set_Standard_Error;
+                     Write_Str ("distribution feature not supported");
+                     Write_Eol;
+                     raise Unrecoverable_Error;
+                  end if;
+               end;
+            end if;
+         end if;
+      end Check_RPC;
+
+      ------------------------
+      -- Find_System_Entity --
+      ------------------------
+
+      function Find_Local_Entity (E : RE_Id) return Entity_Id is
+         RE_Str : String renames RE_Id'Image (E);
+         Ent    : Entity_Id;
+
+         Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
+         --  Save name buffer and length over call
+
+      begin
+         Name_Len := Natural'Max (0, RE_Str'Length - 3);
+         Name_Buffer (1 .. Name_Len) :=
+           RE_Str (RE_Str'First + 3 .. RE_Str'Last);
+
+         Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
+
+         Name_Len := Save_Nam'Length;
+         Name_Buffer (1 .. Name_Len) := Save_Nam;
+
+         return Ent;
+      end Find_Local_Entity;
+
+      --------------------
+      -- Make_Unit_Name --
+      --------------------
+
+      function Make_Unit_Name (N : Node_Id) return Node_Id is
+         Nam  : Node_Id;
+         Scop : Entity_Id;
+
+      begin
+         Nam  := New_Reference_To (U.Entity, Standard_Location);
+         Scop := Scope (U.Entity);
+
+         if Nkind (N) = N_Defining_Program_Unit_Name then
+            while Scop /= Standard_Standard loop
+               Nam :=
+                 Make_Expanded_Name (Standard_Location,
+                   Chars  => Chars (U.Entity),
+                   Prefix => New_Reference_To (Scop, Standard_Location),
+                   Selector_Name => Nam);
+               Set_Entity (Nam, U.Entity);
+
+               Scop := Scope (Scop);
+            end loop;
+         end if;
+
+         return Nam;
+      end Make_Unit_Name;
+
+   --  Start of processing for RTE
+
+   begin
+      --  Doing a rtsfind in system.ads is special, as we cannot do this
+      --  when compiling System itself. So if we are compiling system then
+      --  we should already have acquired and processed the declaration
+      --  of the entity. The test is to see if this compilation's main unit
+      --  is System. If so, return the value from the already compiled
+      --  declaration and otherwise do a regular find.
+
+      --  Not pleasant, but these kinds of annoying recursion when
+      --  writing an Ada compiler in Ada have to be broken somewhere!
+
+      if Present (Main_Unit_Entity)
+        and then Chars (Main_Unit_Entity) = Name_System
+        and then Analyzed (Main_Unit_Entity)
+        and then not Is_Child_Unit (Main_Unit_Entity)
+      then
+         return Find_Local_Entity (E);
+      end if;
+
+      Enode := Current_Error_Node;
+
+      --  Load unit if unit not previously loaded
+
+      if No (RE_Table (E)) then
+         Load_RTU (U_Id);
+         Lib_Unit := Unit (Cunit (U.Unum));
+
+         --  In the subprogram case, we are all done, the entity we want
+         --  is the entity for the subprogram itself. Note that we do not
+         --  bother to check that it is the entity that was requested.
+         --  the only way that could fail to be the case is if runtime is
+         --  hopelessly misconfigured, and it isn't worth testing for this.
+
+         if Nkind (Lib_Unit) = N_Subprogram_Declaration then
+            RE_Table (E) := U.Entity;
+
+         --  Otherwise we must have the package case, and here we have to
+         --  search the package entity chain for the entity we want. The
+         --  entity we want must be present in this chain, or we have a
+         --  misconfigured runtime.
+
+         else
+            pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
+            Ename := RE_Chars (E);
+
+            Pkg_Ent := First_Entity (U.Entity);
+
+            while Present (Pkg_Ent) loop
+               if Ename = Chars (Pkg_Ent) then
+                  RE_Table (E) := Pkg_Ent;
+                  Check_RPC;
+                  goto Found;
+               end if;
+
+               Next_Entity (Pkg_Ent);
+            end loop;
+
+            --  If we didn't find the unit we want, something is wrong!
+
+            Load_Fail ("entity not in package", U_Id,  RE_Id'Image (E));
+            raise Program_Error;
+         end if;
+      end if;
+
+      --  See if we have to generate a with for this entity. We generate
+      --  a with if the current unit is part of the extended main code
+      --  unit, and if we have not already added the with. The with is
+      --  added to the appropriate unit (the current one).
+
+   <<Found>>
+      if (not U.Withed)
+        and then
+          In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
+      then
+         U.Withed := True;
+
+         declare
+            Withn    : Node_Id;
+            Lib_Unit : Node_Id;
+
+         begin
+            Lib_Unit := Unit (Cunit (U.Unum));
+            Withn :=
+              Make_With_Clause (Standard_Location,
+                Name =>
+                  Make_Unit_Name
+                    (Defining_Unit_Name (Specification (Lib_Unit))));
+            Set_Library_Unit          (Withn, Cunit (U.Unum));
+            Set_Corresponding_Spec    (Withn, U.Entity);
+            Set_First_Name            (Withn, True);
+            Set_Implicit_With         (Withn, True);
+
+            Mark_Rewrite_Insertion (Withn);
+            Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
+         end;
+      end if;
+
+      --  We can now obtain the entity. Check that the No_Run_Time condition
+      --  is not violated. Note that we do not signal the error if we detect
+      --  it in a runtime unit. This can only arise if the user explicitly
+      --  with'ed the runtime unit (or another runtime unit that uses it
+      --  transitively), or if some acceptable (e.g. inlined) entity is
+      --  fetched from a unit, some of whose other routines or entities
+      --  violate the conditions. In the latter case, it does not matter,
+      --  since we won't be using those entities.
+
+      Ent := RE_Table (E);
+
+      if Is_Subprogram (Ent)
+        and then not Is_Inlined (Ent)
+        and then Sloc (Enode) /= Standard_Location
+        and then not
+          Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Enode)))
+      then
+         Disallow_In_No_Run_Time_Mode (Enode);
+      end if;
+
+      return Ent;
+   end RTE;
+
+   --------------------
+   -- Text_IO_Kludge --
+   --------------------
+
+   procedure Text_IO_Kludge (Nam : Node_Id) is
+      Chrs : Name_Id;
+
+      type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id;
+
+      Name_Map : Name_Map_Type := Name_Map_Type'(
+        Name_Decimal_IO     => Ada_Text_IO_Decimal_IO,
+        Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO,
+        Name_Fixed_IO       => Ada_Text_IO_Fixed_IO,
+        Name_Float_IO       => Ada_Text_IO_Float_IO,
+        Name_Integer_IO     => Ada_Text_IO_Integer_IO,
+        Name_Modular_IO     => Ada_Text_IO_Modular_IO);
+
+      Wide_Name_Map : Name_Map_Type := Name_Map_Type'(
+        Name_Decimal_IO     => Ada_Wide_Text_IO_Decimal_IO,
+        Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO,
+        Name_Fixed_IO       => Ada_Wide_Text_IO_Fixed_IO,
+        Name_Float_IO       => Ada_Wide_Text_IO_Float_IO,
+        Name_Integer_IO     => Ada_Wide_Text_IO_Integer_IO,
+        Name_Modular_IO     => Ada_Wide_Text_IO_Modular_IO);
+
+   begin
+      --  Nothing to do if name is not identifier or a selected component
+      --  whose selector_name is not an identifier.
+
+      if Nkind (Nam) = N_Identifier then
+         Chrs := Chars (Nam);
+
+      elsif Nkind (Nam) = N_Selected_Component
+        and then Nkind (Selector_Name (Nam)) = N_Identifier
+      then
+         Chrs := Chars (Selector_Name (Nam));
+
+      else
+         return;
+      end if;
+
+      --  Nothing to do if name is not one of the Text_IO subpackages
+      --  Otherwise look through loaded units, and if we find Text_IO
+      --  or Wide_Text_IO already loaded, then load the proper child.
+
+      if Chrs in Text_IO_Package_Name then
+         for U in Main_Unit .. Last_Unit loop
+            Get_Name_String (Unit_File_Name (U));
+
+            if Name_Len = 12 then
+
+               --  Here is where we do the loads if we find one of the
+               --  units Ada.Text_IO or Ada.Wide_Text_IO. An interesting
+               --  detail is that these units may already be used (i.e.
+               --  their In_Use flags may be set). Normally when the In_Use
+               --  flag is set, the Is_Potentially_Use_Visible flag of all
+               --  entities in the package is set, but the new entity we
+               --  are mysteriously adding was not there to have its flag
+               --  set at the time. So that's why we pass the extra parameter
+               --  to RTU_Find, to make sure the flag does get set now.
+               --  Given that those generic packages are in fact child units,
+               --  we must indicate that they are visible.
+
+               if Name_Buffer (1 .. 12) = "a-textio.ads" then
+                  Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+                  Set_Is_Visible_Child_Unit
+                    (RT_Unit_Table (Name_Map (Chrs)).Entity);
+
+               elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
+                  Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+                  Set_Is_Visible_Child_Unit
+                    (RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
+               end if;
+            end if;
+         end loop;
+      end if;
+   end Text_IO_Kludge;
+
+end Rtsfind;