New Language: Ada

From-SVN: r45956

57 files changed, 38371 insertions, 0 deletions

diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
new file mode 100644
index 0000000..a4fa121
--- /dev/null
+++ b/gcc/ada/par-ch10.adb
@@ -0,0 +1,1080 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 0                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.115 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Hostparm; use Hostparm;
+with Uname;    use Uname;
+
+separate (Par)
+package body Ch10 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Context_Clause    return List_Id;
+   function P_Subunit           return Node_Id;
+
+   function Set_Location return Source_Ptr;
+   --  The current compilation unit starts with Token at Token_Ptr. This
+   --  function determines the corresponding source location for the start
+   --  of the unit, including any preceding comment lines.
+
+   procedure Unit_Display
+     (Cunit      : Node_Id;
+      Loc        : Source_Ptr;
+      SR_Present : Boolean);
+   --  This procedure is used to generate a line of output for the a unit in
+   --  the source program. Cunit is the node for the compilation unit, and
+   --  Loc is the source location for the start of the unit in the source
+   --  file (which is not necessarily the Sloc of the Cunit node). This
+   --  output is written to the standard output file for use by gnatchop.
+
+   procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
+   --  This routine has the same calling sequence as Unit_Display, but
+   --  it outputs only the line number and offset of the location, Loc,
+   --  using Cunit to obtain the proper source file index.
+
+   -------------------------
+   -- 10.1.1  Compilation --
+   -------------------------
+
+   --  COMPILATION ::= {COMPILATION_UNIT}
+
+   --  There is no specific parsing routine for a compilation, since we only
+   --  permit a single compilation in a source file, so there is no explicit
+   --  occurrence of compilations as such (our representation of a compilation
+   --  is a series of separate source files).
+
+   ------------------------------
+   -- 10.1.1  Compilation unit --
+   ------------------------------
+
+   --  COMPILATION_UNIT ::=
+   --    CONTEXT_CLAUSE LIBRARY_ITEM
+   --  | CONTEXT_CLAUSE SUBUNIT
+
+   --  LIBRARY_ITEM ::=
+   --    private LIBRARY_UNIT_DECLARATION
+   --  | LIBRARY_UNIT_BODY
+   --  | [private] LIBRARY_UNIT_RENAMING_DECLARATION
+
+   --  LIBRARY_UNIT_DECLARATION ::=
+   --    SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
+   --  | GENERIC_DECLARATION    | GENERIC_INSTANTIATION
+
+   --  LIBRARY_UNIT_RENAMING_DECLARATION ::=
+   --    PACKAGE_RENAMING_DECLARATION
+   --  | GENERIC_RENAMING_DECLARATION
+   --  | SUBPROGRAM_RENAMING_DECLARATION
+
+   --  LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs, tokens
+   --  are skipped up to the next possible beginning of a compilation unit.
+
+   --  Note: if only configuration pragmas are found, Empty is returned
+
+   --  Note: in syntax-only mode, it is possible for P_Compilation_Unit
+   --  to return strange things that are not really compilation units.
+   --  This is done to help out gnatchop when it is faced with nonsense.
+
+   function P_Compilation_Unit return Node_Id is
+      Scan_State         : Saved_Scan_State;
+      Body_Node          : Node_Id;
+      Specification_Node : Node_Id;
+      Unit_Node          : Node_Id;
+      Comp_Unit_Node     : Node_Id;
+      Name_Node          : Node_Id;
+      Item               : Node_Id;
+      Private_Sloc       : Source_Ptr := No_Location;
+      Config_Pragmas     : List_Id;
+      P                  : Node_Id;
+      SR_Present         : Boolean;
+
+      Cunit_Error_Flag   : Boolean := False;
+      --  This flag is set True if we have to scan for a compilation unit
+      --  token. It is used to ensure clean termination in such cases by
+      --  not insisting on being at the end of file, and, in the sytax only
+      --  case by not scanning for additional compilation units.
+
+      Cunit_Location : Source_Ptr;
+      --  Location of unit for unit identification output (List_Unit option)
+
+   begin
+      Num_Library_Units := Num_Library_Units + 1;
+
+      --  Set location of the compilation unit if unit list option set
+      --  and we are in syntax check only mode
+
+      if List_Units and then Operating_Mode = Check_Syntax then
+         Cunit_Location := Set_Location;
+      else
+         Cunit_Location := No_Location;
+      end if;
+
+      --  Deal with initial pragmas
+
+      Config_Pragmas := No_List;
+
+      --  If we have an initial Source_Reference pragma, then remember
+      --  the fact to generate an NR parameter in the output line.
+
+      SR_Present := False;
+
+      if Token = Tok_Pragma then
+         Save_Scan_State (Scan_State);
+         Item := P_Pragma;
+
+         if Item = Error
+           or else Chars (Item) /= Name_Source_Reference
+         then
+            Restore_Scan_State (Scan_State);
+
+         else
+            SR_Present := True;
+
+            --  If first unit, record the file name for gnatchop use
+
+            if Operating_Mode = Check_Syntax
+              and then List_Units
+              and then Num_Library_Units = 1
+            then
+               Write_Str ("Source_Reference pragma for file """);
+               Write_Name (Full_Ref_Name (Current_Source_File));
+               Write_Char ('"');
+               Write_Eol;
+            end if;
+
+            Config_Pragmas := New_List (Item);
+         end if;
+      end if;
+
+      --  Scan out any configuration pragmas
+
+      while Token = Tok_Pragma loop
+         Save_Scan_State (Scan_State);
+         Item := P_Pragma;
+
+         if Item = Error
+           or else Chars (Item) > Last_Configuration_Pragma_Name
+         then
+            Restore_Scan_State (Scan_State);
+            exit;
+         end if;
+
+         if Config_Pragmas = No_List then
+            Config_Pragmas := Empty_List;
+
+            if Operating_Mode = Check_Syntax and then List_Units then
+               Write_Str ("Configuration pragmas at");
+               Unit_Location (Current_Source_File, Cunit_Location);
+               Write_Eol;
+            end if;
+         end if;
+
+         Append (Item, Config_Pragmas);
+         Cunit_Location := Set_Location;
+      end loop;
+
+      --  Establish compilation unit node and scan context items
+
+      Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);
+      Set_Cunit (Current_Source_Unit, Comp_Unit_Node);
+      Set_Context_Items (Comp_Unit_Node, P_Context_Clause);
+      Set_Aux_Decls_Node
+        (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));
+
+      if Present (Config_Pragmas) then
+
+         --  Check for case of only configuration pragmas present
+
+         if Token = Tok_EOF
+           and then Is_Empty_List (Context_Items (Comp_Unit_Node))
+         then
+            if Operating_Mode = Check_Syntax then
+               return Empty;
+
+            else
+               Item := First (Config_Pragmas);
+               Error_Msg_N
+                 ("cannot compile configuration pragmas with gcc", Item);
+               Error_Msg_N
+                 ("use gnatchop -c to process configuration pragmas!", Item);
+               raise Unrecoverable_Error;
+            end if;
+
+         --  Otherwise configuration pragmas are simply prepended to the
+         --  context of the current unit.
+
+         else
+            Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
+            Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
+         end if;
+      end if;
+
+      --  Check for PRIVATE. Note that for the moment we allow this in
+      --  Ada_83 mode, since we do not yet know if we are compiling a
+      --  predefined unit, and if we are then it would be allowed anyway.
+
+      if Token = Tok_Private then
+         Private_Sloc := Token_Ptr;
+         Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
+         if Style_Check then Style.Check_Indentation; end if;
+
+         Save_Scan_State (Scan_State); -- at PRIVATE
+         Scan; -- past PRIVATE
+
+         if Token = Tok_Separate then
+            Error_Msg_SP ("cannot have private subunits!");
+
+         elsif Token = Tok_Package then
+            Scan; -- past PACKAGE
+
+            if Token = Tok_Body then
+               Restore_Scan_State (Scan_State); -- to PRIVATE
+               Error_Msg_SC ("cannot have private package body!");
+               Scan; -- ignore PRIVATE
+
+            else
+               Restore_Scan_State (Scan_State); -- to PRIVATE
+               Scan; -- past PRIVATE
+               Set_Private_Present (Comp_Unit_Node, True);
+            end if;
+
+         elsif Token = Tok_Procedure
+           or else Token = Tok_Function
+           or else Token = Tok_Generic
+         then
+            Set_Private_Present (Comp_Unit_Node, True);
+         end if;
+      end if;
+
+      --  Loop to find our way to a compilation unit token
+
+      loop
+         exit when Token in Token_Class_Cunit and then Token /= Tok_With;
+
+         exit when Bad_Spelling_Of (Tok_Package)
+           or else Bad_Spelling_Of (Tok_Function)
+           or else Bad_Spelling_Of (Tok_Generic)
+           or else Bad_Spelling_Of (Tok_Separate)
+           or else Bad_Spelling_Of (Tok_Procedure);
+
+         --  Allow task and protected for nice error recovery purposes
+
+         exit when Token = Tok_Task
+           or else Token = Tok_Protected;
+
+         if Token = Tok_With then
+            Error_Msg_SC ("misplaced WITH");
+            Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
+
+         elsif Bad_Spelling_Of (Tok_With) then
+            Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
+
+         else
+            Error_Msg_SC ("compilation unit expected");
+            Cunit_Error_Flag := True;
+            Resync_Cunit;
+
+            --  If we are at an end of file, then just quit, the above error
+            --  message was complaint enough.
+
+            if Token = Tok_EOF then
+               return Error;
+            end if;
+         end if;
+      end loop;
+
+      --  We have a compilation unit token, so that's a reasonable choice for
+      --  determining the standard casing convention used for keywords in case
+      --  it hasn't already been done on seeing a WITH or PRIVATE.
+
+      Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
+      if Style_Check then Style.Check_Indentation; end if;
+
+      --  Remaining processing depends on particular type of compilation unit
+
+      if Token = Tok_Package then
+
+         --  A common error is to omit the body keyword after package. We can
+         --  often diagnose this early on (before getting loads of errors from
+         --  contained subprogram bodies), by knowing that that the file we
+         --  are compiling has a name that requires a body to be found.
+
+         --  However, we do not do this check if we are operating in syntax
+         --  checking only mode, because in that case there may be multiple
+         --  units in the same file, and the file name is not a reliable guide.
+
+         Save_Scan_State (Scan_State);
+         Scan; -- past Package keyword
+
+         if Token /= Tok_Body
+           and then Operating_Mode /= Check_Syntax
+           and then
+             Get_Expected_Unit_Type
+               (File_Name (Current_Source_File)) = Expect_Body
+         then
+            Error_Msg_BC ("keyword BODY expected here [see file name]");
+            Restore_Scan_State (Scan_State);
+            Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
+         else
+            Restore_Scan_State (Scan_State);
+            Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
+         end if;
+
+      elsif Token = Tok_Generic then
+         Set_Unit (Comp_Unit_Node, P_Generic);
+
+      elsif Token = Tok_Separate then
+         Set_Unit (Comp_Unit_Node, P_Subunit);
+
+      elsif Token = Tok_Procedure
+        or else Token = Tok_Function
+      then
+         Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
+
+         --  A little bit of an error recovery check here. If we just scanned
+         --  a subprogram declaration (as indicated by an SIS entry being
+         --  active), then if the following token is BEGIN or an identifier,
+         --  or a token which can reasonably start a declaration but cannot
+         --  start a compilation unit, then we assume that the semicolon in
+         --  the declaration should have been IS.
+
+         if SIS_Entry_Active then
+
+            if Token = Tok_Begin
+               or else Token = Tok_Identifier
+               or else Token in Token_Class_Deckn
+            then
+               Push_Scope_Stack;
+               Scope.Table (Scope.Last).Etyp := E_Name;
+               Scope.Table (Scope.Last).Sloc := SIS_Sloc;
+               Scope.Table (Scope.Last).Ecol := SIS_Ecol;
+               Scope.Table (Scope.Last).Lreq := False;
+               SIS_Entry_Active := False;
+
+               --  If we had a missing semicolon in the declaration, then
+               --  change the message to from <missing ";"> to <missing "is">
+
+               if SIS_Missing_Semicolon_Message /= No_Error_Msg then
+                  Change_Error_Text     -- Replace: "missing "";"" "
+                    (SIS_Missing_Semicolon_Message, "missing IS");
+
+               --  Otherwise we saved the semicolon position, so complain
+
+               else
+                  Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
+               end if;
+
+               Body_Node := Unit (Comp_Unit_Node);
+               Specification_Node := Specification (Body_Node);
+               Change_Node (Body_Node, N_Subprogram_Body);
+               Set_Specification (Body_Node, Specification_Node);
+               Parse_Decls_Begin_End (Body_Node);
+               Set_Unit (Comp_Unit_Node, Body_Node);
+            end if;
+
+         --  If we scanned a subprogram body, make sure we did not have private
+
+         elsif Private_Sloc /= No_Location
+           and then Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
+           and then Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
+         then
+            Error_Msg ("cannot have private subprogram body", Private_Sloc);
+
+         --  P_Subprogram can yield an abstract subprogram, but this cannot
+         --  be a compilation unit. Treat as a subprogram declaration.
+
+         elsif
+           Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
+         then
+            Error_Msg_N
+              ("compilation unit cannot be abstract subprogram",
+                 Unit (Comp_Unit_Node));
+
+            Unit_Node :=
+              New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
+            Set_Specification (Unit_Node,
+              Specification (Unit (Comp_Unit_Node)));
+            Set_Unit (Comp_Unit_Node, Unit_Node);
+         end if;
+
+      --  Otherwise we have TASK. This is not really an acceptable token,
+      --  but we accept it to improve error recovery.
+
+      elsif Token = Tok_Task then
+         Scan; -- Past TASK
+
+         if Token = Tok_Type then
+            Error_Msg_SP
+              ("task type cannot be used as compilation unit");
+         else
+            Error_Msg_SP
+              ("task declaration cannot be used as compilation unit");
+         end if;
+
+         --  If in check syntax mode, accept the task anyway. This is done
+         --  particularly to improve the behavior of GNATCHOP in this case.
+
+         if Operating_Mode = Check_Syntax then
+            Set_Unit (Comp_Unit_Node, P_Task);
+
+         --  If not in syntax only mode, treat this as horrible error
+
+         else
+            Cunit_Error_Flag := True;
+            return Error;
+         end if;
+
+      else pragma Assert (Token = Tok_Protected);
+         Scan; -- Past PROTECTED
+
+         if Token = Tok_Type then
+            Error_Msg_SP
+              ("protected type cannot be used as compilation unit");
+         else
+            Error_Msg_SP
+              ("protected declaration cannot be used as compilation unit");
+         end if;
+
+         --  If in check syntax mode, accept protected anyway. This is done
+         --  particularly to improve the behavior of GNATCHOP in this case.
+
+         if Operating_Mode = Check_Syntax then
+            Set_Unit (Comp_Unit_Node, P_Protected);
+
+         --  If not in syntax only mode, treat this as horrible error
+
+         else
+            Cunit_Error_Flag := True;
+            return Error;
+         end if;
+      end if;
+
+      --  Here is where locate the compilation unit entity. This is a little
+      --  tricky, since it is buried in various places.
+
+      Unit_Node := Unit (Comp_Unit_Node);
+
+      --  Another error from which it is hard to recover
+
+      if Nkind (Unit_Node) = N_Subprogram_Body_Stub
+        or else Nkind (Unit_Node) = N_Package_Body_Stub
+      then
+         Cunit_Error_Flag := True;
+         return Error;
+      end if;
+
+      --  Only try this if we got an OK unit!
+
+      if Unit_Node /= Error then
+         if Nkind (Unit_Node) = N_Subunit then
+            Unit_Node := Proper_Body (Unit_Node);
+         end if;
+
+         if Nkind (Unit_Node) in N_Generic_Declaration then
+            Unit_Node := Specification (Unit_Node);
+         end if;
+
+         if Nkind (Unit_Node) = N_Package_Declaration
+           or else Nkind (Unit_Node) = N_Subprogram_Declaration
+           or else Nkind (Unit_Node) = N_Subprogram_Body
+           or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
+         then
+            Unit_Node := Specification (Unit_Node);
+
+         elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
+            if Ada_83 then
+               Error_Msg_N
+                 ("(Ada 83) library unit renaming not allowed", Unit_Node);
+            end if;
+         end if;
+
+         if Nkind (Unit_Node) = N_Task_Body
+           or else Nkind (Unit_Node) = N_Protected_Body
+           or else Nkind (Unit_Node) = N_Task_Type_Declaration
+           or else Nkind (Unit_Node) = N_Protected_Type_Declaration
+           or else Nkind (Unit_Node) = N_Single_Task_Declaration
+           or else Nkind (Unit_Node) = N_Single_Protected_Declaration
+         then
+            Name_Node := Defining_Identifier (Unit_Node);
+         else
+            Name_Node := Defining_Unit_Name (Unit_Node);
+         end if;
+
+         Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
+         Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
+
+         --  Set Entity field in file table. Easier now that we have name!
+         --  Note that this is also skipped if we had a bad unit
+
+         if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
+            Set_Cunit_Entity
+              (Current_Source_Unit, Defining_Identifier (Name_Node));
+         else
+            Set_Cunit_Entity (Current_Source_Unit, Name_Node);
+         end if;
+
+         Set_Unit_Name
+           (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
+
+      --  If we had a bad unit, make sure the fatal flag is set in the file
+      --  table entry, since this is surely a fatal error and also set our
+      --  flag to inhibit the requirement that we be at end of file.
+
+      else
+         Cunit_Error_Flag := True;
+         Set_Fatal_Error (Current_Source_Unit);
+      end if;
+
+      --  Clear away any missing semicolon indication, we are done with that
+      --  unit, so what's done is done, and we don't want anything hanging
+      --  around from the attempt to parse it!
+
+      SIS_Entry_Active := False;
+
+      --  Scan out pragmas after unit
+
+      while Token = Tok_Pragma loop
+         Save_Scan_State (Scan_State);
+
+         --  If we are in syntax scan mode allowing multiple units, then
+         --  start the next unit if we encounter a configuration pragma,
+         --  or a source reference pragma. We take care not to actually
+         --  scan the pragma in this case since we don't want it to take
+         --  effect for the current unit.
+
+         if Operating_Mode = Check_Syntax then
+            Scan;  -- past Pragma
+
+            if Token = Tok_Identifier
+              and then
+                (Token_Name in
+                         First_Pragma_Name .. Last_Configuration_Pragma_Name
+                   or else Token_Name = Name_Source_Reference)
+            then
+               Restore_Scan_State (Scan_State); -- to Pragma
+               exit;
+            end if;
+         end if;
+
+         --  Otherwise eat the pragma, it definitely belongs with the
+         --  current unit, and not with the following unit.
+
+         Restore_Scan_State (Scan_State); -- to Pragma
+         P := P_Pragma;
+
+         if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
+            Set_Pragmas_After
+              (Aux_Decls_Node (Comp_Unit_Node), New_List);
+         end if;
+
+         Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
+      end loop;
+
+      --  Cancel effect of any outstanding pragma Warnings (Off)
+
+      Set_Warnings_Mode_On (Scan_Ptr);
+
+      --  Ada 83 error checks
+
+      if Ada_83 then
+
+         --  Check we did not with any child units
+
+         Item := First (Context_Items (Comp_Unit_Node));
+
+         while Present (Item) loop
+            if Nkind (Item) = N_With_Clause
+              and then Nkind (Name (Item)) /= N_Identifier
+            then
+               Error_Msg_N ("(Ada 83) child units not allowed", Item);
+            end if;
+
+            Next (Item);
+         end loop;
+
+         --  Check that we did not have a PRIVATE keyword present
+
+         if Private_Present (Comp_Unit_Node) then
+            Error_Msg
+              ("(Ada 83) private units not allowed", Private_Sloc);
+         end if;
+      end if;
+
+      --  If no serious error, then output possible unit information line
+      --  for gnatchop if we are in syntax only, list units mode.
+
+      if not Cunit_Error_Flag
+        and then List_Units
+        and then Operating_Mode = Check_Syntax
+      then
+         Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);
+      end if;
+
+      --  And now we should be at the end of file
+
+      if Token /= Tok_EOF then
+
+         --  If we already had to scan for a compilation unit, then don't
+         --  give any further error message, since it just sems to make
+         --  things worse, and we already gave a serious error message.
+
+         if Cunit_Error_Flag then
+            null;
+
+         --  If we are in check syntax mode, then we allow multiple units
+         --  so we just return with Token not set to Tok_EOF and no message.
+
+         elsif Operating_Mode = Check_Syntax then
+            return Comp_Unit_Node;
+
+         --  Otherwise we have an error. We suppress the error message
+         --  if we already had a fatal error, since this stops junk
+         --  cascaded messages in some situations.
+
+         else
+            if not Fatal_Error (Current_Source_Unit) then
+
+               if Token in Token_Class_Cunit then
+                  Error_Msg_SC
+                    ("end of file expected, " &
+                     "file can have only one compilation unit");
+
+               else
+                  Error_Msg_SC ("end of file expected");
+               end if;
+            end if;
+         end if;
+
+         --  Skip tokens to end of file, so that the -gnatl listing
+         --  will be complete in this situation, but no error checking
+         --  other than that provided at the token level.
+
+         while Token /= Tok_EOF loop
+            Scan;
+         end loop;
+
+         return Error;
+
+      --  Normal return (we were at the end of file as expected)
+
+      else
+         return Comp_Unit_Node;
+      end if;
+
+   exception
+
+      --  An error resync is a serious bomb, so indicate result unit no good
+
+      when Error_Resync =>
+         Set_Fatal_Error (Current_Source_Unit);
+         return Error;
+
+   end P_Compilation_Unit;
+
+   --------------------------
+   -- 10.1.1  Library Item --
+   --------------------------
+
+   --  Parsed by P_Compilation_Unit (10.1.1)
+
+   --------------------------------------
+   -- 10.1.1  Library Unit Declaration --
+   --------------------------------------
+
+   --  Parsed by P_Compilation_Unit (10.1.1)
+
+   ------------------------------------------------
+   -- 10.1.1  Library Unit Renaming Declaration  --
+   ------------------------------------------------
+
+   --  Parsed by P_Compilation_Unit (10.1.1)
+
+   -------------------------------
+   -- 10.1.1  Library Unit Body --
+   -------------------------------
+
+   --  Parsed by P_Compilation_Unit (10.1.1)
+
+   ------------------------------
+   -- 10.1.1  Parent Unit Name --
+   ------------------------------
+
+   --  Parsed (as a name) by its parent construct
+
+   ----------------------------
+   -- 10.1.2  Context Clause --
+   ----------------------------
+
+   --  CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
+
+   --  CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
+
+   --  WITH_CLAUSE ::=
+   --    with library_unit_NAME {,library_unit_NAME};
+
+   --  WITH_TYPE_CLAUSE ::=
+   --    with type type_NAME is access; | with type type_NAME is tagged;
+
+   --  Error recovery: Cannot raise Error_Resync
+
+   function P_Context_Clause return List_Id is
+      Item_List  : List_Id;
+      With_Node  : Node_Id;
+      First_Flag : Boolean;
+
+   begin
+      Item_List := New_List;
+
+      --  Get keyword casing from WITH keyword in case not set yet
+
+      if Token = Tok_With then
+         Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
+      end if;
+
+      --  Loop through context items
+
+      loop
+         if Style_Check then Style.Check_Indentation; end if;
+
+         --  Gather any pragmas appearing in the context clause
+
+         P_Pragmas_Opt (Item_List);
+
+         --  Processing for WITH clause
+
+         if Token = Tok_With then
+            Scan; -- past WITH
+
+            if Token = Tok_Type then
+
+               --  WITH TYPE is an extension
+
+               if not Extensions_Allowed then
+                  Error_Msg_SP ("`WITH TYPE` is a non-standard extension");
+
+                  if OpenVMS then
+                     Error_Msg_SP
+                       ("\unit must be compiled with " &
+                        "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+                  else
+                     Error_Msg_SP
+                       ("\unit must be compiled with -gnatX switch");
+                  end if;
+               end if;
+
+               Scan;  -- past TYPE
+               With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
+               Append (With_Node, Item_List);
+               Set_Name (With_Node, P_Qualified_Simple_Name);
+
+               T_Is;
+
+               if Token = Tok_Tagged then
+                  Set_Tagged_Present (With_Node);
+                  Scan;
+
+               elsif Token = Tok_Access then
+                  Scan;
+
+               else
+                  Error_Msg_SC ("expect tagged or access qualifier");
+               end if;
+
+               TF_Semicolon;
+
+            else
+               First_Flag := True;
+
+               --  Loop through names in one with clause, generating a separate
+               --  N_With_Clause node for each nam encountered.
+
+               loop
+                  With_Node := New_Node (N_With_Clause, Token_Ptr);
+                  Append (With_Node, Item_List);
+
+                  --  Note that we allow with'ing of child units, even in
+                  --  Ada 83 mode, since presumably if this is not desired,
+                  --  then the compilation of the child unit itself is the
+                  --  place where such an "error" should be caught.
+
+                  Set_Name (With_Node, P_Qualified_Simple_Name);
+                  Set_First_Name (With_Node, First_Flag);
+                  First_Flag := False;
+                  exit when Token /= Tok_Comma;
+                  Scan; -- past comma
+               end loop;
+
+               Set_Last_Name (With_Node, True);
+               TF_Semicolon;
+            end if;
+
+         --  Processing for USE clause
+
+         elsif Token = Tok_Use then
+            Append (P_Use_Clause, Item_List);
+
+         --  Anything else is end of context clause
+
+         else
+            exit;
+         end if;
+      end loop;
+
+      return Item_List;
+   end P_Context_Clause;
+
+   --------------------------
+   -- 10.1.2  Context Item --
+   --------------------------
+
+   --  Parsed by P_Context_Clause (10.1.2)
+
+   -------------------------
+   -- 10.1.2  With Clause --
+   -------------------------
+
+   --  Parsed by P_Context_Clause (10.1.2)
+
+   -----------------------
+   -- 10.1.3  Body Stub --
+   -----------------------
+
+   --  Subprogram stub parsed by P_Subprogram (6.1)
+   --  Package stub parsed by P_Package (7.1)
+   --  Task stub parsed by P_Task (9.1)
+   --  Protected stub parsed by P_Protected (9.4)
+
+   ----------------------------------
+   -- 10.1.3  Subprogram Body Stub --
+   ----------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -------------------------------
+   -- 10.1.3  Package Body Stub --
+   -------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   ----------------------------
+   -- 10.1.3  Task Body Stub --
+   ----------------------------
+
+   --  Parsed by P_Task (9.1)
+
+   ---------------------------------
+   -- 10.1.3  Protected Body Stub --
+   ---------------------------------
+
+   --  Parsed by P_Protected (9.4)
+
+   ---------------------
+   -- 10.1.3  Subunit --
+   ---------------------
+
+   --  SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
+
+   --  PARENT_UNIT_NAME ::= NAME
+
+   --  The caller has checked that the initial token is SEPARATE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Subunit return Node_Id is
+      Subunit_Node : Node_Id;
+      Body_Node    : Node_Id;
+
+   begin
+      Subunit_Node := New_Node (N_Subunit, Token_Ptr);
+      Body_Node := Error; -- in case no good body found
+      Scan; -- past SEPARATE;
+
+      T_Left_Paren;
+      Set_Name (Subunit_Node, P_Qualified_Simple_Name);
+      T_Right_Paren;
+
+      if Token = Tok_Semicolon then
+         Error_Msg_SC ("unexpected semicolon ignored");
+         Scan;
+      end if;
+
+      if Token = Tok_Function or else Token = Tok_Procedure then
+         Body_Node := P_Subprogram (Pf_Pbod);
+
+      elsif Token = Tok_Package then
+         Body_Node := P_Package (Pf_Pbod);
+
+      elsif Token = Tok_Protected then
+         Scan; -- past PROTECTED
+
+         if Token = Tok_Body then
+            Body_Node := P_Protected;
+         else
+            Error_Msg_AP ("BODY expected");
+            return Error;
+         end if;
+
+      elsif Token = Tok_Task then
+         Scan; -- past TASK
+
+         if Token = Tok_Body then
+            Body_Node := P_Task;
+         else
+            Error_Msg_AP ("BODY expected");
+            return Error;
+         end if;
+
+      else
+         Error_Msg_SC ("proper body expected");
+         return Error;
+      end if;
+
+      Set_Proper_Body  (Subunit_Node, Body_Node);
+      return Subunit_Node;
+
+   end P_Subunit;
+
+   ------------------
+   -- Set_Location --
+   ------------------
+
+   function Set_Location return Source_Ptr is
+      Physical   : Boolean;
+      Loc        : Source_Ptr;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      --  A special check. If the first token is pragma, and this is a
+      --  Source_Reference pragma, then do NOT eat previous comments, since
+      --  the Source_Reference pragma is required to be the first line in
+      --  the source file.
+
+      if Token = Tok_Pragma then
+         Save_Scan_State (Scan_State);
+         Scan; --  past Pragma
+
+         if Token = Tok_Identifier
+           and then Token_Name = Name_Source_Reference
+         then
+            Restore_Scan_State (Scan_State);
+            return Token_Ptr;
+         end if;
+
+         Restore_Scan_State (Scan_State);
+      end if;
+
+      --  Otherwise acquire previous comments and blank lines
+
+      if Prev_Token = No_Token then
+         return Source_First (Current_Source_File);
+
+      else
+         Loc := Prev_Token_Ptr;
+         loop
+            exit when Loc = Token_Ptr;
+
+            if Source (Loc) in Line_Terminator then
+               Skip_Line_Terminators (Loc, Physical);
+               exit when Physical;
+            end if;
+
+            Loc := Loc + 1;
+         end loop;
+
+         return Loc;
+      end if;
+   end Set_Location;
+
+   ------------------
+   -- Unit_Display --
+   ------------------
+
+   --  The format of the generated line, as expected by GNATCHOP is
+
+   --    Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
+
+   --  where
+
+   --     {unit}     unit name with terminating (spec) or (body)
+   --     {line}     starting line number
+   --     {offs}     offset to start of text in file
+   --     {file}     source file name
+
+   --  The SR parameter is present only if a source reference pragma was
+   --  scanned for this unit. The significance is that gnatchop should not
+   --  attempt to add another one.
+
+   procedure Unit_Display
+     (Cunit      : Node_Id;
+      Loc        : Source_Ptr;
+      SR_Present : Boolean)
+   is
+      Unum : constant Unit_Number_Type    := Get_Cunit_Unit_Number (Cunit);
+      Sind : constant Source_File_Index   := Source_Index (Unum);
+      Unam : constant Unit_Name_Type      := Unit_Name (Unum);
+
+   begin
+      if List_Units then
+         Write_Str ("Unit ");
+         Write_Unit_Name (Unit_Name (Unum));
+         Unit_Location (Sind, Loc);
+
+         if SR_Present then
+            Write_Str (", SR");
+         end if;
+
+         Write_Str (", file name ");
+         Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
+         Write_Eol;
+      end if;
+   end Unit_Display;
+
+   -------------------
+   -- Unit_Location --
+   -------------------
+
+   procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
+      Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
+      --  Should the above be the physical line number ???
+
+   begin
+      Write_Str (" line ");
+      Write_Int (Int (Line));
+
+      Write_Str (", file offset ");
+      Write_Int (Int (Loc) - Int (Source_First (Sind)));
+   end Unit_Location;
+
+end Ch10;
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
new file mode 100644
index 0000000..8b59c54
--- /dev/null
+++ b/gcc/ada/par-ch11.adb
@@ -0,0 +1,246 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 1                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.22 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Sinfo.CN; use Sinfo.CN;
+
+separate (Par)
+package body Ch11 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Exception_Handler  return Node_Id;
+   function P_Exception_Choice   return Node_Id;
+
+   ---------------------------------
+   -- 11.1  Exception Declaration --
+   ---------------------------------
+
+   --  Parsed by P_Identifier_Declaration (3.3.1)
+
+   ------------------------------------------
+   -- 11.2  Handled Sequence Of Statements --
+   ------------------------------------------
+
+   --  HANDLED_SEQUENCE_OF_STATEMENTS ::=
+   --      SEQUENCE_OF_STATEMENTS
+   --    [exception
+   --      EXCEPTION_HANDLER
+   --      {EXCEPTION_HANDLER}]
+
+   --  Error_Recovery : Cannot raise Error_Resync
+
+   function P_Handled_Sequence_Of_Statements return Node_Id is
+      Handled_Stmt_Seq_Node : Node_Id;
+
+   begin
+      Handled_Stmt_Seq_Node :=
+        New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr);
+      Set_Statements
+        (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq));
+
+      if Token = Tok_Exception then
+         Scan; -- past EXCEPTION
+         Set_Exception_Handlers
+           (Handled_Stmt_Seq_Node, Parse_Exception_Handlers);
+      end if;
+
+      return Handled_Stmt_Seq_Node;
+   end P_Handled_Sequence_Of_Statements;
+
+   -----------------------------
+   -- 11.2  Exception Handler --
+   -----------------------------
+
+   --  EXCEPTION_HANDLER ::=
+   --    when [CHOICE_PARAMETER_SPECIFICATION :]
+   --      EXCEPTION_CHOICE {| EXCEPTION_CHOICE} =>
+   --        SEQUENCE_OF_STATEMENTS
+
+   --  CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Exception_Handler return Node_Id is
+      Scan_State        : Saved_Scan_State;
+      Handler_Node      : Node_Id;
+      Choice_Param_Node : Node_Id;
+
+   begin
+      Handler_Node := New_Node (N_Exception_Handler, Token_Ptr);
+      T_When;
+
+      --  Test for possible choice parameter present
+
+      if Token = Tok_Identifier then
+         Choice_Param_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at identifier
+         Scan; -- past identifier
+
+         if Token = Tok_Colon then
+            if Ada_83 then
+               Error_Msg_SP ("(Ada 83) choice parameter not allowed!");
+            end if;
+
+            Scan; -- past :
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         elsif Token = Tok_Others then
+            Error_Msg_AP ("missing "":""");
+            Change_Identifier_To_Defining_Identifier (Choice_Param_Node);
+            Set_Choice_Parameter (Handler_Node, Choice_Param_Node);
+
+         else
+            Restore_Scan_State (Scan_State); -- to identifier
+         end if;
+      end if;
+
+      --  Loop through exception choices
+
+      Set_Exception_Choices (Handler_Node, New_List);
+
+      loop
+         Append (P_Exception_Choice, Exception_Choices (Handler_Node));
+         exit when Token /= Tok_Vertical_Bar;
+         Scan; -- past vertical bar
+      end loop;
+
+      TF_Arrow;
+      Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
+      return Handler_Node;
+   end P_Exception_Handler;
+
+   ------------------------------------------
+   -- 11.2  Choice Parameter Specification --
+   ------------------------------------------
+
+   --  Parsed by P_Exception_Handler (11.2)
+
+   ----------------------------
+   -- 11.2  Exception Choice --
+   ----------------------------
+
+   --  EXCEPTION_CHOICE ::= exception_NAME | others
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs, then the
+   --  scan pointer is advanced to the next arrow or vertical bar or semicolon.
+
+   function P_Exception_Choice return Node_Id is
+   begin
+
+      if Token = Tok_Others then
+         Scan; -- past OTHERS
+         return New_Node (N_Others_Choice, Prev_Token_Ptr);
+
+      else
+         return P_Name; -- exception name
+      end if;
+
+   exception
+      when Error_Resync =>
+         Resync_Choice;
+         return Error;
+   end P_Exception_Choice;
+
+   ---------------------------
+   -- 11.3  Raise Statement --
+   ---------------------------
+
+   --  RAISE_STATEMENT ::= raise [exception_NAME];
+
+   --  The caller has verified that the initial token is RAISE
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Raise_Statement return Node_Id is
+      Raise_Node : Node_Id;
+
+   begin
+      Raise_Node := New_Node (N_Raise_Statement, Token_Ptr);
+      Scan; -- past RAISE
+
+      if Token /= Tok_Semicolon then
+         Set_Name (Raise_Node, P_Name);
+      end if;
+
+      TF_Semicolon;
+      return Raise_Node;
+   end P_Raise_Statement;
+
+   ------------------------------
+   -- Parse_Exception_Handlers --
+   ------------------------------
+
+   --  This routine scans out a list of exception handlers appearing in a
+   --  construct as:
+
+   --    exception
+   --      EXCEPTION_HANDLER {EXCEPTION_HANDLER}
+
+   --  The caller has scanned out the EXCEPTION keyword
+
+   --  Control returns after scanning the last exception handler, presumably
+   --  at the keyword END, but this is not checked in this routine.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function Parse_Exception_Handlers return List_Id is
+      Handler       : Node_Id;
+      Handlers_List : List_Id;
+      Pragmas_List  : List_Id;
+
+   begin
+      Handlers_List := New_List;
+      P_Pragmas_Opt (Handlers_List);
+
+      if Token = Tok_End then
+         Error_Msg_SC ("must have at least one exception handler!");
+
+      else
+         loop
+            Handler := P_Exception_Handler;
+            Pragmas_List := No_List;
+            Append (Handler, Handlers_List);
+
+            --  Note: no need to check for pragmas here. Although the
+            --  syntax officially allows them in this position, they
+            --  will have been swallowed up as part of the statement
+            --  sequence of the handler we just scanned out.
+
+            exit when Token /= Tok_When;
+         end loop;
+      end if;
+
+      return Handlers_List;
+   end Parse_Exception_Handlers;
+
+end Ch11;
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
new file mode 100644
index 0000000..139243e
--- /dev/null
+++ b/gcc/ada/par-ch12.adb
@@ -0,0 +1,882 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 2                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.46 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch12 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Formal_Derived_Type_Definition           return Node_Id;
+   function P_Formal_Discrete_Type_Definition          return Node_Id;
+   function P_Formal_Fixed_Point_Definition            return Node_Id;
+   function P_Formal_Floating_Point_Definition         return Node_Id;
+   function P_Formal_Modular_Type_Definition           return Node_Id;
+   function P_Formal_Package_Declaration               return Node_Id;
+   function P_Formal_Private_Type_Definition           return Node_Id;
+   function P_Formal_Signed_Integer_Type_Definition    return Node_Id;
+   function P_Formal_Subprogram_Declaration            return Node_Id;
+   function P_Formal_Type_Declaration                  return Node_Id;
+   function P_Formal_Type_Definition                   return Node_Id;
+   function P_Generic_Association                      return Node_Id;
+
+   procedure P_Formal_Object_Declarations (Decls : List_Id);
+   --  Scans one or more formal object declarations and appends them to
+   --  Decls. Scans more than one declaration only in the case where the
+   --  source has a declaration with multiple defining identifiers.
+
+   --------------------------------
+   -- 12.1  Generic (also 8.5.5) --
+   --------------------------------
+
+   --  This routine parses either one of the forms of a generic declaration
+   --  or a generic renaming declaration.
+
+   --  GENERIC_DECLARATION ::=
+   --    GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION
+
+   --  GENERIC_SUBPROGRAM_DECLARATION ::=
+   --    GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION;
+
+   --  GENERIC_PACKAGE_DECLARATION ::=
+   --    GENERIC_FORMAL_PART PACKAGE_SPECIFICATION;
+
+   --  GENERIC_FORMAL_PART ::=
+   --    generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE}
+
+   --  GENERIC_RENAMING_DECLARATION ::=
+   --    generic package DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_package_NAME
+   --  | generic procedure DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_procedure_NAME
+   --  | generic function DEFINING_PROGRAM_UNIT_NAME
+   --      renames generic_function_NAME
+
+   --  GENERIC_FORMAL_PARAMETER_DECLARATION ::=
+   --    FORMAL_OBJECT_DECLARATION
+   --  | FORMAL_TYPE_DECLARATION
+   --  | FORMAL_SUBPROGRAM_DECLARATION
+   --  | FORMAL_PACKAGE_DECLARATION
+
+   --  The caller has checked that the initial token is GENERIC
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Generic return Node_Id is
+      Gen_Sloc   : constant Source_Ptr := Token_Ptr;
+      Gen_Decl   : Node_Id;
+      Decl_Node  : Node_Id;
+      Decls      : List_Id;
+      Def_Unit   : Node_Id;
+      Ren_Token  : Token_Type;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Scan; -- past GENERIC
+
+      if Token = Tok_Private then
+         Error_Msg_SC ("PRIVATE goes before GENERIC, not after");
+         Scan; -- past junk PRIVATE token
+      end if;
+
+      Save_Scan_State (Scan_State); -- at token past GENERIC
+
+      --  Check for generic renaming declaration case
+
+      if Token = Tok_Package
+        or else Token = Tok_Function
+        or else Token = Tok_Procedure
+      then
+         Ren_Token := Token;
+         Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE
+
+         if Token = Tok_Identifier then
+            Def_Unit := P_Defining_Program_Unit_Name;
+
+            Check_Misspelling_Of (Tok_Renames);
+
+            if Token = Tok_Renames then
+               if Ren_Token = Tok_Package then
+                  Decl_Node := New_Node
+                    (N_Generic_Package_Renaming_Declaration, Gen_Sloc);
+
+               elsif Ren_Token = Tok_Procedure then
+                  Decl_Node := New_Node
+                    (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc);
+
+               else -- Ren_Token = Tok_Function then
+                  Decl_Node := New_Node
+                    (N_Generic_Function_Renaming_Declaration, Gen_Sloc);
+               end if;
+
+               Scan; -- past RENAMES
+               Set_Defining_Unit_Name (Decl_Node, Def_Unit);
+               Set_Name (Decl_Node, P_Name);
+               TF_Semicolon;
+               return Decl_Node;
+            end if;
+         end if;
+      end if;
+
+      --  Fall through if this is *not* a generic renaming declaration
+
+      Restore_Scan_State (Scan_State);
+      Decls := New_List;
+
+      --  Loop through generic parameter declarations and use clauses
+
+      Decl_Loop : loop
+         P_Pragmas_Opt (Decls);
+         Ignore (Tok_Private);
+
+         if Token = Tok_Use then
+            Append (P_Use_Clause, Decls);
+         else
+            --  Parse a generic parameter declaration
+
+            if Token = Tok_Identifier then
+               P_Formal_Object_Declarations (Decls);
+
+            elsif Token = Tok_Type then
+               Append (P_Formal_Type_Declaration, Decls);
+
+            elsif Token = Tok_With then
+               Scan; -- past WITH
+
+               if Token = Tok_Package then
+                  Append (P_Formal_Package_Declaration, Decls);
+
+               elsif Token = Tok_Procedure or Token = Tok_Function then
+                  Append (P_Formal_Subprogram_Declaration, Decls);
+
+               else
+                  Error_Msg_BC
+                    ("FUNCTION, PROCEDURE or PACKAGE expected here");
+                  Resync_Past_Semicolon;
+               end if;
+
+            elsif Token = Tok_Subtype then
+               Error_Msg_SC ("subtype declaration not allowed " &
+                                "as generic parameter declaration!");
+               Resync_Past_Semicolon;
+
+            else
+               exit Decl_Loop;
+            end if;
+         end if;
+
+      end loop Decl_Loop;
+
+      --  Generic formal part is scanned, scan out subprogram or package spec
+
+      if Token = Tok_Package then
+         Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc);
+         Set_Specification (Gen_Decl, P_Package (Pf_Spcn));
+      else
+         Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
+         Set_Specification (Gen_Decl, P_Subprogram_Specification);
+         TF_Semicolon;
+      end if;
+
+      Set_Generic_Formal_Declarations (Gen_Decl, Decls);
+      return Gen_Decl;
+   end P_Generic;
+
+   -------------------------------
+   -- 12.1  Generic Declaration --
+   -------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ------------------------------------------
+   -- 12.1  Generic Subprogram Declaration --
+   ------------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ---------------------------------------
+   -- 12.1  Generic Package Declaration --
+   ---------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   -------------------------------
+   -- 12.1  Generic Formal Part --
+   -------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   -------------------------------------------------
+   -- 12.1   Generic Formal Parameter Declaration --
+   -------------------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+   ---------------------------------
+   -- 12.3  Generic Instantiation --
+   ---------------------------------
+
+   --  Generic package instantiation parsed by P_Package (7.1)
+   --  Generic procedure instantiation parsed by P_Subprogram (6.1)
+   --  Generic function instantiation parsed by P_Subprogram (6.1)
+
+   -------------------------------
+   -- 12.3  Generic Actual Part --
+   -------------------------------
+
+   --  GENERIC_ACTUAL_PART ::=
+   --    (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION})
+
+   --  Returns a list of generic associations, or Empty if none are present
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Generic_Actual_Part_Opt return List_Id is
+      Association_List : List_Id;
+
+   begin
+      --  Figure out if a generic actual part operation is present. Clearly
+      --  there is no generic actual part if the current token is semicolon
+
+      if Token = Tok_Semicolon then
+         return No_List;
+
+      --  If we don't have a left paren, then we have an error, and the job
+      --  is to figure out whether a left paren or semicolon was intended.
+      --  We assume a missing left paren (and hence a generic actual part
+      --  present) if the current token is not on a new line, or if it is
+      --  indented from the subprogram token. Otherwise assume missing
+      --  semicolon (which will be diagnosed by caller) and no generic part
+
+      elsif Token /= Tok_Left_Paren
+        and then Token_Is_At_Start_Of_Line
+        and then Start_Column <= Scope.Table (Scope.Last).Ecol
+      then
+         return No_List;
+
+      --  Otherwise we have a generic actual part (either a left paren is
+      --  present, or we have decided that there must be a missing left paren)
+
+      else
+         Association_List := New_List;
+         T_Left_Paren;
+
+         loop
+            Append (P_Generic_Association, Association_List);
+            exit when not Comma_Present;
+         end loop;
+
+         T_Right_Paren;
+         return Association_List;
+      end if;
+
+   end P_Generic_Actual_Part_Opt;
+
+   -------------------------------
+   -- 12.3  Generic Association --
+   -------------------------------
+
+   --  GENERIC_ASSOCIATION ::=
+   --    [generic_formal_parameter_SELECTOR_NAME =>]
+   --      EXPLICIT_GENERIC_ACTUAL_PARAMETER
+
+   --  EXPLICIT_GENERIC_ACTUAL_PARAMETER ::=
+   --    EXPRESSION      | variable_NAME   | subprogram_NAME
+   --  | entry_NAME      | SUBTYPE_MARK    | package_instance_NAME
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Generic_Association return Node_Id is
+      Scan_State         : Saved_Scan_State;
+      Param_Name_Node    : Node_Id;
+      Generic_Assoc_Node : Node_Id;
+
+   begin
+      Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr);
+
+      if Token in Token_Class_Desig then
+         Param_Name_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at designator
+         Scan; -- past simple name or operator symbol
+
+         if Token = Tok_Arrow then
+            Scan; -- past arrow
+            Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node);
+         else
+            Restore_Scan_State (Scan_State); -- to designator
+         end if;
+      end if;
+
+      Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, P_Expression);
+      return Generic_Assoc_Node;
+   end P_Generic_Association;
+
+   ---------------------------------------------
+   -- 12.3  Explicit Generic Actual Parameter --
+   ---------------------------------------------
+
+   --  Parsed by P_Generic_Association (12.3)
+
+   --------------------------------------
+   -- 12.4  Formal Object Declarations --
+   --------------------------------------
+
+   --  FORMAL_OBJECT_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST :
+   --      MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION];
+
+   --  The caller has checked that the initial token is an identifier
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure P_Formal_Object_Declarations (Decls : List_Id) is
+      Decl_Node  : Node_Id;
+      Scan_State : Saved_Scan_State;
+      Num_Idents : Nat;
+      Ident      : Nat;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  This array holds the list of defining identifiers. The upper bound
+      --  of 4096 is intended to be essentially infinite, and we do not even
+      --  bother to check for it being exceeded.
+
+   begin
+      Idents (1) := P_Defining_Identifier;
+      Num_Idents := 1;
+
+      while Comma_Present loop
+         Num_Idents := Num_Idents + 1;
+         Idents (Num_Idents) := P_Defining_Identifier;
+      end loop;
+
+      T_Colon;
+
+      --  If there are multiple identifiers, we repeatedly scan the
+      --  type and initialization expression information by resetting
+      --  the scan pointer (so that we get completely separate trees
+      --  for each occurrence).
+
+      if Num_Idents > 1 then
+         Save_Scan_State (Scan_State);
+      end if;
+
+      --  Loop through defining identifiers in list
+
+      Ident := 1;
+      Ident_Loop : loop
+         Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr);
+         Set_Defining_Identifier (Decl_Node, Idents (Ident));
+         P_Mode (Decl_Node);
+         Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync);
+         No_Constraint;
+         Set_Expression (Decl_Node, Init_Expr_Opt);
+
+         if Ident > 1 then
+            Set_Prev_Ids (Decl_Node, True);
+         end if;
+
+         if Ident < Num_Idents then
+            Set_More_Ids (Decl_Node, True);
+         end if;
+
+         Append (Decl_Node, Decls);
+
+         exit Ident_Loop when Ident = Num_Idents;
+         Ident := Ident + 1;
+         Restore_Scan_State (Scan_State);
+      end loop Ident_Loop;
+
+      TF_Semicolon;
+   end P_Formal_Object_Declarations;
+
+   -----------------------------------
+   -- 12.5  Formal Type Declaration --
+   -----------------------------------
+
+   --  FORMAL_TYPE_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+   --      is FORMAL_TYPE_DEFINITION;
+
+   --  The caller has checked that the initial token is TYPE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Type_Declaration return Node_Id is
+      Decl_Node  : Node_Id;
+
+   begin
+      Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr);
+      Scan; -- past TYPE
+      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
+
+      if P_Unknown_Discriminant_Part_Opt then
+         Set_Unknown_Discriminants_Present (Decl_Node, True);
+      else
+         Set_Discriminant_Specifications
+           (Decl_Node, P_Known_Discriminant_Part_Opt);
+      end if;
+
+      T_Is;
+
+      Set_Formal_Type_Definition (Decl_Node, P_Formal_Type_Definition);
+      TF_Semicolon;
+      return Decl_Node;
+   end P_Formal_Type_Declaration;
+
+   ----------------------------------
+   -- 12.5  Formal Type Definition --
+   ----------------------------------
+
+   --  FORMAL_TYPE_DEFINITION ::=
+   --    FORMAL_PRIVATE_TYPE_DEFINITION
+   --  | FORMAL_DERIVED_TYPE_DEFINITION
+   --  | FORMAL_DISCRETE_TYPE_DEFINITION
+   --  | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION
+   --  | FORMAL_MODULAR_TYPE_DEFINITION
+   --  | FORMAL_FLOATING_POINT_DEFINITION
+   --  | FORMAL_ORDINARY_FIXED_POINT_DEFINITION
+   --  | FORMAL_DECIMAL_FIXED_POINT_DEFINITION
+   --  | FORMAL_ARRAY_TYPE_DEFINITION
+   --  | FORMAL_ACCESS_TYPE_DEFINITION
+
+   --  FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION
+
+   --  FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION
+
+   function P_Formal_Type_Definition return Node_Id is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token_Name = Name_Abstract then
+         Check_95_Keyword (Tok_Abstract, Tok_Tagged);
+      end if;
+
+      if Token_Name = Name_Tagged then
+         Check_95_Keyword (Tok_Tagged, Tok_Private);
+         Check_95_Keyword (Tok_Tagged, Tok_Limited);
+      end if;
+
+      case Token is
+
+         --  Mostly we can tell what we have from the initial token. The one
+         --  exception is ABSTRACT, where we have to scan ahead to see if we
+         --  have a formal derived type or a formal private type definition.
+
+         when Tok_Abstract =>
+            Save_Scan_State (Scan_State);
+            Scan; -- past ABSTRACT
+
+            if Token = Tok_New then
+               Restore_Scan_State (Scan_State); -- to ABSTRACT
+               return P_Formal_Derived_Type_Definition;
+
+            else
+               Restore_Scan_State (Scan_State); -- to ABSTRACT
+               return P_Formal_Private_Type_Definition;
+            end if;
+
+         when Tok_Private | Tok_Limited | Tok_Tagged =>
+            return P_Formal_Private_Type_Definition;
+
+         when Tok_New =>
+            return P_Formal_Derived_Type_Definition;
+
+         when Tok_Left_Paren =>
+            return P_Formal_Discrete_Type_Definition;
+
+         when Tok_Range =>
+            return P_Formal_Signed_Integer_Type_Definition;
+
+         when Tok_Mod =>
+            return P_Formal_Modular_Type_Definition;
+
+         when Tok_Digits =>
+            return P_Formal_Floating_Point_Definition;
+
+         when Tok_Delta =>
+            return P_Formal_Fixed_Point_Definition;
+
+         when Tok_Array =>
+            return P_Array_Type_Definition;
+
+         when Tok_Access =>
+            return P_Access_Type_Definition;
+
+         when Tok_Record =>
+            Error_Msg_SC ("record not allowed in generic type definition!");
+            Discard_Junk_Node (P_Record_Definition);
+            return Error;
+
+         when others =>
+            Error_Msg_BC ("expecting generic type definition here");
+            Resync_Past_Semicolon;
+            return Error;
+
+      end case;
+   end P_Formal_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.1  Formal Private Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_PRIVATE_TYPE_DEFINITION ::=
+   --    [[abstract] tagged] [limited] private
+
+   --  The caller has checked the initial token is PRIVATE, ABSTRACT,
+   --   TAGGED or LIMITED
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Private_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr);
+
+      if Token = Tok_Abstract then
+         Scan; -- past ABSTRACT
+
+         if Token_Name = Name_Tagged then
+            Check_95_Keyword (Tok_Tagged, Tok_Private);
+            Check_95_Keyword (Tok_Tagged, Tok_Limited);
+         end if;
+
+         if Token /= Tok_Tagged then
+            Error_Msg_SP ("ABSTRACT must be followed by TAGGED");
+         else
+            Set_Abstract_Present (Def_Node, True);
+         end if;
+      end if;
+
+      if Token = Tok_Tagged then
+         Set_Tagged_Present (Def_Node, True);
+         Scan; -- past TAGGED
+      end if;
+
+      if Token = Tok_Limited then
+         Set_Limited_Present (Def_Node, True);
+         Scan; -- past LIMITED
+      end if;
+
+      Set_Sloc (Def_Node, Token_Ptr);
+      T_Private;
+      return Def_Node;
+   end P_Formal_Private_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.1  Formal Derived Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_DERIVED_TYPE_DEFINITION ::=
+   --    [abstract] new SUBTYPE_MARK [with private]
+
+   --  The caller has checked the initial token(s) is/are NEW or ASTRACT NEW
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Derived_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr);
+
+      if Token = Tok_Abstract then
+         Set_Abstract_Present (Def_Node);
+         Scan; -- past ABSTRACT
+      end if;
+
+      Scan; -- past NEW;
+      Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+      No_Constraint;
+
+      if Token = Tok_With then
+         Scan; -- past WITH
+         Set_Private_Present (Def_Node, True);
+         T_Private;
+      end if;
+
+      return Def_Node;
+   end P_Formal_Derived_Type_Definition;
+
+   ---------------------------------------------
+   -- 12.5.2  Formal Discrete Type Definition --
+   ---------------------------------------------
+
+   --  FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>)
+
+   --  The caller has checked the initial token is left paren
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Discrete_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr);
+      Scan; -- past left paren
+      T_Box;
+      T_Right_Paren;
+      return Def_Node;
+   end P_Formal_Discrete_Type_Definition;
+
+   ---------------------------------------------------
+   -- 12.5.2  Formal Signed Integer Type Definition --
+   ---------------------------------------------------
+
+   --  FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <>
+
+   --  The caller has checked the initial token is RANGE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Signed_Integer_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr);
+      Scan; -- past RANGE
+      T_Box;
+      return Def_Node;
+   end P_Formal_Signed_Integer_Type_Definition;
+
+   --------------------------------------------
+   -- 12.5.2  Formal Modular Type Definition --
+   --------------------------------------------
+
+   --  FORMAL_MODULAR_TYPE_DEFINITION ::= mod <>
+
+   --  The caller has checked the initial token is MOD
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Modular_Type_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Modular_Type_Definition, Token_Ptr);
+      Scan; -- past MOD
+      T_Box;
+      return Def_Node;
+   end P_Formal_Modular_Type_Definition;
+
+   ----------------------------------------------
+   -- 12.5.2  Formal Floating Point Definition --
+   ----------------------------------------------
+
+   --  FORMAL_FLOATING_POINT_DEFINITION ::= digits <>
+
+   --  The caller has checked the initial token is DIGITS
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Floating_Point_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node :=
+        New_Node (N_Formal_Floating_Point_Definition, Token_Ptr);
+      Scan; -- past DIGITS
+      T_Box;
+      return Def_Node;
+   end P_Formal_Floating_Point_Definition;
+
+   -------------------------------------------
+   -- 12.5.2  Formal Fixed Point Definition --
+   -------------------------------------------
+
+   --  This routine parses either a formal ordinary fixed point definition
+   --  or a formal decimal fixed point definition:
+
+   --  FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <>
+
+   --  FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <>
+
+   --  The caller has checked the initial token is DELTA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Fixed_Point_Definition return Node_Id is
+      Def_Node   : Node_Id;
+      Delta_Sloc : Source_Ptr;
+
+   begin
+      Delta_Sloc := Token_Ptr;
+      Scan; -- past DELTA
+      T_Box;
+
+      if Token = Tok_Digits then
+         Def_Node :=
+           New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc);
+         Scan; -- past DIGITS
+         T_Box;
+      else
+         Def_Node :=
+           New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc);
+      end if;
+
+      return Def_Node;
+   end P_Formal_Fixed_Point_Definition;
+
+   ----------------------------------------------------
+   -- 12.5.2  Formal Ordinary Fixed Point Definition --
+   ----------------------------------------------------
+
+   --  Parsed by P_Formal_Fixed_Point_Definition (12.5.2)
+
+   ---------------------------------------------------
+   -- 12.5.2  Formal Decimal Fixed Point Definition --
+   ---------------------------------------------------
+
+   --  Parsed by P_Formal_Fixed_Point_Definition (12.5.2)
+
+   ------------------------------------------
+   -- 12.5.3  Formal Array Type Definition --
+   ------------------------------------------
+
+   --  Parsed by P_Formal_Type_Definition (12.5)
+
+   -------------------------------------------
+   -- 12.5.4  Formal Access Type Definition --
+   -------------------------------------------
+
+   --  Parsed by P_Formal_Type_Definition (12.5)
+
+   -----------------------------------------
+   -- 12.6  Formal Subprogram Declaration --
+   -----------------------------------------
+
+   --  FORMAL_SUBPROGRAM_DECLARATION ::=
+   --    with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT];
+
+   --  SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
+
+   --  DEFAULT_NAME ::= NAME
+
+   --  The caller has checked that the initial tokens are WITH FUNCTION or
+   --  WITH PROCEDURE, and the initial WITH has been scanned out.
+
+   --  Note: we separate this into two procedures because the name is allowed
+   --  to be an operator symbol for a function, but not for a procedure.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Subprogram_Declaration return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Formal_Subprogram_Declaration, Prev_Token_Ptr);
+      Set_Specification (Def_Node, P_Subprogram_Specification);
+
+      if Token = Tok_Is then
+         T_Is; -- past IS, skip extra IS or ";"
+
+         if Token = Tok_Box then
+            Set_Box_Present (Def_Node, True);
+            Scan; -- past <>
+
+         else
+            Set_Default_Name (Def_Node, P_Name);
+         end if;
+
+      end if;
+
+      T_Semicolon;
+      return Def_Node;
+   end P_Formal_Subprogram_Declaration;
+
+   ------------------------------
+   -- 12.6  Subprogram Default --
+   ------------------------------
+
+   --  Parsed by P_Formal_Procedure_Declaration (12.6)
+
+   ------------------------
+   -- 12.6  Default Name --
+   ------------------------
+
+   --  Parsed by P_Formal_Procedure_Declaration (12.6)
+
+   --------------------------------------
+   -- 12.7  Formal Package Declaration --
+   --------------------------------------
+
+   --  FORMAL_PACKAGE_DECLARATION ::=
+   --    with package DEFINING_IDENTIFIER
+   --      is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART;
+
+   --  FORMAL_PACKAGE_ACTUAL_PART ::=
+   --    (<>) | [GENERIC_ACTUAL_PART]
+
+   --  The caller has checked that the initial tokens are WITH PACKAGE,
+   --  and the initial WITH has been scanned out (so Token = Tok_Package).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Package_Declaration return Node_Id is
+      Def_Node : Node_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr);
+      Scan; -- past PACKAGE
+      Set_Defining_Identifier (Def_Node, P_Defining_Identifier);
+      T_Is;
+      T_New;
+      Set_Name (Def_Node, P_Qualified_Simple_Name);
+
+      if Token = Tok_Left_Paren then
+         Save_Scan_State (Scan_State); -- at the left paren
+         Scan; -- past the left paren
+
+         if Token = Tok_Box then
+            Set_Box_Present (Def_Node, True);
+            Scan; -- past box
+            T_Right_Paren;
+
+         else
+            Restore_Scan_State (Scan_State); -- to the left paren
+            Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt);
+         end if;
+      end if;
+
+      T_Semicolon;
+      return Def_Node;
+   end P_Formal_Package_Declaration;
+
+   --------------------------------------
+   -- 12.7  Formal Package Actual Part --
+   --------------------------------------
+
+   --  Parsed by P_Formal_Package_Declaration (12.7)
+
+end Ch12;
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
new file mode 100644
index 0000000..03bd7bf
--- /dev/null
+++ b/gcc/ada/par-ch13.adb
@@ -0,0 +1,441 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . C H 1 3                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.34 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch13 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Component_Clause return Node_Id;
+   function P_Mod_Clause return Node_Id;
+
+   --------------------------------------------
+   -- 13.1  Representation Clause (also I.7) --
+   --------------------------------------------
+
+   --  REPRESENTATION_CLAUSE ::=
+   --    ATTRIBUTE_DEFINITION_CLAUSE
+   --  | ENUMERATION_REPRESENTATION_CLAUSE
+   --  | RECORD_REPRESENTATION_CLAUSE
+   --  | AT_CLAUSE
+
+   --  ATTRIBUTE_DEFINITION_CLAUSE ::=
+   --    for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION;
+   --  | for LOCAL_NAME'ATTRIBUTE_DESIGNATOR use NAME;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  ENUMERATION_REPRESENTATION_CLAUSE ::=
+   --    for first_subtype_LOCAL_NAME use ENUMERATION_AGGREGATE;
+
+   --  ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE
+
+   --  RECORD_REPRESENTATION_CLAUSE ::=
+   --    for first_subtype_LOCAL_NAME use
+   --      record [MOD_CLAUSE]
+   --        {COMPONENT_CLAUSE}
+   --      end record;
+
+   --  Note: for now we allow only a direct name as the local name in the
+   --  above constructs. This probably needs changing later on ???
+
+   --  The caller has checked that the initial token is FOR
+
+   --  Error recovery: cannot raise Error_Resync, if an error occurs,
+   --  the scan is repositioned past the next semicolon.
+
+   function P_Representation_Clause return Node_Id is
+      For_Loc         : Source_Ptr;
+      Name_Node       : Node_Id;
+      Prefix_Node     : Node_Id;
+      Attr_Name       : Name_Id;
+      Identifier_Node : Node_Id;
+      Rep_Clause_Node : Node_Id;
+      Expr_Node       : Node_Id;
+      Record_Items    : List_Id;
+
+   begin
+      For_Loc := Token_Ptr;
+      Scan; -- past FOR
+
+      --  Note that the name in a representation clause is always a simple
+      --  name, even in the attribute case, see AI-300 which made this so!
+
+      Identifier_Node := P_Identifier;
+
+      --  Check case of qualified name to give good error message
+
+      if Token = Tok_Dot then
+         Error_Msg_SC
+            ("representation clause requires simple name!");
+
+         loop
+            exit when Token /= Tok_Dot;
+            Scan; -- past dot
+            Discard_Junk_Node (P_Identifier);
+         end loop;
+      end if;
+
+      --  Attribute Definition Clause
+
+      if Token = Tok_Apostrophe then
+
+         --  Allow local names of the form a'b'.... This enables
+         --  us to parse class-wide streams attributes correctly.
+
+         Name_Node := Identifier_Node;
+         while Token = Tok_Apostrophe loop
+
+            Scan; -- past apostrophe
+
+            Identifier_Node := Token_Node;
+            Attr_Name := No_Name;
+
+            if Token = Tok_Identifier then
+               Attr_Name := Token_Name;
+
+               if not Is_Attribute_Name (Attr_Name) then
+                  Signal_Bad_Attribute;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (False);
+               end if;
+
+            --  Here for case of attribute designator is not an identifier
+
+            else
+               if Token = Tok_Delta then
+                  Attr_Name := Name_Delta;
+
+               elsif Token = Tok_Digits then
+                  Attr_Name := Name_Digits;
+
+               elsif Token = Tok_Access then
+                  Attr_Name := Name_Access;
+
+               else
+                  Error_Msg_AP ("attribute designator expected");
+                  raise Error_Resync;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (True);
+               end if;
+            end if;
+
+            --  We come here with an OK attribute scanned, and the
+            --  corresponding Attribute identifier node stored in Ident_Node.
+
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Attribute_Name (Name_Node, Attr_Name);
+            Scan;
+         end loop;
+
+         Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc);
+         Set_Name (Rep_Clause_Node, Prefix_Node);
+         Set_Chars (Rep_Clause_Node, Attr_Name);
+         T_Use;
+
+         Expr_Node := P_Expression_No_Right_Paren;
+         Check_Simple_Expression_In_Ada_83 (Expr_Node);
+         Set_Expression (Rep_Clause_Node, Expr_Node);
+
+      else
+         TF_Use;
+         Rep_Clause_Node := Empty;
+
+         --  AT follows USE (At Clause)
+
+         if Token = Tok_At then
+            Scan; -- past AT
+            Rep_Clause_Node := New_Node (N_At_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+            Expr_Node := P_Expression_No_Right_Paren;
+            Check_Simple_Expression_In_Ada_83 (Expr_Node);
+            Set_Expression (Rep_Clause_Node, Expr_Node);
+
+         --  RECORD follows USE (Record Representation Clause)
+
+         elsif Token = Tok_Record then
+            Record_Items := P_Pragmas_Opt;
+            Rep_Clause_Node :=
+              New_Node (N_Record_Representation_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+
+            Push_Scope_Stack;
+            Scope.Table (Scope.Last).Etyp := E_Record;
+            Scope.Table (Scope.Last).Ecol := Start_Column;
+            Scope.Table (Scope.Last).Sloc := Token_Ptr;
+            Scan; -- past RECORD
+            Record_Items := P_Pragmas_Opt;
+
+            --  Possible Mod Clause
+
+            if Token = Tok_At then
+               Set_Mod_Clause (Rep_Clause_Node, P_Mod_Clause);
+               Set_Pragmas_Before (Mod_Clause (Rep_Clause_Node), Record_Items);
+               Record_Items := P_Pragmas_Opt;
+            end if;
+
+            if No (Record_Items) then
+               Record_Items := New_List;
+            end if;
+
+            Set_Component_Clauses (Rep_Clause_Node, Record_Items);
+
+            --  Loop through component clauses
+
+            loop
+               if Token not in Token_Class_Name then
+                  exit when Check_End;
+               end if;
+
+               Append (P_Component_Clause, Record_Items);
+               P_Pragmas_Opt (Record_Items);
+            end loop;
+
+         --  Left paren follows USE (Enumeration Representation Clause)
+
+         elsif Token = Tok_Left_Paren then
+            Rep_Clause_Node :=
+              New_Node (N_Enumeration_Representation_Clause, For_Loc);
+            Set_Identifier (Rep_Clause_Node, Identifier_Node);
+            Set_Array_Aggregate (Rep_Clause_Node, P_Aggregate);
+
+         --  Some other token follows FOR (invalid representation clause)
+
+         else
+            Error_Msg_SC ("invalid representation clause");
+            raise Error_Resync;
+         end if;
+      end if;
+
+      TF_Semicolon;
+      return Rep_Clause_Node;
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         return Error;
+
+   end P_Representation_Clause;
+
+   ----------------------
+   -- 13.1  Local Name --
+   ----------------------
+
+   --  Local name is always parsed by its parent. In the case of its use in
+   --  pragmas, the check for a local name is handled in Par.Prag and allows
+   --  all the possible forms of local name. For the uses in chapter 13, we
+   --  currently only allow a direct name, but this should probably change???
+
+   ---------------------------
+   -- 13.1  At Clause (I.7) --
+   ---------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------------
+   -- 13.3  Attribute Definition Clause --
+   ---------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------------------
+   -- 13.4  Enumeration Representation Clause --
+   ---------------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ---------------------------------
+   -- 13.4  Enumeration Aggregate --
+   ---------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ------------------------------------------
+   -- 13.5.1  Record Representation Clause --
+   ------------------------------------------
+
+   --  Parsed by P_Representation_Clause (13.1)
+
+   ------------------------------
+   -- 13.5.1  Mod Clause (I.8) --
+   ------------------------------
+
+   --  MOD_CLAUSE ::= at mod static_EXPRESSION;
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  The caller has checked that the initial Token is AT
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  Note: the caller is responsible for setting the Pragmas_Before field
+
+   function P_Mod_Clause return Node_Id is
+      Mod_Node  : Node_Id;
+      Expr_Node : Node_Id;
+
+   begin
+      Mod_Node := New_Node (N_Mod_Clause, Token_Ptr);
+      Scan; -- past AT
+      T_Mod;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Expression (Mod_Node, Expr_Node);
+      TF_Semicolon;
+      return Mod_Node;
+   end P_Mod_Clause;
+
+   ------------------------------
+   -- 13.5.1  Component Clause --
+   ------------------------------
+
+   --  COMPONENT_CLAUSE ::=
+   --    COMPONENT_CLAUSE_COMPONENT_NAME at POSITION
+   --      range FIRST_BIT .. LAST_BIT;
+
+   --  COMPONENT_CLAUSE_COMPONENT_NAME ::=
+   --    component_DIRECT_NAME
+   --  | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+   --  | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR
+
+   --  POSITION ::= static_EXPRESSION
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  FIRST_BIT ::= static_SIMPLE_EXPRESSION
+   --  LAST_BIT ::= static_SIMPLE_EXPRESSION
+
+   --  Note: the AARM V2.0 grammar has an error at this point, it uses
+   --  EXPRESSION instead of SIMPLE_EXPRESSION for FIRST_BIT and LAST_BIT
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Component_Clause return Node_Id is
+      Component_Node : Node_Id;
+      Comp_Name      : Node_Id;
+      Expr_Node      : Node_Id;
+
+   begin
+      Component_Node := New_Node (N_Component_Clause, Token_Ptr);
+      Comp_Name := P_Name;
+
+      if Nkind (Comp_Name) = N_Identifier
+        or else Nkind (Comp_Name) = N_Attribute_Reference
+      then
+         Set_Component_Name (Component_Node, Comp_Name);
+      else
+         Error_Msg_N
+           ("component name must be direct name or attribute", Comp_Name);
+         Set_Component_Name (Component_Node, Error);
+      end if;
+
+      Set_Sloc (Component_Node, Token_Ptr);
+      T_At;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Position (Component_Node, Expr_Node);
+      T_Range;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_First_Bit (Component_Node, Expr_Node);
+      T_Dot_Dot;
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Last_Bit (Component_Node, Expr_Node);
+      TF_Semicolon;
+      return Component_Node;
+   end P_Component_Clause;
+
+   ----------------------
+   -- 13.5.1  Position --
+   ----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   -----------------------
+   -- 13.5.1  First Bit --
+   -----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   ----------------------
+   -- 13.5.1  Last Bit --
+   ----------------------
+
+   --  Parsed by P_Component_Clause (13.5.1)
+
+   --------------------------
+   -- 13.8  Code Statement --
+   --------------------------
+
+   --  CODE_STATEMENT ::= QUALIFIED_EXPRESSION
+
+   --  On entry the caller has scanned the SUBTYPE_MARK (passed in as the
+   --  single argument, and the scan points to the apostrophe.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id is
+      Node1 : Node_Id;
+
+   begin
+      Scan; -- past apostrophe
+
+      --  If left paren, then we have a possible code statement
+
+      if Token = Tok_Left_Paren then
+         Node1 := New_Node (N_Code_Statement, Sloc (Subtype_Mark));
+         Set_Expression (Node1, P_Qualified_Expression (Subtype_Mark));
+         TF_Semicolon;
+         return Node1;
+
+      --  Otherwise we have an illegal range attribute. Note that P_Name
+      --  ensures that Token = Tok_Range is the only possibility left here.
+
+      else -- Token = Tok_Range
+         Error_Msg_SC ("RANGE attribute illegal here!");
+         raise Error_Resync;
+      end if;
+
+   end P_Code_Statement;
+
+end Ch13;
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
new file mode 100644
index 0000000..0eeacea
--- /dev/null
+++ b/gcc/ada/par-ch2.adb
@@ -0,0 +1,405 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 2                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.35 $                             --
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch2 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Pragma_Argument_Association return Node_Id;
+
+   ---------------------
+   -- 2.3  Identifier --
+   ---------------------
+
+   --  IDENTIFIER ::= LETTER {[UNDERLINE] LETTER_OR_DIGIT}
+
+   --  LETTER_OR_DIGIT ::= IDENTIFIER_LETTER | DIGIT
+
+   --  An IDENTIFIER shall not be a reserved word
+
+   --  Error recovery: can raise Error_Resync (cannot return Error)
+
+   function P_Identifier return Node_Id is
+      Ident_Node : Node_Id;
+
+   begin
+      --  All set if we do indeed have an identifier
+
+      if Token = Tok_Identifier then
+         Ident_Node := Token_Node;
+         Scan; -- past Identifier
+         return Ident_Node;
+
+      --  If we have a reserved identifier, manufacture an identifier with
+      --  a corresponding name after posting an appropriate error message
+
+      elsif Is_Reserved_Identifier then
+         Scan_Reserved_Identifier (Force_Msg => False);
+         Ident_Node := Token_Node;
+         Scan; -- past the node
+         return Ident_Node;
+
+      --  Otherwise we have junk that cannot be interpreted as an identifier
+
+      else
+         T_Identifier; -- to give message
+         raise Error_Resync;
+      end if;
+   end P_Identifier;
+
+   --------------------------
+   -- 2.3  Letter Or Digit --
+   --------------------------
+
+   --  Parsed by P_Identifier (2.3)
+
+   --------------------------
+   -- 2.4  Numeric Literal --
+   --------------------------
+
+   --  NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL
+
+   --  Numeric literal is returned by the scanner as either
+   --  Tok_Integer_Literal or Tok_Real_Literal
+
+   ----------------------------
+   -- 2.4.1  Decimal Literal --
+   ----------------------------
+
+   --  DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT]
+
+   --  Handled by scanner as part of numeric lIteral handing (see 2.4)
+
+   --------------------
+   -- 2.4.1  Numeral --
+   --------------------
+
+   --  NUMERAL ::= DIGIT {[UNDERLINE] DIGIT}
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ---------------------
+   -- 2.4.1  Exponent --
+   ---------------------
+
+   --  EXPONENT ::= E [+] NUMERAL | E - NUMERAL
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   --------------------------
+   -- 2.4.2  Based Literal --
+   --------------------------
+
+   --  BASED_LITERAL ::=
+   --   BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT]
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   -----------------
+   -- 2.4.2  Base --
+   -----------------
+
+   --  BASE ::= NUMERAL
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   --------------------------
+   -- 2.4.2  Based Numeral --
+   --------------------------
+
+   --  BASED_NUMERAL ::=
+   --    EXTENDED_DIGIT {[UNDERLINE] EXTENDED_DIGIT}
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ---------------------------
+   -- 2.4.2  Extended Digit --
+   ---------------------------
+
+   --  EXTENDED_DIGIT ::= DIGIT | A | B | C | D | E | F
+
+   --  Handled by scanner as part of numeric literal handling (see 2.4)
+
+   ----------------------------
+   -- 2.5  Character Literal --
+   ----------------------------
+
+   --  CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
+
+   --  Handled by the scanner and returned as Tok_Character_Literal
+
+   -------------------------
+   -- 2.6  String Literal --
+   -------------------------
+
+   --  STRING LITERAL ::= "{STRING_ELEMENT}"
+
+   --  Handled by the scanner and returned as Tok_Character_Literal
+   --  or if the string looks like an operator as Tok_Operator_Symbol.
+
+   -------------------------
+   -- 2.6  String Element --
+   -------------------------
+
+   --  STRING_ELEMENT ::= "" | non-quotation_mark_GRAPHIC_CHARACTER
+
+   --  A STRING_ELEMENT is either a pair of quotation marks ("),
+   --  or a single GRAPHIC_CHARACTER other than a quotation mark.
+
+   --  Handled by scanner as part of string literal handling (see 2.4)
+
+   ------------------
+   -- 2.7  Comment --
+   ------------------
+
+   --  A COMMENT starts with two adjacent hyphens and extends up to the
+   --  end of the line. A COMMENT may appear on any line of a program.
+
+   --  Handled by the scanner which simply skips past encountered comments
+
+   -----------------
+   -- 2.8  Pragma --
+   -----------------
+
+   --  PRAGMA ::= pragma IDENTIFIER
+   --    [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})];
+
+   --  The caller has checked that the initial token is PRAGMA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  One special piece of processing is needed in this routine. As described
+   --  in the section on "Handling semicolon used in place of IS" in module
+   --  Parse, the parser detects the case of missing subprogram bodies to
+   --  allow recovery from this syntactic error. Pragma INTERFACE (and, for
+   --  Ada 95, pragma IMPORT) can appear in place of the body. The parser must
+   --  recognize the use of these two pragmas in this context, otherwise it
+   --  will think there are missing bodies, and try to change ; to IS, when
+   --  in fact the bodies ARE present, supplied by these pragmas.
+
+   function P_Pragma return Node_Id is
+
+      Interface_Check_Required : Boolean := False;
+      --  Set True if check of pragma INTERFACE is required
+
+      Import_Check_Required : Boolean := False;
+      --  Set True if check of pragma IMPORT is required
+
+      Arg_Count : Int := 0;
+      --  Number of argument associations processed
+
+      Pragma_Node   : Node_Id;
+      Pragma_Name   : Name_Id;
+      Semicolon_Loc : Source_Ptr;
+      Ident_Node    : Node_Id;
+      Assoc_Node    : Node_Id;
+
+   begin
+      Pragma_Node := New_Node (N_Pragma, Token_Ptr);
+      Scan; -- past PRAGMA
+      Pragma_Name := Token_Name;
+
+      if Style_Check then
+         Style.Check_Pragma_Name;
+      end if;
+
+      Ident_Node := P_Identifier;
+      Set_Chars (Pragma_Node, Pragma_Name);
+      Delete_Node (Ident_Node);
+
+      --  See if special INTERFACE/IMPORT check is required
+
+      if SIS_Entry_Active then
+         Interface_Check_Required := (Pragma_Name = Name_Interface);
+         Import_Check_Required    := (Pragma_Name = Name_Import);
+      else
+         Interface_Check_Required := False;
+         Import_Check_Required    := False;
+      end if;
+
+      --  Scan arguments. We assume that arguments are present if there is
+      --  a left paren, or if a semicolon is missing and there is another
+      --  token on the same line as the pragma name.
+
+      if Token = Tok_Left_Paren
+        or else (Token /= Tok_Semicolon
+                   and then not Token_Is_At_Start_Of_Line)
+      then
+         Set_Pragma_Argument_Associations (Pragma_Node, New_List);
+         T_Left_Paren;
+
+         loop
+            Arg_Count := Arg_Count + 1;
+            Assoc_Node := P_Pragma_Argument_Association;
+
+            if Arg_Count = 2
+              and then (Interface_Check_Required or else Import_Check_Required)
+            then
+               --  Here is where we cancel the SIS active status if this pragma
+               --  supplies a body for the currently active subprogram spec.
+
+               if Nkind (Expression (Assoc_Node)) in N_Direct_Name
+                 and then Chars (Expression (Assoc_Node)) = Chars (SIS_Labl)
+               then
+                  SIS_Entry_Active := False;
+               end if;
+            end if;
+
+            Append (Assoc_Node, Pragma_Argument_Associations (Pragma_Node));
+            exit when Token /= Tok_Comma;
+            Scan; -- past comma
+         end loop;
+
+         T_Right_Paren;
+      end if;
+
+      Semicolon_Loc := Token_Ptr;
+
+      if Token /= Tok_Semicolon then
+         T_Semicolon;
+         Resync_Past_Semicolon;
+      else
+         Scan; -- past semicolon
+      end if;
+
+      if Is_Pragma_Name (Chars (Pragma_Node)) then
+         return Par.Prag (Pragma_Node, Semicolon_Loc);
+
+      else
+         --  Unrecognized pragma, warning generated in Sem_Prag
+
+         return Pragma_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         return Error;
+
+   end P_Pragma;
+
+   --  This routine is called if a pragma is encountered in an inappropriate
+   --  position, the pragma is scanned out and control returns to continue.
+
+   --  The caller has checked that the initial token is pragma
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure P_Pragmas_Misplaced is
+   begin
+      while Token = Tok_Pragma loop
+         Error_Msg_SC ("pragma not allowed here");
+         Discard_Junk_Node (P_Pragma);
+      end loop;
+   end P_Pragmas_Misplaced;
+
+   --  This function is called to scan out an optional sequence of pragmas.
+   --  If no pragmas are found, then No_List is returned.
+
+   --  Error recovery: Cannot raise Error_Resync
+
+   function P_Pragmas_Opt return List_Id is
+      L : List_Id;
+
+   begin
+      if Token = Tok_Pragma then
+         L := New_List;
+         P_Pragmas_Opt (L);
+         return L;
+
+      else
+         return No_List;
+      end if;
+   end P_Pragmas_Opt;
+
+   --  This procedure is called to scan out an optional sequence of pragmas.
+   --  Any pragmas found are appended to the list provided as an argument.
+
+   --  Error recovery: Cannot raise Error_Resync
+
+   procedure P_Pragmas_Opt (List : List_Id) is
+      P : Node_Id;
+
+   begin
+      while Token = Tok_Pragma loop
+         P := P_Pragma;
+
+         if Chars (P) = Name_Assert or else Chars (P) = Name_Debug then
+            Error_Msg_Name_1 := Chars (P);
+            Error_Msg_N
+              ("pragma% must be in declaration/statement context", P);
+         else
+            Append (P, List);
+         end if;
+      end loop;
+   end P_Pragmas_Opt;
+
+   --------------------------------------
+   -- 2.8  Pragma_Argument Association --
+   --------------------------------------
+
+   --  PRAGMA_ARGUMENT_ASSOCIATION ::=
+   --    [pragma_argument_IDENTIFIER =>] NAME
+   --  | [pragma_argument_IDENTIFIER =>] EXPRESSION
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Pragma_Argument_Association return Node_Id is
+      Scan_State      : Saved_Scan_State;
+      Pragma_Arg_Node : Node_Id;
+      Identifier_Node : Node_Id;
+
+   begin
+      Pragma_Arg_Node := New_Node (N_Pragma_Argument_Association, Token_Ptr);
+      Set_Chars (Pragma_Arg_Node, No_Name);
+
+      if Token = Tok_Identifier then
+         Identifier_Node := Token_Node;
+         Save_Scan_State (Scan_State); -- at Identifier
+         Scan; -- past Identifier
+
+         if Token = Tok_Arrow then
+            Scan; -- past arrow
+            Set_Chars (Pragma_Arg_Node, Chars (Identifier_Node));
+            Delete_Node (Identifier_Node);
+         else
+            Restore_Scan_State (Scan_State); -- to Identifier
+         end if;
+      end if;
+
+      Set_Expression (Pragma_Arg_Node, P_Expression);
+      return Pragma_Arg_Node;
+
+   end P_Pragma_Argument_Association;
+
+end Ch2;
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
new file mode 100644
index 0000000..937f02d
--- /dev/null
+++ b/gcc/ada/par-ch3.adb
@@ -0,0 +1,3724 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 3                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.148 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Sinfo.CN; use Sinfo.CN;
+
+separate (Par)
+
+package body Ch3 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function P_Component_List                               return Node_Id;
+   function P_Defining_Character_Literal                   return Node_Id;
+   function P_Delta_Constraint                             return Node_Id;
+   function P_Derived_Type_Def_Or_Private_Ext_Decl         return Node_Id;
+   function P_Digits_Constraint                            return Node_Id;
+   function P_Discriminant_Association                     return Node_Id;
+   function P_Enumeration_Literal_Specification            return Node_Id;
+   function P_Enumeration_Type_Definition                  return Node_Id;
+   function P_Fixed_Point_Definition                       return Node_Id;
+   function P_Floating_Point_Definition                    return Node_Id;
+   function P_Index_Or_Discriminant_Constraint             return Node_Id;
+   function P_Real_Range_Specification_Opt                 return Node_Id;
+   function P_Subtype_Declaration                          return Node_Id;
+   function P_Type_Declaration                             return Node_Id;
+   function P_Modular_Type_Definition                      return Node_Id;
+   function P_Variant                                      return Node_Id;
+   function P_Variant_Part                                 return Node_Id;
+
+   procedure P_Declarative_Items
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean);
+   --  Scans out a single declarative item, or, in the case of a declaration
+   --  with a list of identifiers, a list of declarations, one for each of
+   --  the identifiers in the list. The declaration or declarations scanned
+   --  are appended to the given list. Done indicates whether or not there
+   --  may be additional declarative items to scan. If Done is True, then
+   --  a decision has been made that there are no more items to scan. If
+   --  Done is False, then there may be additional declarations to scan.
+   --  In_Spec is true if we are scanning a package declaration, and is used
+   --  to generate an appropriate message if a statement is encountered in
+   --  such a context.
+
+   procedure P_Identifier_Declarations
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean);
+   --  Scans out a set of declarations for an identifier or list of
+   --  identifiers, and appends them to the given list. The parameters have
+   --  the same significance as for P_Declarative_Items.
+
+   procedure Statement_When_Declaration_Expected
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean);
+   --  Called when a statement is found at a point where a declaration was
+   --  expected. The parameters are as described for P_Declarative_Items.
+
+   procedure Set_Declaration_Expected;
+   --  Posts a "declaration expected" error messages at the start of the
+   --  current token, and if this is the first such message issued, saves
+   --  the message id in Missing_Begin_Msg, for possible later replacement.
+
+   -------------------
+   -- Init_Expr_Opt --
+   -------------------
+
+   function Init_Expr_Opt (P : Boolean := False) return Node_Id is
+   begin
+      if Token = Tok_Colon_Equal
+        or else Token = Tok_Equal
+        or else Token = Tok_Colon
+        or else Token = Tok_Is
+      then
+         null;
+
+      --  One other possibility. If we have a literal followed by a semicolon,
+      --  we assume that we have a missing colon-equal.
+
+      elsif Token in Token_Class_Literal then
+         declare
+            Scan_State : Saved_Scan_State;
+
+         begin
+            Save_Scan_State (Scan_State);
+            Scan; -- past literal or identifier
+
+            if Token = Tok_Semicolon then
+               Restore_Scan_State (Scan_State);
+            else
+               Restore_Scan_State (Scan_State);
+               return Empty;
+            end if;
+         end;
+
+      --  Otherwise we definitely have no initialization expression
+
+      else
+         return Empty;
+      end if;
+
+      --  Merge here if we have an initialization expression
+
+      T_Colon_Equal;
+
+      if P then
+         return P_Expression;
+      else
+         return P_Expression_No_Right_Paren;
+      end if;
+   end Init_Expr_Opt;
+
+   ----------------------------
+   -- 3.1  Basic Declaration --
+   ----------------------------
+
+   --  Parsed by P_Basic_Declarative_Items (3.9)
+
+   ------------------------------
+   -- 3.1  Defining Identifier --
+   ------------------------------
+
+   --  DEFINING_IDENTIFIER ::= IDENTIFIER
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Defining_Identifier return Node_Id is
+      Ident_Node : Node_Id;
+
+   begin
+      --  Scan out the identifier. Note that this code is essentially identical
+      --  to P_Identifier, except that in the call to Scan_Reserved_Identifier
+      --  we set Force_Msg to True, since we want at least one message for each
+      --  separate declaration (but not use) of a reserved identifier.
+
+      if Token = Tok_Identifier then
+         null;
+
+      --  If we have a reserved identifier, manufacture an identifier with
+      --  a corresponding name after posting an appropriate error message
+
+      elsif Is_Reserved_Identifier then
+         Scan_Reserved_Identifier (Force_Msg => True);
+
+      --  Otherwise we have junk that cannot be interpreted as an identifier
+
+      else
+         T_Identifier; -- to give message
+         raise Error_Resync;
+      end if;
+
+      Ident_Node := Token_Node;
+      Scan; -- past the reserved identifier
+
+      if Ident_Node /= Error then
+         Change_Identifier_To_Defining_Identifier (Ident_Node);
+      end if;
+
+      return Ident_Node;
+   end P_Defining_Identifier;
+
+   -----------------------------
+   -- 3.2.1  Type Declaration --
+   -----------------------------
+
+   --  TYPE_DECLARATION ::=
+   --    FULL_TYPE_DECLARATION
+   --  | INCOMPLETE_TYPE_DECLARATION
+   --  | PRIVATE_TYPE_DECLARATION
+   --  | PRIVATE_EXTENSION_DECLARATION
+
+   --  FULL_TYPE_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
+   --  | CONCURRENT_TYPE_DECLARATION
+
+   --  INCOMPLETE_TYPE_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
+
+   --  PRIVATE_TYPE_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
+   --      is [abstract] [tagged] [limited] private;
+
+   --  PRIVATE_EXTENSION_DECLARATION ::=
+   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
+   --      [abstract] new ancestor_SUBTYPE_INDICATION with private;
+
+   --  TYPE_DEFINITION ::=
+   --    ENUMERATION_TYPE_DEFINITION  | INTEGER_TYPE_DEFINITION
+   --  | REAL_TYPE_DEFINITION         | ARRAY_TYPE_DEFINITION
+   --  | RECORD_TYPE_DEFINITION       | ACCESS_TYPE_DEFINITION
+   --  | DERIVED_TYPE_DEFINITION
+
+   --  INTEGER_TYPE_DEFINITION ::=
+   --    SIGNED_INTEGER_TYPE_DEFINITION
+   --    MODULAR_TYPE_DEFINITION
+
+   --  Error recovery: can raise Error_Resync
+
+   --  Note: The processing for full type declaration, incomplete type
+   --  declaration, private type declaration and type definition is
+   --  included in this function. The processing for concurrent type
+   --  declarations is NOT here, but rather in chapter 9 (i.e. this
+   --  function handles only declarations starting with TYPE).
+
+   function P_Type_Declaration return Node_Id is
+      Type_Loc         : Source_Ptr;
+      Type_Start_Col   : Column_Number;
+      Ident_Node       : Node_Id;
+      Decl_Node        : Node_Id;
+      Discr_List       : List_Id;
+      Unknown_Dis      : Boolean;
+      Discr_Sloc       : Source_Ptr;
+      Abstract_Present : Boolean;
+      Abstract_Loc     : Source_Ptr;
+      End_Labl         : Node_Id;
+
+      Typedef_Node : Node_Id;
+      --  Normally holds type definition, except in the case of a private
+      --  extension declaration, in which case it holds the declaration itself
+
+   begin
+      Type_Loc := Token_Ptr;
+      Type_Start_Col := Start_Column;
+      T_Type;
+      Ident_Node := P_Defining_Identifier;
+      Discr_Sloc := Token_Ptr;
+
+      if P_Unknown_Discriminant_Part_Opt then
+         Unknown_Dis := True;
+         Discr_List := No_List;
+      else
+         Unknown_Dis := False;
+         Discr_List := P_Known_Discriminant_Part_Opt;
+      end if;
+
+      --  Incomplete type declaration. We complete the processing for this
+      --  case here and return the resulting incomplete type declaration node
+
+      if Token = Tok_Semicolon then
+         Scan; -- past ;
+         Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
+         Set_Defining_Identifier (Decl_Node, Ident_Node);
+         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
+         Set_Discriminant_Specifications (Decl_Node, Discr_List);
+         return Decl_Node;
+
+      else
+         Decl_Node := Empty;
+      end if;
+
+      --  Full type declaration or private type declaration, must have IS
+
+      if Token = Tok_Equal then
+         TF_Is;
+         Scan; -- past = used in place of IS
+
+      elsif Token = Tok_Renames then
+         Error_Msg_SC ("RENAMES should be IS");
+         Scan; -- past RENAMES used in place of IS
+
+      else
+         TF_Is;
+      end if;
+
+      --  First an error check, if we have two identifiers in a row, a likely
+      --  possibility is that the first of the identifiers is an incorrectly
+      --  spelled keyword.
+
+      if Token = Tok_Identifier then
+         declare
+            SS : Saved_Scan_State;
+            I2 : Boolean;
+
+         begin
+            Save_Scan_State (SS);
+            Scan; -- past initial identifier
+            I2 := (Token = Tok_Identifier);
+            Restore_Scan_State (SS);
+
+            if I2
+              and then
+                (Bad_Spelling_Of (Tok_Abstract) or else
+                 Bad_Spelling_Of (Tok_Access)   or else
+                 Bad_Spelling_Of (Tok_Aliased)  or else
+                 Bad_Spelling_Of (Tok_Constant))
+            then
+               null;
+            end if;
+         end;
+      end if;
+
+      --  Check for misuse of Ada 95 keyword abstract in Ada 83 mode
+
+      if Token_Name = Name_Abstract then
+         Check_95_Keyword (Tok_Abstract, Tok_Tagged);
+         Check_95_Keyword (Tok_Abstract, Tok_New);
+      end if;
+
+      --  Check cases of misuse of ABSTRACT
+
+      if Token = Tok_Abstract then
+         Abstract_Present := True;
+         Abstract_Loc     := Token_Ptr;
+         Scan; -- past ABSTRACT
+
+         if Token = Tok_Limited
+           or else Token = Tok_Private
+           or else Token = Tok_Record
+           or else Token = Tok_Null
+         then
+            Error_Msg_AP ("TAGGED expected");
+         end if;
+
+      else
+         Abstract_Present := False;
+         Abstract_Loc     := No_Location;
+      end if;
+
+      --  Check for misuse of Ada 95 keyword Tagged
+
+      if Token_Name = Name_Tagged then
+         Check_95_Keyword (Tok_Tagged, Tok_Private);
+         Check_95_Keyword (Tok_Tagged, Tok_Limited);
+         Check_95_Keyword (Tok_Tagged, Tok_Record);
+      end if;
+
+      --  Special check for misuse of Aliased
+
+      if Token = Tok_Aliased or else Token_Name = Name_Aliased then
+         Error_Msg_SC ("ALIASED not allowed in type definition");
+         Scan; -- past ALIASED
+      end if;
+
+      --  The following procesing deals with either a private type declaration
+      --  or a full type declaration. In the private type case, we build the
+      --  N_Private_Type_Declaration node, setting its Tagged_Present and
+      --  Limited_Present flags, on encountering the Private keyword, and
+      --  leave Typedef_Node set to Empty. For the full type declaration
+      --  case, Typedef_Node gets set to the type definition.
+
+      Typedef_Node := Empty;
+
+      --  Switch on token following the IS. The loop normally runs once. It
+      --  only runs more than once if an error is detected, to try again after
+      --  detecting and fixing up the error.
+
+      loop
+         case Token is
+
+            when Tok_Access =>
+               Typedef_Node := P_Access_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Array =>
+               Typedef_Node := P_Array_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Delta =>
+               Typedef_Node := P_Fixed_Point_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Digits =>
+               Typedef_Node := P_Floating_Point_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_In =>
+               Ignore (Tok_In);
+
+            when Tok_Integer_Literal =>
+               T_Range;
+               Typedef_Node := P_Signed_Integer_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Null =>
+               Typedef_Node := P_Record_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Left_Paren =>
+               Typedef_Node := P_Enumeration_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Mod =>
+               Typedef_Node := P_Modular_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_New =>
+               Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Range =>
+               Typedef_Node := P_Signed_Integer_Type_Definition;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Record =>
+               Typedef_Node := P_Record_Definition;
+
+               End_Labl :=
+                 Make_Identifier (Token_Ptr,
+                   Chars => Chars (Ident_Node));
+               Set_Comes_From_Source (End_Labl, False);
+
+               Set_End_Label (Typedef_Node, End_Labl);
+               TF_Semicolon;
+               exit;
+
+            when Tok_Tagged =>
+               Scan; -- past TAGGED
+
+               if Token = Tok_Abstract then
+                  Error_Msg_SC ("ABSTRACT must come before TAGGED");
+                  Abstract_Present := True;
+                  Abstract_Loc := Token_Ptr;
+                  Scan; -- past ABSTRACT
+               end if;
+
+               if Token = Tok_Limited then
+                  Scan; -- past LIMITED
+
+                  --  TAGGED LIMITED PRIVATE case
+
+                  if Token = Tok_Private then
+                     Decl_Node :=
+                       New_Node (N_Private_Type_Declaration, Type_Loc);
+                     Set_Tagged_Present (Decl_Node, True);
+                     Set_Limited_Present (Decl_Node, True);
+                     Scan; -- past PRIVATE
+
+                  --  TAGGED LIMITED RECORD
+
+                  else
+                     Typedef_Node := P_Record_Definition;
+                     Set_Tagged_Present (Typedef_Node, True);
+                     Set_Limited_Present (Typedef_Node, True);
+                  end if;
+
+               else
+                  --  TAGGED PRIVATE
+
+                  if Token = Tok_Private then
+                     Decl_Node :=
+                       New_Node (N_Private_Type_Declaration, Type_Loc);
+                     Set_Tagged_Present (Decl_Node, True);
+                     Scan; -- past PRIVATE
+
+                  --  TAGGED RECORD
+
+                  else
+                     Typedef_Node := P_Record_Definition;
+                     Set_Tagged_Present (Typedef_Node, True);
+                  end if;
+               end if;
+
+               TF_Semicolon;
+               exit;
+
+            when Tok_Private =>
+               Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
+               Scan; -- past PRIVATE
+               TF_Semicolon;
+               exit;
+
+            when Tok_Limited =>
+               Scan; -- past LIMITED
+
+               loop
+                  if Token = Tok_Tagged then
+                     Error_Msg_SC ("TAGGED must come before LIMITED");
+                     Scan; -- past TAGGED
+
+                  elsif Token = Tok_Abstract then
+                     Error_Msg_SC ("ABSTRACT must come before LIMITED");
+                     Scan; -- past ABSTRACT
+
+                  else
+                     exit;
+                  end if;
+               end loop;
+
+               --  LIMITED RECORD or LIMITED NULL RECORD
+
+               if Token = Tok_Record or else Token = Tok_Null then
+                  if Ada_83 then
+                     Error_Msg_SP
+                       ("(Ada 83) limited record declaration not allowed!");
+                  end if;
+
+                  Typedef_Node := P_Record_Definition;
+                  Set_Limited_Present (Typedef_Node, True);
+
+               --  LIMITED PRIVATE is the only remaining possibility here
+
+               else
+                  Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
+                  Set_Limited_Present (Decl_Node, True);
+                  T_Private; -- past PRIVATE (or complain if not there!)
+               end if;
+
+               TF_Semicolon;
+               exit;
+
+            --  Here we have an identifier after the IS, which is certainly
+            --  wrong and which might be one of several different mistakes.
+
+            when Tok_Identifier =>
+
+               --  First case, if identifier is on same line, then probably we
+               --  have something like "type X is Integer .." and the best
+               --  diagnosis is a missing NEW. Note: the missing new message
+               --  will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
+
+               if not Token_Is_At_Start_Of_Line then
+                  Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+                  TF_Semicolon;
+
+               --  If the identifier is at the start of the line, and is in the
+               --  same column as the type declaration itself then we consider
+               --  that we had a missing type definition on the previous line
+
+               elsif Start_Column <= Type_Start_Col then
+                  Error_Msg_AP ("type definition expected");
+                  Typedef_Node := Error;
+
+               --  If the identifier is at the start of the line, and is in
+               --  a column to the right of the type declaration line, then we
+               --  may have something like:
+
+               --    type x is
+               --       r : integer
+
+               --  and the best diagnosis is a missing record keyword
+
+               else
+                  Typedef_Node := P_Record_Definition;
+                  TF_Semicolon;
+               end if;
+
+               exit;
+
+            --  Anything else is an error
+
+            when others =>
+               if Bad_Spelling_Of (Tok_Access)
+                    or else
+                  Bad_Spelling_Of (Tok_Array)
+                    or else
+                  Bad_Spelling_Of (Tok_Delta)
+                    or else
+                  Bad_Spelling_Of (Tok_Digits)
+                    or else
+                  Bad_Spelling_Of (Tok_Limited)
+                    or else
+                  Bad_Spelling_Of (Tok_Private)
+                    or else
+                  Bad_Spelling_Of (Tok_Range)
+                    or else
+                  Bad_Spelling_Of (Tok_Record)
+                    or else
+                  Bad_Spelling_Of (Tok_Tagged)
+               then
+                  null;
+
+               else
+                  Error_Msg_AP ("type definition expected");
+                  raise Error_Resync;
+               end if;
+
+         end case;
+      end loop;
+
+      --  For the private type declaration case, the private type declaration
+      --  node has been built, with the Tagged_Present and Limited_Present
+      --  flags set as needed, and Typedef_Node is left set to Empty.
+
+      if No (Typedef_Node) then
+         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
+         Set_Abstract_Present (Decl_Node, Abstract_Present);
+
+      --  For a private extension declaration, Typedef_Node contains the
+      --  N_Private_Extension_Declaration node, which we now complete. Note
+      --  that the private extension declaration, unlike a full type
+      --  declaration, does permit unknown discriminants.
+
+      elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
+         Decl_Node := Typedef_Node;
+         Set_Sloc (Decl_Node, Type_Loc);
+         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
+         Set_Abstract_Present (Typedef_Node, Abstract_Present);
+
+      --  In the full type declaration case, Typedef_Node has the type
+      --  definition and here is where we build the full type declaration
+      --  node. This is also where we check for improper use of an unknown
+      --  discriminant part (not allowed for full type declaration).
+
+      else
+         if Nkind (Typedef_Node) = N_Record_Definition
+           or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
+                      and then Present (Record_Extension_Part (Typedef_Node)))
+         then
+            Set_Abstract_Present (Typedef_Node, Abstract_Present);
+
+         elsif Abstract_Present then
+            Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
+         end if;
+
+         Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
+         Set_Type_Definition (Decl_Node, Typedef_Node);
+
+         if Unknown_Dis then
+            Error_Msg
+              ("Full type declaration cannot have unknown discriminants",
+                Discr_Sloc);
+         end if;
+      end if;
+
+      --  Remaining processing is common for all three cases
+
+      Set_Defining_Identifier (Decl_Node, Ident_Node);
+      Set_Discriminant_Specifications (Decl_Node, Discr_List);
+      return Decl_Node;
+
+   end P_Type_Declaration;
+
+   ----------------------------------
+   -- 3.2.1  Full Type Declaration --
+   ----------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   ----------------------------
+   -- 3.2.1  Type Definition --
+   ----------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   --------------------------------
+   -- 3.2.2  Subtype Declaration --
+   --------------------------------
+
+   --  SUBTYPE_DECLARATION ::=
+   --    subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+
+   --  The caller has checked that the initial token is SUBTYPE
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subtype_Declaration return Node_Id is
+      Decl_Node : Node_Id;
+
+   begin
+      Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
+      Scan; -- past SUBTYPE
+      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
+      TF_Is;
+
+      if Token = Tok_New then
+         Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
+         Scan; -- past NEW
+      end if;
+
+      Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
+      TF_Semicolon;
+      return Decl_Node;
+   end P_Subtype_Declaration;
+
+   -------------------------------
+   -- 3.2.2  Subtype Indication --
+   -------------------------------
+
+   --  SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subtype_Indication return Node_Id is
+      Type_Node : Node_Id;
+
+   begin
+      if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
+         Type_Node := P_Subtype_Mark;
+         return P_Subtype_Indication (Type_Node);
+
+      else
+         --  Check for error of using record definition and treat it nicely,
+         --  otherwise things are really messed up, so resynchronize.
+
+         if Token = Tok_Record then
+            Error_Msg_SC ("anonymous record definitions are not permitted");
+            Discard_Junk_Node (P_Record_Definition);
+            return Error;
+
+         else
+            Error_Msg_AP ("subtype indication expected");
+            raise Error_Resync;
+         end if;
+      end if;
+   end P_Subtype_Indication;
+
+   --  The following function is identical except that it is called with
+   --  the subtype mark already scanned out, and it scans out the constraint
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is
+      Indic_Node  : Node_Id;
+      Constr_Node : Node_Id;
+
+   begin
+      Constr_Node := P_Constraint_Opt;
+
+      if No (Constr_Node) then
+         return Subtype_Mark;
+      else
+         Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
+         Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
+         Set_Constraint (Indic_Node, Constr_Node);
+         return Indic_Node;
+      end if;
+
+   end P_Subtype_Indication;
+
+   -------------------------
+   -- 3.2.2  Subtype Mark --
+   -------------------------
+
+   --  SUBTYPE_MARK ::= subtype_NAME;
+
+   --  Note: The subtype mark which appears after an IN or NOT IN
+   --  operator is parsed by P_Range_Or_Subtype_Mark (3.5)
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Subtype_Mark return Node_Id is
+   begin
+      return P_Subtype_Mark_Resync;
+
+   exception
+      when Error_Resync =>
+         return Error;
+   end P_Subtype_Mark;
+
+   --  This routine differs from P_Subtype_Mark in that it insists that an
+   --  identifier be present, and if it is not, it raises Error_Resync.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subtype_Mark_Resync return Node_Id is
+      Type_Node : Node_Id;
+
+   begin
+      if Token = Tok_Access then
+         Error_Msg_SC ("anonymous access type definition not allowed here");
+         Scan; -- past ACCESS
+      end if;
+
+      if Token = Tok_Array then
+         Error_Msg_SC ("anonymous array definition not allowed here");
+         Discard_Junk_Node (P_Array_Type_Definition);
+         return Empty;
+
+      else
+         Type_Node := P_Qualified_Simple_Name_Resync;
+
+         --  Check for a subtype mark attribute. The only valid possibilities
+         --  are 'CLASS and 'BASE. Anything else is a definite error. We may
+         --  as well catch it here.
+
+         if Token = Tok_Apostrophe then
+            return P_Subtype_Mark_Attribute (Type_Node);
+         else
+            return Type_Node;
+         end if;
+      end if;
+   end P_Subtype_Mark_Resync;
+
+   --  The following function is called to scan out a subtype mark attribute.
+   --  The caller has already scanned out the subtype mark, which is passed in
+   --  as the argument, and has checked that the current token is apostrophe.
+
+   --  Only a special subclass of attributes, called type attributes
+   --  (see Snames package) are allowed in this syntactic position.
+
+   --  Note: if the apostrophe is followed by other than an identifier, then
+   --  the input expression is returned unchanged, and the scan pointer is
+   --  left pointing to the apostrophe.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
+      Attr_Node  : Node_Id := Empty;
+      Scan_State : Saved_Scan_State;
+      Prefix     : Node_Id;
+
+   begin
+      Prefix := Check_Subtype_Mark (Type_Node);
+
+      if Prefix = Error then
+         raise Error_Resync;
+      end if;
+
+      --  Loop through attributes appearing (more than one can appear as for
+      --  for example in X'Base'Class). We are at an apostrophe on entry to
+      --  this loop, and it runs once for each attribute parsed, with
+      --  Prefix being the current possible prefix if it is an attribute.
+
+      loop
+         Save_Scan_State (Scan_State); -- at Apostrophe
+         Scan; -- past apostrophe
+
+         if Token /= Tok_Identifier then
+            Restore_Scan_State (Scan_State); -- to apostrophe
+            return Prefix; -- no attribute after all
+
+         elsif not Is_Type_Attribute_Name (Token_Name) then
+            Error_Msg_N
+              ("attribute & may not be used in a subtype mark", Token_Node);
+            raise Error_Resync;
+
+         else
+            Attr_Node :=
+              Make_Attribute_Reference (Prev_Token_Ptr,
+                Prefix => Prefix,
+                Attribute_Name => Token_Name);
+            Delete_Node (Token_Node);
+            Scan; -- past type attribute identifier
+         end if;
+
+         exit when Token /= Tok_Apostrophe;
+         Prefix := Attr_Node;
+      end loop;
+
+      --  Fall through here after scanning type attribute
+
+      return Attr_Node;
+   end P_Subtype_Mark_Attribute;
+
+   -----------------------
+   -- 3.2.2  Constraint --
+   -----------------------
+
+   --  CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
+
+   --  SCALAR_CONSTRAINT ::=
+   --    RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
+
+   --  COMPOSITE_CONSTRAINT ::=
+   --    INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
+
+   --  If no constraint is present, this function returns Empty
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Constraint_Opt return Node_Id is
+   begin
+      if Token = Tok_Range
+        or else Bad_Spelling_Of (Tok_Range)
+      then
+         return P_Range_Constraint;
+
+      elsif Token = Tok_Digits
+        or else Bad_Spelling_Of (Tok_Digits)
+      then
+         return P_Digits_Constraint;
+
+      elsif Token = Tok_Delta
+        or else Bad_Spelling_Of (Tok_Delta)
+      then
+         return P_Delta_Constraint;
+
+      elsif Token = Tok_Left_Paren then
+         return P_Index_Or_Discriminant_Constraint;
+
+      elsif Token = Tok_In then
+         Ignore (Tok_In);
+         return P_Constraint_Opt;
+
+      else
+         return Empty;
+      end if;
+
+   end P_Constraint_Opt;
+
+   ------------------------------
+   -- 3.2.2  Scalar Constraint --
+   ------------------------------
+
+   --  Parsed by P_Constraint_Opt (3.2.2)
+
+   ---------------------------------
+   -- 3.2.2  Composite Constraint --
+   ---------------------------------
+
+   --  Parsed by P_Constraint_Opt (3.2.2)
+
+   --------------------------------------------------------
+   -- 3.3  Identifier Declarations (Also 7.4, 8.5, 11.1) --
+   --------------------------------------------------------
+
+   --  This routine scans out a declaration starting with an identifier:
+
+   --  OBJECT_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST : [constant] [aliased]
+   --      SUBTYPE_INDICATION [:= EXPRESSION];
+   --  | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
+   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];
+
+   --  NUMBER_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
+
+   --  OBJECT_RENAMING_DECLARATION ::=
+   --    DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
+
+   --  EXCEPTION_RENAMING_DECLARATION ::=
+   --    DEFINING_IDENTIFIER : exception renames exception_NAME;
+
+   --  EXCEPTION_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST : exception;
+
+   --  Note that the ALIASED indication in an object declaration is
+   --  marked by a flag in the parent node.
+
+   --  The caller has checked that the initial token is an identifier
+
+   --  The value returned is a list of declarations, one for each identifier
+   --  in the list (as described in Sinfo, we always split up multiple
+   --  declarations into the equivalent sequence of single declarations
+   --  using the More_Ids and Prev_Ids flags to preserve the source).
+
+   --  If the identifier turns out to be a probable statement rather than
+   --  an identifier, then the scan is left pointing to the identifier and
+   --  No_List is returned.
+
+   --  Error recovery: can raise Error_Resync
+
+   procedure P_Identifier_Declarations
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean)
+   is
+      Decl_Node  : Node_Id;
+      Type_Node  : Node_Id;
+      Ident_Sloc : Source_Ptr;
+      Scan_State : Saved_Scan_State;
+      List_OK    : Boolean := True;
+      Ident      : Nat;
+      Init_Expr  : Node_Id;
+      Init_Loc   : Source_Ptr;
+      Con_Loc    : Source_Ptr;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  Used to save identifiers in the identifier list. The upper bound
+      --  of 4096 is expected to be infinite in practice, and we do not even
+      --  bother to check if this upper bound is exceeded.
+
+      Num_Idents : Nat := 1;
+      --  Number of identifiers stored in Idents
+
+      procedure No_List;
+      --  This procedure is called in renames cases to make sure that we do
+      --  not have more than one identifier. If we do have more than one
+      --  then an error message is issued (and the declaration is split into
+      --  multiple declarations)
+
+      function Token_Is_Renames return Boolean;
+      --  Checks if current token is RENAMES, and if so, scans past it and
+      --  returns True, otherwise returns False. Includes checking for some
+      --  common error cases.
+
+      procedure No_List is
+      begin
+         if Num_Idents > 1 then
+            Error_Msg ("identifier list not allowed for RENAMES",
+                       Sloc (Idents (2)));
+         end if;
+
+         List_OK := False;
+      end No_List;
+
+      function Token_Is_Renames return Boolean is
+         At_Colon : Saved_Scan_State;
+
+      begin
+         if Token = Tok_Colon then
+            Save_Scan_State (At_Colon);
+            Scan; -- past colon
+            Check_Misspelling_Of (Tok_Renames);
+
+            if Token = Tok_Renames then
+               Error_Msg_SP ("extra "":"" ignored");
+               Scan; -- past RENAMES
+               return True;
+            else
+               Restore_Scan_State (At_Colon);
+               return False;
+            end if;
+
+         else
+            Check_Misspelling_Of (Tok_Renames);
+
+            if Token = Tok_Renames then
+               Scan; -- past RENAMES
+               return True;
+            else
+               return False;
+            end if;
+         end if;
+      end Token_Is_Renames;
+
+   --  Start of processing for P_Identifier_Declarations
+
+   begin
+      Ident_Sloc := Token_Ptr;
+      Save_Scan_State (Scan_State); -- at first identifier
+      Idents (1) := P_Defining_Identifier;
+
+      --  If we have a colon after the identifier, then we can assume that
+      --  this is in fact a valid identifier declaration and can steam ahead.
+
+      if Token = Tok_Colon then
+         Scan; -- past colon
+
+      --  If we have a comma, then scan out the list of identifiers
+
+      elsif Token = Tok_Comma then
+
+         while Comma_Present loop
+            Num_Idents := Num_Idents + 1;
+            Idents (Num_Idents) := P_Defining_Identifier;
+         end loop;
+
+         Save_Scan_State (Scan_State); -- at colon
+         T_Colon;
+
+      --  If we have identifier followed by := then we assume that what is
+      --  really meant is an assignment statement. The assignment statement
+      --  is scanned out and added to the list of declarations. An exception
+      --  occurs if the := is followed by the keyword constant, in which case
+      --  we assume it was meant to be a colon.
+
+      elsif Token = Tok_Colon_Equal then
+         Scan; -- past :=
+
+         if Token = Tok_Constant then
+            Error_Msg_SP ("colon expected");
+
+         else
+            Restore_Scan_State (Scan_State);
+            Statement_When_Declaration_Expected (Decls, Done, In_Spec);
+            return;
+         end if;
+
+      --  If we have an IS keyword, then assume the TYPE keyword was missing
+
+      elsif Token = Tok_Is then
+         Restore_Scan_State (Scan_State);
+         Append_To (Decls, P_Type_Declaration);
+         Done := False;
+         return;
+
+      --  Otherwise we have an error situation
+
+      else
+         Restore_Scan_State (Scan_State);
+
+         --  First case is possible misuse of PROTECTED in Ada 83 mode. If
+         --  so, fix the keyword and return to scan the protected declaration.
+
+         if Token_Name = Name_Protected then
+            Check_95_Keyword (Tok_Protected, Tok_Identifier);
+            Check_95_Keyword (Tok_Protected, Tok_Type);
+            Check_95_Keyword (Tok_Protected, Tok_Body);
+
+            if Token = Tok_Protected then
+               Done := False;
+               return;
+            end if;
+
+         --  Check misspelling possibilities. If so, correct the misspelling
+         --  and return to scan out the resulting declaration.
+
+         elsif Bad_Spelling_Of (Tok_Function)
+           or else Bad_Spelling_Of (Tok_Procedure)
+           or else Bad_Spelling_Of (Tok_Package)
+           or else Bad_Spelling_Of (Tok_Pragma)
+           or else Bad_Spelling_Of (Tok_Protected)
+           or else Bad_Spelling_Of (Tok_Generic)
+           or else Bad_Spelling_Of (Tok_Subtype)
+           or else Bad_Spelling_Of (Tok_Type)
+           or else Bad_Spelling_Of (Tok_Task)
+           or else Bad_Spelling_Of (Tok_Use)
+           or else Bad_Spelling_Of (Tok_For)
+         then
+            Done := False;
+            return;
+
+         --  Otherwise we definitely have an ordinary identifier with a junk
+         --  token after it. Just complain that we expect a declaration, and
+         --  skip to a semicolon
+
+         else
+            Set_Declaration_Expected;
+            Resync_Past_Semicolon;
+            Done := False;
+            return;
+         end if;
+      end if;
+
+      --  Come here with an identifier list and colon scanned out. We now
+      --  build the nodes for the declarative items. One node is built for
+      --  each identifier in the list, with the type information being
+      --  repeated by rescanning the appropriate section of source.
+
+      --  First an error check, if we have two identifiers in a row, a likely
+      --  possibility is that the first of the identifiers is an incorrectly
+      --  spelled keyword.
+
+      if Token = Tok_Identifier then
+         declare
+            SS : Saved_Scan_State;
+            I2 : Boolean;
+
+         begin
+            Save_Scan_State (SS);
+            Scan; -- past initial identifier
+            I2 := (Token = Tok_Identifier);
+            Restore_Scan_State (SS);
+
+            if I2
+              and then
+                (Bad_Spelling_Of (Tok_Access)   or else
+                 Bad_Spelling_Of (Tok_Aliased)  or else
+                 Bad_Spelling_Of (Tok_Constant))
+            then
+               null;
+            end if;
+         end;
+      end if;
+
+      --  Loop through identifiers
+
+      Ident := 1;
+      Ident_Loop : loop
+
+         --  Check for some cases of misused Ada 95 keywords
+
+         if Token_Name = Name_Aliased then
+            Check_95_Keyword (Tok_Aliased, Tok_Array);
+            Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+            Check_95_Keyword (Tok_Aliased, Tok_Constant);
+         end if;
+
+         --  Constant cases
+
+         if Token = Tok_Constant then
+            Con_Loc := Token_Ptr;
+            Scan; -- past CONSTANT
+
+            --  Number declaration, initialization required
+
+            Init_Expr := Init_Expr_Opt;
+
+            if Present (Init_Expr) then
+               Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
+               Set_Expression (Decl_Node, Init_Expr);
+
+            --  Constant object declaration
+
+            else
+               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+               Set_Constant_Present (Decl_Node, True);
+
+               if Token_Name = Name_Aliased then
+                  Check_95_Keyword (Tok_Aliased, Tok_Array);
+                  Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+               end if;
+
+               if Token = Tok_Aliased then
+                  Error_Msg_SC ("ALIASED should be before CONSTANT");
+                  Scan; -- past ALIASED
+                  Set_Aliased_Present (Decl_Node, True);
+               end if;
+
+               if Token = Tok_Array then
+                  Set_Object_Definition
+                    (Decl_Node, P_Array_Type_Definition);
+               else
+                  Set_Object_Definition (Decl_Node, P_Subtype_Indication);
+               end if;
+
+               if Token = Tok_Renames then
+                  Error_Msg
+                    ("CONSTANT not permitted in renaming declaration",
+                     Con_Loc);
+                  Scan; -- Past renames
+                  Discard_Junk_Node (P_Name);
+               end if;
+            end if;
+
+         --  Exception cases
+
+         elsif Token = Tok_Exception then
+            Scan; -- past EXCEPTION
+
+            if Token_Is_Renames then
+               No_List;
+               Decl_Node :=
+                 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
+               Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
+               No_Constraint;
+            else
+               Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
+            end if;
+
+         --  Aliased case (note that an object definition is required)
+
+         elsif Token = Tok_Aliased then
+            Scan; -- past ALIASED
+            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+            Set_Aliased_Present (Decl_Node, True);
+
+            if Token = Tok_Constant then
+               Scan; -- past CONSTANT
+               Set_Constant_Present (Decl_Node, True);
+            end if;
+
+            if Token = Tok_Array then
+               Set_Object_Definition
+                 (Decl_Node, P_Array_Type_Definition);
+            else
+               Set_Object_Definition (Decl_Node, P_Subtype_Indication);
+            end if;
+
+         --  Array case
+
+         elsif Token = Tok_Array then
+            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+            Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
+
+         --  Subtype indication case
+
+         else
+            Type_Node := P_Subtype_Mark;
+
+            --  Object renaming declaration
+
+            if Token_Is_Renames then
+               No_List;
+               Decl_Node :=
+                 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
+               Set_Subtype_Mark (Decl_Node, Type_Node);
+               Set_Name (Decl_Node, P_Name);
+
+            --  Object declaration
+
+            else
+               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
+               Set_Object_Definition
+                 (Decl_Node, P_Subtype_Indication (Type_Node));
+
+               --  RENAMES at this point means that we had the combination of
+               --  a constraint on the Type_Node and renames, which is illegal
+
+               if Token_Is_Renames then
+                  Error_Msg_N
+                    ("constraint not allowed in object renaming declaration",
+                     Constraint (Object_Definition (Decl_Node)));
+                  raise Error_Resync;
+               end if;
+            end if;
+         end if;
+
+         --  Scan out initialization, allowed only for object declaration
+
+         Init_Loc := Token_Ptr;
+         Init_Expr := Init_Expr_Opt;
+
+         if Present (Init_Expr) then
+            if Nkind (Decl_Node) = N_Object_Declaration then
+               Set_Expression (Decl_Node, Init_Expr);
+            else
+               Error_Msg ("initialization not allowed here", Init_Loc);
+            end if;
+         end if;
+
+         TF_Semicolon;
+         Set_Defining_Identifier (Decl_Node, Idents (Ident));
+
+         if List_OK then
+            if Ident < Num_Idents then
+               Set_More_Ids (Decl_Node, True);
+            end if;
+
+            if Ident > 1 then
+               Set_Prev_Ids (Decl_Node, True);
+            end if;
+         end if;
+
+         Append (Decl_Node, Decls);
+         exit Ident_Loop when Ident = Num_Idents;
+         Restore_Scan_State (Scan_State);
+         T_Colon;
+         Ident := Ident + 1;
+      end loop Ident_Loop;
+
+      Done := False;
+
+   end P_Identifier_Declarations;
+
+   -------------------------------
+   -- 3.3.1  Object Declaration --
+   -------------------------------
+
+   --  OBJECT DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+   --      SUBTYPE_INDICATION [:= EXPRESSION];
+   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];
+   --  | SINGLE_TASK_DECLARATION
+   --  | SINGLE_PROTECTED_DECLARATION
+
+   --  Cases starting with TASK are parsed by P_Task (9.1)
+   --  Cases starting with PROTECTED are parsed by P_Protected (9.4)
+   --  All other cases are parsed by P_Identifier_Declarations (3.3)
+
+   -------------------------------------
+   -- 3.3.1  Defining Identifier List --
+   -------------------------------------
+
+   --  DEFINING_IDENTIFIER_LIST ::=
+   --    DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
+
+   --  Always parsed by the construct in which it appears. See special
+   --  section on "Handling of Defining Identifier Lists" in this unit.
+
+   -------------------------------
+   -- 3.3.2  Number Declaration --
+   -------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3)
+
+   -------------------------------------------------------------------------
+   -- 3.4  Derived Type Definition or Private Extension Declaration (7.3) --
+   -------------------------------------------------------------------------
+
+   --  DERIVED_TYPE_DEFINITION ::=
+   --    [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+
+   --  PRIVATE_EXTENSION_DECLARATION ::=
+   --     type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
+   --       [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
+
+   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
+
+   --  The caller has already scanned out the part up to the NEW, and Token
+   --  either contains Tok_New (or ought to, if it doesn't this procedure
+   --  will post an appropriate "NEW expected" message).
+
+   --  Note: the caller is responsible for filling in the Sloc field of
+   --  the returned node in the private extension declaration case as
+   --  well as the stuff relating to the discriminant part.
+
+   --  Error recovery: can raise Error_Resync;
+
+   function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
+      Typedef_Node  : Node_Id;
+      Typedecl_Node : Node_Id;
+
+   begin
+      Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
+      T_New;
+
+      if Token = Tok_Abstract then
+         Error_Msg_SC ("ABSTRACT must come before NEW, not after");
+         Scan;
+      end if;
+
+      Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication);
+
+      --  Deal with record extension, note that we assume that a WITH is
+      --  missing in the case of "type X is new Y record ..." or in the
+      --  case of "type X is new Y null record".
+
+      if Token = Tok_With
+        or else Token = Tok_Record
+        or else Token = Tok_Null
+      then
+         T_With; -- past WITH or give error message
+
+         if Token = Tok_Limited then
+            Error_Msg_SC
+              ("LIMITED keyword not allowed in private extension");
+            Scan; -- ignore LIMITED
+         end if;
+
+         --  Private extension declaration
+
+         if Token = Tok_Private then
+            Scan; -- past PRIVATE
+
+            --  Throw away the type definition node and build the type
+            --  declaration node. Note the caller must set the Sloc,
+            --  Discriminant_Specifications, Unknown_Discriminants_Present,
+            --  and Defined_Identifier fields in the returned node.
+
+            Typedecl_Node :=
+              Make_Private_Extension_Declaration (No_Location,
+                Defining_Identifier => Empty,
+                Subtype_Indication  => Subtype_Indication (Typedef_Node),
+                Abstract_Present    => Abstract_Present (Typedef_Node));
+
+            Delete_Node (Typedef_Node);
+            return Typedecl_Node;
+
+         --  Derived type definition with record extension part
+
+         else
+            Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
+            return Typedef_Node;
+         end if;
+
+      --  Derived type definition with no record extension part
+
+      else
+         return Typedef_Node;
+      end if;
+   end P_Derived_Type_Def_Or_Private_Ext_Decl;
+
+   ---------------------------
+   -- 3.5  Range Constraint --
+   ---------------------------
+
+   --  RANGE_CONSTRAINT ::= range RANGE
+
+   --  The caller has checked that the initial token is RANGE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Range_Constraint return Node_Id is
+      Range_Node : Node_Id;
+
+   begin
+      Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
+      Scan; -- past RANGE
+      Set_Range_Expression (Range_Node, P_Range);
+      return Range_Node;
+   end P_Range_Constraint;
+
+   ----------------
+   -- 3.5  Range --
+   ----------------
+
+   --  RANGE ::=
+   --    RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
+
+   --  Note: the range that appears in a membership test is parsed by
+   --  P_Range_Or_Subtype_Mark (3.5).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Range return Node_Id is
+      Expr_Node  : Node_Id;
+      Range_Node : Node_Id;
+
+   begin
+      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
+
+      if Expr_Form = EF_Range_Attr then
+         return Expr_Node;
+
+      elsif Token = Tok_Dot_Dot then
+         Range_Node := New_Node (N_Range, Token_Ptr);
+         Set_Low_Bound (Range_Node, Expr_Node);
+         Scan; -- past ..
+         Expr_Node := P_Expression;
+         Check_Simple_Expression (Expr_Node);
+         Set_High_Bound (Range_Node, Expr_Node);
+         return Range_Node;
+
+      --  Anything else is an error
+
+      else
+         T_Dot_Dot; -- force missing .. message
+         return Error;
+      end if;
+   end P_Range;
+
+   ----------------------------------
+   -- 3.5  P_Range_Or_Subtype_Mark --
+   ----------------------------------
+
+   --  RANGE ::=
+   --    RANGE_ATTRIBUTE_REFERENCE
+   --  | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
+
+   --  This routine scans out the range or subtype mark that forms the right
+   --  operand of a membership test.
+
+   --  Note: as documented in the Sinfo interface, although the syntax only
+   --  allows a subtype mark, we in fact allow any simple expression to be
+   --  returned from this routine. The semantics is responsible for issuing
+   --  an appropriate message complaining if the argument is not a name.
+   --  This simplifies the coding and error recovery processing in the
+   --  parser, and in any case it is preferable not to consider this a
+   --  syntax error and to continue with the semantic analysis.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Range_Or_Subtype_Mark return Node_Id is
+      Expr_Node  : Node_Id;
+      Range_Node : Node_Id;
+
+   begin
+      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
+
+      if Expr_Form = EF_Range_Attr then
+         return Expr_Node;
+
+      --  Simple_Expression .. Simple_Expression
+
+      elsif Token = Tok_Dot_Dot then
+         Check_Simple_Expression (Expr_Node);
+         Range_Node := New_Node (N_Range, Token_Ptr);
+         Set_Low_Bound (Range_Node, Expr_Node);
+         Scan; -- past ..
+         Set_High_Bound (Range_Node, P_Simple_Expression);
+         return Range_Node;
+
+      --  Case of subtype mark (optionally qualified simple name or an
+      --  attribute whose prefix is an optionally qualifed simple name)
+
+      elsif Expr_Form = EF_Simple_Name
+        or else Nkind (Expr_Node) = N_Attribute_Reference
+      then
+         --  Check for error of range constraint after a subtype mark
+
+         if Token = Tok_Range then
+            Error_Msg_SC
+              ("range constraint not allowed in membership test");
+            Scan; -- past RANGE
+            raise Error_Resync;
+
+         --  Check for error of DIGITS or DELTA after a subtype mark
+
+         elsif Token = Tok_Digits or else Token = Tok_Delta then
+            Error_Msg_SC
+               ("accuracy definition not allowed in membership test");
+            Scan; -- past DIGITS or DELTA
+            raise Error_Resync;
+
+         elsif Token = Tok_Apostrophe then
+            return P_Subtype_Mark_Attribute (Expr_Node);
+
+         else
+            return Expr_Node;
+         end if;
+
+      --  At this stage, we have some junk following the expression. We
+      --  really can't tell what is wrong, might be a missing semicolon,
+      --  or a missing THEN, or whatever. Our caller will figure it out!
+
+      else
+         return Expr_Node;
+      end if;
+   end P_Range_Or_Subtype_Mark;
+
+   ----------------------------------------
+   -- 3.5.1  Enumeration Type Definition --
+   ----------------------------------------
+
+   --  ENUMERATION_TYPE_DEFINITION ::=
+   --    (ENUMERATION_LITERAL_SPECIFICATION
+   --      {, ENUMERATION_LITERAL_SPECIFICATION})
+
+   --  The caller has already scanned out the TYPE keyword
+
+   --  Error recovery: can raise Error_Resync;
+
+   function P_Enumeration_Type_Definition return Node_Id is
+      Typedef_Node : Node_Id;
+
+   begin
+      Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
+      Set_Literals (Typedef_Node, New_List);
+
+      T_Left_Paren;
+
+      loop
+         Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
+         exit when not Comma_Present;
+      end loop;
+
+      T_Right_Paren;
+      return Typedef_Node;
+   end P_Enumeration_Type_Definition;
+
+   ----------------------------------------------
+   -- 3.5.1  Enumeration Literal Specification --
+   ----------------------------------------------
+
+   --  ENUMERATION_LITERAL_SPECIFICATION ::=
+   --    DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Enumeration_Literal_Specification return Node_Id is
+   begin
+      if Token = Tok_Char_Literal then
+         return P_Defining_Character_Literal;
+      else
+         return P_Defining_Identifier;
+      end if;
+   end P_Enumeration_Literal_Specification;
+
+   ---------------------------------------
+   -- 3.5.1  Defining_Character_Literal --
+   ---------------------------------------
+
+   --  DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  The caller has checked that the current token is a character literal
+
+   function P_Defining_Character_Literal return Node_Id is
+      Literal_Node : Node_Id;
+
+   begin
+      Literal_Node := Token_Node;
+      Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
+      Scan; -- past character literal
+      return Literal_Node;
+   end P_Defining_Character_Literal;
+
+   ------------------------------------
+   -- 3.5.4  Integer Type Definition --
+   ------------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   -------------------------------------------
+   -- 3.5.4  Signed Integer Type Definition --
+   -------------------------------------------
+
+   --  SIGNED_INTEGER_TYPE_DEFINITION ::=
+   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+   --  Normally the initial token on entry is RANGE, but in some
+   --  error conditions, the range token was missing and control is
+   --  passed with Token pointing to first token of the first expression.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Signed_Integer_Type_Definition return Node_Id is
+      Typedef_Node : Node_Id;
+      Expr_Node    : Node_Id;
+
+   begin
+      Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
+
+      if Token = Tok_Range then
+         Scan; -- past RANGE
+      end if;
+
+      Expr_Node := P_Expression;
+      Check_Simple_Expression (Expr_Node);
+      Set_Low_Bound (Typedef_Node, Expr_Node);
+      T_Dot_Dot;
+      Expr_Node := P_Expression;
+      Check_Simple_Expression (Expr_Node);
+      Set_High_Bound (Typedef_Node, Expr_Node);
+      return Typedef_Node;
+   end P_Signed_Integer_Type_Definition;
+
+   ------------------------------------
+   -- 3.5.4  Modular Type Definition --
+   ------------------------------------
+
+   --  MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
+
+   --  The caller has checked that the initial token is MOD
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Modular_Type_Definition return Node_Id is
+      Typedef_Node : Node_Id;
+
+   begin
+      if Ada_83 then
+         Error_Msg_SC ("(Ada 83): modular types not allowed");
+      end if;
+
+      Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
+      Scan; -- past MOD
+      Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
+
+      --  Handle mod L..R cleanly
+
+      if Token = Tok_Dot_Dot then
+         Error_Msg_SC ("range not allowed for modular type");
+         Scan; -- past ..
+         Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
+      end if;
+
+      return Typedef_Node;
+   end P_Modular_Type_Definition;
+
+   ---------------------------------
+   -- 3.5.6  Real Type Definition --
+   ---------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   --------------------------------------
+   -- 3.5.7  Floating Point Definition --
+   --------------------------------------
+
+   --  FLOATING_POINT_DEFINITION ::=
+   --    digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+   --  Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
+
+   --  The caller has checked that the initial token is DIGITS
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Floating_Point_Definition return Node_Id is
+      Digits_Loc : constant Source_Ptr := Token_Ptr;
+      Def_Node   : Node_Id;
+      Expr_Node  : Node_Id;
+
+   begin
+      Scan; -- past DIGITS
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+
+      --  Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
+
+      if Token = Tok_Delta then
+         Error_Msg_SC ("DELTA must come before DIGITS");
+         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
+         Scan; -- past DELTA
+         Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
+
+      --  OK floating-point definition
+
+      else
+         Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
+      end if;
+
+      Set_Digits_Expression (Def_Node, Expr_Node);
+      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
+      return Def_Node;
+   end P_Floating_Point_Definition;
+
+   -------------------------------------
+   -- 3.5.7  Real Range Specification --
+   -------------------------------------
+
+   --  REAL_RANGE_SPECIFICATION ::=
+   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Real_Range_Specification_Opt return Node_Id is
+      Specification_Node : Node_Id;
+      Expr_Node          : Node_Id;
+
+   begin
+      if Token = Tok_Range then
+         Specification_Node :=
+           New_Node (N_Real_Range_Specification, Token_Ptr);
+         Scan; -- past RANGE
+         Expr_Node := P_Expression_No_Right_Paren;
+         Check_Simple_Expression (Expr_Node);
+         Set_Low_Bound (Specification_Node, Expr_Node);
+         T_Dot_Dot;
+         Expr_Node := P_Expression_No_Right_Paren;
+         Check_Simple_Expression (Expr_Node);
+         Set_High_Bound (Specification_Node, Expr_Node);
+         return Specification_Node;
+      else
+         return Empty;
+      end if;
+   end P_Real_Range_Specification_Opt;
+
+   -----------------------------------
+   -- 3.5.9  Fixed Point Definition --
+   -----------------------------------
+
+   --  FIXED_POINT_DEFINITION ::=
+   --    ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
+
+   --  ORDINARY_FIXED_POINT_DEFINITION ::=
+   --    delta static_EXPRESSION REAL_RANGE_SPECIFICATION
+
+   --  DECIMAL_FIXED_POINT_DEFINITION ::=
+   --    delta static_EXPRESSION
+   --      digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
+
+   --  The caller has checked that the initial token is DELTA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Fixed_Point_Definition return Node_Id is
+      Delta_Node : Node_Id;
+      Delta_Loc  : Source_Ptr;
+      Def_Node   : Node_Id;
+      Expr_Node  : Node_Id;
+
+   begin
+      Delta_Loc := Token_Ptr;
+      Scan; -- past DELTA
+      Delta_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Delta_Node);
+
+      if Token = Tok_Digits then
+         if Ada_83 then
+            Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
+         end if;
+
+         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
+         Scan; -- past DIGITS
+         Expr_Node := P_Expression_No_Right_Paren;
+         Check_Simple_Expression_In_Ada_83 (Expr_Node);
+         Set_Digits_Expression (Def_Node, Expr_Node);
+
+      else
+         Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
+
+         --  Range is required in ordinary fixed point case
+
+         if Token /= Tok_Range then
+            Error_Msg_AP ("range must be given for fixed-point type");
+            T_Range;
+         end if;
+      end if;
+
+      Set_Delta_Expression (Def_Node, Delta_Node);
+      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
+      return Def_Node;
+   end P_Fixed_Point_Definition;
+
+   --------------------------------------------
+   -- 3.5.9  Ordinary Fixed Point Definition --
+   --------------------------------------------
+
+   --  Parsed by P_Fixed_Point_Definition (3.5.9)
+
+   -------------------------------------------
+   -- 3.5.9  Decimal Fixed Point Definition --
+   -------------------------------------------
+
+   --  Parsed by P_Decimal_Point_Definition (3.5.9)
+
+   ------------------------------
+   -- 3.5.9  Digits Constraint --
+   ------------------------------
+
+   --  DIGITS_CONSTRAINT ::=
+   --    digits static_EXPRESSION [RANGE_CONSTRAINT]
+
+   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+
+   --  The caller has checked that the initial token is DIGITS
+
+   function P_Digits_Constraint return Node_Id is
+      Constraint_Node : Node_Id;
+      Expr_Node : Node_Id;
+
+   begin
+      Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
+      Scan; -- past DIGITS
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Digits_Expression (Constraint_Node, Expr_Node);
+
+      if Token = Tok_Range then
+         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
+      end if;
+
+      return Constraint_Node;
+   end P_Digits_Constraint;
+
+   -----------------------------
+   -- 3.5.9  Delta Constraint --
+   -----------------------------
+
+   --  DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
+
+   --  Note: this is an obsolescent feature in Ada 95 (I.3)
+
+   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
+
+   --  The caller has checked that the initial token is DELTA
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Delta_Constraint return Node_Id is
+      Constraint_Node : Node_Id;
+      Expr_Node : Node_Id;
+
+   begin
+      Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
+      Scan; -- past DELTA
+      Expr_Node := P_Expression_No_Right_Paren;
+      Check_Simple_Expression_In_Ada_83 (Expr_Node);
+      Set_Delta_Expression (Constraint_Node, Expr_Node);
+
+      if Token = Tok_Range then
+         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
+      end if;
+
+      return Constraint_Node;
+   end P_Delta_Constraint;
+
+   --------------------------------
+   -- 3.6  Array Type Definition --
+   --------------------------------
+
+   --  ARRAY_TYPE_DEFINITION ::=
+   --    UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
+
+   --  UNCONSTRAINED_ARRAY_DEFINITION ::=
+   --    array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
+   --      COMPONENT_DEFINITION
+
+   --  INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
+
+   --  CONSTRAINED_ARRAY_DEFINITION ::=
+   --    array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
+   --      COMPONENT_DEFINITION
+
+   --  DISCRETE_SUBTYPE_DEFINITION ::=
+   --    DISCRETE_SUBTYPE_INDICATION | RANGE
+
+   --  COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+
+   --  The caller has checked that the initial token is ARRAY
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Array_Type_Definition return Node_Id is
+      Array_Loc  : Source_Ptr;
+      Def_Node   : Node_Id;
+      Subs_List  : List_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Array_Loc := Token_Ptr;
+      Scan; -- past ARRAY
+      Subs_List := New_List;
+      T_Left_Paren;
+
+      --  It's quite tricky to disentangle these two possibilities, so we do
+      --  a prescan to determine which case we have and then reset the scan.
+      --  The prescan skips past possible subtype mark tokens.
+
+      Save_Scan_State (Scan_State); -- just after paren
+
+      while Token in Token_Class_Desig or else
+            Token = Tok_Dot or else
+            Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
+      loop
+         Scan;
+      end loop;
+
+      --  If we end up on RANGE <> then we have the unconstrained case. We
+      --  will also allow the RANGE to be omitted, just to improve error
+      --  handling for a case like array (integer <>) of integer;
+
+      Scan; -- past possible RANGE or <>
+
+      if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
+         Prev_Token = Tok_Box
+      then
+         Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
+         Restore_Scan_State (Scan_State); -- to first subtype mark
+
+         loop
+            Append (P_Subtype_Mark_Resync, Subs_List);
+            T_Range;
+            T_Box;
+            exit when Token = Tok_Right_Paren or else Token = Tok_Of;
+            T_Comma;
+         end loop;
+
+         Set_Subtype_Marks (Def_Node, Subs_List);
+
+      else
+         Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
+         Restore_Scan_State (Scan_State); -- to first discrete range
+
+         loop
+            Append (P_Discrete_Subtype_Definition, Subs_List);
+            exit when not Comma_Present;
+         end loop;
+
+         Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
+      end if;
+
+      T_Right_Paren;
+      T_Of;
+
+      if Token = Tok_Aliased then
+         Set_Aliased_Present (Def_Node, True);
+         Scan; -- past ALIASED
+      end if;
+
+      Set_Subtype_Indication (Def_Node, P_Subtype_Indication);
+      return Def_Node;
+   end P_Array_Type_Definition;
+
+   -----------------------------------------
+   -- 3.6  Unconstrained Array Definition --
+   -----------------------------------------
+
+   --  Parsed by P_Array_Type_Definition (3.6)
+
+   ---------------------------------------
+   -- 3.6  Constrained Array Definition --
+   ---------------------------------------
+
+   --  Parsed by P_Array_Type_Definition (3.6)
+
+   --------------------------------------
+   -- 3.6  Discrete Subtype Definition --
+   --------------------------------------
+
+   --  DISCRETE_SUBTYPE_DEFINITION ::=
+   --    discrete_SUBTYPE_INDICATION | RANGE
+
+   --  Note: the discrete subtype definition appearing in a constrained
+   --  array definition is parsed by P_Array_Type_Definition (3.6)
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Discrete_Subtype_Definition return Node_Id is
+   begin
+
+      --  The syntax of a discrete subtype definition is identical to that
+      --  of a discrete range, so we simply share the same parsing code.
+
+      return P_Discrete_Range;
+   end P_Discrete_Subtype_Definition;
+
+   -------------------------------
+   -- 3.6  Component Definition --
+   -------------------------------
+
+   --  For the array case, parsed by P_Array_Type_Definition (3.6)
+   --  For the record case, parsed by P_Component_Declaration (3.8)
+
+   -----------------------------
+   -- 3.6.1  Index Constraint --
+   -----------------------------
+
+   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
+
+   ---------------------------
+   -- 3.6.1  Discrete Range --
+   ---------------------------
+
+   --  DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
+
+   --  The possible forms for a discrete range are:
+
+      --   Subtype_Mark                           (SUBTYPE_INDICATION, 3.2.2)
+      --   Subtype_Mark range Range               (SUBTYPE_INDICATION, 3.2.2)
+      --   Range_Attribute                        (RANGE, 3.5)
+      --   Simple_Expression .. Simple_Expression (RANGE, 3.5)
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Discrete_Range return Node_Id is
+      Expr_Node  : Node_Id;
+      Range_Node : Node_Id;
+
+   begin
+      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
+
+      if Expr_Form = EF_Range_Attr then
+         return Expr_Node;
+
+      elsif Token = Tok_Range then
+         if Expr_Form /= EF_Simple_Name then
+            Error_Msg_SC ("range must be preceded by subtype mark");
+         end if;
+
+         return P_Subtype_Indication (Expr_Node);
+
+      --  Check Expression .. Expression case
+
+      elsif Token = Tok_Dot_Dot then
+         Range_Node := New_Node (N_Range, Token_Ptr);
+         Set_Low_Bound (Range_Node, Expr_Node);
+         Scan; -- past ..
+         Expr_Node := P_Expression;
+         Check_Simple_Expression (Expr_Node);
+         Set_High_Bound (Range_Node, Expr_Node);
+         return Range_Node;
+
+      --  Otherwise we must have a subtype mark
+
+      elsif Expr_Form = EF_Simple_Name then
+         return Expr_Node;
+
+      --  If incorrect, complain that we expect ..
+
+      else
+         T_Dot_Dot;
+         return Expr_Node;
+      end if;
+   end P_Discrete_Range;
+
+   ----------------------------
+   -- 3.7  Discriminant Part --
+   ----------------------------
+
+   --  DISCRIMINANT_PART ::=
+   --    UNKNOWN_DISCRIMINANT_PART
+   --  | KNOWN_DISCRIMINANT_PART
+
+   --  A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
+   --  or P_Unknown_Discriminant_Part (3.7), since we know which we want.
+
+   ------------------------------------
+   -- 3.7  Unknown Discriminant Part --
+   ------------------------------------
+
+   --  UNKNOWN_DISCRIMINANT_PART ::= (<>)
+
+   --  If no unknown discriminant part is present, then False is returned,
+   --  otherwise the unknown discriminant is scanned out and True is returned.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Unknown_Discriminant_Part_Opt return Boolean is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token /= Tok_Left_Paren then
+         return False;
+
+      else
+         Save_Scan_State (Scan_State);
+         Scan; -- past the left paren
+
+         if Token = Tok_Box then
+
+            if Ada_83 then
+               Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
+            end if;
+
+            Scan; -- past the box
+            T_Right_Paren; -- must be followed by right paren
+            return True;
+
+         else
+            Restore_Scan_State (Scan_State);
+            return False;
+         end if;
+      end if;
+   end P_Unknown_Discriminant_Part_Opt;
+
+   ----------------------------------
+   -- 3.7  Known Discriminant Part --
+   ----------------------------------
+
+   --  KNOWN_DISCRIMINANT_PART ::=
+   --    (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
+
+   --  DISCRIMINANT_SPECIFICATION ::=
+   --    DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+   --      [:= DEFAULT_EXPRESSION]
+   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+   --      [:= DEFAULT_EXPRESSION]
+
+   --  If no known discriminant part is present, then No_List is returned
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Known_Discriminant_Part_Opt return List_Id is
+      Specification_Node : Node_Id;
+      Specification_List : List_Id;
+      Ident_Sloc         : Source_Ptr;
+      Scan_State         : Saved_Scan_State;
+      Num_Idents         : Nat;
+      Ident              : Nat;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  This array holds the list of defining identifiers. The upper bound
+      --  of 4096 is intended to be essentially infinite, and we do not even
+      --  bother to check for it being exceeded.
+
+   begin
+      if Token = Tok_Left_Paren then
+         Specification_List := New_List;
+         Scan; -- past (
+         P_Pragmas_Misplaced;
+
+         Specification_Loop : loop
+
+            Ident_Sloc := Token_Ptr;
+            Idents (1) := P_Defining_Identifier;
+            Num_Idents := 1;
+
+            while Comma_Present loop
+               Num_Idents := Num_Idents + 1;
+               Idents (Num_Idents) := P_Defining_Identifier;
+            end loop;
+
+            T_Colon;
+
+            --  If there are multiple identifiers, we repeatedly scan the
+            --  type and initialization expression information by resetting
+            --  the scan pointer (so that we get completely separate trees
+            --  for each occurrence).
+
+            if Num_Idents > 1 then
+               Save_Scan_State (Scan_State);
+            end if;
+
+            --  Loop through defining identifiers in list
+
+            Ident := 1;
+            Ident_Loop : loop
+               Specification_Node :=
+                 New_Node (N_Discriminant_Specification, Ident_Sloc);
+               Set_Defining_Identifier (Specification_Node, Idents (Ident));
+
+               if Token = Tok_Access then
+                  if Ada_83 then
+                     Error_Msg_SC
+                       ("(Ada 83) access discriminant not allowed!");
+                  end if;
+
+                  Set_Discriminant_Type
+                    (Specification_Node, P_Access_Definition);
+               else
+                  Set_Discriminant_Type
+                    (Specification_Node, P_Subtype_Mark);
+                  No_Constraint;
+               end if;
+
+               Set_Expression
+                 (Specification_Node, Init_Expr_Opt (True));
+
+               if Ident > 1 then
+                  Set_Prev_Ids (Specification_Node, True);
+               end if;
+
+               if Ident < Num_Idents then
+                  Set_More_Ids (Specification_Node, True);
+               end if;
+
+               Append (Specification_Node, Specification_List);
+               exit Ident_Loop when Ident = Num_Idents;
+               Ident := Ident + 1;
+               Restore_Scan_State (Scan_State);
+            end loop Ident_Loop;
+
+            exit Specification_Loop when Token /= Tok_Semicolon;
+            Scan; -- past ;
+            P_Pragmas_Misplaced;
+         end loop Specification_Loop;
+
+         T_Right_Paren;
+         return Specification_List;
+
+      else
+         return No_List;
+      end if;
+   end P_Known_Discriminant_Part_Opt;
+
+   -------------------------------------
+   -- 3.7  DIscriminant Specification --
+   -------------------------------------
+
+   --  Parsed by P_Known_Discriminant_Part_Opt (3.7)
+
+   -----------------------------
+   -- 3.7  Default Expression --
+   -----------------------------
+
+   --  Always parsed (simply as an Expression) by the parent construct
+
+   ------------------------------------
+   -- 3.7.1  Discriminant Constraint --
+   ------------------------------------
+
+   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
+
+   --------------------------------------------------------
+   -- 3.7.1  Index or Discriminant Constraint (also 3.6) --
+   --------------------------------------------------------
+
+   --  DISCRIMINANT_CONSTRAINT ::=
+   --    (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
+
+   --  DISCRIMINANT_ASSOCIATION ::=
+   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
+   --      EXPRESSION
+
+   --  This routine parses either an index or a discriminant constraint. As
+   --  is clear from the above grammar, it is often possible to clearly
+   --  determine which of the two possibilities we have, but there are
+   --  cases (those in which we have a series of expressions of the same
+   --  syntactic form as subtype indications), where we cannot tell. Since
+   --  this means that in any case the semantic phase has to distinguish
+   --  between the two, there is not much point in the parser trying to
+   --  distinguish even those cases where the difference is clear. In any
+   --  case, if we have a situation like:
+
+   --     (A => 123, 235 .. 500)
+
+   --  it is not clear which of the two items is the wrong one, better to
+   --  let the semantic phase give a clear message. Consequently, this
+   --  routine in general returns a list of items which can be either
+   --  discrete ranges or discriminant associations.
+
+   --  The caller has checked that the initial token is a left paren
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Index_Or_Discriminant_Constraint return Node_Id is
+      Scan_State  : Saved_Scan_State;
+      Constr_Node : Node_Id;
+      Constr_List : List_Id;
+      Expr_Node   : Node_Id;
+      Result_Node : Node_Id;
+
+   begin
+      Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
+      Scan; -- past (
+      Constr_List := New_List;
+      Set_Constraints (Result_Node, Constr_List);
+
+      --  The two syntactic forms are a little mixed up, so what we are doing
+      --  here is looking at the first entry to determine which case we have
+
+      --  A discriminant constraint is a list of discriminant associations,
+      --  which have one of the following possible forms:
+
+      --    Expression
+      --    Id => Expression
+      --    Id | Id | .. | Id => Expression
+
+      --  An index constraint is a list of discrete ranges which have one
+      --  of the following possible forms:
+
+      --    Subtype_Mark
+      --    Subtype_Mark range Range
+      --    Range_Attribute
+      --    Simple_Expression .. Simple_Expression
+
+      --  Loop through discriminants in list
+
+      loop
+         --  Check cases of Id => Expression or Id | Id => Expression
+
+         if Token = Tok_Identifier then
+            Save_Scan_State (Scan_State); -- at Id
+            Scan; -- past Id
+
+            if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
+               Restore_Scan_State (Scan_State); -- to Id
+               Append (P_Discriminant_Association, Constr_List);
+               goto Loop_Continue;
+            else
+               Restore_Scan_State (Scan_State); -- to Id
+            end if;
+         end if;
+
+         --  Otherwise scan out an expression and see what we have got
+
+         Expr_Node := P_Expression_Or_Range_Attribute;
+
+         if Expr_Form = EF_Range_Attr then
+            Append (Expr_Node, Constr_List);
+
+         elsif Token = Tok_Range then
+            if Expr_Form /= EF_Simple_Name then
+               Error_Msg_SC ("subtype mark required before RANGE");
+            end if;
+
+            Append (P_Subtype_Indication (Expr_Node), Constr_List);
+            goto Loop_Continue;
+
+         --  Check Simple_Expression .. Simple_Expression case
+
+         elsif Token = Tok_Dot_Dot then
+            Check_Simple_Expression (Expr_Node);
+            Constr_Node := New_Node (N_Range, Token_Ptr);
+            Set_Low_Bound (Constr_Node, Expr_Node);
+            Scan; -- past ..
+            Expr_Node := P_Expression;
+            Check_Simple_Expression (Expr_Node);
+            Set_High_Bound (Constr_Node, Expr_Node);
+            Append (Constr_Node, Constr_List);
+            goto Loop_Continue;
+
+         --  Case of an expression which could be either form
+
+         else
+            Append (Expr_Node, Constr_List);
+            goto Loop_Continue;
+         end if;
+
+         --  Here with a single entry scanned
+
+         <<Loop_Continue>>
+            exit when not Comma_Present;
+
+      end loop;
+
+      T_Right_Paren;
+      return Result_Node;
+
+   end P_Index_Or_Discriminant_Constraint;
+
+   -------------------------------------
+   -- 3.7.1  Discriminant Association --
+   -------------------------------------
+
+   --  DISCRIMINANT_ASSOCIATION ::=
+   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
+   --      EXPRESSION
+
+   --  This routine is used only when the name list is present and the caller
+   --  has already checked this (by scanning ahead and repositioning the
+   --  scan).
+
+   --  Error_Recovery: cannot raise Error_Resync;
+
+   function P_Discriminant_Association return Node_Id is
+      Discr_Node : Node_Id;
+      Names_List : List_Id;
+      Ident_Sloc : Source_Ptr;
+
+   begin
+      Ident_Sloc := Token_Ptr;
+      Names_List := New_List;
+
+      loop
+         Append (P_Identifier, Names_List);
+         exit when Token /= Tok_Vertical_Bar;
+         Scan; -- past |
+      end loop;
+
+      Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
+      Set_Selector_Names (Discr_Node, Names_List);
+      TF_Arrow;
+      Set_Expression (Discr_Node, P_Expression);
+      return Discr_Node;
+   end P_Discriminant_Association;
+
+   ---------------------------------
+   -- 3.8  Record Type Definition --
+   ---------------------------------
+
+   --  RECORD_TYPE_DEFINITION ::=
+   --    [[abstract] tagged] [limited] RECORD_DEFINITION
+
+   --  There is no node in the tree for a record type definition. Instead
+   --  a record definition node appears, with possible Abstract_Present,
+   --  Tagged_Present, and Limited_Present flags set appropriately.
+
+   ----------------------------
+   -- 3.8  Record Definition --
+   ----------------------------
+
+   --  RECORD_DEFINITION ::=
+   --    record
+   --      COMPONENT_LIST
+   --    end record
+   --  | null record
+
+   --  Note: in the case where a record definition node is used to represent
+   --  a record type definition, the caller sets the Tagged_Present and
+   --  Limited_Present flags in the resulting N_Record_Definition node as
+   --  required.
+
+   --  Note that the RECORD token at the start may be missing in certain
+   --  error situations, so this function is expected to post the error
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Record_Definition return Node_Id is
+      Rec_Node : Node_Id;
+
+   begin
+      Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
+
+      --  Null record case
+
+      if Token = Tok_Null then
+         Scan; -- past NULL
+         T_Record;
+         Set_Null_Present (Rec_Node, True);
+
+      --  Case starting with RECORD keyword. Build scope stack entry. For the
+      --  column, we use the first non-blank character on the line, to deal
+      --  with situations such as:
+
+      --    type X is record
+      --      ...
+      --    end record;
+
+      --  which is not official RM indentation, but is not uncommon usage
+
+      else
+         Push_Scope_Stack;
+         Scope.Table (Scope.Last).Etyp := E_Record;
+         Scope.Table (Scope.Last).Ecol := Start_Column;
+         Scope.Table (Scope.Last).Sloc := Token_Ptr;
+         Scope.Table (Scope.Last).Labl := Error;
+         Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
+
+         T_Record;
+
+         Set_Component_List (Rec_Node, P_Component_List);
+
+         loop
+            exit when Check_End;
+            Discard_Junk_Node (P_Component_List);
+         end loop;
+      end if;
+
+      return Rec_Node;
+   end P_Record_Definition;
+
+   -------------------------
+   -- 3.8  Component List --
+   -------------------------
+
+   --  COMPONENT_LIST ::=
+   --    COMPONENT_ITEM {COMPONENT_ITEM}
+   --  | {COMPONENT_ITEM} VARIANT_PART
+   --  | null;
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Component_List return Node_Id is
+      Component_List_Node : Node_Id;
+      Decls_List          : List_Id;
+      Scan_State          : Saved_Scan_State;
+
+   begin
+      Component_List_Node := New_Node (N_Component_List, Token_Ptr);
+      Decls_List := New_List;
+
+      if Token = Tok_Null then
+         Scan; -- past NULL
+         TF_Semicolon;
+         P_Pragmas_Opt (Decls_List);
+         Set_Null_Present (Component_List_Node, True);
+         return Component_List_Node;
+
+      else
+         P_Pragmas_Opt (Decls_List);
+
+         if Token /= Tok_Case then
+            Component_Scan_Loop : loop
+               P_Component_Items (Decls_List);
+               P_Pragmas_Opt (Decls_List);
+
+               exit Component_Scan_Loop when Token = Tok_End
+                 or else Token = Tok_Case
+                 or else Token = Tok_When;
+
+               --  We are done if we do not have an identifier. However, if
+               --  we have a misspelled reserved identifier that is in a column
+               --  to the right of the record definition, we will treat it as
+               --  an identifier. It turns out to be too dangerous in practice
+               --  to accept such a mis-spelled identifier which does not have
+               --  this additional clue that confirms the incorrect spelling.
+
+               if Token /= Tok_Identifier then
+                  if Start_Column > Scope.Table (Scope.Last).Ecol
+                    and then Is_Reserved_Identifier
+                  then
+                     Save_Scan_State (Scan_State); -- at reserved id
+                     Scan; -- possible reserved id
+
+                     if Token = Tok_Comma or else Token = Tok_Colon then
+                        Restore_Scan_State (Scan_State);
+                        Scan_Reserved_Identifier (Force_Msg => True);
+
+                     --  Note reserved identifier used as field name after
+                     --  all because not followed by colon or comma
+
+                     else
+                        Restore_Scan_State (Scan_State);
+                        exit Component_Scan_Loop;
+                     end if;
+
+                  --  Non-identifier that definitely was not reserved id
+
+                  else
+                     exit Component_Scan_Loop;
+                  end if;
+               end if;
+            end loop Component_Scan_Loop;
+         end if;
+
+         if Token = Tok_Case then
+            Set_Variant_Part (Component_List_Node, P_Variant_Part);
+
+            --  Check for junk after variant part
+
+            if Token = Tok_Identifier then
+               Save_Scan_State (Scan_State);
+               Scan; -- past identifier
+
+               if Token = Tok_Colon then
+                  Restore_Scan_State (Scan_State);
+                  Error_Msg_SC ("component may not follow variant part");
+                  Discard_Junk_Node (P_Component_List);
+
+               elsif Token = Tok_Case then
+                  Restore_Scan_State (Scan_State);
+                  Error_Msg_SC ("only one variant part allowed in a record");
+                  Discard_Junk_Node (P_Component_List);
+
+               else
+                  Restore_Scan_State (Scan_State);
+               end if;
+            end if;
+         end if;
+      end if;
+
+      Set_Component_Items (Component_List_Node, Decls_List);
+      return Component_List_Node;
+
+   end P_Component_List;
+
+   -------------------------
+   -- 3.8  Component Item --
+   -------------------------
+
+   --  COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
+
+   --  COMPONENT_DECLARATION ::=
+   --    DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
+   --      [:= DEFAULT_EXPRESSION];
+
+   --  COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
+
+   --  Error recovery: cannot raise Error_Resync, if an error occurs,
+   --  the scan is positioned past the following semicolon.
+
+   --  Note: we do not yet allow representation clauses to appear as component
+   --  items, do we need to add this capability sometime in the future ???
+
+   procedure P_Component_Items (Decls : List_Id) is
+      Decl_Node  : Node_Id;
+      Scan_State : Saved_Scan_State;
+      Num_Idents : Nat;
+      Ident      : Nat;
+      Ident_Sloc : Source_Ptr;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  This array holds the list of defining identifiers. The upper bound
+      --  of 4096 is intended to be essentially infinite, and we do not even
+      --  bother to check for it being exceeded.
+
+   begin
+      if Token /= Tok_Identifier then
+         Error_Msg_SC ("component declaration expected");
+         Resync_Past_Semicolon;
+         return;
+      end if;
+
+      Ident_Sloc := Token_Ptr;
+      Idents (1) := P_Defining_Identifier;
+      Num_Idents := 1;
+
+      while Comma_Present loop
+         Num_Idents := Num_Idents + 1;
+         Idents (Num_Idents) := P_Defining_Identifier;
+      end loop;
+
+      T_Colon;
+
+      --  If there are multiple identifiers, we repeatedly scan the
+      --  type and initialization expression information by resetting
+      --  the scan pointer (so that we get completely separate trees
+      --  for each occurrence).
+
+      if Num_Idents > 1 then
+         Save_Scan_State (Scan_State);
+      end if;
+
+      --  Loop through defining identifiers in list
+
+      Ident := 1;
+      Ident_Loop : loop
+
+         --  The following block is present to catch Error_Resync
+         --  which causes the parse to be reset past the semicolon
+
+         begin
+            Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
+            Set_Defining_Identifier (Decl_Node, Idents (Ident));
+
+            if Token = Tok_Constant then
+               Error_Msg_SC ("constant components are not permitted");
+               Scan;
+            end if;
+
+            if Token_Name = Name_Aliased then
+               Check_95_Keyword (Tok_Aliased, Tok_Identifier);
+            end if;
+
+            if Token = Tok_Aliased then
+               Scan; -- past ALIASED
+               Set_Aliased_Present (Decl_Node, True);
+            end if;
+
+            if Token = Tok_Array then
+               Error_Msg_SC ("anonymous arrays not allowed as components");
+               raise Error_Resync;
+            end if;
+
+            Set_Subtype_Indication (Decl_Node, P_Subtype_Indication);
+            Set_Expression (Decl_Node, Init_Expr_Opt);
+
+            if Ident > 1 then
+               Set_Prev_Ids (Decl_Node, True);
+            end if;
+
+            if Ident < Num_Idents then
+               Set_More_Ids (Decl_Node, True);
+            end if;
+
+            Append (Decl_Node, Decls);
+
+         exception
+            when Error_Resync =>
+               if Token /= Tok_End then
+                  Resync_Past_Semicolon;
+               end if;
+         end;
+
+         exit Ident_Loop when Ident = Num_Idents;
+         Ident := Ident + 1;
+         Restore_Scan_State (Scan_State);
+
+      end loop Ident_Loop;
+
+      TF_Semicolon;
+
+   end P_Component_Items;
+
+   --------------------------------
+   -- 3.8  Component Declaration --
+   --------------------------------
+
+   --  Parsed by P_Component_Items (3.8)
+
+   -------------------------
+   -- 3.8.1  Variant Part --
+   -------------------------
+
+   --  VARIANT_PART ::=
+   --    case discriminant_DIRECT_NAME is
+   --      VARIANT
+   --      {VARIANT}
+   --    end case;
+
+   --  The caller has checked that the initial token is CASE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Variant_Part return Node_Id is
+      Variant_Part_Node : Node_Id;
+      Variants_List     : List_Id;
+      Case_Node         : Node_Id;
+      Case_Sloc         : Source_Ptr;
+
+   begin
+      Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Case;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+
+      Scan; -- past CASE
+      Case_Node := P_Expression;
+      Case_Sloc := Token_Ptr;
+      Set_Name (Variant_Part_Node, Case_Node);
+
+      if Nkind (Case_Node) /= N_Identifier then
+         Set_Name (Variant_Part_Node, Error);
+         Error_Msg ("discriminant name expected", Sloc (Case_Node));
+      end if;
+
+      TF_Is;
+      Variants_List := New_List;
+      P_Pragmas_Opt (Variants_List);
+
+      --  Test missing variant
+
+      if Token = Tok_End then
+         Error_Msg_BC ("WHEN expected (must have at least one variant)");
+      else
+         Append (P_Variant, Variants_List);
+      end if;
+
+      --  Loop through variants, note that we allow if in place of when,
+      --  this error will be detected and handled in P_Variant.
+
+      loop
+         P_Pragmas_Opt (Variants_List);
+
+         if Token /= Tok_When
+           and then Token /= Tok_If
+           and then Token /= Tok_Others
+         then
+            exit when Check_End;
+         end if;
+
+         Append (P_Variant, Variants_List);
+      end loop;
+
+      Set_Variants (Variant_Part_Node, Variants_List);
+      return Variant_Part_Node;
+
+   end P_Variant_Part;
+
+   --------------------
+   -- 3.8.1  Variant --
+   --------------------
+
+   --  VARIANT ::=
+   --    when DISCRETE_CHOICE_LIST =>
+   --      COMPONENT_LIST
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  The initial token on entry is either WHEN, IF or OTHERS
+
+   function P_Variant return Node_Id is
+      Variant_Node : Node_Id;
+
+   begin
+      --  Special check to recover nicely from use of IF in place of WHEN
+
+      if Token = Tok_If then
+         T_When;
+         Scan; -- past IF
+      else
+         T_When;
+      end if;
+
+      Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
+      Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
+      TF_Arrow;
+      Set_Component_List (Variant_Node, P_Component_List);
+      return Variant_Node;
+   end P_Variant;
+
+   ---------------------------------
+   -- 3.8.1  Discrete Choice List --
+   ---------------------------------
+
+   --  DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
+
+   --  DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
+
+   --  Note: in Ada 83, the expression must be a simple expression
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Discrete_Choice_List return List_Id is
+      Choices     : List_Id;
+      Expr_Node   : Node_Id;
+      Choice_Node : Node_Id;
+
+   begin
+      Choices := New_List;
+
+      loop
+         if Token = Tok_Others then
+            Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
+            Scan; -- past OTHERS
+
+         else
+            begin
+               Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
+
+               if Token = Tok_Colon
+                 and then Nkind (Expr_Node) = N_Identifier
+               then
+                  Error_Msg_SP ("label not permitted in this context");
+                  Scan; -- past colon
+
+               elsif Expr_Form = EF_Range_Attr then
+                  Append (Expr_Node, Choices);
+
+               elsif Token = Tok_Dot_Dot then
+                  Check_Simple_Expression (Expr_Node);
+                  Choice_Node := New_Node (N_Range, Token_Ptr);
+                  Set_Low_Bound (Choice_Node, Expr_Node);
+                  Scan; -- past ..
+                  Expr_Node := P_Expression_No_Right_Paren;
+                  Check_Simple_Expression (Expr_Node);
+                  Set_High_Bound (Choice_Node, Expr_Node);
+                  Append (Choice_Node, Choices);
+
+               elsif Expr_Form = EF_Simple_Name then
+                  if Token = Tok_Range then
+                     Append (P_Subtype_Indication (Expr_Node), Choices);
+
+                  elsif Token in Token_Class_Consk then
+                     Error_Msg_SC
+                        ("the only constraint allowed here " &
+                         "is a range constraint");
+                     Discard_Junk_Node (P_Constraint_Opt);
+                     Append (Expr_Node, Choices);
+
+                  else
+                     Append (Expr_Node, Choices);
+                  end if;
+
+               else
+                  Check_Simple_Expression_In_Ada_83 (Expr_Node);
+                  Append (Expr_Node, Choices);
+               end if;
+
+            exception
+               when Error_Resync =>
+                  Resync_Choice;
+                  return Error_List;
+            end;
+         end if;
+
+         if Token = Tok_Comma then
+            Error_Msg_SC (""","" should be ""|""");
+         else
+            exit when Token /= Tok_Vertical_Bar;
+         end if;
+
+         Scan; -- past | or comma
+      end loop;
+
+      return Choices;
+   end P_Discrete_Choice_List;
+
+   ----------------------------
+   -- 3.8.1  Discrete Choice --
+   ----------------------------
+
+   --  Parsed by P_Discrete_Choice_List (3.8.1)
+
+   ----------------------------------
+   -- 3.9.1  Record Extension Part --
+   ----------------------------------
+
+   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
+
+   --  Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
+
+   ----------------------------------
+   -- 3.10  Access Type Definition --
+   ----------------------------------
+
+   --  ACCESS_TYPE_DEFINITION ::=
+   --    ACCESS_TO_OBJECT_DEFINITION
+   --  | ACCESS_TO_SUBPROGRAM_DEFINITION
+
+   --  ACCESS_TO_OBJECT_DEFINITION ::=
+   --    access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+
+   --  GENERAL_ACCESS_MODIFIER ::= all | constant
+
+   --  ACCESS_TO_SUBPROGRAM_DEFINITION
+   --    access [protected] procedure PARAMETER_PROFILE
+   --  | access [protected] function PARAMETER_AND_RESULT_PROFILE
+
+   --  PARAMETER_PROFILE ::= [FORMAL_PART]
+
+   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
+
+   --  The caller has checked that the initial token is ACCESS
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Access_Type_Definition return Node_Id is
+      Prot_Flag     : Boolean;
+      Access_Loc    : Source_Ptr;
+      Type_Def_Node : Node_Id;
+
+      procedure Check_Junk_Subprogram_Name;
+      --  Used in access to subprogram definition cases to check for an
+      --  identifier or operator symbol that does not belong.
+
+      procedure Check_Junk_Subprogram_Name is
+         Saved_State : Saved_Scan_State;
+
+      begin
+         if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
+            Save_Scan_State (Saved_State);
+            Scan; -- past possible junk subprogram name
+
+            if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
+               Error_Msg_SP ("unexpected subprogram name ignored");
+               return;
+
+            else
+               Restore_Scan_State (Saved_State);
+            end if;
+         end if;
+      end Check_Junk_Subprogram_Name;
+
+   --  Start of processing for P_Access_Type_Definition
+
+   begin
+      Access_Loc := Token_Ptr;
+      Scan; -- past ACCESS
+
+      if Token_Name = Name_Protected then
+         Check_95_Keyword (Tok_Protected, Tok_Procedure);
+         Check_95_Keyword (Tok_Protected, Tok_Function);
+      end if;
+
+      Prot_Flag := (Token = Tok_Protected);
+
+      if Prot_Flag then
+         Scan; -- past PROTECTED
+         if Token /= Tok_Procedure and then Token /= Tok_Function then
+            Error_Msg_SC ("FUNCTION or PROCEDURE expected");
+         end if;
+      end if;
+
+      if Token = Tok_Procedure then
+         if Ada_83 then
+            Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
+         end if;
+
+         Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
+         Scan; -- past PROCEDURE
+         Check_Junk_Subprogram_Name;
+         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
+         Set_Protected_Present (Type_Def_Node, Prot_Flag);
+
+      elsif Token = Tok_Function then
+         if Ada_83 then
+            Error_Msg_SC ("(Ada 83) access to function not allowed!");
+         end if;
+
+         Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
+         Scan; -- past FUNCTION
+         Check_Junk_Subprogram_Name;
+         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
+         Set_Protected_Present (Type_Def_Node, Prot_Flag);
+         TF_Return;
+         Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
+         No_Constraint;
+
+      else
+         Type_Def_Node :=
+           New_Node (N_Access_To_Object_Definition, Access_Loc);
+
+         if Token = Tok_All or else Token = Tok_Constant then
+            if Ada_83 then
+               Error_Msg_SC ("(Ada 83) access modifier not allowed!");
+            end if;
+
+            if Token = Tok_All then
+               Set_All_Present (Type_Def_Node, True);
+
+            else
+               Set_Constant_Present (Type_Def_Node, True);
+            end if;
+
+            Scan; -- past ALL or CONSTANT
+         end if;
+
+         Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication);
+      end if;
+
+      return Type_Def_Node;
+   end P_Access_Type_Definition;
+
+   ---------------------------------------
+   -- 3.10  Access To Object Definition --
+   ---------------------------------------
+
+   --  Parsed by P_Access_Type_Definition (3.10)
+
+   -----------------------------------
+   -- 3.10  General Access Modifier --
+   -----------------------------------
+
+   --  Parsed by P_Access_Type_Definition (3.10)
+
+   -------------------------------------------
+   -- 3.10  Access To Subprogram Definition --
+   -------------------------------------------
+
+   --  Parsed by P_Access_Type_Definition (3.10)
+
+   -----------------------------
+   -- 3.10  Access Definition --
+   -----------------------------
+
+   --  ACCESS_DEFINITION ::= access SUBTYPE_MARK
+
+   --  The caller has checked that the initial token is ACCESS
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Access_Definition return Node_Id is
+      Def_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Access_Definition, Token_Ptr);
+      Scan; -- past ACCESS
+      Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
+      No_Constraint;
+      return Def_Node;
+   end P_Access_Definition;
+
+   -----------------------------------------
+   -- 3.10.1  Incomplete Type Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   ----------------------------
+   -- 3.11  Declarative Part --
+   ----------------------------
+
+   --  DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
+
+   --  Error recovery: cannot raise Error_Resync (because P_Declarative_Items
+   --  handles errors, and returns cleanly after an error has occurred)
+
+   function P_Declarative_Part return List_Id is
+      Decls : List_Id;
+      Done  : Boolean;
+
+   begin
+      --  Indicate no bad declarations detected yet. This will be reset by
+      --  P_Declarative_Items if a bad declaration is discovered.
+
+      Missing_Begin_Msg := No_Error_Msg;
+
+      --  Get rid of active SIS entry from outer scope. This means we will
+      --  miss some nested cases, but it doesn't seem worth the effort. See
+      --  discussion in Par for further details
+
+      SIS_Entry_Active := False;
+      Decls := New_List;
+
+      --  Loop to scan out the declarations
+
+      loop
+         P_Declarative_Items (Decls, Done, In_Spec => False);
+         exit when Done;
+      end loop;
+
+      --  Get rid of active SIS entry which is left set only if we scanned a
+      --  procedure declaration and have not found the body. We could give
+      --  an error message, but that really would be usurping the role of
+      --  semantic analysis (this really is a missing body case).
+
+      SIS_Entry_Active := False;
+      return Decls;
+   end P_Declarative_Part;
+
+   ----------------------------
+   -- 3.11  Declarative Item --
+   ----------------------------
+
+   --  DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
+
+   --  Can return Error if a junk declaration is found, or Empty if no
+   --  declaration is found (i.e. a token ending declarations, such as
+   --  BEGIN or END is encountered).
+
+   --  Error recovery: cannot raise Error_Resync. If an error resync occurs,
+   --  then the scan is set past the next semicolon and Error is returned.
+
+   procedure P_Declarative_Items
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean)
+   is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Style_Check then Style.Check_Indentation; end if;
+
+      case Token is
+
+         when Tok_Function =>
+            Check_Bad_Layout;
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Done := False;
+
+         when Tok_For =>
+            Check_Bad_Layout;
+
+            --  Check for loop (premature statement)
+
+            Save_Scan_State (Scan_State);
+            Scan; -- past FOR
+
+            if Token = Tok_Identifier then
+               Scan; -- past identifier
+
+               if Token = Tok_In then
+                  Restore_Scan_State (Scan_State);
+                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
+                  return;
+               end if;
+            end if;
+
+            --  Not a loop, so must be rep clause
+
+            Restore_Scan_State (Scan_State);
+            Append (P_Representation_Clause, Decls);
+            Done := False;
+
+         when Tok_Generic =>
+            Check_Bad_Layout;
+            Append (P_Generic, Decls);
+            Done := False;
+
+         when Tok_Identifier =>
+            Check_Bad_Layout;
+            P_Identifier_Declarations (Decls, Done, In_Spec);
+
+         when Tok_Package =>
+            Check_Bad_Layout;
+            Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Done := False;
+
+         when Tok_Pragma =>
+            Append (P_Pragma, Decls);
+            Done := False;
+
+         when Tok_Procedure =>
+            Check_Bad_Layout;
+            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
+            Done := False;
+
+         when Tok_Protected =>
+            Check_Bad_Layout;
+            Scan; -- past PROTECTED
+            Append (P_Protected, Decls);
+            Done := False;
+
+         when Tok_Subtype =>
+            Check_Bad_Layout;
+            Append (P_Subtype_Declaration, Decls);
+            Done := False;
+
+         when Tok_Task =>
+            Check_Bad_Layout;
+            Scan; -- past TASK
+            Append (P_Task, Decls);
+            Done := False;
+
+         when Tok_Type =>
+            Check_Bad_Layout;
+            Append (P_Type_Declaration, Decls);
+            Done := False;
+
+         when Tok_Use =>
+            Check_Bad_Layout;
+            Append (P_Use_Clause, Decls);
+            Done := False;
+
+         when Tok_With =>
+            Check_Bad_Layout;
+            Error_Msg_SC ("WITH can only appear in context clause");
+            raise Error_Resync;
+
+         --  BEGIN terminates the scan of a sequence of declarations unless
+         --  there is a missing subprogram body, see section on handling
+         --  semicolon in place of IS. We only treat the begin as satisfying
+         --  the subprogram declaration if it falls in the expected column
+         --  or to its right.
+
+         when Tok_Begin =>
+            if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
+
+               --  Here we have the case where a BEGIN is encountered during
+               --  declarations in a declarative part, or at the outer level,
+               --  and there is a subprogram declaration outstanding for which
+               --  no body has been supplied. This is the case where we assume
+               --  that the semicolon in the subprogram declaration should
+               --  really have been is. The active SIS entry describes the
+               --  subprogram declaration. On return the declaration has been
+               --  modified to become a body.
+
+               declare
+                  Specification_Node : Node_Id;
+                  Decl_Node          : Node_Id;
+                  Body_Node          : Node_Id;
+
+               begin
+                  --  First issue the error message. If we had a missing
+                  --  semicolon in the declaration, then change the message
+                  --  to <missing "is">
+
+                  if SIS_Missing_Semicolon_Message /= No_Error_Msg then
+                     Change_Error_Text     -- Replace: "missing "";"" "
+                       (SIS_Missing_Semicolon_Message, "missing ""is""");
+
+                  --  Otherwise we saved the semicolon position, so complain
+
+                  else
+                     Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
+                  end if;
+
+                  --  The next job is to fix up any declarations that occurred
+                  --  between the procedure header and the BEGIN. These got
+                  --  chained to the outer declarative region (immediately
+                  --  after the procedure declaration) and they should be
+                  --  chained to the subprogram itself, which is a body
+                  --  rather than a spec.
+
+                  Specification_Node := Specification (SIS_Declaration_Node);
+                  Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
+                  Body_Node := SIS_Declaration_Node;
+                  Set_Specification (Body_Node, Specification_Node);
+                  Set_Declarations (Body_Node, New_List);
+
+                  loop
+                     Decl_Node := Remove_Next (Body_Node);
+                     exit when Decl_Node = Empty;
+                     Append (Decl_Node, Declarations (Body_Node));
+                  end loop;
+
+                  --  Now make the scope table entry for the Begin-End and
+                  --  scan it out
+
+                  Push_Scope_Stack;
+                  Scope.Table (Scope.Last).Sloc := SIS_Sloc;
+                  Scope.Table (Scope.Last).Etyp := E_Name;
+                  Scope.Table (Scope.Last).Ecol := SIS_Ecol;
+                  Scope.Table (Scope.Last).Labl := SIS_Labl;
+                  Scope.Table (Scope.Last).Lreq := False;
+                  SIS_Entry_Active := False;
+                  Scan; -- past BEGIN
+                  Set_Handled_Statement_Sequence (Body_Node,
+                    P_Handled_Sequence_Of_Statements);
+                  End_Statements (Handled_Statement_Sequence (Body_Node));
+               end;
+
+               Done := False;
+
+            else
+               Done := True;
+            end if;
+
+            --  Normally an END terminates the scan for basic declarative
+            --  items. The one exception is END RECORD, which is probably
+            --  left over from some other junk.
+
+            when Tok_End =>
+               Save_Scan_State (Scan_State); -- at END
+               Scan; -- past END
+
+               if Token = Tok_Record then
+                  Error_Msg_SP ("no RECORD for this `end record`!");
+                  Scan; -- past RECORD
+                  TF_Semicolon;
+
+               else
+                  Restore_Scan_State (Scan_State); -- to END
+                  Done := True;
+               end if;
+
+         --  The following tokens which can only be the start of a statement
+         --  are considered to end a declarative part (i.e. we have a missing
+         --  BEGIN situation). We are fairly conservative in making this
+         --  judgment, because it is a real mess to go into statement mode
+         --  prematurely in reponse to a junk declaration.
+
+         when Tok_Abort     |
+              Tok_Accept    |
+              Tok_Declare   |
+              Tok_Delay     |
+              Tok_Exit      |
+              Tok_Goto      |
+              Tok_If        |
+              Tok_Loop      |
+              Tok_Null      |
+              Tok_Requeue   |
+              Tok_Select    |
+              Tok_While     =>
+
+            --  But before we decide that it's a statement, let's check for
+            --  a reserved word misused as an identifier.
+
+            if Is_Reserved_Identifier then
+               Save_Scan_State (Scan_State);
+               Scan; -- past the token
+
+               --  If reserved identifier not followed by colon or comma, then
+               --  this is most likely an assignment statement to the bad id.
+
+               if Token /= Tok_Colon and then Token /= Tok_Comma then
+                  Restore_Scan_State (Scan_State);
+                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
+                  return;
+
+               --  Otherwise we have a declaration of the bad id
+
+               else
+                  Restore_Scan_State (Scan_State);
+                  Scan_Reserved_Identifier (Force_Msg => True);
+                  P_Identifier_Declarations (Decls, Done, In_Spec);
+               end if;
+
+            --  If not reserved identifier, then it's definitely a statement
+
+            else
+               Statement_When_Declaration_Expected (Decls, Done, In_Spec);
+               return;
+            end if;
+
+         --  The token RETURN may well also signal a missing BEGIN situation,
+         --  however, we never let it end the declarative part, because it may
+         --  also be part of a half-baked function declaration.
+
+         when Tok_Return =>
+            Error_Msg_SC ("misplaced RETURN statement");
+            raise Error_Resync;
+
+         --  PRIVATE definitely terminates the declarations in a spec,
+         --  and is an error in a body.
+
+         when Tok_Private =>
+            if In_Spec then
+               Done := True;
+            else
+               Error_Msg_SC ("PRIVATE not allowed in body");
+               Scan; -- past PRIVATE
+            end if;
+
+         --  An end of file definitely terminates the declarations!
+
+         when Tok_EOF =>
+            Done := True;
+
+         --  The remaining tokens do not end the scan, but cannot start a
+         --  valid declaration, so we signal an error and resynchronize.
+         --  But first check for misuse of a reserved identifier.
+
+         when others =>
+
+            --  Here we check for a reserved identifier
+
+            if Is_Reserved_Identifier then
+               Save_Scan_State (Scan_State);
+               Scan; -- past the token
+
+               if Token /= Tok_Colon and then Token /= Tok_Comma then
+                  Restore_Scan_State (Scan_State);
+                  Set_Declaration_Expected;
+                  raise Error_Resync;
+               else
+                  Restore_Scan_State (Scan_State);
+                  Scan_Reserved_Identifier (Force_Msg => True);
+                  Check_Bad_Layout;
+                  P_Identifier_Declarations (Decls, Done, In_Spec);
+               end if;
+
+            else
+               Set_Declaration_Expected;
+               raise Error_Resync;
+            end if;
+      end case;
+
+   --  To resynchronize after an error, we scan to the next semicolon and
+   --  return with Done = False, indicating that there may still be more
+   --  valid declarations to come.
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         Done := False;
+
+   end P_Declarative_Items;
+
+   ----------------------------------
+   -- 3.11  Basic Declarative Item --
+   ----------------------------------
+
+   --  BASIC_DECLARATIVE_ITEM ::=
+   --    BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
+
+   --  Scan zero or more basic declarative items
+
+   --  Error recovery: cannot raise Error_Resync. If an error is detected, then
+   --  the scan pointer is repositioned past the next semicolon, and the scan
+   --  for declarative items continues.
+
+   function P_Basic_Declarative_Items return List_Id is
+      Decl  : Node_Id;
+      Decls : List_Id;
+      Kind  : Node_Kind;
+      Done  : Boolean;
+
+   begin
+      --  Get rid of active SIS entry from outer scope. This means we will
+      --  miss some nested cases, but it doesn't seem worth the effort. See
+      --  discussion in Par for further details
+
+      SIS_Entry_Active := False;
+
+      --  Loop to scan out declarations
+
+      Decls := New_List;
+
+      loop
+         P_Declarative_Items (Decls, Done, In_Spec => True);
+         exit when Done;
+      end loop;
+
+      --  Get rid of active SIS entry. This is set only if we have scanned a
+      --  procedure declaration and have not found the body. We could give
+      --  an error message, but that really would be usurping the role of
+      --  semantic analysis (this really is a case of a missing body).
+
+      SIS_Entry_Active := False;
+
+      --  Test for assorted illegal declarations not diagnosed elsewhere.
+
+      Decl := First (Decls);
+
+      while Present (Decl) loop
+         Kind := Nkind (Decl);
+
+         --  Test for body scanned, not acceptable as basic decl item
+
+         if Kind = N_Subprogram_Body or else
+            Kind = N_Package_Body or else
+            Kind = N_Task_Body or else
+            Kind = N_Protected_Body
+         then
+            Error_Msg
+              ("proper body not allowed in package spec", Sloc (Decl));
+
+         --  Test for body stub scanned, not acceptable as basic decl item
+
+         elsif Kind in N_Body_Stub then
+            Error_Msg
+              ("body stub not allowed in package spec", Sloc (Decl));
+
+         elsif Kind = N_Assignment_Statement then
+            Error_Msg
+              ("assignment statement not allowed in package spec",
+                 Sloc (Decl));
+         end if;
+
+         Next (Decl);
+      end loop;
+
+      return Decls;
+   end P_Basic_Declarative_Items;
+
+   ----------------
+   -- 3.11  Body --
+   ----------------
+
+   --  For proper body, see below
+   --  For body stub, see 10.1.3
+
+   -----------------------
+   -- 3.11  Proper Body --
+   -----------------------
+
+   --  Subprogram body is parsed by P_Subprogram (6.1)
+   --  Package body is parsed by P_Package (7.1)
+   --  Task body is parsed by P_Task (9.1)
+   --  Protected body is parsed by P_Protected (9.4)
+
+   ------------------------------
+   -- Set_Declaration_Expected --
+   ------------------------------
+
+   procedure Set_Declaration_Expected is
+   begin
+      Error_Msg_SC ("declaration expected");
+
+      if Missing_Begin_Msg = No_Error_Msg then
+         Missing_Begin_Msg := Get_Msg_Id;
+      end if;
+   end Set_Declaration_Expected;
+
+   ----------------------
+   -- Skip_Declaration --
+   ----------------------
+
+   procedure Skip_Declaration (S : List_Id) is
+      Dummy_Done : Boolean;
+
+   begin
+      P_Declarative_Items (S, Dummy_Done, False);
+   end Skip_Declaration;
+
+   -----------------------------------------
+   -- Statement_When_Declaration_Expected --
+   -----------------------------------------
+
+   procedure Statement_When_Declaration_Expected
+     (Decls   : List_Id;
+      Done    : out Boolean;
+      In_Spec : Boolean)
+   is
+   begin
+      --  Case of second occurrence of statement in one declaration sequence
+
+      if Missing_Begin_Msg /= No_Error_Msg then
+
+         --  In the procedure spec case, just ignore it, we only give one
+         --  message for the first occurrence, since otherwise we may get
+         --  horrible cascading if BODY was missing in the header line.
+
+         if In_Spec then
+            null;
+
+         --  In the declarative part case, take a second statement as a sure
+         --  sign that we really have a missing BEGIN, and end the declarative
+         --  part now. Note that the caller will fix up the first message to
+         --  say "missing BEGIN" so that's how the error will be signalled.
+
+         else
+            Done := True;
+            return;
+         end if;
+
+      --  Case of first occurrence of unexpected statement
+
+      else
+         --  If we are in a package spec, then give message of statement
+         --  not allowed in package spec. This message never gets changed.
+
+         if In_Spec then
+            Error_Msg_SC ("statement not allowed in package spec");
+
+         --  If in declarative part, then we give the message complaining
+         --  about finding a statement when a declaration is expected. This
+         --  gets changed to a complaint about a missing BEGIN if we later
+         --  find that no BEGIN is present.
+
+         else
+            Error_Msg_SC ("statement not allowed in declarative part");
+         end if;
+
+         --  Capture message Id. This is used for two purposes, first to
+         --  stop multiple messages, see test above, and second, to allow
+         --  the replacement of the message in the declarative part case.
+
+         Missing_Begin_Msg := Get_Msg_Id;
+      end if;
+
+      --  In all cases except the case in which we decided to terminate the
+      --  declaration sequence on a second error, we scan out the statement
+      --  and append it to the list of declarations (note that the semantics
+      --  can handle statements in a declaration list so if we proceed to
+      --  call the semantic phase, all will be (reasonably) well!
+
+      Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
+
+      --  Done is set to False, since we want to continue the scan of
+      --  declarations, hoping that this statement was a temporary glitch.
+      --  If we indeed are now in the statement part (i.e. this was a missing
+      --  BEGIN, then it's not terrible, we will simply keep calling this
+      --  procedure to process the statements one by one, and then finally
+      --  hit the missing BEGIN, which will clean up the error message.
+
+      Done := False;
+
+   end Statement_When_Declaration_Expected;
+
+end Ch3;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
new file mode 100644
index 0000000..30fba56
--- /dev/null
+++ b/gcc/ada/par-ch4.adb
@@ -0,0 +1,2298 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 4                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.91 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch4 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function P_Aggregate_Or_Paren_Expr                 return Node_Id;
+   function P_Allocator                               return Node_Id;
+   function P_Record_Or_Array_Component_Association   return Node_Id;
+   function P_Factor                                  return Node_Id;
+   function P_Primary                                 return Node_Id;
+   function P_Relation                                return Node_Id;
+   function P_Term                                    return Node_Id;
+
+   function P_Binary_Adding_Operator                  return Node_Kind;
+   function P_Logical_Operator                        return Node_Kind;
+   function P_Multiplying_Operator                    return Node_Kind;
+   function P_Relational_Operator                     return Node_Kind;
+   function P_Unary_Adding_Operator                   return Node_Kind;
+
+   procedure Bad_Range_Attribute (Loc : Source_Ptr);
+   --  Called to place complaint about bad range attribute at the given
+   --  source location. Terminates by raising Error_Resync.
+
+   function P_Range_Attribute_Reference
+     (Prefix_Node : Node_Id)
+      return        Node_Id;
+   --  Scan a range attribute reference. The caller has scanned out the
+   --  prefix. The current token is known to be an apostrophe and the
+   --  following token is known to be RANGE.
+
+   procedure Set_Op_Name (Node : Node_Id);
+   --  Procedure to set name field (Chars) in operator node
+
+   -------------------------
+   -- Bad_Range_Attribute --
+   -------------------------
+
+   procedure Bad_Range_Attribute (Loc : Source_Ptr) is
+   begin
+      Error_Msg ("range attribute cannot be used in expression", Loc);
+      Resync_Expression;
+   end Bad_Range_Attribute;
+
+   ------------------
+   -- Set_Op_Name --
+   ------------------
+
+   procedure Set_Op_Name (Node : Node_Id) is
+      type Name_Of_Type is array (N_Op) of Name_Id;
+      Name_Of : Name_Of_Type := Name_Of_Type'(
+         N_Op_And                    => Name_Op_And,
+         N_Op_Or                     => Name_Op_Or,
+         N_Op_Xor                    => Name_Op_Xor,
+         N_Op_Eq                     => Name_Op_Eq,
+         N_Op_Ne                     => Name_Op_Ne,
+         N_Op_Lt                     => Name_Op_Lt,
+         N_Op_Le                     => Name_Op_Le,
+         N_Op_Gt                     => Name_Op_Gt,
+         N_Op_Ge                     => Name_Op_Ge,
+         N_Op_Add                    => Name_Op_Add,
+         N_Op_Subtract               => Name_Op_Subtract,
+         N_Op_Concat                 => Name_Op_Concat,
+         N_Op_Multiply               => Name_Op_Multiply,
+         N_Op_Divide                 => Name_Op_Divide,
+         N_Op_Mod                    => Name_Op_Mod,
+         N_Op_Rem                    => Name_Op_Rem,
+         N_Op_Expon                  => Name_Op_Expon,
+         N_Op_Plus                   => Name_Op_Add,
+         N_Op_Minus                  => Name_Op_Subtract,
+         N_Op_Abs                    => Name_Op_Abs,
+         N_Op_Not                    => Name_Op_Not,
+
+         --  We don't really need these shift operators, since they never
+         --  appear as operators in the source, but the path of least
+         --  resistance is to put them in (the aggregate must be complete)
+
+         N_Op_Rotate_Left            => Name_Rotate_Left,
+         N_Op_Rotate_Right           => Name_Rotate_Right,
+         N_Op_Shift_Left             => Name_Shift_Left,
+         N_Op_Shift_Right            => Name_Shift_Right,
+         N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic);
+
+   begin
+      if Nkind (Node) in N_Op then
+         Set_Chars (Node, Name_Of (Nkind (Node)));
+      end if;
+   end Set_Op_Name;
+
+   --------------------------
+   -- 4.1  Name (also 6.4) --
+   --------------------------
+
+   --  NAME ::=
+   --    DIRECT_NAME        | EXPLICIT_DEREFERENCE
+   --  | INDEXED_COMPONENT  | SLICE
+   --  | SELECTED_COMPONENT | ATTRIBUTE
+   --  | TYPE_CONVERSION    | FUNCTION_CALL
+   --  | CHARACTER_LITERAL
+
+   --  DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
+
+   --  PREFIX ::= NAME | IMPLICIT_DEREFERENCE
+
+   --  EXPLICIT_DEREFERENCE ::= NAME . all
+
+   --  IMPLICIT_DEREFERENCE ::= NAME
+
+   --  INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
+
+   --  SLICE ::= PREFIX (DISCRETE_RANGE)
+
+   --  SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
+
+   --  SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
+
+   --  ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
+
+   --  ATTRIBUTE_DESIGNATOR ::=
+   --    IDENTIFIER [(static_EXPRESSION)]
+   --  | access | delta | digits
+
+   --  FUNCTION_CALL ::=
+   --    function_NAME
+   --  | function_PREFIX ACTUAL_PARAMETER_PART
+
+   --  ACTUAL_PARAMETER_PART ::=
+   --    (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
+
+   --  PARAMETER_ASSOCIATION ::=
+   --    [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
+
+   --  EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+
+   --  Note: syntactically a procedure call looks just like a function call,
+   --  so this routine is in practice used to scan out procedure calls as well.
+
+   --  On return, Expr_Form is set to either EF_Name or EF_Simple_Name
+
+   --  Error recovery: can raise Error_Resync
+
+   --  Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
+   --  followed by either a left paren (qualified expression case), or by
+   --  range (range attribute case). All other uses of apostrophe (i.e. all
+   --  other attributes) are handled in this routine.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Name return Node_Id is
+      Scan_State  : Saved_Scan_State;
+      Name_Node   : Node_Id;
+      Prefix_Node : Node_Id;
+      Ident_Node  : Node_Id;
+      Expr_Node   : Node_Id;
+      Range_Node  : Node_Id;
+      Arg_Node    : Node_Id;
+
+      Arg_List  : List_Id := No_List; -- kill junk warning
+      Attr_Name : Name_Id := No_Name; -- kill junk warning
+
+   begin
+      if Token not in Token_Class_Name then
+         Error_Msg_AP ("name expected");
+         raise Error_Resync;
+      end if;
+
+      --  Loop through designators in qualified name
+
+      Name_Node := Token_Node;
+
+      loop
+         Scan; -- past designator
+         exit when Token /= Tok_Dot;
+         Save_Scan_State (Scan_State); -- at dot
+         Scan; -- past dot
+
+         --  If we do not have another designator after the dot, then join
+         --  the normal circuit to handle a dot extension (may be .all or
+         --  character literal case). Otherwise loop back to scan the next
+         --  designator.
+
+         if Token not in Token_Class_Desig then
+            goto Scan_Name_Extension_Dot;
+         else
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Selector_Name (Name_Node, Token_Node);
+         end if;
+      end loop;
+
+      --  We have now scanned out a qualified designator. If the last token is
+      --  an operator symbol, then we certainly do not have the Snam case, so
+      --  we can just use the normal name extension check circuit
+
+      if Prev_Token = Tok_Operator_Symbol then
+         goto Scan_Name_Extension;
+      end if;
+
+      --  We have scanned out a qualified simple name, check for name extension
+      --  Note that we know there is no dot here at this stage, so the only
+      --  possible cases of name extension are apostrophe and left paren.
+
+      if Token = Tok_Apostrophe then
+         Save_Scan_State (Scan_State); -- at apostrophe
+         Scan; -- past apostrophe
+
+         --  If left paren, then this might be a qualified expression, but we
+         --  are only in the business of scanning out names, so return with
+         --  Token backed up to point to the apostrophe. The treatment for
+         --  the range attribute is similar (we do not consider x'range to
+         --  be a name in this grammar).
+
+         if Token = Tok_Left_Paren or else Token = Tok_Range then
+            Restore_Scan_State (Scan_State); -- to apostrophe
+            Expr_Form := EF_Simple_Name;
+            return Name_Node;
+
+         --  Otherwise we have the case of a name extended by an attribute
+
+         else
+            goto Scan_Name_Extension_Apostrophe;
+         end if;
+
+      --  Check case of qualified simple name extended by a left parenthesis
+
+      elsif Token = Tok_Left_Paren then
+         Scan; -- past left paren
+         goto Scan_Name_Extension_Left_Paren;
+
+      --  Otherwise the qualified simple name is not extended, so return
+
+      else
+         Expr_Form := EF_Simple_Name;
+         return Name_Node;
+      end if;
+
+      --  Loop scanning past name extensions. A label is used for control
+      --  transfer for this loop for ease of interfacing with the finite state
+      --  machine in the parenthesis scanning circuit, and also to allow for
+      --  passing in control to the appropriate point from the above code.
+
+      <<Scan_Name_Extension>>
+
+         --  Character literal used as name cannot be extended. Also this
+         --  cannot be a call, since the name for a call must be a designator.
+         --  Return in these cases, or if there is no name extension
+
+         if Token not in Token_Class_Namext
+           or else Prev_Token = Tok_Char_Literal
+         then
+            Expr_Form := EF_Name;
+            return Name_Node;
+         end if;
+
+      --  Merge here when we know there is a name extension
+
+      <<Scan_Name_Extension_OK>>
+
+         if Token = Tok_Left_Paren then
+            Scan; -- past left paren
+            goto Scan_Name_Extension_Left_Paren;
+
+         elsif Token = Tok_Apostrophe then
+            Save_Scan_State (Scan_State); -- at apostrophe
+            Scan; -- past apostrophe
+            goto Scan_Name_Extension_Apostrophe;
+
+         else -- Token = Tok_Dot
+            Save_Scan_State (Scan_State); -- at dot
+            Scan; -- past dot
+            goto Scan_Name_Extension_Dot;
+         end if;
+
+      --  Case of name extended by dot (selection), dot is already skipped
+      --  and the scan state at the point of the dot is saved in Scan_State.
+
+      <<Scan_Name_Extension_Dot>>
+
+         --  Explicit dereference case
+
+         if Token = Tok_All then
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Scan; -- past ALL
+            goto Scan_Name_Extension;
+
+         --  Selected component case
+
+         elsif Token in Token_Class_Name then
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Selector_Name (Name_Node, Token_Node);
+            Scan; -- past selector
+            goto Scan_Name_Extension;
+
+         --  Reserved identifier as selector
+
+         elsif Is_Reserved_Identifier then
+            Scan_Reserved_Identifier (Force_Msg => False);
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Selector_Name (Name_Node, Token_Node);
+            Scan; -- past identifier used as selector
+            goto Scan_Name_Extension;
+
+         --  If dot is at end of line and followed by nothing legal,
+         --  then assume end of name and quit (dot will be taken as
+         --  an erroneous form of some other punctuation by our caller).
+
+         elsif Token_Is_At_Start_Of_Line then
+            Restore_Scan_State (Scan_State);
+            return Name_Node;
+
+         --  Here if nothing legal after the dot
+
+         else
+            Error_Msg_AP ("selector expected");
+            raise Error_Resync;
+         end if;
+
+      --  Here for an apostrophe as name extension. The scan position at the
+      --  apostrophe has already been saved, and the apostrophe scanned out.
+
+      <<Scan_Name_Extension_Apostrophe>>
+
+         Scan_Apostrophe : declare
+            function Apostrophe_Should_Be_Semicolon return Boolean;
+            --  Checks for case where apostrophe should probably be
+            --  a semicolon, and if so, gives appropriate message,
+            --  resets the scan pointer to the apostrophe, changes
+            --  the current token to Tok_Semicolon, and returns True.
+            --  Otherwise returns False.
+
+            function Apostrophe_Should_Be_Semicolon return Boolean is
+            begin
+               if Token_Is_At_Start_Of_Line then
+                  Restore_Scan_State (Scan_State); -- to apostrophe
+                  Error_Msg_SC ("""''"" should be "";""");
+                  Token := Tok_Semicolon;
+                  return True;
+               else
+                  return False;
+               end if;
+            end Apostrophe_Should_Be_Semicolon;
+
+         --  Start of processing for Scan_Apostrophe
+
+         begin
+            --  If range attribute after apostrophe, then return with Token
+            --  pointing to the apostrophe. Note that in this case the prefix
+            --  need not be a simple name (cases like A.all'range). Similarly
+            --  if there is a left paren after the apostrophe, then we also
+            --  return with Token pointing to the apostrophe (this is the
+            --  qualified expression case).
+
+            if Token = Tok_Range or else Token = Tok_Left_Paren then
+               Restore_Scan_State (Scan_State); -- to apostrophe
+               Expr_Form := EF_Name;
+               return Name_Node;
+
+            --  Here for cases where attribute designator is an identifier
+
+            elsif Token = Tok_Identifier then
+               Attr_Name := Token_Name;
+
+               if not Is_Attribute_Name (Attr_Name) then
+                  if Apostrophe_Should_Be_Semicolon then
+                     Expr_Form := EF_Name;
+                     return Name_Node;
+                  else
+                     Signal_Bad_Attribute;
+                  end if;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (False);
+               end if;
+
+               Delete_Node (Token_Node);
+
+            --  Here for case of attribute designator is not an identifier
+
+            else
+               if Token = Tok_Delta then
+                  Attr_Name := Name_Delta;
+
+               elsif Token = Tok_Digits then
+                  Attr_Name := Name_Digits;
+
+               elsif Token = Tok_Access then
+                  Attr_Name := Name_Access;
+
+               elsif Apostrophe_Should_Be_Semicolon then
+                  Expr_Form := EF_Name;
+                  return Name_Node;
+
+               else
+                  Error_Msg_AP ("attribute designator expected");
+                  raise Error_Resync;
+               end if;
+
+               if Style_Check then
+                  Style.Check_Attribute_Name (True);
+               end if;
+            end if;
+
+            --  We come here with an OK attribute scanned, and the
+            --  corresponding Attribute identifier node stored in Ident_Node.
+
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
+            Scan; -- past attribute designator
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Attribute_Name (Name_Node, Attr_Name);
+
+            --  Scan attribute arguments/designator
+
+            if Token = Tok_Left_Paren then
+               Set_Expressions (Name_Node, New_List);
+               Scan; -- past left paren
+
+               loop
+                  declare
+                     Expr : constant Node_Id := P_Expression;
+
+                  begin
+                     if Token = Tok_Arrow then
+                        Error_Msg_SC
+                          ("named parameters not permitted for attributes");
+                        Scan; -- past junk arrow
+
+                     else
+                        Append (Expr, Expressions (Name_Node));
+                        exit when not Comma_Present;
+                     end if;
+                  end;
+               end loop;
+
+               T_Right_Paren;
+            end if;
+
+            goto Scan_Name_Extension;
+         end Scan_Apostrophe;
+
+      --  Here for left parenthesis extending name (left paren skipped)
+
+      <<Scan_Name_Extension_Left_Paren>>
+
+         --  We now have to scan through a list of items, terminated by a
+         --  right parenthesis. The scan is handled by a finite state
+         --  machine. The possibilities are:
+
+         --   (discrete_range)
+
+         --      This is a slice. This case is handled in LP_State_Init.
+
+         --   (expression, expression, ..)
+
+         --      This is interpreted as an indexed component, i.e. as a
+         --      case of a name which can be extended in the normal manner.
+         --      This case is handled by LP_State_Name or LP_State_Expr.
+
+         --   (..., identifier => expression , ...)
+
+         --      If there is at least one occurence of identifier => (but
+         --      none of the other cases apply), then we have a call.
+
+         --  Test for Id => case
+
+         if Token = Tok_Identifier then
+            Save_Scan_State (Scan_State); -- at Id
+            Scan; -- past Id
+
+            --  Test for => (allow := as an error substitute)
+
+            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
+               Restore_Scan_State (Scan_State); -- to Id
+               Arg_List := New_List;
+               goto LP_State_Call;
+
+            else
+               Restore_Scan_State (Scan_State); -- to Id
+            end if;
+         end if;
+
+         --  Here we have an expression after all
+
+         Expr_Node := P_Expression_Or_Range_Attribute;
+
+         --  Check cases of discrete range for a slice
+
+         --  First possibility: Range_Attribute_Reference
+
+         if Expr_Form = EF_Range_Attr then
+            Range_Node := Expr_Node;
+
+         --  Second possibility: Simple_expression .. Simple_expression
+
+         elsif Token = Tok_Dot_Dot then
+            Check_Simple_Expression (Expr_Node);
+            Range_Node := New_Node (N_Range, Token_Ptr);
+            Set_Low_Bound (Range_Node, Expr_Node);
+            Scan; -- past ..
+            Expr_Node := P_Expression;
+            Check_Simple_Expression (Expr_Node);
+            Set_High_Bound (Range_Node, Expr_Node);
+
+         --  Third possibility: Type_name range Range
+
+         elsif Token = Tok_Range then
+            if Expr_Form /= EF_Simple_Name then
+               Error_Msg_SC ("subtype mark must precede RANGE");
+               raise Error_Resync;
+            end if;
+
+            Range_Node := P_Subtype_Indication (Expr_Node);
+
+         --  Otherwise we just have an expression. It is true that we might
+         --  have a subtype mark without a range constraint but this case
+         --  is syntactically indistinguishable from the expression case.
+
+         else
+            Arg_List := New_List;
+            goto LP_State_Expr;
+         end if;
+
+         --  Fall through here with unmistakable Discrete range scanned,
+         --  which means that we definitely have the case of a slice. The
+         --  Discrete range is in Range_Node.
+
+         if Token = Tok_Comma then
+            Error_Msg_SC ("slice cannot have more than one dimension");
+            raise Error_Resync;
+
+         elsif Token /= Tok_Right_Paren then
+            T_Right_Paren;
+            raise Error_Resync;
+
+         else
+            Scan; -- past right paren
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Discrete_Range (Name_Node, Range_Node);
+
+            --  An operator node is legal as a prefix to other names,
+            --  but not for a slice.
+
+            if Nkind (Prefix_Node) = N_Operator_Symbol then
+               Error_Msg_N ("illegal prefix for slice", Prefix_Node);
+            end if;
+
+            --  If we have a name extension, go scan it
+
+            if Token in Token_Class_Namext then
+               goto Scan_Name_Extension_OK;
+
+            --  Otherwise return (a slice is a name, but is not a call)
+
+            else
+               Expr_Form := EF_Name;
+               return Name_Node;
+            end if;
+         end if;
+
+      --  In LP_State_Expr, we have scanned one or more expressions, and
+      --  so we have a call or an indexed component which is a name. On
+      --  entry we have the expression just scanned in Expr_Node and
+      --  Arg_List contains the list of expressions encountered so far
+
+      <<LP_State_Expr>>
+         Append (Expr_Node, Arg_List);
+
+         if Token = Tok_Arrow then
+            Error_Msg
+              ("expect identifier in parameter association",
+                Sloc (Expr_Node));
+            Scan;  --   past arrow.
+
+         elsif not Comma_Present then
+            T_Right_Paren;
+            Prefix_Node := Name_Node;
+            Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
+            Set_Prefix (Name_Node, Prefix_Node);
+            Set_Expressions (Name_Node, Arg_List);
+            goto Scan_Name_Extension;
+         end if;
+
+         --  Comma present (and scanned out), test for identifier => case
+         --  Test for identifer => case
+
+         if Token = Tok_Identifier then
+            Save_Scan_State (Scan_State); -- at Id
+            Scan; -- past Id
+
+            --  Test for => (allow := as error substitute)
+
+            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
+               Restore_Scan_State (Scan_State); -- to Id
+               goto LP_State_Call;
+
+            --  Otherwise it's just an expression after all, so backup
+
+            else
+               Restore_Scan_State (Scan_State); -- to Id
+            end if;
+         end if;
+
+         --  Here we have an expression after all, so stay in this state
+
+         Expr_Node := P_Expression;
+         goto LP_State_Expr;
+
+      --  LP_State_Call corresponds to the situation in which at least
+      --  one instance of Id => Expression has been encountered, so we
+      --  know that we do not have a name, but rather a call. We enter
+      --  it with the scan pointer pointing to the next argument to scan,
+      --  and Arg_List containing the list of arguments scanned so far.
+
+      <<LP_State_Call>>
+
+         --  Test for case of Id => Expression (named parameter)
+
+         if Token = Tok_Identifier then
+            Save_Scan_State (Scan_State); -- at Id
+            Ident_Node := Token_Node;
+            Scan; -- past Id
+
+            --  Deal with => (allow := as erroneous substitute)
+
+            if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
+               Arg_Node :=
+                 New_Node (N_Parameter_Association, Prev_Token_Ptr);
+               Set_Selector_Name (Arg_Node, Ident_Node);
+               T_Arrow;
+               Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
+               Append (Arg_Node, Arg_List);
+
+               --  If a comma follows, go back and scan next entry
+
+               if Comma_Present then
+                  goto LP_State_Call;
+
+               --  Otherwise we have the end of a call
+
+               else
+                  Prefix_Node := Name_Node;
+                  Name_Node :=
+                    New_Node (N_Function_Call, Sloc (Prefix_Node));
+                  Set_Name (Name_Node, Prefix_Node);
+                  Set_Parameter_Associations (Name_Node, Arg_List);
+                  T_Right_Paren;
+
+                  if Token in Token_Class_Namext then
+                     goto Scan_Name_Extension_OK;
+
+                  --  This is a case of a call which cannot be a name
+
+                  else
+                     Expr_Form := EF_Name;
+                     return Name_Node;
+                  end if;
+               end if;
+
+            --  Not named parameter: Id started an expression after all
+
+            else
+               Restore_Scan_State (Scan_State); -- to Id
+            end if;
+         end if;
+
+         --  Here if entry did not start with Id => which means that it
+         --  is a positional parameter, which is not allowed, since we
+         --  have seen at least one named parameter already.
+
+         Error_Msg_SC
+            ("positional parameter association " &
+              "not allowed after named one");
+
+         Expr_Node := P_Expression;
+
+         --  Leaving the '>' in an association is not unusual, so suggest
+         --  a possible fix.
+
+         if Nkind (Expr_Node) = N_Op_Eq then
+            Error_Msg_N ("\maybe `=>` was intended", Expr_Node);
+         end if;
+
+         --  We go back to scanning out expressions, so that we do not get
+         --  multiple error messages when several positional parameters
+         --  follow a named parameter.
+
+         goto LP_State_Expr;
+
+         --  End of treatment for name extensions starting with left paren
+
+      --  End of loop through name extensions
+
+   end P_Name;
+
+   --  This function parses a restricted form of Names which are either
+   --  designators, or designators preceded by a sequence of prefixes
+   --  that are direct names.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Function_Name return Node_Id is
+      Designator_Node : Node_Id;
+      Prefix_Node     : Node_Id;
+      Selector_Node   : Node_Id;
+      Dot_Sloc        : Source_Ptr := No_Location;
+
+   begin
+      --  Prefix_Node is set to the gathered prefix so far, Empty means that
+      --  no prefix has been scanned. This allows us to build up the result
+      --  in the required right recursive manner.
+
+      Prefix_Node := Empty;
+
+      --  Loop through prefixes
+
+      loop
+         Designator_Node := Token_Node;
+
+         if Token not in Token_Class_Desig then
+            return P_Identifier; -- let P_Identifier issue the error message
+
+         else -- Token in Token_Class_Desig
+            Scan; -- past designator
+            exit when Token /= Tok_Dot;
+         end if;
+
+         --  Here at a dot, with token just before it in Designator_Node
+
+         if No (Prefix_Node) then
+            Prefix_Node := Designator_Node;
+         else
+            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+            Set_Prefix (Selector_Node, Prefix_Node);
+            Set_Selector_Name (Selector_Node, Designator_Node);
+            Prefix_Node := Selector_Node;
+         end if;
+
+         Dot_Sloc := Token_Ptr;
+         Scan; -- past dot
+      end loop;
+
+      --  Fall out of the loop having just scanned a designator
+
+      if No (Prefix_Node) then
+         return Designator_Node;
+      else
+         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+         Set_Prefix (Selector_Node, Prefix_Node);
+         Set_Selector_Name (Selector_Node, Designator_Node);
+         return Selector_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         return Error;
+
+   end P_Function_Name;
+
+   --  This function parses a restricted form of Names which are either
+   --  identifiers, or identifiers preceded by a sequence of prefixes
+   --  that are direct names.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Qualified_Simple_Name return Node_Id is
+      Designator_Node : Node_Id;
+      Prefix_Node     : Node_Id;
+      Selector_Node   : Node_Id;
+      Dot_Sloc        : Source_Ptr := No_Location;
+
+   begin
+      --  Prefix node is set to the gathered prefix so far, Empty means that
+      --  no prefix has been scanned. This allows us to build up the result
+      --  in the required right recursive manner.
+
+      Prefix_Node := Empty;
+
+      --  Loop through prefixes
+
+      loop
+         Designator_Node := Token_Node;
+
+         if Token = Tok_Identifier then
+            Scan; -- past identifier
+            exit when Token /= Tok_Dot;
+
+         elsif Token not in Token_Class_Desig then
+            return P_Identifier; -- let P_Identifier issue the error message
+
+         else
+            Scan; -- past designator
+
+            if Token /= Tok_Dot then
+               Error_Msg_SP ("identifier expected");
+               return Error;
+            end if;
+         end if;
+
+         --  Here at a dot, with token just before it in Designator_Node
+
+         if No (Prefix_Node) then
+            Prefix_Node := Designator_Node;
+         else
+            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+            Set_Prefix (Selector_Node, Prefix_Node);
+            Set_Selector_Name (Selector_Node, Designator_Node);
+            Prefix_Node := Selector_Node;
+         end if;
+
+         Dot_Sloc := Token_Ptr;
+         Scan; -- past dot
+      end loop;
+
+      --  Fall out of the loop having just scanned an identifier
+
+      if No (Prefix_Node) then
+         return Designator_Node;
+      else
+         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+         Set_Prefix (Selector_Node, Prefix_Node);
+         Set_Selector_Name (Selector_Node, Designator_Node);
+         return Selector_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         return Error;
+
+   end P_Qualified_Simple_Name;
+
+   --  This procedure differs from P_Qualified_Simple_Name only in that it
+   --  raises Error_Resync if any error is encountered. It only returns after
+   --  scanning a valid qualified simple name.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Qualified_Simple_Name_Resync return Node_Id is
+      Designator_Node : Node_Id;
+      Prefix_Node     : Node_Id;
+      Selector_Node   : Node_Id;
+      Dot_Sloc        : Source_Ptr := No_Location;
+
+   begin
+      Prefix_Node := Empty;
+
+      --  Loop through prefixes
+
+      loop
+         Designator_Node := Token_Node;
+
+         if Token = Tok_Identifier then
+            Scan; -- past identifier
+            exit when Token /= Tok_Dot;
+
+         elsif Token not in Token_Class_Desig then
+            Discard_Junk_Node (P_Identifier); -- to issue the error message
+            raise Error_Resync;
+
+         else
+            Scan; -- past designator
+
+            if Token /= Tok_Dot then
+               Error_Msg_SP ("identifier expected");
+               raise Error_Resync;
+            end if;
+         end if;
+
+         --  Here at a dot, with token just before it in Designator_Node
+
+         if No (Prefix_Node) then
+            Prefix_Node := Designator_Node;
+         else
+            Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+            Set_Prefix (Selector_Node, Prefix_Node);
+            Set_Selector_Name (Selector_Node, Designator_Node);
+            Prefix_Node := Selector_Node;
+         end if;
+
+         Dot_Sloc := Token_Ptr;
+         Scan; -- past period
+      end loop;
+
+      --  Fall out of the loop having just scanned an identifier
+
+      if No (Prefix_Node) then
+         return Designator_Node;
+      else
+         Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
+         Set_Prefix (Selector_Node, Prefix_Node);
+         Set_Selector_Name (Selector_Node, Designator_Node);
+         return Selector_Node;
+      end if;
+
+   end P_Qualified_Simple_Name_Resync;
+
+   ----------------------
+   -- 4.1  Direct_Name --
+   ----------------------
+
+   --  Parsed by P_Name and other functions in section 4.1
+
+   -----------------
+   -- 4.1  Prefix --
+   -----------------
+
+   --  Parsed by P_Name (4.1)
+
+   -------------------------------
+   -- 4.1  Explicit Dereference --
+   -------------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   -------------------------------
+   -- 4.1  Implicit_Dereference --
+   -------------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   ----------------------------
+   -- 4.1  Indexed Component --
+   ----------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   ----------------
+   -- 4.1  Slice --
+   ----------------
+
+   --  Parsed by P_Name (4.1)
+
+   -----------------------------
+   -- 4.1  Selected_Component --
+   -----------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   ------------------------
+   -- 4.1  Selector Name --
+   ------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   ------------------------------
+   -- 4.1  Attribute Reference --
+   ------------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   -------------------------------
+   -- 4.1  Attribute Designator --
+   -------------------------------
+
+   --  Parsed by P_Name (4.1)
+
+   --------------------------------------
+   -- 4.1.4  Range Attribute Reference --
+   --------------------------------------
+
+   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
+
+   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
+
+   --  In the grammar, a RANGE attribute is simply a name, but its use is
+   --  highly restricted, so in the parser, we do not regard it as a name.
+   --  Instead, P_Name returns without scanning the 'RANGE part of the
+   --  attribute, and the caller uses the following function to construct
+   --  a range attribute in places where it is appropriate.
+
+   --  Note that RANGE here is treated essentially as an identifier,
+   --  rather than a reserved word.
+
+   --  The caller has parsed the prefix, i.e. a name, and Token points to
+   --  the apostrophe. The token after the apostrophe is known to be RANGE
+   --  at this point. The prefix node becomes the prefix of the attribute.
+
+   --  Error_Recovery: Cannot raise Error_Resync
+
+   function P_Range_Attribute_Reference
+     (Prefix_Node : Node_Id)
+      return        Node_Id
+   is
+      Attr_Node  : Node_Id;
+
+   begin
+      Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
+      Set_Prefix (Attr_Node, Prefix_Node);
+      Scan; -- past apostrophe
+
+      if Style_Check then
+         Style.Check_Attribute_Name (True);
+      end if;
+
+      Set_Attribute_Name (Attr_Node, Name_Range);
+      Scan; -- past RANGE
+
+      if Token = Tok_Left_Paren then
+         Scan; -- past left paren
+         Set_Expressions (Attr_Node, New_List (P_Expression));
+         T_Right_Paren;
+      end if;
+
+      return Attr_Node;
+   end P_Range_Attribute_Reference;
+
+   ---------------------------------------
+   -- 4.1.4  Range Attribute Designator --
+   ---------------------------------------
+
+   --  Parsed by P_Range_Attribute_Reference (4.4)
+
+   --------------------
+   -- 4.3  Aggregate --
+   --------------------
+
+   --  AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
+   --  an aggregate is known to be required (code statement, extension
+   --  aggregate), in which cases this routine performs the necessary check
+   --  that we have an aggregate rather than a parenthesized expression
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Aggregate return Node_Id is
+      Aggr_Sloc : constant Source_Ptr := Token_Ptr;
+      Aggr_Node : constant Node_Id    := P_Aggregate_Or_Paren_Expr;
+
+   begin
+      if Nkind (Aggr_Node) /= N_Aggregate
+           and then
+         Nkind (Aggr_Node) /= N_Extension_Aggregate
+      then
+         Error_Msg
+           ("aggregate may not have single positional component", Aggr_Sloc);
+         return Error;
+      else
+         return Aggr_Node;
+      end if;
+   end P_Aggregate;
+
+   -------------------------------------------------
+   -- 4.3  Aggregate or Parenthesized Expresssion --
+   -------------------------------------------------
+
+   --  This procedure parses out either an aggregate or a parenthesized
+   --  expression (these two constructs are closely related, since a
+   --  parenthesized expression looks like an aggregate with a single
+   --  positional component).
+
+   --  AGGREGATE ::=
+   --    RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
+
+   --  RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
+
+   --  RECORD_COMPONENT_ASSOCIATION_LIST ::=
+   --     RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
+   --   | null record
+
+   --  RECORD_COMPONENT_ASSOCIATION ::=
+   --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
+
+   --  COMPONENT_CHOICE_LIST ::=
+   --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
+   --  | others
+
+   --  EXTENSION_AGGREGATE ::=
+   --    (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
+
+   --  ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
+
+   --  ARRAY_AGGREGATE ::=
+   --    POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
+
+   --  POSITIONAL_ARRAY_AGGREGATE ::=
+   --    (EXPRESSION, EXPRESSION {, EXPRESSION})
+   --  | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
+
+   --  NAMED_ARRAY_AGGREGATE ::=
+   --    (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
+
+   --  PRIMARY ::= (EXPRESSION);
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Aggregate_Or_Paren_Expr return Node_Id is
+      Aggregate_Node : Node_Id;
+      Expr_List      : List_Id;
+      Assoc_List     : List_Id;
+      Expr_Node      : Node_Id;
+      Lparen_Sloc    : Source_Ptr;
+      Scan_State     : Saved_Scan_State;
+
+   begin
+      Lparen_Sloc := Token_Ptr;
+      T_Left_Paren;
+
+      --  Note: the mechanism used here of rescanning the initial expression
+      --  is distinctly unpleasant, but it saves a lot of fiddling in scanning
+      --  out the discrete choice list.
+
+      --  Deal with expression and extension aggregate cases first
+
+      if Token /= Tok_Others then
+         Save_Scan_State (Scan_State); -- at start of expression
+
+         --  Deal with (NULL RECORD) case
+
+         if Token = Tok_Null then
+            Scan; -- past NULL
+
+            if Token = Tok_Record then
+               Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+               Set_Null_Record_Present (Aggregate_Node, True);
+               Scan; -- past RECORD
+               T_Right_Paren;
+               return Aggregate_Node;
+            else
+               Restore_Scan_State (Scan_State); -- to NULL that must be expr
+            end if;
+         end if;
+
+         Expr_Node := P_Expression_Or_Range_Attribute;
+
+         --  Extension aggregate case
+
+         if Token = Tok_With then
+
+            if Nkind (Expr_Node) = N_Attribute_Reference
+              and then Attribute_Name (Expr_Node) = Name_Range
+            then
+               Bad_Range_Attribute (Sloc (Expr_Node));
+               return Error;
+            end if;
+
+            if Ada_83 then
+               Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
+            end if;
+
+            Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
+            Set_Ancestor_Part (Aggregate_Node, Expr_Node);
+            Scan; -- past WITH
+
+            --  Deal with WITH NULL RECORD case
+
+            if Token = Tok_Null then
+               Save_Scan_State (Scan_State); -- at NULL
+               Scan; -- past NULL
+
+               if Token = Tok_Record then
+                  Scan; -- past RECORD
+                  Set_Null_Record_Present (Aggregate_Node, True);
+                  T_Right_Paren;
+                  return Aggregate_Node;
+
+               else
+                  Restore_Scan_State (Scan_State); -- to NULL that must be expr
+               end if;
+            end if;
+
+            if Token /= Tok_Others then
+               Save_Scan_State (Scan_State);
+               Expr_Node := P_Expression;
+            else
+               Expr_Node := Empty;
+            end if;
+
+         --  Expression case
+
+         elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
+
+            if Nkind (Expr_Node) = N_Attribute_Reference
+              and then Attribute_Name (Expr_Node) = Name_Range
+            then
+               Bad_Range_Attribute (Sloc (Expr_Node));
+               return Error;
+            end if;
+
+            --  Bump paren count of expression, note that if the paren count
+            --  is already at the maximum, then we leave it alone. This will
+            --  cause some failures in pathalogical conformance tests, which
+            --  we do not shed a tear over!
+
+            if Expr_Node /= Error then
+               if Paren_Count (Expr_Node) /= Paren_Count_Type'Last then
+                  Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
+               end if;
+            end if;
+
+            T_Right_Paren; -- past right paren (error message if none)
+            return Expr_Node;
+
+         --  Normal aggregate case
+
+         else
+            Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+         end if;
+
+      --  Others case
+
+      else
+         Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+         Expr_Node := Empty;
+      end if;
+
+      --  Prepare to scan list of component associations
+
+      Expr_List  := No_List; -- don't set yet, maybe all named entries
+      Assoc_List := No_List; -- don't set yet, maybe all positional entries
+
+      --  This loop scans through component associations. On entry to the
+      --  loop, an expression has been scanned at the start of the current
+      --  association unless initial token was OTHERS, in which case
+      --  Expr_Node is set to Empty.
+
+      loop
+         --  Deal with others association first. This is a named association
+
+         if No (Expr_Node) then
+            if No (Assoc_List) then
+               Assoc_List := New_List;
+            end if;
+
+            Append (P_Record_Or_Array_Component_Association, Assoc_List);
+
+         --  Improper use of WITH
+
+         elsif Token = Tok_With then
+            Error_Msg_SC ("WITH must be preceded by single expression in " &
+                             "extension aggregate");
+            raise Error_Resync;
+
+         --  Assume positional case if comma, right paren, or literal or
+         --  identifier or OTHERS follows (the latter cases are missing
+         --  comma cases). Also assume positional if a semicolon follows,
+         --  which can happen if there are missing parens
+
+         elsif Token = Tok_Comma
+           or else Token = Tok_Right_Paren
+           or else Token = Tok_Others
+           or else Token in Token_Class_Lit_Or_Name
+           or else Token = Tok_Semicolon
+         then
+            if Present (Assoc_List) then
+               Error_Msg_BC
+                  ("""=>"" expected (positional association cannot follow " &
+                   "named association)");
+            end if;
+
+            if No (Expr_List) then
+               Expr_List := New_List;
+            end if;
+
+            Append (Expr_Node, Expr_List);
+
+         --  Anything else is assumed to be a named association
+
+         else
+            Restore_Scan_State (Scan_State); -- to start of expression
+
+            if No (Assoc_List) then
+               Assoc_List := New_List;
+            end if;
+
+            Append (P_Record_Or_Array_Component_Association, Assoc_List);
+         end if;
+
+         exit when not Comma_Present;
+
+         --  If we are at an expression terminator, something is seriously
+         --  wrong, so let's get out now, before we start eating up stuff
+         --  that doesn't belong to us!
+
+         if Token in Token_Class_Eterm then
+            Error_Msg_AP ("expecting expression or component association");
+            exit;
+         end if;
+
+         --  Otherwise initiate for reentry to top of loop by scanning an
+         --  initial expression, unless the first token is OTHERS.
+
+         if Token = Tok_Others then
+            Expr_Node := Empty;
+         else
+            Save_Scan_State (Scan_State); -- at start of expression
+            Expr_Node := P_Expression;
+         end if;
+      end loop;
+
+      --  All component associations (positional and named) have been scanned
+
+      T_Right_Paren;
+      Set_Expressions (Aggregate_Node, Expr_List);
+      Set_Component_Associations (Aggregate_Node, Assoc_List);
+      return Aggregate_Node;
+   end P_Aggregate_Or_Paren_Expr;
+
+   ------------------------------------------------
+   -- 4.3  Record or Array Component Association --
+   ------------------------------------------------
+
+   --  RECORD_COMPONENT_ASSOCIATION ::=
+   --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
+
+   --  COMPONENT_CHOICE_LIST =>
+   --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
+   --  | others
+
+   --  ARRAY_COMPONENT_ASSOCIATION ::=
+   --    DISCRETE_CHOICE_LIST => EXPRESSION
+
+   --  Note: this routine only handles the named cases, including others.
+   --  Cases where the component choice list is not present have already
+   --  been handled directly.
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Record_Or_Array_Component_Association return Node_Id is
+      Assoc_Node : Node_Id;
+
+   begin
+      Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
+      Set_Choices (Assoc_Node, P_Discrete_Choice_List);
+      Set_Sloc (Assoc_Node, Token_Ptr);
+      TF_Arrow;
+      Set_Expression (Assoc_Node, P_Expression);
+      return Assoc_Node;
+   end P_Record_Or_Array_Component_Association;
+
+   -----------------------------
+   -- 4.3.1  Record Aggregate --
+   -----------------------------
+
+   --  Case of enumeration aggregate is parsed by P_Aggregate (4.3)
+   --  All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ----------------------------------------------
+   -- 4.3.1  Record Component Association List --
+   ----------------------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ----------------------------------
+   -- 4.3.1  Component Choice List --
+   ----------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   --------------------------------
+   -- 4.3.1  Extension Aggregate --
+   --------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   --------------------------
+   -- 4.3.1  Ancestor Part --
+   --------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ----------------------------
+   -- 4.3.1  Array Aggregate --
+   ----------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ---------------------------------------
+   -- 4.3.1  Positional Array Aggregate --
+   ---------------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ----------------------------------
+   -- 4.3.1  Named Array Aggregate --
+   ----------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ----------------------------------------
+   -- 4.3.1  Array Component Association --
+   ----------------------------------------
+
+   --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
+
+   ---------------------
+   -- 4.4  Expression --
+   ---------------------
+
+   --  EXPRESSION ::=
+   --    RELATION {and RELATION} | RELATION {and then RELATION}
+   --  | RELATION {or RELATION}  | RELATION {or else RELATION}
+   --  | RELATION {xor RELATION}
+
+   --  On return, Expr_Form indicates the categorization of the expression
+   --  EF_Range_Attr is not a possible value (if a range attribute is found,
+   --  an error message is given, and Error is returned).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Expression return Node_Id is
+      Logical_Op      : Node_Kind;
+      Prev_Logical_Op : Node_Kind;
+      Op_Location     : Source_Ptr;
+      Node1           : Node_Id;
+      Node2           : Node_Id;
+
+   begin
+      Node1 := P_Relation;
+
+      if Token in Token_Class_Logop then
+         Prev_Logical_Op := N_Empty;
+
+         loop
+            Op_Location := Token_Ptr;
+            Logical_Op := P_Logical_Operator;
+
+            if Prev_Logical_Op /= N_Empty and then
+               Logical_Op /= Prev_Logical_Op
+            then
+               Error_Msg
+                 ("mixed logical operators in expression", Op_Location);
+               Prev_Logical_Op := N_Empty;
+            else
+               Prev_Logical_Op := Logical_Op;
+            end if;
+
+            Node2 := Node1;
+            Node1 := New_Node (Logical_Op, Op_Location);
+            Set_Left_Opnd (Node1, Node2);
+            Set_Right_Opnd (Node1, P_Relation);
+            Set_Op_Name (Node1);
+            exit when Token not in Token_Class_Logop;
+         end loop;
+
+         Expr_Form := EF_Non_Simple;
+      end if;
+
+      if Token = Tok_Apostrophe then
+         Bad_Range_Attribute (Token_Ptr);
+         return Error;
+      else
+         return Node1;
+      end if;
+
+   end P_Expression;
+
+   --  This function is identical to the normal P_Expression, except that it
+   --  checks that the expression scan did not stop on a right paren. It is
+   --  called in all contexts where a right parenthesis cannot legitimately
+   --  follow an expression.
+
+   function P_Expression_No_Right_Paren return Node_Id is
+   begin
+      return No_Right_Paren (P_Expression);
+   end P_Expression_No_Right_Paren;
+
+   ----------------------------------------
+   -- 4.4  Expression_Or_Range_Attribute --
+   ----------------------------------------
+
+   --  EXPRESSION ::=
+   --    RELATION {and RELATION} | RELATION {and then RELATION}
+   --  | RELATION {or RELATION}  | RELATION {or else RELATION}
+   --  | RELATION {xor RELATION}
+
+   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
+
+   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
+
+   --  On return, Expr_Form indicates the categorization of the expression
+   --  and EF_Range_Attr is one of the possibilities.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  In the grammar, a RANGE attribute is simply a name, but its use is
+   --  highly restricted, so in the parser, we do not regard it as a name.
+   --  Instead, P_Name returns without scanning the 'RANGE part of the
+   --  attribute, and P_Expression_Or_Range_Attribute handles the range
+   --  attribute reference. In the normal case where a range attribute is
+   --  not allowed, an error message is issued by P_Expression.
+
+   function P_Expression_Or_Range_Attribute return Node_Id is
+      Logical_Op      : Node_Kind;
+      Prev_Logical_Op : Node_Kind;
+      Op_Location     : Source_Ptr;
+      Node1           : Node_Id;
+      Node2           : Node_Id;
+      Attr_Node       : Node_Id;
+
+   begin
+      Node1 := P_Relation;
+
+      if Token = Tok_Apostrophe then
+         Attr_Node := P_Range_Attribute_Reference (Node1);
+         Expr_Form := EF_Range_Attr;
+         return Attr_Node;
+
+      elsif Token in Token_Class_Logop then
+         Prev_Logical_Op := N_Empty;
+
+         loop
+            Op_Location := Token_Ptr;
+            Logical_Op := P_Logical_Operator;
+
+            if Prev_Logical_Op /= N_Empty and then
+               Logical_Op /= Prev_Logical_Op
+            then
+               Error_Msg
+                 ("mixed logical operators in expression", Op_Location);
+               Prev_Logical_Op := N_Empty;
+            else
+               Prev_Logical_Op := Logical_Op;
+            end if;
+
+            Node2 := Node1;
+            Node1 := New_Node (Logical_Op, Op_Location);
+            Set_Left_Opnd (Node1, Node2);
+            Set_Right_Opnd (Node1, P_Relation);
+            Set_Op_Name (Node1);
+            exit when Token not in Token_Class_Logop;
+         end loop;
+
+         Expr_Form := EF_Non_Simple;
+      end if;
+
+      if Token = Tok_Apostrophe then
+         Bad_Range_Attribute (Token_Ptr);
+         return Error;
+      else
+         return Node1;
+      end if;
+   end P_Expression_Or_Range_Attribute;
+
+   -------------------
+   -- 4.4  Relation --
+   -------------------
+
+   --  RELATION ::=
+   --    SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
+   --  | SIMPLE_EXPRESSION [not] in RANGE
+   --  | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
+
+   --  On return, Expr_Form indicates the categorization of the expression
+
+   --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
+   --  EF_Simple_Name and the following token is RANGE (range attribute case).
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs within an
+   --  expression, then tokens are scanned until either a non-expression token,
+   --  a right paren (not matched by a left paren) or a comma, is encountered.
+
+   function P_Relation return Node_Id is
+      Node1, Node2 : Node_Id;
+      Optok        : Source_Ptr;
+
+   begin
+      Node1 := P_Simple_Expression;
+
+      if Token not in Token_Class_Relop then
+         return Node1;
+
+      else
+         --  Here we have a relational operator following. If so then scan it
+         --  out. Note that the assignment symbol := is treated as a relational
+         --  operator to improve the error recovery when it is misused for =.
+         --  P_Relational_Operator also parses the IN and NOT IN operations.
+
+         Optok := Token_Ptr;
+         Node2 := New_Node (P_Relational_Operator, Optok);
+         Set_Left_Opnd (Node2, Node1);
+         Set_Op_Name (Node2);
+
+         --  Case of IN or NOT IN
+
+         if Prev_Token = Tok_In then
+            Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark);
+
+         --  Case of relational operator (= /= < <= > >=)
+
+         else
+            Set_Right_Opnd (Node2, P_Simple_Expression);
+         end if;
+
+         Expr_Form := EF_Non_Simple;
+
+         if Token in Token_Class_Relop then
+            Error_Msg_SC ("unexpected relational operator");
+            raise Error_Resync;
+         end if;
+
+         return Node2;
+      end if;
+
+   --  If any error occurs, then scan to the next expression terminator symbol
+   --  or comma or right paren at the outer (i.e. current) parentheses level.
+   --  The flags are set to indicate a normal simple expression.
+
+   exception
+      when Error_Resync =>
+         Resync_Expression;
+         Expr_Form := EF_Simple;
+         return Error;
+   end P_Relation;
+
+   ----------------------------
+   -- 4.4  Simple Expression --
+   ----------------------------
+
+   --  SIMPLE_EXPRESSION ::=
+   --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
+
+   --  On return, Expr_Form indicates the categorization of the expression
+
+   --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
+   --  EF_Simple_Name and the following token is RANGE (range attribute case).
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs within an
+   --  expression, then tokens are scanned until either a non-expression token,
+   --  a right paren (not matched by a left paren) or a comma, is encountered.
+
+   --  Note: P_Simple_Expression is called only internally by higher level
+   --  expression routines. In cases in the grammar where a simple expression
+   --  is required, the approach is to scan an expression, and then post an
+   --  appropriate error message if the expression obtained is not simple. This
+   --  gives better error recovery and treatment.
+
+   function P_Simple_Expression return Node_Id is
+      Scan_State : Saved_Scan_State;
+      Node1      : Node_Id;
+      Node2      : Node_Id;
+      Tokptr     : Source_Ptr;
+
+   begin
+      --  Check for cases starting with a name. There are two reasons for
+      --  special casing. First speed things up by catching a common case
+      --  without going through several routine layers. Second the caller must
+      --  be informed via Expr_Form when the simple expression is a name.
+
+      if Token in Token_Class_Name then
+         Node1 := P_Name;
+
+         --  Deal with apostrophe cases
+
+         if Token = Tok_Apostrophe then
+            Save_Scan_State (Scan_State); -- at apostrophe
+            Scan; -- past apostrophe
+
+            --  If qualified expression, scan it out and fall through
+
+            if Token = Tok_Left_Paren then
+               Node1 := P_Qualified_Expression (Node1);
+               Expr_Form := EF_Simple;
+
+            --  If range attribute, then we return with Token pointing to the
+            --  apostrophe. Note: avoid the normal error check on exit. We
+            --  know that the expression really is complete in this case!
+
+            else -- Token = Tok_Range then
+               Restore_Scan_State (Scan_State); -- to apostrophe
+               Expr_Form := EF_Simple_Name;
+               return Node1;
+            end if;
+         end if;
+
+         --  If an expression terminator follows, the previous processing
+         --  completely scanned out the expression (a common case), and
+         --  left Expr_Form set appropriately for returning to our caller.
+
+         if Token in Token_Class_Sterm then
+            null;
+
+         --  If we do not have an expression terminator, then complete the
+         --  scan of a simple expression. This code duplicates the code
+         --  found in P_Term and P_Factor.
+
+         else
+            if Token = Tok_Double_Asterisk then
+               if Style_Check then Style.Check_Exponentiation_Operator; end if;
+               Node2 := New_Node (N_Op_Expon, Token_Ptr);
+               Scan; -- past **
+               Set_Left_Opnd (Node2, Node1);
+               Set_Right_Opnd (Node2, P_Primary);
+               Set_Op_Name (Node2);
+               Node1 := Node2;
+            end if;
+
+            loop
+               exit when Token not in Token_Class_Mulop;
+               Tokptr := Token_Ptr;
+               Node2 := New_Node (P_Multiplying_Operator, Tokptr);
+               if Style_Check then Style.Check_Binary_Operator; end if;
+               Scan; -- past operator
+               Set_Left_Opnd (Node2, Node1);
+               Set_Right_Opnd (Node2, P_Factor);
+               Set_Op_Name (Node2);
+               Node1 := Node2;
+            end loop;
+
+            loop
+               exit when Token not in Token_Class_Binary_Addop;
+               Tokptr := Token_Ptr;
+               Node2 := New_Node (P_Binary_Adding_Operator, Tokptr);
+               if Style_Check then Style.Check_Binary_Operator; end if;
+               Scan; -- past operator
+               Set_Left_Opnd (Node2, Node1);
+               Set_Right_Opnd (Node2, P_Term);
+               Set_Op_Name (Node2);
+               Node1 := Node2;
+            end loop;
+
+            Expr_Form := EF_Simple;
+         end if;
+
+      --  Cases where simple expression does not start with a name
+
+      else
+         --  Scan initial sign and initial Term
+
+         if Token in Token_Class_Unary_Addop then
+            Tokptr := Token_Ptr;
+            Node1 := New_Node (P_Unary_Adding_Operator, Tokptr);
+            if Style_Check then Style.Check_Unary_Plus_Or_Minus; end if;
+            Scan; -- past operator
+            Set_Right_Opnd (Node1, P_Term);
+            Set_Op_Name (Node1);
+         else
+            Node1 := P_Term;
+         end if;
+
+         --  Scan out sequence of terms separated by binary adding operators
+
+         loop
+            exit when Token not in Token_Class_Binary_Addop;
+            Tokptr := Token_Ptr;
+            Node2 := New_Node (P_Binary_Adding_Operator, Tokptr);
+            Scan; -- past operator
+            Set_Left_Opnd (Node2, Node1);
+            Set_Right_Opnd (Node2, P_Term);
+            Set_Op_Name (Node2);
+            Node1 := Node2;
+         end loop;
+
+         --  All done, we clearly do not have name or numeric literal so this
+         --  is a case of a simple expression which is some other possibility.
+
+         Expr_Form := EF_Simple;
+      end if;
+
+      --  Come here at end of simple expression, where we do a couple of
+      --  special checks to improve error recovery.
+
+      --  Special test to improve error recovery. If the current token
+      --  is a period, then someone is trying to do selection on something
+      --  that is not a name, e.g. a qualified expression.
+
+      if Token = Tok_Dot then
+         Error_Msg_SC ("prefix for selection is not a name");
+         raise Error_Resync;
+      end if;
+
+      --  Special test to improve error recovery: If the current token is
+      --  not the first token on a line (as determined by checking the
+      --  previous token position with the start of the current line),
+      --  then we insist that we have an appropriate terminating token.
+      --  Consider the following two examples:
+
+      --   1)  if A nad B then ...
+
+      --   2)  A := B
+      --       C := D
+
+      --  In the first example, we would like to issue a binary operator
+      --  expected message and resynchronize to the then. In the second
+      --  example, we do not want to issue a binary operator message, so
+      --  that instead we will get the missing semicolon message. This
+      --  distinction is of course a heuristic which does not always work,
+      --  but in practice it is quite effective.
+
+      --  Note: the one case in which we do not go through this circuit is
+      --  when we have scanned a range attribute and want to return with
+      --  Token pointing to the apostrophe. The apostrophe is not normally
+      --  an expression terminator, and is not in Token_Class_Sterm, but
+      --  in this special case we know that the expression is complete.
+
+      if not Token_Is_At_Start_Of_Line
+         and then Token not in Token_Class_Sterm
+      then
+         Error_Msg_AP ("binary operator expected");
+         raise Error_Resync;
+      else
+         return Node1;
+      end if;
+
+   --  If any error occurs, then scan to next expression terminator symbol
+   --  or comma, right paren or vertical bar at the outer (i.e. current) paren
+   --  level. Expr_Form is set to indicate a normal simple expression.
+
+   exception
+      when Error_Resync =>
+         Resync_Expression;
+         Expr_Form := EF_Simple;
+         return Error;
+
+   end P_Simple_Expression;
+
+   -----------------------------------------------
+   -- 4.4  Simple Expression or Range Attribute --
+   -----------------------------------------------
+
+   --  SIMPLE_EXPRESSION ::=
+   --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
+
+   --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
+
+   --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Simple_Expression_Or_Range_Attribute return Node_Id is
+      Sexpr     : Node_Id;
+      Attr_Node : Node_Id;
+
+   begin
+      Sexpr := P_Simple_Expression;
+
+      if Token = Tok_Apostrophe then
+         Attr_Node := P_Range_Attribute_Reference (Sexpr);
+         Expr_Form := EF_Range_Attr;
+         return Attr_Node;
+
+      else
+         return Sexpr;
+      end if;
+   end P_Simple_Expression_Or_Range_Attribute;
+
+   ---------------
+   -- 4.4  Term --
+   ---------------
+
+   --  TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Term return Node_Id is
+      Node1, Node2 : Node_Id;
+      Tokptr       : Source_Ptr;
+
+   begin
+      Node1 := P_Factor;
+
+      loop
+         exit when Token not in Token_Class_Mulop;
+         Tokptr := Token_Ptr;
+         Node2 := New_Node (P_Multiplying_Operator, Tokptr);
+         Scan; -- past operator
+         Set_Left_Opnd (Node2, Node1);
+         Set_Right_Opnd (Node2, P_Factor);
+         Set_Op_Name (Node2);
+         Node1 := Node2;
+      end loop;
+
+      return Node1;
+   end P_Term;
+
+   -----------------
+   -- 4.4  Factor --
+   -----------------
+
+   --  FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Factor return Node_Id is
+      Node1 : Node_Id;
+      Node2 : Node_Id;
+
+   begin
+      if Token = Tok_Abs then
+         Node1 := New_Node (N_Op_Abs, Token_Ptr);
+         if Style_Check then Style.Check_Abs_Not; end if;
+         Scan; -- past ABS
+         Set_Right_Opnd (Node1, P_Primary);
+         Set_Op_Name (Node1);
+         return Node1;
+
+      elsif Token = Tok_Not then
+         Node1 := New_Node (N_Op_Not, Token_Ptr);
+         if Style_Check then Style.Check_Abs_Not; end if;
+         Scan; -- past NOT
+         Set_Right_Opnd (Node1, P_Primary);
+         Set_Op_Name (Node1);
+         return Node1;
+
+      else
+         Node1 := P_Primary;
+
+         if Token = Tok_Double_Asterisk then
+            Node2 := New_Node (N_Op_Expon, Token_Ptr);
+            Scan; -- past **
+            Set_Left_Opnd (Node2, Node1);
+            Set_Right_Opnd (Node2, P_Primary);
+            Set_Op_Name (Node2);
+            return Node2;
+         else
+            return Node1;
+         end if;
+      end if;
+   end P_Factor;
+
+   ------------------
+   -- 4.4  Primary --
+   ------------------
+
+   --  PRIMARY ::=
+   --    NUMERIC_LITERAL  | null
+   --  | STRING_LITERAL   | AGGREGATE
+   --  | NAME             | QUALIFIED_EXPRESSION
+   --  | ALLOCATOR        | (EXPRESSION)
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Primary return Node_Id is
+      Scan_State : Saved_Scan_State;
+      Node1      : Node_Id;
+
+   begin
+      --  The loop runs more than once only if misplaced pragmas are found
+
+      loop
+         case Token is
+
+            --  Name token can start a name, call or qualified expression, all
+            --  of which are acceptable possibilities for primary. Note also
+            --  that string literal is included in name (as operator symbol)
+            --  and type conversion is included in name (as indexed component).
+
+            when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
+               Node1 := P_Name;
+
+               --  All done unless apostrophe follows
+
+               if Token /= Tok_Apostrophe then
+                  return Node1;
+
+               --  Apostrophe following means that we have either just parsed
+               --  the subtype mark of a qualified expression, or the prefix
+               --  or a range attribute.
+
+               else -- Token = Tok_Apostrophe
+                  Save_Scan_State (Scan_State); -- at apostrophe
+                  Scan; -- past apostrophe
+
+                  --  If range attribute, then this is always an error, since
+                  --  the only legitimate case (where the scanned expression is
+                  --  a qualified simple name) is handled at the level of the
+                  --  Simple_Expression processing. This case corresponds to a
+                  --  usage such as 3 + A'Range, which is always illegal.
+
+                  if Token = Tok_Range then
+                     Restore_Scan_State (Scan_State); -- to apostrophe
+                     Bad_Range_Attribute (Token_Ptr);
+                     return Error;
+
+                  --  If left paren, then we have a qualified expression.
+                  --  Note that P_Name guarantees that in this case, where
+                  --  Token = Tok_Apostrophe on return, the only two possible
+                  --  tokens following the apostrophe are left paren and
+                  --  RANGE, so we know we have a left paren here.
+
+                  else -- Token = Tok_Left_Paren
+                     return P_Qualified_Expression (Node1);
+
+                  end if;
+               end if;
+
+            --  Numeric or string literal
+
+            when Tok_Integer_Literal |
+                 Tok_Real_Literal    |
+                 Tok_String_Literal  =>
+
+               Node1 := Token_Node;
+               Scan; -- past number
+               return Node1;
+
+            --  Left paren, starts aggregate or parenthesized expression
+
+            when Tok_Left_Paren =>
+               return P_Aggregate_Or_Paren_Expr;
+
+            --  Allocator
+
+            when Tok_New =>
+               return P_Allocator;
+
+            --  Null
+
+            when Tok_Null =>
+               Scan; -- past NULL
+               return New_Node (N_Null, Prev_Token_Ptr);
+
+            --  Pragma, not allowed here, so just skip past it
+
+            when Tok_Pragma =>
+               P_Pragmas_Misplaced;
+
+            --  Anything else is illegal as the first token of a primary, but
+            --  we test for a reserved identifier so that it is treated nicely
+
+            when others =>
+               if Is_Reserved_Identifier then
+                  return P_Identifier;
+
+               elsif Prev_Token = Tok_Comma then
+                  Error_Msg_SP ("extra "","" ignored");
+                  raise Error_Resync;
+
+               else
+                  Error_Msg_AP ("missing operand");
+                  raise Error_Resync;
+               end if;
+
+         end case;
+      end loop;
+   end P_Primary;
+
+   ---------------------------
+   -- 4.5  Logical Operator --
+   ---------------------------
+
+   --  LOGICAL_OPERATOR  ::=  and | or | xor
+
+   --  Note: AND THEN and OR ELSE are also treated as logical operators
+   --  by the parser (even though they are not operators semantically)
+
+   --  The value returned is the appropriate Node_Kind code for the operator
+   --  On return, Token points to the token following the scanned operator.
+
+   --  The caller has checked that the first token is a legitimate logical
+   --  operator token (i.e. is either XOR, AND, OR).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Logical_Operator return Node_Kind is
+   begin
+      if Token = Tok_And then
+         if Style_Check then Style.Check_Binary_Operator; end if;
+         Scan; -- past AND
+
+         if Token = Tok_Then then
+            Scan; -- past THEN
+            return N_And_Then;
+         else
+            return N_Op_And;
+         end if;
+
+      elsif Token = Tok_Or then
+         if Style_Check then Style.Check_Binary_Operator; end if;
+         Scan; -- past OR
+
+         if Token = Tok_Else then
+            Scan; -- past ELSE
+            return N_Or_Else;
+         else
+            return N_Op_Or;
+         end if;
+
+      else -- Token = Tok_Xor
+         if Style_Check then Style.Check_Binary_Operator; end if;
+         Scan; -- past XOR
+         return N_Op_Xor;
+      end if;
+   end P_Logical_Operator;
+
+   ------------------------------
+   -- 4.5  Relational Operator --
+   ------------------------------
+
+   --  RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
+
+   --  The value returned is the appropriate Node_Kind code for the operator.
+   --  On return, Token points to the operator token, NOT past it.
+
+   --  The caller has checked that the first token is a legitimate relational
+   --  operator token (i.e. is one of the operator tokens listed above).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Relational_Operator return Node_Kind is
+      Op_Kind : Node_Kind;
+      Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
+        (Tok_Less           => N_Op_Lt,
+         Tok_Equal          => N_Op_Eq,
+         Tok_Greater        => N_Op_Gt,
+         Tok_Not_Equal      => N_Op_Ne,
+         Tok_Greater_Equal  => N_Op_Ge,
+         Tok_Less_Equal     => N_Op_Le,
+         Tok_In             => N_In,
+         Tok_Not            => N_Not_In,
+         Tok_Box            => N_Op_Ne);
+
+   begin
+      if Token = Tok_Box then
+         Error_Msg_SC ("""<>"" should be ""/=""");
+      end if;
+
+      Op_Kind := Relop_Node (Token);
+      if Style_Check then Style.Check_Binary_Operator; end if;
+      Scan; -- past operator token
+
+      if Prev_Token = Tok_Not then
+         T_In;
+      end if;
+
+      return Op_Kind;
+   end P_Relational_Operator;
+
+   ---------------------------------
+   -- 4.5  Binary Adding Operator --
+   ---------------------------------
+
+   --  BINARY_ADDING_OPERATOR ::= + | - | &
+
+   --  The value returned is the appropriate Node_Kind code for the operator.
+   --  On return, Token points to the operator token (NOT past it).
+
+   --  The caller has checked that the first token is a legitimate adding
+   --  operator token (i.e. is one of the operator tokens listed above).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Binary_Adding_Operator return Node_Kind is
+      Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
+        (Tok_Ampersand      => N_Op_Concat,
+         Tok_Minus          => N_Op_Subtract,
+         Tok_Plus           => N_Op_Add);
+   begin
+      return Addop_Node (Token);
+   end P_Binary_Adding_Operator;
+
+   --------------------------------
+   -- 4.5  Unary Adding Operator --
+   --------------------------------
+
+   --  UNARY_ADDING_OPERATOR ::= + | -
+
+   --  The value returned is the appropriate Node_Kind code for the operator.
+   --  On return, Token points to the operator token (NOT past it).
+
+   --  The caller has checked that the first token is a legitimate adding
+   --  operator token (i.e. is one of the operator tokens listed above).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Unary_Adding_Operator return Node_Kind is
+      Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
+        (Tok_Minus          => N_Op_Minus,
+         Tok_Plus           => N_Op_Plus);
+   begin
+      return Addop_Node (Token);
+   end P_Unary_Adding_Operator;
+
+   -------------------------------
+   -- 4.5  Multiplying Operator --
+   -------------------------------
+
+   --  MULTIPLYING_OPERATOR ::= * | / | mod | rem
+
+   --  The value returned is the appropriate Node_Kind code for the operator.
+   --  On return, Token points to the operator token (NOT past it).
+
+   --  The caller has checked that the first token is a legitimate multiplying
+   --  operator token (i.e. is one of the operator tokens listed above).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Multiplying_Operator return Node_Kind is
+      Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
+        (Tok_Asterisk       => N_Op_Multiply,
+         Tok_Mod            => N_Op_Mod,
+         Tok_Rem            => N_Op_Rem,
+         Tok_Slash          => N_Op_Divide);
+   begin
+      return Mulop_Node (Token);
+   end P_Multiplying_Operator;
+
+   --------------------------------------
+   -- 4.5  Highest Precedence Operator --
+   --------------------------------------
+
+   --  Parsed by P_Factor (4.4)
+
+   --  Note: this rule is not in fact used by the grammar at any point!
+
+   --------------------------
+   -- 4.6  Type Conversion --
+   --------------------------
+
+   --  Parsed by P_Primary as a Name (4.1)
+
+   -------------------------------
+   -- 4.7  Qualified Expression --
+   -------------------------------
+
+   --  QUALIFIED_EXPRESSION ::=
+   --    SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
+
+   --  The caller has scanned the name which is the Subtype_Mark parameter
+   --  and scanned past the single quote following the subtype mark. The
+   --  caller has not checked that this name is in fact appropriate for
+   --  a subtype mark name (i.e. it is a selected component or identifier).
+
+   --  Error_Recovery: cannot raise Error_Resync
+
+   function  P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
+      Qual_Node : Node_Id;
+
+   begin
+      Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
+      Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
+      Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
+      return Qual_Node;
+   end P_Qualified_Expression;
+
+   --------------------
+   -- 4.8  Allocator --
+   --------------------
+
+   --  ALLOCATOR ::=
+   --   new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+
+   --  The caller has checked that the initial token is NEW
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Allocator return Node_Id is
+      Alloc_Node  : Node_Id;
+      Type_Node   : Node_Id;
+
+   begin
+      Alloc_Node := New_Node (N_Allocator, Token_Ptr);
+      T_New;
+      Type_Node := P_Subtype_Mark_Resync;
+
+      if Token = Tok_Apostrophe then
+         Scan; -- past apostrophe
+         Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
+      else
+         Set_Expression (Alloc_Node, P_Subtype_Indication (Type_Node));
+      end if;
+
+      return Alloc_Node;
+   end P_Allocator;
+
+end Ch4;
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
new file mode 100644
index 0000000..2ec5672
--- /dev/null
+++ b/gcc/ada/par-ch5.adb
@@ -0,0 +1,2184 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 5                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.95 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch5 is
+
+   --  Local functions, used only in this chapter
+
+   function P_Case_Statement                     return Node_Id;
+   function P_Case_Statement_Alternative         return Node_Id;
+   function P_Condition                          return Node_Id;
+   function P_Exit_Statement                     return Node_Id;
+   function P_Goto_Statement                     return Node_Id;
+   function P_If_Statement                       return Node_Id;
+   function P_Label                              return Node_Id;
+   function P_Loop_Parameter_Specification       return Node_Id;
+   function P_Null_Statement                     return Node_Id;
+
+   function P_Assignment_Statement (LHS : Node_Id)  return Node_Id;
+   --  Parse assignment statement. On entry, the caller has scanned the left
+   --  hand side (passed in as Lhs), and the colon-equal (or some symbol
+   --  taken to be an error equivalent such as equal).
+
+   function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
+   --  Parse begin-end statement. If Block_Name is non-Empty on entry, it is
+   --  the N_Identifier node for the label on the block. If Block_Name is
+   --  Empty on entry (the default), then the block statement is unlabeled.
+
+   function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
+   --  Parse declare block. If Block_Name is non-Empty on entry, it is
+   --  the N_Identifier node for the label on the block. If Block_Name is
+   --  Empty on entry (the default), then the block statement is unlabeled.
+
+   function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
+   --  Parse for statement. If Loop_Name is non-Empty on entry, it is
+   --  the N_Identifier node for the label on the loop. If Loop_Name is
+   --  Empty on entry (the default), then the for statement is unlabeled.
+
+   function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
+   --  Parse loop statement. If Loop_Name is non-Empty on entry, it is
+   --  the N_Identifier node for the label on the loop. If Loop_Name is
+   --  Empty on entry (the default), then the loop statement is unlabeled.
+
+   function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
+   --  Parse while statement. If Loop_Name is non-Empty on entry, it is
+   --  the N_Identifier node for the label on the loop. If Loop_Name is
+   --  Empty on entry (the default), then the while statement is unlabeled.
+
+   function Set_Loop_Block_Name (L : Character) return Name_Id;
+   --  Given a letter 'L' for a loop or 'B' for a block, returns a name
+   --  of the form L_nn or B_nn where nn is a serial number obtained by
+   --  incrementing the variable Loop_Block_Count.
+
+   procedure Then_Scan;
+   --  Scan past THEN token, testing for illegal junk after it
+
+   ---------------------------------
+   -- 5.1  Sequence of Statements --
+   ---------------------------------
+
+   --  SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
+
+   --  STATEMENT ::=
+   --    {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
+
+   --  SIMPLE_STATEMENT ::=      NULL_STATEMENT
+   --  | ASSIGNMENT_STATEMENT  | EXIT_STATEMENT
+   --  | GOTO_STATEMENT        | PROCEDURE_CALL_STATEMENT
+   --  | RETURN_STATEMENT      | ENTRY_CALL_STATEMENT
+   --  | REQUEUE_STATEMENT     | DELAY_STATEMENT
+   --  | ABORT_STATEMENT       | RAISE_STATEMENT
+   --  | CODE_STATEMENT
+
+   --  COMPOUND_STATEMENT ::=
+   --    IF_STATEMENT         | CASE_STATEMENT
+   --  | LOOP_STATEMENT       | BLOCK_STATEMENT
+   --  | ACCEPT_STATEMENT     | SELECT_STATEMENT
+
+   --  This procedure scans a sequence of statements. The caller sets SS_Flags
+   --  to indicate acceptable termination conditions for the sequence:
+
+   --    SS_Flags.Eftm Terminate on ELSIF
+   --    SS_Flags.Eltm Terminate on ELSE
+   --    SS_Flags.Extm Terminate on EXCEPTION
+   --    SS_Flags.Ortm Terminate on OR
+   --    SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return)
+   --    SS_Flags.Whtm Terminate on WHEN
+   --    SS_Flags.Unco Unconditional terminate after scanning one statement
+
+   --  In addition, the scan is always terminated by encountering END or the
+   --  end of file (EOF) condition. If one of the six above terminators is
+   --  encountered with the corresponding SS_Flags flag not set, then the
+   --  action taken is as follows:
+
+   --    If the keyword occurs to the left of the expected column of the end
+   --    for the current sequence (as recorded in the current end context),
+   --    then it is assumed to belong to an outer context, and is considered
+   --    to terminate the sequence of statements.
+
+   --    If the keyword occurs to the right of, or in the expected column of
+   --    the end for the current sequence, then an error message is output,
+   --    the keyword together with its associated context is skipped, and
+   --    the statement scan continues until another terminator is found.
+
+   --  Note that the first action means that control can return to the caller
+   --  with Token set to a terminator other than one of those specified by the
+   --  SS parameter. The caller should treat such a case as equivalent to END.
+
+   --  In addition, the flag SS_Flags.Sreq is set to True to indicate that at
+   --  least one real statement (other than a pragma) is required in the
+   --  statement sequence. During the processing of the sequence, this
+   --  flag is manipulated to indicate the current status of the requirement
+   --  for a statement. For example, it is turned off by the occurrence of a
+   --  statement, and back on by a label (which requires a following statement)
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs during
+   --  parsing a statement, then the scan pointer is advanced past the next
+   --  semicolon and the parse continues.
+
+   function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
+
+      Statement_Required : Boolean;
+      --  This flag indicates if a subsequent statement (other than a pragma)
+      --  is required. It is initialized from the Sreq flag, and modified as
+      --  statements are scanned (a statement turns it off, and a label turns
+      --  it back on again since a statement must follow a label).
+
+      Declaration_Found : Boolean := False;
+      --  This flag is set True if a declaration is encountered, so that the
+      --  error message about declarations in the statement part is only
+      --  given once for a given sequence of statements.
+
+      Scan_State_Label : Saved_Scan_State;
+      Scan_State       : Saved_Scan_State;
+
+      Statement_List : List_Id;
+      Block_Label    : Name_Id;
+      Id_Node        : Node_Id;
+      Name_Node      : Node_Id;
+
+      procedure Junk_Declaration;
+      --  Procedure called to handle error of declaration encountered in
+      --  statement sequence.
+
+      procedure Test_Statement_Required;
+      --  Flag error if Statement_Required flag set
+
+      procedure Junk_Declaration is
+      begin
+         if (not Declaration_Found) or All_Errors_Mode then
+            Error_Msg_SC ("declarations must come before BEGIN");
+            Declaration_Found := True;
+         end if;
+
+         Skip_Declaration (Statement_List);
+      end Junk_Declaration;
+
+      procedure Test_Statement_Required is
+      begin
+         if Statement_Required then
+            Error_Msg_BC ("statement expected");
+         end if;
+      end Test_Statement_Required;
+
+   --  Start of processing for P_Sequence_Of_Statements
+
+   begin
+      Statement_List := New_List;
+      Statement_Required := SS_Flags.Sreq;
+
+      loop
+         while Token = Tok_Semicolon loop
+            Error_Msg_SC ("unexpected semicolon ignored");
+            Scan; -- past junk semicolon
+         end loop;
+
+         begin
+            if Style_Check then Style.Check_Indentation; end if;
+
+            --  Deal with reserved identifier (in assignment or call)
+
+            if Is_Reserved_Identifier then
+               Save_Scan_State (Scan_State); -- at possible bad identifier
+               Scan; -- and scan past it
+
+               --  We have an reserved word which is spelled in identifier
+               --  style, so the question is whether it really is intended
+               --  to be an identifier.
+
+               if
+                  --  If followed by a semicolon, then it is an identifier,
+                  --  with the exception of the cases tested for below.
+
+                  (Token = Tok_Semicolon
+                    and then Prev_Token /= Tok_Return
+                    and then Prev_Token /= Tok_Null
+                    and then Prev_Token /= Tok_Raise
+                    and then Prev_Token /= Tok_End
+                    and then Prev_Token /= Tok_Exit)
+
+                  --  If followed by colon, colon-equal, or dot, then we
+                  --  definitely  have an identifier (could not be reserved)
+
+                  or else Token = Tok_Colon
+                  or else Token = Tok_Colon_Equal
+                  or else Token = Tok_Dot
+
+                  --  Left paren means we have an identifier except for those
+                  --  reserved words that can legitimately be followed by a
+                  --  left paren.
+
+                  or else
+                    (Token = Tok_Left_Paren
+                      and then Prev_Token /= Tok_Case
+                      and then Prev_Token /= Tok_Delay
+                      and then Prev_Token /= Tok_If
+                      and then Prev_Token /= Tok_Elsif
+                      and then Prev_Token /= Tok_Return
+                      and then Prev_Token /= Tok_When
+                      and then Prev_Token /= Tok_While
+                      and then Prev_Token /= Tok_Separate)
+               then
+                  --  Here we have an apparent reserved identifier and the
+                  --  token past it is appropriate to this usage (and would
+                  --  be a definite error if this is not an identifier). What
+                  --  we do is to use P_Identifier to fix up the identifier,
+                  --  and then fall into the normal processing.
+
+                  Restore_Scan_State (Scan_State); -- back to the ID
+                  Scan_Reserved_Identifier (Force_Msg => False);
+
+                  --  Not a reserved identifier after all (or at least we can't
+                  --  be sure that it is), so reset the scan and continue.
+
+               else
+                  Restore_Scan_State (Scan_State); -- back to the reserved word
+               end if;
+            end if;
+
+            --  Now look to see what kind of statement we have
+
+            case Token is
+
+               --  Case of end or EOF
+
+               when Tok_End | Tok_EOF =>
+
+                  --  These tokens always terminate the statement sequence
+
+                  Test_Statement_Required;
+                  exit;
+
+               --  Case of ELSIF
+
+               when Tok_Elsif =>
+
+                  --  Terminate if Eftm set or if the ELSIF is to the left
+                  --  of the expected column of the end for this sequence
+
+                  if SS_Flags.Eftm
+                     or else Start_Column < Scope.Table (Scope.Last).Ecol
+                  then
+                     Test_Statement_Required;
+                     exit;
+
+                  --  Otherwise complain and skip past ELSIF Condition then
+
+                  else
+                     Error_Msg_SC ("ELSIF not allowed here");
+                     Scan; -- past ELSIF
+                     Discard_Junk_Node (P_Expression_No_Right_Paren);
+                     Then_Scan;
+                     Statement_Required := False;
+                  end if;
+
+               --  Case of ELSE
+
+               when Tok_Else =>
+
+                  --  Terminate if Eltm set or if the else is to the left
+                  --  of the expected column of the end for this sequence
+
+                  if SS_Flags.Eltm
+                     or else Start_Column < Scope.Table (Scope.Last).Ecol
+                  then
+                     Test_Statement_Required;
+                     exit;
+
+                  --  Otherwise complain and skip past else
+
+                  else
+                     Error_Msg_SC ("ELSE not allowed here");
+                     Scan; -- past ELSE
+                     Statement_Required := False;
+                  end if;
+
+               --  Case of exception
+
+               when Tok_Exception =>
+                  Test_Statement_Required;
+
+                  --  If Extm not set and the exception is not to the left
+                  --  of the expected column of the end for this sequence, then
+                  --  we assume it belongs to the current sequence, even though
+                  --  it is not permitted.
+
+                  if not SS_Flags.Extm and then
+                     Start_Column >= Scope.Table (Scope.Last).Ecol
+
+                  then
+                     Error_Msg_SC ("exception handler not permitted here");
+                     Scan; -- past EXCEPTION
+                     Discard_Junk_List (Parse_Exception_Handlers);
+                  end if;
+
+                  --  Always return, in the case where we scanned out handlers
+                  --  that we did not expect, Parse_Exception_Handlers returned
+                  --  with Token being either end or EOF, so we are OK
+
+                  exit;
+
+               --  Case of OR
+
+               when Tok_Or =>
+
+                  --  Terminate if Ortm set or if the or is to the left
+                  --  of the expected column of the end for this sequence
+
+                  if SS_Flags.Ortm
+                     or else Start_Column < Scope.Table (Scope.Last).Ecol
+                  then
+                     Test_Statement_Required;
+                     exit;
+
+                  --  Otherwise complain and skip past or
+
+                  else
+                     Error_Msg_SC ("OR not allowed here");
+                     Scan; -- past or
+                     Statement_Required := False;
+                  end if;
+
+               --  Case of THEN (deal also with THEN ABORT)
+
+               when Tok_Then =>
+                  Save_Scan_State (Scan_State); -- at THEN
+                  Scan; -- past THEN
+
+                  --  Terminate if THEN ABORT allowed (ATC case)
+
+                  exit when SS_Flags.Tatm and then Token = Tok_Abort;
+
+                  --  Otherwise we treat THEN as some kind of mess where we
+                  --  did not see the associated IF, but we pick up assuming
+                  --  it had been there!
+
+                  Restore_Scan_State (Scan_State); -- to THEN
+                  Append_To (Statement_List, P_If_Statement);
+                  Statement_Required := False;
+
+               --  Case of WHEN (error because we are not in a case)
+
+               when Tok_When | Tok_Others =>
+
+                  --  Terminate if Whtm set or if the WHEN is to the left
+                  --  of the expected column of the end for this sequence
+
+                  if SS_Flags.Whtm
+                     or else Start_Column < Scope.Table (Scope.Last).Ecol
+                  then
+                     Test_Statement_Required;
+                     exit;
+
+                  --  Otherwise complain and skip when Choice {| Choice} =>
+
+                  else
+                     Error_Msg_SC ("WHEN not allowed here");
+                     Scan; -- past when
+                     Discard_Junk_List (P_Discrete_Choice_List);
+                     TF_Arrow;
+                     Statement_Required := False;
+                  end if;
+
+               --  Cases of statements starting with an identifier
+
+               when Tok_Identifier =>
+                  Check_Bad_Layout;
+
+                  --  Save scan pointers and line number in case block label
+
+                  Id_Node := Token_Node;
+                  Block_Label := Token_Name;
+                  Save_Scan_State (Scan_State_Label); -- at possible label
+                  Scan; -- past Id
+
+                  --  Check for common case of assignment, since it occurs
+                  --  frequently, and we want to process it efficiently.
+
+                  if Token = Tok_Colon_Equal then
+                     Scan; -- past the colon-equal
+                     Append_To (Statement_List,
+                       P_Assignment_Statement (Id_Node));
+                     Statement_Required := False;
+
+                  --  Check common case of procedure call, another case that
+                  --  we want to speed up as much as possible.
+
+                  elsif Token = Tok_Semicolon then
+                     Append_To (Statement_List,
+                       P_Statement_Name (Id_Node));
+                     Scan; -- past semicolon
+                     Statement_Required := False;
+
+                  --  Check for case of "go to" in place of "goto"
+
+                  elsif Token = Tok_Identifier
+                    and then Block_Label = Name_Go
+                    and then Token_Name = Name_To
+                  then
+                     Error_Msg_SP ("goto is one word");
+                     Append_To (Statement_List, P_Goto_Statement);
+                     Statement_Required := False;
+
+                  --  Check common case of = used instead of :=, just so we
+                  --  give a better error message for this special misuse.
+
+                  elsif Token = Tok_Equal then
+                     T_Colon_Equal; -- give := expected message
+                     Append_To (Statement_List,
+                       P_Assignment_Statement (Id_Node));
+                     Statement_Required := False;
+
+                  --  Check case of loop label or block label
+
+                  elsif Token = Tok_Colon
+                    or else (Token in Token_Class_Labeled_Stmt
+                              and then not Token_Is_At_Start_Of_Line)
+                  then
+                     T_Colon; -- past colon (if there, or msg for missing one)
+
+                     --  Test for more than one label
+
+                     loop
+                        exit when Token /= Tok_Identifier;
+                        Save_Scan_State (Scan_State); -- at second Id
+                        Scan; -- past Id
+
+                        if Token = Tok_Colon then
+                           Error_Msg_SP
+                              ("only one label allowed on block or loop");
+                           Scan; -- past colon on extra label
+
+                           --  Use the second label as the "real" label
+
+                           Scan_State_Label := Scan_State;
+
+                           --  We will set Error_name as the Block_Label since
+                           --  we really don't know which of the labels might
+                           --  be used at the end of the loop or block!
+
+                           Block_Label := Error_Name;
+
+                        --  If Id with no colon, then backup to point to the
+                        --  Id and we will issue the message below when we try
+                        --  to scan out the statement as some other form.
+
+                        else
+                           Restore_Scan_State (Scan_State); -- to second Id
+                           exit;
+                        end if;
+                     end loop;
+
+                     --  Loop_Statement (labeled Loop_Statement)
+
+                     if Token = Tok_Loop then
+                        Append_To (Statement_List,
+                          P_Loop_Statement (Id_Node));
+
+                     --  While statement (labeled loop statement with WHILE)
+
+                     elsif Token = Tok_While then
+                        Append_To (Statement_List,
+                          P_While_Statement (Id_Node));
+
+                     --  Declare statement (labeled block statement with
+                     --  DECLARE part)
+
+                     elsif Token = Tok_Declare then
+                        Append_To (Statement_List,
+                          P_Declare_Statement (Id_Node));
+
+                     --  Begin statement (labeled block statement with no
+                     --  DECLARE part)
+
+                     elsif Token = Tok_Begin then
+                        Append_To (Statement_List,
+                          P_Begin_Statement (Id_Node));
+
+                     --  For statement (labeled loop statement with FOR)
+
+                     elsif Token = Tok_For then
+                        Append_To (Statement_List,
+                          P_For_Statement (Id_Node));
+
+                     --  Improper statement follows label. If we have an
+                     --  expression token, then assume the colon was part
+                     --  of a misplaced declaration.
+
+                     elsif Token not in Token_Class_Eterm then
+                        Restore_Scan_State (Scan_State_Label);
+                        Junk_Declaration;
+
+                     --  Otherwise complain we have inappropriate statement
+
+                     else
+                        Error_Msg_AP
+                          ("loop or block statement must follow label");
+                     end if;
+
+                     Statement_Required := False;
+
+                  --  Here we have an identifier followed by something
+                  --  other than a colon, semicolon or assignment symbol.
+                  --  The only valid possibility is a name extension symbol
+
+                  elsif Token in Token_Class_Namext then
+                     Restore_Scan_State (Scan_State_Label); -- to Id
+                     Name_Node := P_Name;
+
+                     --  Skip junk right parens in this context
+
+                     while Token = Tok_Right_Paren loop
+                        Error_Msg_SC ("extra right paren");
+                        Scan; -- past )
+                     end loop;
+
+                     --  Check context following call
+
+                     if Token = Tok_Colon_Equal then
+                        Scan; -- past colon equal
+                        Append_To (Statement_List,
+                          P_Assignment_Statement (Name_Node));
+                        Statement_Required := False;
+
+                     --  Check common case of = used instead of :=
+
+                     elsif Token = Tok_Equal then
+                        T_Colon_Equal; -- give := expected message
+                        Append_To (Statement_List,
+                          P_Assignment_Statement (Name_Node));
+                        Statement_Required := False;
+
+                     --  Check apostrophe cases
+
+                     elsif Token = Tok_Apostrophe then
+                        Append_To (Statement_List,
+                          P_Code_Statement (Name_Node));
+                        Statement_Required := False;
+
+                     --  The only other valid item after a name is ; which
+                     --  means that the item we just scanned was a call.
+
+                     elsif Token = Tok_Semicolon then
+                        Append_To (Statement_List,
+                          P_Statement_Name (Name_Node));
+                        Scan; -- past semicolon
+                        Statement_Required := False;
+
+                        --  Else we have a missing semicolon
+
+                     else
+                        TF_Semicolon;
+                        Statement_Required := False;
+                     end if;
+
+                  --  If junk after identifier, check if identifier is an
+                  --  instance of an incorrectly spelled keyword. If so, we
+                  --  do nothing. The Bad_Spelling_Of will have reset Token
+                  --  to the appropriate keyword, so the next time round the
+                  --  loop we will process the modified token. Note that we
+                  --  check for ELSIF before ELSE here. That's not accidental.
+                  --  We don't want to identify a misspelling of ELSE as
+                  --  ELSIF, and in particular we do not want to treat ELSEIF
+                  --  as ELSE IF.
+
+                  else
+                     Restore_Scan_State (Scan_State_Label); -- to identifier
+
+                     if Bad_Spelling_Of (Tok_Abort)
+                       or else Bad_Spelling_Of (Tok_Accept)
+                       or else Bad_Spelling_Of (Tok_Case)
+                       or else Bad_Spelling_Of (Tok_Declare)
+                       or else Bad_Spelling_Of (Tok_Delay)
+                       or else Bad_Spelling_Of (Tok_Elsif)
+                       or else Bad_Spelling_Of (Tok_Else)
+                       or else Bad_Spelling_Of (Tok_End)
+                       or else Bad_Spelling_Of (Tok_Exception)
+                       or else Bad_Spelling_Of (Tok_Exit)
+                       or else Bad_Spelling_Of (Tok_For)
+                       or else Bad_Spelling_Of (Tok_Goto)
+                       or else Bad_Spelling_Of (Tok_If)
+                       or else Bad_Spelling_Of (Tok_Loop)
+                       or else Bad_Spelling_Of (Tok_Or)
+                       or else Bad_Spelling_Of (Tok_Pragma)
+                       or else Bad_Spelling_Of (Tok_Raise)
+                       or else Bad_Spelling_Of (Tok_Requeue)
+                       or else Bad_Spelling_Of (Tok_Return)
+                       or else Bad_Spelling_Of (Tok_Select)
+                       or else Bad_Spelling_Of (Tok_When)
+                       or else Bad_Spelling_Of (Tok_While)
+                     then
+                        null;
+
+                     --  If not a bad spelling, then we really have junk
+
+                     else
+                        Scan; -- past identifier again
+
+                        --  If next token is first token on line, then we
+                        --  consider that we were missing a semicolon after
+                        --  the identifier, and process it as a procedure
+                        --  call with no parameters.
+
+                        if Token_Is_At_Start_Of_Line then
+                           Append_To (Statement_List,
+                             P_Statement_Name (Id_Node));
+                           T_Semicolon; -- to give error message
+                           Statement_Required := False;
+
+                        --  Otherwise we give a missing := message and
+                        --  simply abandon the junk that is there now.
+
+                        else
+                           T_Colon_Equal; -- give := expected message
+                           raise Error_Resync;
+                        end if;
+
+                     end if;
+                  end if;
+
+               --  Statement starting with operator symbol. This could be
+               --  a call, a name starting an assignment, or a qualified
+               --  expression.
+
+               when Tok_Operator_Symbol =>
+                  Check_Bad_Layout;
+                  Name_Node := P_Name;
+
+                  --  An attempt at a range attribute or a qualified expression
+                  --  must be illegal here (a code statement cannot possibly
+                  --  allow qualification by a function name).
+
+                  if Token = Tok_Apostrophe then
+                     Error_Msg_SC ("apostrophe illegal here");
+                     raise Error_Resync;
+                  end if;
+
+                  --  Scan possible assignment if we have a name
+
+                  if Expr_Form = EF_Name
+                    and then Token = Tok_Colon_Equal
+                  then
+                     Scan; -- past colon equal
+                     Append_To (Statement_List,
+                       P_Assignment_Statement (Name_Node));
+                  else
+                     Append_To (Statement_List,
+                       P_Statement_Name (Name_Node));
+                  end if;
+
+                  TF_Semicolon;
+                  Statement_Required := False;
+
+               --  Label starting with << which must precede real statement
+
+               when Tok_Less_Less =>
+                  Append_To (Statement_List, P_Label);
+                  Statement_Required := True;
+
+               --  Pragma appearing as a statement in a statement sequence
+
+               when Tok_Pragma =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Pragma);
+
+               --  Abort_Statement
+
+               when Tok_Abort =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Abort_Statement);
+                  Statement_Required := False;
+
+               --  Accept_Statement
+
+               when Tok_Accept =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Accept_Statement);
+                  Statement_Required := False;
+
+               --  Begin_Statement (Block_Statement with no declare, no label)
+
+               when Tok_Begin =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Begin_Statement);
+                  Statement_Required := False;
+
+               --  Case_Statement
+
+               when Tok_Case =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Case_Statement);
+                  Statement_Required := False;
+
+               --  Block_Statement with DECLARE and no label
+
+               when Tok_Declare =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Declare_Statement);
+                  Statement_Required := False;
+
+               --  Delay_Statement
+
+               when Tok_Delay =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Delay_Statement);
+                  Statement_Required := False;
+
+               --  Exit_Statement
+
+               when Tok_Exit =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Exit_Statement);
+                  Statement_Required := False;
+
+               --  Loop_Statement with FOR and no label
+
+               when Tok_For =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_For_Statement);
+                  Statement_Required := False;
+
+               --  Goto_Statement
+
+               when Tok_Goto =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Goto_Statement);
+                  Statement_Required := False;
+
+               --  If_Statement
+
+               when Tok_If =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_If_Statement);
+                  Statement_Required := False;
+
+               --  Loop_Statement
+
+               when Tok_Loop =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Loop_Statement);
+                  Statement_Required := False;
+
+               --  Null_Statement
+
+               when Tok_Null =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Null_Statement);
+                  Statement_Required := False;
+
+               --  Raise_Statement
+
+               when Tok_Raise =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Raise_Statement);
+                  Statement_Required := False;
+
+               --  Requeue_Statement
+
+               when Tok_Requeue =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Requeue_Statement);
+                  Statement_Required := False;
+
+               --  Return_Statement
+
+               when Tok_Return =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Return_Statement);
+                  Statement_Required := False;
+
+               --  Select_Statement
+
+               when Tok_Select =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_Select_Statement);
+                  Statement_Required := False;
+
+               --  While_Statement (Block_Statement with while and no loop)
+
+               when Tok_While =>
+                  Check_Bad_Layout;
+                  Append_To (Statement_List, P_While_Statement);
+                  Statement_Required := False;
+
+               --  Anything else is some kind of junk, signal an error message
+               --  and then raise Error_Resync, to merge with the normal
+               --  handling of a bad statement.
+
+               when others =>
+
+                  if Token in Token_Class_Declk then
+                     Junk_Declaration;
+
+                  else
+                     Error_Msg_BC ("statement expected");
+                     raise Error_Resync;
+                  end if;
+            end case;
+
+         --  On error resynchronization, skip past next semicolon, and, since
+         --  we are still in the statement loop, look for next statement. We
+         --  set Statement_Required False to avoid an unnecessary error message
+         --  complaining that no statement was found (i.e. we consider the
+         --  junk to satisfy the requirement for a statement being present).
+
+         exception
+            when Error_Resync =>
+               Resync_Past_Semicolon_Or_To_Loop_Or_Then;
+               Statement_Required := False;
+         end;
+
+         exit when SS_Flags.Unco;
+
+      end loop;
+
+      return Statement_List;
+
+   end P_Sequence_Of_Statements;
+
+   --------------------
+   -- 5.1  Statement --
+   --------------------
+
+   --  Parsed by P_Sequence_Of_Statements (5.1), except for the case
+   --  of a statement of the form of a name, which is handled here. The
+   --  argument passed in is the tree for the name which has been scanned
+   --  The returned value is the corresponding statement form.
+
+   --  This routine is also used by Par.Prag for processing the procedure
+   --  call that appears as the second argument of a pragma Assert.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
+      Stmt_Node : Node_Id;
+
+   begin
+      --  Case of Indexed component, which is a procedure call with arguments
+
+      if Nkind (Name_Node) = N_Indexed_Component then
+         declare
+            Prefix_Node : Node_Id := Prefix (Name_Node);
+            Exprs_Node  : List_Id := Expressions (Name_Node);
+         begin
+            Change_Node (Name_Node, N_Procedure_Call_Statement);
+            Set_Name (Name_Node, Prefix_Node);
+            Set_Parameter_Associations (Name_Node, Exprs_Node);
+            return Name_Node;
+         end;
+
+      --  Case of function call node, which is a really a procedure call
+
+      elsif Nkind (Name_Node) = N_Function_Call then
+         declare
+            Fname_Node  : Node_Id := Name (Name_Node);
+            Params_List : List_Id := Parameter_Associations (Name_Node);
+
+         begin
+            Change_Node (Name_Node, N_Procedure_Call_Statement);
+            Set_Name (Name_Node, Fname_Node);
+            Set_Parameter_Associations (Name_Node, Params_List);
+            return Name_Node;
+         end;
+
+      --  Case of call to attribute that denotes a procedure. Here we
+      --  just leave the attribute reference unchanged.
+
+      elsif Nkind (Name_Node) = N_Attribute_Reference
+        and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
+      then
+         return Name_Node;
+
+      --  All other cases of names are parameterless procedure calls
+
+      else
+         Stmt_Node :=
+           New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
+         Set_Name (Stmt_Node, Name_Node);
+         return Stmt_Node;
+      end if;
+
+   end P_Statement_Name;
+
+   ---------------------------
+   -- 5.1  Simple Statement --
+   ---------------------------
+
+   --  Parsed by P_Sequence_Of_Statements (5.1)
+
+   -----------------------------
+   -- 5.1  Compound Statement --
+   -----------------------------
+
+   --  Parsed by P_Sequence_Of_Statements (5.1)
+
+   -------------------------
+   -- 5.1  Null Statement --
+   -------------------------
+
+   --  NULL_STATEMENT ::= null;
+
+   --  The caller has already checked that the current token is null
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Null_Statement return Node_Id is
+      Null_Stmt_Node : Node_Id;
+
+   begin
+      Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
+      Scan; -- past NULL
+      TF_Semicolon;
+      return Null_Stmt_Node;
+   end P_Null_Statement;
+
+   ----------------
+   -- 5.1  Label --
+   ----------------
+
+   --  LABEL ::= <<label_STATEMENT_IDENTIFIER>>
+
+   --  STATEMENT_INDENTIFIER ::= DIRECT_NAME
+
+   --  The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
+   --  (not an OPERATOR_SYMBOL)
+
+   --  The caller has already checked that the current token is <<
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Label return Node_Id is
+      Label_Node : Node_Id;
+
+   begin
+      Label_Node := New_Node (N_Label, Token_Ptr);
+      Scan; -- past <<
+      Set_Identifier (Label_Node, P_Identifier);
+      T_Greater_Greater;
+      Append_Elmt (Label_Node, Label_List);
+      return Label_Node;
+   end P_Label;
+
+   -------------------------------
+   -- 5.1  Statement Identifier --
+   -------------------------------
+
+   --  Statement label is parsed by P_Label (5.1)
+
+   --  Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5)
+   --   or P_While_Statement (5.5)
+
+   --  Block label is parsed by P_Begin_Statement (5.6) or
+   --   P_Declare_Statement (5.6)
+
+   -------------------------------
+   -- 5.2  Assignment Statement --
+   -------------------------------
+
+   --  ASSIGNMENT_STATEMENT ::=
+   --    variable_NAME := EXPRESSION;
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
+      Assign_Node : Node_Id;
+
+   begin
+      Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
+      Set_Name (Assign_Node, LHS);
+      Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
+      TF_Semicolon;
+      return Assign_Node;
+   end P_Assignment_Statement;
+
+   -----------------------
+   -- 5.3  If Statement --
+   -----------------------
+
+   --  IF_STATEMENT ::=
+   --    if CONDITION then
+   --      SEQUENCE_OF_STATEMENTS
+   --    {elsif CONDITION then
+   --      SEQUENCE_OF_STATEMENTS}
+   --    [else
+   --      SEQUENCE_OF_STATEMENTS]
+   --    end if;
+
+   --  The caller has checked that the initial token is IF (or in the error
+   --  case of a mysterious THEN, the initial token may simply be THEN, in
+   --  which case, no condition (or IF) was scanned).
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_If_Statement return Node_Id is
+      If_Node    : Node_Id;
+      Elsif_Node : Node_Id;
+      Loc        : Source_Ptr;
+
+      procedure Add_Elsif_Part;
+      --  An internal procedure used to scan out a single ELSIF part. On entry
+      --  the ELSIF (or an ELSE which has been determined should be ELSIF) is
+      --  scanned out and is in Prev_Token.
+
+      procedure Check_If_Column;
+      --  An internal procedure used to check that THEN, ELSE ELSE, or ELSIF
+      --  appear in the right place if column checking is enabled (i.e. if
+      --  they are the first token on the line, then they must appear in
+      --  the same column as the opening IF).
+
+      procedure Check_Then_Column;
+      --  This procedure carries out the style checks for a THEN token
+      --  Note that the caller has set Loc to the Source_Ptr value for
+      --  the previous IF or ELSIF token. These checks apply only to a
+      --  THEN at the start of a line.
+
+      function Else_Should_Be_Elsif return Boolean;
+      --  An internal routine used to do a special error recovery check when
+      --  an ELSE is encountered. It determines if the ELSE should be treated
+      --  as an ELSIF. A positive decision (TRUE returned, is made if the ELSE
+      --  is followed by a sequence of tokens, starting on the same line as
+      --  the ELSE, which are not expression terminators, followed by a THEN.
+      --  On entry, the ELSE has been scanned out.
+
+      procedure Add_Elsif_Part is
+      begin
+         if No (Elsif_Parts (If_Node)) then
+            Set_Elsif_Parts (If_Node, New_List);
+         end if;
+
+         Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
+         Loc := Prev_Token_Ptr;
+         Set_Condition (Elsif_Node, P_Condition);
+         Check_Then_Column;
+         Then_Scan;
+         Set_Then_Statements
+           (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
+         Append (Elsif_Node, Elsif_Parts (If_Node));
+      end Add_Elsif_Part;
+
+      procedure Check_If_Column is
+      begin
+         if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
+           and then Start_Column /= Scope.Table (Scope.Last).Ecol
+         then
+            Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+            Error_Msg_SC ("(style) this token should be@");
+         end if;
+      end Check_If_Column;
+
+      procedure Check_Then_Column is
+      begin
+         if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
+            Check_If_Column;
+            if Style_Check then Style.Check_Then (Loc); end if;
+         end if;
+      end Check_Then_Column;
+
+      function Else_Should_Be_Elsif return Boolean is
+         Scan_State : Saved_Scan_State;
+
+      begin
+         if Token_Is_At_Start_Of_Line then
+            return False;
+
+         else
+            Save_Scan_State (Scan_State);
+
+            loop
+               if Token in Token_Class_Eterm then
+                  Restore_Scan_State (Scan_State);
+                  return False;
+               else
+                  Scan; -- past non-expression terminating token
+
+                  if Token = Tok_Then then
+                     Restore_Scan_State (Scan_State);
+                     return True;
+                  end if;
+               end if;
+            end loop;
+         end if;
+      end Else_Should_Be_Elsif;
+
+   --  Start of processing for P_If_Statement
+
+   begin
+      If_Node := New_Node (N_If_Statement, Token_Ptr);
+
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_If;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Labl := Error;
+      Scope.Table (Scope.Last).Node := If_Node;
+
+      if Token = Tok_If then
+         Loc := Token_Ptr;
+         Scan; -- past IF
+         Set_Condition (If_Node, P_Condition);
+
+         --  Deal with misuse of IF expression => used instead
+         --  of WHEN expression =>
+
+         if Token = Tok_Arrow then
+            Error_Msg_SC ("THEN expected");
+            Scan; -- past the arrow
+            Pop_Scope_Stack; -- remove unneeded entry
+            raise Error_Resync;
+         end if;
+
+         Check_Then_Column;
+
+      else
+         Error_Msg_SC ("no IF for this THEN");
+         Set_Condition (If_Node, Error);
+      end if;
+
+      Then_Scan;
+
+      Set_Then_Statements
+        (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
+
+      --  This loop scans out else and elsif parts
+
+      loop
+         if Token = Tok_Elsif then
+            Check_If_Column;
+
+            if Present (Else_Statements (If_Node)) then
+               Error_Msg_SP ("ELSIF cannot appear after ELSE");
+            end if;
+
+            Scan; -- past ELSIF
+            Add_Elsif_Part;
+
+         elsif Token = Tok_Else then
+            Check_If_Column;
+            Scan; -- past ELSE
+
+            if Else_Should_Be_Elsif then
+               Error_Msg_SP ("ELSE should be ELSIF");
+               Add_Elsif_Part;
+
+            else
+               --  Here we have an else that really is an else
+
+               if Present (Else_Statements (If_Node)) then
+                  Error_Msg_SP ("Only one ELSE part allowed");
+                  Append_List
+                    (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
+                     Else_Statements (If_Node));
+               else
+                  Set_Else_Statements
+                    (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
+               end if;
+            end if;
+
+         --  If anything other than ELSE or ELSIF, exit the loop. The token
+         --  had better be END (and in fact it had better be END IF), but
+         --  we will let End_Statements take care of checking that.
+
+         else
+            exit;
+         end if;
+      end loop;
+
+      End_Statements;
+      return If_Node;
+
+   end P_If_Statement;
+
+   --------------------
+   -- 5.3  Condition --
+   --------------------
+
+   --  CONDITION ::= boolean_EXPRESSION
+
+   function P_Condition return Node_Id is
+      Cond : Node_Id;
+
+   begin
+      Cond := P_Expression_No_Right_Paren;
+
+      --  It is never possible for := to follow a condition, so if we get
+      --  a := we assume it is a mistyped equality. Note that we do not try
+      --  to reconstruct the tree correctly in this case, but we do at least
+      --  give an accurate error message.
+
+      while Token = Tok_Colon_Equal loop
+         Error_Msg_SC (""":="" should be ""=""");
+         Scan; -- past junk :=
+         Discard_Junk_Node (P_Expression_No_Right_Paren);
+      end loop;
+
+      return Cond;
+   end P_Condition;
+
+   -------------------------
+   -- 5.4  Case Statement --
+   -------------------------
+
+   --  CASE_STATEMENT ::=
+   --    case EXPRESSION is
+   --      CASE_STATEMENT_ALTERNATIVE
+   --      {CASE_STATEMENT_ALTERNATIVE}
+   --    end case;
+
+   --  The caller has checked that the first token is CASE
+
+   --  Can raise Error_Resync
+
+   function P_Case_Statement return Node_Id is
+      Case_Node         : Node_Id;
+      Alternatives_List : List_Id;
+      First_When_Loc    : Source_Ptr;
+
+   begin
+      Case_Node := New_Node (N_Case_Statement, Token_Ptr);
+
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Case;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Labl := Error;
+      Scope.Table (Scope.Last).Node := Case_Node;
+
+      Scan; -- past CASE
+      Set_Expression (Case_Node, P_Expression_No_Right_Paren);
+      TF_Is;
+
+      --  Prepare to parse case statement alternatives
+
+      Alternatives_List := New_List;
+      P_Pragmas_Opt (Alternatives_List);
+      First_When_Loc := Token_Ptr;
+
+      --  Loop through case statement alternatives
+
+      loop
+         --  If we have a WHEN or OTHERS, then that's fine keep going. Note
+         --  that it is a semantic check to ensure the proper use of OTHERS
+
+         if Token = Tok_When or else Token = Tok_Others then
+            Append (P_Case_Statement_Alternative, Alternatives_List);
+
+         --  If we have an END, then probably we are at the end of the case
+         --  but we only exit if Check_End thinks the END was reasonable.
+
+         elsif Token = Tok_End then
+            exit when Check_End;
+
+         --  Here if token is other than WHEN, OTHERS or END. We definitely
+         --  have an error, but the question is whether or not to get out of
+         --  the case statement. We don't want to get out early, or we will
+         --  get a slew of junk error messages for subsequent when tokens.
+
+         --  If the token is not at the start of the line, or if it is indented
+         --  with respect to the current case statement, then the best guess is
+         --  that we are still supposed to be inside the case statement. We
+         --  complain about the missing WHEN, and discard the junk statements.
+
+         elsif not Token_Is_At_Start_Of_Line
+           or else Start_Column > Scope.Table (Scope.Last).Ecol
+         then
+            Error_Msg_BC ("WHEN (case statement alternative) expected");
+
+            --  Here is a possibility for infinite looping if we don't make
+            --  progress. So try to process statements, otherwise exit
+
+            declare
+               Error_Ptr : constant Source_Ptr := Scan_Ptr;
+            begin
+               Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
+               exit when Scan_Ptr = Error_Ptr and then Check_End;
+            end;
+
+         --  Here we have a junk token at the start of the line and it is
+         --  not indented. If Check_End thinks there is a missing END, then
+         --  we will get out of the case, otherwise we keep going.
+
+         else
+            exit when Check_End;
+         end if;
+      end loop;
+
+      --  Make sure we have at least one alternative
+
+      if No (First_Non_Pragma (Alternatives_List)) then
+         Error_Msg
+            ("WHEN expected, must have at least one alternative in case",
+             First_When_Loc);
+         return Error;
+
+      else
+         Set_Alternatives (Case_Node, Alternatives_List);
+         return Case_Node;
+      end if;
+   end P_Case_Statement;
+
+   -------------------------------------
+   -- 5.4  Case Statement Alternative --
+   -------------------------------------
+
+   --  CASE_STATEMENT_ALTERNATIVE ::=
+   --    when DISCRETE_CHOICE_LIST =>
+   --      SEQUENCE_OF_STATEMENTS
+
+   --  The caller has checked that the initial token is WHEN or OTHERS
+   --  Error recovery: can raise Error_Resync
+
+   function P_Case_Statement_Alternative return Node_Id is
+      Case_Alt_Node : Node_Id;
+
+   begin
+      if Style_Check then Style.Check_Indentation; end if;
+      Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
+      T_When; -- past WHEN (or give error in OTHERS case)
+      Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
+      TF_Arrow;
+      Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
+      return Case_Alt_Node;
+   end P_Case_Statement_Alternative;
+
+   -------------------------
+   -- 5.5  Loop Statement --
+   -------------------------
+
+   --  LOOP_STATEMENT ::=
+   --    [LOOP_STATEMENT_IDENTIFIER:]
+   --      [ITERATION_SCHEME] loop
+   --        SEQUENCE_OF_STATEMENTS
+   --      end loop [loop_IDENTIFIER];
+
+   --  ITERATION_SCHEME ::=
+   --    while CONDITION
+   --  | for LOOP_PARAMETER_SPECIFICATION
+
+   --  The parsing of loop statements is handled by one of three functions
+   --  P_Loop_Statement, P_For_Statement or P_While_Statement depending
+   --  on the initial keyword in the construct (excluding the identifier)
+
+   --  P_Loop_Statement
+
+   --  This function parses the case where no iteration scheme is present
+
+   --  The caller has checked that the initial token is LOOP. The parameter
+   --  is the node identifiers for the loop label if any (or is set to Empty
+   --  if there is no loop label).
+
+   --  Error recovery : cannot raise Error_Resync
+
+   function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
+      Loop_Node : Node_Id;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Labl := Loop_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Etyp := E_Loop;
+
+      Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
+      TF_Loop;
+
+      if No (Loop_Name) then
+         Set_Has_Created_Identifier (Loop_Node, True);
+         Set_Identifier (Loop_Node,
+           Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+      else
+         Set_Identifier (Loop_Node, Loop_Name);
+      end if;
+
+      Append_Elmt (Loop_Node, Label_List);
+
+      Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+      End_Statements (Loop_Node);
+      return Loop_Node;
+   end P_Loop_Statement;
+
+   --  P_For_Statement
+
+   --  This function parses a loop statement with a FOR iteration scheme
+
+   --  The caller has checked that the initial token is FOR. The parameter
+   --  is the node identifier for the block label if any (or is set to Empty
+   --  if there is no block label).
+
+   --  Note: the caller fills in the Identifier field if a label was present
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
+      Loop_Node        : Node_Id;
+      Iter_Scheme_Node : Node_Id;
+      Loop_For_Flag    : Boolean;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Labl := Loop_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Etyp := E_Loop;
+
+      Loop_For_Flag := (Prev_Token = Tok_Loop);
+      Scan; -- past FOR
+      Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
+      Set_Loop_Parameter_Specification
+         (Iter_Scheme_Node, P_Loop_Parameter_Specification);
+
+      --  The following is a special test so that a miswritten for loop such
+      --  as "loop for I in 1..10;" is handled nicely, without making an extra
+      --  entry in the scope stack. We don't bother to actually fix up the
+      --  tree in this case since it's not worth the effort. Instead we just
+      --  eat up the loop junk, leaving the entry for what now looks like an
+      --  unmodified loop intact.
+
+      if Loop_For_Flag and then Token = Tok_Semicolon then
+         Error_Msg_SC ("LOOP belongs here, not before FOR");
+         Pop_Scope_Stack;
+         return Error;
+
+      --  Normal case
+
+      else
+         Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
+         TF_Loop;
+         Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+         End_Statements (Loop_Node);
+         Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
+
+         if No (Loop_Name) then
+            Set_Has_Created_Identifier (Loop_Node, True);
+            Set_Identifier (Loop_Node,
+              Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+         else
+            Set_Identifier (Loop_Node, Loop_Name);
+         end if;
+
+         Append_Elmt (Loop_Node, Label_List);
+
+         return Loop_Node;
+      end if;
+
+   end P_For_Statement;
+
+   --  P_While_Statement
+
+   --  This procedure scans a loop statement with a WHILE iteration scheme
+
+   --  The caller has checked that the initial token is WHILE. The parameter
+   --  is the node identifier for the block label if any (or is set to Empty
+   --  if there is no block label).
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
+      Loop_Node        : Node_Id;
+      Iter_Scheme_Node : Node_Id;
+      Loop_While_Flag  : Boolean;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Labl := Loop_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Etyp := E_Loop;
+
+      Loop_While_Flag := (Prev_Token = Tok_Loop);
+      Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
+      Scan; -- past WHILE
+      Set_Condition (Iter_Scheme_Node, P_Condition);
+
+      --  The following is a special test so that a miswritten for loop such
+      --  as "loop while I > 10;" is handled nicely, without making an extra
+      --  entry in the scope stack. We don't bother to actually fix up the
+      --  tree in this case since it's not worth the effort. Instead we just
+      --  eat up the loop junk, leaving the entry for what now looks like an
+      --  unmodified loop intact.
+
+      if Loop_While_Flag and then Token = Tok_Semicolon then
+         Error_Msg_SC ("LOOP belongs here, not before WHILE");
+         Pop_Scope_Stack;
+         return Error;
+
+      --  Normal case
+
+      else
+         Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
+         TF_Loop;
+         Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+         End_Statements (Loop_Node);
+         Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
+
+         if No (Loop_Name) then
+            Set_Has_Created_Identifier (Loop_Node, True);
+            Set_Identifier (Loop_Node,
+              Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+         else
+            Set_Identifier (Loop_Node, Loop_Name);
+         end if;
+
+         Append_Elmt (Loop_Node, Label_List);
+
+         return Loop_Node;
+      end if;
+
+   end P_While_Statement;
+
+   ---------------------------------------
+   -- 5.5  Loop Parameter Specification --
+   ---------------------------------------
+
+   --  LOOP_PARAMETER_SPECIFICATION ::=
+   --    DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Loop_Parameter_Specification return Node_Id is
+      Loop_Param_Specification_Node : Node_Id;
+
+      ID_Node    : Node_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Loop_Param_Specification_Node :=
+        New_Node (N_Loop_Parameter_Specification, Token_Ptr);
+
+      Save_Scan_State (Scan_State);
+      ID_Node := P_Defining_Identifier;
+      Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
+
+      if Token = Tok_Left_Paren then
+         Error_Msg_SC ("subscripted loop parameter not allowed");
+         Restore_Scan_State (Scan_State);
+         Discard_Junk_Node (P_Name);
+
+      elsif Token = Tok_Dot then
+         Error_Msg_SC ("selected loop parameter not allowed");
+         Restore_Scan_State (Scan_State);
+         Discard_Junk_Node (P_Name);
+      end if;
+
+      T_In;
+
+      if Token = Tok_Reverse then
+         Scan; -- past REVERSE
+         Set_Reverse_Present (Loop_Param_Specification_Node, True);
+      end if;
+
+      Set_Discrete_Subtype_Definition
+        (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
+      return Loop_Param_Specification_Node;
+
+   exception
+      when Error_Resync =>
+         return Error;
+   end P_Loop_Parameter_Specification;
+
+   --------------------------
+   -- 5.6  Block Statement --
+   --------------------------
+
+   --  BLOCK_STATEMENT ::=
+   --    [block_STATEMENT_IDENTIFIER:]
+   --      [declare
+   --        DECLARATIVE_PART]
+   --      begin
+   --        HANDLED_SEQUENCE_OF_STATEMENTS
+   --      end [block_IDENTIFIER];
+
+   --  The parsing of block statements is handled by one of the two functions
+   --  P_Declare_Statement or P_Begin_Statement depending on whether or not
+   --  a declare section is present
+
+   --  P_Declare_Statement
+
+   --  This function parses a block statement with DECLARE present
+
+   --  The caller has checked that the initial token is DECLARE.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Declare_Statement
+     (Block_Name : Node_Id := Empty)
+      return       Node_Id
+   is
+      Block_Node : Node_Id;
+
+   begin
+      Block_Node := New_Node (N_Block_Statement, Token_Ptr);
+
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Lreq := Present (Block_Name);
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Labl := Block_Name;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+
+      Scan; -- past DECLARE
+
+      if No (Block_Name) then
+         Set_Has_Created_Identifier (Block_Node, True);
+         Set_Identifier (Block_Node,
+           Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+      else
+         Set_Identifier (Block_Node, Block_Name);
+      end if;
+
+      Append_Elmt (Block_Node, Label_List);
+      Parse_Decls_Begin_End (Block_Node);
+      return Block_Node;
+   end P_Declare_Statement;
+
+   --  P_Begin_Statement
+
+   --  This function parses a block statement with no DECLARE present
+
+   --  The caller has checked that the initial token is BEGIN
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Begin_Statement
+     (Block_Name : Node_Id := Empty)
+      return       Node_Id
+   is
+      Block_Node : Node_Id;
+
+   begin
+      Block_Node := New_Node (N_Block_Statement, Token_Ptr);
+
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Lreq := Present (Block_Name);
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Labl := Block_Name;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+
+      if No (Block_Name) then
+         Set_Has_Created_Identifier (Block_Node, True);
+         Set_Identifier (Block_Node,
+           Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+      else
+         Set_Identifier (Block_Node, Block_Name);
+      end if;
+
+      Append_Elmt (Block_Node, Label_List);
+
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scan; -- past BEGIN
+      Set_Handled_Statement_Sequence
+        (Block_Node, P_Handled_Sequence_Of_Statements);
+      End_Statements (Handled_Statement_Sequence (Block_Node));
+      return Block_Node;
+   end P_Begin_Statement;
+
+   -------------------------
+   -- 5.7  Exit Statement --
+   -------------------------
+
+   --  EXIT_STATEMENT ::=
+   --    exit [loop_NAME] [when CONDITION];
+
+   --  The caller has checked that the initial token is EXIT
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Exit_Statement return Node_Id is
+      Exit_Node : Node_Id;
+
+      function Missing_Semicolon_On_Exit return Boolean;
+      --  This function deals with the following specialized situation
+      --
+      --    when 'x' =>
+      --       exit [identifier]
+      --    when 'y' =>
+      --
+      --  This looks like a messed up EXIT WHEN, when in fact the problem
+      --  is a missing semicolon. It is called with Token pointing to the
+      --  WHEN token, and returns True if a semicolon is missing before
+      --  the WHEN as in the above example.
+
+      function Missing_Semicolon_On_Exit return Boolean is
+         State : Saved_Scan_State;
+
+      begin
+         if not Token_Is_At_Start_Of_Line then
+            return False;
+
+         elsif Scope.Table (Scope.Last).Etyp /= E_Case then
+            return False;
+
+         else
+            Save_Scan_State (State);
+            Scan; -- past WHEN
+            Scan; -- past token after WHEN
+
+            if Token = Tok_Arrow then
+               Restore_Scan_State (State);
+               return True;
+            else
+               Restore_Scan_State (State);
+               return False;
+            end if;
+         end if;
+      end Missing_Semicolon_On_Exit;
+
+   --  Start of processing for P_Exit_Statement
+
+   begin
+      Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
+      Scan; -- past EXIT
+
+      if Token = Tok_Identifier then
+         Set_Name (Exit_Node, P_Qualified_Simple_Name);
+
+      elsif Style_Check then
+         --  This EXIT has no name, so check that
+         --  the innermost loop is unnamed too.
+
+         Check_No_Exit_Name :
+         for J in reverse 1 .. Scope.Last loop
+            if Scope.Table (J).Etyp = E_Loop then
+               if Present (Scope.Table (J).Labl) then
+
+                  --  Innermost loop in fact had a name, style check fails
+
+                  Style.No_Exit_Name (Scope.Table (J).Labl);
+               end if;
+
+               exit Check_No_Exit_Name;
+            end if;
+         end loop Check_No_Exit_Name;
+      end if;
+
+      if Token = Tok_When and then not Missing_Semicolon_On_Exit then
+         Scan; -- past WHEN
+         Set_Condition (Exit_Node, P_Condition);
+
+      --  Allow IF instead of WHEN, giving error message
+
+      elsif Token = Tok_If then
+         T_When;
+         Scan; -- past IF used in place of WHEN
+         Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
+      end if;
+
+      TF_Semicolon;
+      return Exit_Node;
+   end P_Exit_Statement;
+
+   -------------------------
+   -- 5.8  Goto Statement --
+   -------------------------
+
+   --  GOTO_STATEMENT ::= goto label_NAME;
+
+   --  The caller has checked that the initial token is GOTO  (or TO in the
+   --  error case where GO and TO were incorrectly separated).
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Goto_Statement return Node_Id is
+      Goto_Node : Node_Id;
+
+   begin
+      Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
+      Scan; -- past GOTO (or TO)
+      Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
+      No_Constraint;
+      TF_Semicolon;
+      return Goto_Node;
+   end P_Goto_Statement;
+
+   ---------------------------
+   -- Parse_Decls_Begin_End --
+   ---------------------------
+
+   --  This function parses the construct:
+
+   --      DECLARATIVE_PART
+   --    begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS
+   --    end [NAME];
+
+   --  The caller has built the scope stack entry, and created the node to
+   --  whose Declarations and Handled_Statement_Sequence fields are to be
+   --  set. On return these fields are filled in (except in the case of a
+   --  task body, where the handled statement sequence is optional, and may
+   --  thus be Empty), and the scan is positioned past the End sequence.
+
+   --  If the BEGIN is missing, then the parent node is used to help construct
+   --  an appropriate missing BEGIN message. Possibilities for the parent are:
+
+   --    N_Block_Statement     declare block
+   --    N_Entry_Body          entry body
+   --    N_Package_Body        package body (begin part optional)
+   --    N_Subprogram_Body     procedure or function body
+   --    N_Task_Body           task body
+
+   --  Note: in the case of a block statement, there is definitely a DECLARE
+   --  present (because a Begin statement without a DECLARE is handled by the
+   --  P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   procedure Parse_Decls_Begin_End (Parent : Node_Id) is
+      Body_Decl    : Node_Id;
+      Body_Sloc    : Source_Ptr;
+      Decls        : List_Id;
+      Decl         : Node_Id;
+      Parent_Nkind : Node_Kind;
+      Spec_Node    : Node_Id;
+      HSS          : Node_Id;
+
+      procedure Missing_Begin (Msg : String);
+      --  Called to post a missing begin message. In the normal case this is
+      --  posted at the start of the current token. A special case arises when
+      --  P_Declarative_Items has previously found a missing begin, in which
+      --  case we replace the original error message.
+
+      procedure Set_Null_HSS (Parent : Node_Id);
+      --  Construct an empty handled statement sequence and install in Parent
+      --  Leaves HSS set to reference the newly constructed statement sequence.
+
+      -------------------
+      -- Missing_Begin --
+      -------------------
+
+      procedure Missing_Begin (Msg : String) is
+      begin
+         if Missing_Begin_Msg = No_Error_Msg then
+            Error_Msg_BC (Msg);
+         else
+            Change_Error_Text (Missing_Begin_Msg, Msg);
+
+            --  Purge any messages issued after than, since a missing begin
+            --  can cause a lot of havoc, and it is better not to dump these
+            --  cascaded messages on the user.
+
+            Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
+         end if;
+      end Missing_Begin;
+
+      ------------------
+      -- Set_Null_HSS --
+      ------------------
+
+      procedure Set_Null_HSS (Parent : Node_Id) is
+         Null_Stm : Node_Id;
+
+      begin
+         Null_Stm :=
+           Make_Null_Statement (Token_Ptr);
+         Set_Comes_From_Source (Null_Stm, False);
+
+         HSS :=
+           Make_Handled_Sequence_Of_Statements (Token_Ptr,
+             Statements => New_List (Null_Stm));
+         Set_Comes_From_Source (HSS, False);
+
+         Set_Handled_Statement_Sequence (Parent, HSS);
+      end Set_Null_HSS;
+
+   --  Start of processing for Parse_Decls_Begin_End
+
+   begin
+      Decls := P_Declarative_Part;
+
+      --  Check for misplacement of later vs basic declarations in Ada 83
+
+      if Ada_83 then
+         Decl := First (Decls);
+
+         --  Loop through sequence of basic declarative items
+
+         Outer : while Present (Decl) loop
+            if Nkind (Decl) /= N_Subprogram_Body
+              and then Nkind (Decl) /= N_Package_Body
+              and then Nkind (Decl) /= N_Task_Body
+              and then Nkind (Decl) not in  N_Body_Stub
+            then
+               Next (Decl);
+
+            --  Once a body is encountered, we only allow later declarative
+            --  items. The inner loop checks the rest of the list.
+
+            else
+               Body_Sloc := Sloc (Decl);
+
+               Inner : while Present (Decl) loop
+                  if Nkind (Decl) not in N_Later_Decl_Item
+                    and then Nkind (Decl) /= N_Pragma
+                  then
+                     if Ada_83 then
+                        Error_Msg_Sloc := Body_Sloc;
+                        Error_Msg_N
+                          ("(Ada 83) decl cannot appear after body#", Decl);
+                     end if;
+                  end if;
+
+                  Next (Decl);
+               end loop Inner;
+            end if;
+         end loop Outer;
+      end if;
+
+      --  Here is where we deal with the case of IS used instead of semicolon.
+      --  Specifically, if the last declaration in the declarative part is a
+      --  subprogram body still marked as having a bad IS, then this is where
+      --  we decide that the IS should really have been a semicolon and that
+      --  the body should have been a declaration. Note that if the bad IS
+      --  had turned out to be OK (i.e. a decent begin/end was found for it),
+      --  then the Bad_Is_Detected flag would have been reset by now.
+
+      Body_Decl := Last (Decls);
+
+      if Present (Body_Decl)
+        and then Nkind (Body_Decl) = N_Subprogram_Body
+        and then Bad_Is_Detected (Body_Decl)
+      then
+         --  OK, we have the case of a bad IS, so we need to fix up the tree.
+         --  What we have now is a subprogram body with attached declarations
+         --  and a possible statement sequence.
+
+         --  First step is to take the declarations that were part of the bogus
+         --  subprogram body and append them to the outer declaration chain.
+         --  In other words we append them past the body (which we will later
+         --  convert into a declaration).
+
+         Append_List (Declarations (Body_Decl), Decls);
+
+         --  Now take the handled statement sequence of the bogus body and
+         --  set it as the statement sequence for the outer construct. Note
+         --  that it may be empty (we specially allowed a missing BEGIN for
+         --  a subprogram body marked as having a bad IS -- see below).
+
+         Set_Handled_Statement_Sequence (Parent,
+           Handled_Statement_Sequence (Body_Decl));
+
+         --  Next step is to convert the old body node to a declaration node
+
+         Spec_Node := Specification (Body_Decl);
+         Change_Node (Body_Decl, N_Subprogram_Declaration);
+         Set_Specification (Body_Decl, Spec_Node);
+
+         --  Final step is to put the declarations for the parent where
+         --  they belong, and then fall through the IF to scan out the
+         --  END statements.
+
+         Set_Declarations (Parent, Decls);
+
+      --  This is the normal case (i.e. any case except the bad IS case)
+      --  If we have a BEGIN, then scan out the sequence of statements, and
+      --  also reset the expected column for the END to match the BEGIN.
+
+      else
+         Set_Declarations (Parent, Decls);
+
+         if Token = Tok_Begin then
+            if Style_Check then Style.Check_Indentation; end if;
+
+            Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+
+            if Style.RM_Column_Check
+              and then Token_Is_At_Start_Of_Line
+              and then Start_Column /= Error_Msg_Col
+            then
+               Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
+
+            else
+               Scope.Table (Scope.Last).Ecol := Start_Column;
+            end if;
+
+            Scope.Table (Scope.Last).Sloc := Token_Ptr;
+            Scan; -- past BEGIN
+            Set_Handled_Statement_Sequence (Parent,
+              P_Handled_Sequence_Of_Statements);
+
+         --  No BEGIN present
+
+         else
+            Parent_Nkind := Nkind (Parent);
+
+            --  A special check for the missing IS case. If we have a
+            --  subprogram body that was marked as having a suspicious
+            --  IS, and the current token is END, then we simply confirm
+            --  the suspicion, and do not require a BEGIN to be present
+
+            if Parent_Nkind = N_Subprogram_Body
+              and then Token  = Tok_End
+              and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
+            then
+               Scope.Table (Scope.Last).Etyp := E_Bad_Is;
+
+            --  Otherwise BEGIN is not required for a package body, so we
+            --  don't mind if it is missing, but we do construct a dummy
+            --  one (so that we have somewhere to set End_Label).
+
+            --  However if we have something other than a BEGIN which
+            --  looks like it might be statements, then we signal a missing
+            --  BEGIN for these cases as well. We define "something which
+            --  looks like it might be statements" as a token other than
+            --  END, EOF, or a token which starts declarations.
+
+            elsif Parent_Nkind = N_Package_Body
+              and then (Token = Tok_End
+                          or else Token = Tok_EOF
+                          or else Token in Token_Class_Declk)
+            then
+               Set_Null_HSS (Parent);
+
+            --  These are cases in which a BEGIN is required and not present
+
+            else
+               Set_Null_HSS (Parent);
+
+               --  Prepare to issue error message
+
+               Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
+               Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+
+               --  Now issue appropriate message
+
+               if Parent_Nkind = N_Block_Statement then
+                  Missing_Begin ("missing BEGIN for DECLARE#!");
+
+               elsif Parent_Nkind = N_Entry_Body then
+                  Missing_Begin ("missing BEGIN for ENTRY#!");
+
+               elsif Parent_Nkind = N_Subprogram_Body then
+                  if Nkind (Specification (Parent))
+                               = N_Function_Specification
+                  then
+                     Missing_Begin ("missing BEGIN for function&#!");
+                  else
+                     Missing_Begin ("missing BEGIN for procedure&#!");
+                  end if;
+
+               --  The case for package body arises only when
+               --  we have possible statement junk present.
+
+               elsif Parent_Nkind = N_Package_Body then
+                  Missing_Begin ("missing BEGIN for package body&#!");
+
+               else
+                  pragma Assert (Parent_Nkind = N_Task_Body);
+                  Missing_Begin ("missing BEGIN for task body&#!");
+               end if;
+
+               --  Here we pick up the statements after the BEGIN that
+               --  should have been present but was not. We don't insist
+               --  on statements being present if P_Declarative_Part had
+               --  already found a missing BEGIN, since it might have
+               --  swallowed a lone statement into the declarative part.
+
+               if Missing_Begin_Msg /= No_Error_Msg
+                 and then Token = Tok_End
+               then
+                  null;
+               else
+                  Set_Handled_Statement_Sequence (Parent,
+                    P_Handled_Sequence_Of_Statements);
+               end if;
+            end if;
+         end if;
+      end if;
+
+      --  Here with declarations and handled statement sequence scanned
+
+      if Present (Handled_Statement_Sequence (Parent)) then
+         End_Statements (Handled_Statement_Sequence (Parent));
+      else
+         End_Statements;
+      end if;
+
+      --  We know that End_Statements removed an entry from the scope stack
+      --  (because it is required to do so under all circumstances). We can
+      --  therefore reference the entry it removed one past the stack top.
+      --  What we are interested in is whether it was a case of a bad IS.
+
+      if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
+         Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
+         Set_Bad_Is_Detected (Parent, True);
+      end if;
+
+   end Parse_Decls_Begin_End;
+
+   -------------------------
+   -- Set_Loop_Block_Name --
+   -------------------------
+
+   function Set_Loop_Block_Name (L : Character) return Name_Id is
+   begin
+      Name_Buffer (1) := L;
+      Name_Buffer (2) := '_';
+      Name_Len := 2;
+      Loop_Block_Count := Loop_Block_Count + 1;
+      Add_Nat_To_Name_Buffer (Loop_Block_Count);
+      return Name_Find;
+   end Set_Loop_Block_Name;
+
+   ---------------
+   -- Then_Scan --
+   ---------------
+
+   procedure Then_Scan is
+   begin
+      TF_Then;
+
+      while Token = Tok_Then loop
+         Error_Msg_SC ("redundant THEN");
+         TF_Then;
+      end loop;
+
+      if Token = Tok_And or else Token = Tok_Or then
+         Error_Msg_SC ("unexpected logical operator");
+         Scan;
+
+         if (Prev_Token = Tok_And and then Token = Tok_Then)
+              or else
+            (Prev_Token = Tok_Or  and then Token = Tok_Else)
+         then
+            Scan;
+         end if;
+
+         Discard_Junk_Node (P_Expression);
+      end if;
+
+      if Token = Tok_Then then
+         Scan;
+      end if;
+   end Then_Scan;
+
+end Ch5;
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
new file mode 100644
index 0000000..d5d1d3d
--- /dev/null
+++ b/gcc/ada/par-ch6.adb
@@ -0,0 +1,1165 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 6                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.81 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+with Sinfo.CN; use Sinfo.CN;
+
+separate (Par)
+package body Ch6 is
+
+   --  Local subprograms, used only in this chapter
+
+   function P_Defining_Designator        return Node_Id;
+   function P_Defining_Operator_Symbol   return Node_Id;
+
+   procedure Check_Junk_Semicolon_Before_Return;
+   --  Check for common error of junk semicolon before RETURN keyword of
+   --  function specification. If present, skip over it with appropriate
+   --  error message, leaving Scan_Ptr pointing to the RETURN after. This
+   --  routine also deals with a possibly misspelled version of Return.
+
+   ----------------------------------------
+   -- Check_Junk_Semicolon_Before_Return --
+   ----------------------------------------
+
+   procedure Check_Junk_Semicolon_Before_Return is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Semicolon then
+         Save_Scan_State (Scan_State);
+         Scan; -- past the semicolon
+
+         if Token = Tok_Return then
+            Restore_Scan_State (Scan_State);
+            Error_Msg_SC ("Unexpected semicolon ignored");
+            Scan; -- rescan past junk semicolon
+
+         else
+            Restore_Scan_State (Scan_State);
+         end if;
+
+      elsif Bad_Spelling_Of (Tok_Return) then
+         null;
+      end if;
+   end Check_Junk_Semicolon_Before_Return;
+
+   -----------------------------------------------------
+   -- 6.1  Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
+   -----------------------------------------------------
+
+   --  This routine scans out a subprogram declaration, subprogram body,
+   --  subprogram renaming declaration or subprogram generic instantiation.
+
+   --  SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
+
+   --  ABSTRACT_SUBPROGRAM_DECLARATION ::=
+   --    SUBPROGRAM_SPECIFICATION is abstract;
+
+   --  SUBPROGRAM_SPECIFICATION ::=
+   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
+   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
+
+   --  PARAMETER_PROFILE ::= [FORMAL_PART]
+
+   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
+
+   --  SUBPROGRAM_BODY ::=
+   --    SUBPROGRAM_SPECIFICATION is
+   --      DECLARATIVE_PART
+   --    begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS
+   --    end [DESIGNATOR];
+
+   --  SUBPROGRAM_RENAMING_DECLARATION ::=
+   --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
+
+   --  SUBPROGRAM_BODY_STUB ::=
+   --    SUBPROGRAM_SPECIFICATION is separate;
+
+   --  GENERIC_INSTANTIATION ::=
+   --    procedure DEFINING_PROGRAM_UNIT_NAME is
+   --      new generic_procedure_NAME [GENERIC_ACTUAL_PART];
+   --  | function DEFINING_DESIGNATOR is
+   --      new generic_function_NAME [GENERIC_ACTUAL_PART];
+
+   --  The value in Pf_Flags indicates which of these possible declarations
+   --  is acceptable to the caller:
+
+   --    Pf_Flags.Decl                 Set if declaration OK
+   --    Pf_Flags.Gins                 Set if generic instantiation OK
+   --    Pf_Flags.Pbod                 Set if proper body OK
+   --    Pf_Flags.Rnam                 Set if renaming declaration OK
+   --    Pf_Flags.Stub                 Set if body stub OK
+
+   --  If an inappropriate form is encountered, it is scanned out but an
+   --  error message indicating that it is appearing in an inappropriate
+   --  context is issued. The only possible values for Pf_Flags are those
+   --  defined as constants in the Par package.
+
+   --  The caller has checked that the initial token is FUNCTION or PROCEDURE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
+      Specification_Node : Node_Id;
+      Name_Node   : Node_Id;
+      Fpart_List  : List_Id;
+      Fpart_Sloc  : Source_Ptr;
+      Return_Node : Node_Id;
+      Inst_Node   : Node_Id;
+      Body_Node   : Node_Id;
+      Decl_Node   : Node_Id;
+      Rename_Node : Node_Id;
+      Absdec_Node : Node_Id;
+      Stub_Node   : Node_Id;
+      Fproc_Sloc  : Source_Ptr;
+      Func        : Boolean;
+      Scan_State  : Saved_Scan_State;
+
+   begin
+      --  Set up scope stack entry. Note that the Labl field will be set later
+
+      SIS_Entry_Active := False;
+      SIS_Missing_Semicolon_Message := No_Error_Msg;
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Lreq := False;
+
+      Func := (Token = Tok_Function);
+      Fproc_Sloc := Token_Ptr;
+      Scan; -- past FUNCTION or PROCEDURE
+      Ignore (Tok_Type);
+      Ignore (Tok_Body);
+
+      if Func then
+         Name_Node := P_Defining_Designator;
+
+         if Nkind (Name_Node) = N_Defining_Operator_Symbol
+           and then Scope.Last = 1
+         then
+            Error_Msg_SP ("operator symbol not allowed at library level");
+            Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node));
+
+            --  Set name from file name, we need some junk name, and that's
+            --  as good as anything. This is only approximate, since we do
+            --  not do anything with non-standard name translations.
+
+            Get_Name_String (File_Name (Current_Source_File));
+
+            for J in 1 .. Name_Len loop
+               if Name_Buffer (J) = '.' then
+                  Name_Len := J - 1;
+                  exit;
+               end if;
+            end loop;
+
+            Set_Chars (Name_Node, Name_Find);
+            Set_Error_Posted (Name_Node);
+         end if;
+
+      else
+         Name_Node := P_Defining_Program_Unit_Name;
+      end if;
+
+      Scope.Table (Scope.Last).Labl := Name_Node;
+
+      if Token = Tok_Colon then
+         Error_Msg_SC ("redundant colon ignored");
+         Scan; -- past colon
+      end if;
+
+      --  Deal with generic instantiation, the one case in which we do not
+      --  have a subprogram specification as part of whatever we are parsing
+
+      if Token = Tok_Is then
+         Save_Scan_State (Scan_State); -- at the IS
+         T_Is; -- checks for redundant IS's
+
+         if Token = Tok_New then
+            if not Pf_Flags.Gins then
+               Error_Msg_SC ("generic instantation not allowed here!");
+            end if;
+
+            Scan; -- past NEW
+
+            if Func then
+               Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
+               Set_Name (Inst_Node, P_Function_Name);
+            else
+               Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
+               Set_Name (Inst_Node, P_Qualified_Simple_Name);
+            end if;
+
+            Set_Defining_Unit_Name (Inst_Node, Name_Node);
+            Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
+            TF_Semicolon;
+            Pop_Scope_Stack; -- Don't need scope stack entry in this case
+            return Inst_Node;
+
+         else
+            Restore_Scan_State (Scan_State); -- to the IS
+         end if;
+      end if;
+
+      --  If not a generic instantiation, then we definitely have a subprogram
+      --  specification (all possibilities at this stage include one here)
+
+      Fpart_Sloc := Token_Ptr;
+
+      Check_Misspelling_Of (Tok_Return);
+
+      --  Scan formal part. First a special error check. If we have an
+      --  identifier here, then we have a definite error. If this identifier
+      --  is on the same line as the designator, then we assume it is the
+      --  first formal after a missing left parenthesis
+
+      if Token = Tok_Identifier
+        and then not Token_Is_At_Start_Of_Line
+      then
+            T_Left_Paren; -- to generate message
+            Fpart_List := P_Formal_Part;
+
+      --  Otherwise scan out an optional formal part in the usual manner
+
+      else
+         Fpart_List := P_Parameter_Profile;
+      end if;
+
+      --  We treat what we have as a function specification if FUNCTION was
+      --  used, or if a RETURN is present. This gives better error recovery
+      --  since later RETURN statements will be valid in either case.
+
+      Check_Junk_Semicolon_Before_Return;
+      Return_Node := Error;
+
+      if Token = Tok_Return then
+         if not Func then
+            Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc);
+            Func := True;
+         end if;
+
+         Scan; -- past RETURN
+         Return_Node := P_Subtype_Mark;
+         No_Constraint;
+
+      else
+         if Func then
+            Ignore (Tok_Right_Paren);
+            TF_Return;
+         end if;
+      end if;
+
+      if Func then
+         Specification_Node :=
+           New_Node (N_Function_Specification, Fproc_Sloc);
+         Set_Subtype_Mark (Specification_Node, Return_Node);
+
+      else
+         Specification_Node :=
+           New_Node (N_Procedure_Specification, Fproc_Sloc);
+      end if;
+
+      Set_Defining_Unit_Name (Specification_Node, Name_Node);
+      Set_Parameter_Specifications (Specification_Node, Fpart_List);
+
+      --  Error check: barriers not allowed on protected functions/procedures
+
+      if Token = Tok_When then
+         if Func then
+            Error_Msg_SC ("barrier not allowed on function, only on entry");
+         else
+            Error_Msg_SC ("barrier not allowed on procedure, only on entry");
+         end if;
+
+         Scan; -- past WHEN
+         Discard_Junk_Node (P_Expression);
+      end if;
+
+      --  Deal with case of semicolon ending a subprogram declaration
+
+      if Token = Tok_Semicolon then
+         if not Pf_Flags.Decl then
+            T_Is;
+         end if;
+
+         Scan; -- past semicolon
+
+         --  If semicolon is immediately followed by IS, then ignore the
+         --  semicolon, and go process the body.
+
+         if Token = Tok_Is then
+            Error_Msg_SP ("unexpected semicolon ignored");
+            T_Is; -- ignroe redundant IS's
+            goto Subprogram_Body;
+
+         --  If BEGIN follows in an appropriate column, we immediately
+         --  commence the error action of assuming that the previous
+         --  subprogram declaration should have been a subprogram body,
+         --  i.e. that the terminating semicolon should have been IS.
+
+         elsif Token = Tok_Begin
+            and then Start_Column >= Scope.Table (Scope.Last).Ecol
+         then
+            Error_Msg_SP (""";"" should be IS!");
+            goto Subprogram_Body;
+
+         else
+            goto Subprogram_Declaration;
+         end if;
+
+      --  Case of not followed by semicolon
+
+      else
+         --  Subprogram renaming declaration case
+
+         Check_Misspelling_Of (Tok_Renames);
+
+         if Token = Tok_Renames then
+            if not Pf_Flags.Rnam then
+               Error_Msg_SC ("renaming declaration not allowed here!");
+            end if;
+
+            Rename_Node :=
+              New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr);
+            Scan; -- past RENAMES
+            Set_Name (Rename_Node, P_Name);
+            Set_Specification (Rename_Node, Specification_Node);
+            TF_Semicolon;
+            Pop_Scope_Stack;
+            return Rename_Node;
+
+         --  Case of IS following subprogram specification
+
+         elsif Token = Tok_Is then
+            T_Is; -- ignore redundant Is's
+
+            if Token_Name = Name_Abstract then
+               Check_95_Keyword (Tok_Abstract, Tok_Semicolon);
+            end if;
+
+            --  Deal nicely with (now obsolete) use of <> in place of abstract
+
+            if Token = Tok_Box then
+               Error_Msg_SC ("ABSTRACT expected");
+               Token := Tok_Abstract;
+            end if;
+
+            --  Abstract subprogram declaration case
+
+            if Token = Tok_Abstract then
+               Absdec_Node :=
+                 New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr);
+               Set_Specification (Absdec_Node, Specification_Node);
+               Pop_Scope_Stack; -- discard unneeded entry
+               Scan; -- past ABSTRACT
+               TF_Semicolon;
+               return Absdec_Node;
+
+            --  Check for IS NEW with Formal_Part present and handle nicely
+
+            elsif Token = Tok_New then
+               Error_Msg
+                 ("formal part not allowed in instantiation", Fpart_Sloc);
+               Scan; -- past NEW
+
+               if Func then
+                  Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
+               else
+                  Inst_Node :=
+                    New_Node (N_Procedure_Instantiation, Fproc_Sloc);
+               end if;
+
+               Set_Defining_Unit_Name (Inst_Node, Name_Node);
+               Set_Name (Inst_Node, P_Name);
+               Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
+               TF_Semicolon;
+               Pop_Scope_Stack; -- Don't need scope stack entry in this case
+               return Inst_Node;
+
+            else
+               goto Subprogram_Body;
+            end if;
+
+         --  Here we have a missing IS or missing semicolon, we always guess
+         --  a missing semicolon, since we are pretty good at fixing up a
+         --  semicolon which should really be an IS
+
+         else
+            Error_Msg_AP ("missing "";""");
+            SIS_Missing_Semicolon_Message := Get_Msg_Id;
+            goto Subprogram_Declaration;
+         end if;
+      end if;
+
+      --  Processing for subprogram body
+
+      <<Subprogram_Body>>
+         if not Pf_Flags.Pbod then
+            Error_Msg_SP ("subprogram body not allowed here!");
+         end if;
+
+         --  Subprogram body stub case
+
+         if Separate_Present then
+            if not Pf_Flags.Stub then
+               Error_Msg_SC ("body stub not allowed here!");
+            end if;
+
+            if Nkind (Name_Node) = N_Defining_Operator_Symbol then
+               Error_Msg
+                 ("operator symbol cannot be used as subunit name",
+                  Sloc (Name_Node));
+            end if;
+
+            Stub_Node :=
+              New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
+            Set_Specification (Stub_Node, Specification_Node);
+            Scan; -- past SEPARATE
+            Pop_Scope_Stack;
+            TF_Semicolon;
+            return Stub_Node;
+
+         --  Subprogram body case
+
+         else
+            --  Here is the test for a suspicious IS (i.e. one that looks
+            --  like it might more properly be a semicolon). See separate
+            --  section discussing use of IS instead of semicolon in
+            --  package Parse.
+
+            if (Token in Token_Class_Declk
+                  or else
+                Token = Tok_Identifier)
+              and then Start_Column <= Scope.Table (Scope.Last).Ecol
+              and then Scope.Last /= 1
+            then
+               Scope.Table (Scope.Last).Etyp := E_Suspicious_Is;
+               Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr;
+            end if;
+
+            Body_Node :=
+              New_Node (N_Subprogram_Body, Sloc (Specification_Node));
+            Set_Specification (Body_Node, Specification_Node);
+            Parse_Decls_Begin_End (Body_Node);
+            return Body_Node;
+         end if;
+
+      --  Processing for subprogram declaration
+
+      <<Subprogram_Declaration>>
+         Decl_Node :=
+           New_Node (N_Subprogram_Declaration, Sloc (Specification_Node));
+         Set_Specification (Decl_Node, Specification_Node);
+
+         --  If this is a context in which a subprogram body is permitted,
+         --  set active SIS entry in case (see section titled "Handling
+         --  Semicolon Used in Place of IS" in body of Parser package)
+         --  Note that SIS_Missing_Semicolon_Message is already set properly.
+
+         if Pf_Flags.Pbod then
+            SIS_Labl := Scope.Table (Scope.Last).Labl;
+            SIS_Sloc := Scope.Table (Scope.Last).Sloc;
+            SIS_Ecol := Scope.Table (Scope.Last).Ecol;
+            SIS_Declaration_Node := Decl_Node;
+            SIS_Semicolon_Sloc := Prev_Token_Ptr;
+            SIS_Entry_Active := True;
+         end if;
+
+         Pop_Scope_Stack;
+         return Decl_Node;
+
+   end P_Subprogram;
+
+   ---------------------------------
+   -- 6.1  Subprogram Declaration --
+   ---------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   ------------------------------------------
+   -- 6.1  Abstract Subprogram Declaration --
+   ------------------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -----------------------------------
+   -- 6.1  Subprogram Specification --
+   -----------------------------------
+
+   --  SUBPROGRAM_SPECIFICATION ::=
+   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
+   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
+
+   --  PARAMETER_PROFILE ::= [FORMAL_PART]
+
+   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
+
+   --  Subprogram specifications that appear in subprogram declarations
+   --  are parsed by P_Subprogram (6.1). This routine is used in other
+   --  contexts where subprogram specifications occur.
+
+   --  Note: this routine does not affect the scope stack in any way
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Subprogram_Specification return Node_Id is
+      Specification_Node : Node_Id;
+
+   begin
+      if Token = Tok_Function then
+         Specification_Node := New_Node (N_Function_Specification, Token_Ptr);
+         Scan; -- past FUNCTION
+         Ignore (Tok_Body);
+         Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator);
+         Set_Parameter_Specifications
+           (Specification_Node, P_Parameter_Profile);
+         Check_Junk_Semicolon_Before_Return;
+         TF_Return;
+         Set_Subtype_Mark (Specification_Node, P_Subtype_Mark);
+         No_Constraint;
+         return Specification_Node;
+
+      elsif Token = Tok_Procedure then
+         Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr);
+         Scan; -- past PROCEDURE
+         Ignore (Tok_Body);
+         Set_Defining_Unit_Name
+           (Specification_Node, P_Defining_Program_Unit_Name);
+         Set_Parameter_Specifications
+           (Specification_Node, P_Parameter_Profile);
+         return Specification_Node;
+
+      else
+         Error_Msg_SC ("subprogram specification expected");
+         raise Error_Resync;
+      end if;
+   end P_Subprogram_Specification;
+
+   ---------------------
+   -- 6.1  Designator --
+   ---------------------
+
+   --  DESIGNATOR ::=
+   --    [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
+
+   --  The caller has checked that the initial token is an identifier,
+   --  operator symbol, or string literal. Note that we don't bother to
+   --  do much error diagnosis in this routine, since it is only used for
+   --  the label on END lines, and the routines in package Par.Endh will
+   --  check that the label is appropriate.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Designator return Node_Id is
+      Ident_Node  : Node_Id;
+      Name_Node   : Node_Id;
+      Prefix_Node : Node_Id;
+
+      function Real_Dot return Boolean;
+      --  Tests if a current token is an interesting period, i.e. is followed
+      --  by an identifier or operator symbol or string literal. If not, it is
+      --  probably just incorrect punctuation to be caught by our caller. Note
+      --  that the case of an operator symbol or string literal is also an
+      --  error, but that is an error that we catch here. If the result is
+      --  True, a real dot has been scanned and we are positioned past it,
+      --  if the result is False, the scan position is unchanged.
+
+      function Real_Dot return Boolean is
+         Scan_State  : Saved_Scan_State;
+
+      begin
+         if Token /= Tok_Dot then
+            return False;
+
+         else
+            Save_Scan_State (Scan_State);
+            Scan; -- past dot
+
+            if Token = Tok_Identifier
+              or else Token = Tok_Operator_Symbol
+              or else Token = Tok_String_Literal
+            then
+               return True;
+
+            else
+               Restore_Scan_State (Scan_State);
+               return False;
+            end if;
+         end if;
+      end Real_Dot;
+
+   --  Start of processing for P_Designator
+
+   begin
+      Ident_Node := Token_Node;
+      Scan; -- past initial token
+
+      if Prev_Token = Tok_Operator_Symbol
+        or else Prev_Token = Tok_String_Literal
+        or else not Real_Dot
+      then
+         return Ident_Node;
+
+      --  Child name case
+
+      else
+         Prefix_Node := Ident_Node;
+
+         --  Loop through child names, on entry to this loop, Prefix contains
+         --  the name scanned so far, and Ident_Node is the last identifier.
+
+         loop
+            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
+            Set_Prefix (Name_Node, Prefix_Node);
+            Ident_Node := P_Identifier;
+            Set_Selector_Name (Name_Node, Ident_Node);
+            Prefix_Node := Name_Node;
+            exit when not Real_Dot;
+         end loop;
+
+         --  On exit from the loop, Ident_Node is the last identifier scanned,
+         --  i.e. the defining identifier, and Prefix_Node is a node for the
+         --  entire name, structured (incorrectly!) as a selected component.
+
+         Name_Node := Prefix (Prefix_Node);
+         Change_Node (Prefix_Node, N_Designator);
+         Set_Name (Prefix_Node, Name_Node);
+         Set_Identifier (Prefix_Node, Ident_Node);
+         return Prefix_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         while Token = Tok_Dot or else Token = Tok_Identifier loop
+            Scan;
+         end loop;
+
+         return Error;
+   end P_Designator;
+
+   ------------------------------
+   -- 6.1  Defining Designator --
+   ------------------------------
+
+   --  DEFINING_DESIGNATOR ::=
+   --    DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Defining_Designator return Node_Id is
+   begin
+      if Token = Tok_Operator_Symbol then
+         return P_Defining_Operator_Symbol;
+
+      elsif Token = Tok_String_Literal then
+         Error_Msg_SC ("invalid operator name");
+         Scan; -- past junk string
+         return Error;
+
+      else
+         return P_Defining_Program_Unit_Name;
+      end if;
+   end P_Defining_Designator;
+
+   -------------------------------------
+   -- 6.1  Defining Program Unit Name --
+   -------------------------------------
+
+   --  DEFINING_PROGRAM_UNIT_NAME ::=
+   --    [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
+
+   --  Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Defining_Program_Unit_Name return Node_Id is
+      Ident_Node  : Node_Id;
+      Name_Node   : Node_Id;
+      Prefix_Node : Node_Id;
+
+   begin
+      --  Set identifier casing if not already set and scan initial identifier
+
+      if Token = Tok_Identifier
+        and then Identifier_Casing (Current_Source_File) = Unknown
+      then
+         Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
+      end if;
+
+      Ident_Node := P_Identifier;
+      Merge_Identifier (Ident_Node, Tok_Return);
+
+      --  Normal case (not child library unit name)
+
+      if Token /= Tok_Dot then
+         Change_Identifier_To_Defining_Identifier (Ident_Node);
+         return Ident_Node;
+
+      --  Child library unit name case
+
+      else
+         if Scope.Last > 1 then
+            Error_Msg_SP ("child unit allowed only at library level");
+            raise Error_Resync;
+
+         elsif Ada_83 then
+            Error_Msg_SP ("(Ada 83) child unit not allowed!");
+
+         end if;
+
+         Prefix_Node := Ident_Node;
+
+         --  Loop through child names, on entry to this loop, Prefix contains
+         --  the name scanned so far, and Ident_Node is the last identifier.
+
+         loop
+            exit when Token /= Tok_Dot;
+            Name_Node := New_Node (N_Selected_Component, Token_Ptr);
+            Scan; -- past period
+            Set_Prefix (Name_Node, Prefix_Node);
+            Ident_Node := P_Identifier;
+            Set_Selector_Name (Name_Node, Ident_Node);
+            Prefix_Node := Name_Node;
+         end loop;
+
+         --  On exit from the loop, Ident_Node is the last identifier scanned,
+         --  i.e. the defining identifier, and Prefix_Node is a node for the
+         --  entire name, structured (incorrectly!) as a selected component.
+
+         Name_Node := Prefix (Prefix_Node);
+         Change_Node (Prefix_Node, N_Defining_Program_Unit_Name);
+         Set_Name (Prefix_Node, Name_Node);
+         Change_Identifier_To_Defining_Identifier (Ident_Node);
+         Set_Defining_Identifier (Prefix_Node, Ident_Node);
+
+         --  All set with unit name parsed
+
+         return Prefix_Node;
+      end if;
+
+   exception
+      when Error_Resync =>
+         while Token = Tok_Dot or else Token = Tok_Identifier loop
+            Scan;
+         end loop;
+
+         return Error;
+   end P_Defining_Program_Unit_Name;
+
+   --------------------------
+   -- 6.1  Operator Symbol --
+   --------------------------
+
+   --  OPERATOR_SYMBOL ::= STRING_LITERAL
+
+   --  Operator symbol is returned by the scanner as Tok_Operator_Symbol
+
+   -----------------------------------
+   -- 6.1  Defining Operator Symbol --
+   -----------------------------------
+
+   --  DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
+
+   --  The caller has checked that the initial symbol is an operator symbol
+
+   function P_Defining_Operator_Symbol return Node_Id is
+      Op_Node : Node_Id;
+
+   begin
+      Op_Node := Token_Node;
+      Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node);
+      Scan; -- past operator symbol
+      return Op_Node;
+   end P_Defining_Operator_Symbol;
+
+   ----------------------------
+   -- 6.1  Parameter_Profile --
+   ----------------------------
+
+   --  PARAMETER_PROFILE ::= [FORMAL_PART]
+
+   --  Empty is returned if no formal part is present
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Parameter_Profile return List_Id is
+   begin
+      if Token = Tok_Left_Paren then
+         Scan; -- part left paren
+         return P_Formal_Part;
+      else
+         return No_List;
+      end if;
+   end P_Parameter_Profile;
+
+   ---------------------------------------
+   -- 6.1  Parameter And Result Profile --
+   ---------------------------------------
+
+   --  Parsed by its parent construct, which uses P_Parameter_Profile to
+   --  parse the parameters, and P_Subtype_Mark to parse the return type.
+
+   ----------------------
+   -- 6.1  Formal part --
+   ----------------------
+
+   --  FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
+
+   --  PARAMETER_SPECIFICATION ::=
+   --    DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
+   --      [:= DEFAULT_EXPRESSION]
+   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
+   --      [:= DEFAULT_EXPRESSION]
+
+   --  This scans the construct Formal_Part. The caller has already checked
+   --  that the initial token is a left parenthesis, and skipped past it, so
+   --  that on entry Token is the first token following the left parenthesis.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Formal_Part return List_Id is
+      Specification_List : List_Id;
+      Specification_Node : Node_Id;
+      Scan_State         : Saved_Scan_State;
+      Num_Idents         : Nat;
+      Ident              : Nat;
+      Ident_Sloc         : Source_Ptr;
+
+      Idents : array (Int range 1 .. 4096) of Entity_Id;
+      --  This array holds the list of defining identifiers. The upper bound
+      --  of 4096 is intended to be essentially infinite, and we do not even
+      --  bother to check for it being exceeded.
+
+   begin
+      Specification_List := New_List;
+
+      Specification_Loop : loop
+         begin
+            if Token = Tok_Pragma then
+               P_Pragmas_Misplaced;
+            end if;
+
+            Ignore (Tok_Left_Paren);
+            Ident_Sloc := Token_Ptr;
+            Idents (1) := P_Defining_Identifier;
+            Num_Idents := 1;
+
+            Ident_Loop : loop
+               exit Ident_Loop when Token = Tok_Colon;
+
+               --  The only valid tokens are colon and comma, so if we have
+               --  neither do a bit of investigation to see which is the
+               --  better choice for insertion.
+
+               if Token /= Tok_Comma then
+
+                  --  Assume colon if IN or OUT keyword found
+
+                  exit Ident_Loop when Token = Tok_In or else Token = Tok_Out;
+
+                  --  Otherwise scan ahead
+
+                  Save_Scan_State (Scan_State);
+                  Look_Ahead : loop
+
+                     --  If we run into a semicolon, then assume that a
+                     --  colon was missing, e.g.  Parms (X Y; ...). Also
+                     --  assume missing colon on EOF (a real disaster!)
+                     --  and on a right paren, e.g. Parms (X Y), and also
+                     --  on an assignment symbol, e.g. Parms (X Y := ..)
+
+                     if Token = Tok_Semicolon
+                       or else Token = Tok_Right_Paren
+                       or else Token = Tok_EOF
+                       or else Token = Tok_Colon_Equal
+                     then
+                        Restore_Scan_State (Scan_State);
+                        exit Ident_Loop;
+
+                     --  If we run into a colon, assume that we had a missing
+                     --  comma, e.g. Parms (A B : ...). Also assume a missing
+                     --  comma if we hit another comma, e.g. Parms (A B, C ..)
+
+                     elsif Token = Tok_Colon
+                       or else Token = Tok_Comma
+                     then
+                        Restore_Scan_State (Scan_State);
+                        exit Look_Ahead;
+                     end if;
+
+                     Scan;
+                  end loop Look_Ahead;
+               end if;
+
+               --  Here if a comma is present, or to be assumed
+
+               T_Comma;
+               Num_Idents := Num_Idents + 1;
+               Idents (Num_Idents) := P_Defining_Identifier;
+            end loop Ident_Loop;
+
+            --  Fall through the loop on encountering a colon, or deciding
+            --  that there is a missing colon.
+
+            T_Colon;
+
+            --  If there are multiple identifiers, we repeatedly scan the
+            --  type and initialization expression information by resetting
+            --  the scan pointer (so that we get completely separate trees
+            --  for each occurrence).
+
+            if Num_Idents > 1 then
+               Save_Scan_State (Scan_State);
+            end if;
+
+            --  Loop through defining identifiers in list
+
+            Ident := 1;
+
+            Ident_List_Loop : loop
+               Specification_Node :=
+                 New_Node (N_Parameter_Specification, Ident_Sloc);
+               Set_Defining_Identifier (Specification_Node, Idents (Ident));
+
+               if Token = Tok_Access then
+                  if Ada_83 then
+                     Error_Msg_SC ("(Ada 83) access parameters not allowed");
+                  end if;
+
+                  Set_Parameter_Type
+                    (Specification_Node, P_Access_Definition);
+
+               else
+                  P_Mode (Specification_Node);
+
+                  if Token = Tok_Procedure
+                       or else
+                     Token = Tok_Function
+                  then
+                     Error_Msg_SC ("formal subprogram parameter not allowed");
+                     Scan;
+
+                     if Token = Tok_Left_Paren then
+                        Discard_Junk_List (P_Formal_Part);
+                     end if;
+
+                     if Token = Tok_Return then
+                        Scan;
+                        Discard_Junk_Node (P_Subtype_Mark);
+                     end if;
+
+                     Set_Parameter_Type (Specification_Node, Error);
+
+                  else
+                     Set_Parameter_Type (Specification_Node, P_Subtype_Mark);
+                     No_Constraint;
+                  end if;
+               end if;
+
+               Set_Expression (Specification_Node, Init_Expr_Opt (True));
+
+               if Ident > 1 then
+                  Set_Prev_Ids (Specification_Node, True);
+               end if;
+
+               if Ident < Num_Idents then
+                  Set_More_Ids (Specification_Node, True);
+               end if;
+
+               Append (Specification_Node, Specification_List);
+               exit Ident_List_Loop when Ident = Num_Idents;
+               Ident := Ident + 1;
+               Restore_Scan_State (Scan_State);
+            end loop Ident_List_Loop;
+
+         exception
+            when Error_Resync =>
+               Resync_Semicolon_List;
+         end;
+
+         if Token = Tok_Semicolon then
+            Scan; -- past semicolon
+
+            --  If we have RETURN or IS after the semicolon, then assume
+            --  that semicolon should have been a right parenthesis and exit
+
+            if Token = Tok_Is or else Token = Tok_Return then
+               Error_Msg_SP ("expected "")"" in place of "";""");
+               exit Specification_Loop;
+            end if;
+
+         elsif Token = Tok_Right_Paren then
+            Scan; -- past right paren
+            exit Specification_Loop;
+
+         --  Special check for common error of using comma instead of semicolon
+
+         elsif Token = Tok_Comma then
+            T_Semicolon;
+            Scan; -- past comma
+
+         --  Special check for omitted separator
+
+         elsif Token = Tok_Identifier then
+            T_Semicolon;
+
+         --  If nothing sensible, skip to next semicolon or right paren
+
+         else
+            T_Semicolon;
+            Resync_Semicolon_List;
+
+            if Token = Tok_Semicolon then
+               Scan; -- past semicolon
+            else
+               T_Right_Paren;
+               exit Specification_Loop;
+            end if;
+         end if;
+      end loop Specification_Loop;
+
+      return Specification_List;
+   end P_Formal_Part;
+
+   ----------------------------------
+   -- 6.1  Parameter Specification --
+   ----------------------------------
+
+   --  Parsed by P_Formal_Part (6.1)
+
+   ---------------
+   -- 6.1  Mode --
+   ---------------
+
+   --  MODE ::= [in] | in out | out
+
+   --  There is no explicit node in the tree for the Mode. Instead the
+   --  In_Present and Out_Present flags are set in the parent node to
+   --  record the presence of keywords specifying the mode.
+
+   --  Error_Recovery: cannot raise Error_Resync
+
+   procedure P_Mode (Node : Node_Id) is
+   begin
+      if Token = Tok_In then
+         Scan; -- past IN
+         Set_In_Present (Node, True);
+      end if;
+
+      if Token = Tok_Out then
+         Scan; -- past OUT
+         Set_Out_Present (Node, True);
+      end if;
+
+      if Token = Tok_In then
+         Error_Msg_SC ("IN must preceed OUT in parameter mode");
+         Scan; -- past IN
+         Set_In_Present (Node, True);
+      end if;
+   end P_Mode;
+
+   --------------------------
+   -- 6.3  Subprogram Body --
+   --------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -----------------------------------
+   -- 6.4  Procedure Call Statement --
+   -----------------------------------
+
+   --  Parsed by P_Sequence_Of_Statements (5.1)
+
+   ------------------------
+   -- 6.4  Function Call --
+   ------------------------
+
+   --  Parsed by P_Call_Or_Name (4.1)
+
+   --------------------------------
+   -- 6.4  Actual Parameter Part --
+   --------------------------------
+
+   --  Parsed by P_Call_Or_Name (4.1)
+
+   --------------------------------
+   -- 6.4  Parameter Association --
+   --------------------------------
+
+   --  Parsed by P_Call_Or_Name (4.1)
+
+   ------------------------------------
+   -- 6.4  Explicit Actual Parameter --
+   ------------------------------------
+
+   --  Parsed by P_Call_Or_Name (4.1)
+
+   ---------------------------
+   -- 6.5  Return Statement --
+   ---------------------------
+
+   --  RETURN_STATEMENT ::= return [EXPRESSION];
+
+   --  The caller has checked that the initial token is RETURN
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Return_Statement return Node_Id is
+      Return_Node : Node_Id;
+
+   begin
+      Return_Node := New_Node (N_Return_Statement, Token_Ptr);
+
+      --  Sloc points to RETURN
+      --  Expression (Op3)
+
+      Scan; -- past RETURN
+
+      if Token /= Tok_Semicolon then
+
+         --  If no semicolon, then scan an expression, except that
+         --  we avoid trying to scan an expression if we are at an
+         --  expression terminator since in that case the best error
+         --  message is probably that we have a missing semicolon.
+
+         if Token not in Token_Class_Eterm then
+            Set_Expression (Return_Node, P_Expression_No_Right_Paren);
+         end if;
+      end if;
+
+      TF_Semicolon;
+      return Return_Node;
+   end P_Return_Statement;
+
+end Ch6;
diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb
new file mode 100644
index 0000000..de63213
--- /dev/null
+++ b/gcc/ada/par-ch7.adb
@@ -0,0 +1,282 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 7                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.29 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch7 is
+
+   ---------------------------------------------
+   -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
+   ---------------------------------------------
+
+   --  This routine scans out a package declaration, package body, or a
+   --  renaming declaration or generic instantiation starting with PACKAGE
+
+   --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
+
+   --  PACKAGE_SPECIFICATION ::=
+   --    package DEFINING_PROGRAM_UNIT_NAME is
+   --      {BASIC_DECLARATIVE_ITEM}
+   --    [private
+   --      {BASIC_DECLARATIVE_ITEM}]
+   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+   --  PACKAGE_BODY ::=
+   --    package body DEFINING_PROGRAM_UNIT_NAME is
+   --      DECLARATIVE_PART
+   --    [begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS]
+   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
+
+   --  PACKAGE_RENAMING_DECLARATION ::=
+   --    package DEFINING_IDENTIFIER renames package_NAME;
+
+   --  PACKAGE_BODY_STUB ::=
+   --    package body DEFINING_IDENTIFIER is separate;
+
+   --  The value in Pf_Flags indicates which of these possible declarations
+   --  is acceptable to the caller:
+
+   --    Pf_Flags.Spcn                 Set if specification OK
+   --    Pf_Flags.Decl                 Set if declaration OK
+   --    Pf_Flags.Gins                 Set if generic instantiation OK
+   --    Pf_Flags.Pbod                 Set if proper body OK
+   --    Pf_Flags.Rnam                 Set if renaming declaration OK
+   --    Pf_Flags.Stub                 Set if body stub OK
+
+   --  If an inappropriate form is encountered, it is scanned out but an
+   --  error message indicating that it is appearing in an inappropriate
+   --  context is issued. The only possible settings for Pf_Flags are those
+   --  defined as constants in package Par.
+
+   --  Note: in all contexts where a package specification is required, there
+   --  is a terminating semicolon. This semicolon is scanned out in the case
+   --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
+   --  of the package specification (it's just too much trouble, and really
+   --  quite unnecessary, to deal with scanning out an END where the semicolon
+   --  after the END is not considered to be part of the END.
+
+   --  The caller has checked that the initial token is PACKAGE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
+      Package_Node       : Node_Id;
+      Specification_Node : Node_Id;
+      Name_Node          : Node_Id;
+      Package_Sloc       : Source_Ptr;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Lreq := False;
+
+      Package_Sloc := Token_Ptr;
+      Scan; -- past PACKAGE
+
+      if Token = Tok_Type then
+         Error_Msg_SC ("TYPE not allowed here");
+         Scan; -- past TYPE
+      end if;
+
+      --  Case of package body. Note that we demand a package body if that
+      --  is the only possibility (even if the BODY keyword is not present)
+
+      if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
+         if not Pf_Flags.Pbod then
+            Error_Msg_SC ("package body cannot appear here!");
+         end if;
+
+         T_Body;
+         Name_Node := P_Defining_Program_Unit_Name;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+         TF_Is;
+
+         if Separate_Present then
+            if not Pf_Flags.Stub then
+               Error_Msg_SC ("body stub cannot appear here!");
+            end if;
+
+            Scan; -- past SEPARATE
+            TF_Semicolon;
+            Pop_Scope_Stack;
+
+            Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
+            Set_Defining_Identifier (Package_Node, Name_Node);
+
+         else
+            Package_Node := New_Node (N_Package_Body, Package_Sloc);
+            Set_Defining_Unit_Name (Package_Node, Name_Node);
+            Parse_Decls_Begin_End (Package_Node);
+         end if;
+
+         return Package_Node;
+
+      --  Cases other than Package_Body
+
+      else
+         Name_Node := P_Defining_Program_Unit_Name;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+
+         --  Case of renaming declaration
+
+         Check_Misspelling_Of (Tok_Renames);
+
+         if Token = Tok_Renames then
+            if not Pf_Flags.Rnam then
+               Error_Msg_SC ("renaming declaration cannot appear here!");
+            end if;
+
+            Scan; -- past RENAMES;
+
+            Package_Node :=
+              New_Node (N_Package_Renaming_Declaration, Package_Sloc);
+            Set_Defining_Unit_Name (Package_Node, Name_Node);
+            Set_Name (Package_Node, P_Qualified_Simple_Name);
+
+            No_Constraint;
+            TF_Semicolon;
+            Pop_Scope_Stack;
+            return Package_Node;
+
+         else
+            TF_Is;
+
+            --  Case of generic instantiation
+
+            if Token = Tok_New then
+               if not Pf_Flags.Gins then
+                  Error_Msg_SC
+                     ("generic instantiation cannot appear here!");
+               end if;
+
+               Scan; -- past NEW
+
+               Package_Node :=
+                  New_Node (N_Package_Instantiation, Package_Sloc);
+               Set_Defining_Unit_Name (Package_Node, Name_Node);
+               Set_Name (Package_Node, P_Qualified_Simple_Name);
+               Set_Generic_Associations
+                 (Package_Node, P_Generic_Actual_Part_Opt);
+               TF_Semicolon;
+               Pop_Scope_Stack;
+
+            --  Case of package declaration or package specification
+
+            else
+               Specification_Node :=
+                 New_Node (N_Package_Specification, Package_Sloc);
+
+               Set_Defining_Unit_Name (Specification_Node, Name_Node);
+               Set_Visible_Declarations
+                 (Specification_Node, P_Basic_Declarative_Items);
+
+               if Token = Tok_Private then
+                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+
+                  if Style.RM_Column_Check then
+                     if Token_Is_At_Start_Of_Line
+                       and then Start_Column /= Error_Msg_Col
+                     then
+                        Error_Msg_SC
+                          ("(style) PRIVATE in wrong column, should be@");
+                     end if;
+                  end if;
+
+                  Scan; -- past PRIVATE
+                  Set_Private_Declarations
+                    (Specification_Node, P_Basic_Declarative_Items);
+
+                  --  Deal gracefully with multiple PRIVATE parts
+
+                  while Token = Tok_Private loop
+                     Error_Msg_SC
+                       ("only one private part allowed per package");
+                     Scan; -- past PRIVATE
+                     Append_List (P_Basic_Declarative_Items,
+                       Private_Declarations (Specification_Node));
+                  end loop;
+               end if;
+
+               if Pf_Flags = Pf_Spcn then
+                  Package_Node := Specification_Node;
+               else
+                  Package_Node :=
+                    New_Node (N_Package_Declaration, Package_Sloc);
+                  Set_Specification (Package_Node, Specification_Node);
+               end if;
+
+               if Token = Tok_Begin then
+                  Error_Msg_SC ("begin block not allowed in package spec");
+                  Scan; -- past BEGIN
+                  Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
+               end if;
+
+               End_Statements (Specification_Node);
+            end if;
+
+            return Package_Node;
+         end if;
+      end if;
+   end P_Package;
+
+   ------------------------------
+   -- 7.1  Package Declaration --
+   ------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   --------------------------------
+   -- 7.1  Package Specification --
+   --------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   -----------------------
+   -- 7.1  Package Body --
+   -----------------------
+
+   --  Parsed by P_Package (7.1)
+
+   -----------------------------------
+   -- 7.3  Private Type Declaration --
+   -----------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+   ----------------------------------------
+   -- 7.3  Private Extension Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Type_Declaration (3.2.1)
+
+end Ch7;
diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb
new file mode 100644
index 0000000..9d1b386
--- /dev/null
+++ b/gcc/ada/par-ch8.adb
@@ -0,0 +1,175 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 8                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch8 is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function P_Use_Package_Clause                           return Node_Id;
+   function P_Use_Type_Clause                              return Node_Id;
+
+   ---------------------
+   -- 8.4  Use Clause --
+   ---------------------
+
+   --  USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
+
+   --  The caller has checked that the initial token is USE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Clause return Node_Id is
+   begin
+      Scan; -- past USE
+
+      if Token = Tok_Type then
+         return P_Use_Type_Clause;
+
+      else
+         return P_Use_Package_Clause;
+      end if;
+   end P_Use_Clause;
+
+   -----------------------------
+   -- 8.4  Use Package Clause --
+   -----------------------------
+
+   --  USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
+
+   --  The caller has scanned out the USE keyword
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Package_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr);
+      Set_Names (Use_Node, New_List);
+
+      if Token = Tok_Package then
+         Error_Msg_SC ("PACKAGE should not appear here");
+         Scan; -- past PACKAGE
+      end if;
+
+      loop
+         Append (P_Qualified_Simple_Name, Names (Use_Node));
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Package_Clause;
+
+   --------------------------
+   -- 8.4  Use Type Clause --
+   --------------------------
+
+   --  USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK};
+
+   --  The caller has checked that the initial token is USE, scanned it out
+   --  and that the current token is TYPE.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Use_Type_Clause return Node_Id is
+      Use_Node : Node_Id;
+
+   begin
+      Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr);
+      Set_Subtype_Marks (Use_Node, New_List);
+
+      if Ada_83 then
+         Error_Msg_SC ("(Ada 83) use type not allowed!");
+      end if;
+
+      Scan; -- past TYPE
+
+      loop
+         Append (P_Subtype_Mark, Subtype_Marks (Use_Node));
+         No_Constraint;
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Use_Node;
+   end P_Use_Type_Clause;
+
+   -------------------------------
+   -- 8.5  Renaming Declaration --
+   -------------------------------
+
+   --  Object renaming declarations and exception renaming declarations
+   --  are parsed by P_Identifier_Declaration (3.3.1)
+
+   --  Subprogram renaming declarations are parsed by P_Subprogram (6.1)
+
+   --  Package renaming declarations are parsed by P_Package (7.1)
+
+   --  Generic renaming declarations are parsed by P_Generic (12.1)
+
+   ----------------------------------------
+   -- 8.5.1  Object Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   ----------------------------------------
+   -- 8.5.2  Exception Renaming Declaration --
+   ----------------------------------------
+
+   --  Parsed by P_Identifier_Declarations (3.3.1)
+
+   -----------------------------------------
+   -- 8.5.3  Package Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Package (7.1)
+
+   --------------------------------------------
+   -- 8.5.4  Subprogram Renaming Declaration --
+   --------------------------------------------
+
+   --  Parsed by P_Subprogram (6.1)
+
+   -----------------------------------------
+   -- 8.5.2  Generic Renaming Declaration --
+   -----------------------------------------
+
+   --  Parsed by P_Generic (12.1)
+
+end Ch8;
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
new file mode 100644
index 0000000..87d6be6
--- /dev/null
+++ b/gcc/ada/par-ch9.adb
@@ -0,0 +1,1616 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P A R . C H 9                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.82 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+pragma Style_Checks (All_Checks);
+--  Turn off subprogram body ordering check. Subprograms are in order
+--  by RM section rather than alphabetical
+
+separate (Par)
+package body Ch9 is
+
+   --  Local subprograms, used only in this chapter
+
+   function P_Accept_Alternative                   return Node_Id;
+   function P_Delay_Alternative                    return Node_Id;
+   function P_Delay_Relative_Statement             return Node_Id;
+   function P_Delay_Until_Statement                return Node_Id;
+   function P_Entry_Barrier                        return Node_Id;
+   function P_Entry_Body_Formal_Part               return Node_Id;
+   function P_Entry_Declaration                    return Node_Id;
+   function P_Entry_Index_Specification            return Node_Id;
+   function P_Protected_Definition                 return Node_Id;
+   function P_Protected_Operation_Declaration_Opt  return Node_Id;
+   function P_Protected_Operation_Items            return List_Id;
+   function P_Task_Definition                      return Node_Id;
+   function P_Task_Items                           return List_Id;
+
+   -----------------------------
+   -- 9.1  Task (also 10.1.3) --
+   -----------------------------
+
+   --  TASK_TYPE_DECLARATION ::=
+   --    task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+   --      [is TASK_DEFINITION];
+
+   --  SINGLE_TASK_DECLARATION ::=
+   --    task DEFINING_IDENTIFIER [is TASK_DEFINITION];
+
+   --  TASK_BODY ::=
+   --    task body DEFINING_IDENTIFIER is
+   --      DECLARATIVE_PART
+   --    begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS
+   --    end [task_IDENTIFIER]
+
+   --  TASK_BODY_STUB ::=
+   --    task body DEFINING_IDENTIFIER is separate;
+
+   --  This routine scans out a task declaration, task body, or task stub
+
+   --  The caller has checked that the initial token is TASK and scanned
+   --  past it, so that Token is set to the token after TASK
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Task return Node_Id is
+      Name_Node  : Node_Id;
+      Task_Node  : Node_Id;
+      Task_Sloc  : Source_Ptr;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Lreq := False;
+      Task_Sloc := Prev_Token_Ptr;
+
+      if Token = Tok_Body then
+         Scan; -- past BODY
+         Name_Node := P_Defining_Identifier;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+
+         if Token = Tok_Left_Paren then
+            Error_Msg_SC ("discriminant part not allowed in task body");
+            Discard_Junk_List (P_Known_Discriminant_Part_Opt);
+         end if;
+
+         TF_Is;
+
+         --  Task stub
+
+         if Token = Tok_Separate then
+            Scan; -- past SEPARATE
+            Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc);
+            Set_Defining_Identifier (Task_Node, Name_Node);
+            TF_Semicolon;
+            Pop_Scope_Stack; -- remove unused entry
+
+         --  Task body
+
+         else
+            Task_Node := New_Node (N_Task_Body, Task_Sloc);
+            Set_Defining_Identifier (Task_Node, Name_Node);
+            Parse_Decls_Begin_End (Task_Node);
+         end if;
+
+         return Task_Node;
+
+      --  Otherwise we must have a task declaration
+
+      else
+         if Token = Tok_Type then
+            Scan; -- past TYPE
+            Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc);
+            Name_Node := P_Defining_Identifier;
+            Set_Defining_Identifier (Task_Node, Name_Node);
+            Scope.Table (Scope.Last).Labl := Name_Node;
+            Set_Discriminant_Specifications
+              (Task_Node, P_Known_Discriminant_Part_Opt);
+
+         else
+            Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
+            Name_Node := P_Defining_Identifier;
+            Set_Defining_Identifier (Task_Node, Name_Node);
+            Scope.Table (Scope.Last).Labl := Name_Node;
+
+            if Token = Tok_Left_Paren then
+               Error_Msg_SC ("discriminant part not allowed for single task");
+               Discard_Junk_List (P_Known_Discriminant_Part_Opt);
+            end if;
+
+         end if;
+
+         --  Parse optional task definition. Note that P_Task_Definition scans
+         --  out the semicolon as well as the task definition itself.
+
+         if Token = Tok_Semicolon then
+
+            --  A little check, if the next token after semicolon is
+            --  Entry, then surely the semicolon should really be IS
+
+            Scan; -- past semicolon
+
+            if Token = Tok_Entry then
+               Error_Msg_SP (""";"" should be IS");
+               Set_Task_Definition (Task_Node, P_Task_Definition);
+            else
+               Pop_Scope_Stack; -- Remove unused entry
+            end if;
+         else
+            TF_Is; -- must have IS if no semicolon
+            Set_Task_Definition (Task_Node, P_Task_Definition);
+         end if;
+
+         return Task_Node;
+      end if;
+   end P_Task;
+
+   --------------------------------
+   -- 9.1  Task Type Declaration --
+   --------------------------------
+
+   --  Parsed by P_Task (9.1)
+
+   ----------------------------------
+   -- 9.1  Single Task Declaration --
+   ----------------------------------
+
+   --  Parsed by P_Task (9.1)
+
+   --------------------------
+   -- 9.1  Task Definition --
+   --------------------------
+
+   --  TASK_DEFINITION ::=
+   --      {TASK_ITEM}
+   --    [private
+   --      {TASK_ITEM}]
+   --    end [task_IDENTIFIER];
+
+   --  The caller has already made the scope stack entry
+
+   --  Note: there is a small deviation from official syntax here in that we
+   --  regard the semicolon after end as part of the Task_Definition, and in
+   --  the official syntax, it's part of the enclosing declaration. The reason
+   --  for this deviation is that otherwise the end processing would have to
+   --  be special cased, which would be a nuisance!
+
+   --  Error recovery:  cannot raise Error_Resync
+
+   function P_Task_Definition return Node_Id is
+      Def_Node  : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Task_Definition, Token_Ptr);
+      Set_Visible_Declarations (Def_Node, P_Task_Items);
+
+      if Token = Tok_Private then
+         Scan; -- past PRIVATE
+         Set_Private_Declarations (Def_Node, P_Task_Items);
+
+         --  Deal gracefully with multiple PRIVATE parts
+
+         while Token = Tok_Private loop
+            Error_Msg_SC ("Only one private part allowed per task");
+            Scan; -- past PRIVATE
+            Append_List (P_Task_Items, Private_Declarations (Def_Node));
+         end loop;
+      end if;
+
+      End_Statements (Def_Node);
+      return Def_Node;
+   end P_Task_Definition;
+
+   --------------------
+   -- 9.1  Task Item --
+   --------------------
+
+   --  TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE
+
+   --  This subprogram scans a (possibly empty) list of task items and pragmas
+
+   --  Error recovery:  cannot raise Error_Resync
+
+   --  Note: a pragma can also be returned in this position
+
+   function P_Task_Items return List_Id is
+      Items      : List_Id;
+      Item_Node  : Node_Id;
+      Decl_Sloc  : Source_Ptr;
+
+   begin
+      --  Get rid of active SIS entry from outer scope. This means we will
+      --  miss some nested cases, but it doesn't seem worth the effort. See
+      --  discussion in Par for further details
+
+      SIS_Entry_Active := False;
+
+      --  Loop to scan out task items
+
+      Items := New_List;
+
+      Decl_Loop : loop
+         Decl_Sloc := Token_Ptr;
+
+         if Token = Tok_Pragma then
+            Append (P_Pragma, Items);
+
+         elsif Token = Tok_Entry then
+            Append (P_Entry_Declaration, Items);
+
+         elsif Token = Tok_For then
+            --  Representation clause in task declaration. The only rep
+            --  clause which is legal in a protected is an address clause,
+            --  so that is what we try to scan out.
+
+            Item_Node := P_Representation_Clause;
+
+            if Nkind (Item_Node) = N_At_Clause then
+               Append (Item_Node, Items);
+
+            elsif Nkind (Item_Node) = N_Attribute_Definition_Clause
+              and then Chars (Item_Node) = Name_Address
+            then
+               Append (Item_Node, Items);
+
+            else
+               Error_Msg
+                 ("the only representation clause " &
+                  "allowed here is an address clause!", Decl_Sloc);
+            end if;
+
+         elsif Token = Tok_Identifier
+           or else Token in Token_Class_Declk
+         then
+            Error_Msg_SC ("Illegal declaration in task definition");
+            Resync_Past_Semicolon;
+
+         else
+            exit Decl_Loop;
+         end if;
+      end loop Decl_Loop;
+
+      return Items;
+   end P_Task_Items;
+
+   --------------------
+   -- 9.1  Task Body --
+   --------------------
+
+   --  Parsed by P_Task (9.1)
+
+   ----------------------------------
+   -- 9.4  Protected (also 10.1.3) --
+   ----------------------------------
+
+   --  PROTECTED_TYPE_DECLARATION ::=
+   --    protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART]
+   --      is PROTECTED_DEFINITION;
+
+   --  SINGLE_PROTECTED_DECLARATION ::=
+   --    protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
+
+   --  PROTECTED_BODY ::=
+   --    protected body DEFINING_IDENTIFIER is
+   --      {PROTECTED_OPERATION_ITEM}
+   --    end [protected_IDENTIFIER];
+
+   --  PROTECTED_BODY_STUB ::=
+   --    protected body DEFINING_IDENTIFIER is separate;
+
+   --  This routine scans out a protected declaration, protected body
+   --  or a protected stub.
+
+   --  The caller has checked that the initial token is PROTECTED and
+   --  scanned past it, so Token is set to the following token.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Protected return Node_Id is
+      Name_Node      : Node_Id;
+      Protected_Node : Node_Id;
+      Protected_Sloc : Source_Ptr;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Lreq := False;
+      Protected_Sloc := Prev_Token_Ptr;
+
+      if Token = Tok_Body then
+         Scan; -- past BODY
+         Name_Node := P_Defining_Identifier;
+         Scope.Table (Scope.Last).Labl := Name_Node;
+
+         if Token = Tok_Left_Paren then
+            Error_Msg_SC ("discriminant part not allowed in protected body");
+            Discard_Junk_List (P_Known_Discriminant_Part_Opt);
+         end if;
+
+         TF_Is;
+
+         --  Protected stub
+
+         if Token = Tok_Separate then
+            Scan; -- past SEPARATE
+            Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc);
+            Set_Defining_Identifier (Protected_Node, Name_Node);
+            TF_Semicolon;
+            Pop_Scope_Stack; -- remove unused entry
+
+         --  Protected body
+
+         else
+            Protected_Node := New_Node (N_Protected_Body, Protected_Sloc);
+            Set_Defining_Identifier (Protected_Node, Name_Node);
+            Set_Declarations (Protected_Node, P_Protected_Operation_Items);
+            End_Statements (Protected_Node);
+         end if;
+
+         return Protected_Node;
+
+      --  Otherwise we must have a protected declaration
+
+      else
+         if Token = Tok_Type then
+            Scan; -- past TYPE
+            Protected_Node :=
+              New_Node (N_Protected_Type_Declaration, Protected_Sloc);
+            Name_Node := P_Defining_Identifier;
+            Set_Defining_Identifier (Protected_Node, Name_Node);
+            Scope.Table (Scope.Last).Labl := Name_Node;
+            Set_Discriminant_Specifications
+              (Protected_Node, P_Known_Discriminant_Part_Opt);
+
+         else
+            Protected_Node :=
+              New_Node (N_Single_Protected_Declaration, Protected_Sloc);
+            Name_Node := P_Defining_Identifier;
+            Set_Defining_Identifier (Protected_Node, Name_Node);
+
+            if Token = Tok_Left_Paren then
+               Error_Msg_SC
+                 ("discriminant part not allowed for single protected");
+               Discard_Junk_List (P_Known_Discriminant_Part_Opt);
+            end if;
+
+            Scope.Table (Scope.Last).Labl := Name_Node;
+         end if;
+
+         T_Is;
+         Set_Protected_Definition (Protected_Node, P_Protected_Definition);
+         return Protected_Node;
+      end if;
+   end P_Protected;
+
+   -------------------------------------
+   -- 9.4  Protected Type Declaration --
+   -------------------------------------
+
+   --  Parsed by P_Protected (9.4)
+
+   ---------------------------------------
+   -- 9.4  Single Protected Declaration --
+   ---------------------------------------
+
+   --  Parsed by P_Protected (9.4)
+
+   -------------------------------
+   -- 9.4  Protected Definition --
+   -------------------------------
+
+   --  PROTECTED_DEFINITION ::=
+   --      {PROTECTED_OPERATION_DECLARATION}
+   --    [private
+   --      {PROTECTED_ELEMENT_DECLARATION}]
+   --    end [protected_IDENTIFIER]
+
+   --  PROTECTED_ELEMENT_DECLARATION ::=
+   --    PROTECTED_OPERATION_DECLARATION
+   --  | COMPONENT_DECLARATION
+
+   --  The caller has already established the scope stack entry
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Protected_Definition return Node_Id is
+      Def_Node  : Node_Id;
+      Item_Node : Node_Id;
+
+   begin
+      Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
+
+      --  Get rid of active SIS entry from outer scope. This means we will
+      --  miss some nested cases, but it doesn't seem worth the effort. See
+      --  discussion in Par for further details
+
+      SIS_Entry_Active := False;
+
+      --  Loop to scan visible declarations (protected operation declarations)
+
+      Set_Visible_Declarations (Def_Node, New_List);
+
+      loop
+         Item_Node := P_Protected_Operation_Declaration_Opt;
+         exit when No (Item_Node);
+         Append (Item_Node, Visible_Declarations (Def_Node));
+      end loop;
+
+      --  Deal with PRIVATE part (including graceful handling
+      --  of multiple PRIVATE parts).
+
+      Private_Loop : while Token = Tok_Private loop
+         if No (Private_Declarations (Def_Node)) then
+            Set_Private_Declarations (Def_Node, New_List);
+         else
+            Error_Msg_SC ("duplicate private part");
+         end if;
+
+         Scan; -- past PRIVATE
+
+         Declaration_Loop : loop
+            if Token = Tok_Identifier then
+               P_Component_Items (Private_Declarations (Def_Node));
+            else
+               Item_Node := P_Protected_Operation_Declaration_Opt;
+               exit Declaration_Loop when No (Item_Node);
+               Append (Item_Node, Private_Declarations (Def_Node));
+            end if;
+         end loop Declaration_Loop;
+      end loop Private_Loop;
+
+      End_Statements (Def_Node);
+      return Def_Node;
+   end P_Protected_Definition;
+
+   ------------------------------------------
+   -- 9.4  Protected Operation Declaration --
+   ------------------------------------------
+
+   --  PROTECTED_OPERATION_DECLARATION ::=
+   --    SUBPROGRAM_DECLARATION
+   --  | ENTRY_DECLARATION
+   --  | REPRESENTATION_CLAUSE
+
+   --  Error recovery: cannot raise Error_Resync
+
+   --  Note: a pragma can also be returned in this position
+
+   --  We are not currently permitting representation clauses to appear as
+   --  protected operation declarations, do we have to rethink this???
+
+   function P_Protected_Operation_Declaration_Opt return Node_Id is
+      L : List_Id;
+      P : Source_Ptr;
+
+   begin
+      --  This loop runs more than once only when a junk declaration
+      --  is skipped.
+
+      loop
+         if Token = Tok_Pragma then
+            return P_Pragma;
+
+         elsif Token = Tok_Entry then
+            return P_Entry_Declaration;
+
+         elsif Token = Tok_Function or else Token = Tok_Procedure then
+            return P_Subprogram (Pf_Decl);
+
+         elsif Token = Tok_Identifier then
+            L := New_List;
+            P := Token_Ptr;
+            Skip_Declaration (L);
+
+            if Nkind (First (L)) = N_Object_Declaration then
+               Error_Msg
+                 ("component must be declared in private part of " &
+                  "protected type", P);
+            else
+               Error_Msg
+                 ("illegal declaration in protected definition", P);
+            end if;
+
+         elsif Token in Token_Class_Declk then
+            Error_Msg_SC ("illegal declaration in protected definition");
+            Resync_Past_Semicolon;
+
+            --  Return now to avoid cascaded messages if next declaration
+            --  is a valid component declaration.
+
+            return Error;
+
+         elsif Token = Tok_For then
+            Error_Msg_SC
+              ("representation clause not allowed in protected definition");
+            Resync_Past_Semicolon;
+
+         else
+            return Empty;
+         end if;
+      end loop;
+   end P_Protected_Operation_Declaration_Opt;
+
+   -----------------------------------
+   -- 9.4  Protected Operation Item --
+   -----------------------------------
+
+   --  PROTECTED_OPERATION_ITEM ::=
+   --    SUBPROGRAM_DECLARATION
+   --  | SUBPROGRAM_BODY
+   --  | ENTRY_BODY
+   --  | REPRESENTATION_CLAUSE
+
+   --  This procedure parses and returns a list of protected operation items
+
+   --  We are not currently permitting representation clauses to appear
+   --  as protected operation items, do we have to rethink this???
+
+   function P_Protected_Operation_Items return List_Id is
+      Item_List : List_Id;
+
+   begin
+      Item_List := New_List;
+
+      loop
+         if Token = Tok_Entry or else Bad_Spelling_Of (Tok_Entry) then
+            Append (P_Entry_Body, Item_List);
+
+         elsif Token = Tok_Function or else Bad_Spelling_Of (Tok_Function)
+                 or else
+               Token = Tok_Procedure or else Bad_Spelling_Of (Tok_Procedure)
+         then
+            Append (P_Subprogram (Pf_Decl_Pbod), Item_List);
+
+         elsif Token = Tok_Pragma or else Bad_Spelling_Of (Tok_Pragma) then
+            P_Pragmas_Opt (Item_List);
+
+         elsif Token = Tok_Private or else Bad_Spelling_Of (Tok_Private) then
+            Error_Msg_SC ("PRIVATE not allowed in protected body");
+            Scan; -- past PRIVATE
+
+         elsif Token = Tok_Identifier then
+            Error_Msg_SC
+              ("all components must be declared in spec!");
+            Resync_Past_Semicolon;
+
+         elsif Token in Token_Class_Declk then
+            Error_Msg_SC ("this declaration not allowed in protected body");
+            Resync_Past_Semicolon;
+
+         else
+            exit;
+         end if;
+      end loop;
+
+      return Item_List;
+   end P_Protected_Operation_Items;
+
+   ------------------------------
+   -- 9.5.2  Entry Declaration --
+   ------------------------------
+
+   --  ENTRY_DECLARATION ::=
+   --    entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
+   --      PARAMETER_PROFILE;
+
+   --  The caller has checked that the initial token is ENTRY
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Entry_Declaration return Node_Id is
+      Decl_Node  : Node_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
+      Scan; -- past ENTRY
+
+      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
+
+      --  If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
+
+      if Token = Tok_Left_Paren then
+         Scan; -- past (
+
+         --  If identifier after left paren, could still be either
+
+         if Token = Tok_Identifier then
+            Save_Scan_State (Scan_State); -- at Id
+            Scan; -- past Id
+
+            --  If comma or colon after Id, must be Formal_Part
+
+            if Token = Tok_Comma or else Token = Tok_Colon then
+               Restore_Scan_State (Scan_State); -- to Id
+               Set_Parameter_Specifications (Decl_Node, P_Formal_Part);
+
+            --  Else if Id wi no comma or colon, must be discrete subtype defn
+
+            else
+               Restore_Scan_State (Scan_State); -- to Id
+               Set_Discrete_Subtype_Definition
+                 (Decl_Node, P_Discrete_Subtype_Definition);
+               T_Right_Paren;
+               Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
+            end if;
+
+         --  If no Id, must be discrete subtype definition
+
+         else
+            Set_Discrete_Subtype_Definition
+              (Decl_Node, P_Discrete_Subtype_Definition);
+            T_Right_Paren;
+            Set_Parameter_Specifications (Decl_Node, P_Parameter_Profile);
+         end if;
+      end if;
+
+      --  Error recovery check for illegal return
+
+      if Token = Tok_Return then
+         Error_Msg_SC ("entry cannot have return value!");
+         Scan;
+         Discard_Junk_Node (P_Subtype_Indication);
+      end if;
+
+      --  Error recovery check for improper use of entry barrier in spec
+
+      if Token = Tok_When then
+         Error_Msg_SC ("barrier not allowed here (belongs in body)");
+         Scan; -- past WHEN;
+         Discard_Junk_Node (P_Expression_No_Right_Paren);
+      end if;
+
+      TF_Semicolon;
+      return Decl_Node;
+   end P_Entry_Declaration;
+
+   -----------------------------
+   -- 9.5.2  Accept Statement --
+   -----------------------------
+
+   --  ACCEPT_STATEMENT ::=
+   --    accept entry_DIRECT_NAME
+   --      [(ENTRY_INDEX)] PARAMETER_PROFILE [do
+   --        HANDLED_SEQUENCE_OF_STATEMENTS
+   --    end [entry_IDENTIFIER]];
+
+   --  The caller has checked that the initial token is ACCEPT
+
+   --  Error recovery: cannot raise Error_Resync. If an error occurs, the
+   --  scan is resynchronized past the next semicolon and control returns.
+
+   function P_Accept_Statement return Node_Id is
+      Scan_State  : Saved_Scan_State;
+      Accept_Node : Node_Id;
+      Hand_Seq    : Node_Id;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+
+      Accept_Node := New_Node (N_Accept_Statement, Token_Ptr);
+      Scan; -- past ACCEPT
+      Scope.Table (Scope.Last).Labl := Token_Node;
+
+      Set_Entry_Direct_Name (Accept_Node, P_Identifier);
+
+      --  Left paren could be (Entry_Index) or Formal_Part, determine which
+
+      if Token = Tok_Left_Paren then
+         Save_Scan_State (Scan_State); -- at left paren
+         Scan; -- past left paren
+
+         --  If first token after left paren not identifier, then Entry_Index
+
+         if Token /= Tok_Identifier then
+            Set_Entry_Index (Accept_Node, P_Expression);
+            T_Right_Paren;
+            Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
+
+         --  First token after left paren is identifier, could be either case
+
+         else -- Token = Tok_Identifier
+            Scan; -- past identifier
+
+            --  If identifier followed by comma or colon, must be Formal_Part
+
+            if Token = Tok_Comma or else Token = Tok_Colon then
+               Restore_Scan_State (Scan_State); -- to left paren
+               Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
+
+            --  If identifier not followed by comma/colon, must be entry index
+
+            else
+               Restore_Scan_State (Scan_State); -- to left paren
+               Scan; -- past left paren (again!)
+               Set_Entry_Index (Accept_Node, P_Expression);
+               T_Right_Paren;
+               Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile);
+            end if;
+         end if;
+      end if;
+
+      --  Scan out DO if present
+
+      if Token = Tok_Do then
+         Scope.Table (Scope.Last).Etyp := E_Name;
+         Scope.Table (Scope.Last).Lreq := False;
+         Scan; -- past DO
+         Hand_Seq := P_Handled_Sequence_Of_Statements;
+         Set_Handled_Statement_Sequence (Accept_Node, Hand_Seq);
+         End_Statements (Handled_Statement_Sequence (Accept_Node));
+
+         --  Exception handlers not allowed in Ada 95 node
+
+         if Present (Exception_Handlers (Hand_Seq)) then
+            if Ada_83 then
+               Error_Msg_N
+                 ("(Ada 83) exception handlers in accept not allowed",
+                  First_Non_Pragma (Exception_Handlers (Hand_Seq)));
+            end if;
+         end if;
+
+      else
+         Pop_Scope_Stack; -- discard unused entry
+         TF_Semicolon;
+      end if;
+
+      return Accept_Node;
+
+   --  If error, resynchronize past semicolon
+
+   exception
+      when Error_Resync =>
+         Resync_Past_Semicolon;
+         return Error;
+
+   end P_Accept_Statement;
+
+   ------------------------
+   -- 9.5.2  Entry Index --
+   ------------------------
+
+   --  Parsed by P_Expression (4.4)
+
+   -----------------------
+   -- 9.5.2  Entry Body --
+   -----------------------
+
+   --  ENTRY_BODY ::=
+   --    entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is
+   --      DECLARATIVE_PART
+   --    begin
+   --      HANDLED_SEQUENCE_OF_STATEMENTS
+   --    end [entry_IDENTIFIER];
+
+   --  The caller has checked that the initial token is ENTRY
+
+   --  Error_Recovery: cannot raise Error_Resync
+
+   function P_Entry_Body return Node_Id is
+      Entry_Node       : Node_Id;
+      Formal_Part_Node : Node_Id;
+      Name_Node        : Node_Id;
+
+   begin
+      Push_Scope_Stack;
+      Entry_Node := New_Node (N_Entry_Body, Token_Ptr);
+      Scan; -- past ENTRY
+
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Lreq := False;
+      Scope.Table (Scope.Last).Etyp := E_Name;
+
+      Name_Node := P_Defining_Identifier;
+      Set_Defining_Identifier (Entry_Node, Name_Node);
+      Scope.Table (Scope.Last).Labl := Name_Node;
+
+      Formal_Part_Node := P_Entry_Body_Formal_Part;
+      Set_Entry_Body_Formal_Part (Entry_Node, Formal_Part_Node);
+
+      Set_Condition (Formal_Part_Node, P_Entry_Barrier);
+      Parse_Decls_Begin_End (Entry_Node);
+      return Entry_Node;
+   end P_Entry_Body;
+
+   -----------------------------------
+   -- 9.5.2  Entry Body Formal Part --
+   -----------------------------------
+
+   --  ENTRY_BODY_FORMAL_PART ::=
+   --    [(ENTRY_INDEX_SPECIFICATION)] [PARAMETER_PART]
+
+   --  Error_Recovery: cannot raise Error_Resync
+
+   function P_Entry_Body_Formal_Part return Node_Id is
+      Fpart_Node : Node_Id;
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr);
+
+      --  See if entry index specification present, and if so parse it
+
+      if Token = Tok_Left_Paren then
+         Save_Scan_State (Scan_State); -- at left paren
+         Scan; -- past left paren
+
+         if Token = Tok_For then
+            Set_Entry_Index_Specification
+              (Fpart_Node, P_Entry_Index_Specification);
+            T_Right_Paren;
+         else
+            Restore_Scan_State (Scan_State); -- to left paren
+         end if;
+
+      --  Check for (common?) case of left paren omitted before FOR. This
+      --  is a tricky case, because the corresponding missing left paren
+      --  can cause real havoc if a formal part is present which gets
+      --  treated as part of the discrete subtype definition of the
+      --  entry index specification, so just give error and resynchronize
+
+      elsif Token = Tok_For then
+         T_Left_Paren; -- to give error message
+         Resync_To_When;
+      end if;
+
+      Set_Parameter_Specifications (Fpart_Node, P_Parameter_Profile);
+      return Fpart_Node;
+   end P_Entry_Body_Formal_Part;
+
+   --------------------------
+   -- 9.5.2  Entry Barrier --
+   --------------------------
+
+   --  ENTRY_BARRIER ::= when CONDITION
+
+   --  Error_Recovery: cannot raise Error_Resync
+
+   function P_Entry_Barrier return Node_Id is
+      Bnode : Node_Id;
+
+   begin
+      if Token = Tok_When then
+         Scan; -- past WHEN;
+         Bnode := P_Expression_No_Right_Paren;
+
+         if Token = Tok_Colon_Equal then
+            Error_Msg_SC (""":="" should be ""=""");
+            Scan;
+            Bnode := P_Expression_No_Right_Paren;
+         end if;
+
+      else
+         T_When; -- to give error message
+         Bnode := Error;
+      end if;
+
+      TF_Is;
+      return Bnode;
+   end P_Entry_Barrier;
+
+   --------------------------------------
+   -- 9.5.2  Entry Index Specification --
+   --------------------------------------
+
+   --  ENTRY_INDEX_SPECIFICATION ::=
+   --    for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Entry_Index_Specification return Node_Id is
+      Iterator_Node : Node_Id;
+
+   begin
+      Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
+      T_For; -- past FOR
+      Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier);
+      T_In;
+      Set_Discrete_Subtype_Definition
+        (Iterator_Node, P_Discrete_Subtype_Definition);
+      return Iterator_Node;
+   end P_Entry_Index_Specification;
+
+   ---------------------------------
+   -- 9.5.3  Entry Call Statement --
+   ---------------------------------
+
+   --  Parsed by P_Name (4.1). Within a select, an entry call is parsed
+   --  by P_Select_Statement (9.7)
+
+   ------------------------------
+   -- 9.5.4  Requeue Statement --
+   ------------------------------
+
+   --  REQUEUE_STATEMENT ::= requeue entry_NAME [with abort];
+
+   --  The caller has checked that the initial token is requeue
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Requeue_Statement return Node_Id is
+      Requeue_Node : Node_Id;
+
+   begin
+      Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr);
+      Scan; -- past REQUEUE
+      Set_Name (Requeue_Node, P_Name);
+
+      if Token = Tok_With then
+         Scan; -- past WITH
+         T_Abort;
+         Set_Abort_Present (Requeue_Node, True);
+      end if;
+
+      TF_Semicolon;
+      return Requeue_Node;
+   end P_Requeue_Statement;
+
+   --------------------------
+   -- 9.6  Delay Statement --
+   --------------------------
+
+   --  DELAY_STATEMENT ::=
+   --    DELAY_UNTIL_STATEMENT
+   --  | DELAY_RELATIVE_STATEMENT
+
+   --  The caller has checked that the initial token is DELAY
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Delay_Statement return Node_Id is
+   begin
+      Scan; -- past DELAY
+
+      --  The following check for delay until misused in Ada 83 doesn't catch
+      --  all cases, but it's good enough to catch most of them!
+
+      if Token_Name = Name_Until then
+         Check_95_Keyword (Tok_Until, Tok_Left_Paren);
+         Check_95_Keyword (Tok_Until, Tok_Identifier);
+      end if;
+
+      if Token = Tok_Until then
+         return P_Delay_Until_Statement;
+      else
+         return P_Delay_Relative_Statement;
+      end if;
+   end P_Delay_Statement;
+
+   --------------------------------
+   -- 9.6  Delay Until Statement --
+   --------------------------------
+
+   --  DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION;
+
+   --  The caller has checked that the initial token is DELAY, scanned it
+   --  out and checked that the current token is UNTIL
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Delay_Until_Statement return Node_Id is
+      Delay_Node : Node_Id;
+
+   begin
+      Delay_Node := New_Node (N_Delay_Until_Statement, Prev_Token_Ptr);
+      Scan; -- past UNTIL
+      Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
+      TF_Semicolon;
+      return Delay_Node;
+   end P_Delay_Until_Statement;
+
+   -----------------------------------
+   -- 9.6  Delay Relative Statement --
+   -----------------------------------
+
+   --  DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION;
+
+   --  The caller has checked that the initial token is DELAY, scanned it
+   --  out and determined that the current token is not UNTIL
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Delay_Relative_Statement return Node_Id is
+      Delay_Node : Node_Id;
+
+   begin
+      Delay_Node := New_Node (N_Delay_Relative_Statement, Prev_Token_Ptr);
+      Set_Expression (Delay_Node, P_Expression_No_Right_Paren);
+      Check_Simple_Expression_In_Ada_83 (Expression (Delay_Node));
+      TF_Semicolon;
+      return Delay_Node;
+   end P_Delay_Relative_Statement;
+
+   ---------------------------
+   -- 9.7  Select Statement --
+   ---------------------------
+
+   --  SELECT_STATEMENT ::=
+   --    SELECTIVE_ACCEPT
+   --  | TIMED_ENTRY_CALL
+   --  | CONDITIONAL_ENTRY_CALL
+   --  | ASYNCHRONOUS_SELECT
+
+   --  SELECTIVE_ACCEPT ::=
+   --    select
+   --      [GUARD]
+   --        SELECT_ALTERNATIVE
+   --    {or
+   --      [GUARD]
+   --        SELECT_ALTERNATIVE
+   --    [else
+   --      SEQUENCE_OF_STATEMENTS]
+   --    end select;
+
+   --  GUARD ::= when CONDITION =>
+
+   --  Note: the guard preceding a select alternative is included as part
+   --  of the node generated for a selective accept alternative.
+
+   --  SELECT_ALTERNATIVE ::=
+   --    ACCEPT_ALTERNATIVE
+   --  | DELAY_ALTERNATIVE
+   --  | TERMINATE_ALTERNATIVE
+
+   --  TIMED_ENTRY_CALL ::=
+   --    select
+   --      ENTRY_CALL_ALTERNATIVE
+   --    or
+   --      DELAY_ALTERNATIVE
+   --    end select;
+
+   --  CONDITIONAL_ENTRY_CALL ::=
+   --    select
+   --      ENTRY_CALL_ALTERNATIVE
+   --    else
+   --      SEQUENCE_OF_STATEMENTS
+   --    end select;
+
+   --  ENTRY_CALL_ALTERNATIVE ::=
+   --    ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+   --  ASYNCHRONOUS_SELECT ::=
+   --    select
+   --      TRIGGERING_ALTERNATIVE
+   --    then abort
+   --      ABORTABLE_PART
+   --    end select;
+
+   --  TRIGGERING_ALTERNATIVE ::=
+   --    TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+   --  TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT
+
+   --  The caller has checked that the initial token is SELECT
+
+   --  Error recovery: can raise Error_Resync
+
+   function P_Select_Statement return Node_Id is
+      Select_Node    : Node_Id;
+      Select_Sloc    : Source_Ptr;
+      Stmnt_Sloc     : Source_Ptr;
+      Ecall_Node     : Node_Id;
+      Alternative    : Node_Id;
+      Select_Pragmas : List_Id;
+      Alt_Pragmas    : List_Id;
+      Statement_List : List_Id;
+      Alt_List       : List_Id;
+      Cond_Expr      : Node_Id;
+      Delay_Stmnt    : Node_Id;
+
+   begin
+      Push_Scope_Stack;
+      Scope.Table (Scope.Last).Etyp := E_Select;
+      Scope.Table (Scope.Last).Ecol := Start_Column;
+      Scope.Table (Scope.Last).Sloc := Token_Ptr;
+      Scope.Table (Scope.Last).Labl := Error;
+
+      Select_Sloc := Token_Ptr;
+      Scan; -- past SELECT
+      Stmnt_Sloc := Token_Ptr;
+      Select_Pragmas := P_Pragmas_Opt;
+
+      --  If first token after select is designator, then we have an entry
+      --  call, which must be the start of a conditional entry call, timed
+      --  entry call or asynchronous select
+
+      if Token in Token_Class_Desig then
+
+         --  Scan entry call statement
+
+         begin
+            Ecall_Node := P_Name;
+
+            --  ??  The following two clauses exactly parallel code in ch5
+            --      and should be commoned sometime
+
+            if Nkind (Ecall_Node) = N_Indexed_Component then
+               declare
+                  Prefix_Node : Node_Id := Prefix (Ecall_Node);
+                  Exprs_Node  : List_Id := Expressions (Ecall_Node);
+               begin
+                  Change_Node (Ecall_Node, N_Procedure_Call_Statement);
+                  Set_Name (Ecall_Node, Prefix_Node);
+                  Set_Parameter_Associations (Ecall_Node, Exprs_Node);
+               end;
+
+            elsif Nkind (Ecall_Node) = N_Function_Call then
+               declare
+                  Fname_Node  : Node_Id := Name (Ecall_Node);
+                  Params_List : List_Id := Parameter_Associations (Ecall_Node);
+
+               begin
+                  Change_Node (Ecall_Node, N_Procedure_Call_Statement);
+                  Set_Name (Ecall_Node, Fname_Node);
+                  Set_Parameter_Associations (Ecall_Node, Params_List);
+               end;
+
+            elsif Nkind (Ecall_Node) = N_Identifier
+              or else Nkind (Ecall_Node) = N_Selected_Component
+            then
+               --  Case of a call to a parameterless entry.
+
+               declare
+                  C_Node : constant Node_Id :=
+                         New_Node (N_Procedure_Call_Statement, Stmnt_Sloc);
+               begin
+                  Set_Name (C_Node, Ecall_Node);
+                  Set_Parameter_Associations (C_Node, No_List);
+                  Ecall_Node := C_Node;
+               end;
+            end if;
+
+            TF_Semicolon;
+
+         exception
+            when Error_Resync =>
+               Resync_Past_Semicolon;
+               return Error;
+         end;
+
+         Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
+
+         --  OR follows, we have a timed entry call
+
+         if Token = Tok_Or then
+            Scan; -- past OR
+            Alt_Pragmas := P_Pragmas_Opt;
+
+            Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc);
+            Set_Entry_Call_Alternative (Select_Node,
+              Make_Entry_Call_Alternative (Stmnt_Sloc,
+                Entry_Call_Statement => Ecall_Node,
+                Pragmas_Before       => Select_Pragmas,
+                Statements           => Statement_List));
+
+            --  Only possibility is delay alternative. If we have anything
+            --  else, give message, and treat as conditional entry call.
+
+            if Token /= Tok_Delay then
+               Error_Msg_SC
+                 ("only allowed alternative in timed entry call is delay!");
+               Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
+               Set_Delay_Alternative (Select_Node, Error);
+
+            else
+               Set_Delay_Alternative (Select_Node, P_Delay_Alternative);
+               Set_Pragmas_Before
+                 (Delay_Alternative (Select_Node), Alt_Pragmas);
+            end if;
+
+         --  ELSE follows, we have a conditional entry call
+
+         elsif Token = Tok_Else then
+            Scan; -- past ELSE
+            Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc);
+
+            Set_Entry_Call_Alternative (Select_Node,
+              Make_Entry_Call_Alternative (Stmnt_Sloc,
+                Entry_Call_Statement => Ecall_Node,
+                Pragmas_Before       => Select_Pragmas,
+                Statements           => Statement_List));
+
+            Set_Else_Statements
+              (Select_Node, P_Sequence_Of_Statements (SS_Sreq));
+
+         --  Only remaining case is THEN ABORT (asynchronous select)
+
+         elsif Token = Tok_Abort then
+            Select_Node :=
+              Make_Asynchronous_Select (Select_Sloc,
+                Triggering_Alternative =>
+                  Make_Triggering_Alternative (Stmnt_Sloc,
+                    Triggering_Statement => Ecall_Node,
+                    Pragmas_Before       => Select_Pragmas,
+                    Statements           => Statement_List),
+                Abortable_Part => P_Abortable_Part);
+
+         --  Else error
+
+         else
+            if Ada_83 then
+               Error_Msg_BC ("OR or ELSE expected");
+            else
+               Error_Msg_BC ("OR or ELSE or THEN ABORT expected");
+            end if;
+
+            Select_Node := Error;
+         end if;
+
+         End_Statements;
+
+      --  Here we have a selective accept or an an asynchronous select (first
+      --  token after SELECT is other than a designator token).
+
+      else
+         --  If we have delay with no guard, could be asynchronous select
+
+         if Token = Tok_Delay then
+            Delay_Stmnt := P_Delay_Statement;
+            Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm);
+
+            --  Asynchronous select
+
+            if Token = Tok_Abort then
+               Select_Node :=
+                 Make_Asynchronous_Select (Select_Sloc,
+                   Triggering_Alternative =>
+                     Make_Triggering_Alternative (Stmnt_Sloc,
+                       Triggering_Statement => Delay_Stmnt,
+                       Pragmas_Before       => Select_Pragmas,
+                       Statements           => Statement_List),
+                     Abortable_Part => P_Abortable_Part);
+
+               End_Statements;
+               return Select_Node;
+
+            --  Delay which was not an asynchronous select. Must be a selective
+            --  accept, and since at least one accept statement is required,
+            --  we must have at least one OR phrase present.
+
+            else
+               Alt_List := New_List (
+                 Make_Delay_Alternative (Stmnt_Sloc,
+                   Delay_Statement => Delay_Stmnt,
+                   Pragmas_Before  => Select_Pragmas,
+                   Statements      => Statement_List));
+               T_Or;
+               Alt_Pragmas := P_Pragmas_Opt;
+            end if;
+
+         --  If not a delay statement, then must be another possibility for
+         --  a selective accept alternative, or perhaps a guard is present
+
+         else
+            Alt_List := New_List;
+            Alt_Pragmas := Select_Pragmas;
+         end if;
+
+         Select_Node := New_Node (N_Selective_Accept, Select_Sloc);
+         Set_Select_Alternatives (Select_Node, Alt_List);
+
+         --  Scan out selective accept alternatives. On entry to this loop,
+         --  we are just past a SELECT or OR token, and any pragmas that
+         --  immediately follow the SELECT or OR are in Alt_Pragmas.
+
+         loop
+            if Token = Tok_When then
+
+               if Present (Alt_Pragmas) then
+                  Error_Msg_SC ("pragmas may not precede guard");
+               end if;
+
+               Scan; --  past WHEN
+               Cond_Expr := P_Expression_No_Right_Paren;
+               T_Arrow;
+               Alt_Pragmas := P_Pragmas_Opt;
+
+            else
+               Cond_Expr := Empty;
+            end if;
+
+            if Token = Tok_Accept then
+               Alternative := P_Accept_Alternative;
+
+               --  Check for junk attempt at asynchronous select using
+               --  an Accept alternative as the triggering statement
+
+               if Token = Tok_Abort
+                 and then Is_Empty_List (Alt_List)
+                 and then No (Cond_Expr)
+               then
+                  Error_Msg
+                    ("triggering statement must be entry call or delay",
+                     Sloc (Alternative));
+                  Scan; -- past junk ABORT
+                  Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
+                  End_Statements;
+                  return Error;
+               end if;
+
+            elsif Token = Tok_Delay then
+               Alternative := P_Delay_Alternative;
+
+            elsif Token = Tok_Terminate then
+               Alternative := P_Terminate_Alternative;
+
+            else
+               Error_Msg_SC
+                 ("Select alternative (ACCEPT, ABORT, DELAY) expected");
+               Alternative := Error;
+
+               if Token = Tok_Semicolon then
+                  Scan; -- past junk semicolon
+               end if;
+            end if;
+
+            --  THEN ABORT at this stage is just junk
+
+            if Token = Tok_Abort then
+               Error_Msg_SP ("misplaced `THEN ABORT`");
+               Scan; -- past junk ABORT
+               Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq));
+               End_Statements;
+               return Error;
+
+            else
+               if Alternative /= Error then
+                  Set_Condition (Alternative, Cond_Expr);
+                  Set_Pragmas_Before (Alternative, Alt_Pragmas);
+                  Append (Alternative, Alt_List);
+               end if;
+
+               exit when Token /= Tok_Or;
+            end if;
+
+            T_Or;
+            Alt_Pragmas := P_Pragmas_Opt;
+         end loop;
+
+         if Token = Tok_Else then
+            Scan; -- past ELSE
+            Set_Else_Statements
+              (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq));
+
+            if Token = Tok_Or then
+               Error_Msg_SC ("select alternative cannot follow else part!");
+            end if;
+         end if;
+
+         End_Statements;
+      end if;
+
+      return Select_Node;
+   end P_Select_Statement;
+
+   -----------------------------
+   -- 9.7.1  Selective Accept --
+   -----------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   ------------------
+   -- 9.7.1  Guard --
+   ------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   -------------------------------
+   -- 9.7.1  Select Alternative --
+   -------------------------------
+
+   --  SELECT_ALTERNATIVE ::=
+   --    ACCEPT_ALTERNATIVE
+   --  | DELAY_ALTERNATIVE
+   --  | TERMINATE_ALTERNATIVE
+
+   --  Note: the guard preceding a select alternative is included as part
+   --  of the node generated for a selective accept alternative.
+
+   --  Error recovery: cannot raise Error_Resync
+
+   -------------------------------
+   -- 9.7.1  Accept Alternative --
+   -------------------------------
+
+   --  ACCEPT_ALTERNATIVE ::=
+   --    ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+   --  Error_Recovery: Cannot raise Error_Resync
+
+   --  Note: the caller is responsible for setting the Pragmas_Before
+   --  field of the returned N_Terminate_Alternative node.
+
+   function P_Accept_Alternative return Node_Id is
+      Accept_Alt_Node : Node_Id;
+
+   begin
+      Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr);
+      Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement);
+
+      --  Note: the reason that we accept THEN ABORT as a terminator for
+      --  the sequence of statements is for error recovery which allows
+      --  for misuse of an accept statement as a triggering statememt.
+
+      Set_Statements
+        (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
+      return Accept_Alt_Node;
+   end P_Accept_Alternative;
+
+   ------------------------------
+   -- 9.7.1  Delay Alternative --
+   ------------------------------
+
+   --  DELAY_ALTERNATIVE ::=
+   --    DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS]
+
+   --  Error_Recovery: Cannot raise Error_Resync
+
+   --  Note: the caller is responsible for setting the Pragmas_Before
+   --  field of the returned N_Terminate_Alternative node.
+
+   function P_Delay_Alternative return Node_Id is
+      Delay_Alt_Node : Node_Id;
+
+   begin
+      Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr);
+      Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement);
+
+      --  Note: the reason that we accept THEN ABORT as a terminator for
+      --  the sequence of statements is for error recovery which allows
+      --  for misuse of an accept statement as a triggering statememt.
+
+      Set_Statements
+        (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm));
+      return Delay_Alt_Node;
+   end P_Delay_Alternative;
+
+   ----------------------------------
+   -- 9.7.1  Terminate Alternative --
+   ----------------------------------
+
+   --  TERMINATE_ALTERNATIVE ::= terminate;
+
+   --  Error_Recovery: Cannot raise Error_Resync
+
+   --  Note: the caller is responsible for setting the Pragmas_Before
+   --  field of the returned N_Terminate_Alternative node.
+
+   function P_Terminate_Alternative return Node_Id is
+      Terminate_Alt_Node : Node_Id;
+
+   begin
+      Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr);
+      Scan; -- past TERMINATE
+      TF_Semicolon;
+
+      --  For all other select alternatives, the sequence of statements
+      --  after the alternative statement will swallow up any pragmas
+      --  coming in this position. But the terminate alternative has no
+      --  sequence of statements, so the pragmas here must be treated
+      --  specially.
+
+      Set_Pragmas_After (Terminate_Alt_Node, P_Pragmas_Opt);
+      return Terminate_Alt_Node;
+   end P_Terminate_Alternative;
+
+   -----------------------------
+   -- 9.7.2  Timed Entry Call --
+   -----------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   -----------------------------------
+   -- 9.7.2  Entry Call Alternative --
+   -----------------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   -----------------------------------
+   -- 9.7.3  Conditional Entry Call --
+   -----------------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   --------------------------------
+   -- 9.7.4  Asynchronous Select --
+   --------------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   -----------------------------------
+   -- 9.7.4  Triggering Alternative --
+   -----------------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   ---------------------------------
+   -- 9.7.4  Triggering Statement --
+   ---------------------------------
+
+   --  Parsed by P_Select_Statement (9.7)
+
+   ---------------------------
+   -- 9.7.4  Abortable Part --
+   ---------------------------
+
+   --  ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS
+
+   --  The caller has verified that THEN ABORT is present, and Token is
+   --  pointing to the ABORT on entry (or if not, then we have an error)
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Abortable_Part return Node_Id is
+      Abortable_Part_Node : Node_Id;
+
+   begin
+      Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr);
+      T_Abort; -- scan past ABORT
+
+      if Ada_83 then
+         Error_Msg_SP ("(Ada 83) asynchronous select not allowed!");
+      end if;
+
+      Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq));
+      return Abortable_Part_Node;
+   end P_Abortable_Part;
+
+   --------------------------
+   -- 9.8  Abort Statement --
+   --------------------------
+
+   --  ABORT_STATEMENT ::= abort task_NAME {, task_NAME};
+
+   --  The caller has checked that the initial token is ABORT
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Abort_Statement return Node_Id is
+      Abort_Node : Node_Id;
+
+   begin
+      Abort_Node := New_Node (N_Abort_Statement, Token_Ptr);
+      Scan; -- past ABORT
+      Set_Names (Abort_Node, New_List);
+
+      loop
+         Append (P_Name, Names (Abort_Node));
+         exit when Token /= Tok_Comma;
+         Scan; -- past comma
+      end loop;
+
+      TF_Semicolon;
+      return Abort_Node;
+   end P_Abort_Statement;
+
+end Ch9;
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
new file mode 100644
index 0000000..fa5b8c2
--- /dev/null
+++ b/gcc/ada/par-endh.adb
@@ -0,0 +1,1191 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . E N D H                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.61 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Stringt; use Stringt;
+with Uintp;   use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+separate (Par)
+package body Endh is
+
+   ----------------
+   -- Local Data --
+   ----------------
+
+   type End_Action_Type is (
+   --  Type used to describe the result of the Pop_End_Context call
+
+      Accept_As_Scanned,
+      --  Current end sequence is entirely c correct. In this case Token and
+      --  the scan pointer are left pointing past the end sequence (i.e. they
+      --  are unchanged from the values set on entry to Pop_End_Context).
+
+      Insert_And_Accept,
+      --  Current end sequence is to be left in place to satisfy some outer
+      --  scope. Token and the scan pointer are set to point to the end
+      --  token, and should be left there. A message has been generated
+      --  indicating a missing end sequence. This status is also used for
+      --  the case when no end token is present.
+
+      Skip_And_Accept,
+      --  The end sequence is incorrect (and an error message has been
+      --  posted), but it will still be accepted. In this case Token and
+      --  the scan pointer point back to the end token, and the caller
+      --  should skip past the end sequence before proceeding.
+
+      Skip_And_Reject);
+      --  The end sequence is judged to belong to an unrecognized inner
+      --  scope. An appropriate message has been issued and the caller
+      --  should skip past the end sequence and then proceed as though
+      --  no end sequence had been encountered.
+
+   End_Action : End_Action_Type;
+   --  The variable set by Pop_End_Context call showing which of the four
+   --  decisions described above is judged the best.
+
+   End_Sloc : Source_Ptr;
+   --  Source location of END token
+
+   End_OK : Boolean;
+   --  Set False if error is found in END line
+
+   End_Column : Column_Number;
+   --  Column of END line
+
+   End_Type : SS_End_Type;
+   --  Type of END expected. The special value E_Dummy is set to indicate that
+   --  no END token was present (so a missing END inserted message is needed)
+
+   End_Labl : Node_Id;
+   --  Node_Id value for explicit name on END line, or for compiler supplied
+   --  name in the case where an optional name is not given. Empty if no name
+   --  appears. If non-empty, then it is either an N_Designator node for a
+   --  child unit or a node with a Chars field identifying the actual label.
+
+   End_Labl_Present : Boolean;
+   --  Indicates that the value in End_Labl was for an explicit label.
+
+   Syntax_OK : Boolean;
+   --  Set True if the entry is syntactically correct
+
+   Token_OK : Boolean;
+   --  Set True if the keyword in the END sequence matches, or if neither
+   --  the END sequence nor the END stack entry has a keyword.
+
+   Label_OK : Boolean;
+   --  Set True if both the END sequence and the END stack entry contained
+   --  labels (other than No_Name or Error_Name) and the labels matched.
+   --  This is a stronger condition than SYNTAX_OK, since it means that a
+   --  label was present, even in a case where it was optional. Note that
+   --  the case of no label required, and no label present does NOT set
+   --  Label_OK to True, it is True only if a positive label match is found.
+
+   Column_OK : Boolean;
+   --  Column_OK is set True if the END sequence appears in the expected column
+
+   Scan_State : Saved_Scan_State;
+   --  Save state at start of END sequence, in case we decide not to eat it up
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Evaluate_End_Entry (SS_Index : Int);
+   --  Compare scanned END entry (as recorded by a prior call to P_End_Scan)
+   --  with a specified entry in the scope stack (the single parameter is the
+   --  entry index in the scope stack). Note that Scan is not called. The above
+   --  variables xxx_OK are set to indicate the result of the evaluation.
+
+   procedure Output_End_Deleted;
+   --  Output a message complaining that the current END structure does not
+   --  match anything and is being deleted.
+
+   procedure Output_End_Expected (Ins : Boolean);
+   --  Output a message at the start of the current token which is always an
+   --  END, complaining that the END is not of the right form. The message
+   --  indicates the expected form. The information for the message is taken
+   --  from the top entry in the scope stack. The Ins parameter is True if
+   --  an end is being inserted, and false if an existing end is being
+   --  replaced. Note that in the case of a suspicious IS for the Ins case,
+   --  we do not output the message, but instead simply mark the scope stack
+   --  entry as being a case of a bad IS.
+
+   procedure Output_End_Missing;
+   --  Output a message just before the current token, complaining that the
+   --  END is not of the right form. The message indicates the expected form.
+   --  The information for the message is taken from the top entry in the
+   --  scope stack. Note that in the case of a suspicious IS, we do not output
+   --  the message, but instead simply mark the scope stack entry as a bad IS.
+
+   procedure Pop_End_Context;
+   --  Pop_End_Context is called after processing a construct, to pop the
+   --  top entry off the end stack. It decides on the appropriate action to
+   --  to take, signalling the result by setting End_Action as described in
+   --  the global variable section.
+
+   function Same_Label (Label1, Label2 : Node_Id) return Boolean;
+   --  This function compares the two names associated with the given nodes.
+   --  If they are both simple (i.e. have Chars fields), then they have to
+   --  be the same name. Otherwise they must both be N_Selected_Component
+   --  nodes, referring to the same set of names, or Label1 is an N_Designator
+   --  referring to the same set of names as the N_Defining_Program_Unit_Name
+   --  in Label2. Any other combination returns False. This routine is used
+   --  to compare the End_Labl scanned from the End line with the saved label
+   --  value in the scope stack.
+
+   ---------------
+   -- Check_End --
+   ---------------
+
+   function Check_End return Boolean is
+      Name_On_Separate_Line : Boolean;
+      --  Set True if the name on an END line is on a separate source line
+      --  from the END. This is highly suspicious, but is allowed. The point
+      --  is that we want to make sure that we don't just have a missing
+      --  semicolon misleading us into swallowing an identifier from the
+      --  following line.
+
+      Name_Scan_State : Saved_Scan_State;
+      --  Save state at start of name if Name_On_Separate_Line is TRUE
+
+      Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node;
+
+   begin
+      End_Labl_Present := False;
+      End_Labl := Empty;
+
+      --  Our first task is to scan out the END sequence if one is present.
+      --  If none is present, signal by setting End_Type to E_Dummy.
+
+      if Token /= Tok_End then
+         End_Type := E_Dummy;
+
+      else
+         Save_Scan_State (Scan_State); -- at END
+         End_Sloc := Token_Ptr;
+         End_Column := Start_Column;
+         End_OK := True;
+         Scan; -- past END
+
+         --  Set End_Span if expected. note that this will be useless
+         --  if we do not have the right ending keyword, but in this
+         --  case we have a malformed program anyway, and the setting
+         --  of End_Span will simply be unreliable in this case anyway.
+
+         if Present (Span_Node) then
+            Set_End_Location (Span_Node, Token_Ptr);
+         end if;
+
+         --  Cases of keywords where no label is allowed
+
+         if Token = Tok_Case then
+            End_Type := E_Case;
+            Scan; -- past CASE
+
+         elsif Token = Tok_If then
+            End_Type := E_If;
+            Scan; -- past IF
+
+         elsif Token = Tok_Record then
+            End_Type := E_Record;
+            Scan; -- past RECORD
+
+         elsif Token = Tok_Select then
+            End_Type := E_Select;
+            Scan; -- past SELECT
+
+         --  Cases which do allow labels
+
+         else
+            --  LOOP
+
+            if Token = Tok_Loop then
+               Scan; -- past LOOP
+               End_Type := E_Loop;
+
+            --  FOR or WHILE allowed (signalling error) to substitute for LOOP
+            --  if on the same line as the END
+
+            elsif (Token = Tok_For or else Token = Tok_While)
+              and then not Token_Is_At_Start_Of_Line
+            then
+               Scan; -- past FOR or WHILE
+               End_Type := E_Loop;
+               End_OK := False;
+
+            --  Cases with no keyword
+
+            else
+               End_Type := E_Name;
+            end if;
+
+            --  Now see if a name is present
+
+            if Token = Tok_Identifier or else
+               Token = Tok_String_Literal or else
+               Token = Tok_Operator_Symbol
+            then
+               if Token_Is_At_Start_Of_Line then
+                  Name_On_Separate_Line := True;
+                  Save_Scan_State (Name_Scan_State);
+               else
+                  Name_On_Separate_Line := False;
+               end if;
+
+               End_Labl := P_Designator;
+               End_Labl_Present := True;
+
+               --  We have now scanned out a name. Here is where we do a check
+               --  to catch the cases like:
+               --
+               --    end loop
+               --    X := 3;
+               --
+               --  where the missing semicolon might make us swallow up the X
+               --  as a bogus end label. In a situation like this, where the
+               --  apparent name is on a separate line, we accept it only if
+               --  it matches the label and is followed by a semicolon.
+
+               if Name_On_Separate_Line then
+                  if Token /= Tok_Semicolon or else
+                    not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl)
+                  then
+                     Restore_Scan_State (Name_Scan_State);
+                     End_Labl := Empty;
+                     End_Labl_Present := False;
+                  end if;
+               end if;
+
+            --  Here for case of name allowed, but no name present. We will
+            --  supply an implicit matching name, with source location set
+            --  to the scan location past the END token.
+
+            else
+               End_Labl := Scope.Table (Scope.Last).Labl;
+
+               if End_Labl > Empty_Or_Error then
+
+                  --  The task here is to construct a designator from the
+                  --  opening label, with the components all marked as not
+                  --  from source, and Is_End_Label set in the identifier
+                  --  or operator symbol. The location for all components
+                  --  is the curent token location.
+
+                  --  Case of child unit name
+
+                  if Nkind (End_Labl) = N_Defining_Program_Unit_Name then
+                     declare
+                        Eref : constant Node_Id :=
+                                 Make_Identifier (Token_Ptr,
+                                   Chars =>
+                                     Chars (Defining_Identifier (End_Labl)));
+
+                        function Copy_Name (N : Node_Id) return Node_Id;
+                        --  Copies a selected component or identifier
+
+                        function Copy_Name (N : Node_Id) return Node_Id is
+                           R : Node_Id;
+
+                        begin
+                           if Nkind (N) = N_Selected_Component then
+                              return
+                                Make_Selected_Component (Token_Ptr,
+                                  Prefix        =>
+                                    Copy_Name (Prefix (N)),
+                                  Selector_Name =>
+                                    Copy_Name (Selector_Name (N)));
+
+                           else
+                              R :=
+                                Make_Identifier (Token_Ptr,
+                                  Chars => Chars (N));
+                              Set_Comes_From_Source (N, False);
+                              return R;
+                           end if;
+                        end Copy_Name;
+
+                     begin
+                        Set_Comes_From_Source (Eref, False);
+
+                        End_Labl :=
+                          Make_Designator (Token_Ptr,
+                            Name       => Copy_Name (Name (End_Labl)),
+                            Identifier => Eref);
+                     end;
+
+                  --  Simple identifier case
+
+                  elsif Nkind (End_Labl) = N_Defining_Identifier
+                    or else Nkind (End_Labl) = N_Identifier
+                  then
+                     End_Labl :=
+                       Make_Identifier (Token_Ptr,
+                         Chars => Chars (End_Labl));
+
+                  elsif Nkind (End_Labl) = N_Defining_Operator_Symbol
+                    or else Nkind (End_Labl) = N_Operator_Symbol
+                  then
+                     Get_Decoded_Name_String (Chars (End_Labl));
+
+                     End_Labl :=
+                       Make_Operator_Symbol (Token_Ptr,
+                         Chars  => Chars (End_Labl),
+                         Strval => String_From_Name_Buffer);
+                  end if;
+
+                  Set_Comes_From_Source (End_Labl, False);
+                  End_Labl_Present := False;
+
+                  --  Do style check for missing label
+
+                  if Style_Check
+                    and then End_Type = E_Name
+                    and then Present (Scope.Table (Scope.Last).Labl)
+                  then
+                     Style.No_End_Name (Scope.Table (Scope.Last).Labl);
+                  end if;
+               end if;
+            end if;
+         end if;
+
+         --  Except in case of END RECORD, semicolon must follow. For END
+         --  RECORD, a semicolon does follow, but it is part of a higher level
+         --  construct. In any case, a missing semicolon is not serious enough
+         --  to consider the END statement to be bad in the sense that we
+         --  are dealing with (i.e. to be suspicious that it is not in fact
+         --  the END statement we are looking for!)
+
+         if End_Type /= E_Record then
+            if Token = Tok_Semicolon then
+               T_Semicolon;
+
+            --  Semicolon is missing. If the missing semicolon is at the end
+            --  of the line, i.e. we are at the start of the line now, then
+            --  a missing semicolon gets flagged, but is not serious enough
+            --  to consider the END statement to be bad in the sense that we
+            --  are dealing with (i.e. to be suspicious that this END is not
+            --  the END statement we are looking for).
+
+            --  Similarly, if we are at a colon, we flag it but a colon for
+            --  a semicolon is not serious enough to consider the END to be
+            --  incorrect. Same thing for a period in place of a semicolon.
+
+            elsif Token_Is_At_Start_Of_Line
+              or else Token = Tok_Colon
+              or else Token = Tok_Dot
+            then
+               T_Semicolon;
+
+            --  If the missing semicolon is not at the start of the line,
+            --  then we do consider the END line to be dubious in this sense.
+
+            else
+               End_OK := False;
+            end if;
+         end if;
+      end if;
+
+      --  Now we call the Pop_End_Context routine to get a recommendation
+      --  as to what should be done with the END sequence we have scanned.
+
+      Pop_End_Context;
+
+      --  Remaining action depends on End_Action set by Pop_End_Context
+
+      case End_Action is
+
+         --  Accept_As_Scanned. In this case, Pop_End_Context left Token
+         --  pointing past the last token of a syntactically correct END
+
+         when Accept_As_Scanned =>
+
+            --  Syntactically correct included the possibility of a missing
+            --  semicolon. If we do have a missing semicolon, then we have
+            --  already given a message, but now we scan out possible rubbish
+            --  on the same line as the END
+
+            while not Token_Is_At_Start_Of_Line
+              and then Prev_Token /= Tok_Record
+              and then Prev_Token /= Tok_Semicolon
+              and then Token /= Tok_End
+              and then Token /= Tok_EOF
+            loop
+               Scan; -- past junk
+            end loop;
+
+            return True;
+
+         --  Insert_And_Accept. In this case, Pop_End_Context has reset Token
+         --  to point to the start of the END sequence, and recommends that it
+         --  be left in place to satisfy an outer scope level END. This means
+         --  that we proceed as though an END were present, and leave the scan
+         --  pointer unchanged.
+
+         when Insert_And_Accept =>
+            return True;
+
+         --  Skip_And_Accept. In this case, Pop_End_Context has reset Token
+         --  to point to the start of the END sequence. This END sequence is
+         --  syntactically incorrect, and an appropriate error message has
+         --  already been posted. Pop_End_Context recommends accepting the
+         --  END sequence as the one we want, so we skip past it and then
+         --  proceed as though an END were present.
+
+         when Skip_And_Accept =>
+            End_Skip;
+            return True;
+
+         --  Skip_And_Reject. In this case, Pop_End_Context has reset Token
+         --  to point to the start of the END sequence. This END sequence is
+         --  syntactically incorrect, and an appropriate error message has
+         --  already been posted. Pop_End_Context recommends entirely ignoring
+         --  this END sequence, so we skip past it and then return False, since
+         --  as far as the caller is concerned, no END sequence is present.
+
+         when Skip_And_Reject =>
+            End_Skip;
+            return False;
+      end case;
+   end Check_End;
+
+   --------------
+   -- End Skip --
+   --------------
+
+   --  This procedure skips past an END sequence. On entry Token contains
+   --  Tok_End, and we know that the END sequence is syntactically incorrect,
+   --  and that an appropriate error message has already been posted. The
+   --  mission is simply to position the scan pointer to be the best guess of
+   --  the position after the END sequence. We do not issue any additional
+   --  error messages while carrying this out.
+
+   --  Error recovery: does not raise Error_Resync
+
+   procedure End_Skip is
+   begin
+      Scan; -- past END
+
+      --  If the scan past the END leaves us on the next line, that's probably
+      --  where we should quit the scan, since it is likely that what we have
+      --  is a missing semicolon. Consider the following:
+
+      --       END
+      --       Process_Input;
+
+      --  This will have looked like a syntactically valid END sequence to the
+      --  initial scan of the END, but subsequent checking will have determined
+      --  that the label Process_Input is not an appropriate label. The real
+      --  error is a missing semicolon after the END, and by leaving the scan
+      --  pointer just past the END, we will improve the error recovery.
+
+      if Token_Is_At_Start_Of_Line then
+         return;
+      end if;
+
+      --  If there is a semicolon after the END, scan it out and we are done
+
+      if Token = Tok_Semicolon then
+         T_Semicolon;
+         return;
+      end if;
+
+      --  Otherwise skip past a token after the END on the same line. Note
+      --  that we do not eat a token on the following line since it seems
+      --  very unlikely in any case that the END gets separated from its
+      --  token, and we do not want to swallow up a keyword that starts a
+      --  legitimate construct following the bad END.
+
+      if not Token_Is_At_Start_Of_Line
+        and then
+
+         --  Cases of normal tokens following an END
+
+          (Token = Tok_Case   or else
+           Token = Tok_For    or else
+           Token = Tok_If     or else
+           Token = Tok_Loop   or else
+           Token = Tok_Record or else
+           Token = Tok_Select or else
+
+         --  Cases of bogus keywords ending loops
+
+           Token = Tok_For    or else
+           Token = Tok_While  or else
+
+         --  Cases of operator symbol names without quotes
+
+           Token = Tok_Abs    or else
+           Token = Tok_And    or else
+           Token = Tok_Mod    or else
+           Token = Tok_Not    or else
+           Token = Tok_Or     or else
+           Token = Tok_Xor)
+
+      then
+         Scan; -- past token after END
+
+         --  If that leaves us on the next line, then we are done. This is the
+         --  same principle described above for the case of END at line end
+
+         if Token_Is_At_Start_Of_Line then
+            return;
+
+         --  If we just scanned out record, then we are done, since the
+         --  semicolon after END RECORD is not part of the END sequence
+
+         elsif Prev_Token = Tok_Record then
+            return;
+
+         --  If we have a semicolon, scan it out and we are done
+
+         elsif Token = Tok_Semicolon then
+            T_Semicolon;
+            return;
+         end if;
+      end if;
+
+      --  Check for a label present on the same line
+
+      loop
+         if Token_Is_At_Start_Of_Line then
+            return;
+         end if;
+
+         if Token /= Tok_Identifier
+           and then Token /= Tok_Operator_Symbol
+           and then Token /= Tok_String_Literal
+         then
+            exit;
+         end if;
+
+         Scan; -- past identifier, operator symbol or string literal
+
+         if Token_Is_At_Start_Of_Line then
+            return;
+         elsif Token = Tok_Dot then
+            Scan; -- past dot
+         end if;
+      end loop;
+
+      --  Skip final semicolon
+
+      if Token = Tok_Semicolon then
+         T_Semicolon;
+
+      --  If we don't have a final semicolon, skip until we either encounter
+      --  an END token, or a semicolon or the start of the next line. This
+      --  allows general junk to follow the end line (normally it is hard to
+      --  think that anyone will put anything deliberate here, and remember
+      --  that we know there is a missing semicolon in any case). We also
+      --  quite on an EOF (or else we would get stuck in an infinite loop
+      --  if there is no line end at the end of the last line of the file)
+
+      else
+         while Token /= Tok_End
+           and then Token /= Tok_EOF
+           and then Token /= Tok_Semicolon
+           and then not Token_Is_At_Start_Of_Line
+         loop
+            Scan; -- past junk token on same line
+         end loop;
+      end if;
+
+      return;
+   end End_Skip;
+
+   --------------------
+   -- End Statements --
+   --------------------
+
+   --  This procedure is called when END is required or expected to terminate
+   --  a sequence of statements. The caller has already made an appropriate
+   --  entry on the scope stack to describe the expected form of the END.
+   --  End_Statements should only be used in cases where the only appropriate
+   --  terminator is END.
+
+   --  Error recovery: cannot raise Error_Resync;
+
+   procedure End_Statements (Parent : Node_Id := Empty) is
+   begin
+      --  This loop runs more than once in the case where Check_End rejects
+      --  the END sequence, as indicated by Check_End returning False.
+
+      loop
+         if Check_End then
+            if Present (Parent) then
+               Set_End_Label (Parent, End_Labl);
+            end if;
+
+            return;
+         end if;
+
+         --  Extra statements past the bogus END are discarded. This is not
+         --  ideal for maximum error recovery, but it's too much trouble to
+         --  find an appropriate place to put them!
+
+         Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
+      end loop;
+   end End_Statements;
+
+   ------------------------
+   -- Evaluate End Entry --
+   ------------------------
+
+   procedure Evaluate_End_Entry (SS_Index : Int) is
+   begin
+      Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);
+
+      Token_OK  := (End_Type = Scope.Table (SS_Index).Etyp or else
+                     (End_Type = E_Name and then
+                       Scope.Table (SS_Index).Etyp >= E_Name));
+
+      Label_OK := End_Labl_Present
+                    and then
+                      (Same_Label (End_Labl, Scope.Table (SS_Index).Labl)
+                        or else Scope.Table (SS_Index).Labl = Error);
+
+      --  Compute setting of Syntax_OK. We definitely have a syntax error
+      --  if the Token does not match properly or if P_End_Scan detected
+      --  a syntax error such as a missing semicolon.
+
+      if not Token_OK or not End_OK then
+         Syntax_OK := False;
+
+      --  Final check is that label is OK. Certainly it is OK if there
+      --  was an exact match on the label (the END label = the stack label)
+
+      elsif Label_OK then
+         Syntax_OK := True;
+
+      --  Case of label present
+
+      elsif End_Labl_Present then
+
+         --  If probably misspelling, then complain, and pretend it is OK
+
+         declare
+            Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;
+
+         begin
+            if Nkind (End_Labl) in N_Has_Chars
+              and then Nkind (Nam) in N_Has_Chars
+              and then Chars (End_Labl) > Error_Name
+              and then Chars (Nam) > Error_Name
+            then
+               Get_Name_String (Chars (End_Labl));
+               Error_Msg_Name_1 := Chars (Nam);
+
+               if Error_Msg_Name_1 > Error_Name then
+                  declare
+                     S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+
+                  begin
+                     Get_Name_String (Error_Msg_Name_1);
+
+                     if Is_Bad_Spelling_Of
+                         (Name_Buffer (1 .. Name_Len), S)
+                     then
+                        Error_Msg_N ("misspelling of %", End_Labl);
+                        Syntax_OK := True;
+                        return;
+                     end if;
+                  end;
+               end if;
+            end if;
+         end;
+
+         Syntax_OK := False;
+
+      --  Otherwise we have cases of no label on the END line. For the loop
+      --  case, this is acceptable only if the loop is unlabeled.
+
+      elsif End_Type = E_Loop then
+         Syntax_OK := (Scope.Table (SS_Index).Labl = Empty);
+
+      --  Cases where a label is definitely allowed on the END line
+
+      elsif End_Type = E_Name then
+         Syntax_OK := (Scope.Table (SS_Index).Labl = Empty or else
+                         not Scope.Table (SS_Index).Lreq);
+
+      --  Otherwise we have cases which don't allow labels anyway, so we
+      --  certainly accept an END which does not have a label.
+
+      else
+         Syntax_OK := True;
+      end if;
+   end Evaluate_End_Entry;
+
+   ------------------------
+   -- Output End Deleted --
+   ------------------------
+
+   procedure Output_End_Deleted is
+   begin
+
+      if End_Type = E_Loop then
+         Error_Msg_SC ("no LOOP for this `END LOOP`!");
+
+      elsif End_Type = E_Case then
+         Error_Msg_SC ("no CASE for this `END CASE`");
+
+      elsif End_Type = E_If then
+         Error_Msg_SC ("no IF for this `END IF`!");
+
+      elsif End_Type = E_Record then
+         Error_Msg_SC ("no RECORD for this `END RECORD`!");
+
+      elsif End_Type = E_Select then
+         Error_Msg_SC ("no SELECT for this `END SELECT`!");
+
+      else
+         Error_Msg_SC ("no BEGIN for this END!");
+      end if;
+   end Output_End_Deleted;
+
+   -------------------------
+   -- Output End Expected --
+   -------------------------
+
+   procedure Output_End_Expected (Ins : Boolean) is
+      End_Type : SS_End_Type;
+
+   begin
+      --  Suppress message if this was a potentially junk entry (e.g. a
+      --  record entry where no record keyword was present.
+
+      if Scope.Table (Scope.Last).Junk then
+         return;
+      end if;
+
+      End_Type := Scope.Table (Scope.Last).Etyp;
+      Error_Msg_Col    := Scope.Table (Scope.Last).Ecol;
+      Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+      Error_Msg_Sloc   := Scope.Table (Scope.Last).Sloc;
+
+      --  Suppress message if error was posted on opening label
+
+      if Present (Error_Msg_Node_1)
+        and then Error_Posted (Error_Msg_Node_1)
+      then
+         return;
+      end if;
+
+      if End_Type = E_Case then
+         Error_Msg_SC ("`END CASE;` expected@ for CASE#!");
+
+      elsif End_Type = E_If then
+         Error_Msg_SC ("`END IF;` expected@ for IF#!");
+
+      elsif End_Type = E_Loop then
+         if Error_Msg_Node_1 = Empty then
+            Error_Msg_SC
+              ("`END LOOP;` expected@ for LOOP#!");
+         else
+            Error_Msg_SC ("`END LOOP &;` expected@!");
+         end if;
+
+      elsif End_Type = E_Record then
+         Error_Msg_SC
+           ("`END RECORD;` expected@ for RECORD#!");
+
+      elsif End_Type = E_Select then
+         Error_Msg_SC
+           ("`END SELECT;` expected@ for SELECT#!");
+
+      --  All remaining cases are cases with a name (we do not treat
+      --  the suspicious is cases specially for a replaced end, only
+      --  for an inserted end).
+
+      elsif End_Type = E_Name or else (not Ins) then
+         if Error_Msg_Node_1 = Empty then
+            Error_Msg_SC ("`END;` expected@ for BEGIN#!");
+         else
+            Error_Msg_SC ("`END &;` expected@!");
+         end if;
+
+      --  The other possibility is a missing END for a subprogram with a
+      --  suspicious IS (that probably should have been a semicolon). The
+      --  Missing IS confirms the suspicion!
+
+      else -- End_Type = E_Suspicious_Is or E_Bad_Is
+         Scope.Table (Scope.Last).Etyp := E_Bad_Is;
+      end if;
+   end Output_End_Expected;
+
+   ------------------------
+   -- Output End Missing --
+   ------------------------
+
+   procedure Output_End_Missing is
+      End_Type : SS_End_Type;
+
+   begin
+      --  Suppress message if this was a potentially junk entry (e.g. a
+      --  record entry where no record keyword was present.
+
+      if Scope.Table (Scope.Last).Junk then
+         return;
+      end if;
+
+      End_Type := Scope.Table (Scope.Last).Etyp;
+      Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+      Error_Msg_Sloc   := Scope.Table (Scope.Last).Sloc;
+
+      if End_Type = E_Case then
+         Error_Msg_BC ("missing `END CASE;` for CASE#!");
+
+      elsif End_Type = E_If then
+         Error_Msg_BC ("missing `END IF;` for IF#!");
+
+      elsif End_Type = E_Loop then
+         if Error_Msg_Node_1 = Empty then
+            Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
+         else
+            Error_Msg_BC ("missing `END LOOP &;`!");
+         end if;
+
+      elsif End_Type = E_Record then
+         Error_Msg_SC
+           ("missing `END RECORD;` for RECORD#!");
+
+      elsif End_Type = E_Select then
+         Error_Msg_BC
+           ("missing `END SELECT;` for SELECT#!");
+
+      elsif End_Type = E_Name then
+         if Error_Msg_Node_1 = Empty then
+            Error_Msg_BC ("missing `END;` for BEGIN#!");
+         else
+            Error_Msg_BC ("missing `END &;`!");
+         end if;
+
+      else -- End_Type = E_Suspicious_Is or E_Bad_Is
+         Scope.Table (Scope.Last).Etyp := E_Bad_Is;
+      end if;
+   end Output_End_Missing;
+
+   ---------------------
+   -- Pop End Context --
+   ---------------------
+
+   procedure Pop_End_Context is
+
+      Pretty_Good : Boolean;
+      --  This flag is set True if the END sequence is syntactically incorrect,
+      --  but is (from a heuristic point of view), pretty likely to be simply
+      --  a misspelling of the intended END.
+
+      Outer_Match : Boolean;
+      --  This flag is set True if we decide that the current END sequence
+      --  belongs to some outer level entry in the scope stack, and thus
+      --  we will NOT eat it up in matching the current expected END.
+
+   begin
+      --  If not at END, then output END expected message
+
+      if End_Type = E_Dummy then
+         Output_End_Missing;
+         Pop_Scope_Stack;
+         End_Action := Insert_And_Accept;
+         return;
+
+      --  Otherwise we do have an END present
+
+      else
+         --  A special check. If we have END; followed by an end of file,
+         --  WITH or SEPARATE, then if we are not at the outer level, then
+         --  we have a sytax error. Consider the example:
+
+         --   ...
+         --      declare
+         --         X : Integer;
+         --      begin
+         --         X := Father (A);
+         --         Process (X, X);
+         --   end;
+         --   with Package1;
+         --   ...
+
+         --  Now the END; here is a syntactically correct closer for the
+         --  declare block, but if we eat it up, then we obviously have
+         --  a missing END for the outer context (since WITH can only appear
+         --  at the outer level.
+
+         --  In this situation, we always reserve the END; for the outer level,
+         --  even if it is in the wrong column. This is because it's much more
+         --  useful to have the error message point to the DECLARE than to the
+         --  package header in this case.
+
+         --  We also reserve an end with a name before the end of file if the
+         --  name is the one we expect at the outer level.
+
+         if (Token = Tok_EOF or else
+             Token = Tok_With or else
+             Token = Tok_Separate)
+           and then End_Type >= E_Name
+           and then (not End_Labl_Present
+                      or else Same_Label (End_Labl, Scope.Table (1).Labl))
+           and then Scope.Last > 1
+         then
+            Restore_Scan_State (Scan_State); -- to END
+            Output_End_Expected (Ins => True);
+            Pop_Scope_Stack;
+            End_Action := Insert_And_Accept;
+            return;
+         end if;
+
+         --  Otherwise we go through the normal END evaluation procedure
+
+         Evaluate_End_Entry (Scope.Last);
+
+         --  If top entry in stack is syntactically correct, then we have
+         --  scanned it out and everything is fine. This is the required
+         --  action to properly process correct Ada programs.
+
+         if Syntax_OK then
+
+            --  Complain if checking columns and END is not in right column.
+            --  Right in this context means exactly right, or on the same
+            --  line as the opener.
+
+            if Style.RM_Column_Check then
+               if End_Column /= Scope.Table (Scope.Last).Ecol
+                 and then Current_Line_Start > Scope.Table (Scope.Last).Sloc
+               then
+                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+                  Error_Msg
+                    ("(style) END in wrong column, should be@", End_Sloc);
+               end if;
+            end if;
+
+            --  One final check. If the end had a label, check for an exact
+            --  duplicate of this end sequence, and if so, skip it with an
+            --  appropriate message.
+
+            if End_Labl_Present and then Token = Tok_End then
+               declare
+                  Scan_State : Saved_Scan_State;
+                  End_Loc    : constant Source_Ptr := Token_Ptr;
+                  Nxt_Labl   : Node_Id;
+                  Dup_Found  : Boolean := False;
+
+               begin
+                  Save_Scan_State (Scan_State);
+
+                  Scan; -- past END
+
+                  if Token = Tok_Identifier
+                    or else Token = Tok_Operator_Symbol
+                  then
+                     Nxt_Labl := P_Designator;
+
+                     --  We only consider it an error if the label is a match
+                     --  and would be wrong for the level one above us, and
+                     --  the indentation is the same.
+
+                     if Token = Tok_Semicolon
+                       and then Same_Label (End_Labl, Nxt_Labl)
+                       and then End_Column = Start_Column
+                       and then
+                         (Scope.Last = 1
+                            or else
+                              (No (Scope.Table (Scope.Last - 1).Labl)
+                                or else
+                               not Same_Label
+                                     (End_Labl,
+                                      Scope.Table (Scope.Last - 1).Labl)))
+                     then
+                        T_Semicolon;
+                        Error_Msg ("duplicate end line ignored", End_Loc);
+                        Dup_Found := True;
+                     end if;
+                  end if;
+
+                  if not Dup_Found then
+                     Restore_Scan_State (Scan_State);
+                  end if;
+               end;
+            end if;
+
+            --  All OK, so return to caller indicating END is OK
+
+            Pop_Scope_Stack;
+            End_Action := Accept_As_Scanned;
+            return;
+         end if;
+
+         --  If that check failed, then we definitely have an error. The issue
+         --  is how to choose among three possible courses of action:
+
+         --   1. Ignore the current END text completely, scanning past it,
+         --      deciding that it belongs neither to the current context,
+         --      nor to any outer context.
+
+         --   2. Accept the current END text, scanning past it, and issuing
+         --      an error message that it does not have the right form.
+
+         --   3. Leave the current END text in place, NOT scanning past it,
+         --      issuing an error message indicating the END expected for the
+         --      current context. In this case, the END is available to match
+         --      some outer END context.
+
+         --  From a correct functioning point of view, it does not make any
+         --  difference which of these three approaches we take, the program
+         --  will work correctly in any case. However, making an accurate
+         --  choice among these alternatives, i.e. choosing the one that
+         --  corresponds to what the programmer had in mind, does make a
+         --  significant difference in the quality of error recovery.
+
+         Restore_Scan_State (Scan_State); -- to END
+
+         --  First we see how good the current END entry is with respect to
+         --  what we expect. It is considered pretty good if the token is OK,
+         --  and either the label or the column matches. an END for RECORD is
+         --  always considered to be pretty good in the record case. This is
+         --  because not only does a record disallow a nested structure, but
+         --  also it is unlikely that such nesting could occur by accident.
+
+         Pretty_Good := (Token_OK and (Column_OK or Label_OK))
+                          or else Scope.Table (Scope.Last).Etyp = E_Record;
+
+         --  Next check, if there is a deeper entry in the stack which
+         --  has a very high probability of being acceptable, then insert
+         --  the END entry we want, leaving the higher level entry for later
+
+         for J in reverse 1 .. Scope.Last - 1 loop
+            Evaluate_End_Entry (J);
+
+            --  To even consider the deeper entry to be immediately acceptable,
+            --  it must be syntactically correct. Furthermore it must either
+            --  have a correct label, or the correct column. If the current
+            --  entry was a close match (Pretty_Good set), then we are even
+            --  more strict in accepting the outer level one: even if it has
+            --  the right label, it must have the right column as well.
+
+            if Syntax_OK then
+               if Pretty_Good then
+                  Outer_Match := Label_OK and Column_OK;
+               else
+                  Outer_Match := Label_OK or Column_OK;
+               end if;
+            else
+               Outer_Match := False;
+            end if;
+
+            --  If the outer entry does convincingly match the END text, then
+            --  back up the scan to the start of the END sequence, issue an
+            --  error message indicating the END we expected, and return with
+            --  Token pointing to the END (case 3 from above discussion).
+
+            if Outer_Match then
+               Output_End_Missing;
+               Pop_Scope_Stack;
+               End_Action := Insert_And_Accept;
+               return;
+            end if;
+         end loop;
+
+         --  Here we have a situation in which the current END entry is
+         --  syntactically incorrect, but there is no deeper entry in the
+         --  END stack which convincingly matches it.
+
+         --  If the END text was judged to be a Pretty_Good match for the
+         --  expected token or if it appears left of the expected column,
+         --  then we will accept it as the one we want, scanning past it, even
+         --  though it is not completely right (we issue a message showing what
+         --  we expected it to be). This is action 2 from the discussion above.
+         --  There is one other special case to consider: the LOOP case.
+         --  Consider the example:
+
+         --     Lbl: loop
+         --             null;
+         --          end loop;
+
+         --  Here the column lines up with Lbl, so END LOOP is to the right,
+         --  but it is still acceptable. LOOP is the one case where alignment
+         --  practices vary substantially in practice.
+
+         if Pretty_Good
+            or else End_Column <= Scope.Table (Scope.Last).Ecol
+            or else (End_Type = Scope.Table (Scope.Last).Etyp
+                        and then End_Type = E_Loop)
+         then
+            Output_End_Expected (Ins => False);
+            Pop_Scope_Stack;
+            End_Action := Skip_And_Accept;
+            return;
+
+         --  Here we have the case where the END is to the right of the
+         --  expected column and does not have a correct label to convince
+         --  us that it nevertheless belongs to the current scope. For this
+         --  we consider that it probably belongs not to the current context,
+         --  but to some inner context that was not properly recognized (due to
+         --  other syntax errors), and for which no proper scope stack entry
+         --  was made. The proper action in this case is to delete the END text
+         --  and return False to the caller as a signal to keep on looking for
+         --  an acceptable END. This is action 1 from the discussion above.
+
+         else
+            Output_End_Deleted;
+            End_Action := Skip_And_Reject;
+            return;
+         end if;
+      end if;
+   end Pop_End_Context;
+
+   ----------------
+   -- Same_Label --
+   ----------------
+
+   function Same_Label (Label1, Label2 : Node_Id) return Boolean is
+   begin
+      if Nkind (Label1) in N_Has_Chars
+        and then Nkind (Label2) in N_Has_Chars
+      then
+         return Chars (Label1) = Chars (Label2);
+
+      elsif Nkind (Label1) = N_Selected_Component
+        and then Nkind (Label2) = N_Selected_Component
+      then
+         return Same_Label (Prefix (Label1), Prefix (Label2)) and then
+           Same_Label (Selector_Name (Label1), Selector_Name (Label2));
+
+      elsif Nkind (Label1) = N_Designator
+        and then Nkind (Label2) = N_Defining_Program_Unit_Name
+      then
+         return Same_Label (Name (Label1), Name (Label2)) and then
+           Same_Label (Identifier (Label1), Defining_Identifier (Label2));
+
+      else
+         return False;
+      end if;
+   end Same_Label;
+
+end Endh;
diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb
new file mode 100644
index 0000000..e43d3f3
--- /dev/null
+++ b/gcc/ada/par-labl.adb
@@ -0,0 +1,202 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L A B L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.18 $                             --
+--                                                                          --
+--          Copyright (C) 1992-1998, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+procedure Labl is
+   Enclosing_Body_Or_Block : Node_Id;
+   --  Innermost enclosing body or block statement
+
+   Label_Decl_Node : Node_Id;
+   --  Implicit label declaration node
+
+   Defining_Ident_Node : Node_Id;
+   --  Defining identifier node for implicit label declaration
+
+   Next_Label_Elmt : Elmt_Id;
+   --  Next element on label element list
+
+   Label_Node : Node_Id;
+   --  Next label node to process
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
+   --  Find the innermost body or block that encloses N.
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id;
+   --  Find the innermost body that encloses N.
+
+   procedure Check_Distinct_Labels;
+   --  Checks the rule in RM-5.1(11), which requires distinct identifiers
+   --  for all the labels in a given body.
+
+   ---------------------------
+   -- Check_Distinct_Labels --
+   ---------------------------
+
+   procedure Check_Distinct_Labels is
+      Label_Id : constant Node_Id := Identifier (Label_Node);
+
+      Enclosing_Body : constant Node_Id :=
+                         Find_Enclosing_Body (Enclosing_Body_Or_Block);
+      --  Innermost enclosing body
+
+      Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
+      --  Next element on label element list
+
+      Other_Label : Node_Id;
+      --  Next label node to process
+
+   begin
+      --  Loop through all the labels, and if we find some other label
+      --  (i.e. not Label_Node) that has the same identifier,
+      --  and whose innermost enclosing body is the same,
+      --  then we have an error.
+
+      --  Note that in the worst case, this is quadratic in the number
+      --  of labels.  However, labels are not all that common, and this
+      --  is only called for explicit labels.
+      --  ???Nonetheless, the efficiency could be improved. For example,
+      --  call Labl for each body, rather than once per compilation.
+
+      while Present (Next_Other_Label_Elmt) loop
+         Other_Label := Node (Next_Other_Label_Elmt);
+
+         exit when Label_Node = Other_Label;
+
+         if Chars (Label_Id) = Chars (Identifier (Other_Label))
+           and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
+         then
+            Error_Msg_Sloc := Sloc (Other_Label);
+            Error_Msg_N ("& conflicts with label#", Label_Id);
+            exit;
+         end if;
+
+         Next_Elmt (Next_Other_Label_Elmt);
+      end loop;
+   end Check_Distinct_Labels;
+
+   -------------------------
+   -- Find_Enclosing_Body --
+   -------------------------
+
+   function Find_Enclosing_Body (N : Node_Id) return Node_Id is
+      Result : Node_Id := N;
+
+   begin
+      --  This is the same as Find_Enclosing_Body_Or_Block, except
+      --  that we skip block statements and accept statements, instead
+      --  of stopping at them.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body;
+
+   ----------------------------------
+   -- Find_Enclosing_Body_Or_Block --
+   ----------------------------------
+
+   function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
+      Result : Node_Id := Parent (N);
+
+   begin
+      --  Climb up the parent chain until we find a body or block.
+
+      while Present (Result)
+        and then Nkind (Result) /= N_Accept_Statement
+        and then Nkind (Result) /= N_Entry_Body
+        and then Nkind (Result) /= N_Task_Body
+        and then Nkind (Result) /= N_Package_Body
+        and then Nkind (Result) /= N_Subprogram_Body
+        and then Nkind (Result) /= N_Block_Statement
+      loop
+         Result := Parent (Result);
+      end loop;
+
+      return Result;
+   end Find_Enclosing_Body_Or_Block;
+
+--  Start of processing for Par.Labl
+
+begin
+   Next_Label_Elmt := First_Elmt (Label_List);
+
+   while Present (Next_Label_Elmt) loop
+      Label_Node := Node (Next_Label_Elmt);
+
+      if not Comes_From_Source (Label_Node) then
+         goto Next_Label;
+      end if;
+
+      --  Find the innermost enclosing body or block, which is where
+      --  we need to implicitly declare this label
+
+      Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
+
+      --  If we didn't find a parent, then the label in question never got
+      --  hooked into a reasonable declarative part. This happens only in
+      --  error situations, and we simply ignore the entry (we aren't going
+      --  to get into the semantics in any case given the error).
+
+      if Present (Enclosing_Body_Or_Block) then
+         Check_Distinct_Labels;
+
+         --  Now create the implicit label declaration node and its
+         --  corresponding defining identifier. Note that the defining
+         --  occurrence of a label is the implicit label declaration that
+         --  we are creating. The label itself is an applied occurrence.
+
+         Label_Decl_Node :=
+           New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
+         Defining_Ident_Node :=
+           New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
+         Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
+         Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
+         Set_Label_Construct (Label_Decl_Node, Label_Node);
+
+         --  Now attach the implicit label declaration to the appropriate
+         --  declarative region, creating a declaration list if none exists
+
+         if not Present (Declarations (Enclosing_Body_Or_Block)) then
+            Set_Declarations (Enclosing_Body_Or_Block, New_List);
+         end if;
+
+         Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
+      end if;
+
+      <<Next_Label>>
+         Next_Elmt (Next_Label_Elmt);
+   end loop;
+
+end Labl;
diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb
new file mode 100644
index 0000000..39934ca
--- /dev/null
+++ b/gcc/ada/par-load.adb
@@ -0,0 +1,410 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . L O A D                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.60 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The Par.Load procedure loads all units that are definitely required before
+--  it makes any sense at all to proceed with semantic analysis, including
+--  with'ed units, corresponding specs for bodies, parents of child specs,
+--  and parents of subunits. All these units are loaded and pointers installed
+--  in the tree as described in the spec of package Lib.
+
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib.Load; use Lib.Load;
+with Uname;    use Uname;
+with Namet;    use Namet;
+with Casing;   use Casing;
+with Opt;      use Opt;
+with Osint;    use Osint;
+with Sinput.L; use Sinput.L;
+with Stylesw;  use Stylesw;
+with Validsw;  use Validsw;
+
+separate (Par)
+procedure Load is
+
+   File_Name : File_Name_Type;
+   --  Name of file for current unit, derived from unit name
+
+   Cur_Unum : Unit_Number_Type := Current_Source_Unit;
+   --  Unit number of unit that we just finished parsing. Note that we need
+   --  to capture this, because Source_Unit will change as we parse new
+   --  source files in the multiple main source file case.
+
+   Curunit : constant Node_Id := Cunit (Cur_Unum);
+   --  Compilation unit node for current compilation unit
+
+   Loc : Source_Ptr := Sloc (Curunit);
+   --  Source location for compilation unit node
+
+   Save_Style_Check  : Boolean;
+   Save_Style_Checks : Style_Check_Options;
+   --  Save style check so it can be restored later
+
+   Save_Validity_Check  : Boolean;
+   Save_Validity_Checks : Validity_Check_Options;
+   --  Save validity check so it can be restored later
+
+   With_Cunit : Node_Id;
+   --  Compilation unit node for withed unit
+
+   Context_Node : Node_Id;
+   --  Next node in context items list
+
+   With_Node : Node_Id;
+   --  N_With_Clause node
+
+   Spec_Name : Unit_Name_Type;
+   --  Unit name of required spec
+
+   Body_Name : Unit_Name_Type;
+   --  Unit name of corresponding body
+
+   Unum : Unit_Number_Type;
+   --  Unit number of loaded unit
+
+   function Same_File_Name_Except_For_Case
+     (Expected_File_Name : File_Name_Type;
+      Actual_File_Name   : File_Name_Type)
+      return               Boolean;
+   --  Given an actual file name and an expected file name (the latter being
+   --  derived from the unit name), determine if they are the same except for
+   --  possibly different casing of letters.
+
+   function Same_File_Name_Except_For_Case
+     (Expected_File_Name : File_Name_Type;
+      Actual_File_Name   : File_Name_Type)
+      return               Boolean
+   is
+   begin
+      Get_Name_String (Actual_File_Name);
+      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+      declare
+         Lower_Case_Actual_File_Name : String (1 .. Name_Len);
+
+      begin
+         Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
+         Get_Name_String (Expected_File_Name);
+         Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+         return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
+      end;
+
+   end Same_File_Name_Except_For_Case;
+
+--  Start of processing for Load
+
+begin
+   --  Don't do any loads if we already had a fatal error
+
+   if Fatal_Error (Cur_Unum) then
+      return;
+   end if;
+
+   Save_Style_Check_Options (Save_Style_Checks);
+   Save_Style_Check := Opt.Style_Check;
+
+   Save_Validity_Check_Options (Save_Validity_Checks);
+   Save_Validity_Check := Opt.Validity_Checks_On;
+
+   --  If main unit, set Main_Unit_Entity (this will get overwritten if
+   --  the main unit has a separate spec, that happens later on in Load)
+
+   if Cur_Unum = Main_Unit then
+      Main_Unit_Entity := Cunit_Entity (Main_Unit);
+   end if;
+
+   --  If we have no unit name, things are seriously messed up by previous
+   --  errors, and we should not try to continue compilation.
+
+   if Unit_Name (Cur_Unum) = No_Name then
+      raise Unrecoverable_Error;
+   end if;
+
+   --  Next step, make sure that the unit name matches the file name
+   --  and issue a warning message if not. We only output this for the
+   --  main unit, since for other units it is more serious and is
+   --  caught in a separate test below.
+
+   File_Name :=
+     Get_File_Name
+       (Unit_Name (Cur_Unum),
+        Subunit => Nkind (Unit (Cunit (Cur_Unum))) = N_Subunit);
+
+   if Cur_Unum = Main_Unit
+     and then File_Name /= Unit_File_Name (Cur_Unum)
+     and then (File_Names_Case_Sensitive
+                or not Same_File_Name_Except_For_Case
+                         (File_Name, Unit_File_Name (Cur_Unum)))
+   then
+      Error_Msg_Name_1 := File_Name;
+      Error_Msg
+        ("?file name does not match unit name, should be{", Sloc (Curunit));
+   end if;
+
+   --  For units other than the main unit, the expected unit name is set and
+   --  must be the same as the actual unit name, or we are in big trouble, and
+   --  abandon the compilation since there are situations where this really
+   --  gets us into bad trouble (e.g. some subunit situations).
+
+   if Cur_Unum /= Main_Unit
+     and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
+   then
+      Loc := Error_Location (Cur_Unum);
+      Error_Msg_Name_1 := Unit_File_Name (Cur_Unum);
+      Get_Name_String (Error_Msg_Name_1);
+
+      --  Check for predefined file case
+
+      if Name_Len > 1
+        and then Name_Buffer (2) = '-'
+        and then (Name_Buffer (1) = 'a'
+                    or else
+                  Name_Buffer (1) = 's'
+                    or else
+                  Name_Buffer (1) = 'i'
+                    or else
+                  Name_Buffer (1) = 'g')
+      then
+         --  In the predefined file case, we know the user did not construct
+         --  their own package, but we got the wrong one. This means that the
+         --  name supplied by the user crunched to something we recognized,
+         --  but then the file did not contain the unit expected. Most likely
+         --  this is due to a misspelling, e.g.
+
+         --    with Ada.Calender;
+
+         --  This crunches to a-calend, which indeed contains the unit
+         --  Ada.Calendar, and we can diagnose the misspelling. This is
+         --  a simple heuristic, but it catches many common cases of
+         --  misspelling of predefined unit names without needing a full
+         --  list of them.
+
+         Error_Msg_Name_1 := Expected_Unit (Cur_Unum);
+         Error_Msg ("% is not a predefined library unit!", Loc);
+         Error_Msg_Name_1 := Unit_Name (Cur_Unum);
+         Error_Msg ("possible misspelling of %!", Loc);
+
+      --  Non-predefined file name case
+
+      else
+         Error_Msg ("file { does not contain expected unit!", Loc);
+         Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
+         Error_Msg ("expected unit $!", Loc);
+         Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
+         Error_Msg ("found unit $!", Loc);
+      end if;
+
+      raise Unrecoverable_Error;
+   end if;
+
+   --  If current unit is a body, load its corresponding spec
+
+   if Nkind (Unit (Curunit)) = N_Package_Body
+     or else Nkind (Unit (Curunit)) = N_Subprogram_Body
+   then
+      Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
+      Unum :=
+        Load_Unit
+          (Load_Name  => Spec_Name,
+           Required   => False,
+           Subunit    => False,
+           Error_Node => Curunit,
+           Corr_Body  => Cur_Unum);
+
+      --  If we successfully load the unit, then set the spec pointer. Once
+      --  again note that if the loaded unit has a fatal error, Load will
+      --  have set our Fatal_Error flag to propagate this condition.
+
+      if Unum /= No_Unit then
+         Set_Library_Unit (Curunit, Cunit (Unum));
+
+         --  If this is a separate spec for the main unit, then we reset
+         --  Main_Unit_Entity to point to the entity for this separate spec
+
+         if Cur_Unum = Main_Unit then
+            Main_Unit_Entity := Cunit_Entity (Unum);
+         end if;
+
+      --  If we don't find the spec, then if we have a subprogram body, we
+      --  are still OK, we just have a case of a body acting as its own spec
+
+      elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
+         Set_Acts_As_Spec (Curunit, True);
+         Set_Library_Unit (Curunit, Curunit);
+
+      --  Otherwise we do have an error, repeat the load request for the spec
+      --  with Required set True to generate an appropriate error message.
+
+      else
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => True,
+              Subunit    => False,
+              Error_Node => Curunit);
+         return;
+      end if;
+
+   --  If current unit is a child unit spec, load its parent
+
+   elsif Nkind (Unit (Curunit)) = N_Package_Declaration
+     or else Nkind (Unit (Curunit)) =  N_Subprogram_Declaration
+     or else Nkind (Unit (Curunit)) in N_Generic_Declaration
+     or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
+     or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
+   then
+      --  Turn style and validity checks off for parent unit
+
+      if not GNAT_Mode then
+         Reset_Style_Check_Options;
+         Reset_Validity_Check_Options;
+      end if;
+
+      Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
+
+      if Spec_Name /= No_Name then
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => True,
+              Subunit    => False,
+              Error_Node => Curunit);
+
+         if Unum /= No_Unit then
+            Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
+         end if;
+      end if;
+
+   --  If current unit is a subunit, then load its parent body
+
+   elsif Nkind (Unit (Curunit)) = N_Subunit then
+      Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
+      Unum :=
+        Load_Unit
+          (Load_Name  => Body_Name,
+           Required   => True,
+           Subunit    => True,
+           Error_Node => Name (Unit (Curunit)));
+
+      if Unum /= No_Unit then
+         Set_Library_Unit (Curunit, Cunit (Unum));
+      end if;
+
+   end if;
+
+   --  Now we load with'ed units, with style/validity checks turned off
+
+   if not GNAT_Mode then
+      Reset_Style_Check_Options;
+      Reset_Validity_Check_Options;
+   end if;
+
+   --  Loop through context items
+
+   Context_Node := First (Context_Items (Curunit));
+   while Present (Context_Node) loop
+
+      if Nkind (Context_Node) = N_With_Clause then
+         With_Node := Context_Node;
+         Spec_Name := Get_Unit_Name (With_Node);
+
+         Unum :=
+           Load_Unit
+             (Load_Name  => Spec_Name,
+              Required   => False,
+              Subunit    => False,
+              Error_Node => With_Node,
+              Renamings  => True);
+
+         --  If we find the unit, then set spec pointer in the N_With_Clause
+         --  to point to the compilation unit for the spec. Remember that
+         --  the Load routine itself sets our Fatal_Error flag if the loaded
+         --  unit gets a fatal error, so we don't need to worry about that.
+
+         if Unum /= No_Unit then
+            Set_Library_Unit (With_Node, Cunit (Unum));
+
+         --  If the spec isn't found, then try finding the corresponding
+         --  body, since it is possible that we have a subprogram body
+         --  that is acting as a spec (since no spec is present).
+
+         else
+            Body_Name := Get_Body_Name (Spec_Name);
+            Unum :=
+              Load_Unit
+                (Load_Name  => Body_Name,
+                 Required   => False,
+                 Subunit    => False,
+                 Error_Node => With_Node,
+                 Renamings  => True);
+
+            --  If we got a subprogram body, then mark that we are using
+            --  the body as a spec in the file table, and set the spec
+            --  pointer in the N_With_Clause to point to the body entity.
+
+            if Unum /= No_Unit
+              and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
+            then
+               With_Cunit := Cunit (Unum);
+               Set_Library_Unit (With_Node, With_Cunit);
+               Set_Acts_As_Spec (With_Cunit, True);
+               Set_Library_Unit (With_Cunit, With_Cunit);
+
+            --  If we couldn't find the body, or if it wasn't a body spec
+            --  then we are in trouble. We make one more call to Load to
+            --  require the spec. We know it will fail of course, the
+            --  purpose is to generate the required error message (we prefer
+            --  that this message refer to the missing spec, not the body)
+
+            else
+               Unum :=
+                 Load_Unit
+                   (Load_Name  => Spec_Name,
+                    Required   => True,
+                    Subunit    => False,
+                    Error_Node => With_Node,
+                    Renamings  => True);
+
+               --  Here we create a dummy package unit for the missing unit
+
+               Unum := Create_Dummy_Package_Unit (With_Node, Spec_Name);
+               Set_Library_Unit (With_Node, Cunit (Unum));
+            end if;
+         end if;
+      end if;
+
+      Next (Context_Node);
+   end loop;
+
+   --  Restore style/validity check mode for main unit
+
+   Set_Style_Check_Options (Save_Style_Checks);
+   Opt.Style_Check := Save_Style_Check;
+   Set_Validity_Check_Options (Save_Validity_Checks);
+   Opt.Validity_Checks_On := Save_Validity_Check;
+end Load;
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
new file mode 100644
index 0000000..bfca40e
--- /dev/null
+++ b/gcc/ada/par-prag.adb
@@ -0,0 +1,950 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . P R A G                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.149 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Generally the parser checks the basic syntax of pragmas, but does not
+--  do specialized syntax checks for individual pragmas, these are deferred
+--  to semantic analysis time (see unit Sem_Prag). There are some pragmas
+--  which require recognition and either partial or complete processing
+--  during parsing, and this unit performs this required processing.
+
+with Fname.UF; use Fname.UF;
+with Osint;    use Osint;
+with Stringt;  use Stringt;
+with Stylesw;  use Stylesw;
+with Uintp;    use Uintp;
+with Uname;    use Uname;
+
+separate (Par)
+
+function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
+   Pragma_Name : constant Name_Id    := Chars (Pragma_Node);
+   Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
+   Arg_Count   : Nat;
+   Arg_Node    : Node_Id;
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Arg1 return Node_Id;
+   function Arg2 return Node_Id;
+   function Arg3 return Node_Id;
+   function Arg4 return Node_Id;
+   --  Obtain specified Pragma_Argument_Association. It is allowable to call
+   --  the routine for the argument one past the last present argument, but
+   --  that is the only case in which a non-present argument can be referenced.
+
+   procedure Check_Arg_Count (Required : Int);
+   --  Check argument count for pragma = Required.
+   --  If not give error and raise Error_Resync.
+
+   procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
+   --  Check the expression of the specified argument to make sure that it
+   --  is a string literal. If not give error and raise Error_Resync.
+
+   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id);
+   --  Check the expression of the specified argument to make sure that it
+   --  is an identifier which is either ON or OFF, and if not, then issue
+   --  an error message and raise Error_Resync.
+
+   procedure Check_No_Identifier (Arg : Node_Id);
+   --  Checks that the given argument does not have an identifier. If an
+   --  identifier is present, then an error message is issued, and
+   --  Error_Resync is raised.
+
+   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
+   --  Checks if the given argument has an identifier, and if so, requires
+   --  it to match the given identifier name. If there is a non-matching
+   --  identifier, then an error message is given and Error_Resync raised.
+
+   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id);
+   --  Same as Check_Optional_Identifier, except that the name is required
+   --  to be present and to match the given Id value.
+
+   ----------
+   -- Arg1 --
+   ----------
+
+   function Arg1 return Node_Id is
+   begin
+      return First (Pragma_Argument_Associations (Pragma_Node));
+   end Arg1;
+
+   ----------
+   -- Arg2 --
+   ----------
+
+   function Arg2 return Node_Id is
+   begin
+      return Next (Arg1);
+   end Arg2;
+
+   ----------
+   -- Arg3 --
+   ----------
+
+   function Arg3 return Node_Id is
+   begin
+      return Next (Arg2);
+   end Arg3;
+
+   ----------
+   -- Arg4 --
+   ----------
+
+   function Arg4 return Node_Id is
+   begin
+      return Next (Arg3);
+   end Arg4;
+
+   ---------------------
+   -- Check_Arg_Count --
+   ---------------------
+
+   procedure Check_Arg_Count (Required : Int) is
+   begin
+      if Arg_Count /= Required then
+         Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Count;
+
+   ----------------------------
+   -- Check_Arg_Is_On_Or_Off --
+   ----------------------------
+
+   procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is
+      Argx : constant Node_Id := Expression (Arg);
+
+   begin
+      if Nkind (Expression (Arg)) /= N_Identifier
+        or else (Chars (Argx) /= Name_On
+                   and then
+                 Chars (Argx) /= Name_Off)
+      then
+         Error_Msg_Name_2 := Name_On;
+         Error_Msg_Name_3 := Name_Off;
+
+         Error_Msg
+           ("argument for pragma% must be% or%", Sloc (Argx));
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Is_On_Or_Off;
+
+   ---------------------------------
+   -- Check_Arg_Is_String_Literal --
+   ---------------------------------
+
+   procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
+   begin
+      if Nkind (Expression (Arg)) /= N_String_Literal then
+         Error_Msg
+           ("argument for pragma% must be string literal",
+             Sloc (Expression (Arg)));
+         raise Error_Resync;
+      end if;
+   end Check_Arg_Is_String_Literal;
+
+   -------------------------
+   -- Check_No_Identifier --
+   -------------------------
+
+   procedure Check_No_Identifier (Arg : Node_Id) is
+   begin
+      if Chars (Arg) /= No_Name then
+         Error_Msg_N ("pragma% does not permit named arguments", Arg);
+         raise Error_Resync;
+      end if;
+   end Check_No_Identifier;
+
+   -------------------------------
+   -- Check_Optional_Identifier --
+   -------------------------------
+
+   procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
+   begin
+      if Present (Arg) and then Chars (Arg) /= No_Name then
+         if Chars (Arg) /= Id then
+            Error_Msg_Name_2 := Id;
+            Error_Msg_N ("pragma% argument expects identifier%", Arg);
+         end if;
+      end if;
+   end Check_Optional_Identifier;
+
+   -------------------------------
+   -- Check_Required_Identifier --
+   -------------------------------
+
+   procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is
+   begin
+      if Chars (Arg) /= Id then
+         Error_Msg_Name_2 := Id;
+         Error_Msg_N ("pragma% argument must have identifier%", Arg);
+      end if;
+   end Check_Required_Identifier;
+
+   ----------
+   -- Prag --
+   ----------
+
+begin
+   Error_Msg_Name_1 := Pragma_Name;
+
+   --  Count number of arguments. This loop also checks if any of the arguments
+   --  are Error, indicating a syntax error as they were parsed. If so, we
+   --  simply return, because we get into trouble with cascaded errors if we
+   --  try to perform our error checks on junk arguments.
+
+   Arg_Count := 0;
+
+   if Present (Pragma_Argument_Associations (Pragma_Node)) then
+      Arg_Node := Arg1;
+
+      while Arg_Node /= Empty loop
+         Arg_Count := Arg_Count + 1;
+
+         if Expression (Arg_Node) = Error then
+            return Error;
+         end if;
+
+         Next (Arg_Node);
+      end loop;
+   end if;
+
+   --  Remaining processing is pragma dependent
+
+   case Get_Pragma_Id (Pragma_Name) is
+
+      ------------
+      -- Ada_83 --
+      ------------
+
+      --  This pragma must be processed at parse time, since we want to set
+      --  the Ada 83 and Ada 95 switches properly at parse time to recognize
+      --  Ada 83 syntax or Ada 95 syntax as appropriate.
+
+      when Pragma_Ada_83 =>
+         Ada_83 := True;
+         Ada_95 := False;
+
+      ------------
+      -- Ada_95 --
+      ------------
+
+      --  This pragma must be processed at parse time, since we want to set
+      --  the Ada 83 and Ada_95 switches properly at parse time to recognize
+      --  Ada 83 syntax or Ada 95 syntax as appropriate.
+
+      when Pragma_Ada_95 =>
+         Ada_83 := False;
+         Ada_95 := True;
+
+      -----------
+      -- Debug --
+      -----------
+
+      --  pragma Debug (PROCEDURE_CALL_STATEMENT);
+
+      --  This has to be processed by the parser because of the very peculiar
+      --  form of the second parameter, which is syntactically from a formal
+      --  point of view a function call (since it must be an expression), but
+      --  semantically we treat it as a procedure call (which has exactly the
+      --  same syntactic form, so that's why we can get away with this!)
+
+      when Pragma_Debug =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+
+         declare
+            Expr : constant Node_Id := New_Copy (Expression (Arg1));
+
+         begin
+            if Nkind (Expr) /= N_Indexed_Component
+              and then Nkind (Expr) /= N_Function_Call
+              and then Nkind (Expr) /= N_Identifier
+              and then Nkind (Expr) /= N_Selected_Component
+            then
+               Error_Msg
+                 ("argument of pragma% is not procedure call", Sloc (Expr));
+               raise Error_Resync;
+            else
+               Set_Debug_Statement
+                 (Pragma_Node, P_Statement_Name (Expr));
+            end if;
+         end;
+
+      -------------------------------
+      -- Extensions_Allowed (GNAT) --
+      -------------------------------
+
+      --  pragma Extensions_Allowed (Off | On)
+
+      --  The processing for pragma Extensions_Allowed must be done at
+      --  parse time, since extensions mode may affect what is accepted.
+
+      when Pragma_Extensions_Allowed =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+         Check_Arg_Is_On_Or_Off (Arg1);
+         Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
+
+      ----------------
+      -- List (2.8) --
+      ----------------
+
+      --  pragma List (Off | On)
+
+      --  The processing for pragma List must be done at parse time,
+      --  since a listing can be generated in parse only mode.
+
+      when Pragma_List =>
+         Check_Arg_Count (1);
+         Check_No_Identifier (Arg1);
+         Check_Arg_Is_On_Or_Off (Arg1);
+
+         --  We unconditionally make a List_On entry for the pragma, so that
+         --  in the List (Off) case, the pragma will print even in a region
+         --  of code with listing turned off (this is required!)
+
+         List_Pragmas.Increment_Last;
+         List_Pragmas.Table (List_Pragmas.Last) :=
+           (Ptyp => List_On, Ploc => Sloc (Pragma_Node));
+
+         --  Now generate the list off entry for pragma List (Off)
+
+         if Chars (Expression (Arg1)) = Name_Off then
+            List_Pragmas.Increment_Last;
+            List_Pragmas.Table (List_Pragmas.Last) :=
+              (Ptyp => List_Off, Ploc => Semi);
+         end if;
+
+      ----------------
+      -- Page (2.8) --
+      ----------------
+
+      --  pragma Page;
+
+      --  Processing for this pragma must be done at parse time, since a
+      --  listing can be generated in parse only mode with semantics off.
+
+      when Pragma_Page =>
+         Check_Arg_Count (0);
+         List_Pragmas.Increment_Last;
+         List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
+
+      -----------------------------
+      -- Source_File_Name (GNAT) --
+      -----------------------------
+
+      --  There are five forms of this pragma:
+
+      --  pragma Source_File_Name (
+      --    [UNIT_NAME      =>] unit_NAME,
+      --     BODY_FILE_NAME =>  STRING_LITERAL);
+
+      --  pragma Source_File_Name (
+      --    [UNIT_NAME      =>] unit_NAME,
+      --     SPEC_FILE_NAME =>  STRING_LITERAL);
+
+      --  pragma Source_File_Name (
+      --     BODY_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT => STRING_LITERAL]
+      --  [, CASING          => CASING_SPEC]);
+
+      --  pragma Source_File_Name (
+      --     SPEC_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT => STRING_LITERAL]
+      --  [, CASING          => CASING_SPEC]);
+
+      --  pragma Source_File_Name (
+      --     SUBUNIT_FILE_NAME  => STRING_LITERAL
+      --  [, DOT_REPLACEMENT    => STRING_LITERAL]
+      --  [, CASING             => CASING_SPEC]);
+
+      --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
+
+      --  Note: we process this during parsing, since we need to have the
+      --  source file names set well before the semantic analysis starts,
+      --  since we load the spec and with'ed packages before analysis.
+
+      when Pragma_Source_File_Name => Source_File_Name : declare
+         Unam  : Unit_Name_Type;
+         Expr1 : Node_Id;
+         Pat   : String_Ptr;
+         Typ   : Character;
+         Dot   : String_Ptr;
+         Cas   : Casing_Type;
+         Nast  : Nat;
+
+         function Get_Fname (Arg : Node_Id) return Name_Id;
+         --  Process file name from unit name form of pragma
+
+         function Get_String_Argument (Arg : Node_Id) return String_Ptr;
+         --  Process string literal value from argument
+
+         procedure Process_Casing (Arg : Node_Id);
+         --  Process Casing argument of pattern form of pragma
+
+         procedure Process_Dot_Replacement (Arg : Node_Id);
+         --  Process Dot_Replacement argument of patterm form of pragma
+
+         ---------------
+         -- Get_Fname --
+         ---------------
+
+         function Get_Fname (Arg : Node_Id) return Name_Id is
+         begin
+            String_To_Name_Buffer (Strval (Expression (Arg)));
+
+            for J in 1 .. Name_Len loop
+               if Is_Directory_Separator (Name_Buffer (J)) then
+                  Error_Msg
+                    ("directory separator character not allowed",
+                     Sloc (Expression (Arg)) + Source_Ptr (J));
+               end if;
+            end loop;
+
+            return Name_Find;
+         end Get_Fname;
+
+         -------------------------
+         -- Get_String_Argument --
+         -------------------------
+
+         function Get_String_Argument (Arg : Node_Id) return String_Ptr is
+            Str : String_Id;
+
+         begin
+            if Nkind (Expression (Arg)) /= N_String_Literal
+              and then
+               Nkind (Expression (Arg)) /= N_Operator_Symbol
+            then
+               Error_Msg_N
+                 ("argument for pragma% must be string literal", Arg);
+               raise Error_Resync;
+            end if;
+
+            Str := Strval (Expression (Arg));
+
+            --  Check string has no wide chars
+
+            for J in 1 .. String_Length (Str) loop
+               if Get_String_Char (Str, J) > 255 then
+                  Error_Msg
+                    ("wide character not allowed in pattern for pragma%",
+                     Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
+               end if;
+            end loop;
+
+            --  Acquire string
+
+            String_To_Name_Buffer (Str);
+            return new String'(Name_Buffer (1 .. Name_Len));
+         end Get_String_Argument;
+
+         --------------------
+         -- Process_Casing --
+         --------------------
+
+         procedure Process_Casing (Arg : Node_Id) is
+            Expr : constant Node_Id := Expression (Arg);
+
+         begin
+            Check_Required_Identifier (Arg, Name_Casing);
+
+            if Nkind (Expr) = N_Identifier then
+               if Chars (Expr) = Name_Lowercase then
+                  Cas := All_Lower_Case;
+                  return;
+               elsif Chars (Expr) = Name_Uppercase then
+                  Cas := All_Upper_Case;
+                  return;
+               elsif Chars (Expr) = Name_Mixedcase then
+                  Cas := Mixed_Case;
+                  return;
+               end if;
+            end if;
+
+            Error_Msg_N
+              ("Casing argument for pragma% must be " &
+               "one of Mixedcase, Lowercase, Uppercase",
+               Arg);
+         end Process_Casing;
+
+         -----------------------------
+         -- Process_Dot_Replacement --
+         -----------------------------
+
+         procedure Process_Dot_Replacement (Arg : Node_Id) is
+         begin
+            Check_Required_Identifier (Arg, Name_Dot_Replacement);
+            Dot := Get_String_Argument (Arg);
+         end Process_Dot_Replacement;
+
+      --  Start of processing for Source_File_Name pragma
+
+      begin
+         --  We permit from 1 to 3 arguments
+
+         if Arg_Count not in 1 .. 3 then
+            Check_Arg_Count (1);
+         end if;
+
+         Expr1 := Expression (Arg1);
+
+         --  If first argument is identifier or selected component, then
+         --  we have the specific file case of the Source_File_Name pragma,
+         --  and the first argument is a unit name.
+
+         if Nkind (Expr1) = N_Identifier
+           or else
+             (Nkind (Expr1) = N_Selected_Component
+               and then
+              Nkind (Selector_Name (Expr1)) = N_Identifier)
+         then
+            Check_Arg_Count (2);
+
+            Check_Optional_Identifier (Arg1, Name_Unit_Name);
+            Unam := Get_Unit_Name (Expr1);
+
+            Check_Arg_Is_String_Literal (Arg2);
+
+            if Chars (Arg2) = Name_Spec_File_Name then
+               Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2));
+
+            elsif Chars (Arg2) = Name_Body_File_Name then
+               Set_File_Name (Unam, Get_Fname (Arg2));
+
+            else
+               Error_Msg_N ("pragma% argument has incorrect identifier", Arg2);
+               return Pragma_Node;
+            end if;
+
+         --  If the first argument is not an identifier, then we must have
+         --  the pattern form of the pragma, and the first argument must be
+         --  the pattern string with an appropriate name.
+
+         else
+            if Chars (Arg1) = Name_Spec_File_Name then
+               Typ := 's';
+
+            elsif Chars (Arg1) = Name_Body_File_Name then
+               Typ := 'b';
+
+            elsif Chars (Arg1) = Name_Subunit_File_Name then
+               Typ := 'u';
+
+            elsif Chars (Arg1) = Name_Unit_Name then
+               Error_Msg_N
+                 ("Unit_Name parameter for pragma% must be an identifier",
+                  Arg1);
+               raise Error_Resync;
+
+            else
+               Error_Msg_N ("pragma% argument has incorrect identifier", Arg1);
+               raise Error_Resync;
+            end if;
+
+            Pat := Get_String_Argument (Arg1);
+
+            --  Check pattern has exactly one asterisk
+
+            Nast := 0;
+            for J in Pat'Range loop
+               if Pat (J) = '*' then
+                  Nast := Nast + 1;
+               end if;
+            end loop;
+
+            if Nast /= 1 then
+               Error_Msg_N
+                 ("file name pattern must have exactly one * character",
+                  Arg2);
+               return Pragma_Node;
+            end if;
+
+            --  Set defaults for Casing and Dot_Separator parameters
+
+            Cas := All_Lower_Case;
+
+            Dot := new String'(".");
+
+            --  Process second and third arguments if present
+
+            if Arg_Count > 1 then
+               if Chars (Arg2) = Name_Casing then
+                  Process_Casing (Arg2);
+
+                  if Arg_Count = 3 then
+                     Process_Dot_Replacement (Arg3);
+                  end if;
+
+               else
+                  Process_Dot_Replacement (Arg2);
+
+                  if Arg_Count = 3 then
+                     Process_Casing (Arg3);
+                  end if;
+               end if;
+            end if;
+
+            Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
+         end if;
+      end Source_File_Name;
+
+      -----------------------------
+      -- Source_Reference (GNAT) --
+      -----------------------------
+
+      --  pragma Source_Reference
+      --    (INTEGER_LITERAL [, STRING_LITERAL] );
+
+      --  Processing for this pragma must be done at parse time, since error
+      --  messages needing the proper line numbers can be generated in parse
+      --  only mode with semantic checking turned off, and indeed we usually
+      --  turn off semantic checking anyway if any parse errors are found.
+
+      when Pragma_Source_Reference => Source_Reference : declare
+         Fname : Name_Id;
+
+      begin
+         if Arg_Count /= 1 then
+            Check_Arg_Count (2);
+            Check_No_Identifier (Arg2);
+         end if;
+
+         --  Check that this is first line of file. We skip this test if
+         --  we are in syntax check only mode, since we may be dealing with
+         --  multiple compilation units.
+
+         if Get_Physical_Line_Number (Pragma_Sloc) /= 1
+           and then Num_SRef_Pragmas (Current_Source_File) = 0
+           and then Operating_Mode /= Check_Syntax
+         then
+            Error_Msg
+              ("first % pragma must be first line of file", Pragma_Sloc);
+            raise Error_Resync;
+         end if;
+
+         Check_No_Identifier (Arg1);
+
+         if Arg_Count = 1 then
+            if Num_SRef_Pragmas (Current_Source_File) = 0 then
+               Error_Msg
+                 ("file name required for first % pragma in file",
+                  Pragma_Sloc);
+               raise Error_Resync;
+
+            else
+               Fname := No_Name;
+            end if;
+
+         --  File name present
+
+         else
+            Check_Arg_Is_String_Literal (Arg2);
+            String_To_Name_Buffer (Strval (Expression (Arg2)));
+            Fname := Name_Find;
+
+            if Num_SRef_Pragmas (Current_Source_File) > 0 then
+               if Fname /= Full_Ref_Name (Current_Source_File) then
+                  Error_Msg
+                    ("file name must be same in all % pragmas", Pragma_Sloc);
+                  raise Error_Resync;
+               end if;
+            end if;
+         end if;
+
+         if Nkind (Expression (Arg1)) /= N_Integer_Literal then
+            Error_Msg
+              ("argument for pragma% must be integer literal",
+                Sloc (Expression (Arg1)));
+            raise Error_Resync;
+
+         --  OK, this source reference pragma is effective, however, we
+         --  ignore it if it is not in the first unit in the multiple unit
+         --  case. This is because the only purpose in this case is to
+         --  provide source pragmas for subsequent use by gnatchop.
+
+         else
+            if Num_Library_Units = 1 then
+               Register_Source_Ref_Pragma
+                 (Fname,
+                  Strip_Directory (Fname),
+                  UI_To_Int (Intval (Expression (Arg1))),
+                  Get_Physical_Line_Number (Pragma_Sloc) + 1);
+            end if;
+         end if;
+      end Source_Reference;
+
+      -------------------------
+      -- Style_Checks (GNAT) --
+      -------------------------
+
+      --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
+
+      --  This is processed by the parser since some of the style
+      --  checks take place during source scanning and parsing.
+
+      when Pragma_Style_Checks => Style_Checks : declare
+         A  : Node_Id;
+         S  : String_Id;
+         C  : Char_Code;
+         OK : Boolean := True;
+
+      begin
+         --  Two argument case is only for semantics
+
+         if Arg_Count = 2 then
+            null;
+
+         else
+            Check_Arg_Count (1);
+            Check_No_Identifier (Arg1);
+            A := Expression (Arg1);
+
+            if Nkind (A) = N_String_Literal then
+               S   := Strval (A);
+
+               declare
+                  Slen    : Natural := Natural (String_Length (S));
+                  Options : String (1 .. Slen);
+                  J       : Natural;
+                  Ptr     : Natural;
+
+               begin
+                  J := 1;
+                  loop
+                     C := Get_String_Char (S, Int (J));
+
+                     if not In_Character_Range (C) then
+                        OK := False;
+                        Ptr := J;
+                        exit;
+
+                     else
+                        Options (J) := Get_Character (C);
+                     end if;
+
+                     if J = Slen then
+                        Set_Style_Check_Options (Options, OK, Ptr);
+                        exit;
+
+                     else
+                        J := J + 1;
+                     end if;
+                  end loop;
+
+                  if not OK then
+                     Error_Msg
+                       ("invalid style check option",
+                        Sloc (Expression (Arg1)) + Source_Ptr (Ptr));
+                     raise Error_Resync;
+                  end if;
+               end;
+
+            elsif Nkind (A) /= N_Identifier then
+               OK := False;
+
+            elsif Chars (A) = Name_All_Checks then
+               Stylesw.Set_Default_Style_Check_Options;
+
+            elsif Chars (A) = Name_On then
+               Style_Check := True;
+
+            elsif Chars (A) = Name_Off then
+               Style_Check := False;
+
+            else
+               OK := False;
+            end if;
+
+            if not OK then
+               Error_Msg ("incorrect argument for pragma%", Sloc (A));
+               raise Error_Resync;
+            end if;
+         end if;
+      end Style_Checks;
+
+      ---------------------
+      -- Warnings (GNAT) --
+      ---------------------
+
+      --  pragma Warnings (On | Off, [LOCAL_NAME])
+
+      --  The one argument case is processed by the parser, since it may
+      --  control parser warnings as well as semantic warnings, and in any
+      --  case we want to be absolutely sure that the range in the warnings
+      --  table is set well before any semantic analysis is performed.
+
+      when Pragma_Warnings =>
+         if Arg_Count = 1 then
+            Check_No_Identifier (Arg1);
+            Check_Arg_Is_On_Or_Off (Arg1);
+
+            if Chars (Expression (Arg1)) = Name_On then
+               Set_Warnings_Mode_On (Pragma_Sloc);
+            else
+               Set_Warnings_Mode_Off (Pragma_Sloc);
+            end if;
+         end if;
+
+      -----------------------
+      -- All Other Pragmas --
+      -----------------------
+
+      --  For all other pragmas, checking and processing is handled
+      --  entirely in Sem_Prag, and no further checking is done by Par.
+
+      when Pragma_Abort_Defer              |
+           Pragma_AST_Entry                |
+           Pragma_All_Calls_Remote         |
+           Pragma_Annotate                 |
+           Pragma_Assert                   |
+           Pragma_Asynchronous             |
+           Pragma_Atomic                   |
+           Pragma_Atomic_Components        |
+           Pragma_Attach_Handler           |
+           Pragma_CPP_Class                |
+           Pragma_CPP_Constructor          |
+           Pragma_CPP_Virtual              |
+           Pragma_CPP_Vtable               |
+           Pragma_C_Pass_By_Copy           |
+           Pragma_Comment                  |
+           Pragma_Common_Object            |
+           Pragma_Complex_Representation   |
+           Pragma_Component_Alignment      |
+           Pragma_Controlled               |
+           Pragma_Convention               |
+           Pragma_Discard_Names            |
+           Pragma_Eliminate                |
+           Pragma_Elaborate                |
+           Pragma_Elaborate_All            |
+           Pragma_Elaborate_Body           |
+           Pragma_Elaboration_Checks       |
+           Pragma_Export                   |
+           Pragma_Export_Exception         |
+           Pragma_Export_Function          |
+           Pragma_Export_Object            |
+           Pragma_Export_Procedure         |
+           Pragma_Export_Valued_Procedure  |
+           Pragma_Extend_System            |
+           Pragma_External_Name_Casing     |
+           Pragma_Finalize_Storage_Only    |
+           Pragma_Float_Representation     |
+           Pragma_Ident                    |
+           Pragma_Import                   |
+           Pragma_Import_Exception         |
+           Pragma_Import_Function          |
+           Pragma_Import_Object            |
+           Pragma_Import_Procedure         |
+           Pragma_Import_Valued_Procedure  |
+           Pragma_Initialize_Scalars       |
+           Pragma_Inline                   |
+           Pragma_Inline_Always            |
+           Pragma_Inline_Generic           |
+           Pragma_Inspection_Point         |
+           Pragma_Interface                |
+           Pragma_Interface_Name           |
+           Pragma_Interrupt_Handler        |
+           Pragma_Interrupt_Priority       |
+           Pragma_Java_Constructor         |
+           Pragma_Java_Interface           |
+           Pragma_License                  |
+           Pragma_Link_With                |
+           Pragma_Linker_Alias             |
+           Pragma_Linker_Options           |
+           Pragma_Linker_Section           |
+           Pragma_Locking_Policy           |
+           Pragma_Long_Float               |
+           Pragma_Machine_Attribute        |
+           Pragma_Main                     |
+           Pragma_Main_Storage             |
+           Pragma_Memory_Size              |
+           Pragma_No_Return                |
+           Pragma_No_Run_Time              |
+           Pragma_Normalize_Scalars        |
+           Pragma_Optimize                 |
+           Pragma_Pack                     |
+           Pragma_Passive                  |
+           Pragma_Polling                  |
+           Pragma_Preelaborate             |
+           Pragma_Priority                 |
+           Pragma_Propagate_Exceptions     |
+           Pragma_Psect_Object             |
+           Pragma_Pure                     |
+           Pragma_Pure_Function            |
+           Pragma_Queuing_Policy           |
+           Pragma_Remote_Call_Interface    |
+           Pragma_Remote_Types             |
+           Pragma_Restrictions             |
+           Pragma_Restricted_Run_Time      |
+           Pragma_Ravenscar                |
+           Pragma_Reviewable               |
+           Pragma_Share_Generic            |
+           Pragma_Shared                   |
+           Pragma_Shared_Passive           |
+           Pragma_Storage_Size             |
+           Pragma_Storage_Unit             |
+           Pragma_Stream_Convert           |
+           Pragma_Subtitle                 |
+           Pragma_Suppress                 |
+           Pragma_Suppress_All             |
+           Pragma_Suppress_Debug_Info      |
+           Pragma_Suppress_Initialization  |
+           Pragma_System_Name              |
+           Pragma_Task_Dispatching_Policy  |
+           Pragma_Task_Info                |
+           Pragma_Task_Name                |
+           Pragma_Task_Storage             |
+           Pragma_Time_Slice               |
+           Pragma_Title                    |
+           Pragma_Unchecked_Union          |
+           Pragma_Unimplemented_Unit       |
+           Pragma_Unreserve_All_Interrupts |
+           Pragma_Unsuppress               |
+           Pragma_Use_VADS_Size            |
+           Pragma_Volatile                 |
+           Pragma_Volatile_Components      |
+           Pragma_Weak_External            |
+           Pragma_Validity_Checks          =>
+         null;
+
+   end case;
+
+   return Pragma_Node;
+
+   --------------------
+   -- Error Handling --
+   --------------------
+
+exception
+   when Error_Resync =>
+      return Error;
+
+end Prag;
diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb
new file mode 100644
index 0000000..d1ba793
--- /dev/null
+++ b/gcc/ada/par-sync.adb
@@ -0,0 +1,312 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . S Y N C                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+separate (Par)
+package body Sync is
+
+   procedure Resync_Init;
+   --  This routine is called on initiating a resynchronization action
+
+   procedure Resync_Resume;
+   --  This routine is called on completing a resynchronization action
+
+   -------------------
+   -- Resync_Choice --
+   -------------------
+
+   procedure Resync_Choice is
+   begin
+      Resync_Init;
+
+      --  Loop till we get a token that terminates a choice. Note that EOF is
+      --  one such token, so we are sure to get out of this loop eventually!
+
+      while Token not in Token_Class_Cterm loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Choice;
+
+   ------------------
+   -- Resync_Cunit --
+   ------------------
+
+   procedure Resync_Cunit is
+   begin
+      Resync_Init;
+
+      while Token not in Token_Class_Cunit
+        and then Token /= Tok_EOF
+      loop
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Cunit;
+
+   -----------------------
+   -- Resync_Expression --
+   -----------------------
+
+   procedure Resync_Expression is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         --  Terminating tokens are those in class Eterm and also RANGE,
+         --  DIGITS or DELTA if not preceded by an apostrophe (if they are
+         --  preceded by an apostrophe, then they are attributes). In addiion,
+         --  at the outer parentheses level only, we also consider a comma,
+         --  right parenthesis or vertical bar to terminate an expression.
+
+         if Token in Token_Class_Eterm
+
+           or else (Token in Token_Class_Atkwd
+                     and then Prev_Token /= Tok_Apostrophe)
+
+           or else (Paren_Count = 0
+                     and then
+                       (Token = Tok_Comma
+                         or else Token = Tok_Right_Paren
+                         or else Token = Tok_Vertical_Bar))
+         then
+            --  A special check: if we stop on the ELSE of OR ELSE or the
+            --  THEN of AND THEN, keep going, because this is not really an
+            --  expression terminator after all. Also, keep going past WITH
+            --  since this can be part of an extension aggregate
+
+            if (Token = Tok_Else and then Prev_Token = Tok_Or)
+               or else (Token = Tok_Then and then Prev_Token = Tok_And)
+               or else Token = Tok_With
+            then
+               null;
+            else
+               exit;
+            end if;
+         end if;
+
+         if Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            Paren_Count := Paren_Count - 1;
+
+         end if;
+
+         Scan; -- past token to be skipped
+      end loop;
+
+      Resync_Resume;
+   end Resync_Expression;
+
+   -----------------
+   -- Resync_Init --
+   -----------------
+
+   procedure Resync_Init is
+   begin
+      --  The following check makes sure we do not get stuck in an infinite
+      --  loop resynchonizing and getting nowhere. If we are called to do a
+      --  resynchronize and we are exactly at the same point that we left off
+      --  on the last resynchronize call, then we force at least one token to
+      --  be skipped so that we make progress!
+
+      if Token_Ptr = Last_Resync_Point then
+         Scan; -- to skip at least one token
+      end if;
+
+      --  Output extra error message if debug R flag is set
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resynchronizing!");
+      end if;
+   end Resync_Init;
+
+   ---------------------------
+   -- Resync_Past_Semicolon --
+   ---------------------------
+
+   procedure Resync_Past_Semicolon is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if we are at a semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif Token in Token_Class_After_SM
+            and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon;
+
+   ----------------------------------------------
+   -- Resync_Past_Semicolon_Or_To_Loop_Or_Then --
+   ----------------------------------------------
+
+   procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon
+
+         if Token = Tok_Semicolon then
+            Scan; -- past the semicolon
+            exit;
+
+         --  Done if we are at a token which normally appears only after
+         --  a semicolon. One special glitch is that the keyword private is
+         --  in this category only if it does NOT appear after WITH.
+
+         elsif (Token in Token_Class_After_SM
+                  and then (Token /= Tok_Private
+                              or else Prev_Token /= Tok_With))
+         then
+            exit;
+
+         --  Done if we are at THEN or LOOP
+
+         elsif Token = Tok_Then or else Token = Tok_Loop then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_Past_Semicolon_Or_To_Loop_Or_Then;
+
+   -------------------
+   -- Resync_Resume --
+   -------------------
+
+   procedure Resync_Resume is
+   begin
+      --  Save resync point (see special test in Resync_Init)
+
+      Last_Resync_Point := Token_Ptr;
+
+      if Debug_Flag_R then
+         Error_Msg_SC ("resuming here!");
+      end if;
+   end Resync_Resume;
+
+   --------------------
+   -- Resync_To_When --
+   --------------------
+
+   procedure Resync_To_When is
+   begin
+      Resync_Init;
+
+      loop
+         --  Done if at semicolon, WHEN or IS
+
+         if Token = Tok_Semicolon
+           or else Token = Tok_When
+           or else Token = Tok_Is
+         then
+            exit;
+
+         --  Otherwise keep going
+
+         else
+            Scan;
+         end if;
+      end loop;
+
+      --  Fall out of loop with resyncrhonization complete
+
+      Resync_Resume;
+   end Resync_To_When;
+
+   ---------------------------
+   -- Resync_Semicolon_List --
+   ---------------------------
+
+   procedure Resync_Semicolon_List is
+      Paren_Count : Int;
+
+   begin
+      Resync_Init;
+      Paren_Count := 0;
+
+      loop
+         if Token = Tok_EOF
+           or else Token = Tok_Semicolon
+           or else Token = Tok_Is
+           or else Token in Token_Class_After_SM
+         then
+            exit;
+
+         elsif Token = Tok_Left_Paren then
+            Paren_Count := Paren_Count + 1;
+
+         elsif Token = Tok_Right_Paren then
+            if Paren_Count = 0 then
+               exit;
+            else
+               Paren_Count := Paren_Count - 1;
+            end if;
+         end if;
+
+         Scan;
+      end loop;
+
+      Resync_Resume;
+   end Resync_Semicolon_List;
+
+end Sync;
diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb
new file mode 100644
index 0000000..4d49e7a
--- /dev/null
+++ b/gcc/ada/par-tchk.adb
@@ -0,0 +1,812 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . T C H K                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.37 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Token scan routines.
+
+--  Error recovery: none of the T_xxx or TF_xxx routines raise Error_Resync
+
+separate (Par)
+package body Tchk is
+
+   type Position is (SC, BC, AP);
+   --  Specify position of error message (see Error_Msg_SC/BC/AP)
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Token (T : Token_Type; P : Position);
+   pragma Inline (Check_Token);
+   --  Called by T_xx routines to check for reserved keyword token. P is the
+   --  position of the error message if the token is missing (see Wrong_Token)
+
+   procedure Wrong_Token (T : Token_Type; P : Position);
+   --  Called when scanning a reserved keyword when the keyword is not
+   --  present. T is the token type for the keyword, and P indicates the
+   --  position to be used to place a message relative to the current
+   --  token if the keyword is not located nearby.
+
+   -----------------
+   -- Check_Token --
+   -----------------
+
+   procedure Check_Token (T : Token_Type; P : Position) is
+   begin
+      if Token = T then
+         Scan;
+         return;
+      else
+         Wrong_Token (T, P);
+      end if;
+   end Check_Token;
+
+   -------------
+   -- T_Abort --
+   -------------
+
+   procedure T_Abort is
+   begin
+      Check_Token (Tok_Abort, SC);
+   end T_Abort;
+
+   -------------
+   -- T_Arrow --
+   -------------
+
+   procedure T_Arrow is
+   begin
+      if Token = Tok_Arrow then
+         Scan;
+
+      --  A little recovery helper, accept then in place of =>
+
+      elsif Token = Tok_Then then
+         Error_Msg_BC ("missing ""=>""");
+         Scan; -- past THEN used in place of =>
+
+      elsif Token = Tok_Colon_Equal then
+         Error_Msg_SC (""":="" should be ""=>""");
+         Scan; -- past := used in place of =>
+
+      else
+         Error_Msg_AP ("missing ""=>""");
+      end if;
+   end T_Arrow;
+
+   ----------
+   -- T_At --
+   ----------
+
+   procedure T_At is
+   begin
+      Check_Token (Tok_At, SC);
+   end T_At;
+
+   ------------
+   -- T_Body --
+   ------------
+
+   procedure T_Body is
+   begin
+      Check_Token (Tok_Body, BC);
+   end T_Body;
+
+   -----------
+   -- T_Box --
+   -----------
+
+   procedure T_Box is
+   begin
+      if Token = Tok_Box then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""<>""");
+      end if;
+   end T_Box;
+
+   -------------
+   -- T_Colon --
+   -------------
+
+   procedure T_Colon is
+   begin
+      if Token = Tok_Colon then
+         Scan;
+      else
+         Error_Msg_AP ("missing "":""");
+      end if;
+   end T_Colon;
+
+   -------------------
+   -- T_Colon_Equal --
+   -------------------
+
+   procedure T_Colon_Equal is
+   begin
+      if Token = Tok_Colon_Equal then
+         Scan;
+
+      elsif Token = Tok_Equal then
+         Error_Msg_SC ("""="" should be "":=""");
+         Scan;
+
+      elsif Token = Tok_Colon then
+         Error_Msg_SC (""":"" should be "":=""");
+         Scan;
+
+      elsif Token = Tok_Is then
+         Error_Msg_SC ("IS should be "":=""");
+         Scan;
+
+      else
+         Error_Msg_AP ("missing "":=""");
+      end if;
+   end T_Colon_Equal;
+
+   -------------
+   -- T_Comma --
+   -------------
+
+   procedure T_Comma is
+   begin
+      if Token = Tok_Comma then
+         Scan;
+
+      else
+         if Token = Tok_Pragma then
+            P_Pragmas_Misplaced;
+         end if;
+
+         if Token = Tok_Comma then
+            Scan;
+         else
+            Error_Msg_AP ("missing "",""");
+         end if;
+      end if;
+
+      if Token = Tok_Pragma then
+         P_Pragmas_Misplaced;
+      end if;
+   end T_Comma;
+
+   ---------------
+   -- T_Dot_Dot --
+   ---------------
+
+   procedure T_Dot_Dot is
+   begin
+      if Token = Tok_Dot_Dot then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""..""");
+      end if;
+   end T_Dot_Dot;
+
+   -----------
+   -- T_For --
+   -----------
+
+   procedure T_For is
+   begin
+      Check_Token (Tok_For, AP);
+   end T_For;
+
+   -----------------------
+   -- T_Greater_Greater --
+   -----------------------
+
+   procedure T_Greater_Greater is
+   begin
+      if Token = Tok_Greater_Greater then
+         Scan;
+      else
+         Error_Msg_AP ("missing "">>""");
+      end if;
+   end T_Greater_Greater;
+
+   ------------------
+   -- T_Identifier --
+   ------------------
+
+   procedure T_Identifier is
+   begin
+      if Token = Tok_Identifier then
+         Scan;
+      elsif Token in Token_Class_Literal then
+         Error_Msg_SC ("identifier expected");
+         Scan;
+      else
+         Error_Msg_AP ("identifier expected");
+      end if;
+   end T_Identifier;
+
+   ----------
+   -- T_In --
+   ----------
+
+   procedure T_In is
+   begin
+      Check_Token (Tok_In, AP);
+   end T_In;
+
+   ----------
+   -- T_Is --
+   ----------
+
+   procedure T_Is is
+   begin
+      if Token = Tok_Is then
+         Scan;
+
+         Ignore (Tok_Semicolon);
+
+      --  Allow OF, => or = to substitute for IS with complaint
+
+      elsif Token = Tok_Arrow
+        or else Token = Tok_Of
+        or else Token = Tok_Equal
+      then
+         Error_Msg_SC ("missing IS");
+         Scan; -- token used in place of IS
+      else
+         Wrong_Token (Tok_Is, AP);
+      end if;
+
+      while Token = Tok_Is loop
+         Error_Msg_SC ("extra IS ignored");
+         Scan;
+      end loop;
+   end T_Is;
+
+   ------------------
+   -- T_Left_Paren --
+   ------------------
+
+   procedure T_Left_Paren is
+   begin
+      if Token = Tok_Left_Paren then
+         Scan;
+      else
+         Error_Msg_AP ("missing ""(""");
+      end if;
+   end T_Left_Paren;
+
+   ------------
+   -- T_Loop --
+   ------------
+
+   procedure T_Loop is
+   begin
+      if Token = Tok_Do then
+         Error_Msg_SC ("LOOP expected");
+         Scan;
+      else
+         Check_Token (Tok_Loop, AP);
+      end if;
+   end T_Loop;
+
+   -----------
+   -- T_Mod --
+   -----------
+
+   procedure T_Mod is
+   begin
+      Check_Token (Tok_Mod, AP);
+   end T_Mod;
+
+   -----------
+   -- T_New --
+   -----------
+
+   procedure T_New is
+   begin
+      Check_Token (Tok_New, AP);
+   end T_New;
+
+   ----------
+   -- T_Of --
+   ----------
+
+   procedure T_Of is
+   begin
+      Check_Token (Tok_Of, AP);
+   end T_Of;
+
+   ----------
+   -- T_Or --
+   ----------
+
+   procedure T_Or is
+   begin
+      Check_Token (Tok_Or, AP);
+   end T_Or;
+
+   ---------------
+   -- T_Private --
+   ---------------
+
+   procedure T_Private is
+   begin
+      Check_Token (Tok_Private, SC);
+   end T_Private;
+
+   -------------
+   -- T_Range --
+   -------------
+
+   procedure T_Range is
+   begin
+      Check_Token (Tok_Range, AP);
+   end T_Range;
+
+   --------------
+   -- T_Record --
+   --------------
+
+   procedure T_Record is
+   begin
+      Check_Token (Tok_Record, AP);
+   end T_Record;
+
+   -------------------
+   -- T_Right_Paren --
+   -------------------
+
+   procedure T_Right_Paren is
+   begin
+      if Token = Tok_Right_Paren then
+         Scan;
+      else
+         Error_Msg_AP ("missing "")""");
+      end if;
+   end T_Right_Paren;
+
+   -----------------
+   -- T_Semicolon --
+   -----------------
+
+   procedure T_Semicolon is
+   begin
+
+      if Token = Tok_Semicolon then
+         Scan;
+
+         if Token = Tok_Semicolon then
+            Error_Msg_SC ("extra "";"" ignored");
+            Scan;
+         end if;
+
+      elsif Token = Tok_Colon then
+         Error_Msg_SC (""":"" should be "";""");
+         Scan;
+
+      elsif Token = Tok_Comma then
+         Error_Msg_SC (""","" should be "";""");
+         Scan;
+
+      elsif Token = Tok_Dot then
+         Error_Msg_SC ("""."" should be "";""");
+         Scan;
+
+      --  An interesting little kludge here. If the previous token is a
+      --  semicolon, then there is no way that we can legitimately need
+      --  another semicolon. This could only arise in an error situation
+      --  where an error has already been signalled. By simply ignoring
+      --  the request for a semicolon in this case, we avoid some spurious
+      --  missing semicolon messages.
+
+      elsif Prev_Token = Tok_Semicolon then
+         return;
+
+      --  If the current token is | then this is a reasonable
+      --  place to suggest the possibility of a "C" confusion :-)
+
+      elsif Token = Tok_Vertical_Bar then
+         Error_Msg_SC ("unexpected occurrence of ""|"", did you mean OR'?");
+         Resync_Past_Semicolon;
+
+      --  Otherwise we really do have a missing semicolon
+
+      else
+         Error_Msg_AP ("missing "";""");
+         return;
+      end if;
+
+   end T_Semicolon;
+
+   ------------
+   -- T_Then --
+   ------------
+
+   procedure T_Then is
+   begin
+      Check_Token (Tok_Then, AP);
+   end T_Then;
+
+   ------------
+   -- T_Type --
+   ------------
+
+   procedure T_Type is
+   begin
+      Check_Token (Tok_Type, BC);
+   end T_Type;
+
+   -----------
+   -- T_Use --
+   -----------
+
+   procedure T_Use is
+   begin
+      Check_Token (Tok_Use, SC);
+   end T_Use;
+
+   ------------
+   -- T_When --
+   ------------
+
+   procedure T_When is
+   begin
+      Check_Token (Tok_When, SC);
+   end T_When;
+
+   ------------
+   -- T_With --
+   ------------
+
+   procedure T_With is
+   begin
+      Check_Token (Tok_With, BC);
+   end T_With;
+
+   --------------
+   -- TF_Arrow --
+   --------------
+
+   procedure TF_Arrow is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Arrow then
+         Scan; -- skip arrow and we are done
+
+      elsif Token = Tok_Colon_Equal then
+         T_Arrow; -- Let T_Arrow give the message
+
+      else
+         T_Arrow; -- give missing arrow message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Arrow then
+               Scan; -- past arrow
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Arrow;
+
+   -----------
+   -- TF_Is --
+   -----------
+
+   procedure TF_Is is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Is then
+         T_Is; -- past IS and we are done
+
+      --  Allow OF or => or = in place of IS (with error message)
+
+      elsif Token = Tok_Of
+        or else Token = Tok_Arrow
+        or else Token = Tok_Equal
+      then
+         T_Is; -- give missing IS message and skip bad token
+
+      else
+         T_Is; -- give missing IS message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Is
+              or else Token = Tok_Of
+              or else Token = Tok_Arrow
+            then
+               Scan; -- past IS or OF or =>
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Is;
+
+   -------------
+   -- TF_Loop --
+   -------------
+
+   procedure TF_Loop is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Loop then
+         Scan; -- past LOOP and we are done
+
+      --  Allow DO or THEN in place of LOOP
+
+      elsif Token = Tok_Then or else Token = Tok_Do then
+         T_Loop; -- give missing LOOP message
+
+      else
+         T_Loop; -- give missing LOOP message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Loop or else Token = Tok_Then then
+               Scan; -- past loop or then (message already generated)
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Loop;
+
+   --------------
+   -- TF_Return--
+   --------------
+
+   procedure TF_Return is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Return then
+         Scan; -- skip RETURN and we are done
+
+      else
+         Error_Msg_SC ("missing RETURN");
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were!
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Return then
+               Scan; -- past RETURN
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Return;
+
+   ------------------
+   -- TF_Semicolon --
+   ------------------
+
+   procedure TF_Semicolon is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Semicolon then
+         T_Semicolon;
+         return;
+
+      --  An interesting little kludge here. If the previous token is a
+      --  semicolon, then there is no way that we can legitimately need
+      --  another semicolon. This could only arise in an error situation
+      --  where an error has already been signalled. By simply ignoring
+      --  the request for a semicolon in this case, we avoid some spurious
+      --  missing semicolon messages.
+
+      elsif Prev_Token = Tok_Semicolon then
+         return;
+
+      else
+         if Token = Tok_Pragma then
+            P_Pragmas_Misplaced;
+
+            if Token = Tok_Semicolon then
+               T_Semicolon;
+               return;
+            end if;
+         end if;
+
+         T_Semicolon; -- give missing semicolon message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search
+
+            if Token = Tok_Semicolon then
+               T_Semicolon;
+               return;
+
+            elsif Token in Token_Class_After_SM then
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Semicolon;
+
+   -------------
+   -- TF_Then --
+   -------------
+
+   procedure TF_Then is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Then then
+         Scan; -- past THEN and we are done
+
+      else
+         T_Then; -- give missing THEN message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Then then
+               Scan; -- past THEN
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Then;
+
+   ------------
+   -- TF_Use --
+   ------------
+
+   procedure TF_Use is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Use then
+         Scan; -- past USE and we are done
+
+      else
+         T_Use; -- give USE expected message
+         Save_Scan_State (Scan_State); -- at start of junk tokens
+
+         loop
+            if Prev_Token_Ptr < Current_Line_Start
+              or else Token = Tok_Semicolon
+              or else Token = Tok_EOF
+            then
+               Restore_Scan_State (Scan_State); -- to where we were
+               return;
+            end if;
+
+            Scan; -- continue search!
+
+            if Token = Tok_Use then
+               Scan; -- past use
+               return;
+            end if;
+         end loop;
+      end if;
+   end TF_Use;
+
+   -----------------
+   -- Wrong_Token --
+   -----------------
+
+   procedure Wrong_Token (T : Token_Type; P : Position) is
+      Missing : constant String := "missing ";
+      Image : constant String := Token_Type'Image (T);
+      Tok_Name : constant String := Image (5 .. Image'Length);
+      M : String (1 .. Missing'Length + Tok_Name'Length);
+
+   begin
+      --  Set M to Missing & Tok_Name.
+
+      M (1 .. Missing'Length) := Missing;
+      M (Missing'Length + 1 .. M'Last) := Tok_Name;
+
+      if Token = Tok_Semicolon then
+         Scan;
+
+         if Token = T then
+            Error_Msg_SP ("extra "";"" ignored");
+            Scan;
+         else
+            Error_Msg_SP (M);
+         end if;
+
+      elsif Token = Tok_Comma then
+         Scan;
+
+         if Token = T then
+            Error_Msg_SP ("extra "","" ignored");
+            Scan;
+
+         else
+            Error_Msg_SP (M);
+         end if;
+
+      else
+         case P is
+            when SC => Error_Msg_SC (M);
+            when BC => Error_Msg_BC (M);
+            when AP => Error_Msg_AP (M);
+         end case;
+      end if;
+   end Wrong_Token;
+
+end Tchk;
diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb
new file mode 100644
index 0000000..f8082b6
--- /dev/null
+++ b/gcc/ada/par-util.adb
@@ -0,0 +1,638 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P A R . U T I L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.64 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Uintp; use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+separate (Par)
+package body Util is
+
+   ---------------------
+   -- Bad_Spelling_Of --
+   ---------------------
+
+   function Bad_Spelling_Of (T : Token_Type) return Boolean is
+      Tname : constant String := Token_Type'Image (T);
+      --  Characters of token name
+
+      S : String (1 .. Tname'Last - 4);
+      --  Characters of token name folded to lower case, omitting TOK_ at start
+
+      M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
+      M2 : String (1 .. 44) := "illegal abbreviation of keyword ************";
+      --  Buffers used to construct error message
+
+      P1 : constant := 30;
+      P2 : constant := 32;
+      --  Starting subscripts in M1, M2 for keyword name
+
+      SL : constant Natural := S'Length;
+      --  Length of expected token name excluding TOK_ at start
+
+   begin
+      if Token /= Tok_Identifier then
+         return False;
+      end if;
+
+      for J in S'Range loop
+         S (J) := Fold_Lower (Tname (Integer (J) + 4));
+      end loop;
+
+      Get_Name_String (Token_Name);
+
+      --  A special check for case of PROGRAM used for PROCEDURE
+
+      if T = Tok_Procedure
+        and then Name_Len = 7
+        and then Name_Buffer (1 .. 7) = "program"
+      then
+         Error_Msg_SC ("PROCEDURE expected");
+         Token := T;
+         return True;
+
+      --  A special check for an illegal abbrevation
+
+      elsif Name_Len < S'Length
+        and then Name_Len >= 4
+        and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
+      then
+         for J in 1 .. S'Last loop
+            M2 (P2 + J - 1) := Fold_Upper (S (J));
+         end loop;
+
+         Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
+         Token := T;
+         return True;
+      end if;
+
+      --  Now we go into the full circuit to check for a misspelling
+
+      --  Never consider something a misspelling if either the actual or
+      --  expected string is less than 3 characters (before this check we
+      --  used to consider i to be a misspelled if in some cases!)
+
+      if SL < 3 or else Name_Len < 3 then
+         return False;
+
+      --  Special case: prefix matches, i.e. the leading characters of the
+      --  token that we have exactly match the required keyword. If there
+      --  are at least two characters left over, assume that we have a case
+      --  of two keywords joined together which should not be joined.
+
+      elsif Name_Len > SL + 1
+        and then S = Name_Buffer (1 .. SL)
+      then
+         Scan_Ptr := Token_Ptr + S'Length;
+         Error_Msg_S ("missing space");
+         Token := T;
+         return True;
+      end if;
+
+      if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
+
+         for J in 1 .. S'Last loop
+            M1 (P1 + J - 1) := Fold_Upper (S (J));
+         end loop;
+
+         Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last));
+         Token := T;
+         return True;
+
+      else
+         return False;
+      end if;
+
+   end Bad_Spelling_Of;
+
+   ----------------------
+   -- Check_95_Keyword --
+   ----------------------
+
+   --  On entry, the caller has checked that current token is an identifier
+   --  whose name matches the name of the 95 keyword New_Tok.
+
+   procedure Check_95_Keyword (Token_95, Next : Token_Type) is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      Save_Scan_State (Scan_State); -- at identifier/keyword
+      Scan; -- past identifier/keyword
+
+      if Token = Next then
+         Restore_Scan_State (Scan_State); -- to identifier
+         Error_Msg_Name_1 := Token_Name;
+         Error_Msg_SC ("(Ada 83) keyword* cannot be used!");
+         Token := Token_95;
+      else
+         Restore_Scan_State (Scan_State); -- to identifier
+      end if;
+   end Check_95_Keyword;
+
+   ----------------------
+   -- Check_Bad_Layout --
+   ----------------------
+
+   procedure Check_Bad_Layout is
+   begin
+      if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
+        and then Start_Column <= Scope.Table (Scope.Last).Ecol
+      then
+         Error_Msg_BC ("(style) incorrect layout");
+      end if;
+   end Check_Bad_Layout;
+
+   --------------------------
+   -- Check_Misspelling_Of --
+   --------------------------
+
+   procedure Check_Misspelling_Of (T : Token_Type) is
+   begin
+      if Bad_Spelling_Of (T) then
+         null;
+      end if;
+   end Check_Misspelling_Of;
+
+   -----------------------------
+   -- Check_Simple_Expression --
+   -----------------------------
+
+   procedure Check_Simple_Expression (E : Node_Id) is
+   begin
+      if Expr_Form = EF_Non_Simple then
+         Error_Msg_N ("this expression must be parenthesized", E);
+      end if;
+   end Check_Simple_Expression;
+
+   ---------------------------------------
+   -- Check_Simple_Expression_In_Ada_83 --
+   ---------------------------------------
+
+   procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
+   begin
+      if Expr_Form = EF_Non_Simple then
+         if Ada_83 then
+            Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
+         end if;
+      end if;
+   end Check_Simple_Expression_In_Ada_83;
+
+   ------------------------
+   -- Check_Subtype_Mark --
+   ------------------------
+
+   function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is
+   begin
+      if Nkind (Mark) = N_Identifier
+        or else Nkind (Mark) = N_Selected_Component
+        or else (Nkind (Mark) = N_Attribute_Reference
+                  and then Is_Type_Attribute_Name (Attribute_Name (Mark)))
+        or else Mark = Error
+      then
+         return Mark;
+      else
+         Error_Msg ("subtype mark expected", Sloc (Mark));
+         return Error;
+      end if;
+   end Check_Subtype_Mark;
+
+   -------------------
+   -- Comma_Present --
+   -------------------
+
+   function Comma_Present return Boolean is
+      Scan_State  : Saved_Scan_State;
+      Paren_Count : Nat;
+
+   begin
+      --  First check, if a comma is present, then a comma is present!
+
+      if Token = Tok_Comma then
+         T_Comma;
+         return True;
+
+      --  If we have a right paren, then that is taken as ending the list
+      --  i.e. no comma is present.
+
+      elsif Token = Tok_Right_Paren then
+         return False;
+
+      --  If pragmas, then get rid of them and make a recursive call
+      --  to process what follows these pragmas.
+
+      elsif Token = Tok_Pragma then
+         P_Pragmas_Misplaced;
+         return Comma_Present;
+
+      --  At this stage we have an error, and the goal is to decide on whether
+      --  or not we should diagnose an error and report a (non-existent)
+      --  comma as being present, or simply to report no comma is present
+
+      --  If we are a semicolon, then the question is whether we have a missing
+      --  right paren, or whether the semicolon should have been a comma. To
+      --  guess the right answer, we scan ahead keeping track of the paren
+      --  level, looking for a clue that helps us make the right decision.
+
+      --  This approach is highly accurate in the single error case, and does
+      --  not make bad mistakes in the multiple error case (indeed we can't
+      --  really make a very bad decision at this point in any case).
+
+      elsif Token = Tok_Semicolon then
+         Save_Scan_State (Scan_State);
+         Scan; -- past semicolon
+
+         --  Check for being followed by identifier => which almost certainly
+         --  means we are still in a parameter list and the comma should have
+         --  been a semicolon (such a sequence could not follow a semicolon)
+
+         if Token = Tok_Identifier then
+            Scan;
+
+            if Token = Tok_Arrow then
+               goto Assume_Comma;
+            end if;
+         end if;
+
+         --  If that test didn't work, loop ahead looking for a comma or
+         --  semicolon at the same parenthesis level. Always remember that
+         --  we can't go badly wrong in an error situation like this!
+
+         Paren_Count := 0;
+
+         --  Here is the look ahead loop, Paren_Count tells us whether the
+         --  token we are looking at is at the same paren level as the
+         --  suspicious semicolon that we are trying to figure out.
+
+         loop
+
+            --  If we hit another semicolon or an end of file, and we have
+            --  not seen a right paren or another comma on the way, then
+            --  probably the semicolon did end the list. Indeed that is
+            --  certainly the only single error correction possible here.
+
+            if Token = Tok_Semicolon or else Token = Tok_EOF then
+               Restore_Scan_State (Scan_State);
+               return False;
+
+            --  A comma at the same paren level as the semicolon is a strong
+            --  indicator that the semicolon should have been a comma, indeed
+            --  again this is the only possible single error correction.
+
+            elsif Token = Tok_Comma then
+               exit when Paren_Count = 0;
+
+            --  A left paren just bumps the paren count
+
+            elsif Token = Tok_Left_Paren then
+               Paren_Count := Paren_Count + 1;
+
+            --  A right paren that is at the same paren level as the semicolon
+            --  also means that the only possible single error correction is
+            --  to assume that the semicolon should have been a comma. If we
+            --  are not at the same paren level, then adjust the paren level.
+
+            elsif Token = Tok_Right_Paren then
+               exit when Paren_Count = 0;
+               Paren_Count := Paren_Count - 1;
+            end if;
+
+            --  Keep going, we haven't made a decision yet
+
+            Scan;
+         end loop;
+
+         --  If we fall through the loop, it means that we found a terminating
+         --  right paren or another comma. In either case it is reasonable to
+         --  assume that the semicolon was really intended to be a comma. Also
+         --  come here for the identifier arrow case.
+
+         <<Assume_Comma>>
+            Restore_Scan_State (Scan_State);
+            Error_Msg_SC (""";"" illegal here, replaced by "",""");
+            Scan; -- past the semicolon
+            return True;
+
+      --  If we are not at semicolon or a right paren, then we base the
+      --  decision on whether or not the next token can be part of an
+      --  expression. If not, then decide that no comma is present (the
+      --  caller will eventually generate a missing right parent message)
+
+      elsif Token in Token_Class_Eterm then
+         return False;
+
+      --  Otherwise we assume a comma is present, even if none is present,
+      --  since the next token must be part of an expression, so if we were
+      --  at the end of the list, then there is more than one error present.
+
+      else
+         T_Comma; -- to give error
+         return True;
+      end if;
+   end Comma_Present;
+
+   -----------------------
+   -- Discard_Junk_List --
+   -----------------------
+
+   procedure Discard_Junk_List (L : List_Id) is
+   begin
+      null;
+   end Discard_Junk_List;
+
+   -----------------------
+   -- Discard_Junk_Node --
+   -----------------------
+
+   procedure Discard_Junk_Node (N : Node_Id) is
+   begin
+      null;
+   end Discard_Junk_Node;
+
+   ------------
+   -- Ignore --
+   ------------
+
+   procedure Ignore (T : Token_Type) is
+   begin
+      if Token = T then
+         if T = Tok_Comma then
+            Error_Msg_SC ("unexpected "","" ignored");
+
+         elsif T = Tok_Left_Paren then
+            Error_Msg_SC ("unexpected ""("" ignored");
+
+         elsif T = Tok_Right_Paren then
+            Error_Msg_SC ("unexpected "")"" ignored");
+
+         elsif T = Tok_Semicolon then
+            Error_Msg_SC ("unexpected "";"" ignored");
+
+         else
+            declare
+               Tname : constant String := Token_Type'Image (Token);
+               Msg   : String := "unexpected keyword ????????????????????????";
+
+            begin
+               --  Loop to copy characters of keyword name (ignoring Tok_)
+
+               for J in 5 .. Tname'Last loop
+                  Msg (J + 14) := Fold_Upper (Tname (J));
+               end loop;
+
+               Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored";
+               Error_Msg_SC (Msg (1 .. Tname'Last + 22));
+            end;
+         end if;
+
+         Scan; -- Scan past ignored token
+      end if;
+   end Ignore;
+
+   ----------------------------
+   -- Is_Reserved_Identifier --
+   ----------------------------
+
+   function Is_Reserved_Identifier return Boolean is
+   begin
+      if not Is_Reserved_Keyword (Token) then
+         return False;
+
+      else
+         declare
+            Ident_Casing : constant Casing_Type :=
+                             Identifier_Casing (Current_Source_File);
+
+            Key_Casing   : constant Casing_Type :=
+                             Keyword_Casing (Current_Source_File);
+
+         begin
+            --  If the casing of identifiers and keywords is different in
+            --  this source file, and the casing of this token matches the
+            --  keyword casing, then we return False, since it is pretty
+            --  clearly intended to be a keyword.
+
+            if Ident_Casing /= Unknown
+              and then Key_Casing /= Unknown
+              and then Ident_Casing /= Key_Casing
+              and then Determine_Token_Casing = Key_Casing
+            then
+               return False;
+
+            --  Otherwise assume that an identifier was intended
+
+            else
+               return True;
+            end if;
+         end;
+      end if;
+   end Is_Reserved_Identifier;
+
+   ----------------------
+   -- Merge_Identifier --
+   ----------------------
+
+   procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is
+   begin
+      if Token /= Tok_Identifier then
+         return;
+      end if;
+
+      declare
+         S : Saved_Scan_State;
+         T : Token_Type;
+
+      begin
+         Save_Scan_State (S);
+         Scan;
+         T := Token;
+         Restore_Scan_State (S);
+
+         if T /= Nxt then
+            return;
+         end if;
+      end;
+
+      --  Check exactly one space between identifiers
+
+      if Source (Token_Ptr - 1) /= ' '
+        or else Int (Token_Ptr) /=
+                  Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1
+      then
+         return;
+      end if;
+
+      --  Do the merge
+
+      Get_Name_String (Chars (Token_Node));
+
+      declare
+         Buf : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+
+      begin
+         Get_Name_String (Chars (Prev));
+         Add_Char_To_Name_Buffer ('_');
+         Add_Str_To_Name_Buffer (Buf);
+         Set_Chars (Prev, Name_Find);
+      end;
+
+      Error_Msg_Node_1 := Prev;
+      Error_Msg_SC
+        ("unexpected identifier, possibly & was meant here");
+      Scan;
+   end Merge_Identifier;
+
+   -------------------
+   -- No_Constraint --
+   -------------------
+
+   procedure No_Constraint is
+   begin
+      if Token in Token_Class_Consk then
+         Error_Msg_SC ("constraint not allowed here");
+         Discard_Junk_Node (P_Constraint_Opt);
+      end if;
+   end No_Constraint;
+
+   --------------------
+   -- No_Right_Paren --
+   --------------------
+
+   function No_Right_Paren (Expr : Node_Id) return Node_Id is
+   begin
+      if Token = Tok_Right_Paren then
+         Error_Msg_SC ("unexpected right parenthesis");
+         Resync_Expression;
+         return Error;
+      else
+         return Expr;
+      end if;
+   end No_Right_Paren;
+
+   ---------------------
+   -- Pop_Scope_Stack --
+   ---------------------
+
+   procedure Pop_Scope_Stack is
+   begin
+      pragma Assert (Scope.Last > 0);
+      Scope.Decrement_Last;
+
+      if Debug_Flag_P then
+         Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
+         Error_Msg_SC ("decrement scope stack ptr, new value = ^!");
+      end if;
+   end Pop_Scope_Stack;
+
+   ----------------------
+   -- Push_Scope_Stack --
+   ----------------------
+
+   procedure Push_Scope_Stack is
+   begin
+      Scope.Increment_Last;
+      Scope.Table (Scope.Last).Junk := False;
+      Scope.Table (Scope.Last).Node := Empty;
+
+      if Debug_Flag_P then
+         Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
+         Error_Msg_SC ("increment scope stack ptr, new value = ^!");
+      end if;
+   end Push_Scope_Stack;
+
+   ----------------------
+   -- Separate_Present --
+   ----------------------
+
+   function Separate_Present return Boolean is
+      Scan_State : Saved_Scan_State;
+
+   begin
+      if Token = Tok_Separate then
+         return True;
+
+      elsif Token /= Tok_Identifier then
+         return False;
+
+      else
+         Save_Scan_State (Scan_State);
+         Scan; -- past identifier
+
+         if Token = Tok_Semicolon then
+            Restore_Scan_State (Scan_State);
+            return Bad_Spelling_Of (Tok_Separate);
+
+         else
+            Restore_Scan_State (Scan_State);
+            return False;
+         end if;
+      end if;
+   end Separate_Present;
+
+   --------------------------
+   -- Signal_Bad_Attribute --
+   --------------------------
+
+   procedure Signal_Bad_Attribute is
+   begin
+      Error_Msg_N ("unrecognized attribute&", Token_Node);
+
+      --  Check for possible misspelling
+
+      Get_Name_String (Token_Name);
+
+      declare
+         AN : constant String := Name_Buffer (1 .. Name_Len);
+
+      begin
+         Error_Msg_Name_1 := First_Attribute_Name;
+         while Error_Msg_Name_1 <= Last_Attribute_Name loop
+            Get_Name_String (Error_Msg_Name_1);
+
+            if Is_Bad_Spelling_Of
+                 (AN, Name_Buffer (1 .. Name_Len))
+            then
+               Error_Msg_N
+                 ("\possible misspelling of %", Token_Node);
+               exit;
+            end if;
+
+            Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
+         end loop;
+      end;
+   end Signal_Bad_Attribute;
+
+   -------------------------------
+   -- Token_Is_At_Start_Of_Line --
+   -------------------------------
+
+   function Token_Is_At_Start_Of_Line return Boolean is
+   begin
+      return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF);
+   end Token_Is_At_Start_Of_Line;
+
+end Util;
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
new file mode 100644
index 0000000..f45a83b
--- /dev/null
+++ b/gcc/ada/par.adb
@@ -0,0 +1,1181 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P A R                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.126 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Csets;    use Csets;
+with Debug;    use Debug;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Output;   use Output;
+with Scans;    use Scans;
+with Scn;      use Scn;
+with Sinput;   use Sinput;
+with Sinput.L; use Sinput.L;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Style;
+with Table;
+
+function Par (Configuration_Pragmas : Boolean) return List_Id is
+
+   Num_Library_Units : Natural := 0;
+   --  Count number of units parsed (relevant only in syntax check only mode,
+   --  since in semantics check mode only a single unit is permitted anyway)
+
+   Unit_Node : Node_Id;
+   --  Stores compilation unit node for current unit
+
+   Save_Config_Switches : Config_Switches_Type;
+   --  Variable used to save values of config switches while we parse the
+   --  new unit, to be restored on exit for proper recursive behavior.
+
+   Loop_Block_Count : Nat := 0;
+   --  Counter used for constructing loop/block names (see the routine
+   --  Par.Ch5.Get_Loop_Block_Name)
+
+   --------------------
+   -- Error Recovery --
+   --------------------
+
+   --  When an error is encountered, a call is made to one of the Error_Msg
+   --  routines to record the error. If the syntax scan is not derailed by the
+   --  error (e.g. a complaint that logical operators are inconsistent in an
+   --  EXPRESSION), then control returns from the Error_Msg call, and the
+   --  parse continues unimpeded.
+
+   --  If on the other hand, the Error_Msg represents a situation from which
+   --  the parser cannot recover locally, the exception Error_Resync is raised
+   --  immediately after the call to Error_Msg. Handlers for Error_Resync
+   --  are located at strategic points to resynchronize the parse. For example,
+   --  when an error occurs in a statement, the handler skips to the next
+   --  semicolon and continues the scan from there.
+
+   --  Each parsing procedure contains a note with the heading "Error recovery"
+   --  which shows if it can propagate the Error_Resync exception. In order
+   --  not to propagate the exception, a procedure must either contain its own
+   --  handler for this exception, or it must not call any other routines which
+   --  propagate the exception.
+
+   --  Note: the arrangement of Error_Resync handlers is such that it should
+   --  never be possible to transfer control through a procedure which made
+   --  an entry in the scope stack, invalidating the contents of the stack.
+
+   Error_Resync : exception;
+   --  Exception raised on error that is not handled locally, see above.
+
+   Last_Resync_Point : Source_Ptr;
+   --  The resynchronization routines in Par.Sync run a risk of getting
+   --  stuck in an infinite loop if they do not skip a token, and the caller
+   --  keeps repeating the same resync call. On the other hand, if they skip
+   --  a token unconditionally, some recovery opportunities are missed. The
+   --  variable Last_Resync_Point records the token location previously set
+   --  by a Resync call, and if a subsequent Resync call occurs at the same
+   --  location, then the Resync routine does guarantee to skip a token.
+
+   --------------------------------------------
+   -- Handling Semicolon Used in Place of IS --
+   --------------------------------------------
+
+   --  The following global variables are used in handling the error situation
+   --  of using a semicolon in place of IS in a subprogram declaration as in:
+
+   --    procedure X (Y : Integer);
+   --       Q : Integer;
+   --    begin
+   --       ...
+   --    end;
+
+   --  The two contexts in which this can appear are at the outer level, and
+   --  within a declarative region. At the outer level, we know something is
+   --  wrong as soon as we see the Q (or begin, if there are no declarations),
+   --  and we can immediately decide that the semicolon should have been IS.
+
+   --  The situation in a declarative region is more complex. The declaration
+   --  of Q could belong to the outer region, and we do not know that we have
+   --  an error until we hit the begin. It is still not clear at this point
+   --  from a syntactic point of view that something is wrong, because the
+   --  begin could belong to the enclosing subprogram or package. However, we
+   --  can incorporate a bit of semantic knowledge and note that the body of
+   --  X is missing, so we definitely DO have an error. We diagnose this error
+   --  as semicolon in place of IS on the subprogram line.
+
+   --  There are two styles for this diagnostic. If the begin immediately
+   --  follows the semicolon, then we can place a flag (IS expected) right
+   --  on the semicolon. Otherwise we do not detect the error until we hit
+   --  the begin which refers back to the line with the semicolon.
+
+   --  To control the process in the second case, the following global
+   --  variables are set to indicate that we have a subprogram declaration
+   --  whose body is required and has not yet been found. The prefix SIS
+   --  stands for "Subprogram IS" handling.
+
+   SIS_Entry_Active : Boolean;
+   --  Set True to indicate that an entry is active (i.e. that a subprogram
+   --  declaration has been encountered, and no body for this subprogram has
+   --  been encountered). The remaining fields are valid only if this is True.
+
+   SIS_Labl : Node_Id;
+   --  Subprogram designator
+
+   SIS_Sloc : Source_Ptr;
+   --  Source location of FUNCTION/PROCEDURE keyword
+
+   SIS_Ecol : Column_Number;
+   --  Column number of FUNCTION/PROCEDURE keyword
+
+   SIS_Semicolon_Sloc : Source_Ptr;
+   --  Source location of semicolon at end of subprogram declaration
+
+   SIS_Declaration_Node : Node_Id;
+   --  Pointer to tree node for subprogram declaration
+
+   SIS_Missing_Semicolon_Message : Error_Msg_Id;
+   --  Used to save message ID of missing semicolon message (which will be
+   --  modified to missing IS if necessary). Set to No_Error_Msg in the
+   --  normal (non-error) case.
+
+   --  Five things can happen to an active SIS entry
+
+   --   1. If a BEGIN is encountered with an SIS entry active, then we have
+   --   exactly the situation in which we know the body of the subprogram is
+   --   missing. After posting an error message, we change the spec to a body,
+   --   rechaining the declarations that intervened between the spec and BEGIN.
+
+   --   2. Another subprogram declaration or body is encountered. In this
+   --   case the entry gets overwritten with the information for the new
+   --   subprogram declaration. We don't catch some nested cases this way,
+   --   but it doesn't seem worth the effort.
+
+   --   3. A nested declarative region (e.g. package declaration or package
+   --   body) is encountered. The SIS active indication is reset at the start
+   --   of such a nested region. Again, like case 2, this causes us to miss
+   --   some nested cases, but it doesn't seen worth the effort to stack and
+   --   unstack the SIS information. Maybe we will reconsider this if we ever
+   --   get a complaint about a missed case :-)
+
+   --   4. We encounter a valid pragma INTERFACE or IMPORT that effectively
+   --   supplies the missing body. In this case we reset the entry.
+
+   --   5. We encounter the end of the declarative region without encoutering
+   --   a BEGIN first. In this situation we simply reset the entry. We know
+   --   that there is a missing body, but it seems more reasonable to let the
+   --   later semantic checking discover this.
+
+   --------------------------------------------
+   -- Handling IS Used in Place of Semicolon --
+   --------------------------------------------
+
+   --  This is a somewhat trickier situation, and we can't catch it in all
+   --  cases, but we do our best to detect common situations resulting from
+   --  a "cut and paste" operation which forgets to change the IS to semicolon.
+   --  Consider the following example:
+
+   --    package body X is
+   --      procedure A;
+   --      procedure B is
+   --      procedure C;
+   --      ...
+   --      procedure D is
+   --      begin
+   --         ...
+   --      end;
+   --    begin
+   --      ...
+   --    end;
+
+   --  The trouble is that the section of text from PROCEDURE B through END;
+   --  consitutes a valid procedure body, and the danger is that we find out
+   --  far too late that something is wrong (indeed most compilers will behave
+   --  uncomfortably on the above example).
+
+   --  We have two approaches to helping to control this situation. First we
+   --  make every attempt to avoid swallowing the last END; if we can be
+   --  sure that some error will result from doing so. In particular, we won't
+   --  accept the END; unless it is exactly correct (in particular it must not
+   --  have incorrect name tokens), and we won't accept it if it is immediately
+   --  followed by end of file, WITH or SEPARATE (all tokens that unmistakeably
+   --  signal the start of a compilation unit, and which therefore allow us to
+   --  reserve the END; for the outer level.) For more details on this aspect
+   --  of the handling, see package Par.Endh.
+
+   --  If we can avoid eating up the END; then the result in the absense of
+   --  any additional steps would be to post a missing END referring back to
+   --  the subprogram with the bogus IS. Similarly, if the enclosing package
+   --  has no BEGIN, then the result is a missing BEGIN message, which again
+   --  refers back to the subprogram header.
+
+   --  Such an error message is not too bad (it's already a big improvement
+   --  over what many parsers do), but it's not ideal, because the declarations
+   --  following the IS have been absorbed into the wrong scope. In the above
+   --  case, this could result for example in a bogus complaint that the body
+   --  of D was missing from the package.
+
+   --  To catch at least some of these cases, we take the following additional
+   --  steps. First, a subprogram body is marked as having a suspicious IS if
+   --  the declaration line is followed by a line which starts with a symbol
+   --  that can start a declaration in the same column, or to the left of the
+   --  column in which the FUNCTION or PROCEDURE starts (normal style is to
+   --  indent any declarations which really belong a subprogram). If such a
+   --  subprogram encounters a missing BEGIN or missing END, then we decide
+   --  that the IS should have been a semicolon, and the subprogram body node
+   --  is marked (by setting the Bad_Is_Detected flag true. Note that we do
+   --  not do this for library level procedures, only for nested procedures,
+   --  since for library level procedures, we must have a body.
+
+   --  The processing for a declarative part checks to see if the last
+   --  declaration scanned is marked in this way, and if it is, the tree
+   --  is modified to reflect the IS being interpreted as a semicolon.
+
+   ---------------------------------------------------
+   -- Parser Type Definitions and Control Variables --
+   ---------------------------------------------------
+
+   --  The following variable and associated type declaration are used by the
+   --  expression parsing routines to return more detailed information about
+   --  the categorization of a parsed expression.
+
+   type Expr_Form_Type is (
+      EF_Simple_Name,  -- Simple name, i.e. possibly qualified identifier
+      EF_Name,         -- Simple expression which could also be a name
+      EF_Simple,       -- Simple expression which is not call or name
+      EF_Range_Attr,   -- Range attribute reference
+      EF_Non_Simple);  -- Expression that is not a simple expression
+
+   Expr_Form : Expr_Form_Type;
+
+   --  The following type is used for calls to P_Subprogram, P_Package, P_Task,
+   --  P_Protected to indicate which of several possibilities is acceptable.
+
+   type Pf_Rec is record
+      Spcn : Boolean;                  -- True if specification OK
+      Decl : Boolean;                  -- True if declaration OK
+      Gins : Boolean;                  -- True if generic instantiation OK
+      Pbod : Boolean;                  -- True if proper body OK
+      Rnam : Boolean;                  -- True if renaming declaration OK
+      Stub : Boolean;                  -- True if body stub OK
+      Fil1 : Boolean;                  -- Filler to fill to 8 bits
+      Fil2 : Boolean;                  -- Filler to fill to 8 bits
+   end record;
+   pragma Pack (Pf_Rec);
+
+   function T return Boolean renames True;
+   function F return Boolean renames False;
+
+   Pf_Decl_Gins_Pbod_Rnam_Stub : constant Pf_Rec :=
+                                             Pf_Rec'(F, T, T, T, T, T, F, F);
+   Pf_Decl                     : constant Pf_Rec :=
+                                             Pf_Rec'(F, T, F, F, F, F, F, F);
+   Pf_Decl_Gins_Pbod_Rnam      : constant Pf_Rec :=
+                                             Pf_Rec'(F, T, T, T, T, F, F, F);
+   Pf_Decl_Pbod                : constant Pf_Rec :=
+                                             Pf_Rec'(F, T, F, T, F, F, F, F);
+   Pf_Pbod                     : constant Pf_Rec :=
+                                             Pf_Rec'(F, F, F, T, F, F, F, F);
+   Pf_Spcn                     : constant Pf_Rec :=
+                                             Pf_Rec'(T, F, F, F, F, F, F, F);
+   --  The above are the only allowed values of Pf_Rec arguments
+
+   type SS_Rec is record
+      Eftm : Boolean;      -- ELSIF can terminate sequence
+      Eltm : Boolean;      -- ELSE can terminate sequence
+      Extm : Boolean;      -- EXCEPTION can terminate sequence
+      Ortm : Boolean;      -- OR can terminate sequence
+      Sreq : Boolean;      -- at least one statement required
+      Tatm : Boolean;      -- THEN ABORT can terminate sequence
+      Whtm : Boolean;      -- WHEN can terminate sequence
+      Unco : Boolean;      -- Unconditional terminate after one statement
+   end record;
+   pragma Pack (SS_Rec);
+
+   SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F);
+   SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F);
+   SS_Extm_Sreq      : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F);
+   SS_None           : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F);
+   SS_Ortm_Sreq      : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F);
+   SS_Sreq           : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F);
+   SS_Sreq_Whtm      : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F);
+   SS_Whtm           : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F);
+   SS_Unco           : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T);
+
+   Label_List : Elist_Id;
+   --  List of label nodes for labels appearing in the current compilation.
+   --  Used by Par.Labl to construct the corresponding implicit declarations.
+
+   -----------------
+   -- Scope Table --
+   -----------------
+
+   --  The scope table, also referred to as the scope stack, is used to
+   --  record the current scope context. It is organized as a stack, with
+   --  inner nested entries corresponding to higher entries on the stack.
+   --  An entry is made when the parser encounters the opening of a nested
+   --  construct (such as a record, task, package etc.), and then package
+   --  Par.Endh uses this stack to deal with END lines (including properly
+   --  dealing with END nesting errors).
+
+   type SS_End_Type is
+   --  Type of end entry required for this scope. The last two entries are
+   --  used only in the subprogram body case to mark the case of a suspicious
+   --  IS, or a bad IS (i.e. suspicions confirmed by missing BEGIN or END).
+   --  See separate section on dealing with IS used in place of semicolon.
+   --  Note that for many purposes E_Name, E_Suspicious_Is and E_Bad_Is are
+   --  treated the same (E_Suspicious_Is and E_Bad_Is are simply special cases
+   --  of E_Name). They are placed at the end of the enumeration so that a
+   --  test for >= E_Name catches all three cases efficiently.
+
+      (E_Dummy,           -- dummy entry at outer level
+       E_Case,            -- END CASE;
+       E_If,              -- END IF;
+       E_Loop,            -- END LOOP;
+       E_Record,          -- END RECORD;
+       E_Select,          -- END SELECT;
+       E_Name,            -- END [name];
+       E_Suspicious_Is,   -- END [name]; (case of suspicious IS)
+       E_Bad_Is);         -- END [name]; (case of bad IS)
+
+   --  The following describes a single entry in the scope table
+
+   type Scope_Table_Entry is record
+      Etyp : SS_End_Type;
+      --  Type of end entry, as per above description
+
+      Lreq : Boolean;
+      --  A flag indicating whether the label, if present, is required to
+      --  appear on the end line. It is referenced only in the case of
+      --  Etyp = E_Name or E_Suspicious_Is where the name may or may not be
+      --  required (yes for labeled block, no in other cases). Note that for
+      --  all cases except begin, the question of whether a label is required
+      --  can be determined from the other fields (for loop, it is required if
+      --  it is present, and for the other constructs it is never required or
+      --  allowed).
+
+      Ecol : Column_Number;
+      --  Contains the absolute column number (with tabs expanded) of the
+      --  the expected column of the end assuming normal Ada indentation
+      --  usage. If the RM_Column_Check mode is set, this value is used for
+      --  generating error messages about indentation. Otherwise it is used
+      --  only to control heuristic error recovery actions.
+
+      Labl : Node_Id;
+      --  This field is used only for the LOOP and BEGIN cases, and is the
+      --  Node_Id value of the label name. For all cases except child units,
+      --  this value is an entity whose Chars field contains the name pointer
+      --  that identifies the label uniquely. For the child unit case the Labl
+      --  field references an N_Defining_Program_Unit_Name node for the name.
+      --  For cases other than LOOP or BEGIN, the Label field is set to Error,
+      --  indicating that it is an error to have a label on the end line.
+
+      Decl : List_Id;
+      --  Points to the list of declarations (i.e. the declarative part)
+      --  associated with this construct. It is set only in the END [name]
+      --  cases, and is set to No_List for all other cases which do not have a
+      --  declarative unit associated with them. This is used for determining
+      --  the proper location for implicit label declarations.
+
+      Node : Node_Id;
+      --  Empty except in the case of entries for IF and CASE statements,
+      --  in which case it contains the N_If_Statement or N_Case_Statement
+      --  node. This is used for setting the End_Span field.
+
+      Sloc : Source_Ptr;
+      --  Source location of the opening token of the construct. This is
+      --  used to refer back to this line in error messages (such as missing
+      --  or incorrect end lines). The Sloc field is not used, and is not set,
+      --  if a label is present (the Labl field provides the text name of the
+      --  label in this case, which is fine for error messages).
+
+      S_Is : Source_Ptr;
+      --  S_Is is relevant only if Etyp is set to E_Suspicious_Is or
+      --  E_Bad_Is. It records the location of the IS that is considered
+      --  to be suspicious.
+
+      Junk : Boolean;
+      --  A boolean flag that is set true if the opening entry is the dubious
+      --  result of some prior error, e.g. a record entry where the record
+      --  keyword was missing. It is used to suppress the issuing of a
+      --  corresponding junk complaint about the end line (we do not want
+      --  to complain about a missing end record when there was no record).
+   end record;
+
+   --  The following declares the scope table itself. The Last field is the
+   --  stack pointer, so that Scope.Table (Scope.Last) is the top entry. The
+   --  oldest entry, at Scope_Stack (0), is a dummy entry with Etyp set to
+   --  E_Dummy, and the other fields undefined. This dummy entry ensures that
+   --  Scope_Stack (Scope_Stack_Ptr).Etyp can always be tested, and that the
+   --  scope stack pointer is always in range.
+
+   package Scope is new Table.Table (
+     Table_Component_Type => Scope_Table_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => 50,
+     Table_Increment      => 100,
+     Table_Name           => "Scope");
+
+   ---------------------------------
+   -- Parsing Routines by Chapter --
+   ---------------------------------
+
+   --  Uncommented declarations in this section simply parse the construct
+   --  corresponding to their name, and return an ID value for the Node or
+   --  List that is created.
+
+   package Ch2 is
+      function P_Identifier                           return Node_Id;
+      function P_Pragma                               return Node_Id;
+
+      function P_Pragmas_Opt return List_Id;
+      --  This function scans for a sequence of pragmas in other than a
+      --  declaration sequence or statement sequence context. All pragmas
+      --  can appear except pragmas Assert and Debug, which are only allowed
+      --  in a declaration or statement sequence context.
+
+      procedure P_Pragmas_Misplaced;
+      --  Skips misplaced pragmas with a complaint
+
+      procedure P_Pragmas_Opt (List : List_Id);
+      --  Parses optional pragmas and appends them to the List
+   end Ch2;
+
+   package Ch3 is
+      Missing_Begin_Msg : Error_Msg_Id;
+      --  This variable is set by a call to P_Declarative_Part. Normally it
+      --  is set to No_Error_Msg, indicating that no special processing is
+      --  required by the caller. The special case arises when a statement
+      --  is found in the sequence of declarations. In this case the Id of
+      --  the message issued ("declaration expected") is preserved in this
+      --  variable, then the caller can change it to an appropriate missing
+      --  begin message if indeed the BEGIN is missing.
+
+      function P_Access_Definition                    return Node_Id;
+      function P_Access_Type_Definition               return Node_Id;
+      function P_Array_Type_Definition                return Node_Id;
+      function P_Basic_Declarative_Items              return List_Id;
+      function P_Constraint_Opt                       return Node_Id;
+      function P_Declarative_Part                     return List_Id;
+      function P_Defining_Identifier                  return Node_Id;
+      function P_Discrete_Choice_List                 return List_Id;
+      function P_Discrete_Range                       return Node_Id;
+      function P_Discrete_Subtype_Definition          return Node_Id;
+      function P_Known_Discriminant_Part_Opt          return List_Id;
+      function P_Signed_Integer_Type_Definition       return Node_Id;
+      function P_Range                                return Node_Id;
+      function P_Range_Or_Subtype_Mark                return Node_Id;
+      function P_Range_Constraint                     return Node_Id;
+      function P_Record_Definition                    return Node_Id;
+      function P_Subtype_Indication                   return Node_Id;
+      function P_Subtype_Mark                         return Node_Id;
+      function P_Subtype_Mark_Resync                  return Node_Id;
+      function P_Unknown_Discriminant_Part_Opt        return Boolean;
+
+      procedure P_Component_Items (Decls : List_Id);
+      --  Scan out one or more component items and append them to the
+      --  given list. Only scans out more than one declaration in the
+      --  case where the source has a single declaration with multiple
+      --  defining identifiers.
+
+      function Init_Expr_Opt (P : Boolean := False) return Node_Id;
+      --  If an initialization expression is present (:= expression), then
+      --  it is scanned out and returned, otherwise Empty is returned if no
+      --  initialization expression is present. This procedure also handles
+      --  certain common error cases cleanly. The parameter P indicates if
+      --  a right paren can follow the expression (default = no right paren
+      --  allowed).
+
+      procedure Skip_Declaration (S : List_Id);
+      --  Used when scanning statements to skip past a mispaced declaration
+      --  The declaration is scanned out and appended to the given list.
+      --  Token is known to be a declaration token (in Token_Class_Declk)
+      --  on entry, so there definition is a declaration to be scanned.
+
+      function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id;
+      --  This version of P_Subtype_Indication is called when the caller has
+      --  already scanned out the subtype mark which is passed as a parameter.
+
+      function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id;
+      --  Parse a subtype mark attribute. The caller has already parsed the
+      --  subtype mark, which is passed in as the argument, and has checked
+      --  that the current token is apostrophe.
+
+   end Ch3;
+
+   package Ch4 is
+      function P_Aggregate                            return Node_Id;
+      function P_Expression                           return Node_Id;
+      function P_Expression_No_Right_Paren            return Node_Id;
+      function P_Expression_Or_Range_Attribute        return Node_Id;
+      function P_Function_Name                        return Node_Id;
+      function P_Name                                 return Node_Id;
+      function P_Qualified_Simple_Name                return Node_Id;
+      function P_Qualified_Simple_Name_Resync         return Node_Id;
+      function P_Simple_Expression                    return Node_Id;
+      function P_Simple_Expression_Or_Range_Attribute return Node_Id;
+
+      function P_Qualified_Expression
+        (Subtype_Mark : Node_Id)
+         return         Node_Id;
+      --  This routine scans out a qualified expression when the caller has
+      --  already scanned out the name and apostrophe of the construct.
+
+   end Ch4;
+
+   package Ch5 is
+
+      function P_Statement_Name (Name_Node : Node_Id) return Node_Id;
+      --  Given a node representing a name (which is a call), converts it
+      --  to the syntactically corresponding procedure call statement.
+
+      function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id;
+      --  The argument indicates the acceptable termination tokens.
+      --  See body in Par.Ch5 for details of the use of this parameter.
+
+      procedure Parse_Decls_Begin_End (Parent : Node_Id);
+      --  Parses declarations and handled statement sequence, setting
+      --  fields of Parent node appropriately.
+
+   end Ch5;
+
+   package Ch6 is
+      function P_Designator                           return Node_Id;
+      function P_Defining_Program_Unit_Name           return Node_Id;
+      function P_Formal_Part                          return List_Id;
+      function P_Parameter_Profile                    return List_Id;
+      function P_Return_Statement                     return Node_Id;
+      function P_Subprogram_Specification             return Node_Id;
+
+      procedure P_Mode (Node : Node_Id);
+      --  Sets In_Present and/or Out_Present flags in Node scanning past
+      --  IN, OUT or IN OUT tokens in the source.
+
+      function P_Subprogram (Pf_Flags : Pf_Rec)       return Node_Id;
+      --  Scans out any construct starting with either of the keywords
+      --  PROCEDURE or FUNCTION. The parameter indicates which possible
+      --  possible kinds of construct (body, spec, instantiation etc.)
+      --  are permissible in the current context.
+
+   end Ch6;
+
+   package Ch7 is
+      function P_Package (Pf_Flags : Pf_Rec) return Node_Id;
+      --  Scans out any construct starting with the keyword PACKAGE. The
+      --  parameter indicates which possible kinds of construct (body, spec,
+      --  instantiation etc.) are permissible in the current context.
+   end Ch7;
+
+   package Ch8 is
+      function P_Use_Clause                           return Node_Id;
+   end Ch8;
+
+   package Ch9 is
+      function P_Abort_Statement                      return Node_Id;
+      function P_Abortable_Part                       return Node_Id;
+      function P_Accept_Statement                     return Node_Id;
+      function P_Delay_Statement                      return Node_Id;
+      function P_Entry_Body                           return Node_Id;
+      function P_Protected                            return Node_Id;
+      function P_Requeue_Statement                    return Node_Id;
+      function P_Select_Statement                     return Node_Id;
+      function P_Task                                 return Node_Id;
+      function P_Terminate_Alternative                return Node_Id;
+   end Ch9;
+
+   package Ch10 is
+      function P_Compilation_Unit                     return Node_Id;
+      --  Note: this function scans a single compilation unit, and
+      --  checks that an end of file follows this unit, diagnosing
+      --  any unexpected input as an error, and then skipping it, so
+      --  that Token is set to Tok_EOF on return. An exception is in
+      --  syntax-only mode, where multiple compilation units are
+      --  permitted. In this case, P_Compilation_Unit does not check
+      --  for end of file and there may be more compilation units to
+      --  scan. The caller can uniquely detect this situation by the
+      --  fact that Token is not set to Tok_EOF on return.
+   end Ch10;
+
+   package Ch11 is
+      function P_Handled_Sequence_Of_Statements       return Node_Id;
+      function P_Raise_Statement                      return Node_Id;
+
+      function Parse_Exception_Handlers               return List_Id;
+      --  Parses the partial construct EXCEPTION followed by a list of
+      --  exception handlers which appears in a number of productions,
+      --  and returns the list of exception handlers.
+
+   end Ch11;
+
+   package Ch12 is
+      function P_Generic                              return Node_Id;
+      function P_Generic_Actual_Part_Opt              return List_Id;
+   end Ch12;
+
+   package Ch13 is
+      function P_Representation_Clause                return Node_Id;
+
+      function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id;
+      --  Function to parse a code statement. The caller has scanned out
+      --  the name to be used as the subtype mark (but has not checked that
+      --  it is suitable for use as a subtype mark, i.e. is either an
+      --  identifier or a selected component). The current token is an
+      --  apostrophe and the following token is either a left paren or
+      --  RANGE (the latter being an error to be caught by P_Code_Statement.
+   end Ch13;
+
+   --  Note: the parsing for annexe J features (i.e. obsolescent features)
+   --  is found in the logical section where these features would be if
+   --  they were not obsolescent. In particular:
+
+   --    Delta constraint is parsed by P_Delta_Constraint (3.5.9)
+   --    At clause is parsed by P_At_Clause (13.1)
+   --    Mod clause is parsed by P_Mod_Clause (13.5.1)
+
+   ------------------
+   -- End Handling --
+   ------------------
+
+   --  Routines for handling end lines, including scope recovery
+
+   package Endh is
+
+      function Check_End return Boolean;
+      --  Called when an end sequence is required. In the absence of an error
+      --  situation, Token contains Tok_End on entry, but in a missing end
+      --  case, this may not be the case. Pop_End_Context is used to determine
+      --  the appropriate action to be taken. The returned result is True if
+      --  an End sequence was encountered and False if no End sequence was
+      --  present. This occurs if the END keyword encountered was determined
+      --  to be improper and deleted (i.e. Pop_End_Context set End_Action to
+      --  Skip_And_Reject). Note that the END sequence includes a semicolon,
+      --  except in the case of END RECORD, where a semicolon follows the END
+      --  RECORD, but is not part of the record type definition itself.
+
+      procedure End_Skip;
+      --  Skip past an end sequence. On entry Token contains Tok_End, and we
+      --  we know that the end sequence is syntactically incorrect, and that
+      --  an appropriate error message has already been posted. The mission
+      --  is simply to position the scan pointer to be the best guess of the
+      --  position after the end sequence. We do not issue any additional
+      --  error messages while carrying this out.
+
+      procedure End_Statements (Parent : Node_Id := Empty);
+      --  Called when an end is required or expected to terminate a sequence
+      --  of statements. The caller has already made an appropriate entry in
+      --  the Scope.Table to describe the expected form of the end. This can
+      --  only be used in cases where the only appropriate terminator is end.
+      --  If Parent is non-empty, then if a correct END line is encountered,
+      --  the End_Label field of Parent is set appropriately.
+
+   end Endh;
+
+   ------------------------------------
+   -- Resynchronization After Errors --
+   ------------------------------------
+
+   --  These procedures are used to resynchronize after errors. Following an
+   --  error which is not immediately locally recoverable, the exception
+   --  Error_Resync is raised. The handler for Error_Resync typically calls
+   --  one of these recovery procedures to resynchronize the source position
+   --  to a point from which parsing can be restarted.
+
+   --  Note: these procedures output an information message that tokens are
+   --  being skipped, but this message is output only if the option for
+   --  Multiple_Errors_Per_Line is set in Options.
+
+   package Sync is
+
+      procedure Resync_Choice;
+      --  Used if an error occurs scanning a choice. The scan pointer is
+      --  advanced to the next vertical bar, arrow, or semicolon, whichever
+      --  comes first. We also quit if we encounter an end of file.
+
+      procedure Resync_Expression;
+      --  Used if an error is detected during the parsing of an expression.
+      --  It skips past tokens until either a token which cannot be part of
+      --  an expression is encountered (an expression terminator), or if a
+      --  comma or right parenthesis or vertical bar is encountered at the
+      --  current parenthesis level (a parenthesis level counter is maintained
+      --  to carry out this test).
+
+      procedure Resync_Past_Semicolon;
+      --  Used if an error occurs while scanning a sequence of declarations.
+      --  The scan pointer is positioned past the next semicolon and the scan
+      --  resumes. The scan is also resumed on encountering a token which
+      --  starts a declaration (but we make sure to skip at least one token
+      --  in this case, to avoid getting stuck in a loop).
+
+      procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then;
+      --  Used if an error occurs while scanning a sequence of statements.
+      --  The scan pointer is positioned past the next semicolon, or to the
+      --  next occurrence of either then or loop, and the scan resumes.
+
+      procedure Resync_To_When;
+      --  Used when an error occurs scanning an entry index specification.
+      --  The scan pointer is positioned to the next WHEN (or to IS or
+      --  semicolon if either of these appear before WHEN, indicating
+      --  another error has occurred).
+
+      procedure Resync_Semicolon_List;
+      --  Used if an error occurs while scanning a parenthesized list of items
+      --  separated by semicolons. The scan pointer is advanced to the next
+      --  semicolon or right parenthesis at the outer parenthesis level, or
+      --  to the next is or RETURN keyword occurence, whichever comes first.
+
+      procedure Resync_Cunit;
+      --  Synchronize to next token which could be the start of a compilation
+      --  unit, or to the end of file token.
+
+   end Sync;
+
+   -------------------------
+   -- Token Scan Routines --
+   -------------------------
+
+   --  Routines to check for expected tokens
+
+   package Tchk is
+
+      --  Procedures with names of the form T_xxx, where Tok_xxx is a token
+      --  name, check that the current token matches the required token, and
+      --  if so, scan past it. If not, an error is issued indicating that
+      --  the required token is not present (xxx expected). In most cases, the
+      --  scan pointer is not moved in the not-found case, but there are some
+      --  exceptions to this, see for example T_Id, where the scan pointer is
+      --  moved across a literal appearing where an identifier is expected.
+
+      procedure T_Abort;
+      procedure T_Arrow;
+      procedure T_At;
+      procedure T_Body;
+      procedure T_Box;
+      procedure T_Colon;
+      procedure T_Colon_Equal;
+      procedure T_Comma;
+      procedure T_Dot_Dot;
+      procedure T_For;
+      procedure T_Greater_Greater;
+      procedure T_Identifier;
+      procedure T_In;
+      procedure T_Is;
+      procedure T_Left_Paren;
+      procedure T_Loop;
+      procedure T_Mod;
+      procedure T_New;
+      procedure T_Of;
+      procedure T_Or;
+      procedure T_Private;
+      procedure T_Range;
+      procedure T_Record;
+      procedure T_Right_Paren;
+      procedure T_Semicolon;
+      procedure T_Then;
+      procedure T_Type;
+      procedure T_Use;
+      procedure T_When;
+      procedure T_With;
+
+      --  Procedures have names of the form TF_xxx, where Tok_xxx is a token
+      --  name check that the current token matches the required token, and
+      --  if so, scan past it. If not, an error message is issued indicating
+      --  that the required token is not present (xxx expected).
+
+      --  If the missing token is at the end of the line, then control returns
+      --  immediately after posting the message. If there are remaining tokens
+      --  on the current line, a search is conducted to see if the token
+      --  appears later on the current line, as follows:
+
+      --  A call to Scan_Save is issued and a forward search for the token
+      --  is carried out. If the token is found on the current line before a
+      --  semicolon, then it is scanned out and the scan continues from that
+      --  point. If not the scan is restored to the point where it was missing.
+
+      procedure TF_Arrow;
+      procedure TF_Is;
+      procedure TF_Loop;
+      procedure TF_Return;
+      procedure TF_Semicolon;
+      procedure TF_Then;
+      procedure TF_Use;
+
+   end Tchk;
+
+   ----------------------
+   -- Utility Routines --
+   ----------------------
+
+   package Util is
+
+      function Bad_Spelling_Of (T : Token_Type) return Boolean;
+      --  This function is called in an error situation. It checks if the
+      --  current token is an identifier whose name is a plausible bad
+      --  spelling of the given keyword token, and if so, issues an error
+      --  message, sets Token from T, and returns True. Otherwise Token is
+      --  unchanged, and False is returned.
+
+      procedure Check_Bad_Layout;
+      --  Check for bad indentation in RM checking mode. Used for statements
+      --  and declarations. Checks if current token is at start of line and
+      --  is exdented from the current expected end column, and if so an
+      --  error message is generated.
+
+      procedure Check_Misspelling_Of (T : Token_Type);
+      pragma Inline (Check_Misspelling_Of);
+      --  This is similar to the function above, except that it does not
+      --  return a result. It is typically used in a situation where any
+      --  identifier is an error, and it makes sense to simply convert it
+      --  to the given token if it is a plausible misspelling of it.
+
+      procedure Check_95_Keyword (Token_95, Next : Token_Type);
+      --  This routine checks if the token after the current one matches the
+      --  Next argument. If so, the scan is backed up to the current token
+      --  and Token_Type is changed to Token_95 after issuing an appropriate
+      --  error message ("(Ada 83) keyword xx cannot be used"). If not,
+      --  the scan is backed up with Token_Type unchanged. This routine
+      --  is used to deal with an attempt to use a 95 keyword in Ada 83
+      --  mode. The caller has typically checked that the current token,
+      --  an identifier, matches one of the 95 keywords.
+
+      procedure Check_Simple_Expression (E : Node_Id);
+      --  Given an expression E, that has just been scanned, so that Expr_Form
+      --  is still set, outputs an error if E is a non-simple expression. E is
+      --  not modified by this call.
+
+      procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id);
+      --  Like Check_Simple_Expression, except that the error message is only
+      --  given when operating in Ada 83 mode, and includes "in Ada 83".
+
+      function Check_Subtype_Mark (Mark : Node_Id) return Node_Id;
+      --  Called to check that a node representing a name (or call) is
+      --  suitable for a subtype mark, i.e, that it is an identifier or
+      --  a selected component. If so, or if it is already Error, then
+      --  it is returned unchanged. Otherwise an error message is issued
+      --  and Error is returned.
+
+      function Comma_Present return Boolean;
+      --  Used in comma delimited lists to determine if a comma is present, or
+      --  can reasonably be assumed to have been present (an error message is
+      --  generated in the latter case). If True is returned, the scan has been
+      --  positioned past the comma. If False is returned, the scan position
+      --  is unchanged. Note that all comma-delimited lists are terminated by
+      --  a right paren, so the only legitimate tokens when Comma_Present is
+      --  called are right paren and comma. If some other token is found, then
+      --  Comma_Present has the job of deciding whether it is better to pretend
+      --  a comma was present, post a message for a missing comma and return
+      --  True, or return False and let the caller diagnose the missing right
+      --  parenthesis.
+
+      procedure Discard_Junk_Node (N : Node_Id);
+      procedure Discard_Junk_List (L : List_Id);
+      pragma Inline (Discard_Junk_Node);
+      pragma Inline (Discard_Junk_List);
+      --  These procedures do nothing at all, their effect is simply to discard
+      --  the argument. A typical use is to skip by some junk that is not
+      --  expected in the current context.
+
+      procedure Ignore (T : Token_Type);
+      --  If current token matches T, then give an error message and skip
+      --  past it, otherwise the call has no effect at all. T may be any
+      --  reserved word token, or comma, left or right paren, or semicolon.
+
+      function Is_Reserved_Identifier return Boolean;
+      --  Test if current token is a reserved identifier. This test is based
+      --  on the token being a keyword and being spelled in typical identifier
+      --  style (i.e. starting with an upper case letter).
+
+      procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type);
+      --  Called when the previous token is an identifier (whose Token_Node
+      --  value is given by Prev) to check if current token is an identifier
+      --  that can be merged with the previous one adding an underscore. The
+      --  merge is only attempted if the following token matches Nxt. If all
+      --  conditions are met, an error message is issued, and the merge is
+      --  carried out, modifying the Chars field of Prev.
+
+      procedure No_Constraint;
+      --  Called in a place where no constraint is allowed, but one might
+      --  appear due to a common error (e.g. after the type mark in a procedure
+      --  parameter. If a constraint is present, an error message is posted,
+      --  and the constraint is scanned and discarded.
+
+      function No_Right_Paren (Expr : Node_Id) return Node_Id;
+      --  Function to check for no right paren at end of expression, returns
+      --  its argument if no right paren, else flags paren and returns Error.
+
+      procedure Push_Scope_Stack;
+      pragma Inline (Push_Scope_Stack);
+      --  Push a new entry onto the scope stack. Scope.Last (the stack pointer)
+      --  is incremented. The Junk field is preinitialized to False. The caller
+      --  is expected to fill in all remaining entries of the new new top stack
+      --  entry at Scope.Table (Scope.Last).
+
+      procedure Pop_Scope_Stack;
+      --  Pop an entry off the top of the scope stack. Scope_Last (the scope
+      --  table stack pointer) is decremented by one. It is a fatal error to
+      --  try to pop off the dummy entry at the bottom of the stack (i.e.
+      --  Scope.Last must be non-zero at the time of call).
+
+      function Separate_Present return Boolean;
+      --  Determines if the current token is either Tok_Separate, or an
+      --  identifier that is a possible misspelling of "separate" followed
+      --  by a semicolon. True is returned if so, otherwise False.
+
+      procedure Signal_Bad_Attribute;
+      --  The current token is an identifier that is supposed to be an
+      --  attribute identifier but is not. This routine posts appropriate
+      --  error messages, including a check for a near misspelling.
+
+      function Token_Is_At_Start_Of_Line return Boolean;
+      pragma Inline (Token_Is_At_Start_Of_Line);
+      --  Determines if the current token is the first token on the line
+
+   end Util;
+
+   ---------------------------------------
+   -- Specialized Syntax Check Routines --
+   ---------------------------------------
+
+   function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id;
+   --  This function is passed a tree for a pragma that has been scanned out.
+   --  The pragma is syntactically well formed according to the general syntax
+   --  for pragmas and the pragma identifier is for one of the recognized
+   --  pragmas. It performs specific syntactic checks for specific pragmas.
+   --  The result is the input node if it is OK, or Error otherwise. The
+   --  reason that this is separated out is to facilitate the addition
+   --  of implementation defined pragmas. The second parameter records the
+   --  location of the semicolon following the pragma (this is needed for
+   --  correct processing of the List and Page pragmas). The returned value
+   --  is a copy of Pragma_Node, or Error if an error is found.
+
+   -------------------------
+   -- Subsidiary Routines --
+   -------------------------
+
+   procedure Labl;
+   --  This procedure creates implicit label declarations for all label that
+   --  are declared in the current unit. Note that this could conceptually
+   --  be done at the point where the labels are declared, but it is tricky
+   --  to do it then, since the tree is not hooked up at the point where the
+   --  label is declared (e.g. a sequence of statements is not yet attached
+   --  to its containing scope at the point a label in the sequence is found)
+
+   procedure Load;
+   --  This procedure loads all subsidiary units that are required by this
+   --  unit, including with'ed units, specs for bodies, and parents for child
+   --  units. It does not load bodies for inlined procedures and generics,
+   --  since we don't know till semantic analysis is complete what is needed.
+
+   -----------
+   -- Stubs --
+   -----------
+
+   --  The package bodies can see all routines defined in all other subpackages
+
+   use Ch2;
+   use Ch3;
+   use Ch4;
+   use Ch5;
+   use Ch6;
+   use Ch7;
+   use Ch8;
+   use Ch9;
+   use Ch10;
+   use Ch11;
+   use Ch12;
+   use Ch13;
+
+   use Endh;
+   use Tchk;
+   use Sync;
+   use Util;
+
+   package body Ch2 is separate;
+   package body Ch3 is separate;
+   package body Ch4 is separate;
+   package body Ch5 is separate;
+   package body Ch6 is separate;
+   package body Ch7 is separate;
+   package body Ch8 is separate;
+   package body Ch9 is separate;
+   package body Ch10 is separate;
+   package body Ch11 is separate;
+   package body Ch12 is separate;
+   package body Ch13 is separate;
+
+   package body Endh is separate;
+   package body Tchk is separate;
+   package body Sync is separate;
+   package body Util is separate;
+
+   function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id
+     is separate;
+
+   procedure Labl is separate;
+   procedure Load is separate;
+
+   ---------
+   -- Par --
+   ---------
+
+--  This function is the parse routine called at the outer level. It parses
+--  the current compilation unit and adds implicit label declarations.
+
+begin
+   --  Deal with configuration pragmas case first
+
+   if Configuration_Pragmas then
+      declare
+         Ecount  : constant Int := Errors_Detected;
+         Pragmas : List_Id := Empty_List;
+         P_Node  : Node_Id;
+
+      begin
+         loop
+            if Token = Tok_EOF then
+               return Pragmas;
+
+            elsif Token /= Tok_Pragma then
+               Error_Msg_SC ("only pragmas allowed in configuration file");
+               return Error_List;
+
+            else
+               P_Node := P_Pragma;
+
+               if Errors_Detected > Ecount then
+                  return Error_List;
+               end if;
+
+               if Chars (P_Node) > Last_Configuration_Pragma_Name
+                 and then Chars (P_Node) /= Name_Source_Reference
+               then
+                  Error_Msg_SC
+                    ("only configuration pragmas allowed " &
+                     "in configuration file");
+                  return Error_List;
+               end if;
+
+               Append (P_Node, Pragmas);
+            end if;
+         end loop;
+      end;
+
+   --  Normal case of compilation unit
+
+   else
+      Save_Opt_Config_Switches (Save_Config_Switches);
+
+      --  Special processing for language defined units. For this purpose
+      --  we do NOT consider the renamings in annex J as predefined. That
+      --  allows users to compile their own versions of these files, and
+      --  in particular, in the VMS implementation, the DEC versions can
+      --  be substituted for the standard Ada 95 versions.
+
+      if Is_Predefined_File_Name
+           (Fname => File_Name (Current_Source_File),
+            Renamings_Included => False)
+      then
+         Set_Opt_Config_Switches
+           (Is_Internal_File_Name (File_Name (Current_Source_File)));
+
+         --  If this is the main unit, disallow compilation unless the -gnatg
+         --  (GNAT mode) switch is set (from a user point of view, the rule is
+         --  that language defined units cannot be recompiled).
+
+         --  However, an exception is s-rpc, and its children. We test this
+         --  by looking at the character after the minus, the rule is that
+         --  System.RPC and its children are the only children in System
+         --  whose second level name can start with the letter r.
+
+         Get_Name_String (File_Name (Current_Source_File));
+
+         if (Name_Len < 3 or else Name_Buffer (1 .. 3) /= "s-r")
+           and then Current_Source_Unit = Main_Unit
+           and then not GNAT_Mode
+           and then Operating_Mode = Generate_Code
+         then
+            Error_Msg_SC ("language defined units may not be recompiled");
+         end if;
+      end if;
+
+      --  The following loop runs more than once only in syntax check mode
+      --  where we allow multiple compilation units in the same file.
+
+      loop
+         Set_Opt_Config_Switches
+           (Is_Internal_File_Name (File_Name (Current_Source_File)));
+
+         --  Initialize scope table and other parser control variables
+
+         Compiler_State := Parsing;
+         Scope.Init;
+         Scope.Increment_Last;
+         Scope.Table (0).Etyp := E_Dummy;
+         SIS_Entry_Active := False;
+         Last_Resync_Point := No_Location;
+
+         Label_List := New_Elmt_List;
+         Unit_Node := P_Compilation_Unit;
+
+         --  If we are not at an end of file, then this means that we are
+         --  in syntax scan mode, and we can have another compilation unit,
+         --  otherwise we will exit from the loop.
+
+         exit when Token = Tok_EOF;
+         Restore_Opt_Config_Switches (Save_Config_Switches);
+         Set_Comes_From_Source_Default (False);
+      end loop;
+
+      --  Now that we have completely parsed the source file, we can
+      --  complete the source file table entry.
+
+      Complete_Source_File_Entry;
+
+      --  An internal error check, the scope stack should now be empty
+
+      pragma Assert (Scope.Last = 0);
+
+      --  Remaining steps are to create implicit label declarations and to
+      --  load required subsidiary sources. These steps are required only
+      --  if we are doing semantic checking.
+
+      if Operating_Mode /= Check_Syntax or else Debug_Flag_F then
+         Par.Labl;
+         Par.Load;
+      end if;
+
+      --  Restore settings of switches saved on entry
+
+      Restore_Opt_Config_Switches (Save_Config_Switches);
+      Set_Comes_From_Source_Default (False);
+      return Empty_List;
+   end if;
+
+end Par;
diff --git a/gcc/ada/par.ads b/gcc/ada/par.ads
new file mode 100644
index 0000000..c1110a0
--- /dev/null
+++ b/gcc/ada/par.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P A R                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.14 $                             --
+--                                                                          --
+--     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The Par function and its subunits contains all the parsing routines
+--  for the top down recursive descent parser that constructs the parse tree
+
+with Types; use Types;
+
+function Par (Configuration_Pragmas : Boolean) return List_Id;
+--  Top level parsing routine. There are two cases:
+--
+--  If Configuration_Pragmas is False, Par parses a compilation unit in the
+--  current source file and sets the Cunit, Cunit_Entity and Unit_Name fields
+--  of the units table entry for Current_Source_Unit. On return the parse tree
+--  is complete, and decorated with any required implicit label declarations.
+--  The value returned in this case is always No_List.
+--
+--  If Configuration_Pragmas is True, Par parses a list of configuration
+--  pragmas from the current source file, and returns the list of pragmas.
diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb
new file mode 100644
index 0000000..aa79302
--- /dev/null
+++ b/gcc/ada/prj-attr.adb
@@ -0,0 +1,211 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Namet;     use Namet;
+with Output;    use Output;
+
+package body Prj.Attr is
+
+   --  Names end with '#'
+   --  Package names are preceded by 'P'
+   --  Attribute names are preceded by two capital letters:
+   --    'S' for Single or 'L' for list, then
+   --    'V' for single variable, 'A' for associative array, or 'B' for both.
+   --  End is indicated by two consecutive '#'.
+
+   Initialisation_Data : constant String :=
+
+   --  project attributes
+
+     "SVobject_dir#" &
+     "LVsource_dirs#" &
+     "LVsource_files#" &
+     "SVsource_list_file#" &
+     "SVlibrary_dir#" &
+     "SVlibrary_name#" &
+     "SVlibrary_kind#" &
+     "SVlibrary_elaboration#" &
+     "SVlibrary_version#" &
+     "LVmain#" &
+
+   --  package Naming
+
+     "Pnaming#" &
+     "SVspecification_append#" &
+     "SVbody_append#" &
+     "SVseparate_append#" &
+     "SVcasing#" &
+     "SVdot_replacement#" &
+     "SAspecification#" &
+     "SAbody_part#" &
+
+   --  package Compiler
+
+     "Pcompiler#" &
+     "LBswitches#" &
+     "SVlocal_configuration_pragmas#" &
+
+   --  package gnatmake
+
+     "Pgnatmake#" &
+     "LBswitches#" &
+     "SVglobal_configuration_pragmas#" &
+
+   --  package gnatls
+
+     "Pgnatls#" &
+     "LVswitches#" &
+
+   --  package gnatbind
+
+     "Pgnatbind#" &
+     "LBswitches#" &
+
+   --  package gnatlink
+
+     "Pgnatlink#" &
+     "LBswitches#" &
+
+     "#";
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+      Start             : Positive           := Initialisation_Data'First;
+      Finish            : Positive           := Start;
+      Current_Package   : Package_Node_Id    := Empty_Package;
+      Current_Attribute : Attribute_Node_Id  := Empty_Attribute;
+      Is_An_Attribute   : Boolean            := False;
+      Kind_1            : Variable_Kind      := Undefined;
+      Kind_2            : Attribute_Kind     := Single;
+      Package_Name      : Name_Id            := No_Name;
+      Attribute_Name    : Name_Id            := No_Name;
+      First_Attribute   : Attribute_Node_Id  := Attribute_First;
+   begin
+
+      --  Make sure the two tables are empty
+
+      Attributes.Set_Last (Attributes.First);
+      Package_Attributes.Set_Last (Package_Attributes.First);
+
+      while Initialisation_Data (Start) /= '#' loop
+         Is_An_Attribute := True;
+         case Initialisation_Data (Start) is
+            when 'P' =>
+               --  New allowed package
+               Start := Start + 1;
+               Finish := Start;
+               while Initialisation_Data (Finish) /= '#' loop
+                  Finish := Finish + 1;
+               end loop;
+               Name_Len := Finish - Start;
+               Name_Buffer (1 .. Name_Len) :=
+                 To_Lower (Initialisation_Data (Start .. Finish - 1));
+               Package_Name := Name_Find;
+               for Index in Package_First .. Package_Attributes.Last loop
+                  if Package_Name = Package_Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate package name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+
+               Is_An_Attribute := False;
+               Current_Attribute := Empty_Attribute;
+               Package_Attributes.Increment_Last;
+               Current_Package := Package_Attributes.Last;
+               Package_Attributes.Table (Current_Package).Name :=
+                 Package_Name;
+               Start := Finish + 1;
+            when 'S' =>
+               Kind_1 := Single;
+            when 'L' =>
+               Kind_1 := List;
+            when others =>
+               raise Program_Error;
+         end case;
+
+         if Is_An_Attribute then
+            --  New attribute
+            Start := Start + 1;
+            case Initialisation_Data (Start) is
+               when 'V' =>
+                  Kind_2 := Single;
+               when 'A' =>
+                  Kind_2 := Associative_Array;
+               when 'B' =>
+                  Kind_2 := Both;
+               when others =>
+                  raise Program_Error;
+            end case;
+            Start := Start + 1;
+            Finish := Start;
+            while Initialisation_Data (Finish) /= '#' loop
+               Finish := Finish + 1;
+            end loop;
+            Name_Len := Finish - Start;
+            Name_Buffer (1 .. Name_Len) :=
+              To_Lower (Initialisation_Data (Start .. Finish - 1));
+            Attribute_Name := Name_Find;
+            Attributes.Increment_Last;
+            if Current_Attribute = Empty_Attribute then
+               First_Attribute := Attributes.Last;
+               if Current_Package /= Empty_Package then
+                  Package_Attributes.Table (Current_Package).First_Attribute
+                    := Attributes.Last;
+               end if;
+            else
+               --  Check that there are no duplicate attributes
+               for Index in First_Attribute .. Attributes.Last - 1 loop
+                  if Attribute_Name =
+                    Attributes.Table (Index).Name then
+                     Write_Line ("Duplicate attribute name """ &
+                                 Initialisation_Data (Start .. Finish - 1) &
+                                 """ in Prj.Attr body.");
+                     raise Program_Error;
+                  end if;
+               end loop;
+               Attributes.Table (Current_Attribute).Next :=
+                 Attributes.Last;
+            end if;
+            Current_Attribute := Attributes.Last;
+            Attributes.Table (Current_Attribute) :=
+              (Name    => Attribute_Name,
+               Kind_1  => Kind_1,
+               Kind_2  => Kind_2,
+               Next    => Empty_Attribute);
+            Start := Finish + 1;
+         end if;
+      end loop;
+   end Initialize;
+
+end Prj.Attr;
diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads
new file mode 100644
index 0000000..ba4bb2e
--- /dev/null
+++ b/gcc/ada/prj-attr.ads
@@ -0,0 +1,108 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . A T T R                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package defines allowed packages and attributes in GNAT project
+--  files.
+
+with Types; use Types;
+with Table;
+
+package Prj.Attr is
+
+   --  Define the allowed attributes
+
+   Attributes_Initial   : constant := 50;
+   Attributes_Increment : constant := 50;
+
+   Attribute_Node_Low_Bound  : constant := 0;
+   Attribute_Node_High_Bound : constant := 099_999_999;
+
+   type Attribute_Node_Id is
+     range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
+
+   First_Attribute_Node_Id : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   Empty_Attribute : constant Attribute_Node_Id
+     := Attribute_Node_Low_Bound;
+
+   type Attribute_Kind is (Single, Associative_Array, Both);
+
+   type Attribute_Record is record
+      Name     : Name_Id;
+      Kind_1   : Variable_Kind;
+      Kind_2   : Attribute_Kind;
+      Next     : Attribute_Node_Id;
+   end record;
+
+   package Attributes is
+      new Table.Table (Table_Component_Type => Attribute_Record,
+                       Table_Index_Type     => Attribute_Node_Id,
+                       Table_Low_Bound      => First_Attribute_Node_Id,
+                       Table_Initial        => Attributes_Initial,
+                       Table_Increment      => Attributes_Increment,
+                       Table_Name           => "Prj.Attr.Attributes");
+
+   Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id + 1;
+
+   --  Define the allowed packages
+
+   Packages_Initial   : constant := 10;
+   Packages_Increment : constant := 10;
+
+   Package_Node_Low_Bound  : constant := 0;
+   Package_Node_High_Bound : constant := 099_999_999;
+
+   type Package_Node_Id is
+     range Package_Node_Low_Bound .. Package_Node_High_Bound;
+
+   First_Package_Node_Id : constant Package_Node_Id
+     := Package_Node_Low_Bound;
+
+   Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound;
+
+   type Package_Record is record
+      Name            : Name_Id;
+      First_Attribute : Attribute_Node_Id;
+   end record;
+
+   package Package_Attributes is
+      new Table.Table (Table_Component_Type => Package_Record,
+                       Table_Index_Type     => Package_Node_Id,
+                       Table_Low_Bound      => First_Package_Node_Id,
+                       Table_Initial        => Packages_Initial,
+                       Table_Increment      => Packages_Increment,
+                       Table_Name           => "Prj.Attr.Packages");
+
+   Package_First : constant Package_Node_Id := Package_Node_Low_Bound + 1;
+
+   procedure Initialize;
+   --  Initialize the two tables above (Attributes and Package_Attributes).
+   --  This procedure should be called by Prj.Initialize.
+
+end Prj.Attr;
diff --git a/gcc/ada/prj-com.adb b/gcc/ada/prj-com.adb
new file mode 100644
index 0000000..3447e18
--- /dev/null
+++ b/gcc/ada/prj-com.adb
@@ -0,0 +1,49 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.1 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Namet;   use Namet;
+with Stringt; use Stringt;
+
+package body Prj.Com is
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (Name : Name_Id) return Header_Num is
+   begin
+      return Hash (Get_Name_String (Name));
+   end Hash;
+
+   function Hash (Name : String_Id) return Header_Num is
+   begin
+      String_To_Name_Buffer (Name);
+      return Hash (Name_Buffer (1 .. Name_Len));
+   end Hash;
+
+end Prj.Com;
diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads
new file mode 100644
index 0000000..ddb7d0f
--- /dev/null
+++ b/gcc/ada/prj-com.ads
@@ -0,0 +1,92 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . C O M                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $                              --
+--                                                                          --
+--          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The following package declares data types for GNAT project.
+--  These data types are used in the bodies of the Prj hierarchy.
+
+with GNAT.HTable;
+with Table;
+with Types; use Types;
+
+package Prj.Com is
+
+   --  At one point, this package was private.
+   --  It cannot be private, because it is used outside of
+   --  the Prj hierarchy.
+
+   Tool_Name : Name_Id := No_Name;
+
+   Current_Verbosity : Verbosity := Default;
+
+   type Spec_Or_Body is
+     (Specification, Body_Part);
+
+   type File_Name_Data is record
+      Name         : Name_Id := No_Name;
+      Path         : Name_Id := No_Name;
+      Project      : Project_Id := No_Project;
+      Needs_Pragma : Boolean := False;
+   end record;
+   --  File and Path name of a spec or body.
+
+   type File_Names_Data is array (Spec_Or_Body) of File_Name_Data;
+
+   type Unit_Id is new Nat;
+   No_Unit : constant Unit_Id := 0;
+   type Unit_Data is record
+      Name       : Name_Id    := No_Name;
+      File_Names : File_Names_Data;
+   end record;
+   --  File and Path names of a unit, with a reference to its
+   --  GNAT Project File.
+
+   package Units is new Table.Table
+     (Table_Component_Type => Unit_Data,
+      Table_Index_Type     => Unit_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Com.Units");
+
+   type Header_Num is range 0 .. 2047;
+
+   function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
+
+   function Hash (Name : Name_Id) return Header_Num;
+
+   function Hash (Name : String_Id) return Header_Num;
+
+   package Units_Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Unit_Id,
+      No_Element => No_Unit,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+end Prj.Com;
diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb
new file mode 100644
index 0000000..65f7e43
--- /dev/null
+++ b/gcc/ada/prj-dect.adb
@@ -0,0 +1,942 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . D E C T                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Errout;     use Errout;
+with Prj.Strt;
+with Prj.Tree;   use Prj.Tree;
+with Scans;      use Scans;
+with Sinfo;      use Sinfo;
+with Types;      use Types;
+with Prj.Attr;   use Prj.Attr;
+
+package body Prj.Dect is
+
+   type Zone is (In_Project, In_Package, In_Case_Construction);
+
+   procedure Parse_Attribute_Declaration
+     (Attribute         : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse an attribute declaration.
+
+   procedure Parse_Case_Construction
+     (Case_Construction : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse a case construction
+
+   procedure Parse_Declarative_Items
+     (Declarations      : out Project_Node_Id;
+      In_Zone           : Zone;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse declarative items. Depending on In_Zone, some declarative
+   --  items may be forbiden.
+
+   procedure Parse_Package_Declaration
+     (Package_Declaration : out Project_Node_Id;
+      Current_Project     : Project_Node_Id);
+   --  Parse a package declaration
+
+   procedure Parse_String_Type_Declaration
+     (String_Type       : out Project_Node_Id;
+      Current_Project   : Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id);
+   --  type <name> is ( <literal_string> { , <literal_string> } ) ;
+
+   procedure Parse_Variable_Declaration
+     (Variable          : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id);
+   --  Parse a variable assignment
+   --  <variable_Name> := <expression>; OR
+   --  <variable_Name> : <string_type_Name> := <string_expression>;
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Declarations    : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Modifying       : Project_Node_Id)
+   is
+      First_Declarative_Item : Project_Node_Id := Empty_Node;
+
+   begin
+      Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
+      Set_Location_Of (Declarations, To => Token_Ptr);
+      Set_Modified_Project_Of (Declarations, To => Modifying);
+      Parse_Declarative_Items
+        (Declarations    => First_Declarative_Item,
+         In_Zone         => In_Project,
+         First_Attribute => Prj.Attr.Attribute_First,
+         Current_Project => Current_Project,
+         Current_Package => Empty_Node);
+      Set_First_Declarative_Item_Of
+        (Declarations, To => First_Declarative_Item);
+   end Parse;
+
+   ---------------------------------
+   -- Parse_Attribute_Declaration --
+   ---------------------------------
+
+   procedure Parse_Attribute_Declaration
+     (Attribute       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Attribute : Attribute_Node_Id := First_Attribute;
+
+   begin
+      Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
+      Set_Location_Of (Attribute, To => Token_Ptr);
+
+      --  Scan past "for"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Attribute, To => Token_Name);
+         Set_Location_Of (Attribute, To => Token_Ptr);
+         while Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Name /= Token_Name
+         loop
+            Current_Attribute := Attributes.Table (Current_Attribute).Next;
+         end loop;
+
+         if Current_Attribute = Empty_Attribute then
+            Error_Msg ("undefined attribute", Token_Ptr);
+         end if;
+
+         Scan;
+      end if;
+
+      if Token = Tok_Left_Paren then
+         if Current_Attribute /= Empty_Attribute
+           and then Attributes.Table (Current_Attribute).Kind_2 = Single
+         then
+            Error_Msg ("this attribute cannot be an associative array",
+                       Location_Of (Attribute));
+         end if;
+
+         Scan;
+         Expect (Tok_String_Literal, "literal string");
+
+         if Token = Tok_String_Literal then
+            Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
+            Scan;
+         end if;
+
+         Expect (Tok_Right_Paren, ")");
+
+         if Token = Tok_Right_Paren then
+            Scan;
+         end if;
+
+      else
+         if Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Kind_2 = Associative_Array
+         then
+            Error_Msg ("this attribute need to be an associative array",
+                       Location_Of (Attribute));
+         end if;
+      end if;
+
+      if Current_Attribute /= Empty_Attribute then
+         Set_Expression_Kind_Of
+           (Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
+      end if;
+
+      Expect (Tok_Use, "use");
+
+      if Token = Tok_Use then
+         Scan;
+
+         declare
+            Expression_Location : constant Source_Ptr := Token_Ptr;
+            Expression          : Project_Node_Id     := Empty_Node;
+
+         begin
+            Prj.Strt.Parse_Expression
+              (Expression      => Expression,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+            Set_Expression_Of (Attribute, To => Expression);
+
+            if Current_Attribute /= Empty_Attribute
+              and then Expression /= Empty_Node
+              and then Attributes.Table (Current_Attribute).Kind_1 /=
+                                          Expression_Kind_Of (Expression)
+            then
+               Error_Msg
+                 ("wrong expression kind for the attribute",
+                  Expression_Location);
+            end if;
+         end;
+      end if;
+
+   end Parse_Attribute_Declaration;
+
+   -----------------------------
+   -- Parse_Case_Construction --
+   -----------------------------
+
+   procedure Parse_Case_Construction
+     (Case_Construction : out Project_Node_Id;
+      First_Attribute   : Attribute_Node_Id;
+      Current_Project   : Project_Node_Id;
+      Current_Package   : Project_Node_Id)
+   is
+      Current_Item      : Project_Node_Id := Empty_Node;
+      Next_Item         : Project_Node_Id := Empty_Node;
+      First_Case_Item   : Boolean := True;
+
+      Variable_Location : Source_Ptr := No_Location;
+
+      String_Type       : Project_Node_Id := Empty_Node;
+
+      Case_Variable     : Project_Node_Id := Empty_Node;
+
+      First_Declarative_Item : Project_Node_Id := Empty_Node;
+
+      First_Choice      : Project_Node_Id := Empty_Node;
+
+   begin
+      Case_Construction  :=
+        Default_Project_Node (Of_Kind => N_Case_Construction);
+      Set_Location_Of (Case_Construction, To => Token_Ptr);
+
+      --  Scan past "case"
+
+      Scan;
+
+      --  Get the switch variable
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Variable_Location := Token_Ptr;
+         Prj.Strt.Parse_Variable_Reference
+           (Variable        => Case_Variable,
+            Current_Project => Current_Project,
+            Current_Package => Current_Package);
+         Set_Case_Variable_Reference_Of
+           (Case_Construction, To => Case_Variable);
+
+      else
+         if Token /= Tok_Is then
+            Scan;
+         end if;
+      end if;
+
+      if Case_Variable /= Empty_Node then
+         String_Type := String_Type_Of (Case_Variable);
+
+         if String_Type = Empty_Node then
+            Error_Msg ("this variable is not typed", Variable_Location);
+         end if;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      if Token = Tok_Is then
+
+         --  Scan past "is"
+
+         Scan;
+      end if;
+
+      Prj.Strt.Start_New_Case_Construction (String_Type);
+
+      When_Loop :
+
+      while Token = Tok_When loop
+
+         if First_Case_Item then
+            Current_Item := Default_Project_Node (Of_Kind => N_Case_Item);
+            Set_First_Case_Item_Of (Case_Construction, To => Current_Item);
+            First_Case_Item := False;
+
+         else
+            Next_Item := Default_Project_Node (Of_Kind => N_Case_Item);
+            Set_Next_Case_Item (Current_Item, To => Next_Item);
+            Current_Item := Next_Item;
+         end if;
+
+         Set_Location_Of (Current_Item, To => Token_Ptr);
+
+         --  Scan past "when"
+
+         Scan;
+
+         if Token = Tok_Others then
+
+            --  Scan past "others"
+
+            Scan;
+
+            Expect (Tok_Arrow, "=>");
+
+            --  Empty_Node in Field1 of a Case_Item indicates
+            --  the "when others =>" branch.
+
+            Set_First_Choice_Of (Current_Item, To => Empty_Node);
+
+            Parse_Declarative_Items
+              (Declarations    => First_Declarative_Item,
+               In_Zone         => In_Case_Construction,
+               First_Attribute => First_Attribute,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+
+            --  "when others =>" must be the last branch, so save the
+            --  Case_Item and exit
+
+            Set_First_Declarative_Item_Of
+              (Current_Item, To => First_Declarative_Item);
+            exit When_Loop;
+
+         else
+            Prj.Strt.Parse_Choice_List (First_Choice => First_Choice);
+            Set_First_Choice_Of (Current_Item, To => First_Choice);
+
+            Expect (Tok_Arrow, "=>");
+
+            Parse_Declarative_Items
+              (Declarations    => First_Declarative_Item,
+               In_Zone         => In_Case_Construction,
+               First_Attribute => First_Attribute,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+
+            Set_First_Declarative_Item_Of
+              (Current_Item, To => First_Declarative_Item);
+
+         end if;
+      end loop When_Loop;
+
+      Prj.Strt.End_Case_Construction;
+
+      Expect (Tok_End, "end case");
+
+      if Token = Tok_End then
+
+         --  Scan past "end"
+
+         Scan;
+
+         Expect (Tok_Case, "case");
+
+      end if;
+
+      --  Scan past "case"
+
+      Scan;
+
+      Expect (Tok_Semicolon, ";");
+
+   end Parse_Case_Construction;
+
+   -----------------------------
+   -- Parse_Declarative_Items --
+   -----------------------------
+
+   procedure Parse_Declarative_Items
+     (Declarations    : out Project_Node_Id;
+      In_Zone         : Zone;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Declarative_Item : Project_Node_Id := Empty_Node;
+      Next_Declarative_Item    : Project_Node_Id := Empty_Node;
+      Current_Declaration      : Project_Node_Id := Empty_Node;
+      Item_Location            : Source_Ptr      := No_Location;
+
+   begin
+      Declarations := Empty_Node;
+
+      loop
+         --  We are always positioned at the token that precedes
+         --  the first token of the declarative element.
+         --  Scan past it
+
+         Scan;
+
+         Item_Location := Token_Ptr;
+
+         case Token is
+            when Tok_Identifier =>
+
+               if In_Zone = In_Case_Construction then
+                  Error_Msg ("a variable cannot be declared here",
+                             Token_Ptr);
+               end if;
+
+               Parse_Variable_Declaration
+                 (Current_Declaration,
+                  First_Attribute => First_Attribute,
+                  Current_Project => Current_Project,
+                  Current_Package => Current_Package);
+
+            when Tok_For =>
+
+               Parse_Attribute_Declaration
+                 (Attribute       => Current_Declaration,
+                  First_Attribute => First_Attribute,
+                  Current_Project => Current_Project,
+                  Current_Package => Current_Package);
+
+            when Tok_Package =>
+
+               --  Package declaration
+
+               if In_Zone /= In_Project then
+                  Error_Msg ("a package cannot be declared here", Token_Ptr);
+               end if;
+
+               Parse_Package_Declaration
+                 (Package_Declaration => Current_Declaration,
+                  Current_Project     => Current_Project);
+
+            when Tok_Type =>
+
+               --  Type String Declaration
+
+               if In_Zone /= In_Project then
+                  Error_Msg ("a string type cannot be declared here",
+                             Token_Ptr);
+               end if;
+
+               Parse_String_Type_Declaration
+                 (String_Type     => Current_Declaration,
+                  Current_Project => Current_Project,
+                  First_Attribute => First_Attribute);
+
+            when Tok_Case =>
+
+               --  Case construction
+
+               Parse_Case_Construction
+                 (Case_Construction => Current_Declaration,
+                  First_Attribute   => First_Attribute,
+                  Current_Project   => Current_Project,
+                  Current_Package   => Current_Package);
+
+            when others =>
+               exit;
+
+               --  We are leaving Parse_Declarative_Items positionned
+               --  at the first token after the list of declarative items.
+               --  It could be "end" (for a project, a package declaration or
+               --  a case construction) or "when" (for a case construction)
+
+         end case;
+
+         Expect (Tok_Semicolon, "; after declarative items");
+
+         if Current_Declarative_Item = Empty_Node then
+            Current_Declarative_Item :=
+              Default_Project_Node (Of_Kind => N_Declarative_Item);
+            Declarations  := Current_Declarative_Item;
+
+         else
+            Next_Declarative_Item :=
+              Default_Project_Node (Of_Kind => N_Declarative_Item);
+            Set_Next_Declarative_Item
+              (Current_Declarative_Item, To => Next_Declarative_Item);
+            Current_Declarative_Item := Next_Declarative_Item;
+         end if;
+
+         Set_Current_Item_Node
+           (Current_Declarative_Item, To => Current_Declaration);
+         Set_Location_Of (Current_Declarative_Item, To => Item_Location);
+
+      end loop;
+
+   end Parse_Declarative_Items;
+
+   -------------------------------
+   -- Parse_Package_Declaration --
+   -------------------------------
+
+   procedure Parse_Package_Declaration
+     (Package_Declaration : out Project_Node_Id;
+      Current_Project     : Project_Node_Id)
+   is
+      First_Attribute        : Attribute_Node_Id := Empty_Attribute;
+      Current_Package        : Package_Node_Id   := Empty_Package;
+      First_Declarative_Item : Project_Node_Id   := Empty_Node;
+
+   begin
+      Package_Declaration :=
+        Default_Project_Node (Of_Kind => N_Package_Declaration);
+      Set_Location_Of (Package_Declaration, To => Token_Ptr);
+
+      --  Scan past "package"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+
+         Set_Name_Of (Package_Declaration, To => Token_Name);
+
+         for Index in Package_Attributes.First .. Package_Attributes.Last loop
+            if Token_Name = Package_Attributes.Table (Index).Name then
+               First_Attribute :=
+                 Package_Attributes.Table (Index).First_Attribute;
+               Current_Package := Index;
+               exit;
+            end if;
+         end loop;
+
+         if Current_Package  = Empty_Package then
+            Error_Msg ("not an allowed package name", Token_Ptr);
+
+         else
+            Set_Package_Id_Of (Package_Declaration, To => Current_Package);
+
+            declare
+               Current : Project_Node_Id := First_Package_Of (Current_Project);
+
+            begin
+               while Current /= Empty_Node
+                 and then Name_Of (Current) /= Token_Name
+               loop
+                  Current := Next_Package_In_Project (Current);
+               end loop;
+
+               if Current /= Empty_Node then
+                  Error_Msg
+                    ("package declared twice in the same project", Token_Ptr);
+
+               else
+                  --  Add the package to the project list
+
+                  Set_Next_Package_In_Project
+                    (Package_Declaration,
+                     To => First_Package_Of (Current_Project));
+                  Set_First_Package_Of
+                    (Current_Project, To => Package_Declaration);
+               end if;
+            end;
+         end if;
+
+         --  Scan past the package name
+
+         Scan;
+
+      end if;
+
+      if Token = Tok_Renames then
+         --  Scan past "renames"
+         Scan;
+
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier then
+            declare
+               Project_Name : Name_Id := Token_Name;
+               Clause       : Project_Node_Id :=
+                                First_With_Clause_Of (Current_Project);
+               The_Project  : Project_Node_Id := Empty_Node;
+
+            begin
+               while Clause /= Empty_Node loop
+                  The_Project := Project_Node_Of (Clause);
+                  exit when Name_Of (The_Project) = Project_Name;
+                  Clause := Next_With_Clause_Of (Clause);
+               end loop;
+
+               if Clause = Empty_Node then
+                  Error_Msg ("not an imported project", Token_Ptr);
+               else
+                  Set_Project_Of_Renamed_Package_Of
+                    (Package_Declaration, To => The_Project);
+               end if;
+            end;
+
+            Scan;
+            Expect (Tok_Dot, ".");
+
+            if Token = Tok_Dot then
+               Scan;
+               Expect (Tok_Identifier, "identifier");
+
+               if Token = Tok_Identifier then
+                  if Name_Of (Package_Declaration) /= Token_Name then
+                     Error_Msg ("not the same package name", Token_Ptr);
+                  elsif
+                    Project_Of_Renamed_Package_Of (Package_Declaration)
+                                                              /= Empty_Node
+                  then
+                     declare
+                        Current : Project_Node_Id :=
+                                    First_Package_Of
+                                      (Project_Of_Renamed_Package_Of
+                                         (Package_Declaration));
+
+                     begin
+                        while Current /= Empty_Node
+                          and then Name_Of (Current) /= Token_Name
+                        loop
+                           Current := Next_Package_In_Project (Current);
+                        end loop;
+
+                        if Current = Empty_Node then
+                           Error_Msg
+                             ("not a package declared by the project",
+                              Token_Ptr);
+                        end if;
+                     end;
+                  end if;
+
+                  Scan;
+               end if;
+            end if;
+         end if;
+
+         Expect (Tok_Semicolon, ";");
+
+      elsif Token = Tok_Is then
+
+         Parse_Declarative_Items
+           (Declarations    => First_Declarative_Item,
+            In_Zone         => In_Package,
+            First_Attribute => First_Attribute,
+            Current_Project => Current_Project,
+            Current_Package => Package_Declaration);
+
+         Set_First_Declarative_Item_Of
+           (Package_Declaration, To => First_Declarative_Item);
+
+         Expect (Tok_End, "end");
+
+         if Token = Tok_End then
+
+            --  Scan past "end"
+
+            Scan;
+         end if;
+
+         --  We should have the name of the package after "end"
+
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier
+           and then Name_Of (Package_Declaration) /= No_Name
+           and then Token_Name /= Name_Of (Package_Declaration)
+         then
+            Error_Msg_Name_1 := Name_Of (Package_Declaration);
+            Error_Msg ("expected {", Token_Ptr);
+         end if;
+
+         if Token /= Tok_Semicolon then
+
+            --  Scan past the package name
+
+            Scan;
+         end if;
+
+         Expect (Tok_Semicolon, ";");
+
+      else
+         Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
+      end if;
+
+   end Parse_Package_Declaration;
+
+   -----------------------------------
+   -- Parse_String_Type_Declaration --
+   -----------------------------------
+
+   procedure Parse_String_Type_Declaration
+     (String_Type     : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      First_Attribute : Attribute_Node_Id)
+   is
+      Current      : Project_Node_Id := Empty_Node;
+      First_String : Project_Node_Id := Empty_Node;
+
+   begin
+      String_Type :=
+        Default_Project_Node (Of_Kind => N_String_Type_Declaration);
+
+      Set_Location_Of (String_Type, To => Token_Ptr);
+
+      --  Scan past "type"
+
+      Scan;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (String_Type, To => Token_Name);
+
+         Current := First_String_Type_Of (Current_Project);
+         while Current /= Empty_Node
+           and then
+           Name_Of (Current) /= Token_Name
+         loop
+            Current := Next_String_Type (Current);
+         end loop;
+
+         if Current /= Empty_Node then
+            Error_Msg ("duplicate string type name", Token_Ptr);
+         else
+            Current := First_Variable_Of (Current_Project);
+            while Current /= Empty_Node
+              and then Name_Of (Current) /= Token_Name
+            loop
+               Current := Next_Variable (Current);
+            end loop;
+
+            if Current /= Empty_Node then
+               Error_Msg ("already a variable name", Token_Ptr);
+            else
+               Set_Next_String_Type
+                 (String_Type, To => First_String_Type_Of (Current_Project));
+               Set_First_String_Type_Of (Current_Project, To => String_Type);
+            end if;
+         end if;
+
+         --  Scan past the name
+
+         Scan;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      if Token = Tok_Is then
+         Scan;
+      end if;
+
+      Expect (Tok_Left_Paren, "(");
+
+      if Token = Tok_Left_Paren then
+         Scan;
+      end if;
+
+      Prj.Strt.Parse_String_Type_List (First_String => First_String);
+      Set_First_Literal_String (String_Type, To => First_String);
+
+      Expect (Tok_Right_Paren, ")");
+
+      if Token = Tok_Right_Paren then
+         Scan;
+      end if;
+
+   end Parse_String_Type_Declaration;
+
+   --------------------------------
+   -- Parse_Variable_Declaration --
+   --------------------------------
+
+   procedure Parse_Variable_Declaration
+     (Variable        : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Expression_Location      : Source_Ptr;
+      String_Type_Name         : Name_Id := No_Name;
+      Project_String_Type_Name : Name_Id := No_Name;
+      Type_Location            : Source_Ptr := No_Location;
+      Project_Location         : Source_Ptr := No_Location;
+      Expression               : Project_Node_Id := Empty_Node;
+      Variable_Name            : constant Name_Id := Token_Name;
+
+   begin
+      Variable :=
+        Default_Project_Node (Of_Kind => N_Variable_Declaration);
+      Set_Name_Of (Variable, To => Variable_Name);
+      Set_Location_Of (Variable, To => Token_Ptr);
+
+      --  Scan past the variable name
+
+      Scan;
+
+      if Token = Tok_Colon then
+
+         --  Typed string variable declaration
+
+         Scan;
+         Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
+         Expect (Tok_Identifier, "identifier");
+
+         if Token = Tok_Identifier then
+            String_Type_Name := Token_Name;
+            Type_Location := Token_Ptr;
+            Scan;
+
+            if Token = Tok_Dot then
+               Project_String_Type_Name := String_Type_Name;
+               Project_Location := Type_Location;
+
+               --  Scan past the dot
+
+               Scan;
+               Expect (Tok_Identifier, "identifier");
+
+               if Token = Tok_Identifier then
+                  String_Type_Name := Token_Name;
+                  Type_Location := Token_Ptr;
+                  Scan;
+               else
+                  String_Type_Name := No_Name;
+               end if;
+            end if;
+
+            if String_Type_Name /= No_Name then
+               declare
+                  Current : Project_Node_Id :=
+                              First_String_Type_Of (Current_Project);
+
+               begin
+                  if Project_String_Type_Name /= No_Name then
+                     declare
+                        The_Project_Name_And_Node : constant
+                          Tree_Private_Part.Project_Name_And_Node :=
+                          Tree_Private_Part.Projects_Htable.Get
+                                                    (Project_String_Type_Name);
+
+                        use Tree_Private_Part;
+
+                     begin
+                        if The_Project_Name_And_Node =
+                          Tree_Private_Part.No_Project_Name_And_Node
+                        then
+                           Error_Msg ("unknown project", Project_Location);
+                           Current := Empty_Node;
+                        else
+                           Current :=
+                             First_String_Type_Of
+                                         (The_Project_Name_And_Node.Node);
+                        end if;
+                     end;
+                  end if;
+
+                  while Current /= Empty_Node
+                    and then Name_Of (Current) /= String_Type_Name
+                  loop
+                     Current := Next_String_Type (Current);
+                  end loop;
+
+                  if Current = Empty_Node then
+                     Error_Msg ("unknown string type", Type_Location);
+                  else
+                     Set_String_Type_Of
+                       (Variable, To => Current);
+                  end if;
+               end;
+            end if;
+         end if;
+      end if;
+
+      Expect (Tok_Colon_Equal, ":=");
+
+      if Token = Tok_Colon_Equal then
+         Scan;
+      end if;
+
+      --  Get the single string or string list value
+
+      Expression_Location := Token_Ptr;
+
+      Prj.Strt.Parse_Expression
+        (Expression      => Expression,
+         Current_Project => Current_Project,
+         Current_Package => Current_Package);
+      Set_Expression_Of (Variable, To => Expression);
+
+      if Expression /= Empty_Node then
+         Set_Expression_Kind_Of
+           (Variable, To => Expression_Kind_Of (Expression));
+      end if;
+
+      declare
+         The_Variable : Project_Node_Id := Empty_Node;
+
+      begin
+         if Current_Package /= Empty_Node then
+            The_Variable :=  First_Variable_Of (Current_Package);
+         elsif Current_Project /= Empty_Node then
+            The_Variable :=  First_Variable_Of (Current_Project);
+         end if;
+
+         while The_Variable /= Empty_Node
+           and then Name_Of (The_Variable) /= Variable_Name
+         loop
+            The_Variable := Next_Variable (The_Variable);
+         end loop;
+
+         if The_Variable = Empty_Node then
+            if Current_Package /= Empty_Node then
+               Set_Next_Variable
+                 (Variable, To => First_Variable_Of (Current_Package));
+               Set_First_Variable_Of (Current_Package, To => Variable);
+
+            elsif Current_Project /= Empty_Node then
+               Set_Next_Variable
+                 (Variable, To => First_Variable_Of (Current_Project));
+               Set_First_Variable_Of (Current_Project, To => Variable);
+            end if;
+
+         else
+            if Expression_Kind_Of (Variable) /= Undefined then
+               if Expression_Kind_Of (The_Variable) = Undefined then
+                  Set_Expression_Kind_Of
+                    (The_Variable, To => Expression_Kind_Of (Variable));
+
+               else
+                  if Expression_Kind_Of (The_Variable) /=
+                                                 Expression_Kind_Of (Variable)
+                  then
+                     Error_Msg ("wrong expression kind for the variable",
+                                Expression_Location);
+                  end if;
+               end if;
+            end if;
+         end if;
+      end;
+
+   end Parse_Variable_Declaration;
+
+end Prj.Dect;
diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads
new file mode 100644
index 0000000..3072c57
--- /dev/null
+++ b/gcc/ada/prj-dect.ads
@@ -0,0 +1,41 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . D E C T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Parse a list of declarative items in a project file.
+
+with Prj.Tree;
+
+private package Prj.Dect is
+
+   procedure Parse
+     (Declarations    : out Prj.Tree.Project_Node_Id;
+      Current_Project : Prj.Tree.Project_Node_Id;
+      Modifying       : Prj.Tree.Project_Node_Id);
+   --  Parse project declarative items.
+
+end Prj.Dect;
diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
new file mode 100644
index 0000000..171a2d0
--- /dev/null
+++ b/gcc/ada/prj-env.adb
@@ -0,0 +1,1471 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E N V                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.17 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Opt;
+with Osint;       use Osint;
+with Output;      use Output;
+with Prj.Com;     use Prj.Com;
+with Prj.Util;
+with Snames;      use Snames;
+with Stringt;     use Stringt;
+with Table;
+
+package body Prj.Env is
+
+   type Naming_Id is new Nat;
+   No_Naming : constant Naming_Id := 0;
+
+   Ada_Path_Buffer : String_Access := new String (1 .. 1_000);
+   --  A buffer where values for ADA_INCLUDE_PATH
+   --  and ADA_OBJECTS_PATH are stored.
+
+   Ada_Path_Length : Natural := 0;
+   --  Index of the last valid character in Ada_Path_Buffer.
+
+   package Namings is new Table.Table (
+     Table_Component_Type => Naming_Data,
+     Table_Index_Type     => Naming_Id,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 5,
+     Table_Increment      => 100,
+     Table_Name           => "Prj.Env.Namings");
+
+   Default_Naming : constant Naming_Id := Namings.First;
+
+   Global_Configuration_Pragmas : Name_Id;
+   Local_Configuration_Pragmas  : Name_Id;
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   function Body_Path_Name_Of (Unit : Unit_Id) return String;
+   --  Returns the path name of the body of a unit.
+   --  Compute it first, if necessary.
+
+   function Spec_Path_Name_Of (Unit : Unit_Id) return String;
+   --  Returns the path name of the spec of a unit.
+   --  Compute it first, if necessary.
+
+   procedure Add_To_Path (Path : String);
+   --  Add Path to global variable Ada_Path_Buffer
+   --  Increment Ada_Path_Length
+
+   ----------------------
+   -- Ada_Include_Path --
+   ----------------------
+
+   function Ada_Include_Path (Project : Project_Id) return String_Access is
+
+      procedure Add (Project : Project_Id);
+      --  Add all the source directories of a project to the path,
+      --  only if this project has not been visited.
+      --  Call itself recursively for projects being modified,
+      --  and imported projects.
+      --  Add the project to the list Seen if this is the first time
+      --  we call Add for this project.
+
+      ---------
+      -- Add --
+      ---------
+
+      procedure Add (Project : Project_Id) is
+      begin
+         --  If Seen is empty, then the project cannot have been
+         --  visited.
+
+         if not Projects.Table (Project).Seen then
+            Projects.Table (Project).Seen := True;
+
+            declare
+               Data : Project_Data := Projects.Table (Project);
+               List : Project_List := Data.Imported_Projects;
+
+               Current : String_List_Id := Data.Source_Dirs;
+               Source_Dir : String_Element;
+
+            begin
+               --  Add to path all source directories of this project
+
+               while Current /= Nil_String loop
+                  if Ada_Path_Length > 0 then
+                     Add_To_Path (Path => (1 => Path_Separator));
+                  end if;
+
+                  Source_Dir := String_Elements.Table (Current);
+                  String_To_Name_Buffer (Source_Dir.Value);
+
+                  declare
+                     New_Path : constant String :=
+                       Name_Buffer (1 .. Name_Len);
+                  begin
+                     Add_To_Path (New_Path);
+                  end;
+
+                  Current := Source_Dir.Next;
+               end loop;
+
+               --  Call Add to the project being modified, if any
+
+               if Data.Modifies /= No_Project then
+                  Add (Data.Modifies);
+               end if;
+
+               --  Call Add for each imported project, if any
+
+               while List /= Empty_Project_List loop
+                  Add (Project_Lists.Table (List).Project);
+                  List := Project_Lists.Table (List).Next;
+               end loop;
+            end;
+         end if;
+
+      end Add;
+
+   --  Start of processing for Ada_Include_Path
+
+   begin
+      --  If it is the first time we call this function for
+      --  this project, compute the source path
+
+      if Projects.Table (Project).Include_Path = null then
+         Ada_Path_Length := 0;
+
+         for Index in 1 .. Projects.Last loop
+            Projects.Table (Index).Seen := False;
+         end loop;
+
+         Add (Project);
+         Projects.Table (Project).Include_Path :=
+           new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
+      end if;
+
+      return Projects.Table (Project).Include_Path;
+   end Ada_Include_Path;
+
+   ----------------------
+   -- Ada_Objects_Path --
+   ----------------------
+
+   function Ada_Objects_Path
+     (Project             : Project_Id;
+      Including_Libraries : Boolean := True)
+     return String_Access is
+
+      procedure Add (Project : Project_Id);
+      --  Add all the object directory of a project to the path,
+      --  only if this project has not been visited.
+      --  Call itself recursively for projects being modified,
+      --  and imported projects.
+      --  Add the project to the list Seen if this is the first time
+      --  we call Add for this project.
+
+      ---------
+      -- Add --
+      ---------
+
+      procedure Add (Project : Project_Id) is
+      begin
+
+         --  If this project has not been seen yet
+
+         if not Projects.Table (Project).Seen then
+            Projects.Table (Project).Seen := True;
+
+            declare
+               Data : Project_Data := Projects.Table (Project);
+               List : Project_List := Data.Imported_Projects;
+
+            begin
+               --  Add to path the object directory of this project
+               --  except if we don't include library project and
+               --  this is a library project.
+
+               if (Data.Library and then Including_Libraries)
+                 or else
+                 (Data.Object_Directory /= No_Name
+                   and then
+                   (not Including_Libraries or else not Data.Library))
+               then
+                  if Ada_Path_Length > 0 then
+                     Add_To_Path (Path => (1 => Path_Separator));
+                  end if;
+
+                  --  For a library project, att the library directory
+
+                  if Data.Library then
+                     declare
+                        New_Path : constant String :=
+                          Get_Name_String (Data.Library_Dir);
+                     begin
+                        Add_To_Path (New_Path);
+                     end;
+                  else
+
+                     --  For a non library project, add the object directory
+                     declare
+                        New_Path : constant String :=
+                          Get_Name_String (Data.Object_Directory);
+                     begin
+                        Add_To_Path (New_Path);
+                     end;
+                  end if;
+               end if;
+
+               --  Call Add to the project being modified, if any
+
+               if Data.Modifies /= No_Project then
+                  Add (Data.Modifies);
+               end if;
+
+               --  Call Add for each imported project, if any
+
+               while List /= Empty_Project_List loop
+                  Add (Project_Lists.Table (List).Project);
+                  List := Project_Lists.Table (List).Next;
+               end loop;
+            end;
+
+         end if;
+      end Add;
+
+   --  Start of processing for Ada_Objects_Path
+
+   begin
+      --  If it is the first time we call this function for
+      --  this project, compute the objects path
+
+      if Projects.Table (Project).Objects_Path = null then
+         Ada_Path_Length := 0;
+
+         for Index in 1 .. Projects.Last loop
+            Projects.Table (Index).Seen := False;
+         end loop;
+
+         Add (Project);
+         Projects.Table (Project).Objects_Path :=
+           new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
+      end if;
+
+      return Projects.Table (Project).Objects_Path;
+   end Ada_Objects_Path;
+
+   -----------------
+   -- Add_To_Path --
+   -----------------
+
+   procedure Add_To_Path (Path : String) is
+   begin
+      --  If Ada_Path_Buffer is too small, double it
+
+      if Ada_Path_Length + Path'Length > Ada_Path_Buffer'Last then
+         declare
+            New_Ada_Path_Buffer : constant String_Access :=
+                                    new String
+                                      (1 .. Ada_Path_Buffer'Last +
+                                                 Ada_Path_Buffer'Last);
+
+         begin
+            New_Ada_Path_Buffer (1 .. Ada_Path_Length) :=
+              Ada_Path_Buffer (1 .. Ada_Path_Length);
+            Ada_Path_Buffer := New_Ada_Path_Buffer;
+         end;
+      end if;
+
+      Ada_Path_Buffer
+        (Ada_Path_Length + 1 .. Ada_Path_Length + Path'Length) := Path;
+      Ada_Path_Length := Ada_Path_Length + Path'Length;
+   end Add_To_Path;
+
+   -----------------------
+   -- Body_Path_Name_Of --
+   -----------------------
+
+   function Body_Path_Name_Of (Unit : Unit_Id) return String is
+      Data : Unit_Data := Units.Table (Unit);
+
+   begin
+      --  If we don't know the path name of the body of this unit,
+      --  we compute it, and we store it.
+
+      if Data.File_Names (Body_Part).Path = No_Name then
+         declare
+            Current_Source : String_List_Id :=
+              Projects.Table (Data.File_Names (Body_Part).Project).Sources;
+            Path : GNAT.OS_Lib.String_Access;
+
+         begin
+            --  By default, put the file name
+
+            Data.File_Names (Body_Part).Path :=
+              Data.File_Names (Body_Part).Name;
+
+            --  For each source directory
+
+            while Current_Source /= Nil_String loop
+               String_To_Name_Buffer
+                 (String_Elements.Table (Current_Source).Value);
+               Path :=
+                 Locate_Regular_File
+                 (Namet.Get_Name_String
+                  (Data.File_Names (Body_Part).Name),
+                  Name_Buffer (1 .. Name_Len));
+
+               --  If the file is in this directory,
+               --  then we store the path, and we are done.
+
+               if Path /= null then
+                  Name_Len := Path'Length;
+                  Name_Buffer (1 .. Name_Len) := Path.all;
+                  Data.File_Names (Body_Part).Path := Name_Enter;
+                  exit;
+
+               else
+                  Current_Source :=
+                    String_Elements.Table (Current_Source).Next;
+               end if;
+            end loop;
+
+            Units.Table (Unit) := Data;
+         end;
+      end if;
+
+      --  Returned the value stored
+
+      return Namet.Get_Name_String (Data.File_Names (Body_Part).Path);
+   end Body_Path_Name_Of;
+
+   --------------------------------
+   -- Create_Config_Pragmas_File --
+   --------------------------------
+
+   procedure Create_Config_Pragmas_File
+     (For_Project  : Project_Id;
+      Main_Project : Project_Id)
+   is
+      File_Name : Temp_File_Name;
+      File      : File_Descriptor := Invalid_FD;
+
+      The_Packages : Package_Id;
+      Gnatmake     : Prj.Package_Id;
+      Compiler     : Prj.Package_Id;
+
+      Current_Unit : Unit_Id := Units.First;
+
+      First_Project : Project_List := Empty_Project_List;
+
+      Current_Project : Project_List;
+      Current_Naming  : Naming_Id;
+
+      Global_Attribute : Variable_Value := Nil_Variable_Value;
+      Local_Attribute  : Variable_Value := Nil_Variable_Value;
+
+      Global_Attribute_Present : Boolean := False;
+      Local_Attribute_Present  : Boolean := False;
+
+      procedure Check (Project : Project_Id);
+
+      procedure Check_Temp_File;
+      --  Check that a temporary file has been opened.
+      --  If not, create one, and put its name in the project data,
+      --  with the indication that it is a temporary file.
+
+      procedure Copy_File (Name : String_Id);
+      --  Copy a configuration pragmas file into the temp file.
+
+      procedure Put
+        (Unit_Name : Name_Id;
+         File_Name : Name_Id;
+         Unit_Kind : Spec_Or_Body);
+      --  Put an SFN pragma in the temporary file.
+
+      procedure Put (File : File_Descriptor; S : String);
+
+      procedure Put_Line (File : File_Descriptor; S : String);
+
+      -----------
+      -- Check --
+      -----------
+
+      procedure Check (Project : Project_Id) is
+         Data : constant Project_Data := Projects.Table (Project);
+
+      begin
+         if Current_Verbosity = High then
+            Write_Str ("Checking project file """);
+            Write_Str (Namet.Get_Name_String (Data.Name));
+            Write_Str (""".");
+            Write_Eol;
+         end if;
+
+         --  Is this project in the list of the visited project?
+
+         Current_Project := First_Project;
+         while Current_Project /= Empty_Project_List
+           and then Project_Lists.Table (Current_Project).Project /= Project
+         loop
+            Current_Project := Project_Lists.Table (Current_Project).Next;
+         end loop;
+
+         --  If it is not, put it in the list, and visit it
+
+         if Current_Project = Empty_Project_List then
+            Project_Lists.Increment_Last;
+            Project_Lists.Table (Project_Lists.Last) :=
+              (Project => Project, Next => First_Project);
+            First_Project := Project_Lists.Last;
+
+            --  Is the naming scheme of this project one that we know?
+
+            Current_Naming := Default_Naming;
+            while Current_Naming <= Namings.Last and then
+              not Same_Naming_Scheme
+              (Left => Namings.Table (Current_Naming),
+               Right => Data.Naming) loop
+               Current_Naming := Current_Naming + 1;
+            end loop;
+
+            --  If we don't know it, add it
+
+            if Current_Naming > Namings.Last then
+               Namings.Increment_Last;
+               Namings.Table (Namings.Last) := Data.Naming;
+
+               --  We need a temporary file to be created
+
+               Check_Temp_File;
+
+               --  Put the SFN pragmas for the naming scheme
+
+               --  Spec
+
+               Put_Line
+                 (File, "pragma Source_File_Name");
+               Put_Line
+                 (File, "  (Spec_File_Name  => ""*" &
+                  Namet.Get_Name_String (Data.Naming.Specification_Append) &
+                  """,");
+               Put_Line
+                 (File, "   Casing          => " &
+                  Image (Data.Naming.Casing) & ",");
+               Put_Line
+                 (File, "   Dot_Replacement => """ &
+                 Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
+                  """);");
+
+               --  and body
+
+               Put_Line
+                 (File, "pragma Source_File_Name");
+               Put_Line
+                 (File, "  (Body_File_Name  => ""*" &
+                  Namet.Get_Name_String (Data.Naming.Body_Append) &
+                  """,");
+               Put_Line
+                 (File, "   Casing          => " &
+                  Image (Data.Naming.Casing) & ",");
+               Put_Line
+                 (File, "   Dot_Replacement => """ &
+                  Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
+                  """);");
+
+               --  and maybe separate
+
+               if Data.Naming.Body_Append /= Data.Naming.Separate_Append then
+                  Put_Line
+                    (File, "pragma Source_File_Name");
+                  Put_Line
+                    (File, "  (Subunit_File_Name  => ""*" &
+                     Namet.Get_Name_String (Data.Naming.Separate_Append) &
+                     """,");
+                  Put_Line
+                    (File, "   Casing          => " &
+                     Image (Data.Naming.Casing) &
+                     ",");
+                  Put_Line
+                    (File, "   Dot_Replacement => """ &
+                     Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
+                     """);");
+               end if;
+            end if;
+
+            if Data.Modifies /= No_Project then
+               Check (Data.Modifies);
+            end if;
+
+            declare
+               Current : Project_List := Data.Imported_Projects;
+
+            begin
+               while Current /= Empty_Project_List loop
+                  Check (Project_Lists.Table (Current).Project);
+                  Current := Project_Lists.Table (Current).Next;
+               end loop;
+            end;
+         end if;
+      end Check;
+
+      ---------------------
+      -- Check_Temp_File --
+      ---------------------
+
+      procedure Check_Temp_File is
+      begin
+         if File = Invalid_FD then
+            GNAT.OS_Lib.Create_Temp_File (File, Name => File_Name);
+            if File = Invalid_FD then
+               Osint.Fail
+                 ("unable to create temporary configuration pragmas file");
+            elsif Opt.Verbose_Mode then
+               Write_Str ("Creating temp file """);
+               Write_Str (File_Name);
+               Write_Line ("""");
+            end if;
+         end if;
+      end Check_Temp_File;
+
+      ---------------
+      -- Copy_File --
+      ---------------
+
+      procedure Copy_File (Name : in String_Id) is
+         Input         : File_Descriptor;
+         Buffer        : String (1 .. 1_000);
+         Input_Length  : Integer;
+         Output_Length : Integer;
+
+      begin
+         Check_Temp_File;
+         String_To_Name_Buffer (Name);
+
+         if Opt.Verbose_Mode then
+            Write_Str ("Copying config pragmas file """);
+            Write_Str (Name_Buffer (1 .. Name_Len));
+            Write_Line (""" into temp file");
+         end if;
+
+         declare
+            Name : constant String :=
+              Name_Buffer (1 .. Name_Len)  & ASCII.NUL;
+         begin
+            Input := Open_Read (Name'Address, Binary);
+         end;
+
+         if Input = Invalid_FD then
+            Osint.Fail
+              ("cannot open configuration pragmas file " &
+               Name_Buffer (1 .. Name_Len));
+         end if;
+
+         loop
+            Input_Length := Read (Input, Buffer'Address, Buffer'Length);
+            Output_Length := Write (File, Buffer'Address, Input_Length);
+
+            if Output_Length /= Input_Length then
+               Osint.Fail ("disk full");
+            end if;
+
+            exit when Input_Length < Buffer'Length;
+         end loop;
+
+         Close (Input);
+
+      end Copy_File;
+
+      ---------
+      -- Put --
+      ---------
+
+      procedure Put
+        (Unit_Name : Name_Id;
+         File_Name : Name_Id;
+         Unit_Kind : Spec_Or_Body)
+      is
+      begin
+         --  A temporary file needs to be open
+
+         Check_Temp_File;
+
+         --  Put the pragma SFN for the unit kind (spec or body)
+
+         Put (File, "pragma Source_File_Name (");
+         Put (File, Namet.Get_Name_String (Unit_Name));
+
+         if Unit_Kind = Specification then
+            Put (File, ", Spec_File_Name => """);
+         else
+            Put (File, ", Body_File_Name => """);
+         end if;
+
+         Put (File, Namet.Get_Name_String (File_Name));
+         Put_Line (File, """);");
+      end Put;
+
+      procedure Put (File : File_Descriptor; S : String) is
+         Last : Natural;
+
+      begin
+         Last := Write (File, S (S'First)'Address, S'Length);
+
+         if Last /= S'Length then
+            Osint.Fail ("Disk full");
+         end if;
+
+         if Current_Verbosity = High then
+            Write_Str (S);
+         end if;
+      end Put;
+
+      --------------
+      -- Put_Line --
+      --------------
+
+      procedure Put_Line (File : File_Descriptor; S : String) is
+         S0   : String (1 .. S'Length + 1);
+         Last : Natural;
+
+      begin
+         --  Add an ASCII.LF to the string. As this gnat.adc
+         --  is supposed to be used only by the compiler, we don't
+         --  care about the characters for the end of line.
+         --  The truth is we could have put a space, but it is
+         --  more convenient to be able to read gnat.adc during
+         --  development. And the development was done under UNIX.
+         --  Hence the ASCII.LF.
+
+         S0 (1 .. S'Length) := S;
+         S0 (S0'Last) := ASCII.LF;
+         Last := Write (File, S0'Address, S0'Length);
+
+         if Last /= S'Length + 1 then
+            Osint.Fail ("Disk full");
+         end if;
+
+         if Current_Verbosity = High then
+            Write_Line (S);
+         end if;
+      end Put_Line;
+
+   --  Start of processing for Create_Config_Pragmas_File
+
+   begin
+
+      if not Projects.Table (For_Project).Config_Checked then
+
+         --  Remove any memory of processed naming schemes, if any
+
+         Namings.Set_Last (Default_Naming);
+
+         --  Check the naming schemes
+
+         Check (For_Project);
+
+         --  Visit all the units and process those that need an SFN pragma
+
+         while Current_Unit <= Units.Last loop
+            declare
+               Unit : constant Unit_Data :=
+                 Units.Table (Current_Unit);
+
+            begin
+               if Unit.File_Names (Specification).Needs_Pragma then
+                  Put (Unit.Name,
+                       Unit.File_Names (Specification).Name,
+                       Specification);
+               end if;
+
+               if Unit.File_Names (Body_Part).Needs_Pragma then
+                  Put (Unit.Name,
+                       Unit.File_Names (Body_Part).Name,
+                       Body_Part);
+               end if;
+
+               Current_Unit := Current_Unit + 1;
+            end;
+         end loop;
+
+         The_Packages := Projects.Table (Main_Project).Decl.Packages;
+         Gnatmake :=
+           Prj.Util.Value_Of
+           (Name        => Name_Gnatmake,
+            In_Packages => The_Packages);
+
+         if Gnatmake /= No_Package then
+            Global_Attribute := Prj.Util.Value_Of
+              (Variable_Name => Global_Configuration_Pragmas,
+               In_Variables => Packages.Table (Gnatmake).Decl.Attributes);
+            Global_Attribute_Present :=
+              Global_Attribute /= Nil_Variable_Value
+              and then String_Length (Global_Attribute.Value) > 0;
+         end if;
+
+         The_Packages := Projects.Table (For_Project).Decl.Packages;
+         Compiler :=
+           Prj.Util.Value_Of
+           (Name        => Name_Compiler,
+            In_Packages => The_Packages);
+
+         if Compiler /= No_Package then
+            Local_Attribute := Prj.Util.Value_Of
+              (Variable_Name => Local_Configuration_Pragmas,
+               In_Variables => Packages.Table (Compiler).Decl.Attributes);
+            Local_Attribute_Present :=
+              Local_Attribute /= Nil_Variable_Value
+              and then String_Length (Local_Attribute.Value) > 0;
+         end if;
+
+         if Global_Attribute_Present then
+
+            if File /= Invalid_FD
+              or else Local_Attribute_Present
+            then
+               Copy_File (Global_Attribute.Value);
+            else
+               String_To_Name_Buffer (Global_Attribute.Value);
+               Projects.Table (For_Project).Config_File_Name := Name_Find;
+            end if;
+         end if;
+
+         if Local_Attribute_Present then
+
+            if File /= Invalid_FD then
+               Copy_File (Local_Attribute.Value);
+
+            else
+               String_To_Name_Buffer (Local_Attribute.Value);
+               Projects.Table (For_Project).Config_File_Name := Name_Find;
+            end if;
+
+         end if;
+
+         if File /= Invalid_FD then
+            GNAT.OS_Lib.Close (File);
+
+            if Opt.Verbose_Mode then
+               Write_Str ("Closing configuration file """);
+               Write_Str (File_Name);
+               Write_Line ("""");
+            end if;
+
+            Name_Len := File_Name'Length;
+            Name_Buffer (1 .. Name_Len) := File_Name;
+            Projects.Table (For_Project).Config_File_Name := Name_Find;
+            Projects.Table (For_Project).Config_File_Temp := True;
+         end if;
+
+         Projects.Table (For_Project).Config_Checked := True;
+
+      end if;
+
+   end Create_Config_Pragmas_File;
+
+   ------------------------------------
+   -- File_Name_Of_Library_Unit_Body --
+   ------------------------------------
+
+   function File_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String
+   is
+      Data          : constant Project_Data := Projects.Table (Project);
+      Original_Name : String := Name;
+
+      Extended_Spec_Name : String :=
+                             Name & Namet.Get_Name_String
+                                      (Data.Naming.Specification_Append);
+      Extended_Body_Name : String :=
+                             Name & Namet.Get_Name_String
+                                      (Data.Naming.Body_Append);
+
+      Unit : Unit_Data;
+
+      The_Original_Name : Name_Id;
+      The_Spec_Name     : Name_Id;
+      The_Body_Name     : Name_Id;
+
+   begin
+      Canonical_Case_File_Name (Original_Name);
+      Name_Len := Original_Name'Length;
+      Name_Buffer (1 .. Name_Len) := Original_Name;
+      The_Original_Name := Name_Find;
+
+      Canonical_Case_File_Name (Extended_Spec_Name);
+      Name_Len := Extended_Spec_Name'Length;
+      Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
+      The_Spec_Name := Name_Find;
+
+      Canonical_Case_File_Name (Extended_Body_Name);
+      Name_Len := Extended_Body_Name'Length;
+      Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
+      The_Body_Name := Name_Find;
+
+      if Current_Verbosity = High then
+         Write_Str  ("Looking for file name of """);
+         Write_Str  (Name);
+         Write_Char ('"');
+         Write_Eol;
+         Write_Str  ("   Extended Spec Name = """);
+         Write_Str  (Extended_Spec_Name);
+         Write_Char ('"');
+         Write_Eol;
+         Write_Str  ("   Extended Body Name = """);
+         Write_Str  (Extended_Body_Name);
+         Write_Char ('"');
+         Write_Eol;
+      end if;
+
+      --  For every unit
+
+      for Current in reverse Units.First .. Units.Last loop
+         Unit := Units.Table (Current);
+
+         --  If it is a unit of the same project
+
+         if Unit.File_Names (Body_Part).Project = Project then
+            declare
+               Current_Name : constant Name_Id :=
+                                Unit.File_Names (Body_Part).Name;
+
+            begin
+               --  If there is a body
+
+               if Current_Name /= No_Name then
+                  if Current_Verbosity = High then
+                     Write_Str  ("   Comparing with """);
+                     Write_Str  (Get_Name_String (Current_Name));
+                     Write_Char ('"');
+                     Write_Eol;
+                  end if;
+
+                  --  If it has the name of the original name,
+                  --  return the original name
+
+                  if Unit.Name = The_Original_Name
+                    or else Current_Name = The_Original_Name
+                  then
+                     if Current_Verbosity = High then
+                        Write_Line ("   OK");
+                     end if;
+
+                     return Get_Name_String (Current_Name);
+
+                  --  If it has the name of the extended body name,
+                  --  return the extended body name
+
+                  elsif Current_Name = The_Body_Name then
+                     if Current_Verbosity = High then
+                        Write_Line ("   OK");
+                     end if;
+
+                     return Extended_Body_Name;
+
+                  else
+                     if Current_Verbosity = High then
+                        Write_Line ("   not good");
+                     end if;
+                  end if;
+               end if;
+            end;
+         end if;
+
+         --  If it is a unit of the same project
+
+         if Units.Table (Current).File_Names (Specification).Project =
+                                                                 Project
+         then
+            declare
+               Current_Name : constant Name_Id :=
+                                Unit.File_Names (Specification).Name;
+
+            begin
+               --  If there is a spec
+
+               if Current_Name /= No_Name then
+                  if Current_Verbosity = High then
+                     Write_Str  ("   Comparing with """);
+                     Write_Str  (Get_Name_String (Current_Name));
+                     Write_Char ('"');
+                     Write_Eol;
+                  end if;
+
+                  --  If it has the same name as the original name,
+                  --  return the original name
+
+                  if Unit.Name = The_Original_Name
+                    or else Current_Name = The_Original_Name
+                  then
+                     if Current_Verbosity = High then
+                        Write_Line ("   OK");
+                     end if;
+
+                     return Get_Name_String (Current_Name);
+
+                  --  If it has the same name as the extended spec name,
+                  --  return the extended spec name
+
+                  elsif Current_Name = The_Spec_Name then
+                     if Current_Verbosity = High then
+                        Write_Line ("   OK");
+                     end if;
+
+                     return Extended_Spec_Name;
+
+                  else
+                     if Current_Verbosity = High then
+                        Write_Line ("   not good");
+                     end if;
+                  end if;
+               end if;
+            end;
+         end if;
+
+      end loop;
+
+      --  We don't know this file name, return an empty string
+
+      return "";
+   end File_Name_Of_Library_Unit_Body;
+
+   -------------------------
+   -- For_All_Object_Dirs --
+   -------------------------
+
+   procedure For_All_Object_Dirs (Project : Project_Id) is
+      Seen : Project_List := Empty_Project_List;
+
+      procedure Add (Project : Project_Id);
+      --  Process a project. Remember the processes visited to avoid
+      --  processing a project twice. Recursively process an eventual
+      --  modified project, and all imported projects.
+
+      ---------
+      -- Add --
+      ---------
+
+      procedure Add (Project : Project_Id) is
+         Data : constant Project_Data := Projects.Table (Project);
+         List : Project_List := Data.Imported_Projects;
+
+      begin
+         --  If the list of visited project is empty, then
+         --  for sure we never visited this project.
+
+         if Seen = Empty_Project_List then
+            Project_Lists.Increment_Last;
+            Seen := Project_Lists.Last;
+            Project_Lists.Table (Seen) :=
+              (Project => Project, Next => Empty_Project_List);
+
+         else
+            --  Check if the project is in the list
+
+            declare
+               Current : Project_List := Seen;
+
+            begin
+               loop
+                  --  If it is, then there is nothing else to do
+
+                  if Project_Lists.Table (Current).Project = Project then
+                     return;
+                  end if;
+
+                  exit when Project_Lists.Table (Current).Next =
+                    Empty_Project_List;
+                  Current := Project_Lists.Table (Current).Next;
+               end loop;
+
+               --  This project has never been visited, add it
+               --  to the list.
+
+               Project_Lists.Increment_Last;
+               Project_Lists.Table (Current).Next := Project_Lists.Last;
+               Project_Lists.Table (Project_Lists.Last) :=
+                 (Project => Project, Next => Empty_Project_List);
+            end;
+         end if;
+
+         --  If there is an object directory, call Action
+         --  with its name
+
+         if Data.Object_Directory /= No_Name then
+            Get_Name_String (Data.Object_Directory);
+            Action (Name_Buffer (1 .. Name_Len));
+         end if;
+
+         --  If we are modifying a project, visit it
+
+         if Data.Modifies /= No_Project then
+            Add (Data.Modifies);
+         end if;
+
+         --  And visit all imported projects
+
+         while List /= Empty_Project_List loop
+            Add (Project_Lists.Table (List).Project);
+            List := Project_Lists.Table (List).Next;
+         end loop;
+      end Add;
+
+   --  Start of processing for For_All_Object_Dirs
+
+   begin
+      --  Visit this project, and its imported projects,
+      --  recursively
+
+      Add (Project);
+   end For_All_Object_Dirs;
+
+   -------------------------
+   -- For_All_Source_Dirs --
+   -------------------------
+
+   procedure For_All_Source_Dirs (Project : Project_Id) is
+      Seen : Project_List := Empty_Project_List;
+
+      procedure Add (Project : Project_Id);
+      --  Process a project. Remember the processes visited to avoid
+      --  processing a project twice. Recursively process an eventual
+      --  modified project, and all imported projects.
+
+      ---------
+      -- Add --
+      ---------
+
+      procedure Add (Project : Project_Id) is
+         Data : constant Project_Data := Projects.Table (Project);
+         List : Project_List := Data.Imported_Projects;
+
+      begin
+         --  If the list of visited project is empty, then
+         --  for sure we never visited this project.
+
+         if Seen = Empty_Project_List then
+            Project_Lists.Increment_Last;
+            Seen := Project_Lists.Last;
+            Project_Lists.Table (Seen) :=
+              (Project => Project, Next => Empty_Project_List);
+
+         else
+            --  Check if the project is in the list
+
+            declare
+               Current : Project_List := Seen;
+
+            begin
+               loop
+                  --  If it is, then there is nothing else to do
+
+                  if Project_Lists.Table (Current).Project = Project then
+                     return;
+                  end if;
+
+                  exit when Project_Lists.Table (Current).Next =
+                    Empty_Project_List;
+                  Current := Project_Lists.Table (Current).Next;
+               end loop;
+
+               --  This project has never been visited, add it
+               --  to the list.
+
+               Project_Lists.Increment_Last;
+               Project_Lists.Table (Current).Next := Project_Lists.Last;
+               Project_Lists.Table (Project_Lists.Last) :=
+                 (Project => Project, Next => Empty_Project_List);
+            end;
+         end if;
+
+         declare
+            Current    : String_List_Id := Data.Source_Dirs;
+            The_String : String_Element;
+
+         begin
+            --  Call action with the name of every source directorie
+
+            while Current /= Nil_String loop
+               The_String := String_Elements.Table (Current);
+               String_To_Name_Buffer (The_String.Value);
+               Action (Name_Buffer (1 .. Name_Len));
+               Current := The_String.Next;
+            end loop;
+         end;
+
+         --  If we are modifying a project, visit it
+
+         if Data.Modifies /= No_Project then
+            Add (Data.Modifies);
+         end if;
+
+         --  And visit all imported projects
+
+         while List /= Empty_Project_List loop
+            Add (Project_Lists.Table (List).Project);
+            List := Project_Lists.Table (List).Next;
+         end loop;
+      end Add;
+
+   --  Start of processing for For_All_Source_Dirs
+
+   begin
+      --  Visit this project, and its imported projects recursively
+
+      Add (Project);
+   end For_All_Source_Dirs;
+
+   -------------------
+   -- Get_Reference --
+   -------------------
+
+   procedure Get_Reference
+     (Source_File_Name : String;
+      Project          : out Project_Id;
+      Path             : out Name_Id)
+   is
+   begin
+      if Current_Verbosity > Default then
+         Write_Str ("Getting Reference_Of (""");
+         Write_Str (Source_File_Name);
+         Write_Str (""") ... ");
+      end if;
+
+      declare
+         Original_Name : String := Source_File_Name;
+         Unit          : Unit_Data;
+
+      begin
+         Canonical_Case_File_Name (Original_Name);
+
+         for Id in Units.First .. Units.Last loop
+            Unit := Units.Table (Id);
+
+            if (Unit.File_Names (Specification).Name /= No_Name
+                 and then
+                   Namet.Get_Name_String
+                     (Unit.File_Names (Specification).Name) = Original_Name)
+              or else (Unit.File_Names (Specification).Path /= No_Name
+                         and then
+                           Namet.Get_Name_String
+                           (Unit.File_Names (Specification).Path) =
+                                                              Original_Name)
+            then
+               Project := Unit.File_Names (Specification).Project;
+               Path := Unit.File_Names (Specification).Path;
+
+               if Current_Verbosity > Default then
+                  Write_Str ("Done: Specification.");
+                  Write_Eol;
+               end if;
+
+               return;
+
+            elsif (Unit.File_Names (Body_Part).Name /= No_Name
+                    and then
+                      Namet.Get_Name_String
+                        (Unit.File_Names (Body_Part).Name) = Original_Name)
+              or else (Unit.File_Names (Body_Part).Path /= No_Name
+                         and then Namet.Get_Name_String
+                                    (Unit.File_Names (Body_Part).Path) =
+                                                             Original_Name)
+            then
+               Project := Unit.File_Names (Body_Part).Project;
+               Path := Unit.File_Names (Body_Part).Path;
+
+               if Current_Verbosity > Default then
+                  Write_Str ("Done: Body.");
+                  Write_Eol;
+               end if;
+
+               return;
+            end if;
+
+         end loop;
+      end;
+
+      Project := No_Project;
+      Path    := No_Name;
+
+      if Current_Verbosity > Default then
+         Write_Str ("Cannot be found.");
+         Write_Eol;
+      end if;
+   end Get_Reference;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+      Global : constant String := "global_configuration_pragmas";
+      Local  : constant String :=  "local_configuration_pragmas";
+   begin
+      --  Put the standard GNAT naming scheme in the Namings table
+
+      Namings.Increment_Last;
+      Namings.Table (Namings.Last) := Standard_Naming_Data;
+      Name_Len := Global'Length;
+      Name_Buffer (1 .. Name_Len) := Global;
+      Global_Configuration_Pragmas := Name_Find;
+      Name_Len := Local'Length;
+      Name_Buffer (1 .. Name_Len) := Local;
+      Local_Configuration_Pragmas := Name_Find;
+   end Initialize;
+
+   ------------------------------------
+   -- Path_Name_Of_Library_Unit_Body --
+   ------------------------------------
+
+   function Path_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return String
+   is
+      Data : constant Project_Data := Projects.Table (Project);
+      Original_Name : String := Name;
+
+      Extended_Spec_Name : String :=
+                             Name & Namet.Get_Name_String
+                                     (Data.Naming.Specification_Append);
+      Extended_Body_Name : String :=
+                             Name & Namet.Get_Name_String
+                                     (Data.Naming.Body_Append);
+
+      First   : Unit_Id := Units.First;
+      Current : Unit_Id;
+      Unit    : Unit_Data;
+
+   begin
+      Canonical_Case_File_Name (Original_Name);
+      Canonical_Case_File_Name (Extended_Spec_Name);
+      Canonical_Case_File_Name (Extended_Spec_Name);
+
+      if Current_Verbosity = High then
+         Write_Str  ("Looking for path name of """);
+         Write_Str  (Name);
+         Write_Char ('"');
+         Write_Eol;
+         Write_Str  ("   Extended Spec Name = """);
+         Write_Str  (Extended_Spec_Name);
+         Write_Char ('"');
+         Write_Eol;
+         Write_Str  ("   Extended Body Name = """);
+         Write_Str  (Extended_Body_Name);
+         Write_Char ('"');
+         Write_Eol;
+      end if;
+
+      while First <= Units.Last
+        and then Units.Table (First).File_Names (Body_Part).Project /= Project
+      loop
+         First := First + 1;
+      end loop;
+
+      Current := First;
+      while Current <= Units.Last loop
+         Unit := Units.Table (Current);
+
+         if Unit.File_Names (Body_Part).Project = Project
+           and then Unit.File_Names (Body_Part).Name /= No_Name
+         then
+            declare
+               Current_Name : constant String :=
+                 Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
+            begin
+               if Current_Verbosity = High then
+                  Write_Str  ("   Comparing with """);
+                  Write_Str  (Current_Name);
+                  Write_Char ('"');
+                  Write_Eol;
+               end if;
+
+               if Current_Name = Original_Name then
+                  if Current_Verbosity = High then
+                     Write_Line ("   OK");
+                  end if;
+
+                  return Body_Path_Name_Of (Current);
+
+               elsif Current_Name = Extended_Body_Name then
+                  if Current_Verbosity = High then
+                     Write_Line ("   OK");
+                  end if;
+
+                  return Body_Path_Name_Of (Current);
+
+               else
+                  if Current_Verbosity = High then
+                     Write_Line ("   not good");
+                  end if;
+               end if;
+            end;
+
+         elsif Unit.File_Names (Specification).Name /= No_Name then
+            declare
+               Current_Name : constant String :=
+                                Namet.Get_Name_String
+                                  (Unit.File_Names (Specification).Name);
+
+            begin
+               if Current_Verbosity = High then
+                  Write_Str  ("   Comparing with """);
+                  Write_Str  (Current_Name);
+                  Write_Char ('"');
+                  Write_Eol;
+               end if;
+
+               if Current_Name = Original_Name then
+                  if Current_Verbosity = High then
+                     Write_Line ("   OK");
+                  end if;
+
+                  return Spec_Path_Name_Of (Current);
+
+               elsif Current_Name = Extended_Spec_Name then
+
+                  if Current_Verbosity = High then
+                     Write_Line ("   OK");
+                  end if;
+
+                  return Spec_Path_Name_Of (Current);
+
+               else
+                  if Current_Verbosity = High then
+                     Write_Line ("   not good");
+                  end if;
+               end if;
+            end;
+         end if;
+         Current := Current + 1;
+      end loop;
+
+      return "";
+   end Path_Name_Of_Library_Unit_Body;
+
+   -------------------
+   -- Print_Sources --
+   -------------------
+
+   procedure Print_Sources is
+      Unit : Unit_Data;
+
+   begin
+      Write_Line ("List of Sources:");
+
+      for Id in Units.First .. Units.Last loop
+         Unit := Units.Table (Id);
+         Write_Str  ("   ");
+         Write_Line (Namet.Get_Name_String (Unit.Name));
+
+         if Unit.File_Names (Specification).Name /= No_Name then
+            if Unit.File_Names (Specification).Project = No_Project then
+               Write_Line ("   No project");
+
+            else
+               Write_Str  ("   Project: ");
+               Get_Name_String
+                 (Projects.Table
+                   (Unit.File_Names (Specification).Project).Path_Name);
+               Write_Line (Name_Buffer (1 .. Name_Len));
+            end if;
+
+            Write_Str  ("      spec: ");
+            Write_Line
+              (Namet.Get_Name_String
+               (Unit.File_Names (Specification).Name));
+         end if;
+
+         if Unit.File_Names (Body_Part).Name /= No_Name then
+            if Unit.File_Names (Body_Part).Project = No_Project then
+               Write_Line ("   No project");
+
+            else
+               Write_Str  ("   Project: ");
+               Get_Name_String
+                 (Projects.Table
+                   (Unit.File_Names (Body_Part).Project).Path_Name);
+               Write_Line (Name_Buffer (1 .. Name_Len));
+            end if;
+
+            Write_Str  ("      body: ");
+            Write_Line
+              (Namet.Get_Name_String
+               (Unit.File_Names (Body_Part).Name));
+         end if;
+
+      end loop;
+
+      Write_Line ("end of List of Sources.");
+   end Print_Sources;
+
+   -----------------------
+   -- Spec_Path_Name_Of --
+   -----------------------
+
+   function Spec_Path_Name_Of (Unit : Unit_Id) return String is
+      Data : Unit_Data := Units.Table (Unit);
+
+   begin
+      if Data.File_Names (Specification).Path = No_Name then
+         declare
+            Current_Source : String_List_Id :=
+              Projects.Table (Data.File_Names (Specification).Project).Sources;
+            Path : GNAT.OS_Lib.String_Access;
+
+         begin
+            Data.File_Names (Specification).Path :=
+              Data.File_Names (Specification).Name;
+
+            while Current_Source /= Nil_String loop
+               String_To_Name_Buffer
+                 (String_Elements.Table (Current_Source).Value);
+               Path := Locate_Regular_File
+                 (Namet.Get_Name_String
+                  (Data.File_Names (Specification).Name),
+                  Name_Buffer (1 .. Name_Len));
+
+               if Path /= null then
+                  Name_Len := Path'Length;
+                  Name_Buffer (1 .. Name_Len) := Path.all;
+                  Data.File_Names (Specification).Path := Name_Enter;
+                  exit;
+               else
+                  Current_Source :=
+                    String_Elements.Table (Current_Source).Next;
+               end if;
+            end loop;
+
+            Units.Table (Unit) := Data;
+         end;
+      end if;
+
+      return Namet.Get_Name_String (Data.File_Names (Specification).Path);
+   end Spec_Path_Name_Of;
+
+end Prj.Env;
diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads
new file mode 100644
index 0000000..272c559
--- /dev/null
+++ b/gcc/ada/prj-env.ads
@@ -0,0 +1,99 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E N V                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package implements services for Project-aware tools, related
+--  to the environment (gnat.adc, ADA_INCLUDE_PATH, ADA_OBJECTS_PATH)
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Prj.Env is
+
+   procedure Initialize;
+   --  Put Standard_Naming_Data into Namings table (called by Prj.Initialize)
+
+   procedure Print_Sources;
+   --  Output the list of sources, after Project files have been scanned
+
+   procedure Create_Config_Pragmas_File
+     (For_Project  : Project_Id;
+      Main_Project : Project_Id);
+   --  If there needs to have SFN pragmas, either for non standard naming
+   --  schemes or for individual units, or if Global_Configuration_Pragmas
+   --  has been specified in package gnatmake of the main project, or if
+   --  Local_Configuration_Pragmas has been specified in package Compiler
+   --  of the main project, build (if needed) a temporary file that contains
+   --  all configuration pragmas, and specify the configuration pragmas file
+   --  in the project data.
+
+   function Ada_Include_Path (Project : Project_Id) return String_Access;
+   --  Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute
+   --  it and cache it.
+
+   function Ada_Objects_Path
+     (Project             : Project_Id;
+      Including_Libraries : Boolean := True)
+      return                String_Access;
+   --  Get the ADA_OBJECTS_PATH of a Project file. For the first call, compute
+   --  it and cache it. When Including_Libraries is False, do not include the
+   --  object directories of the library projects, and do not cache the result.
+
+   function Path_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the Path of a library unit.
+
+   function File_Name_Of_Library_Unit_Body
+     (Name    : String;
+      Project : Project_Id)
+      return    String;
+   --  Returns the file name of a library unit, in canonical case. Name may or
+   --  may not have an extension (corresponding to the naming scheme of the
+   --  project). If there is no body with this name, but there is a spec, the
+   --  name of the spec is returned. If neither a body or a spec can be found,
+   --  return an empty string.
+
+   procedure Get_Reference
+     (Source_File_Name : String;
+      Project          : out Project_Id;
+      Path             : out Name_Id);
+   --  Returns the project of a source.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Source_Dirs (Project : Project_Id);
+   --  Iterate through all the source directories of a project,
+   --  including those of imported or modified projects.
+
+   generic
+      with procedure Action (Path : String);
+   procedure For_All_Object_Dirs (Project : Project_Id);
+   --  Iterate through all the object directories of a project,
+   --  including those of imported or modified projects.
+
+end Prj.Env;
diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb
new file mode 100644
index 0000000..b6f6ab8
--- /dev/null
+++ b/gcc/ada/prj-ext.adb
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.5 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with GNAT.HTable;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Prj.Com;     use Prj.Com;
+with Stringt;     use Stringt;
+with Types;       use Types;
+
+package body Prj.Ext is
+
+   package Htable is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => String_Id,
+      No_Element => No_String,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add
+     (External_Name : String;
+      Value         : String)
+   is
+      The_Key   : Name_Id;
+      The_Value : String_Id;
+
+   begin
+      Start_String;
+      Store_String_Chars (Value);
+      The_Value := End_String;
+      Name_Len := External_Name'Length;
+      Name_Buffer (1 .. Name_Len) := External_Name;
+      The_Key := Name_Find;
+      Htable.Set (The_Key, The_Value);
+   end Add;
+
+   -----------
+   -- Check --
+   -----------
+
+   function Check (Declaration : String) return Boolean is
+   begin
+      for Equal_Pos in Declaration'Range loop
+
+         if Declaration (Equal_Pos) = '=' then
+            exit when Equal_Pos = Declaration'First;
+            exit when Equal_Pos = Declaration'Last;
+            Add
+              (External_Name =>
+                 Declaration (Declaration'First .. Equal_Pos - 1),
+               Value =>
+                 Declaration (Equal_Pos + 1 .. Declaration'Last));
+            return True;
+         end if;
+
+      end loop;
+
+      return False;
+   end Check;
+
+   --------------
+   -- Value_Of --
+   --------------
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id
+   is
+      The_Value : String_Id;
+
+   begin
+      The_Value := Htable.Get (External_Name);
+
+      if The_Value /= No_String then
+         return The_Value;
+      end if;
+
+      --  Find if it is an environment.
+      --  If it is, put the value in the hash table.
+
+      declare
+         Env_Value : constant String_Access :=
+           Getenv (Get_Name_String (External_Name));
+
+      begin
+         if Env_Value /= null and then Env_Value'Length > 0 then
+            Start_String;
+            Store_String_Chars (Env_Value.all);
+            The_Value := End_String;
+            Htable.Set (External_Name, The_Value);
+            return The_Value;
+
+         else
+            return With_Default;
+         end if;
+      end;
+   end Value_Of;
+
+end Prj.Ext;
diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads
new file mode 100644
index 0000000..4c12b78
--- /dev/null
+++ b/gcc/ada/prj-ext.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . E X T                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Set, Get and cache External reference, to be used as External functions
+--  in project files.
+
+with Types; use Types;
+
+package Prj.Ext is
+
+   procedure Add
+     (External_Name : String;
+      Value         : String);
+   --  Add an external reference (or modify an existing one).
+
+   function Value_Of
+     (External_Name : Name_Id;
+      With_Default  : String_Id := No_String)
+      return          String_Id;
+   --  Get the value of an external reference, and cache it for future uses.
+
+   function Check (Declaration : String) return Boolean;
+   --  Check that an external declaration <external>=<value> is correct.
+   --  If it is correct, the external reference is Added.
+
+end Prj.Ext;
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
new file mode 100644
index 0000000..66031878d2
--- /dev/null
+++ b/gcc/ada/prj-nmsc.adb
@@ -0,0 +1,2236 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . N M S C                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.25 $
+--                                                                          --
+--          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Strings;             use Ada.Strings;
+with Ada.Strings.Fixed;       use Ada.Strings.Fixed;
+with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
+with Errout;                  use Errout;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib;             use GNAT.OS_Lib;
+with Namet;                   use Namet;
+with Osint;                   use Osint;
+with Output;                  use Output;
+with Prj.Com;                 use Prj.Com;
+with Prj.Util;                use Prj.Util;
+with Snames;                  use Snames;
+with Stringt;                 use Stringt;
+with Types;                   use Types;
+
+package body Prj.Nmsc is
+
+   Dir_Sep      : Character renames GNAT.OS_Lib.Directory_Separator;
+
+   Error_Report : Put_Line_Access := null;
+
+   procedure Check_Naming_Scheme (Naming : Naming_Data);
+   --  Check that the package Naming is correct.
+
+   procedure Check_Naming_Scheme
+     (Name : Name_Id;
+      Unit : out Name_Id);
+   --  Check that a name is a valid unit name.
+
+   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+   --  Output an error message.
+   --  If Error_Report is null, simply call Errout.Error_Msg.
+   --  Otherwise, disregard Flag_Location and use Error_Report.
+
+   function Get_Name_String (S : String_Id) return String;
+   --  Get the string from a String_Id
+
+   procedure Get_Unit
+     (File_Name    : Name_Id;
+      Naming       : Naming_Data;
+      Unit_Name    : out Name_Id;
+      Unit_Kind    : out Spec_Or_Body;
+      Needs_Pragma : out Boolean);
+   --  Find out, from a file name, the unit name, the unit kind
+   --  and if a specific SFN pragma is needed.
+   --  If the file name corresponds to no unit, then Unit_Name
+   --  will be No_Name.
+
+   function Is_Illegal_Append (This : String) return Boolean;
+   --  Returns True if the string This cannot be used as
+   --  a Specification_Append, a Body_Append or a Separate_Append.
+
+   procedure Record_Source
+     (File_Name        : Name_Id;
+      Path_Name        : Name_Id;
+      Project          : Project_Id;
+      Data             : in out Project_Data;
+      Error_If_Invalid : Boolean;
+      Location         : Source_Ptr;
+      Current_Source   : in out String_List_Id);
+   --  Put a unit in the list of units of a project, if the file name
+   --  corresponds to a valid unit name.
+   --  If it does not correspond to a valid unit name, report an error
+   --  only if Error_If_Invalid is true.
+
+   procedure Show_Source_Dirs (Project : Project_Id);
+   --  List all the source directories of a project.
+
+   function Locate_Directory
+     (Name   : Name_Id;
+      Parent : Name_Id)
+     return   Name_Id;
+   --  Locate a directory.
+   --  Returns No_Name if directory does not exist.
+
+   function Path_Name_Of
+     (File_Name : String_Id;
+      Directory : Name_Id)
+     return      String;
+   --  Returns the path name of a (non project) file.
+   --  Returns an empty string if file cannot be found.
+
+   function Path_Name_Of
+     (File_Name : String_Id;
+      Directory : String_Id)
+     return      String;
+   --  Same as above except that Directory is a String_Id instead
+   --  of a Name_Id.
+
+   -------------------------
+   -- Check_Naming_Scheme --
+   -------------------------
+
+   procedure Check_Naming_Scheme (Naming : Naming_Data) is
+   begin
+      --  Only check if we are not using the standard naming scheme
+
+      if Naming /= Standard_Naming_Data then
+         declare
+            Dot_Replacement      : constant String :=
+                                     Get_Name_String
+                                       (Naming.Dot_Replacement);
+            Specification_Append : constant String :=
+                                     Get_Name_String
+                                       (Naming.Specification_Append);
+            Body_Append          : constant String :=
+                                     Get_Name_String
+                                       (Naming.Body_Append);
+            Separate_Append      : constant String :=
+                                     Get_Name_String
+                                       (Naming.Separate_Append);
+
+         begin
+            --  Dot_Replacement cannot
+            --   - be empty
+            --   - start or end with an alphanumeric
+            --   - be a single '_'
+            --   - start with an '_' followed by an alphanumeric
+            --   - contain a '.' except if it is "."
+
+            if Dot_Replacement'Length = 0
+              or else Is_Alphanumeric
+                        (Dot_Replacement (Dot_Replacement'First))
+              or else Is_Alphanumeric
+                        (Dot_Replacement (Dot_Replacement'Last))
+              or else (Dot_Replacement (Dot_Replacement'First) = '_'
+                        and then
+                        (Dot_Replacement'Length = 1
+                          or else
+                           Is_Alphanumeric
+                             (Dot_Replacement (Dot_Replacement'First + 1))))
+              or else (Dot_Replacement'Length > 1
+                         and then
+                           Index (Source => Dot_Replacement,
+                                  Pattern => ".") /= 0)
+            then
+               Error_Msg
+                 ('"' & Dot_Replacement &
+                  """ is illegal for Dot_Replacement.",
+                  Naming.Dot_Repl_Loc);
+            end if;
+
+            --  Appends cannot
+            --   - be empty
+            --   - start with an alphanumeric
+            --   - start with an '_' followed by an alphanumeric
+
+            if Is_Illegal_Append (Specification_Append) then
+               Error_Msg
+                 ('"' & Specification_Append &
+                  """ is illegal for Specification_Append.",
+                  Naming.Spec_Append_Loc);
+            end if;
+
+            if Is_Illegal_Append (Body_Append) then
+               Error_Msg
+                 ('"' & Body_Append &
+                  """ is illegal for Body_Append.",
+                  Naming.Body_Append_Loc);
+            end if;
+
+            if Body_Append /= Separate_Append then
+               if Is_Illegal_Append (Separate_Append) then
+                  Error_Msg
+                    ('"' & Separate_Append &
+                     """ is illegal for Separate_Append.",
+                     Naming.Sep_Append_Loc);
+               end if;
+            end if;
+
+            --  Specification_Append cannot have the same termination as
+            --  Body_Append or Separate_Append
+
+            if Specification_Append'Length >= Body_Append'Length
+              and then
+                Body_Append (Body_Append'Last -
+                             Specification_Append'Length + 1 ..
+                             Body_Append'Last) = Specification_Append
+            then
+               Error_Msg
+                 ("Body_Append (""" &
+                  Body_Append &
+                  """) cannot end with" &
+                  " Specification_Append (""" &
+                  Specification_Append & """).",
+                  Naming.Body_Append_Loc);
+            end if;
+
+            if Specification_Append'Length >= Separate_Append'Length
+              and then
+                Separate_Append
+                  (Separate_Append'Last - Specification_Append'Length + 1
+                    ..
+                   Separate_Append'Last) = Specification_Append
+            then
+               Error_Msg
+                 ("Separate_Append (""" &
+                  Separate_Append &
+                  """) cannot end with" &
+                  " Specification_Append (""" &
+                  Specification_Append & """).",
+                  Naming.Sep_Append_Loc);
+            end if;
+         end;
+      end if;
+   end Check_Naming_Scheme;
+
+   procedure Check_Naming_Scheme
+     (Name : Name_Id;
+      Unit : out Name_Id)
+   is
+      The_Name        : String := Get_Name_String (Name);
+      Need_Letter     : Boolean := True;
+      Last_Underscore : Boolean := False;
+      OK              : Boolean := The_Name'Length > 0;
+
+   begin
+      for Index in The_Name'Range loop
+         if Need_Letter then
+
+            --  We need a letter (at the beginning, and following a dot),
+            --  but we don't have one.
+
+            if Is_Letter (The_Name (Index)) then
+               Need_Letter := False;
+
+            else
+               OK := False;
+
+               if Current_Verbosity = High then
+                  Write_Int  (Types.Int (Index));
+                  Write_Str  (": '");
+                  Write_Char (The_Name (Index));
+                  Write_Line ("' is not a letter.");
+               end if;
+
+               exit;
+            end if;
+
+         elsif Last_Underscore
+           and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
+         then
+            --  Two underscores are illegal, and a dot cannot follow
+            --  an underscore.
+
+            OK := False;
+
+            if Current_Verbosity = High then
+               Write_Int  (Types.Int (Index));
+               Write_Str  (": '");
+               Write_Char (The_Name (Index));
+               Write_Line ("' is illegal here.");
+            end if;
+
+            exit;
+
+         elsif The_Name (Index) = '.' then
+
+            --  We need a letter after a dot
+
+            Need_Letter := True;
+
+         elsif The_Name (Index) = '_' then
+            Last_Underscore := True;
+
+         else
+            --  We need an letter or a digit
+
+            Last_Underscore := False;
+
+            if not Is_Alphanumeric (The_Name (Index)) then
+               OK := False;
+
+               if Current_Verbosity = High then
+                  Write_Int  (Types.Int (Index));
+                  Write_Str  (": '");
+                  Write_Char (The_Name (Index));
+                  Write_Line ("' is not alphanumeric.");
+               end if;
+
+               exit;
+            end if;
+         end if;
+      end loop;
+
+      --  We cannot end with an underscore or a dot
+
+      OK := OK and then not Need_Letter and then not Last_Underscore;
+
+      if OK then
+         Unit := Name;
+      else
+         --  We signal a problem with No_Name
+
+         Unit := No_Name;
+      end if;
+   end Check_Naming_Scheme;
+
+   procedure Check_Naming_Scheme
+     (Project      : Project_Id;
+      Report_Error : Put_Line_Access)
+   is
+      Last_Source_Dir   : String_List_Id  := Nil_String;
+      Data              : Project_Data    := Projects.Table (Project);
+
+      procedure Check_Unit_Names (List : Array_Element_Id);
+      --  Check that a list of unit names contains only valid names.
+
+      procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr);
+      --  Find one or several source directories, and add them
+      --  to the list of source directories of the project.
+
+      procedure Find_Sources;
+      --  Find all the sources in all of the source directories
+      --  of a project.
+
+      procedure Get_Path_Name_And_Record_Source
+        (File_Name        : String;
+         Location         : Source_Ptr;
+         Current_Source   : in out String_List_Id);
+      --  Find the path name of a source in the source directories and
+      --  record the source, if found.
+
+      procedure Get_Sources_From_File
+        (Path     : String;
+         Location : Source_Ptr);
+      --  Get the sources of a project from a text file
+
+      ----------------------
+      -- Check_Unit_Names --
+      ----------------------
+
+      procedure Check_Unit_Names (List : Array_Element_Id) is
+         Current   : Array_Element_Id := List;
+         Element   : Array_Element;
+         Unit_Name : Name_Id;
+
+      begin
+         --  Loop through elements of the string list
+
+         while Current /= No_Array_Element loop
+            Element := Array_Elements.Table (Current);
+
+            --  Check that it contains a valid unit name
+
+            Check_Naming_Scheme (Element.Index, Unit_Name);
+
+            if Unit_Name = No_Name then
+               Error_Msg_Name_1 := Element.Index;
+               Error_Msg
+                 ("{ is not a valid unit name.",
+                  Element.Value.Location);
+
+            else
+
+               if Current_Verbosity = High then
+                  Write_Str ("   Body_Part (""");
+                  Write_Str (Get_Name_String (Unit_Name));
+                  Write_Line (""")");
+               end if;
+
+               Element.Index := Unit_Name;
+               Array_Elements.Table (Current) := Element;
+            end if;
+
+            Current := Element.Next;
+         end loop;
+      end Check_Unit_Names;
+
+      ----------------------
+      -- Find_Source_Dirs --
+      ----------------------
+
+      procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr) is
+
+         Directory    : String (1 .. Integer (String_Length (From)));
+         Directory_Id : Name_Id;
+         Element      : String_Element;
+
+         procedure Recursive_Find_Dirs (Path : String_Id);
+         --  Find all the subdirectories (recursively) of Path
+         --  and add them to the list of source directories
+         --  of the project.
+
+         -------------------------
+         -- Recursive_Find_Dirs --
+         -------------------------
+
+         procedure Recursive_Find_Dirs (Path : String_Id) is
+            Dir      : Dir_Type;
+            Name     : String (1 .. 250);
+            Last     : Natural;
+            The_Path : String := Get_Name_String (Path) & Dir_Sep;
+
+            The_Path_Last : Positive := The_Path'Last;
+
+         begin
+            if The_Path'Length > 1
+              and then
+                (The_Path (The_Path_Last - 1) = Dir_Sep
+                   or else The_Path (The_Path_Last - 1) = '/')
+            then
+               The_Path_Last := The_Path_Last - 1;
+            end if;
+
+            if Current_Verbosity = High then
+               Write_Str  ("   ");
+               Write_Line (The_Path (The_Path'First .. The_Path_Last));
+            end if;
+
+            String_Elements.Increment_Last;
+            Element :=
+              (Value    => Path,
+               Location => No_Location,
+               Next     => Nil_String);
+
+            --  Case of first source directory
+
+            if Last_Source_Dir = Nil_String then
+               Data.Source_Dirs := String_Elements.Last;
+
+            --  Here we already have source directories.
+
+            else
+               --  Link the previous last to the new one
+
+               String_Elements.Table (Last_Source_Dir).Next :=
+                 String_Elements.Last;
+            end if;
+
+            --  And register this source directory as the new last
+
+            Last_Source_Dir  := String_Elements.Last;
+            String_Elements.Table (Last_Source_Dir) := Element;
+
+            --  Now look for subdirectories
+
+            Open (Dir, The_Path (The_Path'First .. The_Path_Last));
+
+            loop
+               Read (Dir, Name, Last);
+               exit when Last = 0;
+
+               if Current_Verbosity = High then
+                  Write_Str  ("   Checking ");
+                  Write_Line (Name (1 .. Last));
+               end if;
+
+               if Name (1 .. Last) /= "."
+                 and then Name (1 .. Last) /= ".."
+               then
+                  --  Avoid . and ..
+
+                  declare
+                     Path_Name : constant String :=
+                                   The_Path (The_Path'First .. The_Path_Last) &
+                                   Name (1 .. Last);
+
+                  begin
+                     if Is_Directory (Path_Name) then
+
+                        --  We have found a new subdirectory,
+                        --  register it and find its own subdirectories.
+
+                        Start_String;
+                        Store_String_Chars (Path_Name);
+                        Recursive_Find_Dirs (End_String);
+                     end if;
+                  end;
+               end if;
+            end loop;
+
+            Close (Dir);
+
+         exception
+            when Directory_Error =>
+               null;
+         end Recursive_Find_Dirs;
+
+         --  Start of processing for Find_Source_Dirs
+
+      begin
+         if Current_Verbosity = High then
+            Write_Str ("Find_Source_Dirs (""");
+         end if;
+
+         String_To_Name_Buffer (From);
+         Directory    := Name_Buffer (1 .. Name_Len);
+         Directory_Id := Name_Find;
+
+         if Current_Verbosity = High then
+            Write_Str (Directory);
+            Write_Line (""")");
+         end if;
+
+         --  First, check if we are looking for a directory tree,
+         --  indicated by "/**" at the end.
+
+         if Directory'Length >= 3
+           and then Directory (Directory'Last - 1 .. Directory'Last) = "**"
+           and then (Directory (Directory'Last - 2) = '/'
+                       or else
+                     Directory (Directory'Last - 2) = Dir_Sep)
+         then
+            Name_Len := Directory'Length - 3;
+
+            if Name_Len = 0 then
+               --  This is the case of "/**": all directories
+               --  in the file system.
+
+               Name_Len := 1;
+               Name_Buffer (1) := Directory (Directory'First);
+
+            else
+               Name_Buffer (1 .. Name_Len) :=
+                 Directory (Directory'First .. Directory'Last - 3);
+            end if;
+
+            if Current_Verbosity = High then
+               Write_Str ("Looking for all subdirectories of """);
+               Write_Str (Name_Buffer (1 .. Name_Len));
+               Write_Line ("""");
+            end if;
+
+            declare
+               Base_Dir : constant Name_Id := Name_Find;
+               Root     : constant Name_Id :=
+                            Locate_Directory (Base_Dir, Data.Directory);
+
+            begin
+               if Root = No_Name then
+                  Error_Msg_Name_1 := Base_Dir;
+                  if Location = No_Location then
+                     Error_Msg ("{ is not a valid directory.", Data.Location);
+                  else
+                     Error_Msg ("{ is not a valid directory.", Location);
+                  end if;
+
+               else
+                  --  We have an existing directory,
+                  --  we register it and all of its subdirectories.
+
+                  if Current_Verbosity = High then
+                     Write_Line ("Looking for source directories:");
+                  end if;
+
+                  Start_String;
+                  Store_String_Chars (Get_Name_String (Root));
+                  Recursive_Find_Dirs (End_String);
+
+                  if Current_Verbosity = High then
+                     Write_Line ("End of looking for source directories.");
+                  end if;
+               end if;
+            end;
+
+         --  We have a single directory
+
+         else
+            declare
+               Path_Name : constant Name_Id :=
+                 Locate_Directory (Directory_Id, Data.Directory);
+
+            begin
+               if Path_Name = No_Name then
+                  Error_Msg_Name_1 := Directory_Id;
+                  if Location = No_Location then
+                     Error_Msg ("{ is not a valid directory", Data.Location);
+                  else
+                     Error_Msg ("{ is not a valid directory", Location);
+                  end if;
+               else
+
+                  --  As it is an existing directory, we add it to
+                  --  the list of directories.
+
+                  String_Elements.Increment_Last;
+                  Start_String;
+                  Store_String_Chars (Get_Name_String (Path_Name));
+                  Element.Value := End_String;
+
+                  if Last_Source_Dir = Nil_String then
+
+                     --  This is the first source directory
+
+                     Data.Source_Dirs := String_Elements.Last;
+
+                  else
+                     --  We already have source directories,
+                     --  link the previous last to the new one.
+
+                     String_Elements.Table (Last_Source_Dir).Next :=
+                       String_Elements.Last;
+                  end if;
+
+                  --  And register this source directory as the new last
+
+                  Last_Source_Dir := String_Elements.Last;
+                  String_Elements.Table (Last_Source_Dir) := Element;
+               end if;
+            end;
+         end if;
+      end Find_Source_Dirs;
+
+      ------------------
+      -- Find_Sources --
+      ------------------
+
+      procedure Find_Sources is
+         Source_Dir     : String_List_Id := Data.Source_Dirs;
+         Element        : String_Element;
+         Dir            : Dir_Type;
+         Current_Source : String_List_Id := Nil_String;
+
+      begin
+         if Current_Verbosity = High then
+            Write_Line ("Looking for sources:");
+         end if;
+
+         --  For each subdirectory
+
+         while Source_Dir /= Nil_String loop
+            begin
+               Element := String_Elements.Table (Source_Dir);
+               if Element.Value /= No_String then
+                  declare
+                     Source_Directory : String
+                       (1 .. Integer (String_Length (Element.Value)));
+                  begin
+                     String_To_Name_Buffer (Element.Value);
+                     Source_Directory := Name_Buffer (1 .. Name_Len);
+                     if Current_Verbosity = High then
+                        Write_Str ("Source_Dir = ");
+                        Write_Line (Source_Directory);
+                     end if;
+
+                     --  We look to every entry in the source directory
+
+                     Open (Dir, Source_Directory);
+
+                     loop
+                        Read (Dir, Name_Buffer, Name_Len);
+
+                        if Current_Verbosity = High then
+                           Write_Str  ("   Checking ");
+                           Write_Line (Name_Buffer (1 .. Name_Len));
+                        end if;
+
+                        exit when Name_Len = 0;
+
+                        declare
+                           Path_Access : constant GNAT.OS_Lib.String_Access :=
+                                           Locate_Regular_File
+                                             (Name_Buffer (1 .. Name_Len),
+                                              Source_Directory);
+
+                           File_Name : Name_Id;
+                           Path_Name : Name_Id;
+
+                        begin
+                           --  If it is a regular file
+
+                           if Path_Access /= null then
+                              File_Name := Name_Find;
+                              Name_Len := Path_Access'Length;
+                              Name_Buffer (1 .. Name_Len) := Path_Access.all;
+                              Path_Name := Name_Find;
+
+                              --  We attempt to register it as a source.
+                              --  However, there is no error if the file
+                              --  does not contain a valid source (as
+                              --  indicated by Error_If_Invalid => False).
+                              --  But there is an error if we have a
+                              --  duplicate unit name.
+
+                              Record_Source
+                                (File_Name        => File_Name,
+                                 Path_Name        => Path_Name,
+                                 Project          => Project,
+                                 Data             => Data,
+                                 Error_If_Invalid => False,
+                                 Location         => No_Location,
+                                 Current_Source   => Current_Source);
+
+                           else
+                              if Current_Verbosity = High then
+                                 Write_Line
+                                   ("      Not a regular file.");
+                              end if;
+                           end if;
+                        end;
+                     end loop;
+
+                     Close (Dir);
+                  end;
+               end if;
+
+            exception
+               when Directory_Error =>
+                  null;
+            end;
+
+            Source_Dir := Element.Next;
+         end loop;
+
+         if Current_Verbosity = High then
+            Write_Line ("end Looking for sources.");
+         end if;
+
+         --  If we have looked for sources and found none, then
+         --  it is an error. If a project is not supposed to contain
+         --  any source, then we never call Find_Sources.
+
+         if Current_Source = Nil_String then
+            Error_Msg ("there are no sources in this project",
+                       Data.Location);
+         end if;
+      end Find_Sources;
+
+      -------------------------------------
+      -- Get_Path_Name_And_Record_Source --
+      -------------------------------------
+
+      procedure Get_Path_Name_And_Record_Source
+        (File_Name        : String;
+         Location         : Source_Ptr;
+         Current_Source   : in out String_List_Id)
+      is
+         Source_Dir : String_List_Id := Data.Source_Dirs;
+         Element    : String_Element;
+         Path_Name  : GNAT.OS_Lib.String_Access;
+         Found      : Boolean := False;
+         File       : Name_Id;
+
+      begin
+         if Current_Verbosity = High then
+            Write_Str  ("   Checking """);
+            Write_Str  (File_Name);
+            Write_Line (""".");
+         end if;
+
+         --  We look in all source directories for this file name
+
+         while Source_Dir /= Nil_String loop
+            Element := String_Elements.Table (Source_Dir);
+
+            if Current_Verbosity = High then
+               Write_Str ("      """);
+               Write_Str (Get_Name_String (Element.Value));
+               Write_Str (""": ");
+            end if;
+
+            Path_Name :=
+              Locate_Regular_File
+              (File_Name,
+               Get_Name_String (Element.Value));
+
+            if Path_Name /= null then
+               if Current_Verbosity = High then
+                  Write_Line ("OK");
+               end if;
+
+               Name_Len := File_Name'Length;
+               Name_Buffer (1 .. Name_Len) := File_Name;
+               File := Name_Find;
+               Name_Len := Path_Name'Length;
+               Name_Buffer (1 .. Name_Len) := Path_Name.all;
+
+               --  We register the source.
+               --  We report an error if the file does not
+               --  correspond to a source.
+
+               Record_Source
+                 (File_Name        => File,
+                  Path_Name        => Name_Find,
+                  Project          => Project,
+                  Data             => Data,
+                  Error_If_Invalid => True,
+                  Location         => Location,
+                  Current_Source   => Current_Source);
+               Found := True;
+               exit;
+
+            else
+               if Current_Verbosity = High then
+                  Write_Line ("No");
+               end if;
+
+               Source_Dir := Element.Next;
+            end if;
+         end loop;
+
+         if not Found then
+            Name_Len := File_Name'Length;
+            Name_Buffer (1 .. Name_Len) := File_Name;
+            Error_Msg_Name_1 := Name_Find;
+            Error_Msg
+              ("cannot find source {", Location);
+         end if;
+      end Get_Path_Name_And_Record_Source;
+
+      ---------------------------
+      -- Get_Sources_From_File --
+      ---------------------------
+
+      procedure Get_Sources_From_File
+        (Path     : String;
+         Location : Source_Ptr)
+      is
+         File           : Prj.Util.Text_File;
+         Line           : String (1 .. 250);
+         Last           : Natural;
+         Current_Source : String_List_Id := Nil_String;
+
+         Nmb_Errors : constant Nat := Errors_Detected;
+
+      begin
+         if Current_Verbosity = High then
+            Write_Str  ("Opening """);
+            Write_Str  (Path);
+            Write_Line (""".");
+         end if;
+
+         --  We open the file
+
+         Prj.Util.Open (File, Path);
+
+         if not Prj.Util.Is_Valid (File) then
+            Error_Msg ("file does not exist", Location);
+         else
+            while not Prj.Util.End_Of_File (File) loop
+               Prj.Util.Get_Line (File, Line, Last);
+
+               --  If the line is not empty and does not start with "--",
+               --  then it must contains a file name.
+
+               if Last /= 0
+                 and then (Last = 1 or else Line (1 .. 2) /= "--")
+               then
+                  Get_Path_Name_And_Record_Source
+                    (File_Name => Line (1 .. Last),
+                     Location => Location,
+                     Current_Source => Current_Source);
+                  exit when Nmb_Errors /= Errors_Detected;
+               end if;
+            end loop;
+
+            Prj.Util.Close (File);
+
+         end if;
+
+         --  We should have found at least one source.
+         --  If not, report an error.
+
+         if Current_Source = Nil_String then
+            Error_Msg ("this project has no source", Location);
+         end if;
+      end Get_Sources_From_File;
+
+      --  Start of processing for Check_Naming_Scheme
+
+   begin
+
+      Error_Report := Report_Error;
+
+      if Current_Verbosity = High then
+         Write_Line ("Starting to look for directories");
+      end if;
+
+      --  Let's check the object directory
+
+      declare
+         Object_Dir : Variable_Value :=
+                        Util.Value_Of (Name_Object_Dir, Data.Decl.Attributes);
+
+      begin
+         pragma Assert (Object_Dir.Kind = Single,
+                        "Object_Dir is not a single string");
+
+         --  We set the object directory to its default
+
+         Data.Object_Directory := Data.Directory;
+
+         if not String_Equal (Object_Dir.Value, Empty_String) then
+
+            String_To_Name_Buffer (Object_Dir.Value);
+
+            if Name_Len = 0 then
+               Error_Msg ("Object_Dir cannot be empty",
+                          Object_Dir.Location);
+
+            else
+               --  We check that the specified object directory
+               --  does exist.
+
+               Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+               declare
+                  Dir_Id : constant Name_Id := Name_Find;
+
+               begin
+                  Data.Object_Directory :=
+                    Locate_Directory (Dir_Id, Data.Directory);
+
+                  if Data.Object_Directory = No_Name then
+                     Error_Msg_Name_1 := Dir_Id;
+                     Error_Msg
+                       ("the object directory { cannot be found",
+                        Data.Location);
+                  end if;
+               end;
+            end if;
+         end if;
+      end;
+
+      if Current_Verbosity = High then
+         if Data.Object_Directory = No_Name then
+            Write_Line ("No object directory");
+         else
+            Write_Str ("Object directory: """);
+            Write_Str (Get_Name_String (Data.Object_Directory));
+            Write_Line ("""");
+         end if;
+      end if;
+
+      --  Let's check the source directories
+
+      declare
+         Source_Dirs : Variable_Value :=
+           Util.Value_Of (Name_Source_Dirs, Data.Decl.Attributes);
+
+      begin
+
+         if Current_Verbosity = High then
+            Write_Line ("Starting to look for source directories");
+         end if;
+
+         pragma Assert (Source_Dirs.Kind = List,
+                          "Source_Dirs is not a list");
+
+         if Source_Dirs.Default then
+
+            --  No Source_Dirs specified: the single source directory
+            --  is the one containing the project file
+
+            String_Elements.Increment_Last;
+            Data.Source_Dirs := String_Elements.Last;
+            Start_String;
+            Store_String_Chars (Get_Name_String (Data.Directory));
+            String_Elements.Table (Data.Source_Dirs) :=
+              (Value    => End_String,
+               Location => No_Location,
+               Next     => Nil_String);
+
+            if Current_Verbosity = High then
+               Write_Line ("(Undefined) Single object directory:");
+               Write_Str ("    """);
+               Write_Str (Get_Name_String (Data.Directory));
+               Write_Line ("""");
+            end if;
+
+         elsif Source_Dirs.Values = Nil_String then
+
+            --  If Source_Dirs is an empty string list, this means
+            --  that this project contains no source.
+
+            if Data.Object_Directory = Data.Directory then
+               Data.Object_Directory := No_Name;
+            end if;
+
+            Data.Source_Dirs := Nil_String;
+
+         else
+            declare
+               Source_Dir : String_List_Id := Source_Dirs.Values;
+               Element    : String_Element;
+
+            begin
+               --  We will find the source directories for each
+               --  element of the list
+
+               while Source_Dir /= Nil_String loop
+                  Element := String_Elements.Table (Source_Dir);
+                  Find_Source_Dirs (Element.Value, Element.Location);
+                  Source_Dir := Element.Next;
+               end loop;
+            end;
+         end if;
+
+         if Current_Verbosity = High then
+            Write_Line ("Puting source directories in canonical cases");
+         end if;
+
+         declare
+            Current : String_List_Id := Data.Source_Dirs;
+            Element : String_Element;
+
+         begin
+            while Current /= Nil_String loop
+               Element := String_Elements.Table (Current);
+               if Element.Value /= No_String then
+                  String_To_Name_Buffer (Element.Value);
+                  Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+                  Start_String;
+                  Store_String_Chars (Name_Buffer (1 .. Name_Len));
+                  Element.Value := End_String;
+                  String_Elements.Table (Current) := Element;
+               end if;
+
+               Current := Element.Next;
+            end loop;
+         end;
+      end;
+
+      --  Library Dir, Name, Version and Kind
+
+      declare
+         Attributes : constant Prj.Variable_Id := Data.Decl.Attributes;
+
+         Lib_Dir : Prj.Variable_Value :=
+                     Prj.Util.Value_Of (Snames.Name_Library_Dir, Attributes);
+
+         Lib_Name : Prj.Variable_Value :=
+                      Prj.Util.Value_Of (Snames.Name_Library_Name, Attributes);
+
+         Lib_Version : Prj.Variable_Value :=
+                         Prj.Util.Value_Of
+                           (Snames.Name_Library_Version, Attributes);
+
+         The_Lib_Kind : Prj.Variable_Value :=
+                          Prj.Util.Value_Of
+                            (Snames.Name_Library_Kind, Attributes);
+
+      begin
+         pragma Assert (Lib_Dir.Kind = Single);
+
+         if Lib_Dir.Value = Empty_String then
+
+            if Current_Verbosity = High then
+               Write_Line ("No library directory");
+            end if;
+
+         else
+            --  Find path name, check that it is a directory
+
+            Stringt.String_To_Name_Buffer (Lib_Dir.Value);
+
+            declare
+               Dir_Id : constant Name_Id := Name_Find;
+
+            begin
+               Data.Library_Dir :=
+                 Locate_Directory (Dir_Id, Data.Directory);
+
+               if Data.Library_Dir = No_Name then
+                  Error_Msg ("not an existing directory",
+                             Lib_Dir.Location);
+
+               elsif Data.Library_Dir = Data.Object_Directory then
+                  Error_Msg
+                    ("library directory cannot be the same " &
+                     "as object directory",
+                     Lib_Dir.Location);
+                  Data.Library_Dir := No_Name;
+
+               else
+                  if Current_Verbosity = High then
+                     Write_Str ("Library directory =""");
+                     Write_Str (Get_Name_String (Data.Library_Dir));
+                     Write_Line ("""");
+                  end if;
+               end if;
+            end;
+         end if;
+
+         pragma Assert (Lib_Name.Kind = Single);
+
+         if Lib_Name.Value = Empty_String then
+            if Current_Verbosity = High then
+               Write_Line ("No library name");
+            end if;
+
+         else
+            Stringt.String_To_Name_Buffer (Lib_Name.Value);
+
+            if not Is_Letter (Name_Buffer (1)) then
+               Error_Msg ("must start with a letter",
+                          Lib_Name.Location);
+
+            else
+               Data.Library_Name := Name_Find;
+
+               for Index in 2 .. Name_Len loop
+                  if not Is_Alphanumeric (Name_Buffer (Index)) then
+                     Data.Library_Name := No_Name;
+                     Error_Msg ("only letters and digits are allowed",
+                                Lib_Name.Location);
+                     exit;
+                  end if;
+               end loop;
+
+               if Data.Library_Name /= No_Name
+                 and then Current_Verbosity = High then
+                  Write_Str ("Library name = """);
+                  Write_Str (Get_Name_String (Data.Library_Name));
+                  Write_Line ("""");
+               end if;
+            end if;
+         end if;
+
+         Data.Library :=
+           Data.Library_Dir /= No_Name
+             and then
+           Data.Library_Name /= No_Name;
+
+         if Data.Library then
+            if Current_Verbosity = High then
+               Write_Line ("This is a library project file");
+            end if;
+
+            pragma Assert (Lib_Version.Kind = Single);
+
+            if Lib_Version.Value = Empty_String then
+               if Current_Verbosity = High then
+                  Write_Line ("No library version specified");
+               end if;
+
+            else
+               Stringt.String_To_Name_Buffer (Lib_Version.Value);
+               Data.Lib_Internal_Name := Name_Find;
+            end if;
+
+            pragma Assert (The_Lib_Kind.Kind = Single);
+
+            if The_Lib_Kind.Value = Empty_String then
+               if Current_Verbosity = High then
+                  Write_Line ("No library kind specified");
+               end if;
+
+            else
+               Stringt.String_To_Name_Buffer (The_Lib_Kind.Value);
+
+               declare
+                  Kind_Name : constant String :=
+                                Ada.Characters.Handling.To_Lower
+                                  (Name_Buffer (1 .. Name_Len));
+
+                  OK : Boolean := True;
+
+               begin
+                  if Kind_Name = "static" then
+                     Data.Library_Kind := Static;
+
+                  elsif Kind_Name = "dynamic" then
+                     Data.Library_Kind := Dynamic;
+
+                  elsif Kind_Name = "relocatable" then
+                     Data.Library_Kind := Relocatable;
+
+                  else
+                     Error_Msg
+                       ("illegal value for Library_Kind",
+                        The_Lib_Kind.Location);
+                     OK := False;
+                  end if;
+
+                  if Current_Verbosity = High and then OK then
+                     Write_Str ("Library kind = ");
+                     Write_Line (Kind_Name);
+                  end if;
+               end;
+            end if;
+         end if;
+      end;
+
+      if Current_Verbosity = High then
+         Show_Source_Dirs (Project);
+      end if;
+
+      declare
+         Naming_Id : constant Package_Id :=
+                       Util.Value_Of (Name_Naming, Data.Decl.Packages);
+
+         Naming : Package_Element;
+
+      begin
+         --  If there is a package Naming, we will put in Data.Naming
+         --  what is in this package Naming.
+
+         if Naming_Id /= No_Package then
+            Naming := Packages.Table (Naming_Id);
+
+            if Current_Verbosity = High then
+               Write_Line ("Checking ""Naming"".");
+            end if;
+
+            declare
+               Bodies : constant Array_Element_Id :=
+                          Util.Value_Of (Name_Body_Part, Naming.Decl.Arrays);
+
+               Specifications : constant Array_Element_Id :=
+                                  Util.Value_Of
+                                    (Name_Specification, Naming.Decl.Arrays);
+
+            begin
+               if Bodies /= No_Array_Element then
+
+                  --  We have elements in the array Body_Part
+
+                  if Current_Verbosity = High then
+                     Write_Line ("Found Bodies.");
+                  end if;
+
+                  Data.Naming.Bodies := Bodies;
+                  Check_Unit_Names (Bodies);
+
+               else
+                  if Current_Verbosity = High then
+                     Write_Line ("No Bodies.");
+                  end if;
+               end if;
+
+               if Specifications /= No_Array_Element then
+
+                  --  We have elements in the array Specification
+
+                  if Current_Verbosity = High then
+                     Write_Line ("Found Specifications.");
+                  end if;
+
+                  Data.Naming.Specifications := Specifications;
+                  Check_Unit_Names (Specifications);
+
+               else
+                  if Current_Verbosity = High then
+                     Write_Line ("No Specifications.");
+                  end if;
+               end if;
+            end;
+
+            --  We are now checking if variables Dot_Replacement, Casing,
+            --  Specification_Append, Body_Append and/or Separate_Append
+            --  exist.
+            --  For each variable, if it does not exist, we do nothing,
+            --  because we already have the default.
+
+            --  Let's check Dot_Replacement
+
+            declare
+               Dot_Replacement : constant Variable_Value :=
+                                   Util.Value_Of
+                                     (Name_Dot_Replacement,
+                                      Naming.Decl.Attributes);
+
+            begin
+               pragma Assert (Dot_Replacement.Kind = Single,
+                              "Dot_Replacement is not a single string");
+
+               if not Dot_Replacement.Default then
+
+                  String_To_Name_Buffer (Dot_Replacement.Value);
+
+                  if Name_Len = 0 then
+                     Error_Msg ("Dot_Replacement cannot be empty",
+                                Dot_Replacement.Location);
+
+                  else
+                     Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+                     Data.Naming.Dot_Replacement := Name_Find;
+                     Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location;
+                  end if;
+
+               end if;
+
+            end;
+
+            if Current_Verbosity = High then
+               Write_Str  ("  Dot_Replacement = """);
+               Write_Str  (Get_Name_String (Data.Naming.Dot_Replacement));
+               Write_Char ('"');
+               Write_Eol;
+            end if;
+
+            --  Check Casing
+
+            declare
+               Casing_String : constant Variable_Value :=
+                 Util.Value_Of (Name_Casing, Naming.Decl.Attributes);
+
+            begin
+               pragma Assert (Casing_String.Kind = Single,
+                              "Dot_Replacement is not a single string");
+
+               if not Casing_String.Default then
+                  declare
+                     Casing_Image : constant String :=
+                                      Get_Name_String (Casing_String.Value);
+
+                  begin
+                     declare
+                        Casing : constant Casing_Type :=
+                          Value (Casing_Image);
+
+                     begin
+                        Data.Naming.Casing := Casing;
+                     end;
+
+                  exception
+                     when Constraint_Error =>
+                        if Casing_Image'Length = 0 then
+                           Error_Msg ("Casing cannot be an empty string",
+                                      Casing_String.Location);
+
+                        else
+                           Name_Len := Casing_Image'Length;
+                           Name_Buffer (1 .. Name_Len) := Casing_Image;
+                           Error_Msg_Name_1 := Name_Find;
+                           Error_Msg
+                             ("{ is not a correct Casing",
+                              Casing_String.Location);
+                        end if;
+                  end;
+               end if;
+            end;
+
+            if Current_Verbosity = High then
+               Write_Str  ("  Casing = ");
+               Write_Str  (Image (Data.Naming.Casing));
+               Write_Char ('.');
+               Write_Eol;
+            end if;
+
+            --  Let's check Specification_Append
+
+            declare
+               Specification_Append : constant Variable_Value :=
+                                        Util.Value_Of
+                                          (Name_Specification_Append,
+                                           Naming.Decl.Attributes);
+
+            begin
+               pragma Assert (Specification_Append.Kind = Single,
+                              "Specification_Append is not a single string");
+
+               if not Specification_Append.Default then
+                  String_To_Name_Buffer (Specification_Append.Value);
+
+                  if Name_Len = 0 then
+                     Error_Msg ("Specification_Append cannot be empty",
+                                Specification_Append.Location);
+
+                  else
+                     Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+                     Data.Naming.Specification_Append := Name_Find;
+                     Data.Naming.Spec_Append_Loc :=
+                       Specification_Append.Location;
+                  end if;
+               end if;
+            end;
+
+            if Current_Verbosity = High then
+               Write_Str  ("  Specification_Append = """);
+               Write_Str  (Get_Name_String (Data.Naming.Specification_Append));
+               Write_Line (""".");
+            end if;
+
+            --  Check Body_Append
+
+            declare
+               Body_Append : constant Variable_Value :=
+                               Util.Value_Of
+                                 (Name_Body_Append, Naming.Decl.Attributes);
+
+            begin
+               pragma Assert (Body_Append.Kind = Single,
+                              "Body_Append is not a single string");
+
+               if not Body_Append.Default then
+
+                  String_To_Name_Buffer (Body_Append.Value);
+
+                  if Name_Len = 0 then
+                     Error_Msg ("Body_Append cannot be empty",
+                                Body_Append.Location);
+
+                  else
+                     Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+                     Data.Naming.Body_Append := Name_Find;
+                     Data.Naming.Body_Append_Loc := Body_Append.Location;
+
+                     --  As we have a new Body_Append, we set Separate_Append
+                     --  to the same value.
+
+                     Data.Naming.Separate_Append := Data.Naming.Body_Append;
+                     Data.Naming.Sep_Append_Loc := Data.Naming.Body_Append_Loc;
+                  end if;
+               end if;
+            end;
+
+            if Current_Verbosity = High then
+               Write_Str  ("  Body_Append = """);
+               Write_Str  (Get_Name_String (Data.Naming.Body_Append));
+               Write_Line (""".");
+            end if;
+
+            --  Check Separate_Append
+
+            declare
+               Separate_Append : constant Variable_Value :=
+                                   Util.Value_Of
+                                     (Name_Separate_Append,
+                                      Naming.Decl.Attributes);
+
+            begin
+               pragma Assert (Separate_Append.Kind = Single,
+                             "Separate_Append is not a single string");
+
+               if not Separate_Append.Default then
+                  String_To_Name_Buffer (Separate_Append.Value);
+
+                  if Name_Len = 0 then
+                     Error_Msg ("Separate_Append cannot be empty",
+                                Separate_Append.Location);
+
+                  else
+                     Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+                     Data.Naming.Separate_Append := Name_Find;
+                     Data.Naming.Sep_Append_Loc := Separate_Append.Location;
+                  end if;
+               end if;
+            end;
+
+            if Current_Verbosity = High then
+               Write_Str  ("  Separate_Append = """);
+               Write_Str  (Get_Name_String (Data.Naming.Separate_Append));
+               Write_Line (""".");
+               Write_Line ("end Naming.");
+            end if;
+
+            --  Now, we check if Data.Naming is valid
+
+            Check_Naming_Scheme (Data.Naming);
+         end if;
+      end;
+
+      --  If we have source directories, then let's find the sources.
+
+      if Data.Source_Dirs /= Nil_String then
+         declare
+            Sources : constant Variable_Value :=
+                        Util.Value_Of
+                          (Name_Source_Files,
+                           Data.Decl.Attributes);
+
+            Source_List_File : constant Variable_Value :=
+                                 Util.Value_Of
+                                   (Name_Source_List_File,
+                                    Data.Decl.Attributes);
+
+         begin
+            pragma Assert
+              (Sources.Kind = List,
+               "Source_Files is not a list");
+            pragma Assert
+              (Source_List_File.Kind = Single,
+               "Source_List_File is not a single string");
+
+            if not Sources.Default then
+               if not Source_List_File.Default then
+                  Error_Msg
+                    ("?both variables source_files and " &
+                     "source_list_file are present",
+                     Source_List_File.Location);
+               end if;
+
+               --  Sources is a list of file names
+
+               declare
+                  Current_Source : String_List_Id := Nil_String;
+                  Current        : String_List_Id := Sources.Values;
+                  Element        : String_Element;
+
+               begin
+                  while Current /= Nil_String loop
+                     Element := String_Elements.Table (Current);
+                     String_To_Name_Buffer (Element.Value);
+
+                     declare
+                        File_Name : constant String :=
+                          Name_Buffer (1 .. Name_Len);
+
+                     begin
+                        Get_Path_Name_And_Record_Source
+                          (File_Name        => File_Name,
+                           Location         => Element.Location,
+                           Current_Source   => Current_Source);
+                        Current := Element.Next;
+                     end;
+                  end loop;
+               end;
+
+               --  No source_files specified.
+               --  We check Source_List_File has been specified.
+
+            elsif not Source_List_File.Default then
+
+               --  Source_List_File is the name of the file
+               --  that contains the source file names
+
+               declare
+                  Source_File_Path_Name : constant String :=
+                                            Path_Name_Of
+                                              (Source_List_File.Value,
+                                               Data.Directory);
+
+               begin
+                  if Source_File_Path_Name'Length = 0 then
+                     String_To_Name_Buffer (Source_List_File.Value);
+                     Error_Msg_Name_1 := Name_Find;
+                     Error_Msg
+                       ("file with sources { does not exist",
+                        Source_List_File.Location);
+
+                  else
+                     Get_Sources_From_File
+                       (Source_File_Path_Name,
+                        Source_List_File.Location);
+                  end if;
+               end;
+
+            else
+               --  Neither Source_Files nor Source_List_File has been
+               --  specified.
+               --  Find all the files that satisfy
+               --  the naming scheme in all the source directories.
+
+               Find_Sources;
+            end if;
+         end;
+      end if;
+
+      Projects.Table (Project) := Data;
+   end Check_Naming_Scheme;
+
+   ---------------
+   -- Error_Msg --
+   ---------------
+
+   procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+   begin
+      if Error_Report = null then
+         Errout.Error_Msg (Msg, Flag_Location);
+
+      else
+         declare
+            Error_Buffer : String (1 .. 5_000);
+            Error_Last   : Natural := 0;
+            Msg_Name     : Natural := 0;
+            First        : Positive := Msg'First;
+
+            procedure Add (C : Character);
+            --  Add a character to the buffer
+
+            procedure Add (S : String);
+            --  Add a string to the buffer
+
+            procedure Add (Id : Name_Id);
+            --  Add a name to the buffer
+
+            ---------
+            -- Add --
+            ---------
+
+            procedure Add (C : Character) is
+            begin
+               Error_Last := Error_Last + 1;
+               Error_Buffer (Error_Last) := C;
+            end Add;
+
+            procedure Add (S : String) is
+            begin
+               Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S;
+               Error_Last := Error_Last + S'Length;
+            end Add;
+
+            procedure Add (Id : Name_Id) is
+            begin
+               Get_Name_String (Id);
+               Add (Name_Buffer (1 .. Name_Len));
+            end Add;
+
+         begin
+            if Msg (First) = '\' then
+               --  Continuation character, ignore.
+               First := First + 1;
+
+            elsif Msg (First) = '?' then
+               --  Warning character. It is always the first one,
+               --  in this package.
+               First := First + 1;
+               Add ("Warning: ");
+            end if;
+
+            for Index in First .. Msg'Last loop
+               if Msg (Index) = '{' or else Msg (Index) = '%' then
+                  --  Include a name between double quotes.
+                  Msg_Name := Msg_Name + 1;
+                  Add ('"');
+
+                  case Msg_Name is
+                     when 1 => Add (Error_Msg_Name_1);
+
+                     when 2 => Add (Error_Msg_Name_2);
+
+                     when 3 => Add (Error_Msg_Name_3);
+
+                     when others => null;
+                  end case;
+
+                  Add ('"');
+
+               else
+                  Add (Msg (Index));
+               end if;
+
+            end loop;
+
+            Error_Report (Error_Buffer (1 .. Error_Last));
+         end;
+      end if;
+   end Error_Msg;
+
+   ---------------------
+   -- Get_Name_String --
+   ---------------------
+
+   function Get_Name_String (S : String_Id) return String is
+   begin
+      if S = No_String then
+         return "";
+      else
+         String_To_Name_Buffer (S);
+         return Name_Buffer (1 .. Name_Len);
+      end if;
+   end Get_Name_String;
+
+   --------------
+   -- Get_Unit --
+   --------------
+
+   procedure Get_Unit
+     (File_Name    : Name_Id;
+      Naming       : Naming_Data;
+      Unit_Name    : out Name_Id;
+      Unit_Kind    : out Spec_Or_Body;
+      Needs_Pragma : out Boolean)
+   is
+      Canonical_Case_Name : Name_Id;
+
+   begin
+      Needs_Pragma := False;
+      Get_Name_String (File_Name);
+      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+      Canonical_Case_Name := Name_Find;
+
+      if Naming.Bodies /= No_Array_Element then
+
+         --  There are some specified file names for some bodies
+         --  of this project. Find out if File_Name is one of these bodies.
+
+         declare
+            Current : Array_Element_Id := Naming.Bodies;
+            Element : Array_Element;
+
+         begin
+            while Current /= No_Array_Element loop
+               Element := Array_Elements.Table (Current);
+
+               if Element.Index /= No_Name then
+                  String_To_Name_Buffer (Element.Value.Value);
+                  Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+                  if Canonical_Case_Name = Name_Find then
+
+                     --  File_Name corresponds to one body.
+                     --  So, we know it is a body, and we know the unit name.
+
+                     Unit_Kind := Body_Part;
+                     Unit_Name := Element.Index;
+                     Needs_Pragma := True;
+                     return;
+                  end if;
+               end if;
+
+               Current := Element.Next;
+            end loop;
+         end;
+      end if;
+
+      if Naming.Specifications /= No_Array_Element then
+
+         --  There are some specified file names for some bodiesspecifications
+         --  of this project. Find out if File_Name is one of these
+         --  specifications.
+
+         declare
+            Current : Array_Element_Id := Naming.Specifications;
+            Element : Array_Element;
+
+         begin
+            while Current /= No_Array_Element loop
+               Element := Array_Elements.Table (Current);
+
+               if Element.Index /= No_Name then
+                  String_To_Name_Buffer (Element.Value.Value);
+                  Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+                  if Canonical_Case_Name = Name_Find then
+
+                     --  File_Name corresponds to one specification.
+                     --  So, we know it is a spec, and we know the unit name.
+
+                     Unit_Kind := Specification;
+                     Unit_Name := Element.Index;
+                     Needs_Pragma := True;
+                     return;
+                  end if;
+
+               end if;
+
+               Current := Element.Next;
+            end loop;
+         end;
+      end if;
+
+      declare
+         File  : String   := Get_Name_String (Canonical_Case_Name);
+         First : Positive := File'First;
+         Last  : Natural  := File'Last;
+
+      begin
+         --  Check if the end of the file name is Specification_Append
+
+         Get_Name_String (Naming.Specification_Append);
+
+         if File'Length > Name_Len
+           and then File (Last - Name_Len + 1 .. Last) =
+                                                Name_Buffer (1 .. Name_Len)
+         then
+            --  We have a spec
+
+            Unit_Kind := Specification;
+            Last := Last - Name_Len;
+
+            if Current_Verbosity = High then
+               Write_Str  ("   Specification: ");
+               Write_Line (File (First .. Last));
+            end if;
+
+         else
+            Get_Name_String (Naming.Body_Append);
+
+            --  Check if the end of the file name is Body_Append
+
+            if File'Length > Name_Len
+              and then File (Last - Name_Len + 1 .. Last) =
+                                                Name_Buffer (1 .. Name_Len)
+            then
+               --  We have a body
+
+               Unit_Kind := Body_Part;
+               Last := Last - Name_Len;
+
+               if Current_Verbosity = High then
+                  Write_Str  ("   Body: ");
+                  Write_Line (File (First .. Last));
+               end if;
+
+            elsif Naming.Separate_Append /= Naming.Body_Append then
+               Get_Name_String (Naming.Separate_Append);
+
+               --  Check if the end of the file name is Separate_Append
+
+               if File'Length > Name_Len
+                 and then File (Last - Name_Len + 1 .. Last) =
+                                                Name_Buffer (1 .. Name_Len)
+               then
+                  --  We have a separate (a body)
+
+                  Unit_Kind := Body_Part;
+                  Last := Last - Name_Len;
+
+                  if Current_Verbosity = High then
+                     Write_Str  ("   Separate: ");
+                     Write_Line (File (First .. Last));
+                  end if;
+
+               else
+                  Last := 0;
+               end if;
+
+            else
+               Last := 0;
+            end if;
+         end if;
+
+         if Last = 0 then
+
+            --  This is not a source file
+
+            Unit_Name := No_Name;
+            Unit_Kind := Specification;
+
+            if Current_Verbosity = High then
+               Write_Line ("   Not a valid file name.");
+            end if;
+
+            return;
+         end if;
+
+         Get_Name_String (Naming.Dot_Replacement);
+
+         if Name_Buffer (1 .. Name_Len) /= "." then
+
+            --  If Dot_Replacement is not a single dot,
+            --  then there should not be any dot in the name.
+
+            for Index in First .. Last loop
+               if File (Index) = '.' then
+                  if Current_Verbosity = High then
+                     Write_Line
+                       ("   Not a valid file name (some dot not replaced).");
+                  end if;
+
+                  Unit_Name := No_Name;
+                  return;
+
+               end if;
+            end loop;
+
+            --  Replace the substring Dot_Replacement with dots
+
+            declare
+               Index : Positive := First;
+
+            begin
+               while Index <= Last - Name_Len + 1 loop
+
+                  if File (Index .. Index + Name_Len - 1) =
+                    Name_Buffer (1 .. Name_Len)
+                  then
+                     File (Index) := '.';
+
+                     if Name_Len > 1 and then Index < Last then
+                        File (Index + 1 .. Last - Name_Len + 1) :=
+                          File (Index + Name_Len .. Last);
+                     end if;
+
+                     Last := Last - Name_Len + 1;
+                  end if;
+
+                  Index := Index + 1;
+               end loop;
+            end;
+         end if;
+
+         --  Check if the casing is right
+
+         declare
+            Src : String := File (First .. Last);
+
+         begin
+            case Naming.Casing is
+               when All_Lower_Case =>
+                  Fixed.Translate
+                    (Source  => Src,
+                     Mapping => Lower_Case_Map);
+
+               when All_Upper_Case =>
+                  Fixed.Translate
+                    (Source  => Src,
+                     Mapping => Upper_Case_Map);
+
+               when Mixed_Case | Unknown =>
+                  null;
+            end case;
+
+            if Src /= File (First .. Last) then
+               if Current_Verbosity = High then
+                  Write_Line ("   Not a valid file name (casing).");
+               end if;
+
+               Unit_Name := No_Name;
+               return;
+            end if;
+
+            --  We put the name in lower case
+
+            Fixed.Translate
+              (Source  => Src,
+               Mapping => Lower_Case_Map);
+
+            if Current_Verbosity = High then
+               Write_Str  ("      ");
+               Write_Line (Src);
+            end if;
+
+            Name_Len := Src'Length;
+            Name_Buffer (1 .. Name_Len) := Src;
+
+            --  Now, we check if this name is a valid unit name
+
+            Check_Naming_Scheme (Name => Name_Find, Unit => Unit_Name);
+         end;
+
+      end;
+
+   end Get_Unit;
+
+   -----------------------
+   -- Is_Illegal_Append --
+   -----------------------
+
+   function Is_Illegal_Append (This : String) return Boolean is
+   begin
+      return This'Length = 0
+        or else Is_Alphanumeric (This (This'First))
+        or else (This'Length >= 2
+                 and then This (This'First) = '_'
+                 and then Is_Alphanumeric (This (This'First + 1)));
+   end Is_Illegal_Append;
+
+   ----------------------
+   -- Locate_Directory --
+   ----------------------
+
+   function Locate_Directory
+     (Name   : Name_Id;
+      Parent : Name_Id)
+     return   Name_Id
+   is
+      The_Name   : constant String := Get_Name_String (Name);
+      The_Parent : constant String :=
+                     Get_Name_String (Parent) & Dir_Sep;
+
+      The_Parent_Last : Positive := The_Parent'Last;
+
+   begin
+      if The_Parent'Length > 1
+        and then (The_Parent (The_Parent_Last - 1) = Dir_Sep
+                    or else The_Parent (The_Parent_Last - 1) = '/')
+      then
+         The_Parent_Last := The_Parent_Last - 1;
+      end if;
+
+      if Current_Verbosity = High then
+         Write_Str ("Locate_Directory (""");
+         Write_Str (The_Name);
+         Write_Str (""", """);
+         Write_Str (The_Parent);
+         Write_Line (""")");
+      end if;
+
+      if Is_Absolute_Path (The_Name) then
+         if Is_Directory (The_Name) then
+            return Name;
+         end if;
+
+      else
+         declare
+            Full_Path : constant String :=
+                          The_Parent (The_Parent'First .. The_Parent_Last) &
+                                                                     The_Name;
+
+         begin
+            if Is_Directory (Full_Path) then
+               Name_Len := Full_Path'Length;
+               Name_Buffer (1 .. Name_Len) := Full_Path;
+               return Name_Find;
+            end if;
+         end;
+
+      end if;
+
+      return No_Name;
+   end Locate_Directory;
+
+   ------------------
+   -- Path_Name_Of --
+   ------------------
+
+   function Path_Name_Of
+     (File_Name : String_Id;
+      Directory : String_Id)
+      return      String
+   is
+      Result : String_Access;
+
+   begin
+      String_To_Name_Buffer (File_Name);
+
+      declare
+         The_File_Name : constant String := Name_Buffer (1 .. Name_Len);
+
+      begin
+         String_To_Name_Buffer (Directory);
+         Result := Locate_Regular_File
+           (File_Name => The_File_Name,
+            Path      => Name_Buffer (1 .. Name_Len));
+      end;
+
+      if Result = null then
+         return "";
+      else
+         Canonical_Case_File_Name (Result.all);
+         return Result.all;
+      end if;
+   end Path_Name_Of;
+
+   function Path_Name_Of
+     (File_Name : String_Id;
+      Directory : Name_Id)
+     return      String
+   is
+      Result : String_Access;
+      The_Directory : constant String := Get_Name_String (Directory);
+
+   begin
+      String_To_Name_Buffer (File_Name);
+      Result := Locate_Regular_File
+        (File_Name => Name_Buffer (1 .. Name_Len),
+         Path      => The_Directory);
+
+      if Result = null then
+         return "";
+      else
+         Canonical_Case_File_Name (Result.all);
+         return Result.all;
+      end if;
+   end Path_Name_Of;
+
+   -------------------
+   -- Record_Source --
+   -------------------
+
+   procedure Record_Source
+     (File_Name        : Name_Id;
+      Path_Name        : Name_Id;
+      Project          : Project_Id;
+      Data             : in out Project_Data;
+      Error_If_Invalid : Boolean;
+      Location         : Source_Ptr;
+      Current_Source   : in out String_List_Id)
+   is
+      Unit_Name    : Name_Id;
+      Unit_Kind    : Spec_Or_Body;
+      Needs_Pragma : Boolean;
+      The_Location : Source_Ptr := Location;
+
+   begin
+      --  Find out the unit name, the unit kind and if it needs
+      --  a specific SFN pragma.
+
+      Get_Unit
+        (File_Name    => File_Name,
+         Naming       => Data.Naming,
+         Unit_Name    => Unit_Name,
+         Unit_Kind    => Unit_Kind,
+         Needs_Pragma => Needs_Pragma);
+
+      --  If it is not a source file, report an error only if
+      --  Error_If_Invalid is true.
+
+      if Unit_Name = No_Name then
+         if Error_If_Invalid then
+            Error_Msg_Name_1 := File_Name;
+            Error_Msg
+              ("{ is not a valid source file name",
+               Location);
+
+         else
+            if Current_Verbosity = High then
+               Write_Str  ("   """);
+               Write_Str  (Get_Name_String (File_Name));
+               Write_Line (""" is not a valid source file name (ignored).");
+            end if;
+         end if;
+
+      else
+         --  Put the file name in the list of sources of the project
+
+         String_Elements.Increment_Last;
+         Get_Name_String (File_Name);
+         Start_String;
+         Store_String_Chars (Name_Buffer (1 .. Name_Len));
+         String_Elements.Table (String_Elements.Last) :=
+           (Value    => End_String,
+            Location => No_Location,
+            Next     => Nil_String);
+
+         if Current_Source = Nil_String then
+            Data.Sources := String_Elements.Last;
+
+         else
+            String_Elements.Table (Current_Source).Next :=
+              String_Elements.Last;
+         end if;
+
+         Current_Source := String_Elements.Last;
+
+         --  Put the unit in unit list
+
+         declare
+            The_Unit      : Unit_Id := Units_Htable.Get (Unit_Name);
+            The_Unit_Data : Unit_Data;
+
+         begin
+            if Current_Verbosity = High then
+               Write_Str  ("Putting ");
+               Write_Str  (Get_Name_String (Unit_Name));
+               Write_Line (" in the unit list.");
+            end if;
+
+            --  The unit is already in the list, but may be it is
+            --  only the other unit kind (spec or body), or what is
+            --  in the unit list is a unit of a project we are modifying.
+
+            if The_Unit /= Prj.Com.No_Unit then
+               The_Unit_Data := Units.Table (The_Unit);
+
+               if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name
+                 or else (Data.Modifies /= No_Project
+                            and then
+                          The_Unit_Data.File_Names (Unit_Kind).Project =
+                                                            Data.Modifies)
+               then
+                  The_Unit_Data.File_Names (Unit_Kind) :=
+                    (Name         => File_Name,
+                     Path         => Path_Name,
+                     Project      => Project,
+                     Needs_Pragma => Needs_Pragma);
+                  Units.Table (The_Unit) := The_Unit_Data;
+
+               else
+                  --  It is an error to have two units with the same name
+                  --  and the same kind (spec or body).
+
+                  if The_Location = No_Location then
+                     The_Location := Projects.Table (Project).Location;
+                  end if;
+
+                  Error_Msg_Name_1 := Unit_Name;
+                  Error_Msg ("duplicate source {", The_Location);
+
+                  Error_Msg_Name_1 :=
+                    Projects.Table
+                      (The_Unit_Data.File_Names (Unit_Kind).Project).Name;
+                  Error_Msg_Name_2 :=
+                    The_Unit_Data.File_Names (Unit_Kind).Path;
+                  Error_Msg ("\   project file {, {", The_Location);
+
+                  Error_Msg_Name_1 := Projects.Table (Project).Name;
+                  Error_Msg_Name_2 := Path_Name;
+                  Error_Msg ("\   project file {, {", The_Location);
+
+               end if;
+
+            --  It is a new unit, create a new record
+
+            else
+               Units.Increment_Last;
+               The_Unit := Units.Last;
+               Units_Htable.Set (Unit_Name, The_Unit);
+               The_Unit_Data.Name := Unit_Name;
+               The_Unit_Data.File_Names (Unit_Kind) :=
+                 (Name         => File_Name,
+                  Path         => Path_Name,
+                  Project      => Project,
+                  Needs_Pragma => Needs_Pragma);
+               Units.Table (The_Unit) := The_Unit_Data;
+            end if;
+         end;
+      end if;
+   end Record_Source;
+
+   ----------------------
+   -- Show_Source_Dirs --
+   ----------------------
+
+   procedure Show_Source_Dirs (Project : Project_Id) is
+      Current : String_List_Id := Projects.Table (Project).Source_Dirs;
+      Element : String_Element;
+
+   begin
+      Write_Line ("Source_Dirs:");
+
+      while Current /= Nil_String loop
+         Element := String_Elements.Table (Current);
+         Write_Str  ("   ");
+         Write_Line (Get_Name_String (Element.Value));
+         Current := Element.Next;
+      end loop;
+
+      Write_Line ("end Source_Dirs.");
+   end Show_Source_Dirs;
+
+end Prj.Nmsc;
diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads
new file mode 100644
index 0000000..5fcc005
--- /dev/null
+++ b/gcc/ada/prj-nmsc.ads
@@ -0,0 +1,43 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . N M S C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--             Copyright (C) 2000-2001 Free Software Foundation, Inc.       --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Check the Naming Scheme of a project file, find the directories
+--  and the source files.
+
+private package Prj.Nmsc is
+
+   procedure Check_Naming_Scheme
+     (Project      : Project_Id;
+      Report_Error : Put_Line_Access);
+   --  Check that the Naming Scheme of a project is legal. Find the
+   --  object directory, the source directories, and the source files.
+   --  Check the source files against the Naming Scheme.
+   --  If Report_Error is null , use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Nmsc;
diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb
new file mode 100644
index 0000000..620d2e1
--- /dev/null
+++ b/gcc/ada/prj-pars.adb
@@ -0,0 +1,92 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . P A R S                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with Errout;   use Errout;
+with Output;   use Output;
+with Prj.Com;  use Prj.Com;
+with Prj.Part;
+with Prj.Proc;
+with Prj.Tree; use Prj.Tree;
+
+package body Prj.Pars is
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String)
+   is
+      Project_Tree      : Project_Node_Id := Empty_Node;
+      The_Project       : Project_Id      := No_Project;
+
+   begin
+      --  Parse the main project file into a tree
+
+      Prj.Part.Parse
+        (Project                => Project_Tree,
+         Project_File_Name      => Project_File_Name,
+         Always_Errout_Finalize => False);
+
+      --  If there were no error, process the tree
+
+      if Project_Tree /= Empty_Node then
+         Prj.Proc.Process
+           (Project           => The_Project,
+            From_Project_Node => Project_Tree,
+            Report_Error      => null);
+         Errout.Finalize;
+      end if;
+
+      Project := The_Project;
+
+   exception
+      when X : others =>
+
+         --  Internal error
+
+         Write_Line (Exception_Information (X));
+         Write_Str  ("Exception ");
+         Write_Str  (Exception_Name (X));
+         Write_Line (" raised, while processing project file");
+         Project := No_Project;
+   end Parse;
+
+   -------------------
+   -- Set_Verbosity --
+   -------------------
+
+   procedure Set_Verbosity (To : in Verbosity) is
+   begin
+      Current_Verbosity := To;
+   end Set_Verbosity;
+
+end Prj.Pars;
diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads
new file mode 100644
index 0000000..0adaf72
--- /dev/null
+++ b/gcc/ada/prj-pars.ads
@@ -0,0 +1,44 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R S                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.8 $
+--                                                                          --
+--          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files.
+
+package Prj.Pars is
+
+   procedure Set_Verbosity (To : Verbosity);
+   --  Set the verbosity when parsing the project files.
+
+   procedure Parse
+     (Project           : out Project_Id;
+      Project_File_Name : String);
+   --  Parse a project files and all its imported project files.
+   --  If parsing is successful, Project_Id is the project ID
+   --  of the main project file; otherwise, Project_Id is set
+   --  to No_Project.
+
+end Prj.Pars;
diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb
new file mode 100644
index 0000000..8100ad4
--- /dev/null
+++ b/gcc/ada/prj-part.adb
@@ -0,0 +1,871 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . P A R T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.10 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling;    use Ada.Characters.Handling;
+with Ada.Exceptions;             use Ada.Exceptions;
+with Errout;                     use Errout;
+with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
+with GNAT.OS_Lib;                use GNAT.OS_Lib;
+with Namet;                      use Namet;
+with Osint;                      use Osint;
+with Output;                     use Output;
+with Prj.Com;                    use Prj.Com;
+with Prj.Dect;
+with Scans;                      use Scans;
+with Scn;                        use Scn;
+with Sinfo;                      use Sinfo;
+with Sinput;                     use Sinput;
+with Sinput.P;                   use Sinput.P;
+with Stringt;                    use Stringt;
+with Table;
+with Types;                      use Types;
+
+pragma Elaborate_All (GNAT.OS_Lib);
+
+package body Prj.Part is
+
+   Dir_Sep  : Character renames GNAT.OS_Lib.Directory_Separator;
+
+   Project_File_Extension : String := ".gpr";
+
+   Project_Path : String_Access;
+   --  The project path; initialized during package elaboration.
+
+   Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
+   Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
+
+   ------------------------------------
+   -- Local Packages and Subprograms --
+   ------------------------------------
+
+   package Project_Stack is new Table.Table
+     (Table_Component_Type => Name_Id,
+      Table_Index_Type     => Nat,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 10,
+      Table_Increment      => 10,
+      Table_Name           => "Prj.Part.Project_Stack");
+   --  This table is used to detect circular dependencies
+   --  for imported and modified projects.
+
+   procedure Parse_Context_Clause
+     (Context_Clause    : out Project_Node_Id;
+      Project_Directory : Name_Id);
+   --  Parse the context clause of a project
+   --  Does nothing if there is b\no context clause (if the current
+   --  token is not "with").
+
+   procedure Parse_Single_Project
+     (Project         : out Project_Node_Id;
+      Path_Name       : String;
+      Modified        : Boolean);
+   --  Parse a project file.
+   --  Recursive procedure: it calls itself for imported and
+   --  modified projects.
+
+   function Path_Name_Of
+     (File_Name : String;
+      Directory : String)
+      return      String;
+   --  Returns the path name of a (non project) file.
+   --  Returns an empty string if file cannot be found.
+
+   function Project_Path_Name_Of
+     (Project_File_Name : String;
+      Directory         : String)
+      return              String;
+   --  Returns the path name of a project file.
+   --  Returns an empty string if project file cannot be found.
+
+   function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
+   --  Get the directory of the file with the specified path name.
+   --  This includes the directory separator as the last character.
+   --  Returns "./" if Path_Name contains no directory separator.
+
+   function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id;
+   --  Returns the name of a file with the specified path name
+   --  with no directory information.
+
+   function Project_Name_From (Path_Name : String) return Name_Id;
+   --  Returns the name of the project that corresponds to its path name.
+   --  Returns No_Name if the path name is invalid, because the corresponding
+   --  project name does not have the syntax of an ada identifier.
+
+   ----------------------------
+   -- Immediate_Directory_Of --
+   ----------------------------
+
+   function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is
+   begin
+      Get_Name_String (Path_Name);
+
+      for Index in reverse 1 .. Name_Len loop
+         if Name_Buffer (Index) = '/'
+           or else Name_Buffer (Index) = Dir_Sep
+         then
+            --  Remove from name all characters after the last
+            --  directory separator.
+
+            Name_Len := Index;
+            return Name_Find;
+         end if;
+      end loop;
+
+      --  There is no directory separator in name. Return "./" or ".\".
+      Name_Len := 2;
+      Name_Buffer (1) := '.';
+      Name_Buffer (2) := Dir_Sep;
+      return Name_Find;
+   end Immediate_Directory_Of;
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse
+     (Project                : out Project_Node_Id;
+      Project_File_Name      : String;
+      Always_Errout_Finalize : Boolean)
+   is
+      Current_Directory : constant String := Get_Current_Dir;
+
+   begin
+      Project := Empty_Node;
+
+      if Current_Verbosity >= Medium then
+         Write_Str ("ADA_PROJECT_PATH=""");
+         Write_Str (Project_Path.all);
+         Write_Line ("""");
+      end if;
+
+      declare
+         Path_Name : constant String :=
+           Project_Path_Name_Of (Project_File_Name,
+                                 Directory   => Current_Directory);
+
+      begin
+         --  Initialize the tables
+
+         Tree_Private_Part.Project_Nodes.Set_Last (Empty_Node);
+         Tree_Private_Part.Projects_Htable.Reset;
+
+         Errout.Initialize;
+
+         --  And parse the main project file
+
+         if Path_Name = "" then
+            Fail ("project file """ & Project_File_Name & """ not found");
+         end if;
+
+         Parse_Single_Project
+           (Project         => Project,
+            Path_Name       => Path_Name,
+            Modified        => False);
+
+         if Errout.Errors_Detected > 0 then
+            Project := Empty_Node;
+         end if;
+
+         if Project = Empty_Node or else Always_Errout_Finalize then
+            Errout.Finalize;
+         end if;
+      end;
+
+   exception
+      when X : others =>
+
+         --  Internal error
+
+         Write_Line (Exception_Information (X));
+         Write_Str  ("Exception ");
+         Write_Str  (Exception_Name (X));
+         Write_Line (" raised, while processing project file");
+         Project := Empty_Node;
+   end Parse;
+
+   --------------------------
+   -- Parse_Context_Clause --
+   --------------------------
+
+   procedure Parse_Context_Clause
+     (Context_Clause    : out Project_Node_Id;
+      Project_Directory : Name_Id)
+   is
+      Project_Directory_Path : constant String :=
+                                 Get_Name_String (Project_Directory);
+      Current_With_Clause    : Project_Node_Id := Empty_Node;
+      Next_With_Clause       : Project_Node_Id := Empty_Node;
+
+   begin
+      --  Assume no context clause
+
+      Context_Clause := Empty_Node;
+      With_Loop :
+
+      --  If Token is not "with", there is no context clause,
+      --  or we have exhausted the with clauses.
+
+      while Token = Tok_With loop
+         Comma_Loop :
+         loop
+            --  Scan past "with" or ","
+
+            Scan;
+            Expect (Tok_String_Literal, "literal string");
+
+            if Token /= Tok_String_Literal then
+               return;
+            end if;
+
+            --  New with clause
+
+            if Current_With_Clause = Empty_Node then
+
+               --  First with clause of the context clause
+
+               Current_With_Clause := Default_Project_Node
+                 (Of_Kind => N_With_Clause);
+               Context_Clause := Current_With_Clause;
+
+            else
+               Next_With_Clause := Default_Project_Node
+                 (Of_Kind => N_With_Clause);
+               Set_Next_With_Clause_Of (Current_With_Clause, Next_With_Clause);
+               Current_With_Clause := Next_With_Clause;
+            end if;
+
+            Set_String_Value_Of (Current_With_Clause, Strval (Token_Node));
+            Set_Location_Of     (Current_With_Clause, Token_Ptr);
+            String_To_Name_Buffer (String_Value_Of (Current_With_Clause));
+
+            declare
+               Original_Path : constant String :=
+                                 Name_Buffer (1 .. Name_Len);
+
+               Imported_Path_Name : constant String :=
+                                      Project_Path_Name_Of
+                                        (Original_Path,
+                                         Project_Directory_Path);
+
+               Withed_Project : Project_Node_Id := Empty_Node;
+
+            begin
+               if Imported_Path_Name = "" then
+
+                  --  The project file cannot be found
+
+                  Name_Len := Original_Path'Length;
+                  Name_Buffer (1 .. Name_Len) := Original_Path;
+                  Error_Msg_Name_1 := Name_Find;
+
+                  Error_Msg ("unknown project file: {", Token_Ptr);
+
+               else
+                  --  Parse the imported project
+
+                  Parse_Single_Project
+                    (Project   => Withed_Project,
+                     Path_Name => Imported_Path_Name,
+                     Modified  => False);
+
+                  if Withed_Project /= Empty_Node then
+
+                     --  If parsing was successful, record project name
+                     --  and path name in with clause
+
+                     Set_Project_Node_Of (Current_With_Clause, Withed_Project);
+                     Set_Name_Of (Current_With_Clause,
+                                  Name_Of (Withed_Project));
+                     Name_Len := Imported_Path_Name'Length;
+                     Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
+                     Set_Path_Name_Of (Current_With_Clause, Name_Find);
+                  end if;
+               end if;
+            end;
+
+            Scan;
+            if Token = Tok_Semicolon then
+
+               --  End of (possibly multiple) with clause;
+               --  Scan past the semicolon.
+
+               Scan;
+               exit Comma_Loop;
+
+            elsif Token /= Tok_Comma then
+               Error_Msg ("expected comma or semi colon", Token_Ptr);
+               exit Comma_Loop;
+            end if;
+         end loop Comma_Loop;
+      end loop With_Loop;
+
+   end Parse_Context_Clause;
+
+   --------------------------
+   -- Parse_Single_Project --
+   --------------------------
+
+   procedure Parse_Single_Project
+     (Project         : out Project_Node_Id;
+      Path_Name       : String;
+      Modified        : Boolean)
+   is
+      Canonical_Path_Name : Name_Id;
+      Project_Directory   : Name_Id;
+      Project_Scan_State  : Saved_Project_Scan_State;
+      Source_Index        : Source_File_Index;
+
+      Modified_Project    : Project_Node_Id := Empty_Node;
+
+      A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
+        Tree_Private_Part.Projects_Htable.Get_First;
+
+      Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
+
+      use Tree_Private_Part;
+
+   begin
+      Name_Len := Path_Name'Length;
+      Name_Buffer (1 .. Name_Len) := Path_Name;
+      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+      Canonical_Path_Name := Name_Find;
+
+      --  Check for a circular dependency
+
+      for Index in 1 .. Project_Stack.Last loop
+         if Canonical_Path_Name = Project_Stack.Table (Index) then
+            Error_Msg ("circular dependency detected", Token_Ptr);
+            Error_Msg_Name_1 := Canonical_Path_Name;
+            Error_Msg ("\  { is imported by", Token_Ptr);
+
+            for Current in reverse 1 .. Project_Stack.Last loop
+               Error_Msg_Name_1 := Project_Stack.Table (Current);
+
+               if Error_Msg_Name_1 /= Canonical_Path_Name then
+                  Error_Msg
+                    ("\  { which itself is imported by", Token_Ptr);
+
+               else
+                  Error_Msg ("\  {", Token_Ptr);
+                  exit;
+               end if;
+            end loop;
+
+            Project := Empty_Node;
+            return;
+         end if;
+      end loop;
+
+      Project_Stack.Increment_Last;
+      Project_Stack.Table (Project_Stack.Last) := Canonical_Path_Name;
+
+      --  Check if the project file has already been parsed.
+
+      while
+        A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
+      loop
+         if
+           Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
+         then
+            if Modified then
+
+               if A_Project_Name_And_Node.Modified then
+                  Error_Msg
+                    ("cannot modify several times the same project file",
+                     Token_Ptr);
+
+               else
+                  Error_Msg
+                    ("cannot modify an imported project file",
+                     Token_Ptr);
+               end if;
+
+            elsif A_Project_Name_And_Node.Modified then
+               Error_Msg
+                 ("cannot imported a modified project file",
+                  Token_Ptr);
+            end if;
+
+            Project := A_Project_Name_And_Node.Node;
+            Project_Stack.Decrement_Last;
+            return;
+         end if;
+
+         A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
+      end loop;
+
+      --  We never encountered this project file
+      --  Save the scan state, load the project file and start to scan it.
+
+      Save_Project_Scan_State (Project_Scan_State);
+      Source_Index := Load_Project_File (Path_Name);
+
+      --  if we cannot find it, we stop
+
+      if Source_Index = No_Source_File then
+         Project := Empty_Node;
+         Project_Stack.Decrement_Last;
+         return;
+      end if;
+
+      Initialize_Scanner (Types.No_Unit, Source_Index);
+
+      if Name_From_Path = No_Name then
+
+         --  The project file name is not correct (no or bad extension,
+         --  or not following Ada identifier's syntax).
+
+         Error_Msg_Name_1 := Canonical_Path_Name;
+         Error_Msg ("?{ is not a valid path name for a project file",
+                    Token_Ptr);
+      end if;
+
+      if Current_Verbosity >= Medium then
+         Write_Str  ("Parsing """);
+         Write_Str  (Path_Name);
+         Write_Char ('"');
+         Write_Eol;
+      end if;
+
+      Project_Directory := Immediate_Directory_Of (Canonical_Path_Name);
+      Project := Default_Project_Node (Of_Kind => N_Project);
+      Set_Directory_Of (Project, Project_Directory);
+      Set_Name_Of (Project, Simple_File_Name_Of (Canonical_Path_Name));
+      Set_Path_Name_Of (Project, Canonical_Path_Name);
+      Set_Location_Of (Project, Token_Ptr);
+
+      --  Is there any imported project?
+
+      declare
+         First_With_Clause : Project_Node_Id := Empty_Node;
+
+      begin
+         Parse_Context_Clause (Context_Clause    => First_With_Clause,
+                               Project_Directory => Project_Directory);
+         Set_First_With_Clause_Of (Project, First_With_Clause);
+      end;
+
+      Expect (Tok_Project, "project");
+
+      --  Scan past "project"
+
+      if Token = Tok_Project then
+         Set_Location_Of (Project, Token_Ptr);
+         Scan;
+      end if;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Project, Token_Name);
+
+         Get_Name_String (Token_Name);
+         Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+         declare
+            Expected_Name : constant Name_Id := Name_Find;
+
+         begin
+            if Name_From_Path /= No_Name
+              and then Expected_Name /= Name_From_Path
+            then
+               --  The project name is not the one that was expected from
+               --  the file name. Report a warning.
+
+               Error_Msg_Name_1 := Expected_Name;
+               Error_Msg ("?file name does not match unit name, " &
+                          "should be `{" & Project_File_Extension & "`",
+                          Token_Ptr);
+            end if;
+         end;
+
+         declare
+            Project_Name : Name_Id :=
+                             Tree_Private_Part.Projects_Htable.Get_First.Name;
+
+         begin
+            --  Check if we already have a project with this name
+
+            while Project_Name /= No_Name
+              and then Project_Name /= Token_Name
+            loop
+               Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
+            end loop;
+
+            if Project_Name /= No_Name then
+               Error_Msg ("duplicate project name", Token_Ptr);
+
+            else
+               Tree_Private_Part.Projects_Htable.Set
+                 (K => Token_Name,
+                  E => (Name     => Token_Name,
+                        Node     => Project,
+                        Modified => Modified));
+            end if;
+         end;
+
+         --  Scan past the project name
+
+         Scan;
+
+      end if;
+
+      if Token = Tok_Modifying then
+
+         --  We are modifying another project
+
+         --  Scan past "modifying"
+
+         Scan;
+
+         Expect (Tok_String_Literal, "literal string");
+
+         if Token = Tok_String_Literal then
+            Set_Modified_Project_Path_Of (Project, Strval (Token_Node));
+            String_To_Name_Buffer (Modified_Project_Path_Of (Project));
+
+            declare
+               Original_Path_Name : constant String :=
+                                      Name_Buffer (1 .. Name_Len);
+
+               Modified_Project_Path_Name : constant String :=
+                                              Project_Path_Name_Of
+                                                (Original_Path_Name,
+                                                   Get_Name_String
+                                                     (Project_Directory));
+
+            begin
+               if Modified_Project_Path_Name = "" then
+
+                  --  We could not find the project file to modify
+
+                  Name_Len := Original_Path_Name'Length;
+                  Name_Buffer (1 .. Name_Len) := Original_Path_Name;
+                  Error_Msg_Name_1 := Name_Find;
+
+                  Error_Msg ("unknown project file: {", Token_Ptr);
+
+               else
+                  Parse_Single_Project
+                    (Project   => Modified_Project,
+                     Path_Name => Modified_Project_Path_Name,
+                     Modified  => True);
+               end if;
+            end;
+
+            --  Scan past the modified project path
+
+            Scan;
+         end if;
+      end if;
+
+      Expect (Tok_Is, "is");
+
+      declare
+         Project_Declaration : Project_Node_Id := Empty_Node;
+
+      begin
+         --  No need to Scan past "is", Prj.Dect.Parse will do it.
+
+         Prj.Dect.Parse
+           (Declarations    => Project_Declaration,
+            Current_Project => Project,
+            Modifying       => Modified_Project);
+         Set_Project_Declaration_Of (Project, Project_Declaration);
+      end;
+
+      Expect (Tok_End, "end");
+
+      --  Scan past "end"
+
+      if Token = Tok_End then
+         Scan;
+      end if;
+
+      Expect (Tok_Identifier, "identifier");
+
+      if Token = Tok_Identifier then
+
+         --  We check if this is the project name
+
+         if To_Lower (Get_Name_String (Token_Name)) /=
+            Get_Name_String (Name_Of (Project))
+         then
+            Error_Msg ("Expected """ &
+                       Get_Name_String (Name_Of (Project)) & """",
+                       Token_Ptr);
+         end if;
+      end if;
+
+      if Token /= Tok_Semicolon then
+         Scan;
+      end if;
+
+      Expect (Tok_Semicolon, ";");
+
+      --  Restore the scan state, in case we are not the main project
+
+      Restore_Project_Scan_State (Project_Scan_State);
+
+      Project_Stack.Decrement_Last;
+   end Parse_Single_Project;
+
+   ------------------
+   -- Path_Name_Of --
+   ------------------
+
+   function Path_Name_Of
+     (File_Name : String;
+      Directory : String)
+      return      String
+   is
+      Result : String_Access;
+
+   begin
+      Result := Locate_Regular_File (File_Name => File_Name,
+                                     Path      => Directory);
+
+      if Result = null then
+         return "";
+
+      else
+         Canonical_Case_File_Name (Result.all);
+         return Result.all;
+      end if;
+   end Path_Name_Of;
+
+   -----------------------
+   -- Project_Name_From --
+   -----------------------
+
+   function Project_Name_From (Path_Name : String) return Name_Id is
+      Canonical : String (1 .. Path_Name'Length) := Path_Name;
+      First : Natural  := Canonical'Last;
+      Last  : Positive := First;
+
+   begin
+      if First = 0 then
+         return No_Name;
+      end if;
+
+      Canonical_Case_File_Name (Canonical);
+
+      while First > 0
+        and then
+        Canonical (First) /= '.'
+      loop
+         First := First - 1;
+      end loop;
+
+      if Canonical (First) = '.' then
+         if Canonical (First .. Last) = Project_File_Extension
+           and then First /= 1
+         then
+            First := First - 1;
+            Last := First;
+
+            while First > 0
+              and then Canonical (First) /= '/'
+              and then Canonical (First) /= Dir_Sep
+            loop
+               First := First - 1;
+            end loop;
+
+         else
+            return No_Name;
+         end if;
+
+      else
+         return No_Name;
+      end if;
+
+      if Canonical (First) = '/'
+        or else Canonical (First) = Dir_Sep
+      then
+         First := First + 1;
+      end if;
+
+      Name_Len := Last - First + 1;
+      Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
+
+      if not Is_Letter (Name_Buffer (1)) then
+         return No_Name;
+
+      else
+         for Index in 2 .. Name_Len - 1 loop
+            if Name_Buffer (Index) = '_' then
+               if Name_Buffer (Index + 1) = '_' then
+                  return No_Name;
+               end if;
+
+            elsif not Is_Alphanumeric (Name_Buffer (Index)) then
+               return No_Name;
+            end if;
+
+         end loop;
+
+         if not Is_Alphanumeric (Name_Buffer (Name_Len)) then
+            return No_Name;
+
+         else
+            return Name_Find;
+         end if;
+
+      end if;
+   end Project_Name_From;
+
+   --------------------------
+   -- Project_Path_Name_Of --
+   --------------------------
+
+   function Project_Path_Name_Of
+     (Project_File_Name : String;
+      Directory         : String)
+      return              String
+   is
+      Result : String_Access;
+
+   begin
+      --  First we try <file_name>.<extension>
+
+      if Current_Verbosity = High then
+         Write_Str  ("Project_Path_Name_Of (""");
+         Write_Str  (Project_File_Name);
+         Write_Str  (""", """);
+         Write_Str  (Directory);
+         Write_Line (""");");
+         Write_Str  ("   Trying ");
+         Write_Str (Project_File_Name);
+         Write_Line (Project_File_Extension);
+      end if;
+
+      Result :=
+        Locate_Regular_File
+          (File_Name => Project_File_Name & Project_File_Extension,
+           Path      => Project_Path.all);
+
+      --  Then we try <file_name>
+
+      if Result = null then
+         if Current_Verbosity = High then
+            Write_Str  ("   Trying ");
+            Write_Line  (Project_File_Name);
+         end if;
+
+         Result :=
+           Locate_Regular_File
+           (File_Name => Project_File_Name,
+            Path      => Project_Path.all);
+
+         --  The we try <directory>/<file_name>.<extension>
+
+         if Result = null then
+            if Current_Verbosity = High then
+               Write_Str  ("   Trying ");
+               Write_Str  (Directory);
+               Write_Str (Project_File_Name);
+               Write_Line (Project_File_Extension);
+            end if;
+
+            Result :=
+              Locate_Regular_File
+              (File_Name => Directory & Project_File_Name &
+                            Project_File_Extension,
+               Path      => Project_Path.all);
+
+            --  Then we try <directory>/<file_name>
+
+            if Result = null then
+               if Current_Verbosity = High then
+                  Write_Str  ("   Trying ");
+                  Write_Str  (Directory);
+                  Write_Line  (Project_File_Name);
+               end if;
+
+               Result :=
+                 Locate_Regular_File
+                 (File_Name => Directory & Project_File_Name,
+                  Path      => Project_Path.all);
+            end if;
+         end if;
+      end if;
+
+      --  If we cannot find the project file, we return an empty string
+
+      if Result = null then
+         return "";
+
+      else
+         declare
+            Final_Result : String
+              := GNAT.OS_Lib.Normalize_Pathname (Result.all);
+         begin
+            Free (Result);
+            Canonical_Case_File_Name (Final_Result);
+            return Final_Result;
+         end;
+
+      end if;
+
+   end Project_Path_Name_Of;
+
+   -------------------------
+   -- Simple_File_Name_Of --
+   -------------------------
+
+   function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id is
+   begin
+      Get_Name_String (Path_Name);
+
+      for Index in reverse 1 .. Name_Len loop
+         if Name_Buffer (Index) = '/'
+           or else Name_Buffer (Index) = Dir_Sep
+         then
+            exit when Index = Name_Len;
+            Name_Buffer (1 .. Name_Len - Index) :=
+              Name_Buffer (Index + 1 .. Name_Len);
+            Name_Len := Name_Len - Index;
+            return Name_Find;
+         end if;
+      end loop;
+
+      return No_Name;
+
+   end Simple_File_Name_Of;
+
+begin
+   Canonical_Case_File_Name (Project_File_Extension);
+
+   if Prj_Path.all = "" then
+      Project_Path := new String'(".");
+
+   else
+      Project_Path := new String'("." & Path_Separator & Prj_Path.all);
+   end if;
+
+end Prj.Part;
diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads
new file mode 100644
index 0000000..d960b73
--- /dev/null
+++ b/gcc/ada/prj-part.ads
@@ -0,0 +1,46 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P A R T                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.3 $
+--                                                                          --
+--          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Implements the parsing of project files into a tree.
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Part is
+
+   procedure Parse
+     (Project                : out Project_Node_Id;
+      Project_File_Name      : String;
+      Always_Errout_Finalize : Boolean);
+   --  Parse a project file and all its imported project files
+   --  and create a tree.
+   --  Return the node for the project (or Empty_Node if parsing failed).
+   --  If Always_Errout_Finalize is True, Errout.Finalize is called
+   --  in all cases; otherwise, Errout.Finalize is only called if there are
+   --  errors (but not if there are only warnings).
+
+end Prj.Part;
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
new file mode 100644
index 0000000..4822596
--- /dev/null
+++ b/gcc/ada/prj-proc.adb
@@ -0,0 +1,1371 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P R O C                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Errout;   use Errout;
+with Namet;    use Namet;
+with Opt;
+with Output;   use Output;
+with Prj.Attr; use Prj.Attr;
+with Prj.Com;  use Prj.Com;
+with Prj.Ext;  use Prj.Ext;
+with Prj.Nmsc; use Prj.Nmsc;
+with Stringt;  use Stringt;
+
+with GNAT.HTable;
+
+package body Prj.Proc is
+
+   Error_Report : Put_Line_Access := null;
+
+   package Processed_Projects is new GNAT.HTable.Simple_HTable
+     (Header_Num => Header_Num,
+      Element    => Project_Id,
+      No_Element => No_Project,
+      Key        => Name_Id,
+      Hash       => Hash,
+      Equal      => "=");
+   --  This hash table contains all processed projects
+
+   procedure Add (To_Exp : in out String_Id; Str : String_Id);
+   --  Concatenate two strings and returns another string if both
+   --  arguments are not null string.
+
+   procedure Add_Attributes
+     (Decl     : in out Declarations;
+      First    : Attribute_Node_Id);
+   --  Add all attributes, starting with First, with their default
+   --  values to the package or project with declarations Decl.
+
+   function Expression
+     (Project           : Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Pkg               : Package_Id;
+      First_Term        : Project_Node_Id;
+      Kind              : Variable_Kind)
+      return              Variable_Value;
+   --  From N_Expression project node From_Project_Node, compute the value
+   --  of an expression and return it as a Variable_Value.
+
+   function Imported_Or_Modified_Project_From
+     (Project   : Project_Id;
+      With_Name : Name_Id)
+     return Project_Id;
+   --  Find an imported or modified project of Project whose name is With_Name.
+
+   function Package_From
+     (Project   : Project_Id;
+      With_Name : Name_Id)
+      return      Package_Id;
+   --  Find the package of Project whose name is With_Name.
+
+   procedure Process_Declarative_Items
+     (Project           : Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Pkg               : Package_Id;
+      Item              : Project_Node_Id);
+   --  Process declarative items starting with From_Project_Node, and put them
+   --  in declarations Decl. This is a recursive procedure; it calls itself for
+   --  a package declaration or a case construction.
+
+   procedure Recursive_Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Modified_By       : Project_Id);
+   --  Process project with node From_Project_Node in the tree.
+   --  Do nothing if From_Project_Node is Empty_Node.
+   --  If project has already been processed, simply return its project id.
+   --  Otherwise create a new project id, mark it as processed, call itself
+   --  recursively for all imported projects and a modified project, if any.
+   --  Then process the declarative items of the project.
+
+   procedure Check (Project : in out Project_Id);
+   --  Set all projects to not checked, then call Recursive_Check for
+   --  the main project Project.
+   --  Project is set to No_Project if errors occurred.
+
+   procedure Recursive_Check (Project : Project_Id);
+   --  If Project is marked as not checked, mark it as checked,
+   --  call Check_Naming_Scheme for the project, then call itself
+   --  for a possible modified project and all the imported projects
+   --  of Project.
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add (To_Exp : in out String_Id; Str : String_Id) is
+   begin
+      if To_Exp = Types.No_String or else String_Length (To_Exp) = 0 then
+
+         --  To_Exp is nil or empty. The result is Str.
+
+         To_Exp := Str;
+
+      --  If Str is nil, then do not change To_Ext
+
+      elsif Str /= No_String then
+         Start_String (To_Exp);
+         Store_String_Chars (Str);
+         To_Exp := End_String;
+      end if;
+   end Add;
+
+   --------------------
+   -- Add_Attributes --
+   --------------------
+
+   procedure Add_Attributes
+     (Decl           : in out Declarations;
+      First          : Attribute_Node_Id) is
+      The_Attribute  : Attribute_Node_Id := First;
+      Attribute_Data : Attribute_Record;
+
+   begin
+      while The_Attribute /= Empty_Attribute loop
+         Attribute_Data := Attributes.Table (The_Attribute);
+
+         if Attribute_Data.Kind_2 /= Associative_Array then
+            declare
+               New_Attribute : Variable_Value;
+
+            begin
+               case Attribute_Data.Kind_1 is
+
+                  --  Undefined should not happen
+
+                  when Undefined =>
+                     pragma Assert
+                       (False, "attribute with an undefined kind");
+                     raise Program_Error;
+
+                  --  Single attributes have a default value of empty string
+
+                  when Single =>
+                     New_Attribute :=
+                       (Kind     => Single,
+                        Location => No_Location,
+                        Default  => True,
+                        Value    => Empty_String);
+
+                  --  List attributes have a default value of nil list
+
+                  when List =>
+                     New_Attribute :=
+                       (Kind     => List,
+                        Location => No_Location,
+                        Default  => True,
+                        Values   => Nil_String);
+
+               end case;
+
+               Variable_Elements.Increment_Last;
+               Variable_Elements.Table (Variable_Elements.Last) :=
+                 (Next  => Decl.Attributes,
+                  Name  => Attribute_Data.Name,
+                  Value => New_Attribute);
+               Decl.Attributes := Variable_Elements.Last;
+            end;
+         end if;
+
+         The_Attribute := Attributes.Table (The_Attribute).Next;
+      end loop;
+
+   end Add_Attributes;
+
+   -----------
+   -- Check --
+   -----------
+
+   procedure Check (Project : in out Project_Id) is
+   begin
+      --  Make sure that all projects are marked as not checked.
+
+      for Index in 1 .. Projects.Last loop
+         Projects.Table (Index).Checked := False;
+      end loop;
+
+      Recursive_Check (Project);
+
+      if Errout.Errors_Detected > 0 then
+         Project := No_Project;
+      end if;
+
+   end Check;
+
+   ----------------
+   -- Expression --
+   ----------------
+
+   function Expression
+     (Project           : Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Pkg               : Package_Id;
+      First_Term        : Project_Node_Id;
+      Kind              : Variable_Kind)
+      return              Variable_Value
+   is
+      The_Term : Project_Node_Id := First_Term;
+      --  The term in the expression list
+
+      The_Current_Term : Project_Node_Id := Empty_Node;
+      --  The current term node id
+
+      Term_Kind : Variable_Kind;
+      --  The kind of the current term
+
+      Result : Variable_Value (Kind => Kind);
+      --  The returned result
+
+      Last : String_List_Id := Nil_String;
+      --  Reference to the last string elements in Result, when Kind is List.
+
+   begin
+      Result.Location := Location_Of (From_Project_Node);
+
+      --  Process each term of the expression, starting with First_Term
+
+      while The_Term /= Empty_Node loop
+
+         --  We get the term data and kind ...
+
+         Term_Kind := Expression_Kind_Of (The_Term);
+
+         The_Current_Term := Current_Term (The_Term);
+
+         case Kind_Of (The_Current_Term) is
+
+            when N_Literal_String =>
+
+               case Kind is
+
+                  when Undefined =>
+
+                     --  Should never happen
+
+                     pragma Assert (False, "Undefined expression kind");
+                     raise Program_Error;
+
+                  when Single =>
+                     Add (Result.Value, String_Value_Of (The_Current_Term));
+
+                  when List =>
+
+                     String_Elements.Increment_Last;
+
+                     if Last = Nil_String then
+
+                        --  This can happen in an expression such as
+                        --  () & "toto"
+
+                        Result.Values := String_Elements.Last;
+
+                     else
+                        String_Elements.Table (Last).Next :=
+                          String_Elements.Last;
+                     end if;
+
+                     Last := String_Elements.Last;
+                     String_Elements.Table (Last) :=
+                       (Value    => String_Value_Of (The_Current_Term),
+                        Location => Location_Of (The_Current_Term),
+                        Next     => Nil_String);
+
+               end case;
+
+            when N_Literal_String_List =>
+
+               declare
+                  String_Node : Project_Node_Id :=
+                                  First_Expression_In_List (The_Current_Term);
+
+                  Value : Variable_Value;
+
+               begin
+                  if String_Node /= Empty_Node then
+
+                     --  If String_Node is nil, it is an empty list,
+                     --  there is nothing to do
+
+                     Value := Expression
+                       (Project           => Project,
+                        From_Project_Node => From_Project_Node,
+                        Pkg               => Pkg,
+                        First_Term        => Tree.First_Term (String_Node),
+                        Kind              => Single);
+                     String_Elements.Increment_Last;
+
+                     if Result.Values = Nil_String then
+
+                        --  This literal string list is the first term
+                        --  in a string list expression
+
+                        Result.Values := String_Elements.Last;
+
+                     else
+                        String_Elements.Table (Last).Next :=
+                          String_Elements.Last;
+                     end if;
+
+                     Last := String_Elements.Last;
+                     String_Elements.Table (Last) :=
+                       (Value    => Value.Value,
+                        Location => Value.Location,
+                        Next     => Nil_String);
+
+                     loop
+                        --  Add the other element of the literal string list
+                        --  one after the other
+
+                        String_Node :=
+                          Next_Expression_In_List (String_Node);
+
+                        exit when String_Node = Empty_Node;
+
+                        Value :=
+                          Expression
+                          (Project           => Project,
+                           From_Project_Node => From_Project_Node,
+                           Pkg               => Pkg,
+                           First_Term        => Tree.First_Term (String_Node),
+                           Kind              => Single);
+
+                        String_Elements.Increment_Last;
+                        String_Elements.Table (Last).Next :=
+                          String_Elements.Last;
+                        Last := String_Elements.Last;
+                        String_Elements.Table (Last) :=
+                          (Value    => Value.Value,
+                           Location => Value.Location,
+                           Next     => Nil_String);
+                     end loop;
+
+                  end if;
+
+               end;
+
+            when N_Variable_Reference | N_Attribute_Reference =>
+
+               declare
+                  The_Project     : Project_Id  := Project;
+                  The_Package     : Package_Id  := Pkg;
+                  The_Name        : Name_Id     := No_Name;
+                  The_Variable_Id : Variable_Id := No_Variable;
+                  The_Variable    : Variable;
+                  Term_Project    : constant Project_Node_Id :=
+                                      Project_Node_Of (The_Current_Term);
+                  Term_Package    : constant Project_Node_Id :=
+                                      Package_Node_Of (The_Current_Term);
+
+               begin
+                  if Term_Project /= Empty_Node and then
+                     Term_Project /= From_Project_Node
+                  then
+                     --  This variable or attribute comes from another project
+
+                     The_Name := Name_Of (Term_Project);
+                     The_Project := Imported_Or_Modified_Project_From
+                       (Project => Project, With_Name => The_Name);
+                  end if;
+
+                  if Term_Package /= Empty_Node then
+
+                     --  This is an attribute of a package
+
+                     The_Name := Name_Of (Term_Package);
+                     The_Package := Projects.Table (The_Project).Decl.Packages;
+
+                     while The_Package /= No_Package
+                       and then Packages.Table (The_Package).Name /= The_Name
+                     loop
+                        The_Package := Packages.Table (The_Package).Next;
+                     end loop;
+
+                     pragma Assert
+                       (The_Package /= No_Package,
+                        "package not found.");
+
+                  elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then
+                     The_Package := No_Package;
+                  end if;
+
+                  The_Name := Name_Of (The_Current_Term);
+
+                  if The_Package /= No_Package then
+
+                     --  First, if there is a package, look into the package
+
+                     if Kind_Of (The_Current_Term) = N_Variable_Reference then
+                        The_Variable_Id :=
+                          Packages.Table (The_Package).Decl.Variables;
+
+                     else
+                        The_Variable_Id :=
+                          Packages.Table (The_Package).Decl.Attributes;
+                     end if;
+
+                     while The_Variable_Id /= No_Variable
+                       and then
+                         Variable_Elements.Table (The_Variable_Id).Name /=
+                                                                    The_Name
+                     loop
+                        The_Variable_Id :=
+                          Variable_Elements.Table (The_Variable_Id).Next;
+                     end loop;
+
+                  end if;
+
+                  if The_Variable_Id = No_Variable then
+
+                     --  If we have not found it, look into the project
+
+                     if Kind_Of (The_Current_Term) = N_Variable_Reference then
+                        The_Variable_Id :=
+                          Projects.Table (The_Project).Decl.Variables;
+
+                     else
+                        The_Variable_Id :=
+                          Projects.Table (The_Project).Decl.Attributes;
+                     end if;
+
+                     while The_Variable_Id /= No_Variable
+                       and then
+                         Variable_Elements.Table (The_Variable_Id).Name /=
+                                                                     The_Name
+                     loop
+                        The_Variable_Id :=
+                          Variable_Elements.Table (The_Variable_Id).Next;
+                     end loop;
+
+                  end if;
+
+                  pragma Assert (The_Variable_Id /= No_Variable,
+                                 "variable or attribute not found");
+
+                  The_Variable := Variable_Elements.Table (The_Variable_Id);
+
+                  case Kind is
+
+                     when Undefined =>
+
+                        --  Should never happen
+
+                        pragma Assert (False, "undefined expression kind");
+                        null;
+
+                     when Single =>
+
+                        case The_Variable.Value.Kind is
+
+                           when Undefined =>
+                              null;
+
+                           when Single =>
+                              Add (Result.Value, The_Variable.Value.Value);
+
+                           when List =>
+
+                              --  Should never happen
+
+                              pragma Assert
+                                (False,
+                                 "list cannot appear in single " &
+                                 "string expression");
+                              null;
+
+                        end case;
+
+                     when List =>
+                        case The_Variable.Value.Kind is
+
+                           when Undefined =>
+                              null;
+
+                           when Single =>
+                              String_Elements.Increment_Last;
+
+                              if Last = Nil_String then
+
+                                 --  This can happen in an expression such as
+                                 --  () & Var
+
+                                 Result.Values := String_Elements.Last;
+
+                              else
+                                 String_Elements.Table (Last).Next :=
+                                   String_Elements.Last;
+                              end if;
+
+                              Last := String_Elements.Last;
+                              String_Elements.Table (Last) :=
+                                (Value    => The_Variable.Value.Value,
+                                 Location => Location_Of (The_Current_Term),
+                                 Next     => Nil_String);
+
+                           when List =>
+
+                              declare
+                                 The_List : String_List_Id :=
+                                              The_Variable.Value.Values;
+
+                              begin
+                                 while The_List /= Nil_String loop
+                                    String_Elements.Increment_Last;
+
+                                    if Last = Nil_String then
+                                       Result.Values := String_Elements.Last;
+
+                                    else
+                                       String_Elements.Table (Last).Next :=
+                                         String_Elements.Last;
+
+                                    end if;
+
+                                    Last := String_Elements.Last;
+                                    String_Elements.Table (Last) :=
+                                      (Value    =>
+                                         String_Elements.Table
+                                                          (The_List).Value,
+                                       Location => Location_Of
+                                                          (The_Current_Term),
+                                       Next     => Nil_String);
+                                    The_List :=
+                                      String_Elements.Table (The_List).Next;
+
+                                 end loop;
+                              end;
+                        end case;
+                  end case;
+               end;
+
+            when N_External_Value =>
+               String_To_Name_Buffer
+                 (String_Value_Of (External_Reference_Of (The_Current_Term)));
+
+               declare
+                  Name    : constant Name_Id  := Name_Find;
+                  Default : String_Id         := No_String;
+                  Value   : String_Id         := No_String;
+
+                  Default_Node : constant Project_Node_Id :=
+                                   External_Default_Of (The_Current_Term);
+
+               begin
+                  if Default_Node /= Empty_Node then
+                     Default := String_Value_Of (Default_Node);
+                  end if;
+
+                  Value := Prj.Ext.Value_Of (Name, Default);
+
+                  if Value = No_String then
+                     if Error_Report = null then
+                        Error_Msg
+                          ("undefined external reference",
+                           Location_Of (The_Current_Term));
+
+                     else
+                        Error_Report
+                          ("""" & Get_Name_String (Name) &
+                           """ is an undefined external reference");
+                     end if;
+
+                     Value := Empty_String;
+
+                  end if;
+
+                  case Kind is
+
+                     when Undefined =>
+                        null;
+
+                     when Single =>
+                        Add (Result.Value, Value);
+
+                     when List =>
+                        String_Elements.Increment_Last;
+
+                        if Last = Nil_String then
+                           Result.Values := String_Elements.Last;
+
+                        else
+                           String_Elements.Table (Last).Next :=
+                             String_Elements.Last;
+                        end if;
+
+                        Last := String_Elements.Last;
+                        String_Elements.Table (Last) :=
+                          (Value    => Value,
+                           Location => Location_Of (The_Current_Term),
+                           Next     => Nil_String);
+
+                  end case;
+
+               end;
+
+            when others =>
+
+               --  Should never happen
+
+               pragma Assert
+                 (False,
+                  "illegal node kind in an expression");
+               raise Program_Error;
+
+         end case;
+
+         The_Term := Next_Term (The_Term);
+
+      end loop;
+      return Result;
+   end Expression;
+
+   ---------------------------------------
+   -- Imported_Or_Modified_Project_From --
+   ---------------------------------------
+
+   function Imported_Or_Modified_Project_From
+     (Project   : Project_Id;
+      With_Name : Name_Id)
+      return      Project_Id
+   is
+      Data : constant Project_Data := Projects.Table (Project);
+      List : Project_List          := Data.Imported_Projects;
+
+   begin
+      --  First check if it is the name of a modified project
+
+      if Data.Modifies /= No_Project
+        and then Projects.Table (Data.Modifies).Name = With_Name
+      then
+         return Data.Modifies;
+
+      else
+         --  Then check the name of each imported project
+
+         while List /= Empty_Project_List
+           and then
+             Projects.Table
+               (Project_Lists.Table (List).Project).Name /= With_Name
+
+         loop
+            List := Project_Lists.Table (List).Next;
+         end loop;
+
+         pragma Assert
+           (List /= Empty_Project_List,
+           "project not found");
+
+         return Project_Lists.Table (List).Project;
+      end if;
+
+   end Imported_Or_Modified_Project_From;
+
+   ------------------
+   -- Package_From --
+   ------------------
+
+   function Package_From
+     (Project   : Project_Id;
+      With_Name : Name_Id)
+      return      Package_Id
+   is
+      Data   : constant Project_Data := Projects.Table (Project);
+      Result : Package_Id := Data.Decl.Packages;
+
+   begin
+      --  Check the name of each existing package of Project
+
+      while Result /= No_Package
+        and then
+        Packages.Table (Result).Name /= With_Name
+      loop
+         Result := Packages.Table (Result).Next;
+      end loop;
+
+      if Result = No_Package then
+         --  Should never happen
+         Write_Line ("package """ & Get_Name_String (With_Name) &
+                     """ not found");
+         raise Program_Error;
+
+      else
+         return Result;
+      end if;
+   end Package_From;
+
+   -------------
+   -- Process --
+   -------------
+
+   procedure Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Report_Error      : Put_Line_Access)
+   is
+   begin
+      Error_Report := Report_Error;
+
+      --  Make sure there is no projects in the data structure
+
+      Projects.Set_Last (No_Project);
+      Processed_Projects.Reset;
+
+      --  And process the main project and all of the projects it depends on,
+      --  recursively
+
+      Recursive_Process
+        (Project           => Project,
+         From_Project_Node => From_Project_Node,
+         Modified_By       => No_Project);
+
+      if Errout.Errors_Detected > 0 then
+         Project := No_Project;
+      end if;
+
+      if Project /= No_Project then
+         Check (Project);
+      end if;
+
+   end Process;
+
+   -------------------------------
+   -- Process_Declarative_Items --
+   -------------------------------
+
+   procedure Process_Declarative_Items
+     (Project           : Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Pkg               : Package_Id;
+      Item              : Project_Node_Id) is
+
+      Current_Declarative_Item : Project_Node_Id := Item;
+
+      Current_Item : Project_Node_Id := Empty_Node;
+
+   begin
+      --  For each declarative item
+
+      while Current_Declarative_Item /= Empty_Node loop
+
+         --  Get its data
+
+         Current_Item := Current_Item_Node (Current_Declarative_Item);
+
+         --  And set Current_Declarative_Item to the next declarative item
+         --  ready for the next iteration
+
+         Current_Declarative_Item := Next_Declarative_Item
+                                            (Current_Declarative_Item);
+
+         case Kind_Of (Current_Item) is
+
+            when N_Package_Declaration =>
+               Packages.Increment_Last;
+
+               declare
+                  New_Pkg         : constant Package_Id := Packages.Last;
+                  The_New_Package : Package_Element;
+
+                  Project_Of_Renamed_Package : constant Project_Node_Id :=
+                                                 Project_Of_Renamed_Package_Of
+                                                   (Current_Item);
+
+               begin
+                  The_New_Package.Name := Name_Of (Current_Item);
+
+                  if Pkg /= No_Package then
+                     The_New_Package.Next :=
+                       Packages.Table (Pkg).Decl.Packages;
+                     Packages.Table (Pkg).Decl.Packages := New_Pkg;
+                  else
+                     The_New_Package.Next :=
+                       Projects.Table (Project).Decl.Packages;
+                     Projects.Table (Project).Decl.Packages := New_Pkg;
+                  end if;
+
+                  Packages.Table (New_Pkg) := The_New_Package;
+
+                  if Project_Of_Renamed_Package /= Empty_Node then
+
+                     --  Renamed package
+
+                     declare
+                        Project_Name : constant Name_Id :=
+                                         Name_Of
+                                           (Project_Of_Renamed_Package);
+
+                        Renamed_Project : constant Project_Id :=
+                                            Imported_Or_Modified_Project_From
+                                              (Project, Project_Name);
+
+                        Renamed_Package : constant Package_Id :=
+                                            Package_From
+                                              (Renamed_Project,
+                                               Name_Of (Current_Item));
+
+                     begin
+                        Packages.Table (New_Pkg).Decl :=
+                          Packages.Table (Renamed_Package).Decl;
+                     end;
+
+                  else
+                     --  Set the default values of the attributes
+
+                     Add_Attributes
+                       (Packages.Table (New_Pkg).Decl,
+                        Package_Attributes.Table
+                           (Package_Id_Of (Current_Item)).First_Attribute);
+
+                     Process_Declarative_Items
+                       (Project           => Project,
+                        From_Project_Node => From_Project_Node,
+                        Pkg               => New_Pkg,
+                        Item              => First_Declarative_Item_Of
+                                                             (Current_Item));
+                  end if;
+
+               end;
+
+            when N_String_Type_Declaration =>
+
+               --  There is nothing to process
+
+               null;
+
+            when N_Attribute_Declaration      |
+                 N_Typed_Variable_Declaration |
+                 N_Variable_Declaration       =>
+
+                  pragma Assert (Expression_Of (Current_Item) /= Empty_Node,
+                                 "no expression for an object declaration");
+
+               declare
+                  New_Value : constant Variable_Value :=
+                                Expression
+                                  (Project           => Project,
+                                   From_Project_Node => From_Project_Node,
+                                   Pkg               => Pkg,
+                                   First_Term        =>
+                                     Tree.First_Term (Expression_Of
+                                                              (Current_Item)),
+                                   Kind              =>
+                                     Expression_Kind_Of (Current_Item));
+
+                  The_Variable : Variable_Id := No_Variable;
+
+                  Current_Item_Name : constant Name_Id :=
+                                        Name_Of (Current_Item);
+
+               begin
+                  if Kind_Of (Current_Item) = N_Typed_Variable_Declaration then
+
+                     if String_Equal (New_Value.Value, Empty_String) then
+                        Error_Msg_Name_1 := Name_Of (Current_Item);
+
+                        if Error_Report = null then
+                           Error_Msg
+                             ("no value defined for %",
+                              Location_Of (Current_Item));
+
+                        else
+                           Error_Report
+                             ("no value defined for " &
+                              Get_Name_String (Error_Msg_Name_1));
+                        end if;
+
+                     else
+                        declare
+                           Current_String : Project_Node_Id :=
+                                              First_Literal_String
+                                                (String_Type_Of
+                                                  (Current_Item));
+
+                        begin
+                           while Current_String /= Empty_Node
+                             and then not String_Equal
+                                            (String_Value_Of (Current_String),
+                                             New_Value.Value)
+                           loop
+                              Current_String :=
+                                Next_Literal_String (Current_String);
+                           end loop;
+
+                           if Current_String = Empty_Node then
+                              String_To_Name_Buffer (New_Value.Value);
+                              Error_Msg_Name_1 := Name_Find;
+                              Error_Msg_Name_2 := Name_Of (Current_Item);
+
+                              if Error_Report = null then
+                                 Error_Msg
+                                   ("value { is illegal for typed string %",
+                                    Location_Of (Current_Item));
+
+                              else
+                                 Error_Report
+                                   ("value """ &
+                                    Get_Name_String (Error_Msg_Name_1) &
+                                    """ is illegal for typed string """ &
+                                    Get_Name_String (Error_Msg_Name_2) &
+                                    """");
+                              end if;
+                           end if;
+                        end;
+                     end if;
+                  end if;
+
+                  if Kind_Of (Current_Item) /= N_Attribute_Declaration
+                    or else
+                      Associative_Array_Index_Of (Current_Item) = No_String
+                  then
+                     --  Usual case
+
+                     --  Code below really needs more comments ???
+
+                     if Kind_Of (Current_Item) = N_Attribute_Declaration then
+                        if Pkg /= No_Package then
+                           The_Variable :=
+                             Packages.Table (Pkg).Decl.Attributes;
+
+                        else
+                           The_Variable :=
+                             Projects.Table (Project).Decl.Attributes;
+                        end if;
+
+                     else
+                        if Pkg /= No_Package then
+                           The_Variable :=
+                             Packages.Table (Pkg).Decl.Variables;
+
+                        else
+                           The_Variable :=
+                             Projects.Table (Project).Decl.Variables;
+                        end if;
+
+                     end if;
+
+                     while
+                       The_Variable /= No_Variable
+                         and then
+                           Variable_Elements.Table (The_Variable).Name /=
+                                                          Current_Item_Name
+                     loop
+                        The_Variable :=
+                          Variable_Elements.Table (The_Variable).Next;
+                     end loop;
+
+                     if The_Variable = No_Variable then
+                        pragma Assert
+                          (Kind_Of (Current_Item) /= N_Attribute_Declaration,
+                           "illegal attribute declaration");
+
+                        Variable_Elements.Increment_Last;
+                        The_Variable := Variable_Elements.Last;
+
+                        if Pkg /= No_Package then
+                           Variable_Elements.Table (The_Variable) :=
+                             (Next    =>
+                                Packages.Table (Pkg).Decl.Variables,
+                              Name    => Current_Item_Name,
+                              Value   => New_Value);
+                           Packages.Table (Pkg).Decl.Variables := The_Variable;
+
+                        else
+                           Variable_Elements.Table (The_Variable) :=
+                             (Next    =>
+                                Projects.Table (Project).Decl.Variables,
+                              Name    => Current_Item_Name,
+                              Value   => New_Value);
+                           Projects.Table (Project).Decl.Variables :=
+                             The_Variable;
+                        end if;
+
+                     else
+                        Variable_Elements.Table (The_Variable).Value :=
+                          New_Value;
+
+                     end if;
+
+                  else
+                     --  Associative array attribute
+
+                     String_To_Name_Buffer
+                       (Associative_Array_Index_Of (Current_Item));
+
+                     declare
+                        The_Array : Array_Id;
+
+                        The_Array_Element : Array_Element_Id :=
+                                              No_Array_Element;
+
+                        Index_Name : constant Name_Id := Name_Find;
+
+                     begin
+
+                        if Pkg /= No_Package then
+                           The_Array := Packages.Table (Pkg).Decl.Arrays;
+
+                        else
+                           The_Array := Projects.Table (Project).Decl.Arrays;
+                        end if;
+
+                        while
+                          The_Array /= No_Array
+                            and then Arrays.Table (The_Array).Name /=
+                                                           Current_Item_Name
+                        loop
+                           The_Array := Arrays.Table (The_Array).Next;
+                        end loop;
+
+                        if The_Array = No_Array then
+                           Arrays.Increment_Last;
+                           The_Array := Arrays.Last;
+
+                           if Pkg /= No_Package then
+                              Arrays.Table (The_Array) :=
+                                (Name  => Current_Item_Name,
+                                 Value => No_Array_Element,
+                                 Next  => Packages.Table (Pkg).Decl.Arrays);
+                              Packages.Table (Pkg).Decl.Arrays := The_Array;
+
+                           else
+                              Arrays.Table (The_Array) :=
+                                (Name  => Current_Item_Name,
+                                 Value => No_Array_Element,
+                                 Next  =>
+                                   Projects.Table (Project).Decl.Arrays);
+                              Projects.Table (Project).Decl.Arrays :=
+                                The_Array;
+                           end if;
+
+                        else
+                           The_Array_Element := Arrays.Table (The_Array).Value;
+                        end if;
+
+                        while The_Array_Element /= No_Array_Element
+                          and then
+                            Array_Elements.Table (The_Array_Element).Index /=
+                                                                  Index_Name
+                        loop
+                           The_Array_Element :=
+                             Array_Elements.Table (The_Array_Element).Next;
+                        end loop;
+
+                        if The_Array_Element = No_Array_Element then
+                           Array_Elements.Increment_Last;
+                           The_Array_Element := Array_Elements.Last;
+                           Array_Elements.Table (The_Array_Element) :=
+                             (Index  => Index_Name,
+                              Value  => New_Value,
+                              Next   => Arrays.Table (The_Array).Value);
+                           Arrays.Table (The_Array).Value := The_Array_Element;
+
+                        else
+                           Array_Elements.Table (The_Array_Element).Value :=
+                             New_Value;
+                        end if;
+                     end;
+                  end if;
+               end;
+
+            when N_Case_Construction =>
+               declare
+                  The_Project   : Project_Id      := Project;
+                  The_Package   : Package_Id      := Pkg;
+                  The_Variable  : Variable_Value  := Nil_Variable_Value;
+                  Case_Value    : String_Id       := No_String;
+                  Case_Item     : Project_Node_Id := Empty_Node;
+                  Choice_String : Project_Node_Id := Empty_Node;
+                  Decl_Item     : Project_Node_Id := Empty_Node;
+
+               begin
+                  declare
+                     Variable_Node : constant Project_Node_Id :=
+                                       Case_Variable_Reference_Of
+                                         (Current_Item);
+
+                     Var_Id : Variable_Id := No_Variable;
+                     Name   : Name_Id     := No_Name;
+
+                  begin
+                     if Project_Node_Of (Variable_Node) /= Empty_Node then
+                        Name := Name_Of (Project_Node_Of (Variable_Node));
+                        The_Project :=
+                          Imported_Or_Modified_Project_From (Project, Name);
+                     end if;
+
+                     if Package_Node_Of (Variable_Node) /= Empty_Node then
+                        Name := Name_Of (Package_Node_Of (Variable_Node));
+                        The_Package := Package_From (The_Project, Name);
+                     end if;
+
+                     Name := Name_Of (Variable_Node);
+
+                     if The_Package /= No_Package then
+                        Var_Id := Packages.Table (The_Package).Decl.Variables;
+                        Name := Name_Of (Variable_Node);
+                        while Var_Id /= No_Variable
+                          and then
+                            Variable_Elements.Table (Var_Id).Name /= Name
+                        loop
+                           Var_Id := Variable_Elements.Table (Var_Id).Next;
+                        end loop;
+                     end if;
+
+                     if Var_Id = No_Variable
+                       and then Package_Node_Of (Variable_Node) = Empty_Node
+                     then
+                        Var_Id := Projects.Table (The_Project).Decl.Variables;
+                        while Var_Id /= No_Variable
+                          and then
+                            Variable_Elements.Table (Var_Id).Name /= Name
+                        loop
+                           Var_Id := Variable_Elements.Table (Var_Id).Next;
+                        end loop;
+                     end if;
+
+                     if Var_Id = No_Variable then
+
+                        --  Should never happen
+
+                        Write_Line ("variable """ &
+                                    Get_Name_String (Name) &
+                                    """ not found");
+                        raise Program_Error;
+                     end if;
+
+                     The_Variable := Variable_Elements.Table (Var_Id).Value;
+
+                     if The_Variable.Kind /= Single then
+
+                        --  Should never happen
+
+                        Write_Line ("variable""" &
+                                    Get_Name_String (Name) &
+                                    """ is not a single string variable");
+                        raise Program_Error;
+                     end if;
+
+                     Case_Value := The_Variable.Value;
+                  end;
+
+                  Case_Item := First_Case_Item_Of (Current_Item);
+                  Case_Item_Loop :
+                     while Case_Item /= Empty_Node loop
+                        Choice_String := First_Choice_Of (Case_Item);
+
+                        if Choice_String = Empty_Node then
+                           Decl_Item := First_Declarative_Item_Of (Case_Item);
+                           exit Case_Item_Loop;
+                        end if;
+
+                        Choice_Loop :
+                           while Choice_String /= Empty_Node loop
+                              if String_Equal (Case_Value,
+                                               String_Value_Of (Choice_String))
+                              then
+                                 Decl_Item :=
+                                   First_Declarative_Item_Of (Case_Item);
+                                 exit Case_Item_Loop;
+                              end if;
+
+                              Choice_String :=
+                                Next_Literal_String (Choice_String);
+                           end loop Choice_Loop;
+                        Case_Item := Next_Case_Item (Case_Item);
+                     end loop Case_Item_Loop;
+
+                  if Decl_Item /= Empty_Node then
+                     Process_Declarative_Items
+                       (Project           => Project,
+                        From_Project_Node => From_Project_Node,
+                        Pkg               => Pkg,
+                        Item              => Decl_Item);
+                  end if;
+               end;
+
+            when others =>
+
+               --  Should never happen
+
+               Write_Line ("Illegal declarative item: " &
+                           Project_Node_Kind'Image (Kind_Of (Current_Item)));
+               raise Program_Error;
+         end case;
+      end loop;
+   end Process_Declarative_Items;
+
+   ---------------------
+   -- Recursive_Check --
+   ---------------------
+
+   procedure Recursive_Check (Project : Project_Id) is
+      Data                  : Project_Data;
+      Imported_Project_List : Project_List := Empty_Project_List;
+
+   begin
+      --  Do nothing if Project is No_Project, or Project has already
+      --  been marked as checked.
+
+      if Project /= No_Project
+        and then not Projects.Table (Project).Checked
+      then
+         Data := Projects.Table (Project);
+
+         --  Call itself for a possible modified project.
+         --  (if there is no modified project, then nothing happens).
+
+         Recursive_Check (Data.Modifies);
+
+         --  Call itself for all imported projects
+
+         Imported_Project_List := Data.Imported_Projects;
+         while Imported_Project_List /= Empty_Project_List loop
+            Recursive_Check
+              (Project_Lists.Table (Imported_Project_List).Project);
+            Imported_Project_List :=
+              Project_Lists.Table (Imported_Project_List).Next;
+         end loop;
+
+         --  Mark project as checked
+
+         Projects.Table (Project).Checked := True;
+
+         if Opt.Verbose_Mode then
+            Write_Str ("Checking project file """);
+            Write_Str (Get_Name_String (Data.Name));
+            Write_Line ("""");
+         end if;
+
+         Prj.Nmsc.Check_Naming_Scheme (Project, Error_Report);
+      end if;
+
+   end Recursive_Check;
+
+   -----------------------
+   -- Recursive_Process --
+   -----------------------
+
+   procedure Recursive_Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Modified_By       : Project_Id)
+   is
+      With_Clause : Project_Node_Id;
+
+   begin
+      if From_Project_Node = Empty_Node then
+         Project := No_Project;
+
+      else
+         declare
+            Processed_Data   : Project_Data := Empty_Project;
+            Imported         : Project_List := Empty_Project_List;
+            Declaration_Node : Project_Node_Id := Empty_Node;
+            Name             : constant Name_Id :=
+                                 Name_Of (From_Project_Node);
+
+         begin
+            Project := Processed_Projects.Get (Name);
+
+            if Project /= No_Project then
+               return;
+            end if;
+
+            Projects.Increment_Last;
+            Project := Projects.Last;
+            Processed_Projects.Set (Name, Project);
+            Processed_Data.Name        := Name;
+            Processed_Data.Path_Name   := Path_Name_Of (From_Project_Node);
+            Processed_Data.Location    := Location_Of (From_Project_Node);
+            Processed_Data.Directory   := Directory_Of (From_Project_Node);
+            Processed_Data.Modified_By := Modified_By;
+            Add_Attributes (Processed_Data.Decl, Attribute_First);
+            With_Clause := First_With_Clause_Of (From_Project_Node);
+
+            while With_Clause /= Empty_Node loop
+               declare
+                  New_Project : Project_Id;
+                  New_Data    : Project_Data;
+
+               begin
+                  Recursive_Process
+                    (Project           => New_Project,
+                     From_Project_Node => Project_Node_Of (With_Clause),
+                     Modified_By       => No_Project);
+                  New_Data := Projects.Table (New_Project);
+
+                  --  If we were the first project to import it,
+                  --  set First_Referred_By to us.
+
+                  if New_Data.First_Referred_By = No_Project then
+                     New_Data.First_Referred_By := Project;
+                     Projects.Table (New_Project) := New_Data;
+                  end if;
+
+                  --  Add this project to our list of imported projects
+
+                  Project_Lists.Increment_Last;
+                  Project_Lists.Table (Project_Lists.Last) :=
+                    (Project => New_Project, Next => Empty_Project_List);
+
+                  --  Imported is the id of the last imported project.
+                  --  If it is nil, then this imported project is our first.
+
+                  if Imported = Empty_Project_List then
+                     Processed_Data.Imported_Projects := Project_Lists.Last;
+
+                  else
+                     Project_Lists.Table (Imported).Next := Project_Lists.Last;
+                  end if;
+
+                  Imported := Project_Lists.Last;
+
+                  With_Clause := Next_With_Clause_Of (With_Clause);
+               end;
+            end loop;
+
+            Declaration_Node := Project_Declaration_Of (From_Project_Node);
+
+            Recursive_Process
+              (Project           => Processed_Data.Modifies,
+               From_Project_Node => Modified_Project_Of (Declaration_Node),
+               Modified_By       => Project);
+
+            Projects.Table (Project) := Processed_Data;
+
+            Process_Declarative_Items
+              (Project           => Project,
+               From_Project_Node => From_Project_Node,
+               Pkg               => No_Package,
+               Item              => First_Declarative_Item_Of
+                                      (Declaration_Node));
+
+         end;
+      end if;
+   end Recursive_Process;
+
+end Prj.Proc;
diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads
new file mode 100644
index 0000000..63259a4
--- /dev/null
+++ b/gcc/ada/prj-proc.ads
@@ -0,0 +1,45 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . P R O C                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.2 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package is used to convert a project file tree (see prj-tree.ads) to
+--  project file data structures (see prj.ads), taking into account
+--  the environment (external references).
+
+with Prj.Tree;  use Prj.Tree;
+
+package Prj.Proc is
+
+   procedure Process
+     (Project           : out Project_Id;
+      From_Project_Node : Project_Node_Id;
+      Report_Error      : Put_Line_Access);
+   --  Process a project file tree into project file data structures.
+   --  If Report_Error is null, use the standard error reporting mechanism
+   --  (Errout). Otherwise, report errors using Report_Error.
+
+end Prj.Proc;
diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb
new file mode 100644
index 0000000..790c632
--- /dev/null
+++ b/gcc/ada/prj-strt.adb
@@ -0,0 +1,943 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . S T R T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Errout;    use Errout;
+with Prj.Attr;  use Prj.Attr;
+with Prj.Tree;  use Prj.Tree;
+with Scans;     use Scans;
+with Sinfo;     use Sinfo;
+with Stringt;   use Stringt;
+with Table;
+with Types;     use Types;
+
+package body Prj.Strt is
+
+   Initial_Size : constant := 8;
+
+   type Name_Location is record
+      Name     : Name_Id := No_Name;
+      Location : Source_Ptr := No_Location;
+   end record;
+   --  Store the identifier and the location of a simple name
+
+   type Name_Range is range 0 .. 3;
+   subtype Name_Index is Name_Range range 1 .. Name_Range'Last;
+   --  A Name may contain up to 3 simple names
+
+   type Names is array (Name_Index) of Name_Location;
+   --  Used to store 1 to 3 simple_names. 2 simple names are for
+   --  <project>.<package>, <project>.<variable> or <package>.<variable>.
+   --  3 simple names are for <project>.<package>.<variable>.
+
+   type Choice_String is record
+      The_String : String_Id;
+      Already_Used : Boolean := False;
+   end record;
+   --  The string of a case label, and an indication that it has already
+   --  been used (to avoid duplicate case labels).
+
+   Choices_Initial   : constant := 10;
+   Choices_Increment : constant := 10;
+
+   Choice_Node_Low_Bound  : constant := 0;
+   Choice_Node_High_Bound : constant := 099_999_999; --  In practice, infinite
+
+   type Choice_Node_Id is
+     range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
+
+   First_Choice_Node_Id : constant Choice_Node_Id :=
+     Choice_Node_Low_Bound;
+
+   Empty_Choice : constant Choice_Node_Id :=
+     Choice_Node_Low_Bound;
+
+   First_Choice_Id : constant Choice_Node_Id := First_Choice_Node_Id + 1;
+
+   package Choices is
+      new Table.Table (Table_Component_Type => Choice_String,
+                       Table_Index_Type     => Choice_Node_Id,
+                       Table_Low_Bound      => First_Choice_Node_Id,
+                       Table_Initial        => Choices_Initial,
+                       Table_Increment      => Choices_Increment,
+                       Table_Name           => "Prj.Strt.Choices");
+   --  Used to store the case labels and check that there is no duplicate.
+
+   package Choice_Lasts is
+      new Table.Table (Table_Component_Type => Choice_Node_Id,
+                       Table_Index_Type     => Nat,
+                       Table_Low_Bound      => 1,
+                       Table_Initial        => 3,
+                       Table_Increment      => 3,
+                       Table_Name           => "Prj.Strt.Choice_Lasts");
+   --  Used to store the indices of the choices in table Choices,
+   --  to distinguish nested case constructions.
+
+   Choice_First : Choice_Node_Id := 0;
+   --  Index in table Choices of the first case label of the current
+   --  case construction.
+   --  0 means no current case construction.
+
+   procedure Add (This_String : String_Id);
+   --  Add a string to the case label list, indicating that it has not
+   --  yet been used.
+
+   procedure External_Reference (External_Value : out Project_Node_Id);
+   --  Parse an external reference. Current token is "external".
+
+   procedure Attribute_Reference
+     (Reference       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse an attribute reference. Current token is an apostrophe.
+
+   procedure Terms
+     (Term            : out Project_Node_Id;
+      Expr_Kind       : in out Variable_Kind;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Recursive procedure to parse one term or several terms concatenated
+   --  using "&".
+
+   ---------
+   -- Add --
+   ---------
+
+   procedure Add (This_String : String_Id) is
+   begin
+      Choices.Increment_Last;
+      Choices.Table (Choices.Last) :=
+        (The_String   => This_String,
+         Already_Used => False);
+   end Add;
+
+   -------------------------
+   -- Attribute_Reference --
+   -------------------------
+
+   procedure Attribute_Reference
+     (Reference       : out Project_Node_Id;
+      First_Attribute : Attribute_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      Current_Attribute : Attribute_Node_Id := First_Attribute;
+
+   begin
+      Reference :=  Default_Project_Node (Of_Kind => N_Attribute_Reference);
+      Set_Location_Of (Reference, To => Token_Ptr);
+      Scan; -- past apostrophe
+      Expect (Tok_Identifier, "Identifier");
+
+      if Token = Tok_Identifier then
+         Set_Name_Of (Reference, To => Token_Name);
+
+         while Current_Attribute /= Empty_Attribute
+           and then
+             Attributes.Table (Current_Attribute).Name /= Token_Name
+         loop
+            Current_Attribute := Attributes.Table (Current_Attribute).Next;
+         end loop;
+
+         if Current_Attribute = Empty_Attribute then
+            Error_Msg ("unknown attribute", Token_Ptr);
+            Reference := Empty_Node;
+
+         elsif
+           Attributes.Table (Current_Attribute).Kind_2 = Associative_Array
+         then
+            Error_Msg
+              ("associative array attribute cannot be referenced",
+               Token_Ptr);
+            Reference := Empty_Node;
+
+         else
+            Set_Project_Node_Of (Reference, To => Current_Project);
+            Set_Package_Node_Of (Reference, To => Current_Package);
+            Set_Expression_Kind_Of
+              (Reference, To => Attributes.Table (Current_Attribute).Kind_1);
+            Scan;
+         end if;
+      end if;
+   end Attribute_Reference;
+
+   ---------------------------
+   -- End_Case_Construction --
+   ---------------------------
+
+   procedure End_Case_Construction is
+   begin
+      if Choice_Lasts.Last = 1 then
+         Choice_Lasts.Set_Last (0);
+         Choices.Set_Last (First_Choice_Node_Id);
+         Choice_First := 0;
+
+      elsif Choice_Lasts.Last = 2 then
+         Choice_Lasts.Set_Last (1);
+         Choices.Set_Last (Choice_Lasts.Table (1));
+         Choice_First := 1;
+
+      else
+         Choice_Lasts.Decrement_Last;
+         Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
+         Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
+      end if;
+   end End_Case_Construction;
+
+   ------------------------
+   -- External_Reference --
+   ------------------------
+
+   procedure External_Reference (External_Value : out Project_Node_Id) is
+      Field_Id : Project_Node_Id := Empty_Node;
+
+   begin
+      External_Value :=
+        Default_Project_Node (Of_Kind       => N_External_Value,
+                              And_Expr_Kind => Single);
+      Set_Location_Of (External_Value, To => Token_Ptr);
+
+      --  The current token is External
+
+      --  Get the left parenthesis
+
+      Scan;
+      Expect (Tok_Left_Paren, "(");
+
+      --  Scan past the left parenthesis
+
+      if Token = Tok_Left_Paren then
+         Scan;
+      end if;
+
+      --  Get the name of the external reference
+
+      Expect (Tok_String_Literal, "literal string");
+
+      if Token = Tok_String_Literal then
+         Field_Id :=
+           Default_Project_Node (Of_Kind       => N_Literal_String,
+                                 And_Expr_Kind => Single);
+         Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+         Set_External_Reference_Of (External_Value, To => Field_Id);
+
+         --  Scan past the first argument
+
+         Scan;
+
+         case Token is
+
+            when Tok_Right_Paren =>
+
+               --  Scan past the right parenthesis
+               Scan;
+
+            when Tok_Comma =>
+
+               --  Scan past the comma
+
+               Scan;
+
+               Expect (Tok_String_Literal, "literal string");
+
+               --  Get the default
+
+               if Token = Tok_String_Literal then
+                  Field_Id :=
+                    Default_Project_Node (Of_Kind       => N_Literal_String,
+                                          And_Expr_Kind => Single);
+                  Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+                  Set_External_Default_Of (External_Value, To => Field_Id);
+                  Scan;
+                  Expect (Tok_Right_Paren, ")");
+               end if;
+
+               --  Scan past the right parenthesis
+               if Token = Tok_Right_Paren then
+                  Scan;
+               end if;
+
+            when others =>
+               Error_Msg ("',' or ')' expected", Token_Ptr);
+         end case;
+      end if;
+   end External_Reference;
+
+   -----------------------
+   -- Parse_Choice_List --
+   -----------------------
+
+   procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is
+      Current_Choice : Project_Node_Id := Empty_Node;
+      Next_Choice    : Project_Node_Id := Empty_Node;
+      Choice_String  : String_Id       := No_String;
+      Found          : Boolean         := False;
+
+   begin
+      First_Choice :=
+        Default_Project_Node (Of_Kind       => N_Literal_String,
+                              And_Expr_Kind => Single);
+      Current_Choice := First_Choice;
+
+      loop
+         Expect (Tok_String_Literal, "literal string");
+         exit when Token /= Tok_String_Literal;
+         Set_Location_Of (Current_Choice, To => Token_Ptr);
+         Choice_String := Strval (Token_Node);
+         Set_String_Value_Of (Current_Choice, To => Choice_String);
+
+         Found := False;
+         for Choice in Choice_First .. Choices.Last loop
+            if String_Equal (Choices.Table (Choice).The_String,
+                             Choice_String)
+            then
+               Found := True;
+
+               if Choices.Table (Choice).Already_Used then
+                  Error_Msg ("duplicate case label", Token_Ptr);
+               else
+                  Choices.Table (Choice).Already_Used := True;
+               end if;
+
+               exit;
+            end if;
+         end loop;
+
+         if not Found then
+            Error_Msg ("illegal case label", Token_Ptr);
+         end if;
+
+         Scan;
+
+         if Token = Tok_Vertical_Bar then
+            Next_Choice :=
+              Default_Project_Node (Of_Kind       => N_Literal_String,
+                                    And_Expr_Kind => Single);
+            Set_Next_Literal_String (Current_Choice, To => Next_Choice);
+            Current_Choice := Next_Choice;
+            Scan;
+         else
+            exit;
+         end if;
+      end loop;
+   end Parse_Choice_List;
+
+   ----------------------
+   -- Parse_Expression --
+   ----------------------
+
+   procedure Parse_Expression
+     (Expression      : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      First_Term      : Project_Node_Id := Empty_Node;
+      Expression_Kind : Variable_Kind := Undefined;
+
+   begin
+      Expression := Default_Project_Node (Of_Kind => N_Expression);
+      Set_Location_Of (Expression, To => Token_Ptr);
+      Terms (Term            => First_Term,
+             Expr_Kind       => Expression_Kind,
+             Current_Project => Current_Project,
+             Current_Package => Current_Package);
+      Set_First_Term (Expression, To => First_Term);
+      Set_Expression_Kind_Of (Expression, To => Expression_Kind);
+   end Parse_Expression;
+
+   ----------------------------
+   -- Parse_String_Type_List --
+   ----------------------------
+
+   procedure Parse_String_Type_List (First_String : out Project_Node_Id) is
+      Last_String  : Project_Node_Id := Empty_Node;
+      Next_String  : Project_Node_Id := Empty_Node;
+      String_Value : String_Id := No_String;
+
+   begin
+      First_String :=
+        Default_Project_Node (Of_Kind       => N_Literal_String,
+                              And_Expr_Kind => Single);
+      Last_String := First_String;
+
+      loop
+         Expect (Tok_String_Literal, "literal string");
+         exit when Token /= Tok_String_Literal;
+         String_Value := Strval (Token_Node);
+         Set_String_Value_Of (Last_String, To => String_Value);
+         Set_Location_Of (Last_String, To => Token_Ptr);
+
+         declare
+            Current : Project_Node_Id := First_String;
+
+         begin
+            while Current /= Last_String loop
+               if String_Equal (String_Value_Of (Current), String_Value) then
+                  Error_Msg ("duplicate value in type", Token_Ptr);
+                  exit;
+               end if;
+
+               Current := Next_Literal_String (Current);
+            end loop;
+         end;
+
+         Scan;
+
+         if Token /= Tok_Comma then
+            exit;
+
+         else
+            Next_String :=
+              Default_Project_Node (Of_Kind       => N_Literal_String,
+                                    And_Expr_Kind => Single);
+            Set_Next_Literal_String (Last_String, To => Next_String);
+            Last_String := Next_String;
+            Scan;
+         end if;
+      end loop;
+   end Parse_String_Type_List;
+
+   ------------------------------
+   -- Parse_Variable_Reference --
+   ------------------------------
+
+   procedure Parse_Variable_Reference
+     (Variable        : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id)
+   is
+      The_Names        : Names;
+      Last_Name        : Name_Range := 0;
+      Current_Variable : Project_Node_Id := Empty_Node;
+
+      The_Package : Project_Node_Id := Current_Package;
+      The_Project : Project_Node_Id := Current_Project;
+
+      Specified_Project : Project_Node_Id   := Empty_Node;
+      Specified_Package : Project_Node_Id   := Empty_Node;
+      Look_For_Variable : Boolean           := True;
+      First_Attribute   : Attribute_Node_Id := Empty_Attribute;
+      Variable_Name     : Name_Id;
+
+   begin
+      for Index in The_Names'Range loop
+         Expect (Tok_Identifier, "identifier");
+
+         if Token /= Tok_Identifier then
+            Look_For_Variable := False;
+            exit;
+         end if;
+
+         Last_Name := Last_Name + 1;
+         The_Names (Last_Name) :=
+           (Name     => Token_Name,
+            Location => Token_Ptr);
+         Scan;
+         exit when Token /= Tok_Dot;
+         Scan;
+      end loop;
+
+      if Look_For_Variable then
+         if Token = Tok_Apostrophe then
+
+            --  Attribute reference
+
+            case Last_Name is
+               when 0 =>
+
+                  --  Cannot happen
+
+                  null;
+
+               when 1 =>
+                  for Index in Package_First .. Package_Attributes.Last loop
+                     if Package_Attributes.Table (Index).Name =
+                                                      The_Names (1).Name
+                     then
+                        First_Attribute :=
+                          Package_Attributes.Table (Index).First_Attribute;
+                        exit;
+                     end if;
+                  end loop;
+
+                  if First_Attribute /= Empty_Attribute then
+                     The_Package := First_Package_Of (Current_Project);
+                     while The_Package /= Empty_Node
+                       and then Name_Of (The_Package) /= The_Names (1).Name
+                     loop
+                        The_Package := Next_Package_In_Project (The_Package);
+                     end loop;
+
+                     if The_Package = Empty_Node then
+                        Error_Msg ("package not yet defined",
+                                   The_Names (1).Location);
+                     end if;
+
+                  else
+                     First_Attribute := Attribute_First;
+                     The_Package     := Empty_Node;
+
+                     declare
+                        The_Project_Name_And_Node :
+                          constant Tree_Private_Part.Project_Name_And_Node :=
+                            Tree_Private_Part.Projects_Htable.Get
+                                                          (The_Names (1).Name);
+
+                        use Tree_Private_Part;
+
+                     begin
+                        if The_Project_Name_And_Node =
+                                   Tree_Private_Part.No_Project_Name_And_Node
+                        then
+                           Error_Msg ("unknown project",
+                                      The_Names (1).Location);
+                        else
+                           The_Project := The_Project_Name_And_Node.Node;
+                        end if;
+                     end;
+                  end if;
+
+               when 2 =>
+                  declare
+                     With_Clause : Project_Node_Id :=
+                                     First_With_Clause_Of (Current_Project);
+
+                  begin
+                     while With_Clause /= Empty_Node loop
+                        The_Project := Project_Node_Of (With_Clause);
+                        exit when Name_Of (The_Project) = The_Names (1).Name;
+                        With_Clause := Next_With_Clause_Of (With_Clause);
+                     end loop;
+
+                     if With_Clause = Empty_Node then
+                        Error_Msg ("unknown project",
+                                   The_Names (1).Location);
+                        The_Project := Empty_Node;
+                        The_Package := Empty_Node;
+                        First_Attribute := Attribute_First;
+
+                     else
+                        The_Package := First_Package_Of (The_Project);
+                        while The_Package /= Empty_Node
+                          and then Name_Of (The_Package) /= The_Names (2).Name
+                        loop
+                           The_Package :=
+                             Next_Package_In_Project (The_Package);
+                        end loop;
+
+                        if The_Package = Empty_Node then
+                           Error_Msg ("package not declared in project",
+                                      The_Names (2).Location);
+                           First_Attribute := Attribute_First;
+
+                        else
+                           First_Attribute :=
+                             Package_Attributes.Table
+                             (Package_Id_Of (The_Package)).First_Attribute;
+                        end if;
+                     end if;
+                  end;
+
+               when 3 =>
+                  Error_Msg
+                    ("too many single names for an attribute reference",
+                     The_Names (1).Location);
+                  Scan;
+                  Variable := Empty_Node;
+                  return;
+            end case;
+
+            Attribute_Reference
+              (Variable,
+               Current_Project => The_Project,
+               Current_Package => The_Package,
+               First_Attribute => First_Attribute);
+            return;
+         end if;
+      end if;
+
+      Variable :=
+        Default_Project_Node (Of_Kind => N_Variable_Reference);
+
+      if Look_For_Variable then
+         case Last_Name is
+            when 0 =>
+
+               --  Cannot happen
+
+               null;
+
+            when 1 =>
+               Set_Name_Of (Variable, To => The_Names (1).Name);
+
+            --  Header comment needed ???
+
+            when 2 =>
+               Set_Name_Of (Variable, To => The_Names (2).Name);
+               The_Package := First_Package_Of (Current_Project);
+
+               while The_Package /= Empty_Node
+                 and then Name_Of (The_Package) /= The_Names (1).Name
+               loop
+                  The_Package := Next_Package_In_Project (The_Package);
+               end loop;
+
+               if The_Package /= Empty_Node then
+                  Specified_Package := The_Package;
+                  The_Project := Empty_Node;
+
+               else
+                  declare
+                     With_Clause : Project_Node_Id :=
+                                     First_With_Clause_Of (Current_Project);
+
+                  begin
+                     while With_Clause /= Empty_Node loop
+                        The_Project := Project_Node_Of (With_Clause);
+                        exit when Name_Of (The_Project) = The_Names (1).Name;
+                        With_Clause := Next_With_Clause_Of (With_Clause);
+                     end loop;
+
+                     if With_Clause = Empty_Node then
+                        The_Project :=
+                          Modified_Project_Of
+                                 (Project_Declaration_Of (Current_Project));
+
+                        if The_Project /= Empty_Node
+                          and then
+                            Name_Of (The_Project) /= The_Names (1).Name
+                        then
+                           The_Project := Empty_Node;
+                        end if;
+                     end if;
+
+                     if The_Project = Empty_Node then
+                        Error_Msg ("unknown package or project",
+                                   The_Names (1).Location);
+                        Look_For_Variable := False;
+                     else
+                        Specified_Project := The_Project;
+                     end if;
+                  end;
+               end if;
+
+            --  Header comment needed ???
+
+            when 3 =>
+               Set_Name_Of (Variable, To => The_Names (3).Name);
+
+               declare
+                  With_Clause : Project_Node_Id :=
+                                  First_With_Clause_Of (Current_Project);
+
+               begin
+                  while With_Clause /= Empty_Node loop
+                     The_Project := Project_Node_Of (With_Clause);
+                     exit when Name_Of (The_Project) = The_Names (1).Name;
+                     With_Clause := Next_With_Clause_Of (With_Clause);
+                  end loop;
+
+                  if With_Clause = Empty_Node then
+                     The_Project :=
+                       Modified_Project_Of
+                          (Project_Declaration_Of (Current_Project));
+
+                     if The_Project /= Empty_Node
+                       and then Name_Of (The_Project) /= The_Names (1).Name
+                     then
+                        The_Project := Empty_Node;
+                     end if;
+                  end if;
+
+                  if The_Project = Empty_Node then
+                     Error_Msg ("unknown package or project",
+                                The_Names (1).Location);
+                     Look_For_Variable := False;
+
+                  else
+                     Specified_Project := The_Project;
+                     The_Package := First_Package_Of (The_Project);
+
+                     while The_Package /= Empty_Node
+                       and then Name_Of (The_Package) /= The_Names (2).Name
+                     loop
+                        The_Package := Next_Package_In_Project (The_Package);
+                     end loop;
+
+                     if The_Package = Empty_Node then
+                        Error_Msg ("unknown package",
+                                   The_Names (2).Location);
+                        Look_For_Variable := False;
+
+                     else
+                        Specified_Package := The_Package;
+                        The_Project := Empty_Node;
+                     end if;
+                  end if;
+               end;
+
+         end case;
+      end if;
+
+      if Look_For_Variable then
+         Variable_Name := Name_Of (Variable);
+         Set_Project_Node_Of (Variable, To => Specified_Project);
+         Set_Package_Node_Of (Variable, To => Specified_Package);
+
+         if The_Package /= Empty_Node then
+            Current_Variable := First_Variable_Of (The_Package);
+
+            while Current_Variable /= Empty_Node
+              and then
+              Name_Of (Current_Variable) /= Variable_Name
+            loop
+               Current_Variable := Next_Variable (Current_Variable);
+            end loop;
+         end if;
+
+         if Current_Variable = Empty_Node
+           and then The_Project /= Empty_Node
+         then
+            Current_Variable := First_Variable_Of (The_Project);
+            while Current_Variable /= Empty_Node
+              and then Name_Of (Current_Variable) /= Variable_Name
+            loop
+               Current_Variable := Next_Variable (Current_Variable);
+            end loop;
+         end if;
+
+         if Current_Variable = Empty_Node then
+            Error_Msg ("unknown variable", The_Names (Last_Name).Location);
+         end if;
+      end if;
+
+      if Current_Variable /= Empty_Node then
+         Set_Expression_Kind_Of
+           (Variable, To => Expression_Kind_Of (Current_Variable));
+
+         if Kind_Of (Current_Variable) = N_Typed_Variable_Declaration then
+            Set_String_Type_Of
+              (Variable, To => String_Type_Of (Current_Variable));
+         end if;
+      end if;
+   end Parse_Variable_Reference;
+
+   ---------------------------------
+   -- Start_New_Case_Construction --
+   ---------------------------------
+
+   procedure Start_New_Case_Construction (String_Type  : Project_Node_Id) is
+      Current_String : Project_Node_Id;
+
+   begin
+      if Choice_First = 0 then
+         Choice_First := 1;
+         Choices.Set_Last (First_Choice_Node_Id);
+      else
+         Choice_First := Choices.Last + 1;
+      end if;
+
+      if String_Type /= Empty_Node then
+         Current_String := First_Literal_String (String_Type);
+
+         while Current_String /= Empty_Node loop
+            Add (This_String => String_Value_Of (Current_String));
+            Current_String := Next_Literal_String (Current_String);
+         end loop;
+      end if;
+
+      Choice_Lasts.Increment_Last;
+      Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
+
+   end Start_New_Case_Construction;
+
+   -----------
+   -- Terms --
+   -----------
+
+   procedure Terms (Term            : out Project_Node_Id;
+                    Expr_Kind       : in out Variable_Kind;
+                    Current_Project : Project_Node_Id;
+                    Current_Package : Project_Node_Id)
+   is
+      Next_Term          : Project_Node_Id := Empty_Node;
+      Term_Id            : Project_Node_Id := Empty_Node;
+      Current_Expression : Project_Node_Id := Empty_Node;
+      Next_Expression    : Project_Node_Id := Empty_Node;
+      Current_Location   : Source_Ptr      := No_Location;
+      Reference          : Project_Node_Id := Empty_Node;
+
+   begin
+      Term := Default_Project_Node (Of_Kind => N_Term);
+      Set_Location_Of (Term, To => Token_Ptr);
+
+      case Token is
+
+         when Tok_Left_Paren =>
+            case Expr_Kind is
+               when Undefined =>
+                  Expr_Kind := List;
+               when List =>
+                  null;
+               when Single =>
+                  Expr_Kind := List;
+                  Error_Msg
+                    ("literal string list cannot appear in a string",
+                     Token_Ptr);
+            end case;
+
+            Term_Id := Default_Project_Node
+              (Of_Kind => N_Literal_String_List,
+               And_Expr_Kind => List);
+            Set_Current_Term (Term, To => Term_Id);
+            Set_Location_Of (Term, To => Token_Ptr);
+
+            Scan;
+            if Token = Tok_Right_Paren then
+               Scan;
+
+            else
+               loop
+                  Current_Location := Token_Ptr;
+                  Parse_Expression (Expression      => Next_Expression,
+                                    Current_Project => Current_Project,
+                                    Current_Package => Current_Package);
+
+                  if Expression_Kind_Of (Next_Expression) = List then
+                     Error_Msg ("single expression expected",
+                                Current_Location);
+                  end if;
+
+                  if Current_Expression = Empty_Node then
+                     Set_First_Expression_In_List
+                       (Term_Id, To => Next_Expression);
+                  else
+                     Set_Next_Expression_In_List
+                       (Current_Expression, To => Next_Expression);
+                  end if;
+
+                  Current_Expression := Next_Expression;
+                  exit when Token /= Tok_Comma;
+                  Scan; -- past the comma
+               end loop;
+
+               Expect (Tok_Right_Paren, "(");
+
+               if Token = Tok_Right_Paren then
+                  Scan;
+               end if;
+            end if;
+
+         when Tok_String_Literal =>
+            if Expr_Kind = Undefined then
+               Expr_Kind := Single;
+            end if;
+
+            Term_Id := Default_Project_Node (Of_Kind => N_Literal_String);
+            Set_Current_Term (Term, To => Term_Id);
+            Set_String_Value_Of (Term_Id, To => Strval (Token_Node));
+
+            Scan;
+
+         when Tok_Identifier =>
+            Current_Location := Token_Ptr;
+            Parse_Variable_Reference
+              (Variable        => Reference,
+               Current_Project => Current_Project,
+               Current_Package => Current_Package);
+            Set_Current_Term (Term, To => Reference);
+
+            if Reference /= Empty_Node then
+               if Expr_Kind = Undefined then
+                  Expr_Kind := Expression_Kind_Of (Reference);
+
+               elsif Expr_Kind = Single
+                 and then Expression_Kind_Of (Reference) = List
+               then
+                  Expr_Kind := List;
+                  Error_Msg
+                    ("list variable cannot appear in single string expression",
+                     Current_Location);
+               end if;
+            end if;
+
+         when Tok_Project =>
+            Current_Location := Token_Ptr;
+            Scan;
+            Expect (Tok_Apostrophe, "'");
+
+            if Token = Tok_Apostrophe then
+               Attribute_Reference
+                 (Reference       => Reference,
+                  First_Attribute => Prj.Attr.Attribute_First,
+                  Current_Project => Current_Project,
+                  Current_Package => Empty_Node);
+               Set_Current_Term (Term, To => Reference);
+            end if;
+
+            if Reference /= Empty_Node then
+               if Expr_Kind = Undefined then
+                  Expr_Kind := Expression_Kind_Of (Reference);
+
+               elsif Expr_Kind = Single
+                 and then Expression_Kind_Of (Reference) = List
+               then
+                  Error_Msg
+                    ("lists cannot appear in single string expression",
+                     Current_Location);
+               end if;
+            end if;
+
+         when Tok_External =>
+            if Expr_Kind = Undefined then
+               Expr_Kind := Single;
+            end if;
+
+            External_Reference (External_Value => Reference);
+            Set_Current_Term (Term, To => Reference);
+
+         when others =>
+            Error_Msg ("cannot be part of an expression", Token_Ptr);
+            Term := Empty_Node;
+            return;
+      end case;
+
+      if Token = Tok_Ampersand then
+         Scan;
+
+         Terms (Term            => Next_Term,
+                Expr_Kind       => Expr_Kind,
+                Current_Project => Current_Project,
+                Current_Package => Current_Package);
+         Set_Next_Term (Term, To => Next_Term);
+
+      end if;
+
+   end Terms;
+
+end Prj.Strt;
diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads
new file mode 100644
index 0000000..9bbdbeb
--- /dev/null
+++ b/gcc/ada/prj-strt.ads
@@ -0,0 +1,96 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             P R J . S T R T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.4 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package implements parsing of string expressions in project files.
+
+with Prj.Tree;  use Prj.Tree;
+
+private package Prj.Strt is
+
+   procedure Parse_String_Type_List (First_String : out Project_Node_Id);
+   --  Get the list of literal strings that are allowed for a typed string.
+   --  On entry, the current token is the first literal string following
+   --  a left parenthesis in a string type declaration such as:
+   --    type Toto is ("string_1", "string_2", "string_3");
+   --  On exit, the current token is the right parenthesis.
+   --  The parameter First_String is a node that contained the first
+   --  literal string of the string type, linked with the following
+   --  literal strings.
+   --
+   --  Report an error if
+   --    - a literal string is not found at the beginning of the list
+   --      or after a comma
+   --    - two literal strings in the list are equal
+
+   procedure Start_New_Case_Construction (String_Type : Project_Node_Id);
+   --  This procedure is called at the beginning of a case construction
+   --  The parameter String_Type is the node for the string type
+   --  of the case label variable.
+   --  The different literal strings of the string type are stored
+   --  into a table to be checked against the case labels of the
+   --  case construction.
+
+   procedure End_Case_Construction;
+   --  This procedure is called at the end of a case construction
+   --  to remove the case labels and to restore the previous state.
+   --  In particular, in the case of nested case constructions,
+   --  the case labels of the enclosing case construction are restored.
+
+   procedure Parse_Choice_List
+     (First_Choice : out Project_Node_Id);
+   --  Get the label for a choice list.
+   --  Report an error if
+   --    - a case label is not a literal string
+   --    - a case label is not in the typed string list
+   --    - the same case label is repeated in the same case construction
+
+   procedure Parse_Expression
+     (Expression      : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a simple string expression or a string list expression.
+   --  Current_Project is the node of the project file being parsed.
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Expression is the node of the expression that has
+   --  been parsed.
+
+   procedure Parse_Variable_Reference
+     (Variable        : out Project_Node_Id;
+      Current_Project : Project_Node_Id;
+      Current_Package : Project_Node_Id);
+   --  Parse a variable or attribute reference.
+   --  Used internally (in expressions) and for case variables (in Prj.Dect).
+   --  Current_Package is the node of the package being parsed,
+   --  or Empty_Node when we are at the project level (not in a package).
+   --  On exit, Variable is the node of the variable or attribute reference.
+   --  A variable reference is made of one to three simple names.
+   --  An attribute reference is made of one or two simple names,
+   --  followed by an apostroph, followed by the attribute simple name.
+
+end Prj.Strt;
diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb
new file mode 100644
index 0000000..322e4aa
--- /dev/null
+++ b/gcc/ada/prj-tree.adb
@@ -0,0 +1,1478 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . T R E E                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.7 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Stringt; use Stringt;
+
+package body Prj.Tree is
+
+   use Tree_Private_Part;
+
+   --------------------------------
+   -- Associative_Array_Index_Of --
+   --------------------------------
+
+   function Associative_Array_Index_Of
+     (Node : Project_Node_Id)
+      return String_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
+      return Project_Nodes.Table (Node).Value;
+   end Associative_Array_Index_Of;
+
+   --------------------------------
+   -- Case_Variable_Reference_Of --
+   --------------------------------
+
+   function Case_Variable_Reference_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Construction);
+      return Project_Nodes.Table (Node).Field1;
+   end Case_Variable_Reference_Of;
+
+   -----------------------
+   -- Current_Item_Node --
+   -----------------------
+
+   function Current_Item_Node
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Declarative_Item);
+      return Project_Nodes.Table (Node).Field1;
+   end Current_Item_Node;
+
+   ------------------
+   -- Current_Term --
+   ------------------
+
+   function Current_Term
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Term);
+      return Project_Nodes.Table (Node).Field1;
+   end Current_Term;
+
+   --------------------------
+   -- Default_Project_Node --
+   --------------------------
+
+   function Default_Project_Node
+     (Of_Kind       : Project_Node_Kind;
+      And_Expr_Kind : Variable_Kind := Undefined)
+      return          Project_Node_Id
+   is
+   begin
+      Project_Nodes.Increment_Last;
+      Project_Nodes.Table (Project_Nodes.Last) :=
+           (Kind       => Of_Kind,
+            Location   => No_Location,
+            Directory  => No_Name,
+            Expr_Kind  => And_Expr_Kind,
+            Variables  => Empty_Node,
+            Packages   => Empty_Node,
+            Pkg_Id     => Empty_Package,
+            Name       => No_Name,
+            Path_Name  => No_Name,
+            Value      => No_String,
+            Field1     => Empty_Node,
+            Field2     => Empty_Node,
+            Field3     => Empty_Node);
+      return Project_Nodes.Last;
+   end Default_Project_Node;
+
+   ------------------
+   -- Directory_Of --
+   ------------------
+
+   function Directory_Of (Node : Project_Node_Id) return Name_Id is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Directory;
+   end Directory_Of;
+
+   ------------------------
+   -- Expression_Kind_Of --
+   ------------------------
+
+   function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+           and then
+             (Project_Nodes.Table (Node).Kind = N_Literal_String
+                or else
+              Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Variable_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Expression
+                or else
+              Project_Nodes.Table (Node).Kind = N_Term
+                or else
+              Project_Nodes.Table (Node).Kind = N_Variable_Reference
+                or else
+              Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+
+      return Project_Nodes.Table (Node).Expr_Kind;
+   end Expression_Kind_Of;
+
+   -------------------
+   -- Expression_Of --
+   -------------------
+
+   function Expression_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Variable_Declaration));
+
+      return Project_Nodes.Table (Node).Field1;
+   end Expression_Of;
+
+   ---------------------------
+   -- External_Reference_Of --
+   ---------------------------
+
+   function External_Reference_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_External_Value);
+      return Project_Nodes.Table (Node).Field1;
+   end External_Reference_Of;
+
+   -------------------------
+   -- External_Default_Of --
+   -------------------------
+
+   function External_Default_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_External_Value);
+      return Project_Nodes.Table (Node).Field2;
+   end External_Default_Of;
+
+   ------------------------
+   -- First_Case_Item_Of --
+   ------------------------
+
+   function First_Case_Item_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Construction);
+      return Project_Nodes.Table (Node).Field2;
+   end First_Case_Item_Of;
+
+   ---------------------
+   -- First_Choice_Of --
+   ---------------------
+
+   function First_Choice_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Item);
+      return Project_Nodes.Table (Node).Field1;
+   end First_Choice_Of;
+
+   -------------------------------
+   -- First_Declarative_Item_Of --
+   -------------------------------
+
+   function First_Declarative_Item_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Case_Item
+               or else
+             Project_Nodes.Table (Node).Kind = N_Package_Declaration));
+
+      if Project_Nodes.Table (Node).Kind = N_Project_Declaration then
+         return Project_Nodes.Table (Node).Field1;
+      else
+         return Project_Nodes.Table (Node).Field2;
+      end if;
+   end First_Declarative_Item_Of;
+
+   ------------------------------
+   -- First_Expression_In_List --
+   ------------------------------
+
+   function First_Expression_In_List
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Literal_String_List);
+      return Project_Nodes.Table (Node).Field1;
+   end First_Expression_In_List;
+
+   --------------------------
+   -- First_Literal_String --
+   --------------------------
+
+   function First_Literal_String
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_String_Type_Declaration);
+      return Project_Nodes.Table (Node).Field1;
+   end First_Literal_String;
+
+   ----------------------
+   -- First_Package_Of --
+   ----------------------
+
+   function First_Package_Of
+     (Node : Project_Node_Id)
+      return Package_Declaration_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Packages;
+   end First_Package_Of;
+
+   --------------------------
+   -- First_String_Type_Of --
+   --------------------------
+
+   function First_String_Type_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Field3;
+   end First_String_Type_Of;
+
+   ----------------
+   -- First_Term --
+   ----------------
+
+   function First_Term
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Expression);
+      return Project_Nodes.Table (Node).Field1;
+   end First_Term;
+
+   -----------------------
+   -- First_Variable_Of --
+   -----------------------
+
+   function First_Variable_Of
+     (Node : Project_Node_Id)
+      return Variable_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project
+               or else
+             Project_Nodes.Table (Node).Kind = N_Package_Declaration));
+
+      return Project_Nodes.Table (Node).Variables;
+   end First_Variable_Of;
+
+   --------------------------
+   -- First_With_Clause_Of --
+   --------------------------
+
+   function First_With_Clause_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Field1;
+   end First_With_Clause_Of;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Project_Nodes.Set_Last (Empty_Node);
+      Projects_Htable.Reset;
+   end Initialize;
+
+   -------------
+   -- Kind_Of --
+   -------------
+
+   function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      return Project_Nodes.Table (Node).Kind;
+   end Kind_Of;
+
+   -----------------
+   -- Location_Of --
+   -----------------
+
+   function Location_Of (Node : Project_Node_Id) return Source_Ptr is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      return Project_Nodes.Table (Node).Location;
+   end Location_Of;
+
+   -------------------------
+   -- Modified_Project_Of --
+   -------------------------
+
+   function Modified_Project_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project_Declaration);
+      return Project_Nodes.Table (Node).Field2;
+   end Modified_Project_Of;
+
+   ------------------------------
+   -- Modified_Project_Path_Of --
+   ------------------------------
+
+   function Modified_Project_Path_Of
+     (Node : Project_Node_Id)
+      return String_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Value;
+   end Modified_Project_Path_Of;
+
+   -------------
+   -- Name_Of --
+   -------------
+
+   function Name_Of (Node : Project_Node_Id) return Name_Id is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      return Project_Nodes.Table (Node).Name;
+   end Name_Of;
+
+   --------------------
+   -- Next_Case_Item --
+   --------------------
+
+   function Next_Case_Item
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Item);
+      return Project_Nodes.Table (Node).Field3;
+   end Next_Case_Item;
+
+   ---------------------------
+   -- Next_Declarative_Item --
+   ---------------------------
+
+   function Next_Declarative_Item
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Declarative_Item);
+      return Project_Nodes.Table (Node).Field2;
+   end Next_Declarative_Item;
+
+   -----------------------------
+   -- Next_Expression_In_List --
+   -----------------------------
+
+   function Next_Expression_In_List
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Expression);
+      return Project_Nodes.Table (Node).Field2;
+   end Next_Expression_In_List;
+
+   -------------------------
+   -- Next_Literal_String --
+   -------------------------
+
+   function Next_Literal_String
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Literal_String);
+      return Project_Nodes.Table (Node).Field1;
+   end Next_Literal_String;
+
+   -----------------------------
+   -- Next_Package_In_Project --
+   -----------------------------
+
+   function Next_Package_In_Project
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      return Project_Nodes.Table (Node).Field3;
+   end Next_Package_In_Project;
+
+   ----------------------
+   -- Next_String_Type --
+   ----------------------
+
+   function Next_String_Type
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_String_Type_Declaration);
+      return Project_Nodes.Table (Node).Field2;
+   end Next_String_Type;
+
+   ---------------
+   -- Next_Term --
+   ---------------
+
+   function Next_Term
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Term);
+      return Project_Nodes.Table (Node).Field2;
+   end Next_Term;
+
+   -------------------
+   -- Next_Variable --
+   -------------------
+
+   function Next_Variable
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Variable_Declaration));
+
+      return Project_Nodes.Table (Node).Field3;
+   end Next_Variable;
+
+   -------------------------
+   -- Next_With_Clause_Of --
+   -------------------------
+
+   function Next_With_Clause_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_With_Clause);
+      return Project_Nodes.Table (Node).Field2;
+   end Next_With_Clause_Of;
+
+   -------------------
+   -- Package_Id_Of --
+   -------------------
+
+   function Package_Id_Of (Node : Project_Node_Id) return Package_Node_Id is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      return Project_Nodes.Table (Node).Pkg_Id;
+   end Package_Id_Of;
+
+   ---------------------
+   -- Package_Node_Of --
+   ---------------------
+
+   function Package_Node_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Variable_Reference
+               or else
+             Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+      return Project_Nodes.Table (Node).Field2;
+   end Package_Node_Of;
+
+   ------------------
+   -- Path_Name_Of --
+   ------------------
+
+   function Path_Name_Of (Node : Project_Node_Id) return Name_Id is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project
+               or else
+             Project_Nodes.Table (Node).Kind = N_With_Clause));
+      return Project_Nodes.Table (Node).Path_Name;
+   end Path_Name_Of;
+
+   ----------------------------
+   -- Project_Declaration_Of --
+   ----------------------------
+
+   function Project_Declaration_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      return Project_Nodes.Table (Node).Field2;
+   end Project_Declaration_Of;
+
+   ---------------------
+   -- Project_Node_Of --
+   ---------------------
+
+   function Project_Node_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+           (Project_Nodes.Table (Node).Kind = N_With_Clause
+              or else
+            Project_Nodes.Table (Node).Kind = N_Variable_Reference
+              or else
+            Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+      return Project_Nodes.Table (Node).Field1;
+   end Project_Node_Of;
+
+   -----------------------------------
+   -- Project_Of_Renamed_Package_Of --
+   -----------------------------------
+
+   function Project_Of_Renamed_Package_Of
+     (Node : Project_Node_Id)
+      return Project_Node_Id
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      return Project_Nodes.Table (Node).Field1;
+   end Project_Of_Renamed_Package_Of;
+
+   ------------------------------------
+   -- Set_Associative_Array_Index_Of --
+   ------------------------------------
+
+   procedure Set_Associative_Array_Index_Of
+     (Node : Project_Node_Id;
+      To   : String_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Attribute_Declaration);
+      Project_Nodes.Table (Node).Value := To;
+   end Set_Associative_Array_Index_Of;
+
+   ------------------------------------
+   -- Set_Case_Variable_Reference_Of --
+   ------------------------------------
+
+   procedure Set_Case_Variable_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Construction);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Case_Variable_Reference_Of;
+
+   ---------------------------
+   -- Set_Current_Item_Node --
+   ---------------------------
+
+   procedure Set_Current_Item_Node
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Declarative_Item);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Current_Item_Node;
+
+   ----------------------
+   -- Set_Current_Term --
+   ----------------------
+
+   procedure Set_Current_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Term);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Current_Term;
+
+   ----------------------
+   -- Set_Directory_Of --
+   ----------------------
+
+   procedure Set_Directory_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Directory := To;
+   end Set_Directory_Of;
+
+   ----------------------------
+   -- Set_Expression_Kind_Of --
+   ----------------------------
+
+   procedure Set_Expression_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Kind)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+           and then
+             (Project_Nodes.Table (Node).Kind = N_Literal_String
+                or else
+              Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Variable_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+                or else
+              Project_Nodes.Table (Node).Kind = N_Expression
+                or else
+              Project_Nodes.Table (Node).Kind = N_Term
+                or else
+              Project_Nodes.Table (Node).Kind = N_Variable_Reference
+                or else
+              Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+      Project_Nodes.Table (Node).Expr_Kind := To;
+   end Set_Expression_Kind_Of;
+
+   -----------------------
+   -- Set_Expression_Of --
+   -----------------------
+
+   procedure Set_Expression_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Variable_Declaration));
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Expression_Of;
+
+   -------------------------------
+   -- Set_External_Reference_Of --
+   -------------------------------
+
+   procedure Set_External_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_External_Value);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_External_Reference_Of;
+
+   -----------------------------
+   -- Set_External_Default_Of --
+   -----------------------------
+
+   procedure Set_External_Default_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_External_Value);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_External_Default_Of;
+
+   ----------------------------
+   -- Set_First_Case_Item_Of --
+   ----------------------------
+
+   procedure Set_First_Case_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Construction);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_First_Case_Item_Of;
+
+   -------------------------
+   -- Set_First_Choice_Of --
+   -------------------------
+
+   procedure Set_First_Choice_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Item);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_First_Choice_Of;
+
+   ------------------------
+   -- Set_Next_Case_Item --
+   ------------------------
+
+   procedure Set_Next_Case_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Case_Item);
+      Project_Nodes.Table (Node).Field3 := To;
+   end Set_Next_Case_Item;
+
+   -----------------------------------
+   -- Set_First_Declarative_Item_Of --
+   -----------------------------------
+
+   procedure Set_First_Declarative_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Case_Item
+               or else
+             Project_Nodes.Table (Node).Kind = N_Package_Declaration));
+
+      if Project_Nodes.Table (Node).Kind = N_Project_Declaration then
+         Project_Nodes.Table (Node).Field1 := To;
+      else
+         Project_Nodes.Table (Node).Field2 := To;
+      end if;
+   end Set_First_Declarative_Item_Of;
+
+   ----------------------------------
+   -- Set_First_Expression_In_List --
+   ----------------------------------
+
+   procedure Set_First_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Literal_String_List);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_First_Expression_In_List;
+
+   ------------------------------
+   -- Set_First_Literal_String --
+   ------------------------------
+
+   procedure Set_First_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_String_Type_Declaration);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_First_Literal_String;
+
+   --------------------------
+   -- Set_First_Package_Of --
+   --------------------------
+
+   procedure Set_First_Package_Of
+     (Node : Project_Node_Id;
+      To   : Package_Declaration_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Packages := To;
+   end Set_First_Package_Of;
+
+   ------------------------------
+   -- Set_First_String_Type_Of --
+   ------------------------------
+
+   procedure Set_First_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Field3 := To;
+   end Set_First_String_Type_Of;
+
+   --------------------
+   -- Set_First_Term --
+   --------------------
+
+   procedure Set_First_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Expression);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_First_Term;
+
+   ---------------------------
+   -- Set_First_Variable_Of --
+   ---------------------------
+
+   procedure Set_First_Variable_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project
+               or else
+             Project_Nodes.Table (Node).Kind = N_Package_Declaration));
+      Project_Nodes.Table (Node).Variables := To;
+   end Set_First_Variable_Of;
+
+   ------------------------------
+   -- Set_First_With_Clause_Of --
+   ------------------------------
+
+   procedure Set_First_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_First_With_Clause_Of;
+
+   -----------------
+   -- Set_Kind_Of --
+   -----------------
+
+   procedure Set_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Kind)
+   is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      Project_Nodes.Table (Node).Kind := To;
+   end Set_Kind_Of;
+
+   ---------------------
+   -- Set_Location_Of --
+   ---------------------
+
+   procedure Set_Location_Of
+     (Node : Project_Node_Id;
+      To   : Source_Ptr)
+   is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      Project_Nodes.Table (Node).Location := To;
+   end Set_Location_Of;
+
+   -----------------------------
+   -- Set_Modified_Project_Of --
+   -----------------------------
+
+   procedure Set_Modified_Project_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project_Declaration);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Modified_Project_Of;
+
+   ----------------------------------
+   -- Set_Modified_Project_Path_Of --
+   ----------------------------------
+
+   procedure Set_Modified_Project_Path_Of
+     (Node : Project_Node_Id;
+      To   : String_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Value := To;
+   end Set_Modified_Project_Path_Of;
+
+   -----------------
+   -- Set_Name_Of --
+   -----------------
+
+   procedure Set_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id)
+   is
+   begin
+      pragma Assert (Node /= Empty_Node);
+      Project_Nodes.Table (Node).Name := To;
+   end Set_Name_Of;
+
+   -------------------------------
+   -- Set_Next_Declarative_Item --
+   -------------------------------
+
+   procedure Set_Next_Declarative_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Declarative_Item);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Next_Declarative_Item;
+
+   ---------------------------------
+   -- Set_Next_Expression_In_List --
+   ---------------------------------
+
+   procedure Set_Next_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Expression);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Next_Expression_In_List;
+
+   -----------------------------
+   -- Set_Next_Literal_String --
+   -----------------------------
+
+   procedure Set_Next_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Literal_String);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Next_Literal_String;
+
+   ---------------------------------
+   -- Set_Next_Package_In_Project --
+   ---------------------------------
+
+   procedure Set_Next_Package_In_Project
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      Project_Nodes.Table (Node).Field3 := To;
+   end Set_Next_Package_In_Project;
+
+   --------------------------
+   -- Set_Next_String_Type --
+   --------------------------
+
+   procedure Set_Next_String_Type
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_String_Type_Declaration);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Next_String_Type;
+
+   -------------------
+   -- Set_Next_Term --
+   -------------------
+
+   procedure Set_Next_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Term);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Next_Term;
+
+   -----------------------
+   -- Set_Next_Variable --
+   -----------------------
+
+   procedure Set_Next_Variable
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
+               or else
+             Project_Nodes.Table (Node).Kind = N_Variable_Declaration));
+      Project_Nodes.Table (Node).Field3 := To;
+   end Set_Next_Variable;
+
+   -----------------------------
+   -- Set_Next_With_Clause_Of --
+   -----------------------------
+
+   procedure Set_Next_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_With_Clause);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Next_With_Clause_Of;
+
+   -----------------------
+   -- Set_Package_Id_Of --
+   -----------------------
+
+   procedure Set_Package_Id_Of
+     (Node : Project_Node_Id;
+      To   : Package_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      Project_Nodes.Table (Node).Pkg_Id := To;
+   end Set_Package_Id_Of;
+
+   -------------------------
+   -- Set_Package_Node_Of --
+   -------------------------
+
+   procedure Set_Package_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Variable_Reference
+               or else
+             Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Package_Node_Of;
+
+   ----------------------
+   -- Set_Path_Name_Of --
+   ----------------------
+
+   procedure Set_Path_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Project
+               or else
+             Project_Nodes.Table (Node).Kind = N_With_Clause));
+      Project_Nodes.Table (Node).Path_Name := To;
+   end Set_Path_Name_Of;
+
+   --------------------------------
+   -- Set_Project_Declaration_Of --
+   --------------------------------
+
+   procedure Set_Project_Declaration_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+         and then
+           Project_Nodes.Table (Node).Kind = N_Project);
+      Project_Nodes.Table (Node).Field2 := To;
+   end Set_Project_Declaration_Of;
+
+   -------------------------
+   -- Set_Project_Node_Of --
+   -------------------------
+
+   procedure Set_Project_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_With_Clause
+               or else
+             Project_Nodes.Table (Node).Kind = N_Variable_Reference
+               or else
+             Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Project_Node_Of;
+
+   ---------------------------------------
+   -- Set_Project_Of_Renamed_Package_Of --
+   ---------------------------------------
+
+   procedure Set_Project_Of_Renamed_Package_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            Project_Nodes.Table (Node).Kind = N_Package_Declaration);
+      Project_Nodes.Table (Node).Field1 := To;
+   end Set_Project_Of_Renamed_Package_Of;
+
+   ------------------------
+   -- Set_String_Type_Of --
+   ------------------------
+
+   procedure Set_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Variable_Reference
+               or else
+             Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration)
+           and then
+            Project_Nodes.Table (To).Kind    = N_String_Type_Declaration);
+
+      if Project_Nodes.Table (Node).Kind = N_Variable_Reference then
+         Project_Nodes.Table (Node).Field3 := To;
+      else
+         Project_Nodes.Table (Node).Field2 := To;
+      end if;
+   end Set_String_Type_Of;
+
+   -------------------------
+   -- Set_String_Value_Of --
+   -------------------------
+
+   procedure Set_String_Value_Of
+     (Node : Project_Node_Id;
+      To   : String_Id)
+   is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_With_Clause
+               or else
+             Project_Nodes.Table (Node).Kind = N_Literal_String));
+      Project_Nodes.Table (Node).Value := To;
+   end Set_String_Value_Of;
+
+   --------------------
+   -- String_Type_Of --
+   --------------------
+
+   function String_Type_Of  (Node : Project_Node_Id)
+                            return Project_Node_Id is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+            (Project_Nodes.Table (Node).Kind = N_Variable_Reference
+               or else
+             Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration));
+
+      if Project_Nodes.Table (Node).Kind = N_Variable_Reference then
+         return Project_Nodes.Table (Node).Field3;
+      else
+         return Project_Nodes.Table (Node).Field2;
+      end if;
+   end String_Type_Of;
+
+   ---------------------
+   -- String_Value_Of --
+   ---------------------
+
+   function String_Value_Of (Node : Project_Node_Id) return String_Id is
+   begin
+      pragma Assert
+        (Node /= Empty_Node
+          and then
+           (Project_Nodes.Table (Node).Kind = N_With_Clause
+              or else
+            Project_Nodes.Table (Node).Kind = N_Literal_String));
+      return Project_Nodes.Table (Node).Value;
+   end String_Value_Of;
+
+   --------------------
+   -- Value_Is_Valid --
+   --------------------
+
+   function Value_Is_Valid
+     (For_Typed_Variable : Project_Node_Id;
+      Value              : String_Id)
+      return               Boolean
+   is
+   begin
+      pragma Assert
+        (For_Typed_Variable /= Empty_Node
+          and then
+           (Project_Nodes.Table (For_Typed_Variable).Kind =
+                                     N_Typed_Variable_Declaration));
+
+      declare
+         Current_String : Project_Node_Id :=
+                            First_Literal_String
+                              (String_Type_Of (For_Typed_Variable));
+
+      begin
+         while Current_String /= Empty_Node
+           and then
+             not String_Equal (String_Value_Of (Current_String), Value)
+         loop
+            Current_String :=
+              Next_Literal_String (Current_String);
+         end loop;
+
+         return Current_String /= Empty_Node;
+      end;
+
+   end Value_Is_Valid;
+
+end Prj.Tree;
diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads
new file mode 100644
index 0000000..d32fcb1
--- /dev/null
+++ b/gcc/ada/prj-tree.ads
@@ -0,0 +1,742 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . T R E E                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.9 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package defines the structure of the Project File tree.
+
+with GNAT.HTable;
+
+with Prj.Attr; use Prj.Attr;
+with Prj.Com;  use Prj.Com;
+with Types;    use Types;
+with Table;
+
+package Prj.Tree is
+
+   Project_Nodes_Initial   : constant := 1_000;
+   --  Initial number of nodes in table Tree_Private_Part.Project_Nodes
+   Project_Nodes_Increment : constant := 100;
+
+   Project_Node_Low_Bound  : constant := 0;
+   Project_Node_High_Bound : constant := 099_999_999; -- In practice, infinite
+
+   type Project_Node_Id is range
+     Project_Node_Low_Bound .. Project_Node_High_Bound;
+   --  The index of table Tree_Private_Part.Project_Nodes
+
+   Empty_Node    : constant Project_Node_Id := Project_Node_Low_Bound;
+   --  Designates no node in table Project_Nodes
+   First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound;
+
+   subtype Variable_Node_Id       is Project_Node_Id;
+   --  Used to designate a node whose expected kind is
+   --  N_Typed_Variable_Declaration, N_Variable_Declaration or
+   --  N_Variable_Reference.
+   subtype Package_Declaration_Id is Project_Node_Id;
+   --  Used to designate a node whose expected kind is
+   --  N_Project_Declaration.
+
+   type Project_Node_Kind is
+     (N_Project,
+      N_With_Clause,
+      N_Project_Declaration,
+      N_Declarative_Item,
+      N_Package_Declaration,
+      N_String_Type_Declaration,
+      N_Literal_String,
+      N_Attribute_Declaration,
+      N_Typed_Variable_Declaration,
+      N_Variable_Declaration,
+      N_Expression,
+      N_Term,
+      N_Literal_String_List,
+      N_Variable_Reference,
+      N_External_Value,
+      N_Attribute_Reference,
+      N_Case_Construction,
+      N_Case_Item);
+   --  Each node in the tree is of a Project_Node_Kind
+   --  For the signification of the fields in each node of a
+   --  Project_Node_Kind, look at package Tree_Private_Part.
+
+   procedure Initialize;
+   --  Initialize the Project File tree: empty the Project_Nodes table
+   --  and reset the Projects_Htable.
+
+   function Default_Project_Node
+     (Of_Kind       : Project_Node_Kind;
+      And_Expr_Kind : Variable_Kind := Undefined)
+     return Project_Node_Id;
+   --  Returns a Project_Node_Record with the specified Kind and
+   --  Expr_Kind; all the other components have default nil values.
+
+   ----------------------
+   -- Access Functions --
+   ----------------------
+
+   --  The following query functions are part of the abstract interface
+   --  of the Project File tree
+
+   function Name_Of (Node : Project_Node_Id) return Name_Id;
+   --  Valid for all non empty nodes. May return No_Name for nodes that have
+   --  no names.
+
+   function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind;
+   --  Valid for all non empty nodes
+
+   function Location_Of (Node : Project_Node_Id) return Source_Ptr;
+   --  Valid for all non empty nodes
+
+   function Directory_Of (Node : Project_Node_Id) return Name_Id;
+   --  Only valid for N_Project nodes.
+
+   function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind;
+   --  Only valid for N_Literal_String, N_Attribute_Declaration,
+   --  N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
+   --  N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
+
+   function First_Variable_Of
+     (Node  : Project_Node_Id)
+      return Variable_Node_Id;
+   --  Only valid for N_Project or N_Package_Declaration nodes
+
+   function First_Package_Of
+     (Node  : Project_Node_Id)
+      return  Package_Declaration_Id;
+   --  Only valid for N_Project nodes
+
+   function Package_Id_Of (Node  : Project_Node_Id) return Package_Node_Id;
+   --  Only valid for N_Package_Declaration nodes
+
+   function Path_Name_Of (Node  : Project_Node_Id) return Name_Id;
+   --  Only valid for N_Project and N_With_Clause nodes.
+
+   function String_Value_Of (Node  : Project_Node_Id) return String_Id;
+   --  Only valid for N_With_Clause or N_Literal_String nodes.
+
+   function First_With_Clause_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Project_Declaration_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function First_String_Type_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Modified_Project_Path_Of
+     (Node  : Project_Node_Id)
+      return  String_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Project_Node_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Project nodes
+
+   function Next_With_Clause_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function First_Declarative_Item_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Modified_Project_Of
+     (Node  : Project_Node_Id)
+      return Project_Node_Id;
+   --  Only valid for N_With_Clause nodes
+
+   function Current_Item_Node
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Declarative_Item nodes
+
+   function Next_Declarative_Item
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Declarative_Item node
+
+   function Project_Of_Renamed_Package_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Package_Declaration nodes.
+   --  May return Empty_Node.
+
+   function Next_Package_In_Project
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Package_Declaration nodes
+
+   function First_Literal_String
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_String_Type_Declaration nodes
+
+   function Next_String_Type
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_String_Type_Declaration nodes
+
+   function Next_Literal_String
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Literal_String nodes
+
+   function Expression_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
+   --  or N_Variable_Declaration nodes
+
+   function Value_Is_Valid
+     (For_Typed_Variable : Project_Node_Id;
+      Value              : String_Id)
+      return               Boolean;
+   --  Only valid for N_Typed_Variable_Declaration. Returns True if Value is
+   --  in the list of allowed strings for For_Typed_Variable. False otherwise.
+
+   function Associative_Array_Index_Of
+     (Node  : Project_Node_Id)
+      return  String_Id;
+   --  Only valid for N_Attribute_Declaration.
+   --  Returns No_String for non associative array attributes.
+
+   function Next_Variable
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
+   --  nodes.
+
+   function First_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Expression nodes
+
+   function Next_Expression_In_List
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Expression nodes
+
+   function Current_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Term nodes
+
+   function Next_Term
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Term nodes
+
+   function First_Expression_In_List
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Literal_String_List nodes
+
+   function Package_Node_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
+   --  May return Empty_Node.
+
+   function String_Type_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
+   --  nodes.
+
+   function External_Reference_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_External_Value nodes
+
+   function External_Default_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_External_Value nodes
+
+   function Case_Variable_Reference_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Construction nodes
+
+   function First_Case_Item_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Construction nodes
+
+   function First_Choice_Of
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Item nodes
+
+   function Next_Case_Item
+     (Node  : Project_Node_Id)
+      return  Project_Node_Id;
+   --  Only valid for N_Case_Item nodes
+
+   --------------------
+   -- Set Procedures --
+   --------------------
+
+   --  The following procedures are part of the abstract interface of
+   --  the Project File tree.
+
+   --  Each Set_* procedure is valid only for the same Project_Node_Kind
+   --  nodes as the corresponding query function above.
+
+   procedure Set_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Kind);
+
+   procedure Set_Location_Of
+     (Node : Project_Node_Id;
+      To   : Source_Ptr);
+
+   procedure Set_Directory_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_Expression_Kind_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Kind);
+
+   procedure Set_First_Variable_Of
+     (Node : Project_Node_Id;
+      To   : Variable_Node_Id);
+
+   procedure Set_First_Package_Of
+     (Node : Project_Node_Id;
+      To   : Package_Declaration_Id);
+
+   procedure Set_Package_Id_Of
+     (Node : Project_Node_Id;
+      To   : Package_Node_Id);
+
+   procedure Set_Path_Name_Of
+     (Node : Project_Node_Id;
+      To   : Name_Id);
+
+   procedure Set_String_Value_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_First_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Project_Declaration_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Modified_Project_Path_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_Project_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_With_Clause_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Declarative_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Modified_Project_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Current_Item_Node
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Declarative_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Project_Of_Renamed_Package_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Package_In_Project
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_String_Type
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Literal_String
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Expression_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Associative_Array_Index_Of
+     (Node : Project_Node_Id;
+      To   : String_Id);
+
+   procedure Set_Next_Variable
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Current_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Term
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Expression_In_List
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Package_Node_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_String_Type_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_External_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_External_Default_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Case_Variable_Reference_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Case_Item_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_First_Choice_Of
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   procedure Set_Next_Case_Item
+     (Node : Project_Node_Id;
+      To   : Project_Node_Id);
+
+   -------------------------------
+   -- Restricted Access Section --
+   -------------------------------
+
+   package Tree_Private_Part is
+
+      --  This is conceptually in the private part.
+      --  However, for efficiency, some packages are accessing it directly.
+
+      type Project_Node_Record is record
+
+         Kind        : Project_Node_Kind;
+
+         Location    : Source_Ptr    := No_Location;
+
+         Directory   : Name_Id       := No_Name;
+         --  Only for N_Project
+
+         Expr_Kind   : Variable_Kind := Undefined;
+         --  See below for what Project_Node_Kind it is used
+
+         Variables   : Variable_Node_Id := Empty_Node;
+         --  First variable in a project or a package
+
+         Packages    : Package_Declaration_Id := Empty_Node;
+         --  First package declaration in a project
+
+         Pkg_Id      : Package_Node_Id := Empty_Package;
+         --  Only use in Package_Declaration
+
+         Name        : Name_Id         := No_Name;
+         --  See below for what Project_Node_Kind it is used
+
+         Path_Name   : Name_Id         := No_Name;
+         --  See below for what Project_Node_Kind it is used
+
+         Value       : String_Id       := No_String;
+         --  See below for what Project_Node_Kind it is used
+
+         Field1      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+         Field2      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+         Field3      : Project_Node_Id := Empty_Node;
+         --  See below the meaning for each Project_Node_Kind
+
+      end record;
+
+      --  type Project_Node_Kind is
+
+      --   (N_Project,
+      --    --  Name:      project name
+      --    --  Path_Name: project path name
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first with clause
+      --    --  Field2:    project declaration
+      --    --  Field3:    first string type
+      --    --  Value:     modified project path name (if any)
+
+      --    N_With_Clause,
+      --    --  Name:      imported project name
+      --    --  Path_Name: imported project path name
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    project node
+      --    --  Field2:    next with clause
+      --    --  Field3:    not used
+      --    --  Value:     literal string withed
+
+      --    N_Project_Declaration,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first declarative item
+      --    --  Field2:    modified project
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Declarative_Item,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    current item node
+      --    --  Field2:    next declarative item
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Package_Declaration,
+      --    --  Name:      package name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    project of renamed package (if any)
+      --    --  Field2:    first declarative item
+      --    --  Field3:    next package in project
+      --    --  Value:     not used
+
+      --    N_String_Type_Declaration,
+      --    --  Name:      type name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    first literal string
+      --    --  Field2:    next string type
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Literal_String,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    next literal string
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     string value
+
+      --    N_Attribute_Declaration,
+      --    --  Name:      attribute name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: attribute kind
+      --    --  Field1:    expression
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     associative array index
+      --    --             (if an associative array element)
+
+      --    N_Typed_Variable_Declaration,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    expression
+      --    --  Field2:    type of variable (N_String_Type_Declaration)
+      --    --  Field3:    next variable
+      --    --  Value:     not used
+
+      --    N_Variable_Declaration,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: variable kind
+      --    --  Field1:    expression
+      --    --  Field2:    not used
+      --    --             Field3 is used for next variable, instead of Field2,
+      --    --             so that it is the same field for
+      --    --             N_Variable_Declaration and
+      --    --             N_Typed_Variable_Declaration
+      --    --  Field3:    next variable
+      --    --  Value:     not used
+
+      --    N_Expression,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: expression kind
+      --    --  Field1:    first term
+      --    --  Field2:    next expression in list
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Term,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: term kind
+      --    --  Field1:    current term
+      --    --  Field2:    next term in the expression
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Literal_String_List,
+      --    --  Designates a list of string expressions between brackets
+      --    --  separated by commas. The string expressions are not necessarily
+      --    --  literal strings.
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: List
+      --    --  Field1:    first expression
+      --    --  Field2:    not used
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Variable_Reference,
+      --    --  Name:      variable name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: variable kind
+      --    --  Field1:    project (if specified)
+      --    --  Field2:    package (if specified)
+      --    --  Field3:    type of variable (N_String_Type_Declaration), if any
+      --    --  Value:     not used
+
+      --    N_External_Value,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Single
+      --    --  Field1:    Name of the external reference (literal string)
+      --    --  Field2:    Default (literal string)
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Attribute_Reference,
+      --    --  Name:      attribute name
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: attribute kind
+      --    --  Field1:    project
+      --    --  Field2:    package (if attribute of a package)
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Case_Construction,
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: Undefined
+      --    --  Field1:    case variable reference
+      --    --  Field2:    first case item
+      --    --  Field3:    not used
+      --    --  Value:     not used
+
+      --    N_Case_Item);
+      --    --  Name:      not used
+      --    --  Path_Name: not used
+      --    --  Expr_Kind: not used
+      --    --  Field1:    first choice (literal string)
+      --    --  Field2:    first declarative item
+      --    --  Field3:    next case item
+      --    --  Value:     not used
+
+      package Project_Nodes is
+         new Table.Table (Table_Component_Type => Project_Node_Record,
+                          Table_Index_Type     => Project_Node_Id,
+                          Table_Low_Bound      => First_Node_Id,
+                          Table_Initial        => Project_Nodes_Initial,
+                          Table_Increment      => Project_Nodes_Increment,
+                          Table_Name           => "Project_Nodes");
+      --  This table contains the syntactic tree of project data
+      --  from project files.
+
+      type Project_Name_And_Node is record
+         Name     : Name_Id;
+         --  Name of the project
+         Node     : Project_Node_Id;
+         --  Node of the project in table Project_Nodes
+         Modified : Boolean;
+         --  True when the project is being modified by another project
+      end record;
+
+      No_Project_Name_And_Node : constant Project_Name_And_Node :=
+        (Name => No_Name, Node => Empty_Node, Modified => True);
+
+      package Projects_Htable is new GNAT.HTable.Simple_HTable
+        (Header_Num => Header_Num,
+         Element    => Project_Name_And_Node,
+         No_Element => No_Project_Name_And_Node,
+         Key        => Name_Id,
+         Hash       => Hash,
+         Equal      => "=");
+      --  This hash table contains a mapping of project names to project nodes.
+      --  Note that this hash table contains only the nodes whose Kind is
+      --  N_Project. It is used to find the node of a project from its
+      --  name, and to verify if a project has already been parsed, knowing
+      --  its name.
+
+   end Tree_Private_Part;
+
+end Prj.Tree;
diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb
new file mode 100644
index 0000000..6a94a0c
--- /dev/null
+++ b/gcc/ada/prj-util.adb
@@ -0,0 +1,415 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . U T I L                             --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.8 $                              --
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Namet;    use Namet;
+with Osint;
+with Output;   use Output;
+with Stringt;  use Stringt;
+
+package body Prj.Util is
+
+   procedure Free is new Ada.Unchecked_Deallocation
+     (Text_File_Data, Text_File);
+
+   -----------
+   -- Close --
+   -----------
+
+   procedure Close (File : in out Text_File) is
+   begin
+      if File = null then
+         Osint.Fail ("Close attempted on an invalid Text_File");
+      end if;
+
+      Close (File.FD);
+      Free (File);
+   end Close;
+
+   -----------------
+   -- End_Of_File --
+   -----------------
+
+   function End_Of_File (File : Text_File) return Boolean is
+   begin
+      if File = null then
+         Osint.Fail ("End_Of_File attempted on an invalid Text_File");
+      end if;
+
+      return File.End_Of_File_Reached;
+   end End_Of_File;
+
+   --------------
+   -- Get_Line --
+   --------------
+
+   procedure Get_Line
+     (File : Text_File;
+      Line : out String;
+      Last : out Natural)
+   is
+      C : Character;
+
+      procedure Advance;
+
+      -------------
+      -- Advance --
+      -------------
+
+      procedure Advance is
+      begin
+         if File.Cursor = File.Buffer_Len then
+            File.Buffer_Len :=
+              Read
+               (FD => File.FD,
+                A  => File.Buffer'Address,
+                N  => File.Buffer'Length);
+
+            if File.Buffer_Len = 0 then
+               File.End_Of_File_Reached := True;
+               return;
+            else
+               File.Cursor := 1;
+            end if;
+
+         else
+            File.Cursor := File.Cursor + 1;
+         end if;
+      end Advance;
+
+   --  Start of processing for Get_Line
+
+   begin
+      if File = null then
+         Osint.Fail ("Get_Line attempted on an invalid Text_File");
+      end if;
+
+      Last := Line'First - 1;
+
+      if not File.End_Of_File_Reached then
+         loop
+            C := File.Buffer (File.Cursor);
+            exit when C = ASCII.CR or else C = ASCII.LF;
+            Last := Last + 1;
+            Line (Last) := C;
+            Advance;
+
+            if File.End_Of_File_Reached then
+               return;
+            end if;
+
+            exit when Last = Line'Last;
+         end loop;
+
+         if C = ASCII.CR or else C = ASCII.LF then
+            Advance;
+
+            if File.End_Of_File_Reached then
+               return;
+            end if;
+         end if;
+
+         if C = ASCII.CR
+           and then File.Buffer (File.Cursor) = ASCII.LF
+         then
+            Advance;
+         end if;
+      end if;
+   end Get_Line;
+
+   --------------
+   -- Is_Valid --
+   --------------
+
+   function Is_Valid (File : Text_File) return Boolean is
+   begin
+      return File /= null;
+   end Is_Valid;
+
+   ----------
+   -- Open --
+   ----------
+
+   procedure Open (File : out Text_File; Name : in String) is
+      FD        : File_Descriptor;
+      File_Name : String (1 .. Name'Length + 1);
+
+   begin
+      File_Name (1 .. Name'Length) := Name;
+      File_Name (File_Name'Last) := ASCII.NUL;
+      FD := Open_Read (Name => File_Name'Address,
+                            Fmode => GNAT.OS_Lib.Text);
+      if FD = Invalid_FD then
+         File := null;
+      else
+         File := new Text_File_Data;
+         File.FD := FD;
+         File.Buffer_Len :=
+           Read (FD => FD,
+                 A  => File.Buffer'Address,
+                 N  => File.Buffer'Length);
+
+         if File.Buffer_Len = 0 then
+            File.End_Of_File_Reached := True;
+         else
+            File.Cursor := 1;
+         end if;
+      end if;
+   end Open;
+
+   --------------
+   -- Value_Of --
+   --------------
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Name_Id
+   is
+      Current : Array_Element_Id := In_Array;
+      Element : Array_Element;
+
+   begin
+      while Current /= No_Array_Element loop
+         Element := Array_Elements.Table (Current);
+
+         if Index = Element.Index then
+            exit when Element.Value.Kind /= Single;
+            exit when String_Length (Element.Value.Value) = 0;
+            String_To_Name_Buffer (Element.Value.Value);
+            return Name_Find;
+         else
+            Current := Element.Next;
+         end if;
+      end loop;
+
+      return No_Name;
+   end Value_Of;
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Variable_Value
+   is
+      Current : Array_Element_Id := In_Array;
+      Element : Array_Element;
+
+   begin
+      while Current /= No_Array_Element loop
+         Element := Array_Elements.Table (Current);
+
+         if Index = Element.Index then
+            return Element.Value;
+         else
+            Current := Element.Next;
+         end if;
+      end loop;
+
+      return Nil_Variable_Value;
+   end Value_Of;
+
+   function Value_Of
+     (Name                    : Name_Id;
+      Attribute_Or_Array_Name : Name_Id;
+      In_Package              : Package_Id)
+      return                   Variable_Value
+   is
+      The_Array     : Array_Element_Id;
+      The_Attribute : Variable_Value := Nil_Variable_Value;
+
+   begin
+      if In_Package /= No_Package then
+
+         --  First, look if there is an array element that fits
+
+         The_Array :=
+           Value_Of
+             (Name      => Attribute_Or_Array_Name,
+              In_Arrays => Packages.Table (In_Package).Decl.Arrays);
+         The_Attribute :=
+           Value_Of
+             (Index    => Name,
+              In_Array => The_Array);
+
+         --  If there is no array element, look for a variable
+
+         if The_Attribute = Nil_Variable_Value then
+            The_Attribute :=
+              Value_Of
+                (Variable_Name => Attribute_Or_Array_Name,
+                 In_Variables  => Packages.Table (In_Package).Decl.Attributes);
+         end if;
+      end if;
+
+      return The_Attribute;
+   end Value_Of;
+
+   function Value_Of
+     (Index     : Name_Id;
+      In_Array  : Name_Id;
+      In_Arrays : Array_Id)
+      return      Name_Id
+   is
+      Current : Array_Id := In_Arrays;
+      The_Array : Array_Data;
+
+   begin
+      while Current /= No_Array loop
+         The_Array := Arrays.Table (Current);
+         if The_Array.Name = In_Array then
+            return Value_Of (Index, In_Array => The_Array.Value);
+         else
+            Current := The_Array.Next;
+         end if;
+      end loop;
+
+      return No_Name;
+   end Value_Of;
+
+   function Value_Of
+     (Name      : Name_Id;
+      In_Arrays : Array_Id)
+      return      Array_Element_Id
+   is
+      Current : Array_Id := In_Arrays;
+      The_Array : Array_Data;
+
+   begin
+      while Current /= No_Array loop
+         The_Array := Arrays.Table (Current);
+         if The_Array.Name = Name then
+            return The_Array.Value;
+         else
+            Current := The_Array.Next;
+         end if;
+      end loop;
+
+      return No_Array_Element;
+   end Value_Of;
+
+   function Value_Of
+     (Name        : Name_Id;
+      In_Packages : Package_Id)
+      return        Package_Id
+   is
+      Current : Package_Id := In_Packages;
+      The_Package : Package_Element;
+
+   begin
+      while Current /= No_Package loop
+         The_Package := Packages.Table (Current);
+         exit when The_Package.Name /= No_Name and then
+           The_Package.Name = Name;
+         Current := The_Package.Next;
+      end loop;
+
+      return Current;
+   end Value_Of;
+
+   function Value_Of
+     (Variable_Name : Name_Id;
+      In_Variables  : Variable_Id)
+      return          Variable_Value
+   is
+      Current : Variable_Id := In_Variables;
+      The_Variable : Variable;
+
+   begin
+      while Current /= No_Variable loop
+         The_Variable := Variable_Elements.Table (Current);
+
+         if Variable_Name = The_Variable.Name then
+            return The_Variable.Value;
+         else
+            Current := The_Variable.Next;
+         end if;
+      end loop;
+
+      return Nil_Variable_Value;
+   end Value_Of;
+
+   ---------------
+   -- Write_Str --
+   ---------------
+
+   procedure Write_Str
+     (S          : String;
+      Max_Length : Positive;
+      Separator  : Character)
+   is
+      First : Positive := S'First;
+      Last  : Natural  := S'Last;
+
+   begin
+      --  Nothing to do for empty strings
+
+      if S'Length > 0 then
+         --  Start on a new line if current line is already longer than
+         --  Max_Length.
+
+         if Positive (Column) >= Max_Length then
+            Write_Eol;
+         end if;
+
+         --  If length of remainder is longer than Max_Length, we need to
+         --  cut the remainder in several lines.
+
+         while Positive (Column) + S'Last - First > Max_Length loop
+            --  Try the maximum length possible
+
+            Last := First + Max_Length - Positive (Column);
+
+            --  Look for last Separator in the line
+
+            while Last >= First and then S (Last) /= Separator loop
+               Last := Last - 1;
+            end loop;
+
+            --  If we do not find a separator, we output the maximum length
+            --  possible.
+            if Last < First then
+               Last := First + Max_Length - Positive (Column);
+            end if;
+
+            Write_Line (S (First .. Last));
+
+            --  Set the beginning of the new remainder
+
+            First := Last + 1;
+
+         end loop;
+
+         --  What is left goes to the buffer, without EOL
+
+         Write_Str (S (First .. S'Last));
+
+      end if;
+   end Write_Str;
+
+end Prj.Util;
diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads
new file mode 100644
index 0000000..baef040
--- /dev/null
+++ b/gcc/ada/prj-util.ads
@@ -0,0 +1,148 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              P R J . U T I L                             --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.6 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  Utilities when using project files.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Types;       use Types;
+
+package Prj.Util is
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Name_Id;
+   --  Get a single string array component.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Array is null, or if the component is a String list.
+
+   function Value_Of
+     (Index    : Name_Id;
+      In_Array : Array_Element_Id)
+      return     Variable_Value;
+   --  Get a string array component (single String or String list).
+   --  Returns Nil_Variable_Value if there is no component Index
+   --  (case sensitive), or if In_Array is null.
+
+   function Value_Of
+     (Name                    : Name_Id;
+      Attribute_Or_Array_Name : Name_Id;
+      In_Package              : Package_Id)
+      return                   Variable_Value;
+   --  In a specific package,
+   --   - if there exists an array Variable_Or_Array_Name with an index
+   --     Name, returns the corresponding component,
+   --   - otherwise if there is a attribute Attribute_Or_Array_Name,
+   --     returns this attribute,
+   --   - otherwise, returns Nil_Variable_Value.
+   --  If In_Package is null, returns Nil_Variable_Value.
+
+   function Value_Of
+     (Index     : Name_Id;
+      In_Array  : Name_Id;
+      In_Arrays : Array_Id)
+      return      Name_Id;
+   --  Get a string array component in an array of an array list.
+   --  Returns No_Name if there is no component Index (case sensitive),
+   --  if In_Arrays is null, if In_Array is not found in In_Arrays,
+   --  or if the component is a String list.
+
+   function Value_Of
+     (Name      : Name_Id;
+      In_Arrays : Array_Id)
+      return      Array_Element_Id;
+   --  Returns a specified array in an array list.
+   --  Returns No_Array_Element if In_Arrays is null or if Name is not the
+   --  name of an array in In_Arrays.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Name        : Name_Id;
+      In_Packages : Package_Id)
+      return        Package_Id;
+   --  Returns a specified package in a package list.
+   --  Returns No_Package if In_Packages is null or if Name is not the
+   --  name of a package in Package_List.
+   --  Assumption: Name is in lower case.
+
+   function Value_Of
+     (Variable_Name : Name_Id;
+      In_Variables  : Variable_Id)
+      return          Variable_Value;
+   --  Returns a specified variable in a variable list.
+   --  Returns null if In_Variables is null or if Variable_Name
+   --  is not the name of a variable in In_Variables.
+   --  Assumption: Variable_Name is in lower case.
+
+   procedure Write_Str
+     (S          : String;
+      Max_Length : Positive;
+      Separator  : Character);
+   --  Output string S using Output.Write_Str.
+   --  If S is too long to fit in one line of Max_Length, cut it in
+   --  several lines, using Separator as the last character of each line,
+   --  if possible.
+
+   type Text_File is limited private;
+   --  Represents a text file.
+   --  Default is invalid text file.
+
+   function Is_Valid (File : Text_File) return Boolean;
+   --  Returns True if File designates an open text file that
+   --  has not yet been closed.
+
+   procedure Open (File : out Text_File; Name : String);
+   --  Open a text file. If this procedure fails, File is invalid.
+
+   function End_Of_File (File : Text_File) return Boolean;
+   --  Returns True if the end of the text file File has been
+   --  reached. Fails if File is invalid.
+
+   procedure Get_Line
+     (File : Text_File;
+      Line : out String;
+      Last : out Natural);
+   --  Reads a line from an open text file. Fails if File is invalid.
+
+   procedure Close (File : in out Text_File);
+   --  Close an open text file. File becomes invalid.
+   --  Fails if File is already invalid.
+
+private
+
+   type Text_File_Data is record
+      FD                  : File_Descriptor := Invalid_FD;
+      Buffer              : String (1 .. 1_000);
+      Buffer_Len          : Natural;
+      Cursor              : Natural := 0;
+      End_Of_File_Reached : Boolean := False;
+   end record;
+
+   type Text_File is access Text_File_Data;
+
+end Prj.Util;
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
new file mode 100644
index 0000000..8e30211
--- /dev/null
+++ b/gcc/ada/prj.adb
@@ -0,0 +1,286 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P R J                                   --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.16 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Errout;      use Errout;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet;       use Namet;
+with Osint;       use Osint;
+with Prj.Attr;
+with Prj.Com;
+with Prj.Env;
+with Scans;       use Scans;
+with Scn;
+with Stringt;     use Stringt;
+with Sinfo.CN;
+with Snames;      use Snames;
+
+package body Prj is
+
+   The_Empty_String : String_Id;
+
+   subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
+
+   The_Casing_Images : array (Known_Casing) of String_Access :=
+     (All_Lower_Case => new String'("lowercase"),
+      All_Upper_Case => new String'("UPPERCASE"),
+      Mixed_Case     => new String'("MixedCase"));
+
+   Initialized : Boolean := False;
+
+   Standard_Dot_Replacement      : constant Name_Id :=
+     First_Name_Id + Character'Pos ('-');
+   Standard_Specification_Append : Name_Id;
+   Standard_Body_Append          : Name_Id;
+
+   Std_Naming_Data : Naming_Data :=
+     (Dot_Replacement      => Standard_Dot_Replacement,
+      Dot_Repl_Loc         => No_Location,
+      Casing               => All_Lower_Case,
+      Specification_Append => No_Name,
+      Spec_Append_Loc      => No_Location,
+      Body_Append          => No_Name,
+      Body_Append_Loc      => No_Location,
+      Separate_Append      => No_Name,
+      Sep_Append_Loc       => No_Location,
+      Specifications       => No_Array_Element,
+      Bodies               => No_Array_Element);
+
+   Project_Empty : Project_Data :=
+     (First_Referred_By  => No_Project,
+      Name               => No_Name,
+      Path_Name          => No_Name,
+      Location           => No_Location,
+      Directory          => No_Name,
+      File_Name          => No_Name,
+      Library            => False,
+      Library_Dir        => No_Name,
+      Library_Name       => No_Name,
+      Library_Kind       => Static,
+      Lib_Internal_Name  => No_Name,
+      Lib_Elaboration    => False,
+      Sources            => Nil_String,
+      Source_Dirs        => Nil_String,
+      Object_Directory   => No_Name,
+      Modifies           => No_Project,
+      Modified_By        => No_Project,
+      Naming             => Std_Naming_Data,
+      Decl               => No_Declarations,
+      Imported_Projects  => Empty_Project_List,
+      Include_Path       => null,
+      Objects_Path       => null,
+      Config_File_Name   => No_Name,
+      Config_File_Temp   => False,
+      Config_Checked     => False,
+      Checked            => False,
+      Seen               => False,
+      Flag1              => False,
+      Flag2              => False);
+
+   -------------------
+   -- Empty_Project --
+   -------------------
+
+   function Empty_Project return Project_Data is
+   begin
+      Initialize;
+      return Project_Empty;
+   end Empty_Project;
+
+   ------------------
+   -- Empty_String --
+   ------------------
+
+   function Empty_String return String_Id is
+   begin
+      return The_Empty_String;
+   end Empty_String;
+
+   ------------
+   -- Expect --
+   ------------
+
+   procedure Expect (The_Token : Token_Type; Token_Image : String) is
+   begin
+      if Token /= The_Token then
+         Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
+      end if;
+   end Expect;
+
+   --------------------------------
+   -- For_Every_Project_Imported --
+   --------------------------------
+
+   procedure For_Every_Project_Imported
+     (By         : Project_Id;
+      With_State : in out State)
+   is
+
+      procedure Check (Project : Project_Id);
+      --  Check if a project has already been seen.
+      --  If not seen, mark it as seen, call Action,
+      --  and check all its imported projects.
+
+      procedure Check (Project : Project_Id) is
+         List : Project_List;
+
+      begin
+         if not Projects.Table (Project).Seen then
+            Projects.Table (Project).Seen := False;
+            Action (Project, With_State);
+
+            List := Projects.Table (Project).Imported_Projects;
+            while List /= Empty_Project_List loop
+               Check (Project_Lists.Table (List).Project);
+               List := Project_Lists.Table (List).Next;
+            end loop;
+         end if;
+      end Check;
+
+   begin
+      for Project in Projects.First .. Projects.Last loop
+         Projects.Table (Project).Seen := False;
+      end loop;
+
+      Check (Project => By);
+   end For_Every_Project_Imported;
+
+   -----------
+   -- Image --
+   -----------
+
+   function Image (Casing : Casing_Type) return String is
+   begin
+      return The_Casing_Images (Casing).all;
+   end Image;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      if not Initialized then
+         Initialized := True;
+         Stringt.Initialize;
+         Start_String;
+         The_Empty_String := End_String;
+         Name_Len := 4;
+         Name_Buffer (1 .. 4) := ".ads";
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Specification_Append := Name_Find;
+         Name_Buffer (4) := 'b';
+         Canonical_Case_File_Name (Name_Buffer (1 .. 4));
+         Standard_Body_Append := Name_Find;
+         Std_Naming_Data.Specification_Append := Standard_Specification_Append;
+         Std_Naming_Data.Body_Append          := Standard_Body_Append;
+         Std_Naming_Data.Separate_Append      := Standard_Body_Append;
+         Project_Empty.Naming                 := Std_Naming_Data;
+         Prj.Env.Initialize;
+         Prj.Attr.Initialize;
+         Set_Name_Table_Byte (Name_Project,   Token_Type'Pos (Tok_Project));
+         Set_Name_Table_Byte (Name_Modifying, Token_Type'Pos (Tok_Modifying));
+         Set_Name_Table_Byte (Name_External,  Token_Type'Pos (Tok_External));
+      end if;
+   end Initialize;
+
+   ------------
+   --  Reset --
+   ------------
+
+   procedure Reset is
+   begin
+      Projects.Init;
+      Project_Lists.Init;
+      Packages.Init;
+      Arrays.Init;
+      Variable_Elements.Init;
+      String_Elements.Init;
+      Prj.Com.Units.Init;
+      Prj.Com.Units_Htable.Reset;
+   end Reset;
+
+   ------------------------
+   -- Same_Naming_Scheme --
+   ------------------------
+
+   function Same_Naming_Scheme
+     (Left, Right : Naming_Data)
+      return        Boolean
+   is
+   begin
+      return Left.Dot_Replacement = Right.Dot_Replacement
+        and then Left.Casing = Right.Casing
+        and then Left.Specification_Append = Right.Specification_Append
+        and then Left.Body_Append = Right.Body_Append
+        and then Left.Separate_Append = Right.Separate_Append;
+   end Same_Naming_Scheme;
+
+   ----------
+   -- Scan --
+   ----------
+
+   procedure Scan is
+   begin
+      Scn.Scan;
+
+      --  Change operator symbol to literal strings, since that's the way
+      --  we treat all strings in a project file.
+
+      if Token = Tok_Operator_Symbol then
+         Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
+         Token := Tok_String_Literal;
+      end if;
+   end Scan;
+
+   --------------------------
+   -- Standard_Naming_Data --
+   --------------------------
+
+   function Standard_Naming_Data return Naming_Data is
+   begin
+      Initialize;
+      return Std_Naming_Data;
+   end Standard_Naming_Data;
+
+   -----------
+   -- Value --
+   -----------
+
+   function Value (Image : String) return Casing_Type is
+   begin
+      for Casing in The_Casing_Images'Range loop
+         if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
+            return Casing;
+         end if;
+      end loop;
+
+      raise Constraint_Error;
+   end Value;
+
+end Prj;
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
new file mode 100644
index 0000000..409a071
--- /dev/null
+++ b/gcc/ada/prj.ads
@@ -0,0 +1,416 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                  P R J                                   --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.18 $
+--                                                                          --
+--             Copyright (C) 2001 Free Software Foundation, Inc.            --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  The following package declares the data types for GNAT project.
+--  These data types may be used by GNAT Project-aware tools.
+
+--  Children of these package implements various services on these data types.
+--  See in particular Prj.Pars and Prj.Env.
+
+with Casing;      use Casing;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Scans;       use Scans;
+with Table;
+with Types;       use Types;
+
+package Prj is
+
+   type Put_Line_Access is access procedure (Line : String);
+   --  Use to customize error reporting in Prj.Proc and Prj.Nmsc.
+
+   type Verbosity is (Default, Medium, High);
+   --  Verbosity when parsing GNAT Project Files.
+   --  Default is default (very quiet, if no errors).
+   --  Medium is more verbose.
+   --  High is extremely verbose.
+
+   type Lib_Kind is (Static, Dynamic, Relocatable);
+
+   function Empty_String return String_Id;
+
+   type String_List_Id is new Nat;
+   Nil_String : constant String_List_Id := 0;
+   type String_Element is record
+      Value    : String_Id      := No_String;
+      Location : Source_Ptr     := No_Location;
+      Next     : String_List_Id := Nil_String;
+   end record;
+   --  To hold values for string list variables and array elements.
+
+   package String_Elements is new Table.Table
+     (Table_Component_Type => String_Element,
+      Table_Index_Type     => String_List_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.String_Elements");
+   --  The table for string elements in string lists.
+
+   type Variable_Kind is (Undefined, List, Single);
+   --  Different kinds of variables
+
+   type Variable_Value (Kind : Variable_Kind := Undefined) is record
+      Location : Source_Ptr := No_Location;
+      Default  : Boolean    := False;
+      case Kind is
+         when Undefined =>
+            null;
+         when List =>
+            Values : String_List_Id := Nil_String;
+         when Single =>
+            Value : String_Id := No_String;
+      end case;
+   end record;
+   --  Values for variables and array elements
+
+   Nil_Variable_Value : constant Variable_Value :=
+     (Kind     => Undefined,
+      Location => No_Location,
+      Default  => False);
+   --  Value of a non existing variable or array element.
+
+   type Variable_Id is new Nat;
+   No_Variable : constant Variable_Id := 0;
+   type Variable is record
+      Next     : Variable_Id := No_Variable;
+      Name     : Name_Id;
+      Value    : Variable_Value;
+   end record;
+   --  To hold the list of variables in a project file and in packages.
+
+   package Variable_Elements is new Table.Table
+     (Table_Component_Type => Variable,
+      Table_Index_Type     => Variable_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Variable_Elements");
+   --  The table of variable in list of variables.
+
+   type Array_Element_Id is new Nat;
+   No_Array_Element : constant Array_Element_Id := 0;
+   type Array_Element is record
+      Index    : Name_Id;
+      Value    : Variable_Value;
+      Next     : Array_Element_Id := No_Array_Element;
+   end record;
+   --  Each Array_Element represents an array element.
+   --  Each Array_Element is linked (Next) to the next array element,
+   --  if any, in the array.
+
+   package Array_Elements is new Table.Table
+     (Table_Component_Type => Array_Element,
+      Table_Index_Type     => Array_Element_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Array_Elements");
+   --  The table that contains all array elements
+
+   type Array_Id is new Nat;
+   No_Array : constant Array_Id := 0;
+   type Array_Data is record
+      Name  : Name_Id          := No_Name;
+      Value : Array_Element_Id := No_Array_Element;
+      Next  : Array_Id         := No_Array;
+   end record;
+   --  Each Array_Data represents an array.
+   --  Value is the id of the first element.
+   --  Next is the id of the next array in the project file or package.
+
+   package Arrays is new Table.Table
+     (Table_Component_Type => Array_Data,
+      Table_Index_Type     => Array_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 200,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Arrays");
+   --  The table that contains all arrays
+
+   type Package_Id is new Nat;
+   No_Package : constant Package_Id := 0;
+   type Declarations is record
+      Variables  : Variable_Id := No_Variable;
+      Attributes : Variable_Id := No_Variable;
+      Arrays     : Array_Id    := No_Array;
+      Packages   : Package_Id  := No_Package;
+   end record;
+
+   No_Declarations : constant Declarations :=
+     (Variables  => No_Variable,
+      Attributes => No_Variable,
+      Arrays     => No_Array,
+      Packages   => No_Package);
+   --  Declarations. Used in project structures and packages.
+
+   type Package_Element is record
+      Name   : Name_Id      := No_Name;
+      Decl   : Declarations := No_Declarations;
+      Parent : Package_Id   := No_Package;
+      Next   : Package_Id   := No_Package;
+   end record;
+   --  A package. Includes declarations that may include
+   --  other packages.
+
+   package Packages is new Table.Table
+     (Table_Component_Type => Package_Element,
+      Table_Index_Type     => Package_Id,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Packages");
+   --  The table that contains all packages.
+
+   function Image (Casing : Casing_Type) return String;
+   --  Similar to 'Image
+
+   function Value (Image : String) return Casing_Type;
+   --  Similar to 'Value
+   --  This is to avoid s-valenu in the closure of the tools
+   --  Raises Constraint_Error if not a Casing_Type image.
+
+   type Naming_Data is record
+      Dot_Replacement      : Name_Id          := No_Name;
+      --  The string to replace '.' in the source file name.
+
+      Dot_Repl_Loc         : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Dot_Replacement is defined.
+
+      Casing               : Casing_Type      := All_Lower_Case;
+      --  The casing of the source file name.
+
+      Specification_Append : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a specification.
+
+      Spec_Append_Loc      : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Specification_Append is defined.
+
+      Body_Append          : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a body.
+
+      Body_Append_Loc      : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Body_Append is defined.
+
+      Separate_Append      : Name_Id          := No_Name;
+      --  The string to append to the unit name for the
+      --  source file name of a subunit.
+
+      Sep_Append_Loc       : Source_Ptr       := No_Location;
+      --  The position in the project file source where
+      --  Separate_Append is defined.
+
+      Specifications       : Array_Element_Id := No_Array_Element;
+      --  An associative array mapping individual specifications
+      --  to source file names.
+
+      Bodies               : Array_Element_Id := No_Array_Element;
+      --  An associative array mapping individual bodies
+      --  to source file names.
+
+   end record;
+   --  A naming scheme.
+
+   function Standard_Naming_Data return Naming_Data;
+   pragma Inline (Standard_Naming_Data);
+   --  The standard GNAT naming scheme.
+
+   function Same_Naming_Scheme
+     (Left, Right : Naming_Data)
+      return        Boolean;
+   --  Returns True if Left and Right are the same naming scheme
+   --  not considering Specifications and Bodies.
+
+   type Project_Id is new Nat;
+   No_Project : constant Project_Id := 0;
+   --  Id of a Project File
+
+   type Project_List is new Nat;
+   Empty_Project_List : constant Project_List := 0;
+   --  A list of project files.
+
+   type Project_Element is record
+      Project : Project_Id   := No_Project;
+      Next    : Project_List := Empty_Project_List;
+   end record;
+   --  Element in a list of project file.
+   --  Next is the id of the next project file in the list.
+
+   package Project_Lists is new Table.Table
+     (Table_Component_Type => Project_Element,
+      Table_Index_Type     => Project_List,
+      Table_Low_Bound      => 1,
+      Table_Initial        => 100,
+      Table_Increment      => 100,
+      Table_Name           => "Prj.Project_Lists");
+   --  The table that contains the lists of project files.
+
+   type Project_Data is record
+      First_Referred_By  : Project_Id     := No_Project;
+      --  The project, if any, that was the first to be known
+      --  as importing or modifying this project.
+
+      Name               : Name_Id        := No_Name;
+      --  The name of the project.
+
+      Path_Name          : Name_Id        := No_Name;
+      --  The path name of the project file.
+
+      Location           : Source_Ptr     := No_Location;
+      --  The location in the project file source of the
+      --  reserved word project.
+
+      Directory          : Name_Id        := No_Name;
+      --  The directory where the project file resides.
+
+      File_Name          : Name_Id        := No_Name;
+      --  The file name of the project file.
+
+      Library            : Boolean        := False;
+      --  True if this is a library project
+
+      Library_Dir        : Name_Id        := No_Name;
+      --  If a library project, directory where resides the library
+
+      Library_Name       : Name_Id        := No_Name;
+      --  If a library project, name of the library
+
+      Library_Kind       : Lib_Kind       := Static;
+      --  If a library project, kind of library
+
+      Lib_Internal_Name  : Name_Id        := No_Name;
+      --  If a library project, internal name store inside the library
+
+      Lib_Elaboration    : Boolean        := False;
+      --  If a library project, indicate if <lib>init and <lib>final
+      --  procedures need to be defined.
+
+      Sources            : String_List_Id := Nil_String;
+      --  The list of all the source file names.
+
+      Source_Dirs        : String_List_Id := Nil_String;
+      --  The list of all the source directories.
+
+      Object_Directory   : Name_Id        := No_Name;
+      --  The object directory of this project file.
+
+      Modifies           : Project_Id     := No_Project;
+      --  The reference of the project file, if any, that this
+      --  project file modifies.
+
+      Modified_By        : Project_Id     := No_Project;
+      --  The reference of the project file, if any, that
+      --  modifies this project file.
+
+      Naming             : Naming_Data    := Standard_Naming_Data;
+      --  The naming scheme of this project file.
+
+      Decl               : Declarations   := No_Declarations;
+      --  The declarations (variables, attributes and packages)
+      --  of this project file.
+
+      Imported_Projects  : Project_List   := Empty_Project_List;
+      --  The list of all directly imported projects, if any.
+
+      Include_Path       : String_Access  := null;
+      --  The cached value of ADA_INCLUDE_PATH for this project file.
+
+      Objects_Path       : String_Access  := null;
+      --  The cached value of ADA_OBJECTS_PATH for this project file.
+
+      Config_File_Name   : Name_Id        := No_Name;
+      --  The name of the configuration pragmas file, if any.
+
+      Config_File_Temp   : Boolean        := False;
+      --  An indication that the configuration pragmas file is
+      --  a temporary file that must be deleted at the end.
+
+      Config_Checked     : Boolean        := False;
+      --  A flag to avoid checking repetively the configuration pragmas file.
+
+      Checked            : Boolean        := False;
+      --  A flag to avoid checking repetively the naming scheme of
+      --  this project file.
+
+      --  Various flags that are used in an ad hoc manner
+
+      Seen               : Boolean        := False;
+      Flag1              : Boolean        := False;
+      Flag2              : Boolean        := False;
+
+   end record;
+   --  Project File representation.
+
+   function Empty_Project return Project_Data;
+   --  Return the representation of an empty project.
+
+   package Projects is new Table.Table (
+     Table_Component_Type => Project_Data,
+     Table_Index_Type     => Project_Id,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 100,
+     Table_Increment      => 100,
+     Table_Name           => "Prj.Projects");
+   --  The set of all project files.
+
+   procedure Expect (The_Token : Token_Type; Token_Image : String);
+   --  Check that the current token is The_Token. If it is not, then
+   --  output an error message.
+
+   procedure Initialize;
+   --  This procedure must be called before using any services from the Prj
+   --  hierarchy. Namet.Initialize must be called before Prj.Initialize.
+
+   procedure Reset;
+   --  This procedure resets all the tables that are used when processing a
+   --  project file tree. Initialize must be called before the call to Reset.
+
+   generic
+      type State is limited private;
+      with procedure Action
+        (Project    : Project_Id;
+         With_State : in out State);
+   procedure For_Every_Project_Imported
+     (By         : Project_Id;
+      With_State : in out State);
+   --  Call Action for each project imported directly or indirectly by project
+   --  By.--  Action is called according to the order of importation: if A
+   --  imports B, directly or indirectly, Action will be called for A before
+   --  it is called for B. With_State may be used by Action to choose a
+   --  behavior or to report some global result.
+
+private
+
+   procedure Scan;
+   --  Calls Scn.Scan and change any Operator_Symbol to String_Literal
+
+end Prj;
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
new file mode 100644
index 0000000..43d6307
--- /dev/null
+++ b/gcc/ada/raise.c
@@ -0,0 +1,86 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *             Copyright (C) 1992-2001, Free Software Foundation, Inc.      *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* Routines to support runtime exception handling */
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+#include "raise.h"
+
+/*  We have not yet figured out how to import this directly */
+
+void
+_gnat_builtin_longjmp (ptr, flag)
+     void *ptr;
+     int flag ATTRIBUTE_UNUSED;
+{
+   __builtin_longjmp (ptr, 1);
+}
+
+/* When an exception is raised for which no handler exists, the procedure
+   Ada.Exceptions.Unhandled_Exception is called, which performs the call to
+   adafinal to complete finalization, and then prints out the error messages
+   for the unhandled exception. The final step is to call this routine, which
+   performs any system dependent cleanup required.  */
+
+void
+__gnat_unhandled_terminate ()
+{
+  /* Special termination handling for VMS */
+
+#ifdef VMS
+    {
+      long prvhnd;
+
+      /* Remove the exception vector so it won't intercept any errors
+	 in the call to exit, and go into and endless loop */
+
+      SYS$SETEXV (1, 0, 3, &prvhnd);
+      __gnat_os_exit (1);
+    }
+
+/* Termination handling for all other systems. */
+
+#elif !defined (__RT__)
+    __gnat_os_exit (1);
+#endif
+}
diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h
new file mode 100644
index 0000000..8db83f4
--- /dev/null
+++ b/gcc/ada/raise.h
@@ -0,0 +1,71 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                                R A I S E                                 *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                            $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1992-2001, Free Software Foundation, Inc.         *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+struct Exception_Data
+{ 
+  char  Handled_By_Others;
+  char Lang;
+  int Name_Length;
+  char *Full_Name, Htable_Ptr;
+  int Import_Code;
+};
+
+typedef struct Exception_Data *Exception_Id;
+
+struct Exception_Occurrence
+{
+  int Max_Length;
+  Exception_Id Id;
+  int Msg_Length;
+  char Msg [0];
+};
+
+typedef struct Exception_Occurrence *Exception_Occurrence_Access;
+
+extern void _gnat_builtin_longjmp	PARAMS ((void *, int));
+extern void __gnat_unhandled_terminate	PARAMS ((void));
+extern void *__gnat_malloc		PARAMS ((__SIZE_TYPE__));
+extern void __gnat_free			PARAMS ((void *));
+extern void *__gnat_realloc		PARAMS ((void *, __SIZE_TYPE__));
+extern void __gnat_finalize		PARAMS ((void));
+extern void set_gnat_exit_status	PARAMS ((int));
+extern void __gnat_set_globals		PARAMS ((int, int, int, int, int, int,
+						 void (*) PARAMS ((void)),
+						 int, int));
+extern void __gnat_initialize		PARAMS ((void));
+extern void __gnat_init_float		PARAMS ((void));
+extern void __gnat_install_handler	PARAMS ((void));
+
+extern int gnat_exit_status;
+
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
new file mode 100644
index 0000000..9e71152
--- /dev/null
+++ b/gcc/ada/repinfo.adb
@@ -0,0 +1,1024 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R E P I N F O                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.36 $
+--                                                                          --
+--          Copyright (C) 1999-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Alloc;    use Alloc;
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Opt;      use Opt;
+with Output;   use Output;
+with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
+with Table;    use Table;
+with Uname;    use Uname;
+with Urealp;   use Urealp;
+
+package body Repinfo is
+
+   SSU : constant := 8;
+   --  Value for Storage_Unit, we do not want to get this from TTypes, since
+   --  this introduces problematic dependencies in ASIS, and in any case this
+   --  value is assumed to be 8 for the implementation of the DDA.
+   --  This is wrong for AAMP???
+
+   ---------------------------------------
+   -- Representation of gcc Expressions --
+   ---------------------------------------
+
+   --    This table is used only if Frontend_Layout_On_Target is False,
+   --    so that gigi lays out dynamic size/offset fields using encoded
+   --    gcc expressions.
+
+   --    A table internal to this unit is used to hold the values of
+   --    back annotated expressions. This table is written out by -gnatt
+   --    and read back in for ASIS processing.
+
+   --    Node values are stored as Uint values which are the negative of
+   --    the node index in this table. Constants appear as non-negative
+   --    Uint values.
+
+   type Exp_Node is record
+      Expr : TCode;
+      Op1  : Node_Ref_Or_Val;
+      Op2  : Node_Ref_Or_Val;
+      Op3  : Node_Ref_Or_Val;
+   end record;
+
+   package Rep_Table is new Table.Table (
+      Table_Component_Type => Exp_Node,
+      Table_Index_Type     => Nat,
+      Table_Low_Bound      => 1,
+      Table_Initial        => Alloc.Rep_Table_Initial,
+      Table_Increment      => Alloc.Rep_Table_Increment,
+      Table_Name           => "BE_Rep_Table");
+
+   --------------------------------------------------------------
+   -- Representation of Front-End Dynamic Size/Offset Entities --
+   --------------------------------------------------------------
+
+   package Dynamic_SO_Entity_Table is new Table.Table (
+      Table_Component_Type => Entity_Id,
+      Table_Index_Type     => Nat,
+      Table_Low_Bound      => 1,
+      Table_Initial        => Alloc.Rep_Table_Initial,
+      Table_Increment      => Alloc.Rep_Table_Increment,
+      Table_Name           => "FE_Rep_Table");
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   Unit_Casing : Casing_Type;
+   --  Indentifier casing for current unit
+
+   procedure Spaces (N : Natural);
+   --  Output given number of spaces
+
+   function Back_End_Layout return Boolean;
+   --  Test for layout mode, True = back end, False = front end. This
+   --  function is used rather than checking the configuration parameter
+   --  because we do not want Repinfo to depend on Targparm (for ASIS)
+
+   procedure List_Entities (Ent : Entity_Id);
+   --  This procedure lists the entities associated with the entity E,
+   --  starting with the First_Entity and using the Next_Entity link.
+   --  If a nested package is found, entities within the package are
+   --  recursively processed.
+
+   procedure List_Name (Ent : Entity_Id);
+   --  List name of entity Ent in appropriate case. The name is listed with
+   --  full qualification up to but not including the compilation unit name.
+
+   procedure List_Array_Info (Ent : Entity_Id);
+   --  List representation info for array type Ent
+
+   procedure List_Object_Info (Ent : Entity_Id);
+   --  List representation info for object Ent
+
+   procedure List_Record_Info (Ent : Entity_Id);
+   --  List representation info for record type Ent
+
+   procedure List_Type_Info (Ent : Entity_Id);
+   --  List type info for type Ent
+
+   function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
+   --  Returns True if Val represents a variable value, and False if it
+   --  represents a value that is fixed at compile time.
+
+   procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
+   --  Given a representation value, write it out. No_Uint values or values
+   --  dependent on discriminants are written as two question marks. If the
+   --  flag Paren is set, then the output is surrounded in parentheses if
+   --  it is other than a simple value.
+
+   ---------------------
+   -- Back_End_Layout --
+   ---------------------
+
+   function Back_End_Layout return Boolean is
+   begin
+      --  We have back end layout if the back end has made any entries in
+      --  the table of GCC expressions, otherwise we have front end layout.
+
+      return Rep_Table.Last > 0;
+   end Back_End_Layout;
+
+   ------------------------
+   -- Create_Discrim_Ref --
+   ------------------------
+
+   function Create_Discrim_Ref
+     (Discr : Entity_Id)
+      return  Node_Ref
+   is
+      N : constant Uint := Discriminant_Number (Discr);
+      T : Nat;
+
+   begin
+      Rep_Table.Increment_Last;
+      T := Rep_Table.Last;
+      Rep_Table.Table (T).Expr := Discrim_Val;
+      Rep_Table.Table (T).Op1  := N;
+      Rep_Table.Table (T).Op2  := No_Uint;
+      Rep_Table.Table (T).Op3  := No_Uint;
+      return UI_From_Int (-T);
+   end Create_Discrim_Ref;
+
+   ---------------------------
+   -- Create_Dynamic_SO_Ref --
+   ---------------------------
+
+   function Create_Dynamic_SO_Ref
+     (E    : Entity_Id)
+      return Dynamic_SO_Ref
+   is
+      T : Nat;
+
+   begin
+      Dynamic_SO_Entity_Table.Increment_Last;
+      T := Dynamic_SO_Entity_Table.Last;
+      Dynamic_SO_Entity_Table.Table (T) := E;
+      return UI_From_Int (-T);
+   end Create_Dynamic_SO_Ref;
+
+   -----------------
+   -- Create_Node --
+   -----------------
+
+   function Create_Node
+     (Expr : TCode;
+      Op1  : Node_Ref_Or_Val;
+      Op2  : Node_Ref_Or_Val := No_Uint;
+      Op3  : Node_Ref_Or_Val := No_Uint)
+      return  Node_Ref
+   is
+      T : Nat;
+
+   begin
+      Rep_Table.Increment_Last;
+      T := Rep_Table.Last;
+      Rep_Table.Table (T).Expr := Expr;
+      Rep_Table.Table (T).Op1  := Op1;
+      Rep_Table.Table (T).Op2  := Op2;
+      Rep_Table.Table (T).Op3  := Op3;
+
+      return UI_From_Int (-T);
+   end Create_Node;
+
+   ---------------------------
+   -- Get_Dynamic_SO_Entity --
+   ---------------------------
+
+   function Get_Dynamic_SO_Entity
+     (U    : Dynamic_SO_Ref)
+      return Entity_Id
+   is
+   begin
+      return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
+   end Get_Dynamic_SO_Entity;
+
+   -----------------------
+   -- Is_Dynamic_SO_Ref --
+   -----------------------
+
+   function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
+   begin
+      return U < Uint_0;
+   end Is_Dynamic_SO_Ref;
+
+   ----------------------
+   -- Is_Static_SO_Ref --
+   ----------------------
+
+   function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
+   begin
+      return U >= Uint_0;
+   end Is_Static_SO_Ref;
+
+   ---------
+   -- lgx --
+   ---------
+
+   procedure lgx (U : Node_Ref_Or_Val) is
+   begin
+      List_GCC_Expression (U);
+      Write_Eol;
+   end lgx;
+
+   ----------------------
+   -- List_Array_Info --
+   ----------------------
+
+   procedure List_Array_Info (Ent : Entity_Id) is
+   begin
+      List_Type_Info (Ent);
+
+      Write_Str ("for ");
+      List_Name (Ent);
+      Write_Str ("'Component_Size use ");
+      Write_Val (Component_Size (Ent));
+      Write_Line (";");
+   end List_Array_Info;
+
+   -------------------
+   -- List_Entities --
+   -------------------
+
+   procedure List_Entities (Ent : Entity_Id) is
+      E : Entity_Id;
+
+   begin
+      if Present (Ent) then
+         E := First_Entity (Ent);
+         while Present (E) loop
+            if Comes_From_Source (E) or else Debug_Flag_AA then
+
+               if Is_Record_Type (E) then
+                  List_Record_Info (E);
+
+               elsif Is_Array_Type (E) then
+                  List_Array_Info (E);
+
+               elsif List_Representation_Info >= 2 then
+
+                  if Is_Type (E) then
+                     List_Type_Info (E);
+
+                  elsif Ekind (E) = E_Variable
+                          or else
+                        Ekind (E) = E_Constant
+                          or else
+                        Ekind (E) = E_Loop_Parameter
+                          or else
+                        Is_Formal (E)
+                  then
+                     List_Object_Info (E);
+                  end if;
+               end if;
+
+               --  Recurse over nested package, but not if they are
+               --  package renamings (in particular renamings of the
+               --  enclosing package, as for some Java bindings and
+               --  for generic instances).
+
+               if (Ekind (E) = E_Package
+                         and then No (Renamed_Object (E)))
+                       or else
+                     Ekind (E) = E_Protected_Type
+                       or else
+                     Ekind (E) = E_Task_Type
+                       or else
+                     Ekind (E) = E_Subprogram_Body
+                       or else
+                     Ekind (E) = E_Package_Body
+                       or else
+                     Ekind (E) = E_Task_Body
+                       or else
+                     Ekind (E) = E_Protected_Body
+               then
+                  List_Entities (E);
+               end if;
+            end if;
+
+            E := Next_Entity (E);
+         end loop;
+      end if;
+   end List_Entities;
+
+   -------------------------
+   -- List_GCC_Expression --
+   -------------------------
+
+   procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
+
+      procedure P (Val : Node_Ref_Or_Val);
+      --  Internal recursive procedure to print expression
+
+      procedure P (Val : Node_Ref_Or_Val) is
+      begin
+         if Val >= 0 then
+            UI_Write (Val, Decimal);
+
+         else
+            declare
+               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
+
+               procedure Binop (S : String);
+               --  Output text for binary operator with S being operator name
+
+               procedure Binop (S : String) is
+               begin
+                  Write_Char ('(');
+                  P (Node.Op1);
+                  Write_Str (S);
+                  P (Node.Op2);
+                  Write_Char (')');
+               end Binop;
+
+            --  Start of processing for P
+
+            begin
+               case Node.Expr is
+                  when Cond_Expr =>
+                     Write_Str ("(if ");
+                     P (Node.Op1);
+                     Write_Str (" then ");
+                     P (Node.Op2);
+                     Write_Str (" else ");
+                     P (Node.Op3);
+                     Write_Str (" end)");
+
+                  when Plus_Expr =>
+                     Binop (" + ");
+
+                  when Minus_Expr =>
+                     Binop (" - ");
+
+                  when Mult_Expr =>
+                     Binop (" * ");
+
+                  when Trunc_Div_Expr =>
+                     Binop (" /t ");
+
+                  when Ceil_Div_Expr =>
+                     Binop (" /c ");
+
+                  when Floor_Div_Expr =>
+                     Binop (" /f ");
+
+                  when Trunc_Mod_Expr =>
+                     Binop (" modt ");
+
+                  when Floor_Mod_Expr =>
+                     Binop (" modf ");
+
+                  when Ceil_Mod_Expr =>
+                     Binop (" modc ");
+
+                  when Exact_Div_Expr =>
+                     Binop (" /e ");
+
+                  when Negate_Expr =>
+                     Write_Char ('-');
+                     P (Node.Op1);
+
+                  when Min_Expr =>
+                     Binop (" min ");
+
+                  when Max_Expr =>
+                     Binop (" max ");
+
+                  when Abs_Expr =>
+                     Write_Str ("abs ");
+                     P (Node.Op1);
+
+                  when Truth_Andif_Expr =>
+                     Binop (" and if ");
+
+                  when Truth_Orif_Expr =>
+                     Binop (" or if ");
+
+                  when Truth_And_Expr =>
+                     Binop (" and ");
+
+                  when Truth_Or_Expr =>
+                     Binop (" or ");
+
+                  when Truth_Xor_Expr =>
+                     Binop (" xor ");
+
+                  when Truth_Not_Expr =>
+                     Write_Str ("not ");
+                     P (Node.Op1);
+
+                  when Lt_Expr =>
+                     Binop (" < ");
+
+                  when Le_Expr =>
+                     Binop (" <= ");
+
+                  when Gt_Expr =>
+                     Binop (" > ");
+
+                  when Ge_Expr =>
+                     Binop (" >= ");
+
+                  when Eq_Expr =>
+                     Binop (" == ");
+
+                  when Ne_Expr =>
+                     Binop (" != ");
+
+                  when Discrim_Val =>
+                     Write_Char ('#');
+                     UI_Write (Node.Op1);
+
+               end case;
+            end;
+         end if;
+      end P;
+
+   --  Start of processing for List_GCC_Expression
+
+   begin
+      if U = No_Uint then
+         Write_Line ("??");
+      else
+         P (U);
+      end if;
+   end List_GCC_Expression;
+
+   ---------------
+   -- List_Name --
+   ---------------
+
+   procedure List_Name (Ent : Entity_Id) is
+   begin
+      if not Is_Compilation_Unit (Scope (Ent)) then
+         List_Name (Scope (Ent));
+         Write_Char ('.');
+      end if;
+
+      Get_Unqualified_Decoded_Name_String (Chars (Ent));
+      Set_Casing (Unit_Casing);
+      Write_Str (Name_Buffer (1 .. Name_Len));
+   end List_Name;
+
+   ---------------------
+   -- List_Object_Info --
+   ---------------------
+
+   procedure List_Object_Info (Ent : Entity_Id) is
+   begin
+      Write_Eol;
+
+      if Known_Esize (Ent) then
+         Write_Str ("for ");
+         List_Name (Ent);
+         Write_Str ("'Size use ");
+         Write_Val (Esize (Ent));
+         Write_Line (";");
+      end if;
+
+      if Known_Alignment (Ent) then
+         Write_Str ("for ");
+         List_Name (Ent);
+         Write_Str ("'Alignment use ");
+         Write_Val (Alignment (Ent));
+         Write_Line (";");
+      end if;
+   end List_Object_Info;
+
+   ----------------------
+   -- List_Record_Info --
+   ----------------------
+
+   procedure List_Record_Info (Ent : Entity_Id) is
+      Comp  : Entity_Id;
+      Esiz  : Uint;
+      Cfbit : Uint;
+      Sunit : Uint;
+
+      Max_Name_Length : Natural;
+      Max_Suni_Length : Natural;
+
+   begin
+      List_Type_Info (Ent);
+
+      Write_Str ("for ");
+      List_Name (Ent);
+      Write_Line (" use record");
+
+      --  First loop finds out max line length and max starting position
+      --  length, for the purpose of lining things up nicely.
+
+      Max_Name_Length := 0;
+      Max_Suni_Length   := 0;
+
+      Comp := First_Entity (Ent);
+      while Present (Comp) loop
+         if Ekind (Comp) = E_Component
+           or else Ekind (Comp) = E_Discriminant
+         then
+            Get_Decoded_Name_String (Chars (Comp));
+            Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
+
+            Cfbit := Component_Bit_Offset (Comp);
+
+            if Rep_Not_Constant (Cfbit) then
+               UI_Image_Length := 2;
+
+            else
+               --  Complete annotation in case not done
+
+               Set_Normalized_Position (Comp, Cfbit / SSU);
+               Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
+
+               Esiz  := Esize (Comp);
+               Sunit := Cfbit / SSU;
+               UI_Image (Sunit);
+            end if;
+
+            if Unknown_Normalized_First_Bit (Comp) then
+               Set_Normalized_First_Bit (Comp, Uint_0);
+            end if;
+
+            Max_Suni_Length :=
+              Natural'Max (Max_Suni_Length, UI_Image_Length);
+         end if;
+
+         Comp := Next_Entity (Comp);
+      end loop;
+
+      --  Second loop does actual output based on those values
+
+      Comp := First_Entity (Ent);
+      while Present (Comp) loop
+         if Ekind (Comp) = E_Component
+           or else Ekind (Comp) = E_Discriminant
+         then
+            declare
+               Esiz : constant Uint := Esize (Comp);
+               Bofs : constant Uint := Component_Bit_Offset (Comp);
+               Npos : constant Uint := Normalized_Position (Comp);
+               Fbit : constant Uint := Normalized_First_Bit (Comp);
+               Lbit : Uint;
+
+            begin
+               Write_Str ("   ");
+               Get_Decoded_Name_String (Chars (Comp));
+               Set_Casing (Unit_Casing);
+               Write_Str (Name_Buffer (1 .. Name_Len));
+
+               for J in 1 .. Max_Name_Length - Name_Len loop
+                  Write_Char (' ');
+               end loop;
+
+               Write_Str (" at ");
+
+               if Known_Static_Normalized_Position (Comp) then
+                  UI_Image (Npos);
+                  Spaces (Max_Suni_Length - UI_Image_Length);
+                  Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
+
+               elsif Known_Component_Bit_Offset (Comp)
+                 and then List_Representation_Info = 3
+               then
+                  Spaces (Max_Suni_Length - 2);
+                  Write_Val (Bofs, Paren => True);
+                  Write_Str (" / 8");
+
+               elsif Known_Normalized_Position (Comp)
+                 and then List_Representation_Info = 3
+               then
+                  Spaces (Max_Suni_Length - 2);
+                  Write_Val (Npos);
+
+               else
+                  Write_Str ("??");
+               end if;
+
+               Write_Str (" range  ");
+               UI_Write (Fbit);
+               Write_Str (" .. ");
+
+               if not Is_Dynamic_SO_Ref (Esize (Comp)) then
+                  Lbit := Fbit + Esiz - 1;
+
+                  if Lbit < 10 then
+                     Write_Char (' ');
+                  end if;
+
+                  UI_Write (Lbit);
+
+               elsif List_Representation_Info < 3 then
+                  Write_Str ("??");
+
+               else -- List_Representation >= 3
+
+                  Write_Val (Esiz, Paren => True);
+
+                  --  If in front end layout mode, then dynamic size is
+                  --  stored in storage units, so renormalize for output
+
+                  if not Back_End_Layout then
+                     Write_Str (" * ");
+                     Write_Int (SSU);
+                  end if;
+
+                  --  Add appropriate first bit offset
+
+                  if Fbit = 0 then
+                     Write_Str (" - 1");
+
+                  elsif Fbit = 1 then
+                     null;
+
+                  else
+                     Write_Str (" + ");
+                     Write_Int (UI_To_Int (Fbit) - 1);
+                  end if;
+               end if;
+
+               Write_Line (";");
+            end;
+         end if;
+
+         Comp := Next_Entity (Comp);
+      end loop;
+
+      Write_Line ("end record;");
+   end List_Record_Info;
+
+   -------------------
+   -- List_Rep_Info --
+   -------------------
+
+   procedure List_Rep_Info is
+      Col : Nat;
+
+   begin
+      for U in Main_Unit .. Last_Unit loop
+         if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
+            Unit_Casing := Identifier_Casing (Source_Index (U));
+            Write_Eol;
+            Write_Str ("Representation information for unit ");
+            Write_Unit_Name (Unit_Name (U));
+            Col := Column;
+            Write_Eol;
+
+            for J in 1 .. Col - 1 loop
+               Write_Char ('-');
+            end loop;
+
+            Write_Eol;
+            List_Entities (Cunit_Entity (U));
+         end if;
+      end loop;
+   end List_Rep_Info;
+
+   --------------------
+   -- List_Type_Info --
+   --------------------
+
+   procedure List_Type_Info (Ent : Entity_Id) is
+   begin
+      Write_Eol;
+
+      --  If Esize and RM_Size are the same and known, list as Size. This
+      --  is a common case, which we may as well list in simple form.
+
+      if Esize (Ent) = RM_Size (Ent) then
+         if Known_Esize (Ent) then
+            Write_Str ("for ");
+            List_Name (Ent);
+            Write_Str ("'Size use ");
+            Write_Val (Esize (Ent));
+            Write_Line (";");
+         end if;
+
+      --  For now, temporary case, to be removed when gigi properly back
+      --  annotates RM_Size, if RM_Size is not set, then list Esize as
+      --  Size. This avoids odd Object_Size output till we fix things???
+
+      elsif Unknown_RM_Size (Ent) then
+         if Known_Esize (Ent) then
+            Write_Str ("for ");
+            List_Name (Ent);
+            Write_Str ("'Size use ");
+            Write_Val (Esize (Ent));
+            Write_Line (";");
+         end if;
+
+      --  Otherwise list size values separately if they are set
+
+      else
+         if Known_Esize (Ent) then
+            Write_Str ("for ");
+            List_Name (Ent);
+            Write_Str ("'Object_Size use ");
+            Write_Val (Esize (Ent));
+            Write_Line (";");
+         end if;
+
+         --  Note on following check: The RM_Size of a discrete type can
+         --  legitimately be set to zero, so a special check is needed.
+
+         if Known_RM_Size (Ent) or else Is_Discrete_Type (Ent) then
+            Write_Str ("for ");
+            List_Name (Ent);
+            Write_Str ("'Value_Size use ");
+            Write_Val (RM_Size (Ent));
+            Write_Line (";");
+         end if;
+      end if;
+
+      if Known_Alignment (Ent) then
+         Write_Str ("for ");
+         List_Name (Ent);
+         Write_Str ("'Alignment use ");
+         Write_Val (Alignment (Ent));
+         Write_Line (";");
+      end if;
+   end List_Type_Info;
+
+   ----------------------
+   -- Rep_Not_Constant --
+   ----------------------
+
+   function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
+   begin
+      if Val = No_Uint or else Val < 0 then
+         return True;
+      else
+         return False;
+      end if;
+   end Rep_Not_Constant;
+
+   ---------------
+   -- Rep_Value --
+   ---------------
+
+   function Rep_Value
+     (Val  : Node_Ref_Or_Val;
+      D    : Discrim_List)
+      return Uint
+   is
+      function B (Val : Boolean) return Uint;
+      --  Returns Uint_0 for False, Uint_1 for True
+
+      function T (Val : Node_Ref_Or_Val) return Boolean;
+      --  Returns True for 0, False for any non-zero (i.e. True)
+
+      function V (Val : Node_Ref_Or_Val) return Uint;
+      --  Internal recursive routine to evaluate tree
+
+      -------
+      -- B --
+      -------
+
+      function B (Val : Boolean) return Uint is
+      begin
+         if Val then
+            return Uint_1;
+         else
+            return Uint_0;
+         end if;
+      end B;
+
+      -------
+      -- T --
+      -------
+
+      function T (Val : Node_Ref_Or_Val) return Boolean is
+      begin
+         if V (Val) = 0 then
+            return False;
+         else
+            return True;
+         end if;
+      end T;
+
+      -------
+      -- V --
+      -------
+
+      function V (Val : Node_Ref_Or_Val) return Uint is
+         L, R, Q : Uint;
+
+      begin
+         if Val >= 0 then
+            return Val;
+
+         else
+            declare
+               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
+
+            begin
+               case Node.Expr is
+                  when Cond_Expr =>
+                     if T (Node.Op1) then
+                        return V (Node.Op2);
+                     else
+                        return V (Node.Op3);
+                     end if;
+
+                  when Plus_Expr =>
+                     return V (Node.Op1) + V (Node.Op2);
+
+                  when Minus_Expr =>
+                     return V (Node.Op1) - V (Node.Op2);
+
+                  when Mult_Expr =>
+                     return V (Node.Op1) * V (Node.Op2);
+
+                  when Trunc_Div_Expr =>
+                     return V (Node.Op1) / V (Node.Op2);
+
+                  when Ceil_Div_Expr =>
+                     return
+                       UR_Ceiling
+                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
+
+                  when Floor_Div_Expr =>
+                     return
+                       UR_Floor
+                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
+
+                  when Trunc_Mod_Expr =>
+                     return V (Node.Op1) rem V (Node.Op2);
+
+                  when Floor_Mod_Expr =>
+                     return V (Node.Op1) mod V (Node.Op2);
+
+                  when Ceil_Mod_Expr =>
+                     L := V (Node.Op1);
+                     R := V (Node.Op2);
+                     Q := UR_Ceiling (L / UR_From_Uint (R));
+                     return L - R * Q;
+
+                  when Exact_Div_Expr =>
+                     return V (Node.Op1) / V (Node.Op2);
+
+                  when Negate_Expr =>
+                     return -V (Node.Op1);
+
+                  when Min_Expr =>
+                     return UI_Min (V (Node.Op1), V (Node.Op2));
+
+                  when Max_Expr =>
+                     return UI_Max (V (Node.Op1), V (Node.Op2));
+
+                  when Abs_Expr =>
+                     return UI_Abs (V (Node.Op1));
+
+                  when Truth_Andif_Expr =>
+                     return B (T (Node.Op1) and then T (Node.Op2));
+
+                  when Truth_Orif_Expr =>
+                     return B (T (Node.Op1) or else T (Node.Op2));
+
+                  when Truth_And_Expr =>
+                     return B (T (Node.Op1) and T (Node.Op2));
+
+                  when Truth_Or_Expr =>
+                     return B (T (Node.Op1) or T (Node.Op2));
+
+                  when Truth_Xor_Expr =>
+                     return B (T (Node.Op1) xor T (Node.Op2));
+
+                  when Truth_Not_Expr =>
+                     return B (not T (Node.Op1));
+
+                  when Lt_Expr =>
+                     return B (V (Node.Op1) < V (Node.Op2));
+
+                  when Le_Expr =>
+                     return B (V (Node.Op1) <= V (Node.Op2));
+
+                  when Gt_Expr =>
+                     return B (V (Node.Op1) > V (Node.Op2));
+
+                  when Ge_Expr =>
+                     return B (V (Node.Op1) >= V (Node.Op2));
+
+                  when Eq_Expr =>
+                     return B (V (Node.Op1) = V (Node.Op2));
+
+                  when Ne_Expr =>
+                     return B (V (Node.Op1) /= V (Node.Op2));
+
+                  when Discrim_Val =>
+                     declare
+                        Sub : constant Int := UI_To_Int (Node.Op1);
+
+                     begin
+                        pragma Assert (Sub in D'Range);
+                        return D (Sub);
+                     end;
+
+               end case;
+            end;
+         end if;
+      end V;
+
+   --  Start of processing for Rep_Value
+
+   begin
+      if Val = No_Uint then
+         return No_Uint;
+
+      else
+         return V (Val);
+      end if;
+   end Rep_Value;
+
+   ------------
+   -- Spaces --
+   ------------
+
+   procedure Spaces (N : Natural) is
+   begin
+      for J in 1 .. N loop
+         Write_Char (' ');
+      end loop;
+   end Spaces;
+
+   ---------------
+   -- Tree_Read --
+   ---------------
+
+   procedure Tree_Read is
+   begin
+      Rep_Table.Tree_Read;
+   end Tree_Read;
+
+   ----------------
+   -- Tree_Write --
+   ----------------
+
+   procedure Tree_Write is
+   begin
+      Rep_Table.Tree_Write;
+   end Tree_Write;
+
+   ---------------
+   -- Write_Val --
+   ---------------
+
+   procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
+   begin
+      if Rep_Not_Constant (Val) then
+         if List_Representation_Info < 3 then
+            Write_Str ("??");
+         else
+            if Back_End_Layout then
+               Write_Char (' ');
+               List_GCC_Expression (Val);
+               Write_Char (' ');
+            else
+               Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
+            end if;
+         end if;
+
+      else
+         UI_Write (Val);
+      end if;
+   end Write_Val;
+
+end Repinfo;
diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads
new file mode 100644
index 0000000..0b41ba0
--- /dev/null
+++ b/gcc/ada/repinfo.ads
@@ -0,0 +1,320 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R E P I N F O                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.20 $
+--                                                                          --
+--          Copyright (C) 1999-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package contains the routines to handle back annotation of the
+--  tree to fill in representation information, and also the routine used
+--  by -gnatR to print this information. This unit is used both in the
+--  compiler and in ASIS (it is used in ASIS as part of the implementation
+--  of the data decomposition annex.
+
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Repinfo is
+
+   --------------------------------
+   -- Representation Information --
+   --------------------------------
+
+   --  The representation information of interest here is size and
+   --  component information for arrays and records. For primitive
+   --  types, the front end computes the Esize and RM_Size fields of
+   --  the corresponding entities as constant non-negative integers,
+   --  and the Uint values are stored directly in these fields.
+
+   --  For composite types, there are three cases:
+
+   --    1. In some cases the front end knows the values statically,
+   --       for example in the ase where representation clauses or
+   --       pragmas specify the values.
+
+   --    2. If Backend_Layout is True, then the backend is responsible
+   --       for layout of all types and objects not laid out by the
+   --       front end. This includes all dynamic values, and also
+   --       static values (e.g. record sizes) when not set by the
+   --       front end.
+
+   --    3. If Backend_Layout is False, then the front end lays out
+   --       all data, according to target dependent size and alignment
+   --       information, creating dynamic inlinable functions where
+   --       needed in the case of sizes not known till runtime.
+
+   -----------------------------
+   -- Back-Annotation by Gigi --
+   -----------------------------
+
+   --  The following interface is used by gigi if Backend_Layout is True.
+
+   --  As part of the processing in gigi, the types are laid out and
+   --  appropriate values computed for the sizes and component positions
+   --  and sizes of records and arrays.
+
+   --  The back-annotation circuit in gigi is responsible for updating the
+   --  relevant fields in the tree to reflect these computations, as follows:
+
+   --    For E_Array_Type entities, the Component_Size field
+
+   --    For all record and array types and subtypes, the Esize field,
+   --    which contains the Size (more accurately the Object_SIze) value
+   --    for the type or subtype.
+
+   --    For E_Component and E_Distriminant entities, the Esize (size
+   --    of component) and Component_Bit_Offset fields. Note that gigi
+   --    does not (yet ???) back annotate Normalized_Position/First_Bit.
+
+   --  There are three cases to consider:
+
+   --    1. The value is constant. In this case, the back annotation works
+   --       by simply storing the non-negative universal integer value in
+   --       the appropriate field corresponding to this constant size.
+
+   --    2. The value depends on variables other than discriminants of the
+   --       current record. In this case, the value is not known, even if
+   --       the complete data of the record is available, and gigi marks
+   --       this situation by storing the special value No_Uint.
+
+   --    3. The value depends on the discriminant values for the current
+   --       record. In this case, gigi back annotates the field with a
+   --       representation of the expression for computing the value in
+   --       terms of the discriminants. A negative Uint value is used to
+   --       represent the value of such an expression, as explained in
+   --       the following section.
+
+   --  GCC expressions are represented with a Uint value that is negative.
+   --  See the body of this package for details on the representation used.
+
+   --  One other case in which gigi back annotates GCC expressions is in
+   --  the Present_Expr field of an N_Variant node. This expression which
+   --  will always depend on discriminants, and hence always be represented
+   --  as a negative Uint value, provides an expression which, when evaluated
+   --  with a given set of discriminant values, indicates whether the variant
+   --  is present for that set of values (result is True, i.e. non-zero) or
+   --  not present (result is False, i.e. zero).
+
+   subtype Node_Ref is Uint;
+   --  Subtype used for negative Uint values used to represent nodes
+
+   subtype Node_Ref_Or_Val is Uint;
+   --  Subtype used for values that can either be a Node_Ref (negative)
+   --  or a value (non-negative)
+
+   type TCode is range 0 .. 27;
+   --  Type used on Ada side to represent DEFTREECODE values defined in
+   --  tree.def. Only a subset of these tree codes can actually appear.
+   --  The names are the names from tree.def in Ada casing.
+
+   --  name                             code   description           operands
+
+   Cond_Expr        : constant TCode :=  1; -- conditional              3
+   Plus_Expr        : constant TCode :=  2; -- addition                 2
+   Minus_Expr       : constant TCode :=  3; -- subtraction              2
+   Mult_Expr        : constant TCode :=  4; -- multiplication           2
+   Trunc_Div_Expr   : constant TCode :=  5; -- truncating division      2
+   Ceil_Div_Expr    : constant TCode :=  6; -- division rounding up     2
+   Floor_Div_Expr   : constant TCode :=  7; -- division rounding down   2
+   Trunc_Mod_Expr   : constant TCode :=  8; -- mod for trunc_div        2
+   Ceil_Mod_Expr    : constant TCode :=  9; -- mod for ceil_div         2
+   Floor_Mod_Expr   : constant TCode := 10; -- mod for floor_div        2
+   Exact_Div_Expr   : constant TCode := 11; -- exact div                2
+   Negate_Expr      : constant TCode := 12; -- negation                 1
+   Min_Expr         : constant TCode := 13; -- minimum                  2
+   Max_Expr         : constant TCode := 14; -- maximum                  2
+   Abs_Expr         : constant TCode := 15; -- absolute value           1
+   Truth_Andif_Expr : constant TCode := 16; -- Boolean and then         2
+   Truth_Orif_Expr  : constant TCode := 17; -- Boolean or else          2
+   Truth_And_Expr   : constant TCode := 18; -- Boolean and              2
+   Truth_Or_Expr    : constant TCode := 19; -- Boolean or               2
+   Truth_Xor_Expr   : constant TCode := 20; -- Boolean xor              2
+   Truth_Not_Expr   : constant TCode := 21; -- Boolean not              1
+   Lt_Expr          : constant TCode := 22; -- comparision <            2
+   Le_Expr          : constant TCode := 23; -- comparision <=           2
+   Gt_Expr          : constant TCode := 24; -- comparision >            2
+   Ge_Expr          : constant TCode := 25; -- comparision >=           2
+   Eq_Expr          : constant TCode := 26; -- comparision =            2
+   Ne_Expr          : constant TCode := 27; -- comparision /=           2
+
+   --  The following entry is used to represent a discriminant value in
+   --  the tree. It has a special tree code that does not correspond
+   --  directly to a gcc node. The single operand is the number of the
+   --  discriminant in the record (1 = first discriminant).
+
+   Discrim_Val : constant TCode := 0;  -- discriminant value       1
+
+   ------------------------
+   -- The gigi Interface --
+   ------------------------
+
+   --  The following declarations are for use by gigi for back annotation
+
+   function Create_Node
+     (Expr  : TCode;
+      Op1   : Node_Ref_Or_Val;
+      Op2   : Node_Ref_Or_Val := No_Uint;
+      Op3   : Node_Ref_Or_Val := No_Uint)
+      return  Node_Ref;
+   --  Creates a node with using the tree code defined by Expr and from
+   --  1-3 operands as required (unused operands set as shown to No_Uint)
+   --  Note that this call can be used to create a discriminant reference
+   --  by using (Expr => Discrim_Val, Op1 => discriminant_number).
+
+   function Create_Discrim_Ref
+     (Discr : Entity_Id)
+      return  Node_Ref;
+   --  Creates a refrerence to the discriminant whose entity is Discr.
+
+   --------------------------------------------------------
+   -- Front-End Interface for Dynamic Size/Offset Values --
+   --------------------------------------------------------
+
+   --  If Backend_Layout is False, then the front-end deals with all
+   --  dynamic size and offset fields. There are two cases:
+
+   --    1. The value can be computed at the time of type freezing, and
+   --       is stored in a run-time constant. In this case, the field
+   --       contains a reference to this entity. In the case of sizes
+   --       the value stored is the size in storage units, since dynamic
+   --       sizes are always a multiple of storage units.
+
+   --    2. The size/offset depends on the value of discriminants at
+   --       run-time. In this case, the front end builds a function to
+   --       compute the value. This function has a single parameter
+   --       which is the discriminated record object in question. Any
+   --       references to discriminant values are simply references to
+   --       the appropriate discriminant in this single argument, and
+   --       to compute the required size/offset value at run time, the
+   --       code generator simply constructs a call to the function
+   --       with the appropriate argument. The size/offset field in
+   --       this case contains a reference to the function entity.
+   --       Note that as for case 1, if such a function is used to
+   --       return a size, then the size in storage units is returned,
+   --       not the size in bits.
+
+   --  The interface here allows these created entities to be referenced
+   --  using negative Unit values, so that they can be stored in the
+   --  appropriate size and offset fields in the tree.
+
+   --  In the case of components, if the location of the component is static,
+   --  then all four fields (Component_Bit_Offset, Normalized_Position, Esize,
+   --  and Normalized_First_Bit) are set to appropraite values. In the case of
+   --  a non-static component location, Component_Bit_Offset is not used and
+   --  is left set to Unknown. Normalized_Position and Normalized_First_Bit
+   --  are set appropriately.
+
+   subtype SO_Ref is Uint;
+   --  Type used to represent a Uint value that represents a static or
+   --  dynamic size/offset value (non-negative if static, negative if
+   --  the size value is dynamic).
+
+   subtype Dynamic_SO_Ref is Uint;
+   --  Type used to represent a negative Uint value used to store
+   --  a dynamic size/offset value.
+
+   function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean;
+   pragma Inline (Is_Dynamic_SO_Ref);
+   --  Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
+   --  represents a dynamic Size/Offset value (i.e. it is negative).
+
+   function Is_Static_SO_Ref (U : SO_Ref) return Boolean;
+   pragma Inline (Is_Static_SO_Ref);
+   --  Given a SO_Ref (Uint) value, returns True iff the SO_Ref value
+   --  represents a static Size/Offset value (i.e. it is non-negative).
+
+   function Create_Dynamic_SO_Ref
+     (E    : Entity_Id)
+      return Dynamic_SO_Ref;
+   --  Given the Entity_Id for a constant (case 1), the Node_Id for an
+   --  expression (case 2), or the Entity_Id for a function (case 3),
+   --  this function returns a (negative) Uint value that can be used
+   --  to retrieve the entity or expression for later use.
+
+   function Get_Dynamic_SO_Entity
+     (U    : Dynamic_SO_Ref)
+      return Entity_Id;
+   --  Retrieve the Node_Id or Entity_Id stored by a previous call to
+   --  Create_Dynamic_SO_Ref. The approach is that the front end makes
+   --  the necessary Create_Dynamic_SO_Ref calls to associate the node
+   --  and entity id values and the back end makes Get_Dynamic_SO_Ref
+   --  calls to retrive them.
+
+   --------------------
+   -- ASIS_Interface --
+   --------------------
+
+   type Discrim_List is array (Pos range <>) of Uint;
+   --  Type used to represent list of discriminant values
+
+   function Rep_Value
+     (Val  : Node_Ref_Or_Val;
+      D    : Discrim_List)
+      return Uint;
+   --  Given the contents of a First_Bit_Position or Esize field containing
+   --  a node reference (i.e. a negative Uint value) and D, the list of
+   --  discriminant values, returns the interpreted value of this field.
+   --  For convenience, Rep_Value will take a non-negative Uint value
+   --  as an argument value, and return it unmodified. A No_Uint value is
+   --  also returned unmodified.
+
+   procedure Tree_Read;
+   --  Read in the value of the Rep_Table
+
+   ------------------------
+   -- Compiler Interface --
+   ------------------------
+
+   procedure List_Rep_Info;
+   --  Procedure to list representation information
+
+   procedure Tree_Write;
+   --  Write out the value of the Rep_Table
+
+   --------------------------
+   -- Debugging Procedures --
+   --------------------------
+
+   procedure List_GCC_Expression (U : Node_Ref_Or_Val);
+   --  Prints out given expression in symbolic form. Constants are listed
+   --  in decimal numeric form, Discriminants are listed with a # followed
+   --  by the discriminant number, and operators are output in appropriate
+   --  symbolic form No_Uint displays as two question marks. The output is
+   --  on a single line but has no line return after it. This procedure is
+   --  useful only if operating in backend layout mode.
+
+   procedure lgx (U : Node_Ref_Or_Val);
+   --  In backend layout mode, this is like List_GCC_Expression, but
+   --  includes a line return at the end. If operating in front end
+   --  layout mode, then the name of the entity for the size (either
+   --  a function of a variable) is listed followed by a line return.
+
+end Repinfo;
diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h
new file mode 100644
index 0000000..305c818
--- /dev/null
+++ b/gcc/ada/repinfo.h
@@ -0,0 +1,79 @@
+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                              R E P I N F O                               *
+ *                                                                          *
+ *                              C Header File                               *
+ *                                                                          *
+ *                             $Revision: 1.1 $
+ *                                                                          *
+ *          Copyright (C) 1999-2001 Free Software Foundation, Inc.          *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
+ * MA 02111-1307, USA.                                                      *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ *                                                                          *
+ ****************************************************************************/
+
+/* This file corresponds to the Ada file repinfo.ads.  */
+
+typedef Uint Node_Ref;
+typedef Uint Node_Ref_Or_Val;
+typedef char TCode;
+
+/* These are the values of TCcode that correspond to tree codes in tree.def,
+   except for the first, which is how we encode discriminants.  */
+
+#define Discrim_Val       0
+#define Cond_Expr         1
+#define Plus_Expr         2
+#define Minus_Expr        3
+#define Mult_Expr         4
+#define Trunc_Div_Expr    5
+#define Ceil_Div_Expr     6
+#define Floor_Div_Expr    7
+#define Trunc_Mod_Expr    8
+#define Ceil_Mod_Expr     9
+#define Floor_Mod_Expr   10
+#define Exact_Div_Expr   11
+#define Negate_Expr      12
+#define Min_Expr         13
+#define Max_Expr         14
+#define Abs_Expr         15
+#define Truth_Andif_Expr 16
+#define Truth_Orif_Expr  17
+#define Truth_And_Expr   18
+#define Truth_Or_Expr    19
+#define Truth_Xor_Expr   20
+#define Truth_Not_Expr   21
+#define Lt_Expr          22
+#define Le_Expr          23
+#define Gt_Expr          24
+#define Ge_Expr          25
+#define Eq_Expr          26
+#define Ne_Expr          27
+
+/* Creates a node using the tree code defined by Expr and from 1-3
+   operands as required (unused operands set as shown to No_Uint) Note
+   that this call can be used to create a discriminant reference by
+   using (Expr => Discrim_Val, Op1 => discriminant_number).  */
+#define Create_Node repinfo__create_node
+extern Node_Ref Create_Node	PARAMS((TCode, Node_Ref_Or_Val,
+					Node_Ref_Or_Val, Node_Ref_Or_Val));
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
new file mode 100644
index 0000000..a284cd4
--- /dev/null
+++ b/gcc/ada/restrict.adb
@@ -0,0 +1,458 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             R E S T R I C T                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.37 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Stand;    use Stand;
+with Uname;    use Uname;
+
+package body Restrict is
+
+   function Suppress_Restriction_Message (N : Node_Id) return Boolean;
+   --  N is the node for a possible restriction violation message, but
+   --  the message is to be suppressed if this is an internal file and
+   --  this file is not the main unit.
+
+   -------------------
+   -- Abort_Allowed --
+   -------------------
+
+   function Abort_Allowed return Boolean is
+   begin
+      return
+        Restrictions (No_Abort_Statements) = False
+          or else
+        Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
+   end Abort_Allowed;
+
+   ------------------------------------
+   -- Check_Elaboration_Code_Allowed --
+   ------------------------------------
+
+   procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
+   begin
+      --  Avoid calling Namet.Unlock/Lock except when there is an error.
+      --  Even in the error case it is a bit dubious, either gigi needs
+      --  the table locked or it does not! ???
+
+      if Restrictions (No_Elaboration_Code)
+        and then not Suppress_Restriction_Message (N)
+      then
+         Namet.Unlock;
+         Check_Restriction (No_Elaboration_Code, N);
+         Namet.Lock;
+      end if;
+   end Check_Elaboration_Code_Allowed;
+
+   ---------------------------
+   -- Check_Restricted_Unit --
+   ---------------------------
+
+   procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
+   begin
+      if Suppress_Restriction_Message (N) then
+         return;
+
+      elsif Is_Spec_Name (U) then
+         declare
+            Fnam : constant File_Name_Type :=
+                     Get_File_Name (U, Subunit => False);
+            R_Id : Restriction_Id;
+
+         begin
+            if not Is_Predefined_File_Name (Fnam) then
+               return;
+
+            --  Ada child unit spec, needs checking against list
+
+            else
+               --  Pad name to 8 characters with blanks
+
+               Get_Name_String (Fnam);
+               Name_Len := Name_Len - 4;
+
+               while Name_Len < 8 loop
+                  Name_Len := Name_Len + 1;
+                  Name_Buffer (Name_Len) := ' ';
+               end loop;
+
+               for J in Unit_Array'Range loop
+                  if Name_Len = 8
+                    and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
+                  then
+                     R_Id := Unit_Array (J).Res_Id;
+                     Violations (R_Id) := True;
+
+                     if Restrictions (R_Id) then
+                        declare
+                           S : constant String := Restriction_Id'Image (R_Id);
+
+                        begin
+                           Error_Msg_Unit_1 := U;
+
+                           Error_Msg_N
+                             ("dependence on $ not allowed,", N);
+
+                           Name_Buffer (1 .. S'Last) := S;
+                           Name_Len := S'Length;
+                           Set_Casing (All_Lower_Case);
+                           Error_Msg_Name_1 := Name_Enter;
+                           Error_Msg_Sloc := Restrictions_Loc (R_Id);
+
+                           Error_Msg_N
+                             ("\violates pragma Restriction (%) #", N);
+                           return;
+                        end;
+                     end if;
+                  end if;
+               end loop;
+            end if;
+         end;
+      end if;
+   end Check_Restricted_Unit;
+
+   -----------------------
+   -- Check_Restriction --
+   -----------------------
+
+   --  Case of simple identifier (no parameter)
+
+   procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
+   begin
+      Violations (R) := True;
+
+      if Restrictions (R)
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            S : constant String := Restriction_Id'Image (R);
+
+         begin
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restrictions_Loc (R);
+            Error_Msg_N ("violation of restriction %#", N);
+         end;
+      end if;
+   end Check_Restriction;
+
+   --  Case where a parameter is present (but no count)
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      N : Node_Id)
+   is
+   begin
+      if Restriction_Parameters (R) = Uint_0
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            Loc : constant Source_Ptr := Sloc (N);
+            S   : constant String :=
+                    Restriction_Parameter_Id'Image (R);
+
+         begin
+            Error_Msg_NE
+              ("& will be raised at run time?!", N, Standard_Storage_Error);
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restriction_Parameters_Loc (R);
+            Error_Msg_N ("violation of restriction %?#!", N);
+
+            Insert_Action (N,
+              Make_Raise_Storage_Error (Loc));
+         end;
+      end if;
+   end Check_Restriction;
+
+   --  Case where a parameter is present, with a count
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      V : Uint;
+      N : Node_Id)
+   is
+   begin
+      if Restriction_Parameters (R) /= No_Uint
+        and then V > Restriction_Parameters (R)
+        and then not Suppress_Restriction_Message (N)
+      then
+         declare
+            S : constant String := Restriction_Parameter_Id'Image (R);
+
+         begin
+            Name_Buffer (1 .. S'Last) := S;
+            Name_Len := S'Length;
+            Set_Casing (All_Lower_Case);
+            Error_Msg_Name_1 := Name_Enter;
+            Error_Msg_Sloc := Restriction_Parameters_Loc (R);
+            Error_Msg_N ("maximum value exceeded for restriction %#", N);
+         end;
+      end if;
+   end Check_Restriction;
+
+   -------------------------------------------
+   -- Compilation_Unit_Restrictions_Restore --
+   -------------------------------------------
+
+   procedure Compilation_Unit_Restrictions_Restore
+     (R : Save_Compilation_Unit_Restrictions)
+   is
+   begin
+      for J in Compilation_Unit_Restrictions loop
+         Restrictions (J) := R (J);
+      end loop;
+   end Compilation_Unit_Restrictions_Restore;
+
+   ----------------------------------------
+   -- Compilation_Unit_Restrictions_Save --
+   ----------------------------------------
+
+   function Compilation_Unit_Restrictions_Save
+     return Save_Compilation_Unit_Restrictions
+   is
+      R : Save_Compilation_Unit_Restrictions;
+
+   begin
+      for J in Compilation_Unit_Restrictions loop
+         R (J) := Restrictions (J);
+         Restrictions (J) := False;
+      end loop;
+
+      return R;
+   end Compilation_Unit_Restrictions_Save;
+
+   ----------------------------------
+   -- Disallow_In_No_Run_Time_Mode --
+   ----------------------------------
+
+   procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
+   begin
+      if No_Run_Time then
+         Error_Msg_N
+           ("this construct not allowed in No_Run_Time mode", Enode);
+      end if;
+   end Disallow_In_No_Run_Time_Mode;
+
+   ------------------------
+   -- Get_Restriction_Id --
+   ------------------------
+
+   function Get_Restriction_Id
+     (N    : Name_Id)
+      return Restriction_Id
+   is
+      J : Restriction_Id;
+
+   begin
+      Get_Name_String (N);
+      Set_Casing (All_Upper_Case);
+
+      J := Restriction_Id'First;
+      while J /= Not_A_Restriction_Id loop
+         declare
+            S : constant String := Restriction_Id'Image (J);
+
+         begin
+            exit when S = Name_Buffer (1 .. Name_Len);
+         end;
+
+         J := Restriction_Id'Succ (J);
+      end loop;
+
+      return J;
+   end Get_Restriction_Id;
+
+   ----------------------------------
+   -- Get_Restriction_Parameter_Id --
+   ----------------------------------
+
+   function Get_Restriction_Parameter_Id
+     (N    : Name_Id)
+      return Restriction_Parameter_Id
+   is
+      J : Restriction_Parameter_Id;
+
+   begin
+      Get_Name_String (N);
+      Set_Casing (All_Upper_Case);
+
+      J := Restriction_Parameter_Id'First;
+      while J /= Not_A_Restriction_Parameter_Id loop
+         declare
+            S : constant String := Restriction_Parameter_Id'Image (J);
+
+         begin
+            exit when S = Name_Buffer (1 .. Name_Len);
+         end;
+
+         J := Restriction_Parameter_Id'Succ (J);
+      end loop;
+
+      return J;
+   end Get_Restriction_Parameter_Id;
+
+   -------------------------------
+   -- No_Exception_Handlers_Set --
+   -------------------------------
+
+   function No_Exception_Handlers_Set return Boolean is
+   begin
+      return Restrictions (No_Exception_Handlers);
+   end No_Exception_Handlers_Set;
+
+   ------------------------
+   -- Restricted_Profile --
+   ------------------------
+
+   --  This implementation must be coordinated with Set_Restricted_Profile
+
+   function Restricted_Profile return Boolean is
+   begin
+      return     Restrictions (No_Abort_Statements)
+        and then Restrictions (No_Asynchronous_Control)
+        and then Restrictions (No_Entry_Queue)
+        and then Restrictions (No_Task_Hierarchy)
+        and then Restrictions (No_Task_Allocators)
+        and then Restrictions (No_Dynamic_Priorities)
+        and then Restrictions (No_Terminate_Alternatives)
+        and then Restrictions (No_Dynamic_Interrupts)
+        and then Restrictions (No_Protected_Type_Allocators)
+        and then Restrictions (No_Local_Protected_Objects)
+        and then Restrictions (No_Requeue)
+        and then Restrictions (No_Task_Attributes)
+        and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) =  0
+        and then Restriction_Parameters (Max_Task_Entries)                =  0
+        and then Restriction_Parameters (Max_Protected_Entries)           <= 1
+        and then Restriction_Parameters (Max_Select_Alternatives)         =  0;
+   end Restricted_Profile;
+
+   --------------------------
+   -- Set_No_Run_Time_Mode --
+   --------------------------
+
+   procedure Set_No_Run_Time_Mode is
+   begin
+      No_Run_Time := True;
+      Restrictions (No_Exception_Handlers) := True;
+   end Set_No_Run_Time_Mode;
+
+   -------------------
+   -- Set_Ravenscar --
+   -------------------
+
+   procedure Set_Ravenscar is
+   begin
+      Set_Restricted_Profile;
+      Restrictions (Boolean_Entry_Barriers)       := True;
+      Restrictions (No_Select_Statements)         := True;
+      Restrictions (No_Calendar)                  := True;
+      Restrictions (Static_Storage_Size)          := True;
+      Restrictions (No_Entry_Queue)               := True;
+      Restrictions (No_Relative_Delay)            := True;
+      Restrictions (No_Task_Termination)          := True;
+      Restrictions (No_Implicit_Heap_Allocations) := True;
+   end Set_Ravenscar;
+
+   ----------------------------
+   -- Set_Restricted_Profile --
+   ----------------------------
+
+   --  This must be coordinated with Restricted_Profile
+
+   procedure Set_Restricted_Profile is
+   begin
+      Restrictions (No_Abort_Statements)          := True;
+      Restrictions (No_Asynchronous_Control)      := True;
+      Restrictions (No_Entry_Queue)               := True;
+      Restrictions (No_Task_Hierarchy)            := True;
+      Restrictions (No_Task_Allocators)           := True;
+      Restrictions (No_Dynamic_Priorities)        := True;
+      Restrictions (No_Terminate_Alternatives)    := True;
+      Restrictions (No_Dynamic_Interrupts)        := True;
+      Restrictions (No_Protected_Type_Allocators) := True;
+      Restrictions (No_Local_Protected_Objects)   := True;
+      Restrictions (No_Requeue)                   := True;
+      Restrictions (No_Task_Attributes)           := True;
+
+      Restriction_Parameters (Max_Asynchronous_Select_Nesting) :=  Uint_0;
+      Restriction_Parameters (Max_Task_Entries)                :=  Uint_0;
+      Restriction_Parameters (Max_Select_Alternatives)         :=  Uint_0;
+
+      if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
+         Restriction_Parameters (Max_Protected_Entries) := Uint_1;
+      end if;
+   end Set_Restricted_Profile;
+
+   ----------------------------------
+   -- Suppress_Restriction_Message --
+   ----------------------------------
+
+   function Suppress_Restriction_Message (N : Node_Id) return Boolean is
+   begin
+      --  If main unit is library unit, then we will output message
+
+      if In_Extended_Main_Source_Unit (N) then
+         return False;
+
+      --  If loaded by rtsfind, then suppress message
+
+      elsif Sloc (N) <= No_Location then
+         return True;
+
+      --  Otherwise suppress message if internal file
+
+      else
+         return
+           Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
+      end if;
+   end Suppress_Restriction_Message;
+
+   ---------------------
+   -- Tasking_Allowed --
+   ---------------------
+
+   function Tasking_Allowed return Boolean is
+   begin
+      return
+        Restriction_Parameters (Max_Tasks) /= 0;
+   end Tasking_Allowed;
+
+end Restrict;
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
new file mode 100644
index 0000000..426149e
--- /dev/null
+++ b/gcc/ada/restrict.ads
@@ -0,0 +1,253 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             R E S T R I C T                              --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.27 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package deals with the implementation of the Restrictions pragma
+
+with Rident;
+with Types;  use Types;
+with Uintp;  use Uintp;
+
+package Restrict is
+
+   type Restriction_Id is new Rident.Restriction_Id;
+   --  The type Restriction_Id defines the set of restriction identifiers,
+   --  which take no parameter (i.e. they are either present or not present).
+   --  The actual definition is in the separate package Rident, so that it
+   --  can easily be accessed by the binder without dragging in lots of stuff.
+
+   subtype Partition_Restrictions is
+     Restriction_Id range
+       Restriction_Id (Rident.Partition_Restrictions'First) ..
+       Restriction_Id (Rident.Partition_Restrictions'Last);
+   --  Range of restriction identifiers that are checked by the binder
+
+   subtype Compilation_Unit_Restrictions is
+     Restriction_Id range
+       Restriction_Id (Rident.Compilation_Unit_Restrictions'First) ..
+       Restriction_Id (Rident.Compilation_Unit_Restrictions'Last);
+   --  Range of restriction identifiers not checked by binder
+
+   type Restriction_Parameter_Id is new Rident.Restriction_Parameter_Id;
+   --  The type Restriction_Parameter_Id records cases where a parameter is
+   --  present in the corresponding pragma. These cases are not checked for
+   --  consistency by the binder. The actual definition is in the separate
+   --  package Rident for consistency.
+
+   type Restrictions_Flags is array (Restriction_Id) of Boolean;
+   --  Type used for arrays indexed by Restriction_Id.
+
+   Restrictions : Restrictions_Flags := (others => False);
+   --  Corresponding entry is False if restriction is not active, and
+   --  True if the restriction is active, i.e. if a pragma Restrictions
+   --  has been seen anywhere. Note that we are happy to pick up any
+   --  restrictions pragmas in with'ed units, since we are required to
+   --  be consistent at link time, and we might as well find the error
+   --  at compile time. Clients must NOT use this array for checking to
+   --  see if a restriction is violated, instead it is required that the
+   --  Check_Restrictions subprograms be used for this purpose. The only
+   --  legitimate direct use of this array is when the code is modified
+   --  as a result of the restriction in some way.
+
+   Restrictions_Loc : array (Restriction_Id) of Source_Ptr;
+   --  Locations of Restrictions pragmas for error message purposes.
+   --  Valid only if corresponding entry in Restrictions is set.
+
+   Main_Restrictions : Restrictions_Flags := (others => False);
+   --  This variable saves the cumulative restrictions in effect compiling
+   --  any unit that is part of the extended main unit (i.e. the compiled
+   --  unit, its spec if any, and its subunits if any). The reason we keep
+   --  track of this is for the information that goes to the binder about
+   --  restrictions that are set. The binder will identify a unit that has
+   --  a restrictions pragma for error message purposes, and we do not want
+   --  to pick up a restrictions pragma in a with'ed unit for this purpose.
+
+   Violations : Restrictions_Flags := (others => False);
+   --  Corresponding entry is False if the restriction has not been
+   --  violated in the current main unit, and True if it has been violated.
+
+   Restriction_Parameters :
+     array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
+   --  This array indicates the setting of restriction parameter identifier
+   --  values. All values are initially set to No_Uint indicating that the
+   --  parameter is not set, and are set to the appropriate non-negative
+   --  value if a Restrictions pragma specifies the corresponding
+   --  restriction parameter identifier with an appropriate value.
+
+   Restriction_Parameters_Loc :
+     array (Restriction_Parameter_Id) of Source_Ptr;
+   --  Locations of Restrictions pragmas for error message purposes.
+   --  Valid only if corresponding entry in Restriction_Parameters is
+   --  set to a value other than No_Uint.
+
+   type Unit_Entry is record
+      Res_Id : Restriction_Id;
+      Filenm : String (1 .. 8);
+   end record;
+
+   type Unit_Array_Type is array (Positive range <>) of Unit_Entry;
+
+   Unit_Array : constant Unit_Array_Type := (
+     (No_Asynchronous_Control,    "a-astaco"),
+     (No_Calendar,                "a-calend"),
+     (No_Calendar,                "calendar"),
+     (No_Delay,                   "a-calend"),
+     (No_Delay,                   "calendar"),
+     (No_Dynamic_Priorities,      "a-dynpri"),
+     (No_IO,                      "a-direio"),
+     (No_IO,                      "directio"),
+     (No_IO,                      "a-sequio"),
+     (No_IO,                      "sequenio"),
+     (No_IO,                      "a-ststio"),
+     (No_IO,                      "a-textio"),
+     (No_IO,                      "text_io "),
+     (No_IO,                      "a-witeio"),
+     (No_Task_Attributes,         "a-tasatt"),
+     (No_Streams,                 "a-stream"),
+     (No_Unchecked_Conversion,    "a-unccon"),
+     (No_Unchecked_Conversion,    "unchconv"),
+     (No_Unchecked_Deallocation,  "a-uncdea"),
+     (No_Unchecked_Deallocation,  "unchdeal"));
+   --  This array defines the mapping between restriction identifiers and
+   --  predefined language files containing units for which the identifier
+   --  forbids semantic dependence.
+
+   type Save_Compilation_Unit_Restrictions is private;
+   --  Type used for saving and restoring compilation unit restrictions.
+   --  See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id);
+   --  Checks if loading of unit U is prohibited by the setting of some
+   --  restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO).
+   --  If a restriction exists post error message at the given node.
+
+   procedure Check_Restriction (R : Restriction_Id; N : Node_Id);
+   --  Checks that the given restriction is not set, and if it is set, an
+   --  appropriate message is posted on the given node. Also records the
+   --  violation in the violations array. Note that it is mandatory to
+   --  always use this routine to check if a restriction is violated. Such
+   --  checks must never be done directly by the caller, since otherwise
+   --  they are not properly recorded in the violations array.
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      N : Node_Id);
+   --  Checks that the given restriction parameter identifier is not set to
+   --  zero. If it is set to zero, then the node N is replaced by a node
+   --  that raises Storage_Error, and a warning is issued.
+
+   procedure Check_Restriction
+     (R : Restriction_Parameter_Id;
+      V : Uint;
+      N : Node_Id);
+   --  Checks that the count in V does not exceed the maximum value of the
+   --  restriction parameter value corresponding to the given restriction
+   --  parameter identifier (if it has been set). If the count in V exceeds
+   --  the maximum, then post an error message on node N.
+
+   procedure Check_Elaboration_Code_Allowed (N : Node_Id);
+   --  Tests to see if elaboration code is allowed by the current restrictions
+   --  settings. This function is called by Gigi when it needs to define
+   --  an elaboration routine. If elaboration code is not allowed, an error
+   --  message is posted on the node given as argument.
+
+   function No_Exception_Handlers_Set return Boolean;
+   --  Test to see if current restrictions settings specify that no exception
+   --  handlers are present. This function is called by Gigi when it needs to
+   --  expand an AT END clean up identifier with no exception handler.
+
+   function Compilation_Unit_Restrictions_Save
+     return Save_Compilation_Unit_Restrictions;
+   --  This function saves the compilation unit restriction settings, and
+   --  resets them to False. This is used e.g. when compiling a with'ed
+   --  unit to avoid incorrectly propagating restrictions. Note that it
+   --  would not be wrong to also save and reset the partition restrictions,
+   --  since the binder would catch inconsistencies, but actually it is a
+   --  good thing to acquire restrictions from with'ed units if they are
+   --  required to be partition wide, because it allows the restriction
+   --  violation message to be given at compile time instead of link time.
+
+   procedure Compilation_Unit_Restrictions_Restore
+     (R : Save_Compilation_Unit_Restrictions);
+   --  This is the corresponding restore procedure to restore restrictions
+   --  previously saved by Compilation_Unit_Restrictions_Save.
+
+   procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id);
+   --  If in No_Run_Time mode, then the construct represented by Enode is
+   --  not permitted, and will be appropriately flagged.
+
+   procedure Set_No_Run_Time_Mode;
+   --  Set the no run time mode, and associated restriction pragmas.
+
+   function Get_Restriction_Id
+     (N    : Name_Id)
+      return Restriction_Id;
+   --  Given an identifier name, determines if it is a valid restriction
+   --  identifier, and if so returns the corresponding Restriction_Id
+   --  value, otherwise returns Not_A_Restriction_Id.
+
+   function Get_Restriction_Parameter_Id
+     (N    : Name_Id)
+      return Restriction_Parameter_Id;
+   --  Given an identifier name, determines if it is a valid restriction
+   --  parameter identifier, and if so returns the corresponding
+   --  Restriction_Parameter_Id value, otherwise returns
+   --  Not_A_Restriction_Parameter_Id.
+
+   function Abort_Allowed return Boolean;
+   pragma Inline (Abort_Allowed);
+   --  Tests to see if abort is allowed by the current restrictions settings.
+   --  For abort to be allowed, either No_Abort_Statements must be False,
+   --  or Max_Asynchronous_Select_Nesting must be non-zero.
+
+   function Restricted_Profile return Boolean;
+   --  Tests to see if tasking operations follow the GNAT restricted run time
+   --  profile.
+
+   procedure Set_Ravenscar;
+   --  Sets the set of rerstrictions fro Ravenscar
+
+   procedure Set_Restricted_Profile;
+   --  Sets the set of restrictions for pragma Restricted_Run_Time
+
+   function Tasking_Allowed return Boolean;
+   pragma Inline (Tasking_Allowed);
+   --  Tests to see if tasking operations are allowed by the current
+   --  restrictions settings. For tasking to be allowed Max_Tasks must
+   --  be non-zero.
+
+private
+   type Save_Compilation_Unit_Restrictions is
+     array (Compilation_Unit_Restrictions) of Boolean;
+   --  Type used for saving and restoring compilation unit restrictions.
+   --  See Compilation_Unit_Restrictions_[Save|Restore] subprograms.
+
+end Restrict;
diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads
new file mode 100644
index 0000000..3eb6540
--- /dev/null
+++ b/gcc/ada/rident.ads
@@ -0,0 +1,139 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               R I D E N T                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.12 $
+--                                                                          --
+--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This package defines the set of restriction identifiers. It is in a
+--  separate package from Restrict so that it can be easily used by the
+--  binder without dragging in a lot of stuff.
+
+package Rident is
+
+   --  The following enumeration type defines the set of restriction
+   --  identifiers not taking a parameter that are implemented in GNAT.
+   --  To add a new restriction identifier, add an entry with the name
+   --  to be used in the pragma, and add appropriate calls to the
+   --  Check_Restriction routine.
+
+   type Restriction_Id is (
+
+      --  The following cases are checked for consistency in the binder
+
+      Boolean_Entry_Barriers,                  -- GNAT (Ravenscar)
+      No_Abort_Statements,                     -- (RM D.7(5), H.4(3))
+      No_Access_Subprograms,                   -- (RM H.4(17))
+      No_Allocators,                           -- (RM H.4(7))
+      No_Asynchronous_Control,                 -- (RM D.9(10))
+      No_Calendar,                             -- GNAT
+      No_Delay,                                -- (RM H.4(21))
+      No_Dispatch,                             -- (RM H.4(19))
+      No_Dynamic_Interrupts,                   -- GNAT
+      No_Dynamic_Priorities,                   -- (RM D.9(9))
+      No_Enumeration_Maps,                     -- GNAT
+      No_Entry_Calls_In_Elaboration_Code,      -- GNAT
+      No_Entry_Queue,                          -- GNAT
+      No_Exception_Handlers,                   -- GNAT
+      No_Exceptions,                           -- (RM H.4(12))
+      No_Fixed_Point,                          -- (RM H.4(15))
+      No_Floating_Point,                       -- (RM H.4(14))
+      No_IO,                                   -- (RM H.4(20))
+      No_Implicit_Conditionals,                -- GNAT
+      No_Implicit_Dynamic_Code,                -- GNAT
+      No_Implicit_Heap_Allocations,            -- (RM D.8(8), H.4(3))
+      No_Implicit_Loops,                       -- GNAT
+      No_Local_Allocators,                     -- (RM H.4(8))
+      No_Local_Protected_Objects,              -- GNAT
+      No_Nested_Finalization,                  -- (RM D.7(4))
+      No_Protected_Type_Allocators,            -- GNAT
+      No_Protected_Types,                      -- (RM H.4(5))
+      No_Recursion,                            -- (RM H.4(22))
+      No_Reentrancy,                           -- (RM H.4(23))
+      No_Relative_Delay,                       -- GNAT
+      No_Requeue,                              -- GNAT
+      No_Select_Statements,                    -- GNAT (Ravenscar)
+      No_Standard_Storage_Pools,               -- GNAT
+      No_Streams,                              -- GNAT
+      No_Task_Allocators,                      -- (RM D.7(7))
+      No_Task_Attributes,                      -- GNAT
+      No_Task_Hierarchy,                       -- (RM D.7(3), H.4(3))
+      No_Task_Termination,                     -- GNAT
+      No_Terminate_Alternatives,               -- (RM D.7(6))
+      No_Unchecked_Access,                     -- (RM H.4(18))
+      No_Unchecked_Conversion,                 -- (RM H.4(16))
+      No_Unchecked_Deallocation,               -- (RM H.4(9))
+      No_Wide_Characters,                      -- GNAT
+      Static_Priorities,                       -- GNAT
+      Static_Storage_Size,                     -- GNAT
+
+      --  The following cases do not require partition-wide checks
+
+      Immediate_Reclamation,                   -- (RM H.4(10))
+      No_Implementation_Attributes,            -- GNAT
+      No_Implementation_Pragmas,               -- GNAT
+      No_Implementation_Restrictions,          -- GNAT
+      No_Elaboration_Code,                     -- GNAT
+
+      Not_A_Restriction_Id);
+
+   --  The following range of Restriction identifiers is checked for
+   --  consistency across a partition. The generated ali file is marked
+   --  for each entry to show one of three possibilities:
+   --
+   --    Corresponding restriction is set (so unit does not violate it)
+   --    Corresponding restriction is not violated
+   --    Corresponding restriction is violated
+
+   subtype Partition_Restrictions is
+     Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size;
+
+   --  The following set of Restriction identifiers is not checked for
+   --  consistency across a partition, and the generated ali files does
+   --  not carry any indications with respect to such restrictions.
+
+   subtype Compilation_Unit_Restrictions is
+     Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code;
+
+   --  The following enumeration type defines the set of restriction
+   --  parameter identifiers taking a parameter that are implemented in
+   --  GNAT. To add a new restriction parameter identifier, add an entry
+   --  with the name to be used in the pragma, and add appropriate
+   --  calls to Check_Restriction.
+
+   --  Note: the GNAT implementation currently only accomodates restriction
+   --  parameter identifiers whose expression value is a non-negative
+   --  integer. This is true for all language defined parameters.
+
+   type Restriction_Parameter_Id is (
+     Max_Asynchronous_Select_Nesting,         -- (RM D.7(18), H.4(3))
+     Max_Entry_Queue_Depth,                   -- GNAT
+     Max_Protected_Entries,                   -- (RM D.7(14))
+     Max_Select_Alternatives,                 -- (RM D.7(12))
+     Max_Storage_At_Blocking,                 -- (RM D.7(17))
+     Max_Task_Entries,                        -- (RM D.7(13), H.4(3))
+     Max_Tasks,                               -- (RM D.7(19), H.4(3))
+     Not_A_Restriction_Parameter_Id);
+
+end Rident;
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
new file mode 100644
index 0000000..1299e1e
--- /dev/null
+++ b/gcc/ada/rtsfind.adb
@@ -0,0 +1,913 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R T S F I N D                               --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.96 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Casing;   use Casing;
+with Csets;    use Csets;
+with Debug;    use Debug;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Fname;    use Fname;
+with Fname.UF; use Fname.UF;
+with Lib;      use Lib;
+with Lib.Load; use Lib.Load;
+with Namet;    use Namet;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Output;   use Output;
+with Opt;      use Opt;
+with Restrict; use Restrict;
+with Sem;      use Sem;
+with Sem_Ch7;  use Sem_Ch7;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Stand;    use Stand;
+with Snames;   use Snames;
+with Tbuild;   use Tbuild;
+with Uname;    use Uname;
+
+package body Rtsfind is
+
+   ----------------
+   -- Unit table --
+   ----------------
+
+   --  The unit table has one entry for each unit included in the definition
+   --  of the type RTU_Id in the spec. The table entries are initialized in
+   --  Initialize to set the Entity field to Empty, indicating that the
+   --  corresponding unit has not yet been loaded. The fields are set when
+   --  a unit is loaded to contain the defining entity for the unit, the
+   --  unit name, and the unit number.
+
+   type RT_Unit_Table_Record is record
+      Entity : Entity_Id;
+      Uname  : Unit_Name_Type;
+      Unum   : Unit_Number_Type;
+      Withed : Boolean;
+   end record;
+
+   RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
+
+   --------------------------
+   -- Runtime Entity Table --
+   --------------------------
+
+   --  There is one entry in the runtime entity table for each entity that is
+   --  included in the definition of the RE_Id type in the spec. The entries
+   --  are set by Initialize_Rtsfind to contain Empty, indicating that the
+   --  entity has not yet been located. Once the entity is located for the
+   --  first time, its ID is stored in this array, so that subsequent calls
+   --  for the same entity can be satisfied immediately.
+
+   RE_Table : array (RE_Id) of Entity_Id;
+
+   --------------------------
+   -- Generation of WITH's --
+   --------------------------
+
+   --  When a unit is implicitly loaded as a result of a call to RTE, it
+   --  is necessary to create an implicit with to ensure that the object
+   --  is correctly loaded by the binder. Such with statements are only
+   --  required when the request is from the extended main unit (if a
+   --  client needs a with, that will be taken care of when the client
+   --  is compiled.
+
+   --  We always attach the with to the main unit. This is not perfectly
+   --  accurate in terms of elaboration requirements, but it is close
+   --  enough, since the units that are accessed using rtsfind do not
+   --  have delicate elaboration requirements.
+
+   --  The flag Withed in the unit table record is initially set to False.
+   --  It is set True if a with has been generated for the main unit for
+   --  the corresponding unit.
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "");
+   --  Internal procedure called if we can't find the entity or unit.
+   --  The parameter is a detailed error message that is to be given.
+   --  S is a reason for failing to compile the file. U_Id is the unit
+   --  id, and Ent_Name, if non-null, is the associated entity name.
+
+   function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
+   --  Retrieves the Unit Name given a unit id represented by its
+   --  enumaration value in RTU_Id.
+
+   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False);
+   --  Load the unit whose Id is given if not already loaded. The unit is
+   --  loaded, analyzed, and added to the with list, and the entry in
+   --  RT_Unit_Table is updated to reflect the load. The second parameter
+   --  indicates the initial setting for the Is_Potentially_Use_Visible
+   --  flag of the entity for the loaded unit (if it is indeed loaded).
+   --  A value of False means nothing special need be done. A value of
+   --  True indicates that this flag must be set to True. It is needed
+   --  only in the Text_IO_Kludge procedure, which may materialize an
+   --  entity of Text_IO (or Wide_Text_IO) that was previously unknown.
+
+   function RE_Chars (E : RE_Id) return Name_Id;
+   --  Given a RE_Id value returns the Chars of the corresponding entity.
+
+   -------------------
+   -- Get_Unit_Name --
+   -------------------
+
+   function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is
+      Uname_Chars : constant String := RTU_Id'Image (U_Id);
+
+   begin
+      Name_Len := Uname_Chars'Length;
+      Name_Buffer (1 .. Name_Len) := Uname_Chars;
+      Set_Casing (All_Lower_Case);
+
+      if U_Id in Ada_Child then
+         Name_Buffer (4) := '.';
+
+         if U_Id in Ada_Calendar_Child then
+            Name_Buffer (13) := '.';
+
+         elsif U_Id in Ada_Finalization_Child then
+            Name_Buffer (17) := '.';
+
+         elsif U_Id in Ada_Real_Time_Child then
+            Name_Buffer (14) := '.';
+
+         elsif U_Id in Ada_Streams_Child then
+            Name_Buffer (12) := '.';
+
+         elsif U_Id in Ada_Text_IO_Child then
+            Name_Buffer (12) := '.';
+
+         elsif U_Id in Ada_Wide_Text_IO_Child then
+            Name_Buffer (17) := '.';
+         end if;
+
+      elsif U_Id in Interfaces_Child then
+         Name_Buffer (11) := '.';
+
+      elsif U_Id in System_Child then
+         Name_Buffer (7) := '.';
+
+         if U_Id in System_Tasking_Child then
+            Name_Buffer (15) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Restricted_Child then
+            Name_Buffer (26) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Protected_Objects_Child then
+            Name_Buffer (33) := '.';
+         end if;
+
+         if U_Id in System_Tasking_Async_Delays_Child then
+            Name_Buffer (28) := '.';
+         end if;
+      end if;
+
+      --  Add %s at end for spec
+
+      Name_Buffer (Name_Len + 1) := '%';
+      Name_Buffer (Name_Len + 2) := 's';
+      Name_Len := Name_Len + 2;
+
+      return Name_Find;
+   end Get_Unit_Name;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      --  Initialize the unit table
+
+      for J in RTU_Id loop
+         RT_Unit_Table (J).Entity := Empty;
+      end loop;
+
+      for J in RE_Id loop
+         RE_Table (J) := Empty;
+      end loop;
+   end Initialize;
+
+   ------------
+   -- Is_RTE --
+   ------------
+
+   function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is
+      E_Unit_Name   : Unit_Name_Type;
+      Ent_Unit_Name : Unit_Name_Type;
+
+      S  : Entity_Id;
+      E1 : Entity_Id;
+      E2 : Entity_Id;
+
+   begin
+      if No (Ent) then
+         return False;
+
+      --  If E has already a corresponding entity, check it directly,
+      --  going to full views if they exist to deal with the incomplete
+      --  and private type cases properly.
+
+      elsif Present (RE_Table (E)) then
+         E1 := Ent;
+
+         if Is_Type (E1) and then Present (Full_View (E1)) then
+            E1 := Full_View (E1);
+         end if;
+
+         E2 := RE_Table (E);
+
+         if Is_Type (E2) and then Present (Full_View (E2)) then
+            E2 := Full_View (E2);
+         end if;
+
+         return E1 = E2;
+      end if;
+
+      --  If the unit containing E is not loaded, we already know that
+      --  the entity we have cannot have come from this unit.
+
+      E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E));
+
+      if not Is_Loaded (E_Unit_Name) then
+         return False;
+      end if;
+
+      --  Here the unit containing the entity is loaded. We have not made
+      --  an explicit call to RTE to get the entity in question, but we may
+      --  have obtained a reference to it indirectly from some other entity
+      --  in the same unit, or some other unit that references it.
+
+      --  Get the defining unit of the entity
+
+      S := Scope (Ent);
+
+      if Ekind (S) /= E_Package then
+         return False;
+      end if;
+
+      Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S));
+
+      --  If the defining unit of the entity we are testing is not the
+      --  unit containing E, then they cannot possibly match.
+
+      if Ent_Unit_Name /= E_Unit_Name then
+         return False;
+      end if;
+
+      --  If the units match, then compare the names (remember that no
+      --  overloading is permitted in entities fetched using Rtsfind).
+
+      if RE_Chars (E) = Chars (Ent) then
+         RE_Table (E) := Ent;
+
+         --  If front-end inlining is enabled, we may be within a body that
+         --  contains inlined functions, which has not been retrieved through
+         --  rtsfind, and therefore is not yet recorded in the RT_Unit_Table.
+         --  Add the unit information now, it must be fully available.
+
+         declare
+            U : RT_Unit_Table_Record
+                  renames  RT_Unit_Table (RE_Unit_Table (E));
+         begin
+            if No (U.Entity) then
+               U.Entity := S;
+               U.Uname  := E_Unit_Name;
+               U.Unum   := Get_Source_Unit (S);
+            end if;
+         end;
+
+         return True;
+      else
+         return False;
+      end if;
+   end Is_RTE;
+
+   ----------------------------
+   -- Is_Text_IO_Kludge_Unit --
+   ----------------------------
+
+   function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean is
+      Prf : Node_Id;
+      Sel : Node_Id;
+
+   begin
+      if Nkind (Nam) /= N_Expanded_Name then
+         return False;
+      end if;
+
+      Prf := Prefix (Nam);
+      Sel := Selector_Name (Nam);
+
+      if Nkind (Sel) /= N_Expanded_Name
+        or else Nkind (Prf) /= N_Identifier
+        or else Chars (Prf) /= Name_Ada
+      then
+         return False;
+      end if;
+
+      Prf := Prefix (Sel);
+      Sel := Selector_Name (Sel);
+
+      return
+        Nkind (Prf) = N_Identifier
+          and then
+        (Chars (Prf) = Name_Text_IO or else Chars (Prf) = Name_Wide_Text_IO)
+          and then
+        Nkind (Sel) = N_Identifier
+          and then
+        Chars (Sel) in Text_IO_Package_Name;
+
+   end Is_Text_IO_Kludge_Unit;
+
+   ---------------
+   -- Load_Fail --
+   ---------------
+
+   procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is
+   begin
+      Set_Standard_Error;
+
+      Write_Str ("fatal error: run-time library configuration error");
+      Write_Eol;
+
+      if Ent_Name /= "" then
+         Write_Str ("cannot locate """);
+
+         --  Copy name skipping initial RE_ or RO_XX characters
+
+         if Ent_Name (1 .. 2) = "RE" then
+            for J in 4 .. Ent_Name'Length loop
+               Name_Buffer (J - 3) := Ent_Name (J);
+            end loop;
+         else
+            for J in 7 .. Ent_Name'Length loop
+               Name_Buffer (J - 6) := Ent_Name (J);
+            end loop;
+         end if;
+
+         Name_Len := Ent_Name'Length - 3;
+         Set_Casing (Mixed_Case);
+         Write_Str (Name_Buffer (1 .. Name_Len));
+         Write_Str (""" in file """);
+
+      else
+         Write_Str ("cannot load file """);
+      end if;
+
+      Write_Name
+        (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
+      Write_Str (""" (");
+      Write_Str (S);
+      Write_Char (')');
+      Write_Eol;
+      Set_Standard_Output;
+      raise Unrecoverable_Error;
+   end Load_Fail;
+
+   --------------
+   -- Load_RTU --
+   --------------
+
+   procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is
+      Loaded   : Boolean;
+      U        : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+      Priv_Par : Elist_Id := New_Elmt_List;
+      Lib_Unit : Node_Id;
+
+      procedure Save_Private_Visibility;
+      --  If the current unit is the body of child unit or the spec of a
+      --  private child unit, the private declarations of the parent (s)
+      --  are visible. If the unit to be loaded is another public sibling,
+      --  its compilation will affect the visibility of the common ancestors.
+      --  Indicate those that must be restored.
+
+      procedure Restore_Private_Visibility;
+      --  Restore the visibility of ancestors after compiling RTU.
+
+      --------------------------------
+      -- Restore_Private_Visibility --
+      --------------------------------
+
+      procedure Restore_Private_Visibility is
+         E_Par : Elmt_Id;
+
+      begin
+         E_Par := First_Elmt (Priv_Par);
+
+         while Present (E_Par) loop
+            if not In_Private_Part (Node (E_Par)) then
+               Install_Private_Declarations (Node (E_Par));
+            end if;
+
+            Next_Elmt (E_Par);
+         end loop;
+      end Restore_Private_Visibility;
+
+      -----------------------------
+      -- Save_Private_Visibility --
+      -----------------------------
+
+      procedure Save_Private_Visibility is
+         Par : Entity_Id;
+
+      begin
+         Par := Scope (Current_Scope);
+
+         while Present (Par)
+           and then Par /= Standard_Standard
+         loop
+            if Ekind (Par) = E_Package
+              and then Is_Compilation_Unit (Par)
+              and then In_Private_Part (Par)
+            then
+               Append_Elmt (Par, Priv_Par);
+            end if;
+
+            Par := Scope (Par);
+         end loop;
+      end Save_Private_Visibility;
+
+   --  Start of processing for Load_RTU
+
+   begin
+      --  Nothing to do if unit is already loaded
+
+      if Present (U.Entity) then
+         return;
+      end if;
+
+      --  Otherwise we need to load the unit, First build unit name
+      --  from the enumeration literal name in type RTU_Id.
+
+      U.Uname  := Get_Unit_Name (U_Id);
+      U.Withed := False;
+      Loaded   := Is_Loaded (U.Uname);
+
+      --  Now do the load call, note that setting Error_Node to Empty is
+      --  a signal to Load_Unit that we will regard a failure to find the
+      --  file as a fatal error, and that it should not output any kind
+      --  of diagnostics, since we will take care of it here.
+
+      U.Unum :=
+        Load_Unit
+          (Load_Name  => U.Uname,
+           Required   => False,
+           Subunit    => False,
+           Error_Node => Empty);
+
+      if U.Unum = No_Unit then
+         Load_Fail ("unit not found", U_Id);
+
+      elsif Fatal_Error (U.Unum) then
+         Load_Fail ("parser errors", U_Id);
+      end if;
+
+      --  Make sure that the unit is analyzed
+
+      declare
+         Was_Analyzed : Boolean := Analyzed (Cunit (Current_Sem_Unit));
+
+      begin
+         --  Pretend that the current unit is analysed, in case it is
+         --  System or some such. This allows us to put some declarations,
+         --  such as exceptions and packed arrays of Boolean, into System
+         --  even though expanding them requires System...
+
+         --  This is a bit odd but works fine. If the RTS unit does not depend
+         --  in any way on the current unit, then it never gets back into the
+         --  current unit's tree, and the change we make to the current unit
+         --  tree is never noticed by anyone (it is undone in a moment). That
+         --  is the normal situation.
+
+         --  If the RTS Unit *does* depend on the current unit, for instance,
+         --  when you are compiling System, then you had better have finished
+         --  Analyzing the part of System that is depended on before you try
+         --  to load the RTS Unit. This means having the System ordered in an
+         --  appropriate manner.
+
+         Set_Analyzed (Cunit (Current_Sem_Unit), True);
+
+         if not Analyzed (Cunit (U.Unum)) then
+
+            Save_Private_Visibility;
+            Semantics (Cunit (U.Unum));
+            Restore_Private_Visibility;
+
+            if Fatal_Error (U.Unum) then
+               Load_Fail ("semantic errors", U_Id);
+            end if;
+         end if;
+
+         --  Undo the pretence
+
+         Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed);
+      end;
+
+      Lib_Unit := Unit (Cunit (U.Unum));
+      U.Entity := Defining_Entity (Lib_Unit);
+
+      if Use_Setting then
+         Set_Is_Potentially_Use_Visible (U.Entity, True);
+      end if;
+   end Load_RTU;
+
+   --------------
+   -- RE_Chars --
+   --------------
+
+   function RE_Chars (E : RE_Id) return Name_Id is
+      RE_Name_Chars : constant String := RE_Id'Image (E);
+
+   begin
+      --  Copy name skipping initial RE_ or RO_XX characters
+
+      if RE_Name_Chars (1 .. 2) = "RE" then
+         for J in 4 .. RE_Name_Chars'Last loop
+            Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J));
+         end loop;
+
+         Name_Len := RE_Name_Chars'Length - 3;
+
+      else
+         for J in 7 .. RE_Name_Chars'Last loop
+            Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J));
+         end loop;
+
+         Name_Len := RE_Name_Chars'Length - 6;
+      end if;
+
+      return Name_Find;
+   end RE_Chars;
+
+   ---------
+   -- RTE --
+   ---------
+
+   function RTE (E : RE_Id) return Entity_Id is
+      U_Id : constant RTU_Id := RE_Unit_Table (E);
+      U    : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
+
+      Ent      : Entity_Id;
+      Lib_Unit : Node_Id;
+      Pkg_Ent  : Entity_Id;
+      Ename    : Name_Id;
+      Enode    : Node_Id;
+
+      procedure Check_RPC;
+      --  Reject programs that make use of distribution features not supported
+      --  on the current target. On such targets (VMS, Vxworks, others?) we
+      --  only provide a minimal body for System.Rpc that only supplies an
+      --  implementation of partition_id.
+
+      function Find_Local_Entity (E : RE_Id) return Entity_Id;
+      --  This function is used when entity E is in this compilation's main
+      --  unit. It gets the value from the already compiled declaration.
+
+      function Make_Unit_Name (N : Node_Id) return Node_Id;
+      --  If the unit is a child unit, build fully qualified name for use
+      --  in with_clause.
+
+      ---------------
+      -- Check_RPC --
+      ---------------
+
+      procedure Check_RPC is
+         Body_Name    : Unit_Name_Type;
+         Unum         : Unit_Number_Type;
+
+      begin
+         --  Bypass this check if debug flag -gnatdR set
+
+         if Debug_Flag_RR then
+            return;
+         end if;
+
+         --  Otherwise we need the check if we are going after one of
+         --  the critical entities in System.RPC in stubs mode.
+
+         if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
+                      or else
+                        Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+           and then (E = RE_Do_Rpc
+                       or else E = RE_Do_Apc
+                       or else E = RE_Params_Stream_Type
+                       or else E = RE_RPC_Receiver)
+         then
+            --  Load body of System.Rpc, and abort if this is the body that is
+            --  provided by GNAT, for which these features are not supported
+            --  on current target. We identify the gnat body by the presence
+            --  of a local entity called Gnat in the first declaration.
+
+            Lib_Unit := Unit (Cunit (U.Unum));
+            Body_Name := Get_Body_Name (Get_Unit_Name (Lib_Unit));
+            Unum :=
+              Load_Unit
+                (Load_Name  => Body_Name,
+                 Required   => False,
+                 Subunit    => False,
+                 Error_Node => Empty,
+                 Renamings  => True);
+
+            if Unum /= No_Unit then
+               declare
+                  Decls : List_Id := Declarations (Unit (Cunit (Unum)));
+
+               begin
+                  if Present (Decls)
+                    and then Nkind (First (Decls)) = N_Object_Declaration
+                    and then
+                      Chars (Defining_Identifier (First (Decls))) = Name_Gnat
+                  then
+                     Set_Standard_Error;
+                     Write_Str ("distribution feature not supported");
+                     Write_Eol;
+                     raise Unrecoverable_Error;
+                  end if;
+               end;
+            end if;
+         end if;
+      end Check_RPC;
+
+      ------------------------
+      -- Find_System_Entity --
+      ------------------------
+
+      function Find_Local_Entity (E : RE_Id) return Entity_Id is
+         RE_Str : String renames RE_Id'Image (E);
+         Ent    : Entity_Id;
+
+         Save_Nam : constant String := Name_Buffer (1 .. Name_Len);
+         --  Save name buffer and length over call
+
+      begin
+         Name_Len := Natural'Max (0, RE_Str'Length - 3);
+         Name_Buffer (1 .. Name_Len) :=
+           RE_Str (RE_Str'First + 3 .. RE_Str'Last);
+
+         Ent := Entity_Id (Get_Name_Table_Info (Name_Find));
+
+         Name_Len := Save_Nam'Length;
+         Name_Buffer (1 .. Name_Len) := Save_Nam;
+
+         return Ent;
+      end Find_Local_Entity;
+
+      --------------------
+      -- Make_Unit_Name --
+      --------------------
+
+      function Make_Unit_Name (N : Node_Id) return Node_Id is
+         Nam  : Node_Id;
+         Scop : Entity_Id;
+
+      begin
+         Nam  := New_Reference_To (U.Entity, Standard_Location);
+         Scop := Scope (U.Entity);
+
+         if Nkind (N) = N_Defining_Program_Unit_Name then
+            while Scop /= Standard_Standard loop
+               Nam :=
+                 Make_Expanded_Name (Standard_Location,
+                   Chars  => Chars (U.Entity),
+                   Prefix => New_Reference_To (Scop, Standard_Location),
+                   Selector_Name => Nam);
+               Set_Entity (Nam, U.Entity);
+
+               Scop := Scope (Scop);
+            end loop;
+         end if;
+
+         return Nam;
+      end Make_Unit_Name;
+
+   --  Start of processing for RTE
+
+   begin
+      --  Doing a rtsfind in system.ads is special, as we cannot do this
+      --  when compiling System itself. So if we are compiling system then
+      --  we should already have acquired and processed the declaration
+      --  of the entity. The test is to see if this compilation's main unit
+      --  is System. If so, return the value from the already compiled
+      --  declaration and otherwise do a regular find.
+
+      --  Not pleasant, but these kinds of annoying recursion when
+      --  writing an Ada compiler in Ada have to be broken somewhere!
+
+      if Present (Main_Unit_Entity)
+        and then Chars (Main_Unit_Entity) = Name_System
+        and then Analyzed (Main_Unit_Entity)
+        and then not Is_Child_Unit (Main_Unit_Entity)
+      then
+         return Find_Local_Entity (E);
+      end if;
+
+      Enode := Current_Error_Node;
+
+      --  Load unit if unit not previously loaded
+
+      if No (RE_Table (E)) then
+         Load_RTU (U_Id);
+         Lib_Unit := Unit (Cunit (U.Unum));
+
+         --  In the subprogram case, we are all done, the entity we want
+         --  is the entity for the subprogram itself. Note that we do not
+         --  bother to check that it is the entity that was requested.
+         --  the only way that could fail to be the case is if runtime is
+         --  hopelessly misconfigured, and it isn't worth testing for this.
+
+         if Nkind (Lib_Unit) = N_Subprogram_Declaration then
+            RE_Table (E) := U.Entity;
+
+         --  Otherwise we must have the package case, and here we have to
+         --  search the package entity chain for the entity we want. The
+         --  entity we want must be present in this chain, or we have a
+         --  misconfigured runtime.
+
+         else
+            pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
+            Ename := RE_Chars (E);
+
+            Pkg_Ent := First_Entity (U.Entity);
+
+            while Present (Pkg_Ent) loop
+               if Ename = Chars (Pkg_Ent) then
+                  RE_Table (E) := Pkg_Ent;
+                  Check_RPC;
+                  goto Found;
+               end if;
+
+               Next_Entity (Pkg_Ent);
+            end loop;
+
+            --  If we didn't find the unit we want, something is wrong!
+
+            Load_Fail ("entity not in package", U_Id,  RE_Id'Image (E));
+            raise Program_Error;
+         end if;
+      end if;
+
+      --  See if we have to generate a with for this entity. We generate
+      --  a with if the current unit is part of the extended main code
+      --  unit, and if we have not already added the with. The with is
+      --  added to the appropriate unit (the current one).
+
+   <<Found>>
+      if (not U.Withed)
+        and then
+          In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
+      then
+         U.Withed := True;
+
+         declare
+            Withn    : Node_Id;
+            Lib_Unit : Node_Id;
+
+         begin
+            Lib_Unit := Unit (Cunit (U.Unum));
+            Withn :=
+              Make_With_Clause (Standard_Location,
+                Name =>
+                  Make_Unit_Name
+                    (Defining_Unit_Name (Specification (Lib_Unit))));
+            Set_Library_Unit          (Withn, Cunit (U.Unum));
+            Set_Corresponding_Spec    (Withn, U.Entity);
+            Set_First_Name            (Withn, True);
+            Set_Implicit_With         (Withn, True);
+
+            Mark_Rewrite_Insertion (Withn);
+            Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
+         end;
+      end if;
+
+      --  We can now obtain the entity. Check that the No_Run_Time condition
+      --  is not violated. Note that we do not signal the error if we detect
+      --  it in a runtime unit. This can only arise if the user explicitly
+      --  with'ed the runtime unit (or another runtime unit that uses it
+      --  transitively), or if some acceptable (e.g. inlined) entity is
+      --  fetched from a unit, some of whose other routines or entities
+      --  violate the conditions. In the latter case, it does not matter,
+      --  since we won't be using those entities.
+
+      Ent := RE_Table (E);
+
+      if Is_Subprogram (Ent)
+        and then not Is_Inlined (Ent)
+        and then Sloc (Enode) /= Standard_Location
+        and then not
+          Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Enode)))
+      then
+         Disallow_In_No_Run_Time_Mode (Enode);
+      end if;
+
+      return Ent;
+   end RTE;
+
+   --------------------
+   -- Text_IO_Kludge --
+   --------------------
+
+   procedure Text_IO_Kludge (Nam : Node_Id) is
+      Chrs : Name_Id;
+
+      type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id;
+
+      Name_Map : Name_Map_Type := Name_Map_Type'(
+        Name_Decimal_IO     => Ada_Text_IO_Decimal_IO,
+        Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO,
+        Name_Fixed_IO       => Ada_Text_IO_Fixed_IO,
+        Name_Float_IO       => Ada_Text_IO_Float_IO,
+        Name_Integer_IO     => Ada_Text_IO_Integer_IO,
+        Name_Modular_IO     => Ada_Text_IO_Modular_IO);
+
+      Wide_Name_Map : Name_Map_Type := Name_Map_Type'(
+        Name_Decimal_IO     => Ada_Wide_Text_IO_Decimal_IO,
+        Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO,
+        Name_Fixed_IO       => Ada_Wide_Text_IO_Fixed_IO,
+        Name_Float_IO       => Ada_Wide_Text_IO_Float_IO,
+        Name_Integer_IO     => Ada_Wide_Text_IO_Integer_IO,
+        Name_Modular_IO     => Ada_Wide_Text_IO_Modular_IO);
+
+   begin
+      --  Nothing to do if name is not identifier or a selected component
+      --  whose selector_name is not an identifier.
+
+      if Nkind (Nam) = N_Identifier then
+         Chrs := Chars (Nam);
+
+      elsif Nkind (Nam) = N_Selected_Component
+        and then Nkind (Selector_Name (Nam)) = N_Identifier
+      then
+         Chrs := Chars (Selector_Name (Nam));
+
+      else
+         return;
+      end if;
+
+      --  Nothing to do if name is not one of the Text_IO subpackages
+      --  Otherwise look through loaded units, and if we find Text_IO
+      --  or Wide_Text_IO already loaded, then load the proper child.
+
+      if Chrs in Text_IO_Package_Name then
+         for U in Main_Unit .. Last_Unit loop
+            Get_Name_String (Unit_File_Name (U));
+
+            if Name_Len = 12 then
+
+               --  Here is where we do the loads if we find one of the
+               --  units Ada.Text_IO or Ada.Wide_Text_IO. An interesting
+               --  detail is that these units may already be used (i.e.
+               --  their In_Use flags may be set). Normally when the In_Use
+               --  flag is set, the Is_Potentially_Use_Visible flag of all
+               --  entities in the package is set, but the new entity we
+               --  are mysteriously adding was not there to have its flag
+               --  set at the time. So that's why we pass the extra parameter
+               --  to RTU_Find, to make sure the flag does get set now.
+               --  Given that those generic packages are in fact child units,
+               --  we must indicate that they are visible.
+
+               if Name_Buffer (1 .. 12) = "a-textio.ads" then
+                  Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+                  Set_Is_Visible_Child_Unit
+                    (RT_Unit_Table (Name_Map (Chrs)).Entity);
+
+               elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
+                  Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+                  Set_Is_Visible_Child_Unit
+                    (RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
+               end if;
+            end if;
+         end loop;
+      end if;
+   end Text_IO_Kludge;
+
+end Rtsfind;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
new file mode 100644
index 0000000..11304f6
--- /dev/null
+++ b/gcc/ada/rtsfind.ads
@@ -0,0 +1,2324 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                              R T S F I N D                               --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision: 1.216 $
+--                                                                          --
+--          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Types; use Types;
+
+package Rtsfind is
+
+--  This package contains the routine that is used to obtain runtime library
+--  entities, loading in the required runtime library packages on demand. It
+--  is also used for such purposes as finding System.Address when System has
+--  not been explicitly With'ed.
+
+   ------------------------
+   -- Runtime Unit Table --
+   ------------------------
+
+   --  The following type includes an enumeration entry for each runtime
+   --  unit. The enumeration literal represents the fully qualified
+   --  name of the unit, as follows:
+
+   --    Names of the form Ada_xxx are first level children of Ada, whose
+   --    name is Ada.xxx. For example, the name Ada_Tags refers to package
+   --    Ada.Tags.
+
+   --    Names of the form Ada_Calendar_xxx are second level children
+   --    of Ada.Calendar. This is part of a temporary implementation of
+   --    delays; eventually, packages implementing delays will be found
+   --    relative to the package that declares the time type.
+
+   --    Names of the form Interfaces_xxx are first level children of
+   --    Interfaces_CPP refers to package Interfaces.CPP
+
+   --    Names of the form System_xxx are first level children of System, whose
+   --    name is System.xxx. For example, the name System_Str_Concat refers to
+   --    package System.Str_Concat.
+
+   --    Names of the form System_Tasking_xxx are second level children of the
+   --    package System.Tasking. For example, System_Tasking_Stages refers to
+   --    refers to the package System.Tasking.Stages.
+
+   --    Other names stand for themselves (e.g. System for package System)
+
+   --  This list can contain both subprogram and package unit names. For
+   --  packages, the accessible entities in the package are separately
+   --  listed in the package entity table. The units must be either library
+   --  level package declarations, or library level subprogram declarations.
+   --  Generic units, library level instantiations and subprogram bodies
+   --  acting as specs may not be referenced (all these cases could be added
+   --  at the expense of additional complexity in the body of Rtsfind, but
+   --  it doesn't seem worth while, since the implementation controls the
+   --  set of units that are referenced, and this restrictions is easily met.
+
+   --  IMPORTANT NOTE: the specs of packages and procedures with'ed using
+   --  this mechanism may not contain use clauses. This is because these
+   --  subprograms are compiled in the current visibility environment, and
+   --  it would be too much trouble to establish a clean environment for the
+   --  compilation. The presence of extraneous visible stuff has no effect
+   --  on the compilation except in the presence of use clauses (which might
+   --  result in unexpected ambiguities).
+
+   type RTU_Id is (
+      --  Runtime packages, for list of accessible entities in each
+      --  package see declarations in the runtime entity table below.
+
+      RTU_Null,
+      --  Used as a null entry. Will cause an error if referenced.
+
+      --  Children of Ada
+
+      Ada_Calendar,
+      Ada_Exceptions,
+      Ada_Finalization,
+      Ada_Interrupts,
+      Ada_Real_Time,
+      Ada_Streams,
+      Ada_Tags,
+      Ada_Task_Identification,
+
+      --  Children of Ada.Calendar
+
+      Ada_Calendar_Delays,
+
+      --  Children of Ada.Finalization
+
+      Ada_Finalization_List_Controller,
+
+      --  Children of Ada.Real_Time
+
+      Ada_Real_Time_Delays,
+
+      --  Children of Ada.Streams
+
+      Ada_Streams_Stream_IO,
+
+      --  Children of Ada.Text_IO (for Text_IO_Kludge)
+
+      Ada_Text_IO_Decimal_IO,
+      Ada_Text_IO_Enumeration_IO,
+      Ada_Text_IO_Fixed_IO,
+      Ada_Text_IO_Float_IO,
+      Ada_Text_IO_Integer_IO,
+      Ada_Text_IO_Modular_IO,
+
+      --  Children of Ada.Wide_Text_IO (for Text_IO_Kludge)
+
+      Ada_Wide_Text_IO_Decimal_IO,
+      Ada_Wide_Text_IO_Enumeration_IO,
+      Ada_Wide_Text_IO_Fixed_IO,
+      Ada_Wide_Text_IO_Float_IO,
+      Ada_Wide_Text_IO_Integer_IO,
+      Ada_Wide_Text_IO_Modular_IO,
+
+      --  Interfaces
+
+      Interfaces,
+
+      --  Children of Interfaces
+
+      Interfaces_CPP,
+      Interfaces_Packed_Decimal,
+
+      --  Package System
+
+      System,
+
+      --  Children of System
+
+      System_Arith_64,
+      System_AST_Handling,
+      System_Assertions,
+      System_Aux_DEC,
+      System_Bit_Ops,
+      System_Checked_Pools,
+      System_Exception_Table,
+      System_Exceptions,
+      System_Delay_Operations,
+      System_Exn_Flt,
+      System_Exn_Int,
+      System_Exn_LFlt,
+      System_Exn_LInt,
+      System_Exn_LLF,
+      System_Exn_LLI,
+      System_Exn_SFlt,
+      System_Exn_SInt,
+      System_Exn_SSI,
+      System_Exp_Flt,
+      System_Exp_Int,
+      System_Exp_LFlt,
+      System_Exp_LInt,
+      System_Exp_LLF,
+      System_Exp_LLI,
+      System_Exp_LLU,
+      System_Exp_Mod,
+      System_Exp_SFlt,
+      System_Exp_SInt,
+      System_Exp_SSI,
+      System_Exp_Uns,
+      System_Fat_Flt,
+      System_Fat_LFlt,
+      System_Fat_LLF,
+      System_Fat_SFlt,
+      System_Finalization_Implementation,
+      System_Finalization_Root,
+      System_Fore,
+      System_Img_Bool,
+      System_Img_Char,
+      System_Img_Dec,
+      System_Img_Enum,
+      System_Img_Int,
+      System_Img_LLD,
+      System_Img_LLI,
+      System_Img_LLU,
+      System_Img_Name,
+      System_Img_Real,
+      System_Img_Uns,
+      System_Img_WChar,
+      System_Interrupts,
+      System_Machine_Code,
+      System_Mantissa,
+      System_Pack_03,
+      System_Pack_05,
+      System_Pack_06,
+      System_Pack_07,
+      System_Pack_09,
+      System_Pack_10,
+      System_Pack_11,
+      System_Pack_12,
+      System_Pack_13,
+      System_Pack_14,
+      System_Pack_15,
+      System_Pack_17,
+      System_Pack_18,
+      System_Pack_19,
+      System_Pack_20,
+      System_Pack_21,
+      System_Pack_22,
+      System_Pack_23,
+      System_Pack_24,
+      System_Pack_25,
+      System_Pack_26,
+      System_Pack_27,
+      System_Pack_28,
+      System_Pack_29,
+      System_Pack_30,
+      System_Pack_31,
+      System_Pack_33,
+      System_Pack_34,
+      System_Pack_35,
+      System_Pack_36,
+      System_Pack_37,
+      System_Pack_38,
+      System_Pack_39,
+      System_Pack_40,
+      System_Pack_41,
+      System_Pack_42,
+      System_Pack_43,
+      System_Pack_44,
+      System_Pack_45,
+      System_Pack_46,
+      System_Pack_47,
+      System_Pack_48,
+      System_Pack_49,
+      System_Pack_50,
+      System_Pack_51,
+      System_Pack_52,
+      System_Pack_53,
+      System_Pack_54,
+      System_Pack_55,
+      System_Pack_56,
+      System_Pack_57,
+      System_Pack_58,
+      System_Pack_59,
+      System_Pack_60,
+      System_Pack_61,
+      System_Pack_62,
+      System_Pack_63,
+      System_Parameters,
+      System_Partition_Interface,
+      System_Pool_Global,
+      System_Pool_Empty,
+      System_Pool_Local,
+      System_Pool_Size,
+      System_RPC,
+      System_Scalar_Values,
+      System_Secondary_Stack,
+      System_Shared_Storage,
+      System_Soft_Links,
+      System_Standard_Library,
+      System_Storage_Elements,
+      System_Storage_Pools,
+      System_Stream_Attributes,
+      System_String_Ops,
+      System_String_Ops_Concat_3,
+      System_String_Ops_Concat_4,
+      System_String_Ops_Concat_5,
+      System_Task_Info,
+      System_Tasking,
+      System_Unsigned_Types,
+      System_Val_Bool,
+      System_Val_Char,
+      System_Val_Dec,
+      System_Val_Enum,
+      System_Val_Int,
+      System_Val_LLD,
+      System_Val_LLI,
+      System_Val_LLU,
+      System_Val_Name,
+      System_Val_Real,
+      System_Val_Uns,
+      System_Val_WChar,
+      System_Vax_Float_Operations,
+      System_Version_Control,
+      System_VMS_Exception_Table,
+      System_WCh_StW,
+      System_WCh_WtS,
+      System_Wid_Bool,
+      System_Wid_Char,
+      System_Wid_Enum,
+      System_Wid_LLI,
+      System_Wid_LLU,
+      System_Wid_Name,
+      System_Wid_WChar,
+      System_WWd_Char,
+      System_WWd_Enum,
+      System_WWd_Wchar,
+
+      --  Children of System.Tasking
+
+      System_Tasking_Async_Delays,
+      System_Tasking_Async_Delays_Enqueue_Calendar,
+      System_Tasking_Async_Delays_Enqueue_RT,
+      System_Tasking_Protected_Objects,
+      System_Tasking_Protected_Objects_Entries,
+      System_Tasking_Protected_Objects_Operations,
+      System_Tasking_Protected_Objects_Single_Entry,
+      System_Tasking_Restricted_Stages,
+      System_Tasking_Rendezvous,
+      System_Tasking_Stages);
+
+   subtype Ada_Child is RTU_Id
+     range Ada_Calendar .. Ada_Wide_Text_IO_Modular_IO;
+   --  Range of values for children or grand-children of Ada
+
+   subtype Ada_Calendar_Child is Ada_Child
+     range Ada_Calendar_Delays .. Ada_Calendar_Delays;
+   --  Range of values for children of Ada.Calendar
+
+   subtype Ada_Finalization_Child is Ada_Child range
+     Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller;
+   --  Range of values for children of Ada.Finalization
+
+   subtype Ada_Real_Time_Child is Ada_Child
+     range Ada_Real_Time_Delays .. Ada_Real_Time_Delays;
+   --  Range of values for children of Ada.Real_Time
+
+   subtype Ada_Streams_Child is Ada_Child
+     range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
+
+   subtype Ada_Text_IO_Child is Ada_Child
+     range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
+   --  Range of values for children of Ada.Text_IO
+
+   subtype Ada_Wide_Text_IO_Child is Ada_Child
+     range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO;
+   --  Range of values for children of Ada.Text_IO
+
+   subtype Interfaces_Child is RTU_Id
+     range Interfaces_CPP .. Interfaces_Packed_Decimal;
+   --  Range of values for children of Interfaces
+
+   subtype System_Child is RTU_Id
+     range System_Arith_64 .. System_Tasking_Stages;
+   --  Range of values for children or grandchildren of System
+
+   subtype System_Tasking_Child is System_Child
+     range System_Tasking_Async_Delays .. System_Tasking_Stages;
+   --  Range of values for children of System.Tasking
+
+   subtype System_Tasking_Protected_Objects_Child is System_Tasking_Child
+     range System_Tasking_Protected_Objects_Entries ..
+       System_Tasking_Protected_Objects_Single_Entry;
+   --  Range of values for children of System.Tasking.Protected_Objects
+
+   subtype System_Tasking_Restricted_Child is System_Tasking_Child
+     range System_Tasking_Restricted_Stages ..
+       System_Tasking_Restricted_Stages;
+   --  Range of values for children of System.Tasking.Restricted
+
+   subtype System_Tasking_Async_Delays_Child is System_Tasking_Child
+     range System_Tasking_Async_Delays_Enqueue_Calendar ..
+       System_Tasking_Async_Delays_Enqueue_RT;
+   --  Range of values for children of System.Tasking.Async_Delays
+
+   --------------------------
+   -- Runtime Entity Table --
+   --------------------------
+
+   --  This is the enumeration type used to define the argument passed to
+   --  the RTE function. The name must exactly match the name of the entity
+   --  involved, and in the case of a package entity, this name must uniquely
+   --  imply the package containing the entity.
+
+   --  As far as possible, we avoid duplicate names in runtime packages, so
+   --  that the name RE_nnn uniquely identifies the entity nnn. In some cases,
+   --  it is impossible to avoid such duplication because the names come from
+   --  RM defined packages. In such cases, the name is of the form RO_XX_nnn
+   --  where XX is two letters used to differentiate the multiple occurrences
+   --  of the name xx, and nnn is the entity name.
+
+   --  Note that not all entities in the units contained in the run-time unit
+   --  table are included in the following table, only those that actually
+   --  have to be referenced from generated code.
+
+   --  Note on RE_Null. This value is used as a null entry where an RE_Id
+   --  value is required syntactically, but no real entry is required or
+   --  needed. Use of this value will cause a fatal error in an RTE call.
+
+   type RE_Id is (
+
+     RE_Null,
+
+     RE_Code_Loc,                        -- Ada.Exceptions
+     RE_Current_Target_Exception,        -- Ada.Exceptions (JGNAT use only)
+     RE_Exception_Id,                    -- Ada.Exceptions
+     RE_Exception_Information,           -- Ada.Exceptions
+     RE_Exception_Message,               -- Ada.Exceptions
+     RE_Exception_Name_Simple,           -- Ada.Exceptions
+     RE_Exception_Occurrence,            -- Ada.Exceptions
+     RE_Null_Id,                         -- Ada.Exceptions
+     RE_Null_Occurrence,                 -- Ada.Exceptions
+     RE_Poll,                            -- Ada.Exceptions
+     RE_Raise_Exception,                 -- Ada.Exceptions
+     RE_Raise_Exception_Always,          -- Ada.Exceptions
+     RE_Reraise_Occurrence,              -- Ada.Exceptions
+     RE_Reraise_Occurrence_Always,       -- Ada.Exceptions
+     RE_Reraise_Occurrence_No_Defer,     -- Ada.Exceptions
+     RE_Save_Occurrence,                 -- Ada.Exceptions
+
+     RE_Simple_List_Controller,          -- Ada.Finalization.List_Controller
+     RE_List_Controller,                 -- Ada.Finalization.List_Controller
+
+     RE_Interrupt_Id,                    -- Ada.Interrupts
+
+     RE_Root_Stream_Type,                -- Ada.Streams
+     RE_Stream_Element,                  -- Ada.Streams
+     RE_Stream_Element_Offset,           -- Ada.Streams
+     RE_Stream_Element_Array,            -- Ada.Streams
+
+     RE_Stream_Access,                   -- Ada.Streams.Stream_IO
+
+     RE_CW_Membership,                   -- Ada.Tags
+     RE_DT_Entry_Size,                   -- Ada.Tags
+     RE_DT_Prologue_Size,                -- Ada.Tags
+     RE_External_Tag,                    -- Ada.Tags
+     RE_Get_Expanded_Name,               -- Ada.Tags
+     RE_Get_External_Tag,                -- Ada.Tags
+     RE_Get_Prim_Op_Address,             -- Ada.Tags
+     RE_Get_RC_Offset,                   -- Ada.Tags
+     RE_Get_Remotely_Callable,           -- Ada.Tags
+     RE_Get_TSD,                         -- Ada.Tags
+     RE_Inherit_DT,                      -- Ada.Tags
+     RE_Inherit_TSD,                     -- Ada.Tags
+     RE_Internal_Tag,                    -- Ada.Tags
+     RE_Register_Tag,                    -- Ada.Tags
+     RE_Set_Expanded_Name,               -- Ada.Tags
+     RE_Set_External_Tag,                -- Ada.Tags
+     RE_Set_Prim_Op_Address,             -- Ada.Tags
+     RE_Set_RC_Offset,                   -- Ada.Tags
+     RE_Set_Remotely_Callable,           -- Ada.Tags
+     RE_Set_TSD,                         -- Ada.Tags
+     RE_Tag_Error,                       -- Ada.Tags
+     RE_TSD_Entry_Size,                  -- Ada.Tags
+     RE_TSD_Prologue_Size,               -- Ada.Tags
+     RE_Tag,                             -- Ada.Tags
+     RE_Address_Array,                   -- Ada.Tags
+
+     RE_Current_Task,                    -- Ada.Task_Identification
+     RO_AT_Task_ID,                      -- Ada.Task_Identification
+
+     RO_CA_Time,                         -- Ada.Calendar
+
+     RO_CA_Delay_For,                    -- Ada.Calendar.Delays
+     RO_CA_Delay_Until,                  -- Ada.Calendar.Delays
+     RO_CA_To_Duration,                  -- Ada.Calendar.Delays
+
+     RO_RT_Time,                         -- Ada.Real_Time
+
+     RO_RT_Delay_Until,                  -- Ada.Real_Time.Delays
+     RO_RT_To_Duration,                  -- Ada.Real_Time.Delays
+
+     RE_Integer_64,                      -- Interfaces
+     RE_Unsigned_8,                      -- Interfaces
+     RE_Unsigned_16,                     -- Interfaces
+     RE_Unsigned_32,                     -- Interfaces
+     RE_Unsigned_64,                     -- Interfaces
+
+     RE_Vtable_Ptr,                      -- Interfaces.CPP
+     RE_Displaced_This,                  -- Interfaces.CPP
+     RE_CPP_CW_Membership,               -- Interfaces.CPP
+     RE_CPP_DT_Entry_Size,               -- Interfaces.CPP
+     RE_CPP_DT_Prologue_Size,            -- Interfaces.CPP
+     RE_CPP_Get_Expanded_Name,           -- Interfaces.CPP
+     RE_CPP_Get_External_Tag,            -- Interfaces.CPP
+     RE_CPP_Get_Prim_Op_Address,         -- Interfaces.CPP
+     RE_CPP_Get_RC_Offset,               -- Interfaces.CPP
+     RE_CPP_Get_Remotely_Callable,       -- Interfaces.CPP
+     RE_CPP_Get_TSD,                     -- Interfaces.CPP
+     RE_CPP_Inherit_DT,                  -- Interfaces.CPP
+     RE_CPP_Inherit_TSD,                 -- Interfaces.CPP
+     RE_CPP_Register_Tag,                -- Interfaces.CPP
+     RE_CPP_Set_Expanded_Name,           -- Interfaces.CPP
+     RE_CPP_Set_External_Tag,            -- Interfaces.CPP
+     RE_CPP_Set_Prim_Op_Address,         -- Interfaces.CPP
+     RE_CPP_Set_RC_Offset,               -- Interfaces.CPP
+     RE_CPP_Set_Remotely_Callable,       -- Interfaces.CPP
+     RE_CPP_Set_TSD,                     -- Interfaces.CPP
+     RE_CPP_TSD_Entry_Size,              -- Interfaces.CPP
+     RE_CPP_TSD_Prologue_Size,           -- Interfaces.CPP
+
+     RE_Packed_Size,                     -- Interfaces.Packed_Decimal
+     RE_Packed_To_Int32,                 -- Interfaces.Packed_Decimal
+     RE_Packed_To_Int64,                 -- Interfaces.Packed_Decimal
+     RE_Int32_To_Packed,                 -- Interfaces.Packed_Decimal
+     RE_Int64_To_Packed,                 -- Interfaces.Packed_Decimal
+
+     RE_Address,                         -- System
+     RE_Any_Priority,                    -- System
+     RE_Bit_Order,                       -- System
+     RE_Default_Priority,                -- System
+     RE_High_Order_First,                -- System
+     RE_Interrupt_Priority,              -- System
+     RE_Lib_Stop,                        -- System
+     RE_Low_Order_First,                 -- System
+     RE_Max_Interrupt_Priority,          -- System
+     RE_Max_Priority,                    -- System
+     RE_Null_Address,                    -- System
+     RE_Priority,                        -- System
+
+     RE_Add_With_Ovflo_Check,            -- System.Arith_64
+     RE_Double_Divide,                   -- System.Arith_64
+     RE_Multiply_With_Ovflo_Check,       -- System.Arith_64
+     RE_Scaled_Divide,                   -- System.Arith_64
+     RE_Subtract_With_Ovflo_Check,       -- System.Arith_64
+
+     RE_Create_AST_Handler,              -- System.AST_Handling
+
+     RE_Raise_Assert_Failure,            -- System.Assertions
+
+     RE_AST_Handler,                     -- System.Aux_DEC
+     RE_Import_Value,                    -- System.Aux_DEC
+     RE_No_AST_Handler,                  -- System.Aux_DEC
+     RE_Type_Class,                      -- System.Aux_DEC
+     RE_Type_Class_Enumeration,          -- System.Aux_DEC
+     RE_Type_Class_Integer,              -- System.Aux_DEC
+     RE_Type_Class_Fixed_Point,          -- System.Aux_DEC
+     RE_Type_Class_Floating_Point,       -- System.Aux_DEC
+     RE_Type_Class_Array,                -- System.Aux_DEC
+     RE_Type_Class_Record,               -- System.Aux_DEC
+     RE_Type_Class_Access,               -- System.Aux_DEC
+     RE_Type_Class_Task,                 -- System.Aux_DEC
+     RE_Type_Class_Address,              -- System.Aux_DEC
+
+     RE_Bit_And,                         -- System.Bit_Ops
+     RE_Bit_Eq,                          -- System.Bit_Ops
+     RE_Bit_Not,                         -- System.Bit_Ops
+     RE_Bit_Or,                          -- System.Bit_Ops
+     RE_Bit_Xor,                         -- System.Bit_Ops
+
+     RE_Checked_Pool,                    -- System.Checked_Pools
+
+     RE_Register_Exception,              -- System.Exception_Table
+
+     RE_All_Others_Id,                   -- System.Exceptions
+     RE_Handler_Record,                  -- System.Exceptions
+     RE_Handler_Record_Ptr,              -- System.Exceptions
+     RE_Others_Id,                       -- System.Exceptions
+     RE_Subprogram_Descriptor,           -- System.Exceptions
+     RE_Subprogram_Descriptor_0,         -- System.Exceptions
+     RE_Subprogram_Descriptor_1,         -- System.Exceptions
+     RE_Subprogram_Descriptor_2,         -- System.Exceptions
+     RE_Subprogram_Descriptor_3,         -- System.Exceptions
+     RE_Subprogram_Descriptor_List,      -- System.Exceptions
+     RE_Subprogram_Descriptor_Ptr,       -- System.Exceptions
+     RE_Subprogram_Descriptors_Record,   -- System.Exceptions
+     RE_Subprogram_Descriptors_Ptr,      -- System.Exceptions
+
+     RE_Exn_Float,                       -- System.Exn_Flt
+
+     RE_Exn_Integer,                     -- System.Exn_Int
+
+     RE_Exn_Long_Float,                  -- System.Exn_LFlt
+
+     RE_Exn_Long_Integer,                -- System.Exn_LInt
+
+     RE_Exn_Long_Long_Float,             -- System.Exn_LLF
+
+     RE_Exn_Long_Long_Integer,           -- System.Exn_LLI
+
+     RE_Exn_Short_Float,                 -- System.Exn_SFlt
+
+     RE_Exn_Short_Integer,               -- System.Exn_SInt
+
+     RE_Exn_Short_Short_Integer,         -- System.Exn_SSI
+
+     RE_Exp_Float,                       -- System.Exp_Flt
+
+     RE_Exp_Integer,                     -- System.Exp_Int
+
+     RE_Exp_Long_Float,                  -- System.Exp_LFlt
+
+     RE_Exp_Long_Integer,                -- System.Exp_LInt
+
+     RE_Exp_Long_Long_Float,             -- System.Exp_LLF
+
+     RE_Exp_Long_Long_Integer,           -- System.Exp_LLI
+
+     RE_Exp_Long_Long_Unsigned,          -- System.Exp_LLU
+
+     RE_Exp_Modular,                     -- System.Exp_Mod
+
+     RE_Exp_Short_Float,                 -- System.Exp_SFlt
+
+     RE_Exp_Short_Integer,               -- System.Exp_SInt
+
+     RE_Exp_Short_Short_Integer,         -- System.Exp_SSI
+
+     RE_Exp_Unsigned,                    -- System.Exp_Uns
+
+     RE_Fat_Float,                       -- System.Fat_Flt
+
+     RE_Fat_Long_Float,                  -- System.Fat_LFlt
+
+     RE_Fat_Long_Long_Float,             -- System.Fat_LLF
+
+     RE_Fat_Short_Float,                 -- System.Fat_SFlt
+
+     RE_Attach_To_Final_List,            -- System.Finalization_Implementation
+     RE_Finalize_List,                   -- System.Finalization_Implementation
+     RE_Finalize_One,                    -- System.Finalization_Implementation
+     RE_Global_Final_List,               -- System.Finalization_Implementation
+     RE_Record_Controller,               -- System.Finalization_Implementation
+     RE_Limited_Record_Controller,       -- System.Finalization_Implementation
+     RE_Deep_Tag_Initialize,             -- System.Finalization_Implementation
+     RE_Deep_Tag_Adjust,                 -- System.Finalization_Implementation
+     RE_Deep_Tag_Finalize,               -- System.Finalization_Implementation
+     RE_Deep_Tag_Attach,                 -- System.Finalization_Implementation
+     RE_Deep_Rec_Initialize,             -- System.Finalization_Implementation
+     RE_Deep_Rec_Adjust,                 -- System.Finalization_Implementation
+     RE_Deep_Rec_Finalize,               -- System.Finalization_Implementation
+
+     RE_Root_Controlled,                 -- System.Finalization_Root
+     RE_Finalizable,                     -- System.Finalization_Root
+     RE_Finalizable_Ptr,                 -- System.Finalization_Root
+
+     RE_Fore,                            -- System.Fore
+
+     RE_Image_Boolean,                   -- System.Img_Bool
+
+     RE_Image_Character,                 -- System.Img_Char
+
+     RE_Image_Decimal,                   -- System.Img_Dec
+
+     RE_Image_Enumeration_8,             -- System.Img_Enum
+     RE_Image_Enumeration_16,            -- System.Img_Enum
+     RE_Image_Enumeration_32,            -- System.Img_Enum
+
+     RE_Image_Integer,                   -- System.Img_Int
+
+     RE_Image_Long_Long_Decimal,         -- System.Img_LLD
+
+     RE_Image_Long_Long_Integer,         -- System.Img_LLI
+
+     RE_Image_Long_Long_Unsigned,        -- System.Img_LLU
+
+     RE_Image_Ordinary_Fixed_Point,      -- System.Img_Real
+     RE_Image_Floating_Point,            -- System.Img_Real
+
+     RE_Image_Unsigned,                  -- System.Img_Uns
+
+     RE_Image_Wide_Character,            -- System.Img_WChar
+
+     RE_Bind_Interrupt_To_Entry,         -- System.Interrupts
+     RE_Default_Interrupt_Priority,      -- System.Interrupts
+     RE_Dynamic_Interrupt_Protection,    -- System.Interrupts
+     RE_Install_Handlers,                -- System.Interrupts
+     RE_Register_Interrupt_Handler,      -- System.Interrupts
+     RE_Static_Interrupt_Protection,     -- System.Interrupts
+
+     RE_Asm_Insn,                        -- System.Machine_Code
+     RE_Asm_Input_Operand,               -- System.Machine_Code
+     RE_Asm_Output_Operand,              -- System.Machine_Code
+
+     RE_Mantissa_Value,                  -- System_Mantissa
+
+     RE_Bits_03,                         -- System.Pack_03
+     RE_Get_03,                          -- System.Pack_03
+     RE_Set_03,                          -- System.Pack_03
+
+     RE_Bits_05,                         -- System.Pack_05
+     RE_Get_05,                          -- System.Pack_05
+     RE_Set_05,                          -- System.Pack_05
+
+     RE_Bits_06,                         -- System.Pack_06
+     RE_Get_06,                          -- System.Pack_06
+     RE_GetU_06,                         -- System.Pack_06
+     RE_Set_06,                          -- System.Pack_06
+     RE_SetU_06,                         -- System.Pack_06
+
+     RE_Bits_07,                         -- System.Pack_07
+     RE_Get_07,                          -- System.Pack_07
+     RE_Set_07,                          -- System.Pack_07
+
+     RE_Bits_09,                         -- System.Pack_09
+     RE_Get_09,                          -- System.Pack_09
+     RE_Set_09,                          -- System.Pack_09
+
+     RE_Bits_10,                         -- System.Pack_10
+     RE_Get_10,                          -- System.Pack_10
+     RE_GetU_10,                         -- System.Pack_10
+     RE_Set_10,                          -- System.Pack_10
+     RE_SetU_10,                         -- System.Pack_10
+
+     RE_Bits_11,                         -- System.Pack_11
+     RE_Get_11,                          -- System.Pack_11
+     RE_Set_11,                          -- System.Pack_11
+
+     RE_Bits_12,                         -- System.Pack_12
+     RE_Get_12,                          -- System.Pack_12
+     RE_GetU_12,                         -- System.Pack_12
+     RE_Set_12,                          -- System.Pack_12
+     RE_SetU_12,                         -- System.Pack_12
+
+     RE_Bits_13,                         -- System.Pack_13
+     RE_Get_13,                          -- System.Pack_13
+     RE_Set_13,                          -- System.Pack_13
+
+     RE_Bits_14,                         -- System.Pack_14
+     RE_Get_14,                          -- System.Pack_14
+     RE_GetU_14,                         -- System.Pack_14
+     RE_Set_14,                          -- System.Pack_14
+     RE_SetU_14,                         -- System.Pack_14
+
+     RE_Bits_15,                         -- System.Pack_15
+     RE_Get_15,                          -- System.Pack_15
+     RE_Set_15,                          -- System.Pack_15
+
+     RE_Bits_17,                         -- System.Pack_17
+     RE_Get_17,                          -- System.Pack_17
+     RE_Set_17,                          -- System.Pack_17
+
+     RE_Bits_18,                         -- System.Pack_18
+     RE_Get_18,                          -- System.Pack_18
+     RE_GetU_18,                         -- System.Pack_18
+     RE_Set_18,                          -- System.Pack_18
+     RE_SetU_18,                         -- System.Pack_18
+
+     RE_Bits_19,                         -- System.Pack_19
+     RE_Get_19,                          -- System.Pack_19
+     RE_Set_19,                          -- System.Pack_19
+
+     RE_Bits_20,                         -- System.Pack_20
+     RE_Get_20,                          -- System.Pack_20
+     RE_GetU_20,                         -- System.Pack_20
+     RE_Set_20,                          -- System.Pack_20
+     RE_SetU_20,                         -- System.Pack_20
+
+     RE_Bits_21,                         -- System.Pack_21
+     RE_Get_21,                          -- System.Pack_21
+     RE_Set_21,                          -- System.Pack_21
+
+     RE_Bits_22,                         -- System.Pack_22
+     RE_Get_22,                          -- System.Pack_22
+     RE_GetU_22,                         -- System.Pack_22
+     RE_Set_22,                          -- System.Pack_22
+     RE_SetU_22,                         -- System.Pack_22
+
+     RE_Bits_23,                         -- System.Pack_23
+     RE_Get_23,                          -- System.Pack_23
+     RE_Set_23,                          -- System.Pack_23
+
+     RE_Bits_24,                         -- System.Pack_24
+     RE_Get_24,                          -- System.Pack_24
+     RE_GetU_24,                         -- System.Pack_24
+     RE_Set_24,                          -- System.Pack_24
+     RE_SetU_24,                         -- System.Pack_24
+
+     RE_Bits_25,                         -- System.Pack_25
+     RE_Get_25,                          -- System.Pack_25
+     RE_Set_25,                          -- System.Pack_25
+
+     RE_Bits_26,                         -- System.Pack_26
+     RE_Get_26,                          -- System.Pack_26
+     RE_GetU_26,                         -- System.Pack_26
+     RE_Set_26,                          -- System.Pack_26
+     RE_SetU_26,                         -- System.Pack_26
+
+     RE_Bits_27,                         -- System.Pack_27
+     RE_Get_27,                          -- System.Pack_27
+     RE_Set_27,                          -- System.Pack_27
+
+     RE_Bits_28,                         -- System.Pack_28
+     RE_Get_28,                          -- System.Pack_28
+     RE_GetU_28,                         -- System.Pack_28
+     RE_Set_28,                          -- System.Pack_28
+     RE_SetU_28,                         -- System.Pack_28
+
+     RE_Bits_29,                         -- System.Pack_29
+     RE_Get_29,                          -- System.Pack_29
+     RE_Set_29,                          -- System.Pack_29
+
+     RE_Bits_30,                         -- System.Pack_30
+     RE_Get_30,                          -- System.Pack_30
+     RE_GetU_30,                         -- System.Pack_30
+     RE_Set_30,                          -- System.Pack_30
+     RE_SetU_30,                         -- System.Pack_30
+
+     RE_Bits_31,                         -- System.Pack_31
+     RE_Get_31,                          -- System.Pack_31
+     RE_Set_31,                          -- System.Pack_31
+
+     RE_Bits_33,                         -- System.Pack_33
+     RE_Get_33,                          -- System.Pack_33
+     RE_Set_33,                          -- System.Pack_33
+
+     RE_Bits_34,                         -- System.Pack_34
+     RE_Get_34,                          -- System.Pack_34
+     RE_GetU_34,                         -- System.Pack_34
+     RE_Set_34,                          -- System.Pack_34
+     RE_SetU_34,                         -- System.Pack_34
+
+     RE_Bits_35,                         -- System.Pack_35
+     RE_Get_35,                          -- System.Pack_35
+     RE_Set_35,                          -- System.Pack_35
+
+     RE_Bits_36,                         -- System.Pack_36
+     RE_Get_36,                          -- System.Pack_36
+     RE_GetU_36,                         -- System.Pack_36
+     RE_Set_36,                          -- System.Pack_36
+     RE_SetU_36,                         -- System.Pack_36
+
+     RE_Bits_37,                         -- System.Pack_37
+     RE_Get_37,                          -- System.Pack_37
+     RE_Set_37,                          -- System.Pack_37
+
+     RE_Bits_38,                         -- System.Pack_38
+     RE_Get_38,                          -- System.Pack_38
+     RE_GetU_38,                         -- System.Pack_38
+     RE_Set_38,                          -- System.Pack_38
+     RE_SetU_38,                         -- System.Pack_38
+
+     RE_Bits_39,                         -- System.Pack_39
+     RE_Get_39,                          -- System.Pack_39
+     RE_Set_39,                          -- System.Pack_39
+
+     RE_Bits_40,                         -- System.Pack_40
+     RE_Get_40,                          -- System.Pack_40
+     RE_GetU_40,                         -- System.Pack_40
+     RE_Set_40,                          -- System.Pack_40
+     RE_SetU_40,                         -- System.Pack_40
+
+     RE_Bits_41,                         -- System.Pack_41
+     RE_Get_41,                          -- System.Pack_41
+     RE_Set_41,                          -- System.Pack_41
+
+     RE_Bits_42,                         -- System.Pack_42
+     RE_Get_42,                          -- System.Pack_42
+     RE_GetU_42,                         -- System.Pack_42
+     RE_Set_42,                          -- System.Pack_42
+     RE_SetU_42,                         -- System.Pack_42
+
+     RE_Bits_43,                         -- System.Pack_43
+     RE_Get_43,                          -- System.Pack_43
+     RE_Set_43,                          -- System.Pack_43
+
+     RE_Bits_44,                         -- System.Pack_44
+     RE_Get_44,                          -- System.Pack_44
+     RE_GetU_44,                         -- System.Pack_44
+     RE_Set_44,                          -- System.Pack_44
+     RE_SetU_44,                         -- System.Pack_44
+
+     RE_Bits_45,                         -- System.Pack_45
+     RE_Get_45,                          -- System.Pack_45
+     RE_Set_45,                          -- System.Pack_45
+
+     RE_Bits_46,                         -- System.Pack_46
+     RE_Get_46,                          -- System.Pack_46
+     RE_GetU_46,                         -- System.Pack_46
+     RE_Set_46,                          -- System.Pack_46
+     RE_SetU_46,                         -- System.Pack_46
+
+     RE_Bits_47,                         -- System.Pack_47
+     RE_Get_47,                          -- System.Pack_47
+     RE_Set_47,                          -- System.Pack_47
+
+     RE_Bits_48,                         -- System.Pack_48
+     RE_Get_48,                          -- System.Pack_48
+     RE_GetU_48,                         -- System.Pack_48
+     RE_Set_48,                          -- System.Pack_48
+     RE_SetU_48,                         -- System.Pack_48
+
+     RE_Bits_49,                         -- System.Pack_49
+     RE_Get_49,                          -- System.Pack_49
+     RE_Set_49,                          -- System.Pack_49
+
+     RE_Bits_50,                         -- System.Pack_50
+     RE_Get_50,                          -- System.Pack_50
+     RE_GetU_50,                         -- System.Pack_50
+     RE_Set_50,                          -- System.Pack_50
+     RE_SetU_50,                         -- System.Pack_50
+
+     RE_Bits_51,                         -- System.Pack_51
+     RE_Get_51,                          -- System.Pack_51
+     RE_Set_51,                          -- System.Pack_51
+
+     RE_Bits_52,                         -- System.Pack_52
+     RE_Get_52,                          -- System.Pack_52
+     RE_GetU_52,                         -- System.Pack_52
+     RE_Set_52,                          -- System.Pack_52
+     RE_SetU_52,                         -- System.Pack_52
+
+     RE_Bits_53,                         -- System.Pack_53
+     RE_Get_53,                          -- System.Pack_53
+     RE_Set_53,                          -- System.Pack_53
+
+     RE_Bits_54,                         -- System.Pack_54
+     RE_Get_54,                          -- System.Pack_54
+     RE_GetU_54,                         -- System.Pack_54
+     RE_Set_54,                          -- System.Pack_54
+     RE_SetU_54,                         -- System.Pack_54
+
+     RE_Bits_55,                         -- System.Pack_55
+     RE_Get_55,                          -- System.Pack_55
+     RE_Set_55,                          -- System.Pack_55
+
+     RE_Bits_56,                         -- System.Pack_56
+     RE_Get_56,                          -- System.Pack_56
+     RE_GetU_56,                         -- System.Pack_56
+     RE_Set_56,                          -- System.Pack_56
+     RE_SetU_56,                         -- System.Pack_56
+
+     RE_Bits_57,                         -- System.Pack_57
+     RE_Get_57,                          -- System.Pack_57
+     RE_Set_57,                          -- System.Pack_57
+
+     RE_Bits_58,                         -- System.Pack_58
+     RE_Get_58,                          -- System.Pack_58
+     RE_GetU_58,                         -- System.Pack_58
+     RE_Set_58,                          -- System.Pack_58
+     RE_SetU_58,                         -- System.Pack_58
+
+     RE_Bits_59,                         -- System.Pack_59
+     RE_Get_59,                          -- System.Pack_59
+     RE_Set_59,                          -- System.Pack_59
+
+     RE_Bits_60,                         -- System.Pack_60
+     RE_Get_60,                          -- System.Pack_60
+     RE_GetU_60,                         -- System.Pack_60
+     RE_Set_60,                          -- System.Pack_60
+     RE_SetU_60,                         -- System.Pack_60
+
+     RE_Bits_61,                         -- System.Pack_61
+     RE_Get_61,                          -- System.Pack_61
+     RE_Set_61,                          -- System.Pack_61
+
+     RE_Bits_62,                         -- System.Pack_62
+     RE_Get_62,                          -- System.Pack_62
+     RE_GetU_62,                         -- System.Pack_62
+     RE_Set_62,                          -- System.Pack_62
+     RE_SetU_62,                         -- System.Pack_62
+
+     RE_Bits_63,                         -- System.Pack_63
+     RE_Get_63,                          -- System.Pack_63
+     RE_Set_63,                          -- System.Pack_63
+
+     RE_Adjust_Storage_Size,             -- System_Parameters
+     RE_Default_Stack_Size,              -- System.Parameters
+     RE_Garbage_Collected,               -- System.Parameters
+     RE_Size_Type,                       -- System.Parameters
+     RE_Unspecified_Size,                -- System.Parameters
+
+     RE_Get_Active_Partition_Id,         -- System.Partition_Interface
+     RE_Get_Passive_Partition_Id,        -- System.Partition_Interface
+     RE_Get_Local_Partition_Id,          -- System.Partition_Interface
+     RE_Get_RCI_Package_Receiver,        -- System.Partition_Interface
+     RE_Get_Unique_Remote_Pointer,       -- System.Partition_Interface
+     RE_RACW_Stub_Type,                  -- System.Partition_Interface
+     RE_RACW_Stub_Type_Access,           -- System.Partition_Interface
+     RE_Raise_Program_Error_For_E_4_18,  -- System.Partition_Interface
+     RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface
+     RE_Register_Passive_Package,        -- System.Partition_Interface
+     RE_Register_Receiving_Stub,         -- System.Partition_Interface
+     RE_RCI_Info,                        -- System.Partition_Interface
+     RE_Subprogram_Id,                   -- System.Partition_Interface
+
+     RE_Global_Pool_Object,              -- System.Pool_Global
+
+     RE_Unbounded_Reclaim_Pool,          -- System.Pool_Local
+
+     RE_Stack_Bounded_Pool,              -- System.Pool_Size
+
+     RE_Do_Apc,                          -- System.RPC
+     RE_Do_Rpc,                          -- System.RPC
+     RE_Params_Stream_Type,              -- System.RPC
+     RE_Partition_ID,                    -- System.RPC
+     RE_RPC_Receiver,                    -- System.RPC
+
+     RE_IS_Is1,                          -- System.Scalar_Values
+     RE_IS_Is2,                          -- System.Scalar_Values
+     RE_IS_Is4,                          -- System.Scalar_Values
+     RE_IS_Is8,                          -- System.Scalar_Values
+     RE_IS_Iu1,                          -- System.Scalar_Values
+     RE_IS_Iu2,                          -- System.Scalar_Values
+     RE_IS_Iu4,                          -- System.Scalar_Values
+     RE_IS_Iu8,                          -- System.Scalar_Values
+     RE_IS_Isf,                          -- System.Scalar_Values
+     RE_IS_Ifl,                          -- System.Scalar_Values
+     RE_IS_Ilf,                          -- System.Scalar_Values
+     RE_IS_Ill,                          -- System.Scalar_Values
+
+     RE_Mark_Id,                         -- System.Secondary_Stack
+     RE_SS_Allocate,                     -- System.Secondary_Stack
+     RE_SS_Pool,                         -- System.Secondary_Stack
+     RE_SS_Mark,                         -- System.Secondary_Stack
+     RE_SS_Release,                      -- System.Secondary_Stack
+
+     RE_Shared_Var_Close,                -- System.Shared_Storage
+     RE_Shared_Var_Lock,                 -- System.Shared_Storage
+     RE_Shared_Var_ROpen,                -- System.Shared_Storage
+     RE_Shared_Var_Unlock,               -- System.Shared_Storage
+     RE_Shared_Var_WOpen,                -- System.Shared_Storage
+
+     RE_Abort_Undefer_Direct,            -- System.Standard_Library
+     RE_Exception_Data,                  -- System.Standard_Library
+     RE_Exception_Data_Ptr,              -- System.Standard_Library
+
+     RE_Integer_Address,                 -- System.Storage_Elements
+     RE_Storage_Offset,                  -- System.Storage_Elements
+     RE_Storage_Array,                   -- System.Storage_Elements
+     RE_To_Address,                      -- System.Storage_Elements
+
+     RE_Root_Storage_Pool,               -- System.Storage_Pools
+
+     RE_Thin_Pointer,                    -- System.Stream_Attributes
+     RE_Fat_Pointer,                     -- System.Stream_Attributes
+
+     RE_I_AD,                            -- System.Stream_Attributes
+     RE_I_AS,                            -- System.Stream_Attributes
+     RE_I_B,                             -- System.Stream_Attributes
+     RE_I_C,                             -- System.Stream_Attributes
+     RE_I_F,                             -- System.Stream_Attributes
+     RE_I_I,                             -- System.Stream_Attributes
+     RE_I_LF,                            -- System.Stream_Attributes
+     RE_I_LI,                            -- System.Stream_Attributes
+     RE_I_LLF,                           -- System.Stream_Attributes
+     RE_I_LLI,                           -- System.Stream_Attributes
+     RE_I_LLU,                           -- System.Stream_Attributes
+     RE_I_LU,                            -- System.Stream_Attributes
+     RE_I_SF,                            -- System.Stream_Attributes
+     RE_I_SI,                            -- System.Stream_Attributes
+     RE_I_SSI,                           -- System.Stream_Attributes
+     RE_I_SSU,                           -- System.Stream_Attributes
+     RE_I_SU,                            -- System.Stream_Attributes
+     RE_I_U,                             -- System.Stream_Attributes
+     RE_I_WC,                            -- System.Stream_Attributes
+
+     RE_W_AD,                            -- System.Stream_Attributes
+     RE_W_AS,                            -- System.Stream_Attributes
+     RE_W_B,                             -- System.Stream_Attributes
+     RE_W_C,                             -- System.Stream_Attributes
+     RE_W_F,                             -- System.Stream_Attributes
+     RE_W_I,                             -- System.Stream_Attributes
+     RE_W_LF,                            -- System.Stream_Attributes
+     RE_W_LI,                            -- System.Stream_Attributes
+     RE_W_LLF,                           -- System.Stream_Attributes
+     RE_W_LLI,                           -- System.Stream_Attributes
+     RE_W_LLU,                           -- System.Stream_Attributes
+     RE_W_LU,                            -- System.Stream_Attributes
+     RE_W_SF,                            -- System.Stream_Attributes
+     RE_W_SI,                            -- System.Stream_Attributes
+     RE_W_SSI,                           -- System.Stream_Attributes
+     RE_W_SSU,                           -- System.Stream_Attributes
+     RE_W_SU,                            -- System.Stream_Attributes
+     RE_W_U,                             -- System.Stream_Attributes
+     RE_W_WC,                            -- System.Stream_Attributes
+
+     RE_Str_Concat,                      -- System.String_Ops
+     RE_Str_Concat_CC,                   -- System.String_Ops
+     RE_Str_Concat_CS,                   -- System.String_Ops
+     RE_Str_Concat_SC,                   -- System.String_Ops
+     RE_Str_Equal,                       -- System.String_Ops
+     RE_Str_Normalize,                   -- System.String_Ops
+     RE_Wide_Str_Normalize,              -- System.String_Ops
+
+     RE_Str_Concat_3,                    -- System.String_Ops_Concat_3
+
+     RE_Str_Concat_4,                    -- System.String_Ops_Concat_4
+
+     RE_Str_Concat_5,                    -- System.String_Ops_Concat_5
+
+     RE_Free_Task_Image,                 -- System.Task_Info
+     RE_Task_Info_Type,                  -- System.Task_Info
+     RE_Task_Image_Type,                 -- System_Task_Info
+     RE_Unspecified_Task_Info,           -- System.Task_Info
+
+     RE_Library_Task_Level,              -- System.Tasking
+
+     RE_Task_Procedure_Access,           -- System.Tasking
+
+     RO_ST_Task_ID,                      -- System.Tasking
+
+     RE_Call_Modes,                      -- System.Tasking
+     RE_Simple_Call,                     -- System.Tasking
+     RE_Conditional_Call,                -- System.Tasking
+     RE_Asynchronous_Call,               -- System.Tasking
+     RE_Timed_Call,                      -- System.Tasking
+
+     RE_Task_List,                       -- System.Tasking
+
+     RE_Accept_Alternative,              -- System.Tasking
+     RE_Accept_List,                     -- System.Tasking
+     RE_Accept_List_Access,              -- System.Tasking
+     RE_Max_Select,                      -- System.Tasking
+     RE_Max_Task_Entry,                  -- System.Tasking
+     RE_No_Rendezvous,                   -- System.Tasking
+     RE_Null_Task_Entry,                 -- System.Tasking
+     RE_Positive_Select_Index,           -- System.Tasking
+     RE_Select_Index,                    -- System.Tasking
+     RE_Select_Modes,                    -- System.Tasking
+     RE_Else_Mode,                       -- System.Tasking
+     RE_Simple_Mode,                     -- System.Tasking
+     RE_Terminate_Mode,                  -- System.Tasking
+     RE_Delay_Mode,                      -- System.Tasking
+     RE_Task_Entry_Index,                -- System.Tasking
+     RE_Self,                            -- System.Tasking
+
+     RE_Master_Id,                       -- System.Tasking
+     RE_Unspecified_Priority,            -- System.Tasking
+
+     RE_Activation_Chain,                -- System.Tasking
+
+     RE_Abort_Defer,                     -- System.Soft_Links
+     RE_Abort_Undefer,                   -- System.Soft_Links
+     RE_Complete_Master,                 -- System.Soft_Links
+     RE_Current_Master,                  -- System.Soft_Links
+     RE_Enter_Master,                    -- System.Soft_Links
+     RE_Get_Current_Excep,               -- System.Soft_Links
+     RE_Get_GNAT_Exception,              -- System.Soft_Links
+     RE_Update_Exception,                -- System.Soft_Links
+
+     RE_Bits_1,                          -- System.Unsigned_Types
+     RE_Bits_2,                          -- System.Unsigned_Types
+     RE_Bits_4,                          -- System.Unsigned_Types
+     RE_Float_Unsigned,                  -- System.Unsigned_Types
+     RE_Long_Long_Unsigned,              -- System.Unsigned_Types
+     RE_Packed_Byte,                     -- System.Unsigned_Types
+     RE_Packed_Bytes1,                   -- System.Unsigned_Types
+     RE_Packed_Bytes2,                   -- System.Unsigned_Types
+     RE_Packed_Bytes4,                   -- System.Unsigned_Types
+     RE_Unsigned,                        -- System.Unsigned_Types
+
+     RE_Value_Boolean,                   -- System.Val_Bool
+
+     RE_Value_Character,                 -- System.Val_Char
+
+     RE_Value_Decimal,                   -- System.Val_Dec
+
+     RE_Value_Enumeration_8,             -- System.Val_Enum
+     RE_Value_Enumeration_16,            -- System.Val_Enum
+     RE_Value_Enumeration_32,            -- System.Val_Enum
+
+     RE_Value_Integer,                   -- System.Val_Int
+
+     RE_Value_Long_Long_Decimal,         -- System.Val_LLD
+
+     RE_Value_Long_Long_Integer,         -- System.Val_LLI
+
+     RE_Value_Long_Long_Unsigned,        -- System.Val_LLU
+
+     RE_Value_Real,                      -- System.Val_Real
+
+     RE_Value_Unsigned,                  -- System.Val_Uns
+
+     RE_Value_Wide_Character,            -- System.Val_WChar
+
+     RE_D,                               -- System.Vax_Float_Operations
+     RE_F,                               -- System.Vax_Float_Operations
+     RE_G,                               -- System.Vax_Float_Operations
+     RE_Q,                               -- System.Vax_Float_Operations
+     RE_S,                               -- System.Vax_Float_Operations
+     RE_T,                               -- System.Vax_Float_Operations
+
+     RE_D_To_G,                          -- System.Vax_Float_Operations
+     RE_F_To_G,                          -- System.Vax_Float_Operations
+     RE_F_To_Q,                          -- System.Vax_Float_Operations
+     RE_F_To_S,                          -- System.Vax_Float_Operations
+     RE_G_To_D,                          -- System.Vax_Float_Operations
+     RE_G_To_F,                          -- System.Vax_Float_Operations
+     RE_G_To_Q,                          -- System.Vax_Float_Operations
+     RE_G_To_T,                          -- System.Vax_Float_Operations
+     RE_Q_To_F,                          -- System.Vax_Float_Operations
+     RE_Q_To_G,                          -- System.Vax_Float_Operations
+     RE_S_To_F,                          -- System.Vax_Float_Operations
+     RE_T_To_D,                          -- System.Vax_Float_Operations
+     RE_T_To_G,                          -- System.Vax_Float_Operations
+
+     RE_Abs_F,                           -- System.Vax_Float_Operations
+     RE_Abs_G,                           -- System.Vax_Float_Operations
+     RE_Add_F,                           -- System.Vax_Float_Operations
+     RE_Add_G,                           -- System.Vax_Float_Operations
+     RE_Div_F,                           -- System.Vax_Float_Operations
+     RE_Div_G,                           -- System.Vax_Float_Operations
+     RE_Mul_F,                           -- System.Vax_Float_Operations
+     RE_Mul_G,                           -- System.Vax_Float_Operations
+     RE_Neg_F,                           -- System.Vax_Float_Operations
+     RE_Neg_G,                           -- System.Vax_Float_Operations
+     RE_Sub_F,                           -- System.Vax_Float_Operations
+     RE_Sub_G,                           -- System.Vax_Float_Operations
+
+     RE_Eq_F,                            -- System.Vax_Float_Operations
+     RE_Eq_G,                            -- System.Vax_Float_Operations
+     RE_Le_F,                            -- System.Vax_Float_Operations
+     RE_Le_G,                            -- System.Vax_Float_Operations
+     RE_Lt_F,                            -- System.Vax_Float_Operations
+     RE_Lt_G,                            -- System.Vax_Float_Operations
+
+     RE_Version_String,                  -- System.Version_Control
+     RE_Get_Version_String,              -- System.Version_Control
+
+     RE_Register_VMS_Exception,          -- System.VMS_Exception_Table
+
+     RE_String_To_Wide_String,           -- System.WCh_StW
+
+     RE_Wide_String_To_String,           -- System.WCh_WtS
+
+     RE_Wide_Width_Character,            -- System.WWd_Char
+
+     RE_Wide_Width_Enumeration_8,        -- System.WWd_Enum
+     RE_Wide_Width_Enumeration_16,       -- System.WWd_Enum
+     RE_Wide_Width_Enumeration_32,       -- System.WWd_Enum
+
+     RE_Wide_Width_Wide_Character,       -- System.WWd_Wchar
+
+     RE_Width_Boolean,                   -- System.Wid_Bool
+
+     RE_Width_Character,                 -- System.Wid_Char
+
+     RE_Width_Enumeration_8,             -- System.Wid_Enum
+     RE_Width_Enumeration_16,            -- System.Wid_Enum
+     RE_Width_Enumeration_32,            -- System.Wid_Enum
+
+     RE_Width_Long_Long_Integer,         -- System.Wid_LLI
+
+     RE_Width_Long_Long_Unsigned,        -- System.Wid_LLU
+
+     RE_Width_Wide_Character,            -- System.Wid_WChar
+
+     RE_Protected_Entry_Body_Array,      -- Tasking.Protected_Objects.Entries
+     RE_Protection_Entries,              -- Tasking.Protected_Objects.Entries
+     RE_Initialize_Protection_Entries,   -- Tasking.Protected_Objects.Entries
+     RE_Lock_Entries,                    -- Tasking.Protected_Objects.Entries
+     RE_Lock_Read_Only_Entries,          -- Tasking.Protected_Objects.Entries
+     RE_Unlock_Entries,                  -- Tasking.Protected_Objects.Entries
+     RE_Communication_Block,             -- Protected_Objects.Operations
+     RE_Protected_Entry_Call,            -- Protected_Objects.Operations
+     RE_Service_Entries,                 -- Protected_Objects.Operations
+     RE_Cancel_Protected_Entry_Call,     -- Protected_Objects.Operations
+     RE_Enqueued,                        -- Protected_Objects.Operations
+     RE_Cancelled,                       -- Protected_Objects.Operations
+     RE_Complete_Entry_Body,             -- Protected_Objects.Operations
+     RE_Exceptional_Complete_Entry_Body, -- Protected_Objects.Operations
+     RE_Requeue_Protected_Entry,         -- Protected_Objects.Operations
+     RE_Requeue_Task_To_Protected_Entry, -- Protected_Objects.Operations
+     RE_Protected_Count,                 -- Protected_Objects.Operations
+     RE_Protected_Entry_Caller,          -- Protected_Objects.Operations
+     RE_Timed_Protected_Entry_Call,      -- Protected_Objects.Operations
+
+     RE_Protection_Entry,                -- Protected_Objects.Single_Entry
+     RE_Initialize_Protection_Entry,     -- Protected_Objects.Single_Entry
+     RE_Lock_Entry,                      -- Protected_Objects.Single_Entry
+     RE_Lock_Read_Only_Entry,            -- Protected_Objects.Single_Entry
+     RE_Unlock_Entry,                    -- Protected_Objects.Single_Entry
+     RE_Protected_Single_Entry_Call,     -- Protected_Objects.Single_Entry
+     RE_Service_Entry,                   -- Protected_Objects.Single_Entry
+     RE_Complete_Single_Entry_Body,      -- Protected_Objects.Single_Entry
+     RE_Exceptional_Complete_Single_Entry_Body,
+     RE_Protected_Count_Entry,           -- Protected_Objects.Single_Entry
+     RE_Protected_Single_Entry_Caller,   -- Protected_Objects.Single_Entry
+     RE_Timed_Protected_Single_Entry_Call,
+
+     RE_Protected_Entry_Index,           -- System.Tasking.Protected_Objects
+     RE_Entry_Body,                      -- System.Tasking.Protected_Objects
+     RE_Protection,                      -- System.Tasking.Protected_Objects
+     RE_Initialize_Protection,           -- System.Tasking.Protected_Objects
+     RE_Finalize_Protection,             -- System.Tasking.Protected_Objects
+     RE_Lock,                            -- System.Tasking.Protected_Objects
+     RE_Lock_Read_Only,                  -- System.Tasking.Protected_Objects
+     RE_Unlock,                          -- System.Tasking.Protected_Objects
+
+     RE_Delay_Block,                     -- System.Tasking.Async_Delays
+     RE_Timed_Out,                       -- System.Tasking.Async_Delays
+     RE_Cancel_Async_Delay,              -- System.Tasking.Async_Delays
+     RE_Enqueue_Duration,                -- System.Tasking.Async_Delays
+     RE_Enqueue_Calendar,                -- System.Tasking.Async_Delays
+     RE_Enqueue_RT,                      -- System.Tasking.Async_Delays
+
+     RE_Accept_Call,                     -- System.Tasking.Rendezvous
+     RE_Accept_Trivial,                  -- System.Tasking.Rendezvous
+     RE_Callable,                        -- System.Tasking.Rendezvous
+     RE_Call_Simple,                     -- System.Tasking.Rendezvous
+     RE_Requeue_Task_Entry,              -- System.Tasking.Rendezvous
+     RE_Requeue_Protected_To_Task_Entry, -- System.Tasking.Rendezvous
+     RE_Cancel_Task_Entry_Call,          -- System.Tasking.Rendezvous
+     RE_Complete_Rendezvous,             -- System.Tasking.Rendezvous
+     RE_Task_Count,                      -- System.Tasking.Rendezvous
+     RE_Exceptional_Complete_Rendezvous, -- System.Tasking.Rendezvous
+     RE_Selective_Wait,                  -- System.Tasking.Rendezvous
+     RE_Task_Entry_Call,                 -- System.Tasking.Rendezvous
+     RE_Task_Entry_Caller,               -- System.Tasking.Rendezvous
+     RE_Timed_Task_Entry_Call,           -- System.Tasking.Rendezvous
+     RE_Timed_Selective_Wait,            -- System.Tasking.Rendezvous
+
+     RE_Activate_Restricted_Tasks,       -- System.Tasking.Restricted.Stages
+     RE_Complete_Restricted_Activation,  -- System.Tasking.Restricted.Stages
+     RE_Create_Restricted_Task,          -- System.Tasking.Restricted.Stages
+     RE_Complete_Restricted_Task,        -- System.Tasking.Restricted.Stages
+     RE_Restricted_Terminated,           -- System.Tasking.Restricted.Stages
+
+     RE_Abort_Tasks,                     -- System.Tasking.Stages
+     RE_Activate_Tasks,                  -- System.Tasking.Stages
+     RE_Complete_Activation,             -- System.Tasking.Stages
+     RE_Create_Task,                     -- System.Tasking.Stages
+     RE_Complete_Task,                   -- System.Tasking.Stages
+     RE_Free_Task,                       -- System.Tasking.Stages
+     RE_Expunge_Unactivated_Tasks,       -- System.Tasking.Stages
+     RE_Terminated);                     -- System.Tasking.Stages
+
+   --  The following declarations build a table that is indexed by the
+   --  RTE function to determine the unit containing the given entity.
+   --  This table is sorted in order of package names.
+
+   RE_Unit_Table : array (RE_Id) of RTU_Id := (
+
+     RE_Null                             => RTU_Null,
+
+     RE_Code_Loc                         => Ada_Exceptions,
+     RE_Current_Target_Exception         => Ada_Exceptions, -- of JGNAT
+     RE_Exception_Id                     => Ada_Exceptions,
+     RE_Exception_Information            => Ada_Exceptions,
+     RE_Exception_Message                => Ada_Exceptions,
+     RE_Exception_Name_Simple            => Ada_Exceptions,
+     RE_Exception_Occurrence             => Ada_Exceptions,
+     RE_Null_Id                          => Ada_Exceptions,
+     RE_Null_Occurrence                  => Ada_Exceptions,
+     RE_Poll                             => Ada_Exceptions,
+     RE_Raise_Exception                  => Ada_Exceptions,
+     RE_Raise_Exception_Always           => Ada_Exceptions,
+     RE_Reraise_Occurrence               => Ada_Exceptions,
+     RE_Reraise_Occurrence_Always        => Ada_Exceptions,
+     RE_Reraise_Occurrence_No_Defer      => Ada_Exceptions,
+     RE_Save_Occurrence                  => Ada_Exceptions,
+
+     RE_Simple_List_Controller           => Ada_Finalization_List_Controller,
+     RE_List_Controller                  => Ada_Finalization_List_Controller,
+
+     RE_Interrupt_Id                     => Ada_Interrupts,
+
+     RE_Root_Stream_Type                 => Ada_Streams,
+     RE_Stream_Element                   => Ada_Streams,
+     RE_Stream_Element_Offset            => Ada_Streams,
+     RE_Stream_Element_Array             => Ada_Streams,
+
+     RE_Stream_Access                    => Ada_Streams_Stream_IO,
+
+     RE_CW_Membership                    => Ada_Tags,
+     RE_DT_Entry_Size                    => Ada_Tags,
+     RE_DT_Prologue_Size                 => Ada_Tags,
+     RE_External_Tag                     => Ada_Tags,
+     RE_Get_Expanded_Name                => Ada_Tags,
+     RE_Get_External_Tag                 => Ada_Tags,
+     RE_Get_Prim_Op_Address              => Ada_Tags,
+     RE_Get_RC_Offset                    => Ada_Tags,
+     RE_Get_Remotely_Callable            => Ada_Tags,
+     RE_Get_TSD                          => Ada_Tags,
+     RE_Inherit_DT                       => Ada_Tags,
+     RE_Inherit_TSD                      => Ada_Tags,
+     RE_Internal_Tag                     => Ada_Tags,
+     RE_Register_Tag                     => Ada_Tags,
+     RE_Set_Expanded_Name                => Ada_Tags,
+     RE_Set_External_Tag                 => Ada_Tags,
+     RE_Set_Prim_Op_Address              => Ada_Tags,
+     RE_Set_RC_Offset                    => Ada_Tags,
+     RE_Set_Remotely_Callable            => Ada_Tags,
+     RE_Set_TSD                          => Ada_Tags,
+     RE_Tag_Error                        => Ada_Tags,
+     RE_TSD_Entry_Size                   => Ada_Tags,
+     RE_TSD_Prologue_Size                => Ada_Tags,
+     RE_Tag                              => Ada_Tags,
+     RE_Address_Array                    => Ada_Tags,
+
+     RE_Current_Task                     => Ada_Task_Identification,
+     RO_AT_Task_ID                       => Ada_Task_Identification,
+
+     RO_CA_Time                          => Ada_Calendar,
+     RO_CA_Delay_For                     => Ada_Calendar_Delays,
+     RO_CA_Delay_Until                   => Ada_Calendar_Delays,
+     RO_CA_To_Duration                   => Ada_Calendar_Delays,
+
+     RO_RT_Time                          => Ada_Real_Time,
+     RO_RT_Delay_Until                   => Ada_Real_Time_Delays,
+     RO_RT_To_Duration                   => Ada_Real_Time_Delays,
+
+     RE_Integer_64                       => Interfaces,
+     RE_Unsigned_8                       => Interfaces,
+     RE_Unsigned_16                      => Interfaces,
+     RE_Unsigned_32                      => Interfaces,
+     RE_Unsigned_64                      => Interfaces,
+
+     RE_Vtable_Ptr                       => Interfaces_CPP,
+     RE_Displaced_This                   => Interfaces_CPP,
+     RE_CPP_CW_Membership                => Interfaces_CPP,
+     RE_CPP_DT_Entry_Size                => Interfaces_CPP,
+     RE_CPP_DT_Prologue_Size             => Interfaces_CPP,
+     RE_CPP_Get_Expanded_Name            => Interfaces_CPP,
+     RE_CPP_Get_External_Tag             => Interfaces_CPP,
+     RE_CPP_Get_Prim_Op_Address          => Interfaces_CPP,
+     RE_CPP_Get_RC_Offset                => Interfaces_CPP,
+     RE_CPP_Get_Remotely_Callable        => Interfaces_CPP,
+     RE_CPP_Get_TSD                      => Interfaces_CPP,
+     RE_CPP_Inherit_DT                   => Interfaces_CPP,
+     RE_CPP_Inherit_TSD                  => Interfaces_CPP,
+     RE_CPP_Register_Tag                 => Interfaces_CPP,
+     RE_CPP_Set_Expanded_Name            => Interfaces_CPP,
+     RE_CPP_Set_External_Tag             => Interfaces_CPP,
+     RE_CPP_Set_Prim_Op_Address          => Interfaces_CPP,
+     RE_CPP_Set_RC_Offset                => Interfaces_CPP,
+     RE_CPP_Set_Remotely_Callable        => Interfaces_CPP,
+     RE_CPP_Set_TSD                      => Interfaces_CPP,
+     RE_CPP_TSD_Entry_Size               => Interfaces_CPP,
+     RE_CPP_TSD_Prologue_Size            => Interfaces_CPP,
+
+     RE_Packed_Size                      => Interfaces_Packed_Decimal,
+     RE_Packed_To_Int32                  => Interfaces_Packed_Decimal,
+     RE_Packed_To_Int64                  => Interfaces_Packed_Decimal,
+     RE_Int32_To_Packed                  => Interfaces_Packed_Decimal,
+     RE_Int64_To_Packed                  => Interfaces_Packed_Decimal,
+
+     RE_Address                          => System,
+     RE_Any_Priority                     => System,
+     RE_Bit_Order                        => System,
+     RE_Default_Priority                 => System,
+     RE_High_Order_First                 => System,
+     RE_Interrupt_Priority               => System,
+     RE_Lib_Stop                         => System,
+     RE_Low_Order_First                  => System,
+     RE_Max_Interrupt_Priority           => System,
+     RE_Max_Priority                     => System,
+     RE_Null_Address                     => System,
+     RE_Priority                         => System,
+
+     RE_Add_With_Ovflo_Check             => System_Arith_64,
+     RE_Double_Divide                    => System_Arith_64,
+     RE_Multiply_With_Ovflo_Check        => System_Arith_64,
+     RE_Scaled_Divide                    => System_Arith_64,
+     RE_Subtract_With_Ovflo_Check        => System_Arith_64,
+
+     RE_Create_AST_Handler               => System_AST_Handling,
+
+     RE_Raise_Assert_Failure             => System_Assertions,
+
+     RE_AST_Handler                      => System_Aux_DEC,
+     RE_Import_Value                     => System_Aux_DEC,
+     RE_No_AST_Handler                   => System_Aux_DEC,
+     RE_Type_Class                       => System_Aux_DEC,
+     RE_Type_Class_Enumeration           => System_Aux_DEC,
+     RE_Type_Class_Integer               => System_Aux_DEC,
+     RE_Type_Class_Fixed_Point           => System_Aux_DEC,
+     RE_Type_Class_Floating_Point        => System_Aux_DEC,
+     RE_Type_Class_Array                 => System_Aux_DEC,
+     RE_Type_Class_Record                => System_Aux_DEC,
+     RE_Type_Class_Access                => System_Aux_DEC,
+     RE_Type_Class_Task                  => System_Aux_DEC,
+     RE_Type_Class_Address               => System_Aux_DEC,
+
+     RE_Bit_And                          => System_Bit_Ops,
+     RE_Bit_Eq                           => System_Bit_Ops,
+     RE_Bit_Not                          => System_Bit_Ops,
+     RE_Bit_Or                           => System_Bit_Ops,
+     RE_Bit_Xor                          => System_Bit_Ops,
+
+     RE_Checked_Pool                     => System_Checked_Pools,
+
+     RE_Register_Exception               => System_Exception_Table,
+
+     RE_All_Others_Id                    => System_Exceptions,
+     RE_Handler_Record                   => System_Exceptions,
+     RE_Handler_Record_Ptr               => System_Exceptions,
+     RE_Others_Id                        => System_Exceptions,
+     RE_Subprogram_Descriptor            => System_Exceptions,
+     RE_Subprogram_Descriptor_0          => System_Exceptions,
+     RE_Subprogram_Descriptor_1          => System_Exceptions,
+     RE_Subprogram_Descriptor_2          => System_Exceptions,
+     RE_Subprogram_Descriptor_3          => System_Exceptions,
+     RE_Subprogram_Descriptor_List       => System_Exceptions,
+     RE_Subprogram_Descriptor_Ptr        => System_Exceptions,
+     RE_Subprogram_Descriptors_Record    => System_Exceptions,
+     RE_Subprogram_Descriptors_Ptr       => System_Exceptions,
+
+     RE_Exn_Float                        => System_Exn_Flt,
+
+     RE_Exn_Integer                      => System_Exn_Int,
+
+     RE_Exn_Long_Float                   => System_Exn_LFlt,
+
+     RE_Exn_Long_Integer                 => System_Exn_LInt,
+
+     RE_Exn_Long_Long_Float              => System_Exn_LLF,
+
+     RE_Exn_Long_Long_Integer            => System_Exn_LLI,
+
+     RE_Exn_Short_Float                  => System_Exn_SFlt,
+
+     RE_Exn_Short_Integer                => System_Exn_SInt,
+
+     RE_Exn_Short_Short_Integer          => System_Exn_SSI,
+
+     RE_Exp_Float                        => System_Exp_Flt,
+
+     RE_Exp_Integer                      => System_Exp_Int,
+
+     RE_Exp_Long_Float                   => System_Exp_LFlt,
+
+     RE_Exp_Long_Integer                 => System_Exp_LInt,
+
+     RE_Exp_Long_Long_Float              => System_Exp_LLF,
+
+     RE_Exp_Long_Long_Integer            => System_Exp_LLI,
+
+     RE_Exp_Long_Long_Unsigned           => System_Exp_LLU,
+
+     RE_Exp_Modular                      => System_Exp_Mod,
+
+     RE_Exp_Short_Float                  => System_Exp_SFlt,
+
+     RE_Exp_Short_Integer                => System_Exp_SInt,
+
+     RE_Exp_Short_Short_Integer          => System_Exp_SSI,
+
+     RE_Exp_Unsigned                     => System_Exp_Uns,
+
+     RE_Fat_Float                        => System_Fat_Flt,
+
+     RE_Fat_Long_Float                   => System_Fat_LFlt,
+
+     RE_Fat_Long_Long_Float              => System_Fat_LLF,
+
+     RE_Fat_Short_Float                  => System_Fat_SFlt,
+
+     RE_Attach_To_Final_List             => System_Finalization_Implementation,
+     RE_Finalize_List                    => System_Finalization_Implementation,
+     RE_Finalize_One                     => System_Finalization_Implementation,
+     RE_Global_Final_List                => System_Finalization_Implementation,
+     RE_Record_Controller                => System_Finalization_Implementation,
+     RE_Limited_Record_Controller        => System_Finalization_Implementation,
+     RE_Deep_Tag_Initialize              => System_Finalization_Implementation,
+     RE_Deep_Tag_Adjust                  => System_Finalization_Implementation,
+     RE_Deep_Tag_Finalize                => System_Finalization_Implementation,
+     RE_Deep_Tag_Attach                  => System_Finalization_Implementation,
+     RE_Deep_Rec_Initialize              => System_Finalization_Implementation,
+     RE_Deep_Rec_Adjust                  => System_Finalization_Implementation,
+     RE_Deep_Rec_Finalize                => System_Finalization_Implementation,
+
+     RE_Root_Controlled                  => System_Finalization_Root,
+     RE_Finalizable                      => System_Finalization_Root,
+     RE_Finalizable_Ptr                  => System_Finalization_Root,
+
+     RE_Fore                             => System_Fore,
+
+     RE_Image_Boolean                    => System_Img_Bool,
+
+     RE_Image_Character                  => System_Img_Char,
+
+     RE_Image_Decimal                    => System_Img_Dec,
+
+     RE_Image_Enumeration_8              => System_Img_Enum,
+     RE_Image_Enumeration_16             => System_Img_Enum,
+     RE_Image_Enumeration_32             => System_Img_Enum,
+
+     RE_Image_Integer                    => System_Img_Int,
+
+     RE_Image_Long_Long_Decimal          => System_Img_LLD,
+
+     RE_Image_Long_Long_Integer          => System_Img_LLI,
+
+     RE_Image_Long_Long_Unsigned         => System_Img_LLU,
+
+     RE_Image_Ordinary_Fixed_Point       => System_Img_Real,
+     RE_Image_Floating_Point             => System_Img_Real,
+
+     RE_Image_Unsigned                   => System_Img_Uns,
+
+     RE_Image_Wide_Character             => System_Img_WChar,
+
+     RE_Bind_Interrupt_To_Entry          => System_Interrupts,
+     RE_Default_Interrupt_Priority       => System_Interrupts,
+     RE_Dynamic_Interrupt_Protection     => System_Interrupts,
+     RE_Install_Handlers                 => System_Interrupts,
+     RE_Register_Interrupt_Handler       => System_Interrupts,
+     RE_Static_Interrupt_Protection      => System_Interrupts,
+
+     RE_Asm_Insn                         => System_Machine_Code,
+     RE_Asm_Input_Operand                => System_Machine_Code,
+     RE_Asm_Output_Operand               => System_Machine_Code,
+
+     RE_Mantissa_Value                   => System_Mantissa,
+
+     RE_Bits_03                          => System_Pack_03,
+     RE_Get_03                           => System_Pack_03,
+     RE_Set_03                           => System_Pack_03,
+
+     RE_Bits_05                          => System_Pack_05,
+     RE_Get_05                           => System_Pack_05,
+     RE_Set_05                           => System_Pack_05,
+
+     RE_Bits_06                          => System_Pack_06,
+     RE_Get_06                           => System_Pack_06,
+     RE_GetU_06                          => System_Pack_06,
+     RE_Set_06                           => System_Pack_06,
+     RE_SetU_06                          => System_Pack_06,
+
+     RE_Bits_07                          => System_Pack_07,
+     RE_Get_07                           => System_Pack_07,
+     RE_Set_07                           => System_Pack_07,
+
+     RE_Bits_09                          => System_Pack_09,
+     RE_Get_09                           => System_Pack_09,
+     RE_Set_09                           => System_Pack_09,
+
+     RE_Bits_10                          => System_Pack_10,
+     RE_Get_10                           => System_Pack_10,
+     RE_GetU_10                          => System_Pack_10,
+     RE_Set_10                           => System_Pack_10,
+     RE_SetU_10                          => System_Pack_10,
+
+     RE_Bits_11                          => System_Pack_11,
+     RE_Get_11                           => System_Pack_11,
+     RE_Set_11                           => System_Pack_11,
+
+     RE_Bits_12                          => System_Pack_12,
+     RE_Get_12                           => System_Pack_12,
+     RE_GetU_12                          => System_Pack_12,
+     RE_Set_12                           => System_Pack_12,
+     RE_SetU_12                          => System_Pack_12,
+
+     RE_Bits_13                          => System_Pack_13,
+     RE_Get_13                           => System_Pack_13,
+     RE_Set_13                           => System_Pack_13,
+
+     RE_Bits_14                          => System_Pack_14,
+     RE_Get_14                           => System_Pack_14,
+     RE_GetU_14                          => System_Pack_14,
+     RE_Set_14                           => System_Pack_14,
+     RE_SetU_14                          => System_Pack_14,
+
+     RE_Bits_15                          => System_Pack_15,
+     RE_Get_15                           => System_Pack_15,
+     RE_Set_15                           => System_Pack_15,
+
+     RE_Bits_17                          => System_Pack_17,
+     RE_Get_17                           => System_Pack_17,
+     RE_Set_17                           => System_Pack_17,
+
+     RE_Bits_18                          => System_Pack_18,
+     RE_Get_18                           => System_Pack_18,
+     RE_GetU_18                          => System_Pack_18,
+     RE_Set_18                           => System_Pack_18,
+     RE_SetU_18                          => System_Pack_18,
+
+     RE_Bits_19                          => System_Pack_19,
+     RE_Get_19                           => System_Pack_19,
+     RE_Set_19                           => System_Pack_19,
+
+     RE_Bits_20                          => System_Pack_20,
+     RE_Get_20                           => System_Pack_20,
+     RE_GetU_20                          => System_Pack_20,
+     RE_Set_20                           => System_Pack_20,
+     RE_SetU_20                          => System_Pack_20,
+
+     RE_Bits_21                          => System_Pack_21,
+     RE_Get_21                           => System_Pack_21,
+     RE_Set_21                           => System_Pack_21,
+
+     RE_Bits_22                          => System_Pack_22,
+     RE_Get_22                           => System_Pack_22,
+     RE_GetU_22                          => System_Pack_22,
+     RE_Set_22                           => System_Pack_22,
+     RE_SetU_22                          => System_Pack_22,
+
+     RE_Bits_23                          => System_Pack_23,
+     RE_Get_23                           => System_Pack_23,
+     RE_Set_23                           => System_Pack_23,
+
+     RE_Bits_24                          => System_Pack_24,
+     RE_Get_24                           => System_Pack_24,
+     RE_GetU_24                          => System_Pack_24,
+     RE_Set_24                           => System_Pack_24,
+     RE_SetU_24                          => System_Pack_24,
+
+     RE_Bits_25                          => System_Pack_25,
+     RE_Get_25                           => System_Pack_25,
+     RE_Set_25                           => System_Pack_25,
+
+     RE_Bits_26                          => System_Pack_26,
+     RE_Get_26                           => System_Pack_26,
+     RE_GetU_26                          => System_Pack_26,
+     RE_Set_26                           => System_Pack_26,
+     RE_SetU_26                          => System_Pack_26,
+
+     RE_Bits_27                          => System_Pack_27,
+     RE_Get_27                           => System_Pack_27,
+     RE_Set_27                           => System_Pack_27,
+
+     RE_Bits_28                          => System_Pack_28,
+     RE_Get_28                           => System_Pack_28,
+     RE_GetU_28                          => System_Pack_28,
+     RE_Set_28                           => System_Pack_28,
+     RE_SetU_28                          => System_Pack_28,
+
+     RE_Bits_29                          => System_Pack_29,
+     RE_Get_29                           => System_Pack_29,
+     RE_Set_29                           => System_Pack_29,
+
+     RE_Bits_30                          => System_Pack_30,
+     RE_Get_30                           => System_Pack_30,
+     RE_GetU_30                          => System_Pack_30,
+     RE_Set_30                           => System_Pack_30,
+     RE_SetU_30                          => System_Pack_30,
+
+     RE_Bits_31                          => System_Pack_31,
+     RE_Get_31                           => System_Pack_31,
+     RE_Set_31                           => System_Pack_31,
+
+     RE_Bits_33                          => System_Pack_33,
+     RE_Get_33                           => System_Pack_33,
+     RE_Set_33                           => System_Pack_33,
+
+     RE_Bits_34                          => System_Pack_34,
+     RE_Get_34                           => System_Pack_34,
+     RE_GetU_34                          => System_Pack_34,
+     RE_Set_34                           => System_Pack_34,
+     RE_SetU_34                          => System_Pack_34,
+
+     RE_Bits_35                          => System_Pack_35,
+     RE_Get_35                           => System_Pack_35,
+     RE_Set_35                           => System_Pack_35,
+
+     RE_Bits_36                          => System_Pack_36,
+     RE_Get_36                           => System_Pack_36,
+     RE_GetU_36                          => System_Pack_36,
+     RE_Set_36                           => System_Pack_36,
+     RE_SetU_36                          => System_Pack_36,
+
+     RE_Bits_37                          => System_Pack_37,
+     RE_Get_37                           => System_Pack_37,
+     RE_Set_37                           => System_Pack_37,
+
+     RE_Bits_38                          => System_Pack_38,
+     RE_Get_38                           => System_Pack_38,
+     RE_GetU_38                          => System_Pack_38,
+     RE_Set_38                           => System_Pack_38,
+     RE_SetU_38                          => System_Pack_38,
+
+     RE_Bits_39                          => System_Pack_39,
+     RE_Get_39                           => System_Pack_39,
+     RE_Set_39                           => System_Pack_39,
+
+     RE_Bits_40                          => System_Pack_40,
+     RE_Get_40                           => System_Pack_40,
+     RE_GetU_40                          => System_Pack_40,
+     RE_Set_40                           => System_Pack_40,
+     RE_SetU_40                          => System_Pack_40,
+
+     RE_Bits_41                          => System_Pack_41,
+     RE_Get_41                           => System_Pack_41,
+     RE_Set_41                           => System_Pack_41,
+
+     RE_Bits_42                          => System_Pack_42,
+     RE_Get_42                           => System_Pack_42,
+     RE_GetU_42                          => System_Pack_42,
+     RE_Set_42                           => System_Pack_42,
+     RE_SetU_42                          => System_Pack_42,
+
+     RE_Bits_43                          => System_Pack_43,
+     RE_Get_43                           => System_Pack_43,
+     RE_Set_43                           => System_Pack_43,
+
+     RE_Bits_44                          => System_Pack_44,
+     RE_Get_44                           => System_Pack_44,
+     RE_GetU_44                          => System_Pack_44,
+     RE_Set_44                           => System_Pack_44,
+     RE_SetU_44                          => System_Pack_44,
+
+     RE_Bits_45                          => System_Pack_45,
+     RE_Get_45                           => System_Pack_45,
+     RE_Set_45                           => System_Pack_45,
+
+     RE_Bits_46                          => System_Pack_46,
+     RE_Get_46                           => System_Pack_46,
+     RE_GetU_46                          => System_Pack_46,
+     RE_Set_46                           => System_Pack_46,
+     RE_SetU_46                          => System_Pack_46,
+
+     RE_Bits_47                          => System_Pack_47,
+     RE_Get_47                           => System_Pack_47,
+     RE_Set_47                           => System_Pack_47,
+
+     RE_Bits_48                          => System_Pack_48,
+     RE_Get_48                           => System_Pack_48,
+     RE_GetU_48                          => System_Pack_48,
+     RE_Set_48                           => System_Pack_48,
+     RE_SetU_48                          => System_Pack_48,
+
+     RE_Bits_49                          => System_Pack_49,
+     RE_Get_49                           => System_Pack_49,
+     RE_Set_49                           => System_Pack_49,
+
+     RE_Bits_50                          => System_Pack_50,
+     RE_Get_50                           => System_Pack_50,
+     RE_GetU_50                          => System_Pack_50,
+     RE_Set_50                           => System_Pack_50,
+     RE_SetU_50                          => System_Pack_50,
+
+     RE_Bits_51                          => System_Pack_51,
+     RE_Get_51                           => System_Pack_51,
+     RE_Set_51                           => System_Pack_51,
+
+     RE_Bits_52                          => System_Pack_52,
+     RE_Get_52                           => System_Pack_52,
+     RE_GetU_52                          => System_Pack_52,
+     RE_Set_52                           => System_Pack_52,
+     RE_SetU_52                          => System_Pack_52,
+
+     RE_Bits_53                          => System_Pack_53,
+     RE_Get_53                           => System_Pack_53,
+     RE_Set_53                           => System_Pack_53,
+
+     RE_Bits_54                          => System_Pack_54,
+     RE_Get_54                           => System_Pack_54,
+     RE_GetU_54                          => System_Pack_54,
+     RE_Set_54                           => System_Pack_54,
+     RE_SetU_54                          => System_Pack_54,
+
+     RE_Bits_55                          => System_Pack_55,
+     RE_Get_55                           => System_Pack_55,
+     RE_Set_55                           => System_Pack_55,
+
+     RE_Bits_56                          => System_Pack_56,
+     RE_Get_56                           => System_Pack_56,
+     RE_GetU_56                          => System_Pack_56,
+     RE_Set_56                           => System_Pack_56,
+     RE_SetU_56                          => System_Pack_56,
+
+     RE_Bits_57                          => System_Pack_57,
+     RE_Get_57                           => System_Pack_57,
+     RE_Set_57                           => System_Pack_57,
+
+     RE_Bits_58                          => System_Pack_58,
+     RE_Get_58                           => System_Pack_58,
+     RE_GetU_58                          => System_Pack_58,
+     RE_Set_58                           => System_Pack_58,
+     RE_SetU_58                          => System_Pack_58,
+
+     RE_Bits_59                          => System_Pack_59,
+     RE_Get_59                           => System_Pack_59,
+     RE_Set_59                           => System_Pack_59,
+
+     RE_Bits_60                          => System_Pack_60,
+     RE_Get_60                           => System_Pack_60,
+     RE_GetU_60                          => System_Pack_60,
+     RE_Set_60                           => System_Pack_60,
+     RE_SetU_60                          => System_Pack_60,
+
+     RE_Bits_61                          => System_Pack_61,
+     RE_Get_61                           => System_Pack_61,
+     RE_Set_61                           => System_Pack_61,
+
+     RE_Bits_62                          => System_Pack_62,
+     RE_Get_62                           => System_Pack_62,
+     RE_GetU_62                          => System_Pack_62,
+     RE_Set_62                           => System_Pack_62,
+     RE_SetU_62                          => System_Pack_62,
+
+     RE_Bits_63                          => System_Pack_63,
+     RE_Get_63                           => System_Pack_63,
+     RE_Set_63                           => System_Pack_63,
+
+     RE_Adjust_Storage_Size              => System_Parameters,
+     RE_Default_Stack_Size               => System_Parameters,
+     RE_Garbage_Collected                => System_Parameters,
+     RE_Size_Type                        => System_Parameters,
+     RE_Unspecified_Size                 => System_Parameters,
+
+     RE_Get_Active_Partition_Id          => System_Partition_Interface,
+     RE_Get_Passive_Partition_Id         => System_Partition_Interface,
+     RE_Get_Local_Partition_Id           => System_Partition_Interface,
+     RE_Get_RCI_Package_Receiver         => System_Partition_Interface,
+     RE_Get_Unique_Remote_Pointer        => System_Partition_Interface,
+     RE_RACW_Stub_Type                   => System_Partition_Interface,
+     RE_RACW_Stub_Type_Access            => System_Partition_Interface,
+     RE_Raise_Program_Error_For_E_4_18   => System_Partition_Interface,
+     RE_Raise_Program_Error_Unknown_Tag  => System_Partition_Interface,
+     RE_Register_Passive_Package         => System_Partition_Interface,
+     RE_Register_Receiving_Stub          => System_Partition_Interface,
+     RE_RCI_Info                         => System_Partition_Interface,
+     RE_Subprogram_Id                    => System_Partition_Interface,
+
+     RE_Global_Pool_Object               => System_Pool_Global,
+
+     RE_Unbounded_Reclaim_Pool           => System_Pool_Local,
+
+     RE_Stack_Bounded_Pool               => System_Pool_Size,
+
+     RE_Do_Apc                           => System_RPC,
+     RE_Do_Rpc                           => System_RPC,
+     RE_Params_Stream_Type               => System_RPC,
+     RE_Partition_ID                     => System_RPC,
+     RE_RPC_Receiver                     => System_RPC,
+
+     RE_IS_Is1                           => System_Scalar_Values,
+     RE_IS_Is2                           => System_Scalar_Values,
+     RE_IS_Is4                           => System_Scalar_Values,
+     RE_IS_Is8                           => System_Scalar_Values,
+     RE_IS_Iu1                           => System_Scalar_Values,
+     RE_IS_Iu2                           => System_Scalar_Values,
+     RE_IS_Iu4                           => System_Scalar_Values,
+     RE_IS_Iu8                           => System_Scalar_Values,
+     RE_IS_Isf                           => System_Scalar_Values,
+     RE_IS_Ifl                           => System_Scalar_Values,
+     RE_IS_Ilf                           => System_Scalar_Values,
+     RE_IS_Ill                           => System_Scalar_Values,
+
+     RE_Mark_Id                          => System_Secondary_Stack,
+     RE_SS_Allocate                      => System_Secondary_Stack,
+     RE_SS_Mark                          => System_Secondary_Stack,
+     RE_SS_Pool                          => System_Secondary_Stack,
+     RE_SS_Release                       => System_Secondary_Stack,
+
+     RE_Shared_Var_Close                 => System_Shared_Storage,
+     RE_Shared_Var_Lock                  => System_Shared_Storage,
+     RE_Shared_Var_ROpen                 => System_Shared_Storage,
+     RE_Shared_Var_Unlock                => System_Shared_Storage,
+     RE_Shared_Var_WOpen                 => System_Shared_Storage,
+
+     RE_Abort_Undefer_Direct             => System_Standard_Library,
+     RE_Exception_Data                   => System_Standard_Library,
+     RE_Exception_Data_Ptr               => System_Standard_Library,
+
+     RE_Integer_Address                  => System_Storage_Elements,
+     RE_Storage_Offset                   => System_Storage_Elements,
+     RE_Storage_Array                    => System_Storage_Elements,
+     RE_To_Address                       => System_Storage_Elements,
+
+     RE_Root_Storage_Pool                => System_Storage_Pools,
+
+     RE_Thin_Pointer                     => System_Stream_Attributes,
+     RE_Fat_Pointer                      => System_Stream_Attributes,
+
+     RE_I_AD                             => System_Stream_Attributes,
+     RE_I_AS                             => System_Stream_Attributes,
+     RE_I_B                              => System_Stream_Attributes,
+     RE_I_C                              => System_Stream_Attributes,
+     RE_I_F                              => System_Stream_Attributes,
+     RE_I_I                              => System_Stream_Attributes,
+     RE_I_LF                             => System_Stream_Attributes,
+     RE_I_LI                             => System_Stream_Attributes,
+     RE_I_LLF                            => System_Stream_Attributes,
+     RE_I_LLI                            => System_Stream_Attributes,
+     RE_I_LLU                            => System_Stream_Attributes,
+     RE_I_LU                             => System_Stream_Attributes,
+     RE_I_SF                             => System_Stream_Attributes,
+     RE_I_SI                             => System_Stream_Attributes,
+     RE_I_SSI                            => System_Stream_Attributes,
+     RE_I_SSU                            => System_Stream_Attributes,
+     RE_I_SU                             => System_Stream_Attributes,
+     RE_I_U                              => System_Stream_Attributes,
+     RE_I_WC                             => System_Stream_Attributes,
+
+     RE_W_AD                             => System_Stream_Attributes,
+     RE_W_AS                             => System_Stream_Attributes,
+     RE_W_B                              => System_Stream_Attributes,
+     RE_W_C                              => System_Stream_Attributes,
+     RE_W_F                              => System_Stream_Attributes,
+     RE_W_I                              => System_Stream_Attributes,
+     RE_W_LF                             => System_Stream_Attributes,
+     RE_W_LI                             => System_Stream_Attributes,
+     RE_W_LLF                            => System_Stream_Attributes,
+     RE_W_LLI                            => System_Stream_Attributes,
+     RE_W_LLU                            => System_Stream_Attributes,
+     RE_W_LU                             => System_Stream_Attributes,
+     RE_W_SF                             => System_Stream_Attributes,
+     RE_W_SI                             => System_Stream_Attributes,
+     RE_W_SSI                            => System_Stream_Attributes,
+     RE_W_SSU                            => System_Stream_Attributes,
+     RE_W_SU                             => System_Stream_Attributes,
+     RE_W_U                              => System_Stream_Attributes,
+     RE_W_WC                             => System_Stream_Attributes,
+
+     RE_Str_Concat                       => System_String_Ops,
+     RE_Str_Equal                        => System_String_Ops,
+     RE_Str_Normalize                    => System_String_Ops,
+     RE_Wide_Str_Normalize               => System_String_Ops,
+     RE_Str_Concat_CC                    => System_String_Ops,
+     RE_Str_Concat_CS                    => System_String_Ops,
+     RE_Str_Concat_SC                    => System_String_Ops,
+
+     RE_Str_Concat_3                     => System_String_Ops_Concat_3,
+
+     RE_Str_Concat_4                     => System_String_Ops_Concat_4,
+
+     RE_Str_Concat_5                     => System_String_Ops_Concat_5,
+
+     RE_Free_Task_Image                  => System_Task_Info,
+     RE_Task_Info_Type                   => System_Task_Info,
+     RE_Task_Image_Type                  => System_Task_Info,
+     RE_Unspecified_Task_Info            => System_Task_Info,
+
+     RE_Library_Task_Level               => System_Tasking,
+
+     RE_Task_Procedure_Access            => System_Tasking,
+
+     RO_ST_Task_ID                       => System_Tasking,
+
+     RE_Call_Modes                       => System_Tasking,
+     RE_Simple_Call                      => System_Tasking,
+     RE_Conditional_Call                 => System_Tasking,
+     RE_Asynchronous_Call                => System_Tasking,
+     RE_Timed_Call                       => System_Tasking,
+
+     RE_Task_List                        => System_Tasking,
+
+     RE_Accept_Alternative               => System_Tasking,
+     RE_Accept_List                      => System_Tasking,
+     RE_Accept_List_Access               => System_Tasking,
+     RE_Max_Select                       => System_Tasking,
+     RE_Max_Task_Entry                   => System_Tasking,
+     RE_No_Rendezvous                    => System_Tasking,
+     RE_Null_Task_Entry                  => System_Tasking,
+     RE_Positive_Select_Index            => System_Tasking,
+     RE_Select_Index                     => System_Tasking,
+     RE_Select_Modes                     => System_Tasking,
+     RE_Else_Mode                        => System_Tasking,
+     RE_Simple_Mode                      => System_Tasking,
+     RE_Terminate_Mode                   => System_Tasking,
+     RE_Delay_Mode                       => System_Tasking,
+     RE_Task_Entry_Index                 => System_Tasking,
+     RE_Self                             => System_Tasking,
+
+     RE_Master_Id                        => System_Tasking,
+     RE_Unspecified_Priority             => System_Tasking,
+
+     RE_Activation_Chain                 => System_Tasking,
+
+     RE_Abort_Defer                      => System_Soft_Links,
+     RE_Abort_Undefer                    => System_Soft_Links,
+     RE_Complete_Master                  => System_Soft_Links,
+     RE_Current_Master                   => System_Soft_Links,
+     RE_Enter_Master                     => System_Soft_Links,
+     RE_Get_Current_Excep                => System_Soft_Links,
+     RE_Get_GNAT_Exception               => System_Soft_Links,
+     RE_Update_Exception                 => System_Soft_Links,
+
+     RE_Bits_1                           => System_Unsigned_Types,
+     RE_Bits_2                           => System_Unsigned_Types,
+     RE_Bits_4                           => System_Unsigned_Types,
+     RE_Float_Unsigned                   => System_Unsigned_Types,
+     RE_Long_Long_Unsigned               => System_Unsigned_Types,
+     RE_Packed_Byte                      => System_Unsigned_Types,
+     RE_Packed_Bytes1                    => System_Unsigned_Types,
+     RE_Packed_Bytes2                    => System_Unsigned_Types,
+     RE_Packed_Bytes4                    => System_Unsigned_Types,
+     RE_Unsigned                         => System_Unsigned_Types,
+
+     RE_Value_Boolean                    => System_Val_Bool,
+
+     RE_Value_Character                  => System_Val_Char,
+
+     RE_Value_Decimal                    => System_Val_Dec,
+
+     RE_Value_Enumeration_8              => System_Val_Enum,
+     RE_Value_Enumeration_16             => System_Val_Enum,
+     RE_Value_Enumeration_32             => System_Val_Enum,
+
+     RE_Value_Integer                    => System_Val_Int,
+
+     RE_Value_Long_Long_Decimal          => System_Val_LLD,
+
+     RE_Value_Long_Long_Integer          => System_Val_LLI,
+
+     RE_Value_Long_Long_Unsigned         => System_Val_LLU,
+
+     RE_Value_Real                       => System_Val_Real,
+
+     RE_Value_Unsigned                   => System_Val_Uns,
+
+     RE_Value_Wide_Character             => System_Val_WChar,
+
+     RE_D                                => System_Vax_Float_Operations,
+     RE_F                                => System_Vax_Float_Operations,
+     RE_G                                => System_Vax_Float_Operations,
+     RE_Q                                => System_Vax_Float_Operations,
+     RE_S                                => System_Vax_Float_Operations,
+     RE_T                                => System_Vax_Float_Operations,
+
+     RE_D_To_G                           => System_Vax_Float_Operations,
+     RE_F_To_G                           => System_Vax_Float_Operations,
+     RE_F_To_Q                           => System_Vax_Float_Operations,
+     RE_F_To_S                           => System_Vax_Float_Operations,
+     RE_G_To_D                           => System_Vax_Float_Operations,
+     RE_G_To_F                           => System_Vax_Float_Operations,
+     RE_G_To_Q                           => System_Vax_Float_Operations,
+     RE_G_To_T                           => System_Vax_Float_Operations,
+     RE_Q_To_F                           => System_Vax_Float_Operations,
+     RE_Q_To_G                           => System_Vax_Float_Operations,
+     RE_S_To_F                           => System_Vax_Float_Operations,
+     RE_T_To_D                           => System_Vax_Float_Operations,
+     RE_T_To_G                           => System_Vax_Float_Operations,
+
+     RE_Abs_F                            => System_Vax_Float_Operations,
+     RE_Abs_G                            => System_Vax_Float_Operations,
+     RE_Add_F                            => System_Vax_Float_Operations,
+     RE_Add_G                            => System_Vax_Float_Operations,
+     RE_Div_F                            => System_Vax_Float_Operations,
+     RE_Div_G                            => System_Vax_Float_Operations,
+     RE_Mul_F                            => System_Vax_Float_Operations,
+     RE_Mul_G                            => System_Vax_Float_Operations,
+     RE_Neg_F                            => System_Vax_Float_Operations,
+     RE_Neg_G                            => System_Vax_Float_Operations,
+     RE_Sub_F                            => System_Vax_Float_Operations,
+     RE_Sub_G                            => System_Vax_Float_Operations,
+
+     RE_Eq_F                             => System_Vax_Float_Operations,
+     RE_Eq_G                             => System_Vax_Float_Operations,
+     RE_Le_F                             => System_Vax_Float_Operations,
+     RE_Le_G                             => System_Vax_Float_Operations,
+     RE_Lt_F                             => System_Vax_Float_Operations,
+     RE_Lt_G                             => System_Vax_Float_Operations,
+
+     RE_Version_String                   => System_Version_Control,
+     RE_Get_Version_String               => System_Version_Control,
+
+     RE_Register_VMS_Exception           => System_VMS_Exception_Table,
+
+     RE_String_To_Wide_String            => System_WCh_StW,
+
+     RE_Wide_String_To_String            => System_WCh_WtS,
+
+     RE_Wide_Width_Character             => System_WWd_Char,
+
+     RE_Wide_Width_Enumeration_8         => System_WWd_Enum,
+     RE_Wide_Width_Enumeration_16        => System_WWd_Enum,
+     RE_Wide_Width_Enumeration_32        => System_WWd_Enum,
+
+     RE_Wide_Width_Wide_Character        => System_WWd_Wchar,
+
+     RE_Width_Boolean                    => System_Wid_Bool,
+
+     RE_Width_Character                  => System_Wid_Char,
+
+     RE_Width_Enumeration_8              => System_Wid_Enum,
+     RE_Width_Enumeration_16             => System_Wid_Enum,
+     RE_Width_Enumeration_32             => System_Wid_Enum,
+
+     RE_Width_Long_Long_Integer          => System_Wid_LLI,
+
+     RE_Width_Long_Long_Unsigned         => System_Wid_LLU,
+
+     RE_Width_Wide_Character             => System_Wid_WChar,
+
+     RE_Protected_Entry_Body_Array       =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Protection_Entries               =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Initialize_Protection_Entries    =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Lock_Entries                     =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Lock_Read_Only_Entries           =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Unlock_Entries                   =>
+       System_Tasking_Protected_Objects_Entries,
+     RE_Communication_Block              =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Protected_Entry_Call             =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Service_Entries                  =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Cancel_Protected_Entry_Call      =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Enqueued                         =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Cancelled                        =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Complete_Entry_Body              =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Exceptional_Complete_Entry_Body  =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Requeue_Protected_Entry          =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Requeue_Task_To_Protected_Entry  =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Protected_Count                  =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Protected_Entry_Caller           =>
+       System_Tasking_Protected_Objects_Operations,
+     RE_Timed_Protected_Entry_Call       =>
+       System_Tasking_Protected_Objects_Operations,
+
+     RE_Protection_Entry                 =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Initialize_Protection_Entry      =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Lock_Entry                       =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Lock_Read_Only_Entry             =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Unlock_Entry                     =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Protected_Single_Entry_Call      =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Service_Entry                    =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Complete_Single_Entry_Body       =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Exceptional_Complete_Single_Entry_Body =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Protected_Count_Entry            =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Protected_Single_Entry_Caller    =>
+       System_Tasking_Protected_Objects_Single_Entry,
+     RE_Timed_Protected_Single_Entry_Call =>
+       System_Tasking_Protected_Objects_Single_Entry,
+
+     RE_Protected_Entry_Index            => System_Tasking_Protected_Objects,
+     RE_Entry_Body                       => System_Tasking_Protected_Objects,
+     RE_Protection                       => System_Tasking_Protected_Objects,
+     RE_Initialize_Protection            => System_Tasking_Protected_Objects,
+     RE_Finalize_Protection              => System_Tasking_Protected_Objects,
+     RE_Lock                             => System_Tasking_Protected_Objects,
+     RE_Lock_Read_Only                   => System_Tasking_Protected_Objects,
+     RE_Unlock                           => System_Tasking_Protected_Objects,
+
+     RE_Delay_Block                      => System_Tasking_Async_Delays,
+     RE_Timed_Out                        => System_Tasking_Async_Delays,
+     RE_Cancel_Async_Delay               => System_Tasking_Async_Delays,
+     RE_Enqueue_Duration                 => System_Tasking_Async_Delays,
+
+     RE_Enqueue_Calendar                 =>
+       System_Tasking_Async_Delays_Enqueue_Calendar,
+     RE_Enqueue_RT                       =>
+       System_Tasking_Async_Delays_Enqueue_RT,
+
+     RE_Accept_Call                      => System_Tasking_Rendezvous,
+     RE_Accept_Trivial                   => System_Tasking_Rendezvous,
+     RE_Callable                         => System_Tasking_Rendezvous,
+     RE_Call_Simple                      => System_Tasking_Rendezvous,
+     RE_Cancel_Task_Entry_Call           => System_Tasking_Rendezvous,
+     RE_Requeue_Task_Entry               => System_Tasking_Rendezvous,
+     RE_Requeue_Protected_To_Task_Entry  => System_Tasking_Rendezvous,
+     RE_Complete_Rendezvous              => System_Tasking_Rendezvous,
+     RE_Task_Count                       => System_Tasking_Rendezvous,
+     RE_Exceptional_Complete_Rendezvous  => System_Tasking_Rendezvous,
+     RE_Selective_Wait                   => System_Tasking_Rendezvous,
+     RE_Task_Entry_Call                  => System_Tasking_Rendezvous,
+     RE_Task_Entry_Caller                => System_Tasking_Rendezvous,
+     RE_Timed_Task_Entry_Call            => System_Tasking_Rendezvous,
+     RE_Timed_Selective_Wait             => System_Tasking_Rendezvous,
+
+     RE_Activate_Restricted_Tasks        => System_Tasking_Restricted_Stages,
+     RE_Complete_Restricted_Activation   => System_Tasking_Restricted_Stages,
+     RE_Create_Restricted_Task           => System_Tasking_Restricted_Stages,
+     RE_Complete_Restricted_Task         => System_Tasking_Restricted_Stages,
+     RE_Restricted_Terminated            => System_Tasking_Restricted_Stages,
+
+     RE_Abort_Tasks                      => System_Tasking_Stages,
+     RE_Activate_Tasks                   => System_Tasking_Stages,
+     RE_Complete_Activation              => System_Tasking_Stages,
+     RE_Create_Task                      => System_Tasking_Stages,
+     RE_Complete_Task                    => System_Tasking_Stages,
+     RE_Free_Task                        => System_Tasking_Stages,
+     RE_Expunge_Unactivated_Tasks        => System_Tasking_Stages,
+     RE_Terminated                       => System_Tasking_Stages);
+
+   -----------------
+   -- Subprograms --
+   -----------------
+
+   procedure Initialize;
+   --  Procedure to initialize data structures used by RTE. Called at the
+   --  start of processing a new main source file. Must be called after
+   --  Initialize_Snames (since names it enters into name table must come
+   --  after names entered by Snames).
+
+   function RTE (E : RE_Id) return Entity_Id;
+   --  Given the entity defined in the above tables, as identified by the
+   --  corresponding value in the RE_Id enumeration type, returns the Id
+   --  of the corresponding entity, first loading in (parsing, analyzing and
+   --  expanding) its spec if the unit has not already been loaded. If the
+   --  unit cannot be found, or if it does not contain the specified entity,
+   --  then an appropriate error message is output ("run-time configuration
+   --  error") and an Unrecoverable_Error exception is raised.
+
+   function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean;
+   --  This function determines if the given entity corresponds to the entity
+   --  referenced by RE_Id. It is similar in effect to (Ent = RTE (E)) except
+   --  that the latter would unconditionally load the unit containing E. For
+   --  this call, if the unit is not loaded, then a result of False is returned
+   --  immediately, since obviously Ent cannot be the entity in question if the
+   --  corresponding unit has not been loaded.
+
+   procedure Text_IO_Kludge (Nam : Node_Id);
+   --  In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
+   --  generic subpackages (e.g. Integer_IO). They really should be child
+   --  packages, and in GNAT, they *are* child packages. To maintain the
+   --  required compatibility, this routine is called for package renamings
+   --  and generic instantiations, with the simple name of the referenced
+   --  package. If Text_IO has been with'ed and if the simple name of Nam
+   --  matches one of the subpackages of Text_IO, then this subpackage is
+   --  with'ed automatically. The important result of this approach is that
+   --  Text_IO does not drag in all the code for the subpackages unless they
+   --  are used. Our test is a little crude, and could drag in stuff when it
+   --  is not necessary, but that doesn't matter. Wide_Text_IO is handled in
+   --  a similar manner.
+
+   function Is_Text_IO_Kludge_Unit (Nam : Node_Id) return Boolean;
+   --  Returns True if the given Nam is an Expanded Name, whose Prefix is
+   --  Ada, and whose selector is either Text_IO.xxx or Wide_Text_IO.xxx
+   --  where xxx is one of the subpackages of Text_IO that is specially
+   --  handled as described above for Text_IO_Kludge.
+
+end Rtsfind;